packages feed

ghc-lib 0.20200301 → 0.20200401

raw patch · 307 files changed

+34559/−33391 lines, 307 filesdep ~ghc-lib-parser

Dependency ranges changed: ghc-lib-parser

Files

compiler/GHC.hs view
@@ -311,35 +311,37 @@ import TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Iface.Load   ( loadSysInterface ) import TcRnTypes-import Predicate+import GHC.Core.Predicate import GHC.Driver.Packages-import NameSet-import RdrName+import GHC.Types.Name.Set+import GHC.Types.Name.Reader import GHC.Hs-import Type     hiding( typeKind )+import GHC.Core.Type  hiding( typeKind ) import TcType-import Id+import GHC.Types.Id import TysPrim          ( alphaTyVars )-import TyCon-import TyCoPpr          ( pprForAll )-import Class-import DataCon-import Name             hiding ( varName )-import Avail-import InstEnv-import FamInstEnv ( FamInst )-import SrcLoc+import GHC.Core.TyCon+import GHC.Core.TyCo.Ppr   ( pprForAll )+import GHC.Core.Class+import GHC.Core.DataCon+import GHC.Core.FVs        ( orphNamesOfFamInst )+import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )+import GHC.Core.InstEnv+import GHC.Types.Name      hiding ( varName )+import GHC.Types.Avail+import GHC.Types.SrcLoc import GHC.Core import GHC.Iface.Tidy-import GHC.Driver.Phases     ( Phase(..), isHaskellSrcFilename )+import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename ) import GHC.Driver.Finder import GHC.Driver.Types import GHC.Driver.CmdLine import GHC.Driver.Session hiding (WarnReason(..))+import GHC.Driver.Ways import SysTools import SysTools.BaseDir-import Annotations-import Module+import GHC.Types.Annotations+import GHC.Types.Module import Panic import GHC.Platform import Bag              ( listToBag )@@ -348,15 +350,13 @@ import Util import StringBuffer import Outputable-import BasicTypes+import GHC.Types.Basic import FastString import qualified Parser import Lexer import ApiAnnotation import qualified GHC.LanguageExtensions as LangExt-import NameEnv-import GHC.Core.FVs     ( orphNamesOfFamInst )-import FamInstEnv       ( famInstEnvElts )+import GHC.Types.Name.Env import TcRnDriver import Inst import FamInst@@ -365,6 +365,7 @@ import Data.Foldable import qualified Data.Map.Strict as Map import Data.Set (Set)+import qualified Data.Set as S import qualified Data.Sequence as Seq import Data.Maybe import Data.Time@@ -542,10 +543,10 @@  checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool checkBrokenTablesNextToCode' dflags-  | not (isARM arch)              = return False-  | WayDyn `notElem` ways dflags  = return False-  | not (tablesNextToCode dflags) = return False-  | otherwise                     = do+  | not (isARM arch)                 = return False+  | WayDyn `S.notMember` ways dflags = return False+  | not (tablesNextToCode dflags)    = return False+  | otherwise                        = do     linkerInfo <- liftIO $ getLinkerInfo dflags     case linkerInfo of       GnuLD _  -> return True@@ -605,22 +606,24 @@          let            prog = pgm_i dflags ++ flavour            flavour-             | WayProf `elem` ways dflags = "-prof"-             | WayDyn `elem` ways dflags  = "-dyn"-             | otherwise                  = ""+             | WayProf `S.member` ways dflags = "-prof"+             | WayDyn `S.member` ways dflags  = "-dyn"+             | otherwise                      = ""            msg = text "Starting " <> text prog          tr <- if verbosity dflags >= 3                 then return (logInfo dflags (defaultDumpStyle dflags) msg)                 else return (pure ())          let           conf = IServConfig-            { iservConfProgram = prog-            , iservConfOpts    = getOpts dflags opt_i-            , iservConfHook    = createIservProcessHook (hooks dflags)-            , iservConfTrace   = tr+            { iservConfProgram  = prog+            , iservConfOpts     = getOpts dflags opt_i+            , iservConfProfiled = gopt Opt_SccProfilingOn dflags+            , iservConfDynamic  = WayDyn `S.member` ways dflags+            , iservConfHook     = createIservProcessHook (hooks dflags)+            , iservConfTrace    = tr             }-         s <- liftIO $ newMVar (IServPending conf)-         return (Just (ExternalInterp (IServ s)))+         s <- liftIO $ newMVar IServPending+         return (Just (ExternalInterp conf (IServ s)))     else #if defined(HAVE_INTERNAL_INTERPRETER)       return (Just InternalInterp)
compiler/GHC/ByteCode/Asm.hs view
@@ -24,10 +24,10 @@ import GHC.Runtime.Interpreter  import GHC.Driver.Types-import Name-import NameSet-import Literal-import TyCon+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Literal+import GHC.Core.TyCon import FastString import GHC.StgToCmm.Layout     ( ArgRep(..) ) import GHC.Runtime.Heap.Layout@@ -35,8 +35,8 @@ import Outputable import GHC.Platform import Util-import Unique-import UniqDSet+import GHC.Types.Unique+import GHC.Types.Unique.DSet  -- From iserv import SizedSeq@@ -96,7 +96,7 @@   -> IO CompiledByteCode assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do   itblenv <- mkITbls hsc_env tycons-  bcos    <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos+  bcos    <- mapM (assembleBCO (targetPlatform (hsc_dflags hsc_env))) proto_bcos   (bcos',ptrs) <- mallocStrings hsc_env bcos   return CompiledByteCode     { bc_bcos = bcos'@@ -151,18 +151,18 @@  assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO assembleOneBCO hsc_env pbco = do-  ubco <- assembleBCO (hsc_dflags hsc_env) pbco+  ubco <- assembleBCO (targetPlatform (hsc_dflags hsc_env)) pbco   ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]   return ubco' -assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO-assembleBCO dflags (ProtoBCO { protoBCOName       = nm+assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO+assembleBCO platform (ProtoBCO { protoBCOName       = nm                              , protoBCOInstrs     = instrs                              , protoBCOBitmap     = bitmap                              , protoBCOBitmapSize = bsize                              , protoBCOArity      = arity }) = do   -- pass 1: collect up the offsets of the local labels.-  let asm = mapM_ (assembleI dflags) instrs+  let asm = mapM_ (assembleI platform) instrs        initial_offset = 0 @@ -174,9 +174,9 @@       -- and if the final size is indeed small enough for short jumps, we are       -- done.  Otherwise, we repeat the calculation, and we force all jumps in       -- this BCO to be long.-      (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm+      (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm       ((n_insns, lbl_map), long_jumps)-        | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)+        | isLarge n_insns0 = (inspectAsm platform True initial_offset asm, True)         | otherwise = ((n_insns0, lbl_map0), False)        env :: Word16 -> Word@@ -186,7 +186,7 @@    -- pass 2: run assembler and generate instructions, literals and pointers   let initial_state = (emptySS, emptySS, emptySS)-  (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm+  (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm    -- precomputed size should be equal to final size   ASSERT(n_insns == sizeSS final_insns) return ()@@ -265,8 +265,8 @@    LabelOp _ -> long_jumps -- LargeOp _ -> True -runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a-runAsm dflags long_jumps e = go+runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a+runAsm platform long_jumps e = go   where     go (NullAsm x) = return x     go (AllocPtr p_io k) = do@@ -289,8 +289,8 @@           words = concatMap expand ops           expand (SmallOp w) = [w]           expand (LabelOp w) = expand (Op (e w))-          expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]---        expand (LargeOp w) = largeArg dflags w+          expand (Op w) = if largeOps then largeArg platform w else [fromIntegral w]+--        expand (LargeOp w) = largeArg platform w       state $ \(st_i0,st_l0,st_p0) ->         let st_i1 = addListToSS st_i0 (opcode : words)         in ((), (st_i1,st_l0,st_p0))@@ -305,8 +305,8 @@   , lblEnv :: LabelEnvMap   } -inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)-inspectAsm dflags long_jumps initial_offset+inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)+inspectAsm platform long_jumps initial_offset   = go (InspectState initial_offset 0 0 Map.empty)   where     go s (NullAsm _) = (instrCount s, lblEnv s)@@ -323,8 +323,8 @@         largeOps = any (largeOp long_jumps) ops         count (SmallOp _) = 1         count (LabelOp _) = count (Op 0)-        count (Op _) = if largeOps then largeArg16s dflags else 1---      count (LargeOp _) = largeArg16s dflags+        count (Op _) = if largeOps then largeArg16s platform else 1+--      count (LargeOp _) = largeArg16s platform  -- Bring in all the bci_ bytecode constants. #include "rts/Bytecodes.h"@@ -332,26 +332,24 @@ largeArgInstr :: Word16 -> Word16 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci -largeArg :: DynFlags -> Word -> [Word16]-largeArg dflags w- | wORD_SIZE_IN_BITS dflags == 64-           = [fromIntegral (w `shiftR` 48),-              fromIntegral (w `shiftR` 32),-              fromIntegral (w `shiftR` 16),-              fromIntegral w]- | wORD_SIZE_IN_BITS dflags == 32-           = [fromIntegral (w `shiftR` 16),-              fromIntegral w]- | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"+largeArg :: Platform -> Word -> [Word16]+largeArg platform w = case platformWordSize platform of+   PW8 -> [fromIntegral (w `shiftR` 48),+           fromIntegral (w `shiftR` 32),+           fromIntegral (w `shiftR` 16),+           fromIntegral w]+   PW4 -> [fromIntegral (w `shiftR` 16),+           fromIntegral w] -largeArg16s :: DynFlags -> Word-largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4-                   | otherwise                      = 2+largeArg16s :: Platform -> Word+largeArg16s platform = case platformWordSize platform of+   PW8 -> 4+   PW4 -> 2 -assembleI :: DynFlags+assembleI :: Platform           -> BCInstr           -> Assembler ()-assembleI dflags i = case i of+assembleI platform i = case i of   STKCHECK n               -> emit bci_STKCHECK [Op n]   PUSH_L o1                -> emit bci_PUSH_L [SmallOp o1]   PUSH_LL o1 o2            -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]@@ -366,14 +364,14 @@                                  emit bci_PUSH_G [Op p]   PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)                                  emit bci_PUSH_G [Op p]-  PUSH_BCO proto           -> do let ul_bco = assembleBCO dflags proto+  PUSH_BCO proto           -> do let ul_bco = assembleBCO platform proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  emit bci_PUSH_G [Op p]-  PUSH_ALTS proto          -> do let ul_bco = assembleBCO dflags proto+  PUSH_ALTS proto          -> do let ul_bco = assembleBCO platform proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  emit bci_PUSH_ALTS [Op p]   PUSH_ALTS_UNLIFTED proto pk-                           -> do let ul_bco = assembleBCO dflags proto+                           -> do let ul_bco = assembleBCO platform proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  emit (push_alts pk) [Op p]   PUSH_PAD8                -> emit bci_PUSH_PAD8 []@@ -444,7 +442,7 @@    where     literal (LitLabel fs (Just sz) _)-     | platformOS (targetPlatform dflags) == OSMinGW32+     | platformOS platform == OSMinGW32          = litlabel (appendFS fs (mkFastString ('@':show sz)))      -- On Windows, stdcall labels have a suffix indicating the no. of      -- arg words, e.g. foo@8.  testcase: ffi012(ghci)@@ -470,9 +468,9 @@     litlabel fs = lit [BCONPtrLbl fs]     addr (RemotePtr a) = words [fromIntegral a]     float = words . mkLitF-    double = words . mkLitD dflags+    double = words . mkLitD platform     int = words . mkLitI-    int64 = words . mkLitI64 dflags+    int64 = words . mkLitI64 platform     words ws = lit (map BCONPtrWord ws)     word w = words [w] @@ -506,8 +504,8 @@ -- bit pattern is correct for the host's word size and endianness. mkLitI   ::             Int    -> [Word] mkLitF   ::             Float  -> [Word]-mkLitD   :: DynFlags -> Double -> [Word]-mkLitI64 :: DynFlags -> Int64  -> [Word]+mkLitD   :: Platform -> Double -> [Word]+mkLitI64 :: Platform -> Int64  -> [Word]  mkLitF f    = runST (do@@ -518,9 +516,8 @@         return [w0 :: Word]      ) -mkLitD dflags d-   | wORD_SIZE dflags == 4-   = runST (do+mkLitD platform d = case platformWordSize platform of+   PW4 -> runST (do         arr <- newArray_ ((0::Int),1)         writeArray arr 0 d         d_arr <- castSTUArray arr@@ -528,20 +525,16 @@         w1 <- readArray d_arr 1         return [w0 :: Word, w1]      )-   | wORD_SIZE dflags == 8-   = runST (do+   PW8 -> runST (do         arr <- newArray_ ((0::Int),0)         writeArray arr 0 d         d_arr <- castSTUArray arr         w0 <- readArray d_arr 0         return [w0 :: Word]      )-   | otherwise-   = panic "mkLitD: Bad wORD_SIZE" -mkLitI64 dflags ii-   | wORD_SIZE dflags == 4-   = runST (do+mkLitI64 platform ii = case platformWordSize platform of+   PW4 -> runST (do         arr <- newArray_ ((0::Int),1)         writeArray arr 0 ii         d_arr <- castSTUArray arr@@ -549,16 +542,13 @@         w1 <- readArray d_arr 1         return [w0 :: Word,w1]      )-   | wORD_SIZE dflags == 8-   = runST (do+   PW8 -> runST (do         arr <- newArray_ ((0::Int),0)         writeArray arr 0 ii         d_arr <- castSTUArray arr         w0 <- readArray d_arr 0         return [w0 :: Word]      )-   | otherwise-   = panic "mkLitI64: Bad wORD_SIZE"  mkLitI i = [fromIntegral i :: Word]
compiler/GHC/ByteCode/InfoTable.hs view
@@ -15,10 +15,10 @@ import GHC.Runtime.Interpreter import GHC.Driver.Session import GHC.Driver.Types-import Name             ( Name, getName )-import NameEnv-import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )-import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )+import GHC.Types.Name       ( Name, getName )+import GHC.Types.Name.Env+import GHC.Core.DataCon     ( DataCon, dataConRepArgTys, dataConIdentity )+import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import GHC.Types.RepType import GHC.StgToCmm.Layout  ( mkVirtConstrSizes ) import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )@@ -71,6 +71,8 @@           descr = dataConIdentity dcon -     r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really+         tables_next_to_code = tablesNextToCode dflags++     r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really                               conNo (tagForCon dflags dcon) descr)      return (getName dcon, ItblPtr r)
compiler/GHC/ByteCode/Instr.hs view
@@ -20,13 +20,13 @@ import GHC.Core.Ppr import Outputable import FastString-import Name-import Unique-import Id+import GHC.Types.Name+import GHC.Types.Unique+import GHC.Types.Id import GHC.Core-import Literal-import DataCon-import VarSet+import GHC.Types.Literal+import GHC.Core.DataCon+import GHC.Types.Var.Set import PrimOp import GHC.Runtime.Heap.Layout
compiler/GHC/ByteCode/Linker.hs view
@@ -28,10 +28,10 @@ import GHC.Runtime.Interpreter import GHC.ByteCode.Types import GHC.Driver.Types-import Name-import NameEnv+import GHC.Types.Name+import GHC.Types.Name.Env import PrimOp-import Module+import GHC.Types.Module import FastString import Panic import Outputable
compiler/GHC/Cmm/CallConv.hs view
@@ -43,6 +43,7 @@  assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)     where+      platform = targetPlatform dflags       regs = case (reps, conv) of                (_,   NativeNodeCall)   -> getRegsWithNode dflags                (_,   NativeDirectCall) -> getRegsWithoutNode dflags@@ -57,7 +58,7 @@       -- different type).  When returning an unboxed tuple, we also       -- separate the stack arguments by pointerhood.       (reg_assts, stk_args)  = assign_regs [] reps regs-      (stk_off,   stk_assts) = assignStack dflags off arg_ty stk_args+      (stk_off,   stk_assts) = assignStack platform off arg_ty stk_args       assignments = reg_assts ++ stk_assts        assign_regs assts []     _    = (assts, [])@@ -84,9 +85,9 @@                         _ -> (assts, (r:rs))               int = case (w, regs) of                       (W128, _) -> panic "W128 unsupported register type"-                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)+                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform)                           -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))-                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)+                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform)                           -> k (RegisterParam l, (vs, fs, ds, ls, ss))                       _   -> (assts, (r:rs))               k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'@@ -94,10 +95,10 @@               w  = typeWidth ty               gcp | isGcPtrType ty = VGcPtr                   | otherwise      = VNonGcPtr-              passFloatInXmm = passFloatArgsInXmm dflags+              passFloatInXmm = passFloatArgsInXmm platform -passFloatArgsInXmm :: DynFlags -> Bool-passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of+passFloatArgsInXmm :: Platform -> Bool+passFloatArgsInXmm platform = case platformArch platform of                               ArchX86_64 -> True                               ArchX86    -> False                               _          -> False@@ -109,12 +110,12 @@ passVectorInReg :: Width -> DynFlags -> Bool passVectorInReg _ _ = True -assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]+assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]             -> (                  ByteOff              -- bytes of stack args                , [(a, ParamLocation)] -- args and locations                )-assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)+assignStack platform offset arg_ty args = assign_stk offset [] (reverse args)  where       assign_stk offset assts [] = (offset, assts)       assign_stk offset assts (r:rs)@@ -123,7 +124,7 @@               off' = offset + size               -- Stack arguments always take a whole number of words, we never               -- pack them unlike constructor fields.-              size = roundUpToWords dflags (widthInBytes w)+              size = roundUpToWords platform (widthInBytes w)  ----------------------------------------------------------------------------- -- Local information about the registers available@@ -202,9 +203,10 @@ -- only use this functionality in hand-written C-- code in the RTS. realArgRegsCover :: DynFlags -> [GlobalReg] realArgRegsCover dflags-    | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++-                                  realLongRegs dflags ++-                                  map XmmReg (realXmmRegNos dflags)+    | passFloatArgsInXmm (targetPlatform dflags)+    = map ($VGcPtr) (realVanillaRegs dflags) +++      realLongRegs dflags +++      map XmmReg (realXmmRegNos dflags)     | otherwise                 = map ($VGcPtr) (realVanillaRegs dflags) ++                                   realFloatRegs dflags ++                                   realDoubleRegs dflags ++
compiler/GHC/Cmm/CommonBlockElim.hs view
@@ -25,8 +25,8 @@ import qualified Data.Map as M import Outputable import qualified TrieMap as TM-import UniqFM-import Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique import Control.Arrow (first, second)  -- -----------------------------------------------------------------------------
compiler/GHC/Cmm/Dataflow.hs view
@@ -37,7 +37,7 @@ import GhcPrelude  import GHC.Cmm-import UniqSupply+import GHC.Types.Unique.Supply  import Data.Array import Data.Maybe
compiler/GHC/Cmm/DebugBlock.hs view
@@ -27,16 +27,17 @@  import GhcPrelude +import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils import GHC.Core import FastString      ( nilFS, mkFastString )-import Module+import GHC.Types.Module import Outputable import GHC.Cmm.Ppr.Expr ( pprExpr )-import SrcLoc+import GHC.Types.SrcLoc import Util            ( seqList )  import GHC.Cmm.Dataflow.Block@@ -525,14 +526,14 @@ -- | Conversion of Cmm expressions to unwind expressions. We check for -- unsupported operator usages and simplify the expression as far as -- possible.-toUnwindExpr :: CmmExpr -> UnwindExpr-toUnwindExpr (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)-toUnwindExpr (CmmLit (CmmLabel l))       = UwLabel l-toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i-toUnwindExpr (CmmReg (CmmGlobal g))      = UwReg g 0-toUnwindExpr (CmmLoad e _)               = UwDeref (toUnwindExpr e)-toUnwindExpr e@(CmmMachOp op [e1, e2])   =-  case (op, toUnwindExpr e1, toUnwindExpr e2) of+toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr+toUnwindExpr _ (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)+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 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)     (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)     (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)@@ -543,6 +544,6 @@     (MO_Sub{}, u1,        u2       ) -> UwMinus u1 u2     (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2     _otherwise -> pprPanic "Unsupported operator in unwind expression!"-                           (pprExpr e)-toUnwindExpr e+                           (pprExpr platform e)+toUnwindExpr _ e   = pprPanic "Unsupported unwind expression!" (ppr e)
compiler/GHC/Cmm/Graph.hs view
@@ -33,10 +33,10 @@ import GHC.Cmm.Dataflow.Label import GHC.Driver.Session import FastString-import ForeignCall+import GHC.Types.ForeignCall import OrdList import GHC.Runtime.Heap.Layout (ByteOff)-import UniqSupply+import GHC.Types.Unique.Supply import Util import Panic @@ -310,15 +310,16 @@ copyIn dflags conv area formals extra_stk   = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))   where+    platform = targetPlatform dflags     -- See Note [Width of parameters]     ci (reg, RegisterParam r@(VanillaReg {})) =         let local = CmmLocal reg             global = CmmReg (CmmGlobal r)-            width = cmmRegWidth dflags local+            width = cmmRegWidth platform local             expr-                | width == wordWidth dflags = global-                | width < wordWidth dflags =-                    CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]+                | width == wordWidth platform = global+                | width < wordWidth platform =+                    CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global]                 | otherwise = panic "Parameter width greater than word width"          in CmmAssign local expr@@ -329,21 +330,21 @@      ci (reg, StackParam off)       | isBitsType $ localRegType reg-      , typeWidth (localRegType reg) < wordWidth dflags =+      , typeWidth (localRegType reg) < wordWidth platform =         let-          stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags))+          stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform))           local = CmmLocal reg-          width = cmmRegWidth dflags local-          expr  = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]+          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)          where ty = localRegType reg -    init_offset = widthInBytes (wordWidth dflags) -- infotable+    init_offset = widthInBytes (wordWidth platform) -- infotable -    (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk+    (stk_off, stk_args) = assignStack platform init_offset localRegType extra_stk      (stk_size, args) = assignArgumentsPos dflags stk_off conv                                           localRegType formals@@ -370,15 +371,16 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff   = (stk_size, regs, graph)   where+    platform = targetPlatform dflags     (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)      -- See Note [Width of parameters]     co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =-        let width = cmmExprWidth dflags v+        let width = cmmExprWidth platform v             value-                | width == wordWidth dflags = v-                | width < wordWidth dflags =-                    CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]+                | width == wordWidth platform = v+                | width < wordWidth platform =+                    CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v]                 | otherwise = panic "Parameter width greater than word width"          in (r:rs, mkAssign (CmmGlobal r) value <*> ms)@@ -391,11 +393,11 @@     co (v, StackParam off)  (rs, ms)       = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms) -    width v = cmmExprWidth dflags v+    width v = cmmExprWidth platform v     value v-      | isBitsType $ cmmExprType dflags v-      , width v < wordWidth dflags =-        CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v]+      | isBitsType $ cmmExprType platform v+      , width v < wordWidth platform =+        CmmMachOp (MO_XX_Conv (width v) (wordWidth platform)) [v]       | otherwise = v      (setRA, init_offset) =@@ -405,20 +407,20 @@                   case transfer of                      Call ->                        ([(CmmLit (CmmBlock id), StackParam init_offset)],-                       widthInBytes (wordWidth dflags))+                       widthInBytes (wordWidth platform))                      JumpRet ->                        ([],-                       widthInBytes (wordWidth dflags))+                       widthInBytes (wordWidth platform))                      _other ->                        ([], 0)             Old -> ([], updfr_off)      (extra_stack_off, stack_params) =-       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff+       assignStack platform init_offset (cmmExprType platform) extra_stack_stuff      args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it     (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv-                                          (cmmExprType dflags) actuals+                                          (cmmExprType platform) actuals   -- Note [Width of parameters]
compiler/GHC/Cmm/Info.hs view
@@ -49,7 +49,7 @@ import GHC.Driver.Session import ErrUtils (withTimingSilent) import Panic-import UniqSupply+import GHC.Types.Unique.Supply import MonadUtils import Util import Outputable@@ -194,7 +194,7 @@     -- (which in turn came from a handwritten .cmm file)    | StackRep frame <- smrep-  = do { (prof_lits, prof_data) <- mkProfLits dflags prof+  = do { (prof_lits, prof_data) <- mkProfLits platform prof        ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt        ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame        ; let@@ -207,7 +207,7 @@    | HeapRep _ ptrs nonptrs closure_type <- smrep   = do { let layout  = packIntsCLit dflags ptrs nonptrs-       ; (prof_lits, prof_data) <- mkProfLits dflags prof+       ; (prof_lits, prof_data) <- mkProfLits platform prof        ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt        ; (mb_srt_field, mb_layout, extra_bits, ct_data)                                 <- mk_pieces closure_type srt_label@@ -217,6 +217,7 @@                                        (mb_layout    `orElse` layout)        ; return (prof_data ++ ct_data, (std_info, extra_bits)) }   where+    platform = targetPlatform dflags     mk_pieces :: ClosureTypeInfo -> [CmmLit]               -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this                         , Maybe CmmLit  -- Override the layout field with this@@ -225,15 +226,15 @@     mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor       = do { (descr_lit, decl) <- newStringLit con_descr            ; return ( Just (CmmInt (fromIntegral con_tag)-                                   (halfWordWidth dflags))+                                   (halfWordWidth platform))                     , Nothing, [descr_lit], [decl]) }      mk_pieces Thunk srt_label       = return (Nothing, Nothing, srt_label, [])      mk_pieces (ThunkSelector offset) _no_srt-      = return (Just (CmmInt 0 (halfWordWidth dflags)),-                Just (mkWordCLit dflags (fromIntegral offset)), [], [])+      = return (Just (CmmInt 0 (halfWordWidth platform)),+                Just (mkWordCLit platform (fromIntegral offset)), [], [])          -- Layout known (one free var); we use the layout field for offset      mk_pieces (Fun arity (ArgSpec fun_type)) srt_label@@ -251,7 +252,7 @@       where         slow_entry = CmmLabel (toSlowEntryLbl info_lbl)         srt_lit = case srt_label of-                    []          -> mkIntCLit dflags 0+                    []          -> mkIntCLit platform 0                     (lit:_rest) -> ASSERT( null _rest ) lit      mk_pieces other _ = pprPanic "mk_pieces" (ppr other)@@ -260,8 +261,9 @@  packIntsCLit :: DynFlags -> Int -> Int -> CmmLit packIntsCLit dflags a b = packHalfWordsCLit dflags-                           (toStgHalfWord dflags (fromIntegral a))-                           (toStgHalfWord dflags (fromIntegral b))+                           (toStgHalfWord platform (fromIntegral a))+                           (toStgHalfWord platform (fromIntegral b))+                          where platform = targetPlatform dflags   mkSRTLit :: DynFlags@@ -271,9 +273,9 @@              CmmLit)      -- srt_bitmap mkSRTLit dflags info_lbl (Just lbl)   | inlineSRT dflags-  = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))-mkSRTLit dflags _ Nothing    = ([], CmmInt 0 (halfWordWidth dflags))-mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))+  = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth (targetPlatform dflags)))+mkSRTLit dflags _ Nothing    = ([], CmmInt 0 (halfWordWidth (targetPlatform dflags)))+mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth (targetPlatform dflags)))   -- | Is the SRT offset field inline in the info table on this platform?@@ -314,10 +316,10 @@  makeRelativeRefTo dflags info_lbl (CmmLabel lbl)   | tablesNextToCode dflags-  = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags)+  = CmmLabelDiffOff lbl info_lbl 0 (wordWidth (targetPlatform dflags)) makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)   | tablesNextToCode dflags-  = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)+  = CmmLabelDiffOff lbl info_lbl off (wordWidth (targetPlatform dflags)) makeRelativeRefTo _ _ lit = lit  @@ -347,29 +349,30 @@               --   2. Large bitmap CmmData if needed  mkLivenessBits dflags liveness-  | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word+  | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word   = do { uniq <- getUniqueM        ; let bitmap_lbl = mkBitmapLabel uniq        ; return (CmmLabel bitmap_lbl,                  [mkRODataLits bitmap_lbl lits]) }    | otherwise -- Fits in one word-  = return (mkStgWordCLit dflags bitmap_word, [])+  = return (mkStgWordCLit platform bitmap_word, [])   where+    platform = targetPlatform dflags     n_bits = length liveness      bitmap :: Bitmap-    bitmap = mkBitmap dflags liveness+    bitmap = mkBitmap platform liveness      small_bitmap = case bitmap of-                     []  -> toStgWord dflags 0+                     []  -> toStgWord platform 0                      [b] -> b                      _   -> panic "mkLiveness"-    bitmap_word = toStgWord dflags (fromIntegral n_bits)+    bitmap_word = toStgWord platform (fromIntegral n_bits)               .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) -    lits = mkWordCLit dflags (fromIntegral n_bits)-         : map (mkStgWordCLit dflags) bitmap+    lits = mkWordCLit platform (fromIntegral n_bits)+         : map (mkStgWordCLit platform) bitmap       -- The first word is the size.  The structure must match       -- StgLargeBitmap in includes/rts/storage/InfoTable.h @@ -402,11 +405,12 @@  ++ [layout_lit, tag, srt]   where+    platform = targetPlatform dflags     prof_info         | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]         | otherwise = [] -    tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)+    tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform)  ------------------------------------------------------------------------- --@@ -414,8 +418,8 @@ -- ------------------------------------------------------------------------- -mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])-mkProfLits dflags NoProfilingInfo       = return ((zeroCLit dflags, zeroCLit dflags), [])+mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])+mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), []) mkProfLits _ (ProfilingInfo td cd)   = do { (td_lit, td_decl) <- newStringLit td        ; (cd_lit, cd_decl) <- newStringLit cd@@ -430,8 +434,8 @@ -- Misc utils  -- | Value of the srt field of an info table when using an StgLargeSRT-srtEscape :: DynFlags -> StgHalfWord-srtEscape dflags = toStgHalfWord dflags (-1)+srtEscape :: Platform -> StgHalfWord+srtEscape platform = toStgHalfWord platform (-1)  ------------------------------------------------------------------------- --@@ -444,21 +448,22 @@ wordAligned :: DynFlags -> CmmExpr -> CmmExpr wordAligned dflags e   | gopt Opt_AlignmentSanitisation dflags-  = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]+  = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]   | otherwise   = e+  where platform = targetPlatform dflags  closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer and returns the info table pointer closureInfoPtr dflags e =-    CmmLoad (wordAligned dflags e) (bWord dflags)+    CmmLoad (wordAligned dflags e) (bWord (targetPlatform dflags))  entryCode :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns its entry code entryCode dflags e  | tablesNextToCode dflags = e- | otherwise               = CmmLoad e (bWord dflags)+ | otherwise               = CmmLoad e (bWord (targetPlatform dflags))  getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed*@@ -466,25 +471,28 @@ -- This lives in the SRT field of the info table -- (constructors don't need SRTs). getConstrTag dflags closure_ptr-  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]+  = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag dflags info_table]   where     info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)+    platform = targetPlatform dflags  cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the closure type -- obtained from the info table cmmGetClosureType dflags closure_ptr-  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]+  = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType dflags info_table]   where     info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)+    platform = targetPlatform dflags  infoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) infoTable dflags info_ptr-  | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)-  | otherwise               = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer+  | tablesNextToCode dflags = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags)+  | otherwise               = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer+  where platform = targetPlatform dflags  infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag@@ -495,21 +503,25 @@ -- Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table infoTableSrtBitmap dflags info_tbl-  = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)+  = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord platform)+    where platform = targetPlatform dflags  infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. infoTableClosureType dflags info_tbl-  = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)+  = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset dflags)) (bHalfWord platform)+    where platform = targetPlatform dflags  infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr infoTablePtrs dflags info_tbl-  = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)+  = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset dflags)) (bHalfWord platform)+    where platform = targetPlatform dflags  infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr infoTableNonPtrs dflags info_tbl-  = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)+  = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset dflags)) (bHalfWord platform)+    where platform = targetPlatform dflags  funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes the info pointer of a function,@@ -517,16 +529,19 @@ -- in the info table. funInfoTable dflags info_ptr   | tablesNextToCode dflags-  = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)+  = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)   | otherwise-  = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)-                                -- Past the entry code pointer+  = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW dflags)+                                  -- Past the entry code pointer+  where+    platform = targetPlatform dflags  -- Takes the info pointer of a function, returns the function's arity funInfoArity :: DynFlags -> CmmExpr -> CmmExpr funInfoArity dflags iptr-  = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))+  = cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes))   where+   platform = targetPlatform dflags    fun_info = funInfoTable dflags iptr    rep = cmmBits (widthFromBytes rep_bytes) @@ -572,20 +587,27 @@   + 1 {- srt label -}  stdInfoTableSizeB  :: DynFlags -> ByteOff-stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * platformWordSizeInBytes platform+   where platform = targetPlatform dflags  stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize dflags+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize platform+   where platform = targetPlatform dflags  stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word-stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - platformWordSizeInBytes platform+   where platform = targetPlatform dflags  stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff-stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags-stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + halfWordSize dflags+stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform+   where platform = targetPlatform dflags +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform + halfWordSize platform+   where platform = targetPlatform dflags+ conInfoTableSizeB :: DynFlags -> Int-conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags+conInfoTableSizeB dflags = stdInfoTableSizeB dflags + platformWordSizeInBytes platform+   where platform = targetPlatform dflags
compiler/GHC/Cmm/Info/Build.hs view
@@ -10,15 +10,15 @@  import GhcPrelude hiding (succ) -import Id-import IdInfo+import GHC.Types.Id+import GHC.Types.Id.Info import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow-import Module+import GHC.Types.Module import GHC.Platform import Digraph import GHC.Cmm.CLabel@@ -28,8 +28,8 @@ import Maybes import Outputable import GHC.Runtime.Heap.Layout-import UniqSupply-import CostCentre+import GHC.Types.Unique.Supply+import GHC.Types.CostCentre import GHC.StgToCmm.Heap  import Control.Monad@@ -41,7 +41,7 @@ import Control.Monad.Trans.Class import Data.List (unzip4) -import NameSet+import GHC.Types.Name.Set  {- Note [SRTs] @@ -1086,12 +1086,13 @@   id <- getUniqueM   let     lbl = mkSRTLabel id+    platform = targetPlatform dflags     srt_n_info = mkSRTInfoLabel (length refs)     fields =       mkStaticClosure dflags srt_n_info dontCareCCS         [ CmmLabel lbl | SRTEntry lbl <- refs ]         [] -- no padding-        [mkIntCLit dflags 0] -- link field+        [mkIntCLit platform 0] -- link field         [] -- no saved info   return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
compiler/GHC/Cmm/LayoutStack.hs view
@@ -8,14 +8,14 @@ import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs, newTemp  ) -- XXX layering violation import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation -import BasicTypes+import GHC.Types.Basic import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm.Utils import GHC.Cmm.Graph-import ForeignCall+import GHC.Types.ForeignCall import GHC.Cmm.Liveness import GHC.Cmm.ProcPoint import GHC.Runtime.Heap.Layout@@ -24,11 +24,12 @@ import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label-import UniqSupply+import GHC.Types.Unique.Supply import Maybes-import UniqFM+import GHC.Types.Unique.FM import Util +import GHC.Platform import GHC.Driver.Session import FastString import Outputable hiding ( isEmpty )@@ -459,7 +460,7 @@        return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off      CmmForeignCall{ succ = cont_lbl, .. } -> do-       return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off+       return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off             -- one word of args: the return address      CmmBranch {}     ->  handleBranches@@ -467,6 +468,7 @@     CmmSwitch {}     ->  handleBranches    where+     platform = targetPlatform dflags      -- Calls and ForeignCalls are handled the same way:      lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff               -> ( [CmmNode O O]@@ -495,7 +497,7 @@        = (save_assignments, new_cont_stack)        where         (new_cont_stack, save_assignments)-           = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0+           = setupStackFrame platform lbl liveness cml_ret_off cml_ret_args stack0        -- For other last nodes (branches), if any of the targets is a@@ -518,7 +520,7 @@              out = mapFromList [ (l', cont_stack)                                | l' <- successors last ]          return ( assigs-                , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)+                , spOffsetForCall sp0 cont_stack (platformWordSizeInBytes platform)                 , last                 , []                 , out)@@ -552,7 +554,7 @@         = do              let cont_args = mapFindWithDefault 0 l cont_info                  (stack2, assigs) =-                      setupStackFrame dflags l liveness (sm_ret_off stack0)+                      setupStackFrame platform l liveness (sm_ret_off stack0)                                                         cont_args stack0              (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs              return (l, tmp_lbl, stack2, block)@@ -609,7 +611,7 @@   setupStackFrame-             :: DynFlags+             :: Platform              -> BlockId                 -- label of continuation              -> LabelMap CmmLocalLive   -- liveness              -> ByteOff      -- updfr@@ -617,7 +619,7 @@              -> StackMap     -- current StackMap              -> (StackMap, [CmmNode O O]) -setupStackFrame dflags lbl liveness updfr_off ret_args stack0+setupStackFrame platform lbl liveness updfr_off ret_args stack0   = (cont_stack, assignments)   where       -- get the set of LocalRegs live in the continuation@@ -633,7 +635,7 @@        -- everything up to updfr_off is off-limits       -- stack1 contains updfr_off, plus everything we need to save-      (stack1, assignments) = allocate dflags updfr_off live stack0+      (stack1, assignments) = allocate platform updfr_off live stack0        -- And the Sp at the continuation is:       --   sm_sp stack1 + ret_args@@ -714,9 +716,9 @@ -- on the stack and return the new StackMap and the assignments to do -- the saving. ---allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap+allocate :: Platform -> ByteOff -> LocalRegSet -> StackMap          -> (StackMap, [CmmNode O O])-allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0+allocate platform ret_off live stackmap@StackMap{ sm_sp = sp0                                               , sm_regs = regs0 }  =    -- we only have to save regs that are not already in a slot@@ -726,38 +728,38 @@     -- make a map of the stack    let stack = reverse $ Array.elems $-               accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $+               accumArray (\_ x -> x) Empty (1, toWords platform (max sp0 ret_off)) $                  ret_words ++ live_words             where ret_words =                    [ (x, Occupied)-                   | x <- [ 1 .. toWords dflags ret_off] ]+                   | x <- [ 1 .. toWords platform ret_off] ]                   live_words =-                   [ (toWords dflags x, Occupied)+                   [ (toWords platform x, Occupied)                    | (r,off) <- nonDetEltsUFM regs1,                    -- See Note [Unique Determinism and code generation]-                     let w = localRegBytes dflags r,-                     x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]+                     let w = localRegBytes platform r,+                     x <- [ off, off - platformWordSizeInBytes platform .. off - w + 1] ]    in     -- Pass over the stack: find slots to save all the new live variables,    -- choosing the oldest slots first (hence a foldr).    let        save slot ([], stack, n, assigs, regs) -- no more regs to save-          = ([], slot:stack, plusW dflags n 1, assigs, regs)+          = ([], slot:stack, plusW platform n 1, assigs, regs)        save slot (to_save, stack, n, assigs, regs)           = case slot of-               Occupied ->  (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)+               Occupied ->  (to_save, Occupied:stack, plusW platform n 1, assigs, regs)                Empty                  | Just (stack', r, to_save') <-                        select_save to_save (slot:stack)                  -> let assig = CmmStore (CmmStackSlot Old n')                                          (CmmReg (CmmLocal r))-                        n' = plusW dflags n 1+                        n' = plusW platform n 1                    in                         (to_save', stack', n', assig : assigs, (r,(r,n')):regs)                   | otherwise-                 -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)+                 -> (to_save, slot:stack, plusW platform n 1, assigs, regs)         -- we should do better here: right now we'll fit the smallest first,        -- but it would make more sense to fit the biggest first.@@ -770,7 +772,7 @@                  = Just (replicate words Occupied ++ rest, r, rs++no_fit)                  | otherwise                  = go rs (r:no_fit)-                 where words = localRegWords dflags r+                 where words = localRegWords platform r         -- fill in empty slots as much as possible        (still_to_save, save_stack, n, save_assigs, save_regs)@@ -783,14 +785,14 @@               push r (n, assigs, regs)                 = (n', assig : assigs, (r,(r,n')) : regs)                 where-                  n' = n + localRegBytes dflags r+                  n' = n + localRegBytes platform r                   assig = CmmStore (CmmStackSlot Old n')                                    (CmmReg (CmmLocal r))         trim_sp           | not (null push_regs) = push_sp           | otherwise-          = plusW dflags n (- length (takeWhile isEmpty save_stack))+          = plusW platform n (- length (takeWhile isEmpty save_stack))         final_regs = regs1 `addListToUFM` push_regs                           `addListToUFM` save_regs@@ -799,7 +801,7 @@   -- XXX should be an assert    if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else -   if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else+   if (trim_sp .&. (platformWordSizeInBytes platform - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else     ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }    , push_assigs ++ save_assigs )@@ -838,10 +840,11 @@   = final_block : fixup_blocks'   where     area_off = getAreaOff stackmaps+    platform = targetPlatform dflags      adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x-    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)-    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)+    adj_pre_sp  = mapExpDeep (areaToSp platform sp0            sp_high area_off)+    adj_post_sp = mapExpDeep (areaToSp platform (sp0 - sp_off) sp_high area_off)      final_middle = maybeAddSpAdj dflags sp0 sp_off                  . blockFromList@@ -867,9 +870,10 @@ maybeAddSpAdj dflags sp0 sp_off block =   add_initial_unwind $ add_adj_unwind $ adj block   where+    platform = targetPlatform dflags     adj block       | sp_off /= 0-      = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)+      = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off)       | otherwise = block     -- Add unwind pseudo-instruction at the beginning of each block to     -- document Sp level for debugging@@ -878,7 +882,7 @@       = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block       | otherwise       = block-      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)+      where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform)      -- Add unwind pseudo-instruction right after the Sp adjustment     -- if there is one.@@ -888,7 +892,7 @@       = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]       | otherwise       = block-      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)+      where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off)  {- Note [SP old/young offsets] @@ -908,23 +912,23 @@    to be Sp + Sp(L) - Sp(L') -} -areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr+areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr -areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)-  = cmmOffset dflags spExpr (sp_old - area_off area - n)+areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n)+  = cmmOffset platform spExpr (sp_old - area_off area - n)     -- Replace (CmmStackSlot area n) with an offset from Sp -areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)-  = mkIntExpr dflags sp_hwm+areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark)+  = mkIntExpr platform sp_hwm     -- Replace CmmHighStackMark with the number of bytes of stack used,     -- the sp_hwm.   See Note [Stack usage] in GHC.StgToCmm.Heap -areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)+areaToSp platform _ _ _ (CmmMachOp (MO_U_Lt _) args)   | falseStackCheck args-  = zeroExpr dflags-areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)+  = zeroExpr platform+areaToSp platform _ _ _ (CmmMachOp (MO_U_Ge _) args)   | falseStackCheck args-  = mkIntExpr dflags 1+  = mkIntExpr platform 1     -- Replace a stack-overflow test that cannot fail with a no-op     -- See Note [Always false stack check] @@ -1004,8 +1008,8 @@ -- Update info tables to include stack liveness  -setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl-setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)+setInfoTableStackMap :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl+setInfoTableStackMap platform stackmaps (CmmProc top_info@TopInfo{..} l v g)   = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g   where     fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =@@ -1016,18 +1020,18 @@     get_liveness lbl       = case mapLookup lbl stackmaps of           Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)-          Just sm -> stackMapToLiveness dflags sm+          Just sm -> stackMapToLiveness platform sm  setInfoTableStackMap _ _ d = d  -stackMapToLiveness :: DynFlags -> StackMap -> Liveness-stackMapToLiveness dflags StackMap{..} =+stackMapToLiveness :: Platform -> StackMap -> Liveness+stackMapToLiveness platform StackMap{..} =    reverse $ Array.elems $-        accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,-                                     toWords dflags (sm_sp - sm_args)) live_words+        accumArray (\_ x -> x) True (toWords platform sm_ret_off + 1,+                                     toWords platform (sm_sp - sm_args)) live_words    where-     live_words =  [ (toWords dflags off, False)+     live_words =  [ (toWords platform off, False)                    | (r,off) <- nonDetEltsUFM sm_regs                    , isGcPtrType (localRegType r) ]                    -- See Note [Unique Determinism and code generation]@@ -1050,6 +1054,7 @@     rewriteCC :: RewriteFun CmmLocalLive     rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do         let entry_label = entryLabel e_node+            platform = targetPlatform dflags             stackmap = case mapLookup entry_label final_stackmaps of                 Just sm -> sm                 Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"@@ -1066,7 +1071,7 @@             -- to a proc point.             (middle1, live_with_reloads)                 | entry_label `setMember` procpoints-                = let reloads = insertReloads dflags stackmap live_at_middle0+                = let reloads = insertReloads platform stackmap live_at_middle0                   in (foldr blockCons middle0 reloads, emptyRegSet)                 | otherwise                 = (middle0, live_at_middle0)@@ -1076,12 +1081,12 @@          return (BlockCC e_node middle1 x_node, fact_base2) -insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]-insertReloads dflags stackmap live =+insertReloads :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]+insertReloads platform stackmap live =      [ CmmAssign (CmmLocal reg)                  -- This cmmOffset basically corresponds to manifesting                  -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]-                 (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))+                 (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off))                           (localRegType reg))      | (reg, reg_off) <- stackSlotRegs stackmap      , reg `elemRegSet` live@@ -1131,16 +1136,17 @@ lowerSafeForeignCall dflags block   | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block   = do+    let platform = targetPlatform dflags     -- Both 'id' and 'new_base' are KindNonPtr because they're     -- RTS-only objects and are not subject to garbage collection-    id <- newTemp (bWord dflags)-    new_base <- newTemp (cmmRegType dflags baseReg)+    id <- newTemp (bWord platform)+    new_base <- newTemp (cmmRegType platform baseReg)     let (caller_save, caller_load) = callerSaveVolatileRegs dflags     save_state_code <- saveThreadState dflags     load_state_code <- loadThreadState dflags     let suspend = save_state_code  <*>                   caller_save <*>-                  mkMiddle (callSuspendThread dflags id intrbl)+                  mkMiddle (callSuspendThread platform id intrbl)         midCall = mkUnsafeCall tgt res args         resume  = mkMiddle (callResumeThread new_base id) <*>                   -- Assign the result to BaseReg: we@@ -1160,10 +1166,10 @@         -- different.  Hence we continue by jumping to the top stack frame,         -- not by jumping to succ.         jump = CmmCall { cml_target    = entryCode dflags $-                                         CmmLoad spExpr (bWord dflags)+                                         CmmLoad spExpr (bWord platform)                        , cml_cont      = Just succ                        , cml_args_regs = regs-                       , cml_args      = widthInBytes (wordWidth dflags)+                       , cml_args      = widthInBytes (wordWidth platform)                        , cml_ret_args  = ret_args                        , cml_ret_off   = ret_off } @@ -1185,12 +1191,12 @@ foreignLbl :: FastString -> CmmExpr foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction)) -callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O-callSuspendThread dflags id intrbl =+callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O+callSuspendThread platform id intrbl =   CmmUnsafeForeignCall        (ForeignTarget (foreignLbl (fsLit "suspendThread"))         (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))-       [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]+       [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)]  callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id =@@ -1201,8 +1207,8 @@  -- ----------------------------------------------------------------------------- -plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff-plusW dflags b w = b + w * wORD_SIZE dflags+plusW :: Platform -> ByteOff -> WordOff -> ByteOff+plusW platform b w = b + w * platformWordSizeInBytes platform  data StackSlot = Occupied | Empty      -- Occupied: a return address or part of an update frame@@ -1220,15 +1226,15 @@ isEmpty Empty = True isEmpty _ = False -localRegBytes :: DynFlags -> LocalReg -> ByteOff-localRegBytes dflags r-    = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))+localRegBytes :: Platform -> LocalReg -> ByteOff+localRegBytes platform r+    = roundUpToWords platform (widthInBytes (typeWidth (localRegType r))) -localRegWords :: DynFlags -> LocalReg -> WordOff-localRegWords dflags = toWords dflags . localRegBytes dflags+localRegWords :: Platform -> LocalReg -> WordOff+localRegWords platform = toWords platform . localRegBytes platform -toWords :: DynFlags -> ByteOff -> WordOff-toWords dflags x = x `quot` wORD_SIZE dflags+toWords :: Platform -> ByteOff -> WordOff+toWords platform x = x `quot` platformWordSizeInBytes platform   stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
compiler/GHC/Cmm/Lexer.x view
@@ -21,8 +21,8 @@  import Lexer import GHC.Cmm.Monad-import SrcLoc-import UniqFM+import GHC.Types.SrcLoc+import GHC.Types.Unique.FM import StringBuffer import FastString import Ctype
compiler/GHC/Cmm/Lint.hs view
@@ -13,6 +13,7 @@  import GhcPrelude +import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph@@ -87,31 +88,31 @@   _ <- lintCmmExpr expr   -- Disabled, if we have the inlining phase before the lint phase,   -- we can have funny offsets due to pointer tagging. -- EZY-  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $+  -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $   --   cmmCheckWordAddress expr   return rep lintCmmExpr expr@(CmmMachOp op args) = do-  dflags <- getDynFlags+  platform <- getPlatform   tys <- mapM lintCmmExpr args-  if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op+  if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op         then cmmCheckMachOp op args tys-        else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)+        else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op) lintCmmExpr (CmmRegOff reg offset)-  = do dflags <- getDynFlags-       let rep = typeWidth (cmmRegType dflags reg)+  = do platform <- getPlatform+       let rep = typeWidth (cmmRegType platform reg)        lintCmmExpr (CmmMachOp (MO_Add rep)                 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) lintCmmExpr expr =-  do dflags <- getDynFlags-     return (cmmExprType dflags expr)+  do platform <- getPlatform+     return (cmmExprType platform expr)  -- Check for some common byte/word mismatches (eg. Sp + 1) cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys   = cmmCheckMachOp op [reg, lit] tys cmmCheckMachOp op _ tys-  = do dflags <- getDynFlags-       return (machOpResultType dflags op tys)+  = do platform <- getPlatform+       return (machOpResultType platform op tys)  {- isOffsetOp :: MachOp -> Bool@@ -123,10 +124,10 @@ -- check for funny-looking sub-word offsets. _cmmCheckWordAddress :: CmmExpr -> CmmLint () _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0   = cmmLintDubiousWordOffset e _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0   = cmmLintDubiousWordOffset e _cmmCheckWordAddress _   = return ()@@ -145,9 +146,9 @@   CmmUnwind{}  -> return ()    CmmAssign reg expr -> do-            dflags <- getDynFlags+            platform <- getPlatform             erep <- lintCmmExpr expr-            let reg_ty = cmmRegType dflags reg+            let reg_ty = cmmRegType platform reg             if (erep `cmmEqType_ignoring_ptrhood` reg_ty)                 then return ()                 else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty@@ -167,16 +168,16 @@   CmmBranch id -> checkTarget id    CmmCondBranch e t f _ -> do-            dflags <- getDynFlags+            platform <- getPlatform             mapM_ checkTarget [t,f]             _ <- lintCmmExpr e-            checkCond dflags e+            checkCond platform e    CmmSwitch e ids -> do-            dflags <- getDynFlags+            platform <- getPlatform             mapM_ checkTarget $ switchTargetsToList ids             erep <- lintCmmExpr e-            if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)+            if (erep `cmmEqType_ignoring_ptrhood` bWord platform)               then return ()               else cmmLintErr (text "switch scrutinee is not a word: " <>                                ppr e <> text " :: " <> ppr erep)@@ -200,9 +201,9 @@ lintTarget (PrimTarget {})     = return ()  -checkCond :: DynFlags -> CmmExpr -> CmmLint ()+checkCond :: Platform -> CmmExpr -> CmmLint () checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()-checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values+checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values checkCond _ expr     = cmmLintErr (hang (text "expression is not a conditional:") 2                          (ppr expr))@@ -227,6 +228,9 @@  instance HasDynFlags CmmLint where     getDynFlags = CmmLint (\dflags -> Right dflags)++getPlatform :: CmmLint Platform+getPlatform = targetPlatform <$> getDynFlags  cmmLintErr :: SDoc -> CmmLint a cmmLintErr msg = CmmLint (\_ -> Left msg)
compiler/GHC/Cmm/Opt.hs view
@@ -17,7 +17,6 @@  import GHC.Cmm.Utils import GHC.Cmm-import GHC.Driver.Session import Util  import Outputable@@ -27,12 +26,12 @@ import Data.Maybe  -constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x-constantFoldNode dflags = mapExp (constantFoldExpr dflags)+constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x+constantFoldNode platform = mapExp (constantFoldExpr platform) -constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr-constantFoldExpr dflags = wrapRecExp f-  where f (CmmMachOp op args) = cmmMachOpFold dflags op args+constantFoldExpr :: Platform -> CmmExpr -> CmmExpr+constantFoldExpr platform = wrapRecExp f+  where f (CmmMachOp op args) = cmmMachOpFold platform op args         f (CmmRegOff r 0) = CmmReg r         f e = e @@ -43,17 +42,17 @@ -- been optimized and folded.  cmmMachOpFold-    :: DynFlags+    :: Platform     -> MachOp       -- The operation from an CmmMachOp     -> [CmmExpr]    -- The optimized arguments     -> CmmExpr -cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)+cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args)  -- Returns Nothing if no changes, useful for Hoopl, also reduces -- allocation! cmmMachOpFoldM-    :: DynFlags+    :: Platform     -> MachOp     -> [CmmExpr]     -> Maybe CmmExpr@@ -79,7 +78,7 @@ cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x  -- Eliminate nested conversions where possible-cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]+cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]   | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,     Just (_,   rep3,signed2) <- isIntConversion conv_outer   = case () of@@ -89,13 +88,13 @@         -- but remember to use the signedness from the widening, just in case         -- the final conversion is a widen.         | rep1 < rep2 && rep2 > rep3 ->-            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]+            Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]         -- Nested widenings: collapse if the signedness is the same         | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->-            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]+            Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]         -- Nested narrowings: collapse         | rep1 > rep2 && rep2 > rep3 ->-            Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]+            Just $ cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x]         | otherwise ->             Nothing   where@@ -112,22 +111,22 @@ -- but what if the architecture only supports word-sized loads, should -- we do the transformation anyway? -cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]+cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]   = case mop of         -- for comparisons: don't forget to narrow the arguments before         -- comparing, since they might be out of range.-        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))-        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))+        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform))+        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform)) -        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth dflags))-        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))-        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth dflags))-        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))+        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth platform))+        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform))+        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth platform))+        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform)) -        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth dflags))-        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))-        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth dflags))-        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))+        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth platform))+        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform))+        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth platform))+        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform))          MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)         MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)@@ -159,9 +158,9 @@ -- also assume that constants have been shifted to the right when -- possible. -cmmMachOpFoldM dflags op [x@(CmmLit _), y]+cmmMachOpFoldM platform op [x@(CmmLit _), y]    | not (isLit y) && isCommutableMachOp op-   = Just (cmmMachOpFold dflags op [y, x])+   = Just (cmmMachOpFold platform op [y, x])  -- Turn (a+b)+c into a+(b+c) where possible.  Because literals are -- moved to the right, it is more likely that we will find@@ -179,19 +178,19 @@ -- Also don't do it if arg1 is PicBaseReg, so that we don't separate the -- PicBaseReg from the corresponding label (or label difference). ---cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]+cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3]    | mop2 `associates_with` mop1      && not (isLit arg1) && not (isPicReg arg1)-   = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])+   = Just (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]])    where      MO_Add{} `associates_with` MO_Sub{} = True      mop1 `associates_with` mop2 =         mop1 == mop2 && isAssociativeMachOp mop1  -- special case: (a - b) + c  ==>  a + (c - b)-cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]+cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]    | not (isLit arg1) && not (isPicReg arg1)-   = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])+   = Just (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]])  -- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N) --@@ -234,9 +233,9 @@ -- narrowing throws away bits from the operand, there's no way to do -- the same comparison at the larger size. -cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]+cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]   |     -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try-    platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],+    platformArch platform `elem` [ArchX86, ArchX86_64],         -- if the operand is widened:     Just (rep, signed, narrow_fn) <- maybe_conversion conv,         -- and this is a comparison operation:@@ -244,7 +243,7 @@         -- and the literal fits in the smaller size:     i == narrow_fn rep i         -- then we can do the comparison at the smaller size-  = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])+  = Just (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)])  where     maybe_conversion (MO_UU_Conv from to)         | to > from@@ -278,7 +277,7 @@ -- We can often do something with constants of 0 and 1 ... -- See Note [Comparison operators] -cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]+cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))]   = case mop of         -- Arithmetic         MO_Add   _ -> Just x   -- x + 0 = x@@ -310,10 +309,10 @@         MO_S_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'         _ -> Nothing   where-    zero = CmmLit (CmmInt 0 (wordWidth dflags))-    one  = CmmLit (CmmInt 1 (wordWidth dflags))+    zero = CmmLit (CmmInt 0 (wordWidth platform))+    one  = CmmLit (CmmInt 1 (wordWidth platform)) -cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]+cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt 1 rep))]   = case mop of         -- Arithmetic: x*1 = x, etc         MO_Mul    _ -> Just x@@ -336,27 +335,27 @@         MO_S_Ge  _ | isComparisonExpr x -> Just x         _ -> Nothing   where-    zero = CmmLit (CmmInt 0 (wordWidth dflags))-    one  = CmmLit (CmmInt 1 (wordWidth dflags))+    zero = CmmLit (CmmInt 0 (wordWidth platform))+    one  = CmmLit (CmmInt 1 (wordWidth platform))  -- Now look for multiplication/division by powers of 2 (integers). -cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]+cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))]   = case mop of         MO_Mul rep            | Just p <- exactLog2 n ->-                 Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])+                 Just (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)])         MO_U_Quot rep            | Just p <- exactLog2 n ->-                 Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])+                 Just (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])         MO_U_Rem rep            | Just _ <- exactLog2 n ->-                 Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])+                 Just (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])         MO_S_Quot rep            | Just p <- exactLog2 n,              CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require                                 -- it is a reg.  FIXME: remove this restriction.-                Just (cmmMachOpFold dflags (MO_S_Shr rep)+                Just (cmmMachOpFold platform (MO_S_Shr rep)                   [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])         MO_S_Rem rep            | Just p <- exactLog2 n,@@ -365,8 +364,8 @@                 -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).                 -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)                 -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.-                Just (cmmMachOpFold dflags (MO_Sub rep)-                    [x, cmmMachOpFold dflags (MO_And rep)+                Just (cmmMachOpFold platform (MO_Sub rep)+                    [x, cmmMachOpFold platform (MO_And rep)                       [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])         _ -> Nothing   where
compiler/GHC/Cmm/Parser.y view
@@ -234,14 +234,14 @@ import GHC.Runtime.Heap.Layout import Lexer -import CostCentre-import ForeignCall-import Module+import GHC.Types.CostCentre+import GHC.Types.ForeignCall+import GHC.Types.Module import GHC.Platform-import Literal-import Unique-import UniqFM-import SrcLoc+import GHC.Types.Literal+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.SrcLoc import GHC.Driver.Session import ErrUtils import StringBuffer@@ -249,9 +249,9 @@ import Panic import Constants import Outputable-import BasicTypes+import GHC.Types.Basic import Bag              ( emptyBag, unitBag )-import Var+import GHC.Types.Var  import Control.Monad import Data.Array@@ -542,10 +542,11 @@                 -- closure type, live regs                 {% liftP . withThisPackage $ \pkg ->                    do dflags <- getDynFlags+                      let platform = targetPlatform dflags                       live <- sequence $7                       let prof = NoProfilingInfo                           -- drop one for the info pointer-                          bitmap = mkLiveness dflags (drop 1 live)+                          bitmap = mkLiveness platform (drop 1 live)                           rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap                       return (mkCmmRetLabel pkg $3,                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3@@ -770,7 +771,7 @@  -- leaving out the type of a literal gives you the native word size in C-- maybe_ty :: { CmmType }-        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }+        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord (targetPlatform dflags) }         | '::' type                     { $2 }  cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }@@ -859,7 +860,7 @@         | 'bits512'             { b512 }         | 'float32'             { f32 }         | 'float64'             { f64 }-        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }+        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord (targetPlatform dflags) }  { section :: String -> SectionType@@ -873,17 +874,6 @@ mkString :: String -> CmmStatic mkString s = CmmString (BS8.pack s) --- |--- Given an info table, decide what the entry convention for the proc--- is.  That is, for an INFO_TABLE_RET we want the return convention,--- otherwise it is a NativeNodeCall.----infoConv :: Maybe CmmInfoTable -> Convention-infoConv Nothing = NativeNodeCall-infoConv (Just info)-  | isStackRep (cit_rep info) = NativeReturn-  | otherwise                 = NativeNodeCall- -- mkMachOp infers the type of the MachOp from the type of its first -- argument.  We assume that this is correct: for MachOps that don't have -- symmetrical args (e.g. shift ops), the first arg determines the type of@@ -891,8 +881,9 @@ mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr mkMachOp fn args = do   dflags <- getDynFlags+  let platform = targetPlatform dflags   arg_exprs <- sequence args-  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)+  return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs)  getLit :: CmmExpr -> CmmLit getLit (CmmLit l) = l@@ -1155,14 +1146,15 @@   -> CmmParse () reserveStackFrame psize preg body = do   dflags <- getDynFlags+  let platform = targetPlatform dflags   old_updfr_off <- getUpdFrameOff   reg <- preg   esize <- psize-  let size = case constantFoldExpr dflags esize of+  let size = case constantFoldExpr platform esize of                CmmLit (CmmInt n _) -> n                _other -> pprPanic "CmmParse: not a compile-time integer: "                             (ppr esize)-  let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size+  let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size   emitAssign reg (CmmStackSlot Old frame)   withUpdFrameOff frame body @@ -1196,7 +1188,8 @@           expr <- expr_code           args <- sequence args_code           let-                  expr' = adjCallTarget dflags conv expr args+                  platform = targetPlatform dflags+                  expr' = adjCallTarget platform conv expr args                   (arg_exprs, arg_hints) = unzip args                   (res_regs,  res_hints) = unzip results                   fc = ForeignConvention conv arg_hints res_hints ret@@ -1216,7 +1209,8 @@ mkReturnSimple dflags actuals updfr_off =   mkReturn dflags e actuals updfr_off   where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)-                             (gcWord dflags))+                             (gcWord platform))+        platform = targetPlatform dflags  doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () doRawJump expr_code vols = do@@ -1238,7 +1232,6 @@ doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]        -> CmmParse () doCall expr_code res_code args_code = do-  dflags <- getDynFlags   expr <- expr_code   args <- sequence args_code   ress <- sequence res_code@@ -1246,14 +1239,14 @@   c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []   emit c -adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]+adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]               -> CmmExpr -- On Windows, we have to add the '@N' suffix to the label when making -- a call with the stdcall calling convention.-adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args- | platformOS (targetPlatform dflags) == OSMinGW32+adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args+ | platformOS platform == OSMinGW32   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))-  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))+  where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e)))                  -- c.f. CgForeignCall.emitForeignCall adjCallTarget _ _ expr _   = expr@@ -1282,8 +1275,9 @@         -- mismatch to be flagged by cmm-lint.  If we don't do this, then         -- the store will happen at the wrong type, and the error will not         -- be noticed.-       let val_width = typeWidth (cmmExprType dflags val)+       let val_width = typeWidth (cmmExprType platform val)            rep_width = typeWidth rep+           platform  = targetPlatform dflags        let coerce_val                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]                 | otherwise              = val@@ -1386,7 +1380,8 @@         let table = M.fromList (concat table_entries)          dflags <- getDynFlags-        let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range+        let platform = targetPlatform dflags+        let range = fromMaybe (0, platformMaxWord platform) mb_range          expr <- scrut         -- ToDo: check for out of range and jump to default if necessary@@ -1413,10 +1408,11 @@ initEnv :: DynFlags -> Env initEnv dflags = listToUFM [   ( fsLit "SIZEOF_StgHeader",-    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth platform)) )),   ( fsLit "SIZEOF_StgInfoTable",-    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))+    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth platform)) ))   ]+  where platform = targetPlatform dflags  parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
compiler/GHC/Cmm/Pipeline.hs view
@@ -22,7 +22,7 @@ import GHC.Cmm.Sink import GHC.Cmm.Dataflow.Collections -import UniqSupply+import GHC.Types.Unique.Supply import GHC.Driver.Session import ErrUtils import GHC.Driver.Types@@ -138,7 +138,7 @@         ------------- Populate info tables with stack info -----------------        g <- {-# SCC "setInfoTableStackMap" #-}-            return $ map (setInfoTableStackMap dflags stackmaps) g+            return $ map (setInfoTableStackMap platform stackmaps) g        dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g         ----------- Control-flow optimisations -----------------------------
compiler/GHC/Cmm/Ppr.hs view
@@ -42,6 +42,8 @@  import GhcPrelude hiding (succ) +import GHC.Platform+import GHC.Driver.Session (targetPlatform) import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils@@ -52,7 +54,7 @@ import GHC.Cmm.Ppr.Expr import Util -import BasicTypes+import GHC.Types.Basic import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph @@ -67,7 +69,8 @@   instance Outputable (CmmNode e x) where-    ppr = pprNode+    ppr e = sdocWithDynFlags $ \dflags ->+            pprNode (targetPlatform dflags) e  instance Outputable Convention where     ppr = pprConvention@@ -177,8 +180,8 @@                          (mkFastString (show op))                          Nothing ForeignLabelInThisPackage IsFunction)) -pprNode :: CmmNode e x -> SDoc-pprNode node = pp_node <+> pp_debug+pprNode :: Platform -> CmmNode e x -> SDoc+pprNode platform node = pp_node <+> pp_debug   where     pp_node :: SDoc     pp_node = case node of@@ -209,8 +212,7 @@       -- rep[lv] = expr;       CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi           where-            rep = sdocWithDynFlags $ \dflags ->-                  ppr ( cmmExprType dflags expr )+            rep = ppr ( cmmExprType platform expr )        -- call "ccall" foo(x, y)[r1, r2];       -- ToDo ppr volatile
compiler/GHC/Cmm/Ppr/Decl.hs view
@@ -40,6 +40,7 @@  import GhcPrelude +import GHC.Platform import GHC.Cmm.Ppr.Expr import GHC.Cmm @@ -76,7 +77,8 @@     ppr = pprRawStatics  instance Outputable CmmStatic where-    ppr = pprStatic+    ppr e = sdocWithDynFlags $ \dflags ->+            pprStatic (targetPlatform dflags) e  instance Outputable CmmInfoTable where     ppr = pprInfoTable@@ -148,9 +150,9 @@ pprRawStatics :: RawCmmStatics -> SDoc pprRawStatics (RawCmmStatics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) -pprStatic :: CmmStatic -> SDoc-pprStatic s = case s of-    CmmStaticLit lit   -> nest 4 $ text "const" <+> pprLit lit <> semi+pprStatic :: Platform -> CmmStatic -> SDoc+pprStatic platform s = case s of+    CmmStaticLit lit   -> nest 4 $ text "const" <+> pprLit platform lit <> semi     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)     CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
compiler/GHC/Cmm/Ppr/Expr.hs view
@@ -41,6 +41,8 @@  import GhcPrelude +import GHC.Platform+import GHC.Driver.Session (targetPlatform) import GHC.Cmm.Expr  import Outputable@@ -51,13 +53,15 @@ -----------------------------------------------------------------------------  instance Outputable CmmExpr where-    ppr e = pprExpr e+    ppr e = sdocWithDynFlags $ \dflags ->+            pprExpr (targetPlatform dflags) e  instance Outputable CmmReg where     ppr e = pprReg e  instance Outputable CmmLit where-    ppr l = pprLit l+    ppr l = sdocWithDynFlags $ \dflags ->+            pprLit (targetPlatform dflags) l  instance Outputable LocalReg where     ppr e = pprLocalReg e@@ -72,16 +76,15 @@ -- Expressions -- -pprExpr :: CmmExpr -> SDoc-pprExpr e-    = sdocWithDynFlags $ \dflags ->-      case e of+pprExpr :: Platform -> CmmExpr -> SDoc+pprExpr platform e+    = case e of         CmmRegOff reg i ->-                pprExpr (CmmMachOp (MO_Add rep)+                pprExpr platform (CmmMachOp (MO_Add rep)                            [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])-                where rep = typeWidth (cmmRegType dflags reg)-        CmmLit lit -> pprLit lit-        _other     -> pprExpr1 e+                where rep = typeWidth (cmmRegType platform reg)+        CmmLit lit -> pprLit platform lit+        _other     -> pprExpr1 platform e  -- Here's the precedence table from GHC.Cmm.Parser: -- %nonassoc '>=' '>' '<=' '<' '!=' '=='@@ -97,10 +100,11 @@ -- a default conservative behaviour.  -- %nonassoc '>=' '>' '<=' '<' '!=' '=='-pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc-pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op-   = pprExpr7 x <+> doc <+> pprExpr7 y-pprExpr1 e = pprExpr7 e+pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc+pprExpr1 platform (CmmMachOp op [x,y])+   | Just doc <- infixMachOp1 op+   = pprExpr7 platform x <+> doc <+> pprExpr7 platform y+pprExpr1 platform e = pprExpr7 platform e  infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc @@ -115,55 +119,57 @@ infixMachOp1 _             = Nothing  -- %left '-' '+'-pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0-   = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])-pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op-   = pprExpr7 x <+> doc <+> pprExpr8 y-pprExpr7 e = pprExpr8 e+pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0+   = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])+pprExpr7 platform (CmmMachOp op [x,y])+   | Just doc <- infixMachOp7 op+   = pprExpr7 platform x <+> doc <+> pprExpr8 platform y+pprExpr7 platform e = pprExpr8 platform e  infixMachOp7 (MO_Add _)  = Just (char '+') infixMachOp7 (MO_Sub _)  = Just (char '-') infixMachOp7 _           = Nothing  -- %left '/' '*' '%'-pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op-   = pprExpr8 x <+> doc <+> pprExpr9 y-pprExpr8 e = pprExpr9 e+pprExpr8 platform (CmmMachOp op [x,y])+   | Just doc <- infixMachOp8 op+   = pprExpr8 platform x <+> doc <+> pprExpr9 platform y+pprExpr8 platform e = pprExpr9 platform e  infixMachOp8 (MO_U_Quot _) = Just (char '/') infixMachOp8 (MO_Mul _)    = Just (char '*') infixMachOp8 (MO_U_Rem _)  = Just (char '%') infixMachOp8 _             = Nothing -pprExpr9 :: CmmExpr -> SDoc-pprExpr9 e =+pprExpr9 :: Platform -> CmmExpr -> SDoc+pprExpr9 platform e =    case e of-        CmmLit    lit       -> pprLit1 lit+        CmmLit    lit       -> pprLit1 platform lit         CmmLoad   expr rep  -> ppr rep <> brackets (ppr expr)         CmmReg    reg       -> ppr reg         CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)         CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)-        CmmMachOp mop args  -> genMachOp mop args+        CmmMachOp mop args  -> genMachOp platform mop args -genMachOp :: MachOp -> [CmmExpr] -> SDoc-genMachOp mop args+genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc+genMachOp platform mop args    | Just doc <- infixMachOp mop = case args of         -- dyadic-        [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y+        [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y          -- unary-        [x]   -> doc <> pprExpr9 x+        [x]   -> doc <> pprExpr9 platform x          _     -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args"                           (pprMachOp mop <+>-                            parens (hcat $ punctuate comma (map pprExpr args)))+                            parens (hcat $ punctuate comma (map (pprExpr platform) args)))                           empty     | isJust (infixMachOp1 mop)    || isJust (infixMachOp7 mop)-   || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))+   || isJust (infixMachOp8 mop)  = parens (pprExpr platform (CmmMachOp mop args)) -   | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))+   | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args))         where ppr_op = text (map (\c -> if c == ' ' then '_' else c)                                  (show mop))                 -- replace spaces in (show mop) with underscores,@@ -187,16 +193,15 @@ --  To minimise line noise we adopt the convention that if the literal --  has the natural machine word size, we do not append the type ---pprLit :: CmmLit -> SDoc-pprLit lit = sdocWithDynFlags $ \dflags ->-             case lit of+pprLit :: Platform -> CmmLit -> SDoc+pprLit platform lit = case lit of     CmmInt i rep ->         hcat [ (if i < 0 then parens else id)(integer i)-             , ppUnless (rep == wordWidth dflags) $+             , ppUnless (rep == wordWidth platform) $                space <> dcolon <+> ppr rep ]      CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]-    CmmVec lits        -> char '<' <> commafy (map pprLit lits) <> char '>'+    CmmVec lits        -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'     CmmLabel clbl      -> ppr clbl     CmmLabelOff clbl i -> ppr clbl <> ppr_offset i     CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'@@ -204,9 +209,9 @@     CmmBlock id        -> ppr id     CmmHighStackMark -> text "<highSp>" -pprLit1 :: CmmLit -> SDoc-pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)-pprLit1 lit                  = pprLit lit+pprLit1 :: Platform -> CmmLit -> SDoc+pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)+pprLit1 platform lit                  = pprLit platform lit  ppr_offset :: Int -> SDoc ppr_offset i
compiler/GHC/Cmm/ProcPoint.hs view
@@ -25,7 +25,7 @@ import Control.Monad import Outputable import GHC.Platform-import UniqSupply+import GHC.Types.Unique.Supply import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow
compiler/GHC/Cmm/Sink.hs view
@@ -14,11 +14,11 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Platform.Regs-import GHC.Platform (isARM, platformArch) +import GHC.Platform import GHC.Driver.Session-import Unique-import UniqFM+import GHC.Types.Unique+import GHC.Types.Unique.FM  import qualified Data.IntSet as IntSet import Data.List (partition)@@ -181,6 +181,7 @@     -- pprTrace "sink" (ppr lbl) $     blockJoin first final_middle final_last : sink sunk' bs     where+      platform = targetPlatform dflags       lbl = entryLabel b       (first, middle, last) = blockSplit b @@ -195,7 +196,7 @@        -- Now sink and inline in this block       (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)-      fold_last = constantFoldNode dflags last+      fold_last = constantFoldNode platform last       (final_last, assigs') = tryToInline dflags live fold_last assigs        -- We cannot sink into join points (successors with more than@@ -330,12 +331,13 @@  where    go []               block as = (block, as)    go ((live,node):ns) block as-    | shouldDiscard node live           = go ns block as+    | shouldDiscard node live             = go ns block as        -- discard dead assignment-    | Just a <- shouldSink dflags node2 = go ns block (a : as1)-    | otherwise                         = go ns block' as'+    | Just a <- shouldSink platform node2 = go ns block (a : as1)+    | otherwise                           = go ns block' as'     where-      node1 = constantFoldNode dflags node+      platform = targetPlatform dflags+      node1 = constantFoldNode platform node        (node2, as1) = tryToInline dflags live node1 as @@ -351,8 +353,8 @@ -- be profitable to sink assignments to global regs too, but the -- liveness analysis doesn't track those (yet) so we can't. ---shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment-shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)+shouldSink :: Platform -> CmmNode e x -> Maybe Assignment+shouldSink platform (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem platform e)   where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e shouldSink _ _other = Nothing @@ -430,6 +432,7 @@    | isTrivial dflags rhs    = inline_and_keep    | otherwise               = dont_inline    where+        platform = targetPlatform dflags         inline_and_discard = go usages' inl_node skipped rest           where usages' = foldLocalRegsUsed dflags addUsage usages rhs @@ -462,9 +465,9 @@         -- inl_exp is where the inlining actually takes place!         inl_exp (CmmReg    (CmmLocal l'))     | l == l' = rhs         inl_exp (CmmRegOff (CmmLocal l') off) | l == l'-                    = cmmOffset dflags rhs off+                    = cmmOffset platform rhs off                     -- re-constant fold after inlining-        inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args+        inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args         inl_exp other = other  @@ -588,7 +591,7 @@    -- (3) a store to an address conflicts with a read of the same memory   | CmmStore addr' e <- node-  , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True+  , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True    -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively   | HeapMem    <- addr, CmmAssign (CmmGlobal Hp) _ <- node        = True@@ -603,19 +606,21 @@    -- (7) otherwise, no conflict   | otherwise = False+  where+    platform = targetPlatform dflags  -- Returns True if node defines any global registers that are used in the -- Cmm expression globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool globalRegistersConflict dflags expr node =-    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)+    foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmGlobal r) expr)                  False node  -- Returns True if node defines any local registers that are used in the -- Cmm expression localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool localRegistersConflict dflags expr node =-    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal  r) expr)+    foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmLocal  r) expr)                  False node  -- Note [Sinking and calls]@@ -745,24 +750,24 @@   | otherwise = o2 + w2 > o1 memConflicts _         _         = True -exprMem :: DynFlags -> CmmExpr -> AbsMem-exprMem dflags (CmmLoad addr w)  = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)-exprMem dflags (CmmMachOp _ es)  = foldr bothMems NoMem (map (exprMem dflags) es)-exprMem _      _                 = NoMem+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 -loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem-loadAddr dflags e w =+loadAddr :: Platform -> CmmExpr -> Width -> AbsMem+loadAddr platform e w =   case e of-   CmmReg r       -> regAddr dflags r 0 w-   CmmRegOff r i  -> regAddr dflags r i w-   _other | regUsedIn dflags spReg e -> StackMem-          | otherwise -> AnyMem+   CmmReg r       -> regAddr platform r 0 w+   CmmRegOff r i  -> regAddr platform r i w+   _other | regUsedIn platform spReg e -> StackMem+          | otherwise                  -> AnyMem -regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem+regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem regAddr _      (CmmGlobal Sp) i w = SpMem i (widthInBytes w) regAddr _      (CmmGlobal Hp) _ _ = HeapMem regAddr _      (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps-regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself+regAddr platform r _ _ | isGcPtrType (cmmRegType platform r) = HeapMem -- yay! GCPtr pays for itself regAddr _      _ _ _ = AnyMem  {-
compiler/GHC/Cmm/Switch/Implement.hs view
@@ -6,12 +6,13 @@  import GhcPrelude +import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch-import UniqSupply+import GHC.Types.Unique.Supply import GHC.Driver.Session import MonadUtils (concatMapM) @@ -36,18 +37,18 @@     -- Switch generation done by backend (LLVM/C)     | targetSupportsSwitch (hscTarget dflags) = return g     | otherwise = do-    blocks' <- concatMapM (visitSwitches dflags) (toBlockList g)+    blocks' <- concatMapM (visitSwitches (targetPlatform dflags)) (toBlockList g)     return $ ofBlockList (g_entry g) blocks' -visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]-visitSwitches dflags block+visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock]+visitSwitches platform block   | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block   = do     let plan = createSwitchPlan ids     -- See Note [Floating switch expressions]-    (assignSimple, simpleExpr) <- floatSwitchExpr dflags vanillaExpr+    (assignSimple, simpleExpr) <- floatSwitchExpr platform vanillaExpr -    (newTail, newBlocks) <- implementSwitchPlan dflags scope simpleExpr plan+    (newTail, newBlocks) <- implementSwitchPlan platform scope simpleExpr plan      let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail @@ -71,16 +72,16 @@ -- This happened in parts of the handwritten RTS Cmm code. See also #16933  -- See Note [Floating switch expressions]-floatSwitchExpr :: DynFlags -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)-floatSwitchExpr _      reg@(CmmReg {})  = return (emptyBlock, reg)-floatSwitchExpr dflags expr             = do-  (assign, expr') <- cmmMkAssign dflags expr <$> getUniqueM+floatSwitchExpr :: Platform -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)+floatSwitchExpr _        reg@(CmmReg {})  = return (emptyBlock, reg)+floatSwitchExpr platform expr             = do+  (assign, expr') <- cmmMkAssign platform expr <$> getUniqueM   return (BMiddle assign, expr')   -- Implementing a switch plan (returning a tail block)-implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])-implementSwitchPlan dflags scope expr = go+implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])+implementSwitchPlan platform scope expr = go   where     go (Unconditionally l)       = return (emptyBlock `blockJoinTail` CmmBranch l, [])@@ -93,7 +94,7 @@          let lt | signed    = cmmSLtWord                | otherwise = cmmULtWord-            scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i+            scrut = lt platform expr $ CmmLit $ mkWordCLit platform i             lastNode = CmmCondBranch scrut bid1 bid2 Nothing             lastBlock = emptyBlock `blockJoinTail` lastNode         return (lastBlock, newBlocks1++newBlocks2)@@ -101,7 +102,7 @@       = do         (bid2, newBlocks2) <- go' ids2 -        let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i+        let scrut = cmmNeWord platform expr $ CmmLit $ mkWordCLit platform i             lastNode = CmmCondBranch scrut bid2 l Nothing             lastBlock = emptyBlock `blockJoinTail` lastNode         return (lastBlock, newBlocks2)
compiler/GHC/Cmm/Utils.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs, RankNTypes #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -72,16 +73,17 @@  import GhcPrelude -import TyCon    ( PrimRep(..), PrimElemRep(..) )+import GHC.Core.TyCon     ( PrimRep(..), PrimElemRep(..) ) import GHC.Types.RepType  ( UnaryType, SlotTy (..), typePrimRep1 ) +import GHC.Platform import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.CLabel import Outputable import GHC.Driver.Session-import Unique+import GHC.Types.Unique import GHC.Platform.Regs  import Data.ByteString (ByteString)@@ -98,31 +100,33 @@ -- --------------------------------------------------- -primRepCmmType :: DynFlags -> PrimRep -> CmmType-primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"-primRepCmmType dflags LiftedRep        = gcWord dflags-primRepCmmType dflags UnliftedRep      = gcWord dflags-primRepCmmType dflags IntRep           = bWord dflags-primRepCmmType dflags WordRep          = bWord dflags-primRepCmmType _      Int8Rep          = b8-primRepCmmType _      Word8Rep         = b8-primRepCmmType _      Int16Rep         = b16-primRepCmmType _      Word16Rep        = b16-primRepCmmType _      Int32Rep         = b32-primRepCmmType _      Word32Rep        = b32-primRepCmmType _      Int64Rep         = b64-primRepCmmType _      Word64Rep        = b64-primRepCmmType dflags AddrRep          = bWord dflags-primRepCmmType _      FloatRep         = f32-primRepCmmType _      DoubleRep        = f64-primRepCmmType _      (VecRep len rep) = vec len (primElemRepCmmType rep)+primRepCmmType :: Platform -> PrimRep -> CmmType+primRepCmmType platform = \case+   VoidRep          -> panic "primRepCmmType:VoidRep"+   LiftedRep        -> gcWord platform+   UnliftedRep      -> gcWord platform+   IntRep           -> bWord platform+   WordRep          -> bWord platform+   Int8Rep          -> b8+   Word8Rep         -> b8+   Int16Rep         -> b16+   Word16Rep        -> b16+   Int32Rep         -> b32+   Word32Rep        -> b32+   Int64Rep         -> b64+   Word64Rep        -> b64+   AddrRep          -> bWord platform+   FloatRep         -> f32+   DoubleRep        -> f64+   (VecRep len rep) -> vec len (primElemRepCmmType rep) -slotCmmType :: DynFlags -> SlotTy -> CmmType-slotCmmType dflags PtrSlot    = gcWord dflags-slotCmmType dflags WordSlot   = bWord dflags-slotCmmType _      Word64Slot = b64-slotCmmType _      FloatSlot  = f32-slotCmmType _      DoubleSlot = f64+slotCmmType :: Platform -> SlotTy -> CmmType+slotCmmType platform = \case+   PtrSlot    -> gcWord platform+   WordSlot   -> bWord platform+   Word64Slot -> b64+   FloatSlot  -> f32+   DoubleSlot -> f64  primElemRepCmmType :: PrimElemRep -> CmmType primElemRepCmmType Int8ElemRep   = b8@@ -136,8 +140,8 @@ primElemRepCmmType FloatElemRep  = f32 primElemRepCmmType DoubleElemRep = f64 -typeCmmType :: DynFlags -> UnaryType -> CmmType-typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)+typeCmmType :: Platform -> UnaryType -> CmmType+typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty)  primRepForeignHint :: PrimRep -> ForeignHint primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"@@ -176,20 +180,20 @@  -- XXX: should really be Integer, since Int doesn't necessarily cover -- the full range of target Ints.-mkIntCLit :: DynFlags -> Int -> CmmLit-mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)+mkIntCLit :: Platform -> Int -> CmmLit+mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform) -mkIntExpr :: DynFlags -> Int -> CmmExpr-mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i+mkIntExpr :: Platform -> Int -> CmmExpr+mkIntExpr platform i = CmmLit $! mkIntCLit platform i -zeroCLit :: DynFlags -> CmmLit-zeroCLit dflags = CmmInt 0 (wordWidth dflags)+zeroCLit :: Platform -> CmmLit+zeroCLit platform = CmmInt 0 (wordWidth platform) -zeroExpr :: DynFlags -> CmmExpr-zeroExpr dflags = CmmLit (zeroCLit dflags)+zeroExpr :: Platform -> CmmExpr+zeroExpr platform = CmmLit (zeroCLit platform) -mkWordCLit :: DynFlags -> Integer -> CmmLit-mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)+mkWordCLit :: Platform -> Integer -> CmmLit+mkWordCLit platform wd = CmmInt wd (wordWidth platform)  mkByteStringCLit   :: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics info stmt)@@ -218,8 +222,8 @@     needsRelocation (CmmLabelOff _ _) = True     needsRelocation _                 = False -mkStgWordCLit :: DynFlags -> StgWord -> CmmLit-mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)+mkStgWordCLit :: Platform -> StgWord -> CmmLit+mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)  packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit -- Make a single word literal in which the lower_half_word is@@ -229,10 +233,11 @@ --       but be careful: that's vulnerable when reversed packHalfWordsCLit dflags lower_half_word upper_half_word    = if wORDS_BIGENDIAN dflags-     then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u)-     else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags))+     then mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)+     else mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))     where l = fromStgHalfWord lower_half_word           u = fromStgHalfWord upper_half_word+          platform = targetPlatform dflags  --------------------------------------------------- --@@ -243,26 +248,23 @@ mkLblExpr :: CLabel -> CmmExpr mkLblExpr lbl = CmmLit (CmmLabel lbl) -cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+cmmOffsetExpr :: Platform -> CmmExpr -> CmmExpr -> CmmExpr -- assumes base and offset have the same CmmType-cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)-cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]+cmmOffsetExpr platform e (CmmLit (CmmInt n _)) = cmmOffset platform e (fromInteger n)+cmmOffsetExpr platform e byte_off = CmmMachOp (MO_Add (cmmExprWidth platform e)) [e, byte_off] -cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr-cmmOffset _ e                 0        = e-cmmOffset _ (CmmReg reg)      byte_off = cmmRegOff reg byte_off-cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)-cmmOffset _ (CmmLit lit)      byte_off = CmmLit (cmmOffsetLit lit byte_off)-cmmOffset _ (CmmStackSlot area off) byte_off-  = CmmStackSlot area (off - byte_off)+cmmOffset :: Platform -> CmmExpr -> Int -> CmmExpr+cmmOffset _platform e 0        = e+cmmOffset platform  e byte_off = case e of+   CmmReg reg            -> cmmRegOff reg byte_off+   CmmRegOff reg m       -> cmmRegOff reg (m+byte_off)+   CmmLit lit            -> CmmLit (cmmOffsetLit lit byte_off)+   CmmStackSlot area off -> CmmStackSlot area (off - byte_off)   -- note stack area offsets increase towards lower addresses-cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2-  = CmmMachOp (MO_Add rep)-              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]-cmmOffset dflags expr byte_off-  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]-  where-    width = cmmExprWidth dflags expr+   CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]+      -> CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off) rep)]+   _ -> CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]+         where width = cmmExprWidth platform e  -- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above. cmmRegOff :: CmmReg -> Int -> CmmExpr@@ -284,37 +286,37 @@  -- | Useful for creating an index into an array, with a statically known offset. -- The type is the element type; used for making the multiplier-cmmIndex :: DynFlags+cmmIndex :: Platform          -> Width       -- Width w          -> CmmExpr     -- Address of vector of items of width w          -> Int         -- Which element of the vector (0 based)          -> CmmExpr     -- Address of i'th element-cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)+cmmIndex platform width base idx = cmmOffset platform base (idx * widthInBytes width)  -- | Useful for creating an index into an array, with an unknown offset.-cmmIndexExpr :: DynFlags+cmmIndexExpr :: Platform              -> Width           -- Width w              -> CmmExpr         -- Address of vector of items of width w              -> CmmExpr         -- Which element of the vector (0 based)              -> CmmExpr         -- Address of i'th element-cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)-cmmIndexExpr dflags width base idx =-  cmmOffsetExpr dflags base byte_off+cmmIndexExpr platform width base (CmmLit (CmmInt n _)) = cmmIndex platform width base (fromInteger n)+cmmIndexExpr platform width base idx =+  cmmOffsetExpr platform base byte_off   where-    idx_w = cmmExprWidth dflags idx-    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]+    idx_w = cmmExprWidth platform idx+    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)] -cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr-cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty+cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr+cmmLoadIndex platform ty expr ix = CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty  -- The "B" variants take byte offsets cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr cmmRegOffB = cmmRegOff -cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr+cmmOffsetB :: Platform -> CmmExpr -> ByteOff -> CmmExpr cmmOffsetB = cmmOffset -cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+cmmOffsetExprB :: Platform -> CmmExpr -> CmmExpr -> CmmExpr cmmOffsetExprB = cmmOffsetExpr  cmmLabelOffB :: CLabel -> ByteOff -> CmmLit@@ -326,25 +328,25 @@ ----------------------- -- The "W" variants take word offsets -cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+cmmOffsetExprW :: Platform -> CmmExpr -> CmmExpr -> CmmExpr -- The second arg is a *word* offset; need to change it to bytes-cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)-cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off+cmmOffsetExprW platform  e (CmmLit (CmmInt n _)) = cmmOffsetW platform e (fromInteger n)+cmmOffsetExprW platform e wd_off = cmmIndexExpr platform (wordWidth platform) e wd_off -cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr-cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)+cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr+cmmOffsetW platform e n = cmmOffsetB platform e (wordsToBytes platform n) -cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr-cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)+cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr+cmmRegOffW platform reg wd_off = cmmRegOffB reg (wordsToBytes platform wd_off) -cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit-cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)+cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit+cmmOffsetLitW platform lit wd_off = cmmOffsetLitB lit (wordsToBytes platform wd_off) -cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit-cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)+cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit+cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off) -cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr-cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty+cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr+cmmLoadIndexW platform base off ty = CmmLoad (cmmOffsetW platform base off) ty  ----------------------- cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,@@ -352,39 +354,41 @@   cmmNeWord, cmmEqWord,   cmmOrWord, cmmAndWord,   cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord-  :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr-cmmOrWord dflags  e1 e2 = CmmMachOp (mo_wordOr dflags)  [e1, e2]-cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]-cmmNeWord dflags  e1 e2 = CmmMachOp (mo_wordNe dflags)  [e1, e2]-cmmEqWord dflags  e1 e2 = CmmMachOp (mo_wordEq dflags)  [e1, e2]-cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]-cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]-cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]-cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]-cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]-cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]-cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]-cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]-cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]+  :: Platform -> CmmExpr -> CmmExpr -> CmmExpr+cmmOrWord platform  e1 e2 = CmmMachOp (mo_wordOr platform)  [e1, e2]+cmmAndWord platform e1 e2 = CmmMachOp (mo_wordAnd platform) [e1, e2]+cmmNeWord platform  e1 e2 = CmmMachOp (mo_wordNe platform)  [e1, e2]+cmmEqWord platform  e1 e2 = CmmMachOp (mo_wordEq platform)  [e1, e2]+cmmULtWord platform e1 e2 = CmmMachOp (mo_wordULt platform) [e1, e2]+cmmUGeWord platform e1 e2 = CmmMachOp (mo_wordUGe platform) [e1, e2]+cmmUGtWord platform e1 e2 = CmmMachOp (mo_wordUGt platform) [e1, e2]+cmmSLtWord platform e1 e2 = CmmMachOp (mo_wordSLt platform) [e1, e2]+cmmUShrWord platform e1 e2 = CmmMachOp (mo_wordUShr platform) [e1, e2]+cmmAddWord platform e1 e2 = CmmMachOp (mo_wordAdd platform) [e1, e2]+cmmSubWord platform e1 e2 = CmmMachOp (mo_wordSub platform) [e1, e2]+cmmMulWord platform e1 e2 = CmmMachOp (mo_wordMul platform) [e1, e2]+cmmQuotWord platform e1 e2 = CmmMachOp (mo_wordUQuot platform) [e1, e2] -cmmNegate :: DynFlags -> CmmExpr -> CmmExpr-cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)-cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]+cmmNegate :: Platform -> CmmExpr -> CmmExpr+cmmNegate platform = \case+   (CmmLit (CmmInt n rep))+     -> CmmLit (CmmInt (-n) rep)+   e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e] -blankWord :: DynFlags -> CmmStatic-blankWord dflags = CmmUninitialised (wORD_SIZE dflags)+blankWord :: Platform -> CmmStatic+blankWord platform = CmmUninitialised (platformWordSizeInBytes platform) -cmmToWord :: DynFlags -> CmmExpr -> CmmExpr-cmmToWord dflags e+cmmToWord :: Platform -> CmmExpr -> CmmExpr+cmmToWord platform e   | w == word  = e   | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]   where-    w = cmmExprWidth dflags e-    word = wordWidth dflags+    w = cmmExprWidth platform e+    word = wordWidth platform -cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)-cmmMkAssign dflags expr uq =-  let !ty = cmmExprType dflags expr+cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)+cmmMkAssign platform expr uq =+  let !ty = cmmExprType platform expr       reg = (CmmLocal (LocalReg uq ty))   in  (CmmAssign reg expr, CmmReg reg) @@ -427,21 +431,24 @@  -- Tag bits mask cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr-cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)-cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))+cmmTagMask dflags = mkIntExpr (targetPlatform dflags) (tAG_MASK dflags)+cmmPointerMask dflags = mkIntExpr (targetPlatform dflags) (complement (tAG_MASK dflags))  -- Used to untag a possibly tagged pointer -- A static label need not be untagged cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr cmmUntag _ e@(CmmLit (CmmLabel _)) = e -- Default case-cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)+cmmUntag dflags e = cmmAndWord platform e (cmmPointerMask dflags)+   where platform = targetPlatform dflags  -- Test if a closure pointer is untagged-cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)+cmmIsTagged dflags e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask dflags)) (zeroExpr platform)+   where platform = targetPlatform dflags  -- Get constructor tag, but one based.-cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)+cmmConstrTag1 dflags e = cmmAndWord platform e (cmmTagMask dflags)+   where platform = targetPlatform dflags   -----------------------------------------------------------------------------@@ -451,10 +458,10 @@ -- platform, in the sense that writing to one will clobber the -- other. This includes the case that the two registers are the same -- STG register. See Note [Overlapping global registers] for details.-regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool-regsOverlap dflags (CmmGlobal g) (CmmGlobal g')-  | Just real  <- globalRegMaybe (targetPlatform dflags) g,-    Just real' <- globalRegMaybe (targetPlatform dflags) g',+regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool+regsOverlap platform (CmmGlobal g) (CmmGlobal g')+  | Just real  <- globalRegMaybe platform g,+    Just real' <- globalRegMaybe platform g',     real == real'     = True regsOverlap _ reg reg' = reg == reg'@@ -467,12 +474,12 @@ -- registers here, otherwise CmmSink may incorrectly reorder -- assignments that conflict due to overlap. See #10521 and Note -- [Overlapping global registers].-regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool-regUsedIn dflags = regUsedIn_ where+regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool+regUsedIn platform = regUsedIn_ where   _   `regUsedIn_` CmmLit _         = False   reg `regUsedIn_` CmmLoad e  _     = reg `regUsedIn_` e-  reg `regUsedIn_` CmmReg reg'      = regsOverlap dflags reg reg'-  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'+  reg `regUsedIn_` CmmReg reg'      = regsOverlap platform reg reg'+  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg'   reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es   _   `regUsedIn_` CmmStackSlot _ _ = False @@ -482,13 +489,14 @@ -- --------------------------------------------- -mkLiveness :: DynFlags -> [LocalReg] -> Liveness+mkLiveness :: Platform -> [LocalReg] -> Liveness mkLiveness _      [] = []-mkLiveness dflags (reg:regs)-  = bits ++ mkLiveness dflags regs+mkLiveness platform (reg:regs)+  = bits ++ mkLiveness platform regs   where-    sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)-            `quot` wORD_SIZE dflags+    word_size = platformWordSizeInBytes platform+    sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1)+            `quot` word_size             -- number of words, rounded up     bits = replicate sizeW is_non_ptr -- True <=> Non Ptr
compiler/GHC/CmmToAsm.hs view
@@ -69,6 +69,7 @@ import GHC.CmmToAsm.Monad import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Dwarf+import GHC.CmmToAsm.Config import GHC.Cmm.DebugBlock  import GHC.Cmm.BlockId@@ -82,19 +83,19 @@ import GHC.Cmm.Ppr import GHC.Cmm.CLabel -import UniqFM-import UniqSupply+import GHC.Types.Unique.FM+import GHC.Types.Unique.Supply import GHC.Driver.Session import Util -import BasicTypes       ( Alignment )+import GHC.Types.Basic       ( Alignment ) import qualified Pretty import BufWrite import Outputable import FastString-import UniqSet+import GHC.Types.Unique.Set import ErrUtils-import Module+import GHC.Types.Module import Stream (Stream) import qualified Stream @@ -191,14 +192,15 @@                                   X86.Instr.Instr X86.Instr.JumpDest x86_64NcgImpl dflags  = NcgImpl {-        cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen-       ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags+        ncgConfig                 = config+       ,cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen+       ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr config        ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId        ,canShortcut               = X86.Instr.canShortcut        ,shortcutStatics           = X86.Instr.shortcutStatics        ,shortcutJump              = X86.Instr.shortcutJump-       ,pprNatCmmDecl             = X86.Ppr.pprNatCmmDecl-       ,maxSpillSlots             = X86.Instr.maxSpillSlots dflags+       ,pprNatCmmDecl             = X86.Ppr.pprNatCmmDecl config+       ,maxSpillSlots             = X86.Instr.maxSpillSlots config        ,allocatableRegs           = X86.Regs.allocatableRegs platform        ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform        ,ncgExpandTop              = id@@ -206,19 +208,22 @@        ,extractUnwindPoints       = X86.CodeGen.extractUnwindPoints        ,invertCondBranches        = X86.CodeGen.invertCondBranches    }-    where platform = targetPlatform dflags+    where+      config   = initConfig dflags+      platform = ncgPlatform config  ppcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest ppcNcgImpl dflags  = NcgImpl {-        cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen-       ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags+        ncgConfig                 = config+       ,cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen+       ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr config        ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId        ,canShortcut               = PPC.RegInfo.canShortcut        ,shortcutStatics           = PPC.RegInfo.shortcutStatics        ,shortcutJump              = PPC.RegInfo.shortcutJump-       ,pprNatCmmDecl             = PPC.Ppr.pprNatCmmDecl-       ,maxSpillSlots             = PPC.Instr.maxSpillSlots dflags+       ,pprNatCmmDecl             = PPC.Ppr.pprNatCmmDecl config+       ,maxSpillSlots             = PPC.Instr.maxSpillSlots config        ,allocatableRegs           = PPC.Regs.allocatableRegs platform        ,ncgAllocMoreStack         = PPC.Instr.allocMoreStack platform        ,ncgExpandTop              = id@@ -226,19 +231,22 @@        ,extractUnwindPoints       = const []        ,invertCondBranches        = \_ _ -> id    }-    where platform = targetPlatform dflags+    where+      config   = initConfig dflags+      platform = ncgPlatform config  sparcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest sparcNcgImpl dflags  = NcgImpl {-        cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen-       ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags+        ncgConfig                 = config+       ,cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen+       ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr platform        ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId        ,canShortcut               = SPARC.ShortcutJump.canShortcut        ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics        ,shortcutJump              = SPARC.ShortcutJump.shortcutJump-       ,pprNatCmmDecl             = SPARC.Ppr.pprNatCmmDecl-       ,maxSpillSlots             = SPARC.Instr.maxSpillSlots dflags+       ,pprNatCmmDecl             = SPARC.Ppr.pprNatCmmDecl config+       ,maxSpillSlots             = SPARC.Instr.maxSpillSlots config        ,allocatableRegs           = SPARC.Regs.allocatableRegs        ,ncgAllocMoreStack         = noAllocMoreStack        ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop@@ -246,6 +254,9 @@        ,extractUnwindPoints       = const []        ,invertCondBranches        = \_ _ -> id    }+    where+      config   = initConfig dflags+      platform = ncgPlatform config  -- -- Allocating more stack space for spilling is currently only@@ -538,7 +549,8 @@  cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count  = do-        let platform = targetPlatform dflags+        let config   = ncgConfig ncgImpl+        let platform = ncgPlatform config          let proc_name = case cmm of                 (CmmProc _ entry_label _ _) -> ppr entry_label@@ -577,7 +589,7 @@         -- tag instructions with register liveness information         -- also drops dead code. We don't keep the cfg in sync on         -- some backends, so don't use it there.-        let livenessCfg = if (backendMaintainsCfg dflags)+        let livenessCfg = if backendMaintainsCfg platform                                 then Just nativeCfgWeights                                 else Nothing         let (withLiveness, usLive) =@@ -607,7 +619,7 @@                         = {-# SCC "RegAlloc-color" #-}                           initUs usLive                           $ Color.regAlloc-                                dflags+                                config                                 alloc_regs                                 (mkUniqSet [0 .. maxSpillSlots ncgImpl])                                 (maxSpillSlots ncgImpl)@@ -655,7 +667,7 @@                 -- do linear register allocation                 let reg_alloc proc = do                        (alloced, maybe_more_stack, ra_stats) <--                               Linear.regAlloc dflags proc+                               Linear.regAlloc config proc                        case maybe_more_stack of                          Nothing -> return ( alloced, ra_stats, [] )                          Just amount -> do@@ -691,11 +703,11 @@             cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)          let cfgWithFixupBlks =-                (\cfg -> addNodesBetween cfg cfgRegAllocUpdates) <$> livenessCfg+                (\cfg -> addNodesBetween dflags cfg cfgRegAllocUpdates) <$> livenessCfg          -- Insert stack update blocks         let postRegCFG =-                pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m ))+                pure (foldl' (\m (from,to) -> addImmediateSuccessor dflags from to m ))                      <*> cfgWithFixupBlks                      <*> pure stack_updt_blks @@ -725,7 +737,7 @@         let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks             getBlks _ = [] -        when ( backendMaintainsCfg dflags &&+        when ( backendMaintainsCfg platform &&                 (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do                 let blocks = concatMap getBlks shorted                 let labels = setFromList $ fmap blockId blocks :: LabelSet@@ -854,7 +866,7 @@                 -- security. GHC generated code does not need an executable                 -- stack so add the note in:             (if platformHasGnuNonexecStack platform-             then text ".section .note.GNU-stack,\"\"," <> sectionType "progbits"+             then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"              else Outputable.empty)             $$                 -- And just because every other compiler does, let's stick in@@ -865,9 +877,8 @@              else Outputable.empty)   where-        platform = targetPlatform dflags-        arch = platformArch platform-        os   = platformOS   platform+        config   = initConfig dflags+        platform = ncgPlatform config          -- Generate "symbol stubs" for all external symbols that might         -- come from a dynamic library.@@ -877,10 +888,10 @@         -- (Hack) sometimes two Labels pretty-print the same, but have         -- different uniques; so we compare their text versions...         dyld_stubs imps-                | needImportedSymbols dflags arch os+                | needImportedSymbols config                 = vcat $-                        (pprGotDeclaration dflags arch os :) $-                        map ( pprImportedSymbol dflags platform . fst . head) $+                        (pprGotDeclaration config :) $+                        map ( pprImportedSymbol dflags config . fst . head) $                         groupBy (\(_,a) (_,b) -> a == b) $                         sortBy (\(_,a) (_,b) -> compare a b) $                         map doPpr $@@ -1179,7 +1190,8 @@ cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep cmmExprCon dflags (CmmMachOp mop args)-    = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args)+    = cmmMachOpFold platform mop (map (cmmExprCon dflags) args)+    where platform = targetPlatform dflags cmmExprCon _ other = other  -- handles both PIC and non-PIC cases... a very strange mixture@@ -1211,9 +1223,9 @@            -> do                  dynRef <- cmmMakeDynamicReference dflags referenceKind lbl                  -- need to optimize here, since it's late-                 return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [+                 return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [                      dynRef,-                     (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))+                     (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))                    ]          -- On powerpc (non-PIC), it's easier to jump directly to a label than
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -10,7 +10,7 @@ {-# LANGUAGE FlexibleContexts #-}  module GHC.CmmToAsm.BlockLayout-    ( sequenceTop )+    ( sequenceTop, backendMaintainsCfg) where  #include "HsVersions.h"@@ -25,10 +25,11 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg)-import UniqFM+import GHC.Platform+import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform)+import GHC.Types.Unique.FM import Util-import Unique+import GHC.Types.Unique  import Digraph import Outputable@@ -785,7 +786,7 @@ sequenceTop _     _       _           top@(CmmData _ _) = top sequenceTop dflags ncgImpl edgeWeights             (CmmProc info lbl live (ListGraph blocks))-  | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags+  | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg (targetPlatform dflags)   --Use chain based algorithm   , Just cfg <- edgeWeights   = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $@@ -799,7 +800,7 @@                                 sequenceBlocks cfg info blocks)   where     dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||-                 (not $ backendMaintainsCfg dflags)+                 (not $ backendMaintainsCfg (targetPlatform dflags))  -- The old algorithm: -- It is very simple (and stupid): We make a graph out of@@ -893,3 +894,10 @@ lookupDeleteUFM m k = do -- Maybe monad     v <- lookupUFM m k     return (v, delFromUFM m k)++backendMaintainsCfg :: Platform -> Bool+backendMaintainsCfg platform = case platformArch platform of+    -- ArchX86 -- Should work but not tested so disabled currently.+    ArchX86_64 -> True+    _otherwise -> False+
compiler/GHC/CmmToAsm/CFG.hs view
@@ -60,7 +60,7 @@ import Digraph import Maybes -import Unique+import GHC.Types.Unique import qualified GHC.CmmToAsm.CFG.Dominators as Dom import Data.IntMap.Strict (IntMap) import Data.IntSet (IntSet)@@ -328,12 +328,12 @@ --             \                  \ --              -> C    =>         -> C ---addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG-addImmediateSuccessor node follower cfg+addImmediateSuccessor :: D.DynFlags -> BlockId -> BlockId -> CFG -> CFG+addImmediateSuccessor dflags node follower cfg     = updateEdges . addWeightEdge node follower uncondWeight $ cfg     where         uncondWeight = fromIntegral . D.uncondWeight .-                       D.cfgWeightInfo $ D.unsafeGlobalDynFlags+                       D.cfgWeightInfo $ dflags         targets = getSuccessorEdges cfg node         successors = map fst targets :: [BlockId]         updateEdges = addNewSuccs . remOldSuccs@@ -508,13 +508,13 @@ -- these cases. -- We assign the old edge info to the edge A -> B and assign B -> C the -- weight of an unconditional jump.-addNodesBetween :: CFG -> [(BlockId,BlockId,BlockId)] -> CFG-addNodesBetween m updates =+addNodesBetween :: D.DynFlags -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG+addNodesBetween dflags m updates =   foldl'  updateWeight m .           weightUpdates $ updates     where       weight = fromIntegral . D.uncondWeight .-                D.cfgWeightInfo $ D.unsafeGlobalDynFlags+                D.cfgWeightInfo $ dflags       -- We might add two blocks for different jumps along a single       -- edge. So we end up with edges:   A -> B -> C   ,   A -> D -> C       -- in this case after applying the first update the weight for A -> C
+ compiler/GHC/CmmToAsm/Config.hs view
@@ -0,0 +1,37 @@+-- | Native code generator configuration+module GHC.CmmToAsm.Config+   ( NCGConfig(..)+   , ncgWordWidth+   , platformWordWidth+   )+where++import GhcPrelude+import GHC.Platform+import GHC.Cmm.Type (Width(..))++-- | Native code generator configuration+data NCGConfig = NCGConfig+   { ncgPlatform            :: !Platform    -- ^ Target platform+   , ncgProcAlignment       :: !(Maybe Int) -- ^ Mandatory proc alignment+   , ncgDebugLevel          :: !Int         -- ^ Debug level+   , ncgExternalDynamicRefs :: !Bool        -- ^ Generate code to link against dynamic libraries+   , ncgPIC                 :: !Bool        -- ^ Enable Position-Independent Code+   , ncgSplitSections       :: !Bool        -- ^ Split sections+   , ncgSpillPreallocSize   :: !Int         -- ^ Size in bytes of the pre-allocated spill space on the C stack+   , ncgRegsIterative       :: !Bool+   , ncgAsmLinting          :: !Bool        -- ^ Perform ASM linting pass+   , ncgDumpRegAllocStages  :: !Bool+   , ncgDumpAsmStats        :: !Bool+   , ncgDumpAsmConflicts    :: !Bool+   }++-- | Return Word size+ncgWordWidth :: NCGConfig -> Width+ncgWordWidth config = platformWordWidth (ncgPlatform config)++-- | Return Word size+platformWordWidth :: Platform -> Width+platformWordWidth platform = case platformWordSize platform of+   PW4 -> W32+   PW8 -> W64
compiler/GHC/CmmToAsm/Dwarf.hs view
@@ -10,11 +10,11 @@ import GHC.Core        ( Tickish(..) ) import GHC.Cmm.DebugBlock import GHC.Driver.Session-import Module+import GHC.Types.Module import Outputable import GHC.Platform-import Unique-import UniqSupply+import GHC.Types.Unique+import GHC.Types.Unique.Supply  import GHC.CmmToAsm.Dwarf.Constants import GHC.CmmToAsm.Dwarf.Types@@ -36,6 +36,7 @@             -> IO (SDoc, UniqSupply) dwarfGen _  _      us [] = return (empty, us) dwarfGen df modLoc us blocks = do+  let platform = targetPlatform df    -- Convert debug data structures to DWARF info records   -- We strip out block information when running with -g0 or -g1.@@ -64,33 +65,33 @@       haveSrc = any haveSrcIn procs    -- .debug_abbrev section: Declare the format we're using-  let abbrevSct = pprAbbrevDecls haveSrc+  let abbrevSct = pprAbbrevDecls platform haveSrc    -- .debug_info section: Information records on procedures and blocks   let -- unique to identify start and end compilation unit .debug_inf       (unitU, us') = takeUniqFromSupply us       infoSct = vcat [ ptext dwarfInfoLabel <> colon-                     , dwarfInfoSection-                     , compileUnitHeader unitU-                     , pprDwarfInfo haveSrc dwarfUnit+                     , dwarfInfoSection platform+                     , compileUnitHeader platform unitU+                     , pprDwarfInfo platform haveSrc dwarfUnit                      , compileUnitFooter unitU                      ]    -- .debug_line section: Generated mainly by the assembler, but we   -- need to label it-  let lineSct = dwarfLineSection $$+  let lineSct = dwarfLineSection platform $$                 ptext dwarfLineLabel <> colon    -- .debug_frame section: Information about the layout of the GHC stack   let (framesU, us'') = takeUniqFromSupply us'-      frameSct = dwarfFrameSection $$+      frameSct = dwarfFrameSection platform $$                  ptext dwarfFrameLabel <> colon $$-                 pprDwarfFrame (debugFrame framesU procs)+                 pprDwarfFrame platform (debugFrame framesU procs)    -- .aranges section: Information about the bounds of compilation units   let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs                | otherwise                 = [DwarfARange lowLabel highLabel]-  let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU+  let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU    return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'') @@ -106,17 +107,17 @@  -- | Header for a compilation unit, establishing global format -- parameters-compileUnitHeader :: Unique -> SDoc-compileUnitHeader unitU = sdocWithPlatform $ \plat ->+compileUnitHeader :: Platform -> Unique -> SDoc+compileUnitHeader platform unitU =   let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field       length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel                <> text "-4"       -- length of initialLength field   in vcat [ ppr cuLabel <> colon           , text "\t.long " <> length  -- compilation unit size           , pprHalf 3                          -- DWARF version-          , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)+          , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)                                                -- abbrevs offset-          , text "\t.byte " <> ppr (platformWordSizeInBytes plat) -- word size+          , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size           ]  -- | Compilation unit footer, mainly establishing size of debug sections@@ -176,7 +177,7 @@ -- | Generate DWARF info for a procedure debug block procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo procToDwarf df prc-  = DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc)+  = DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc)                     , dwName     = case dblSourceTick prc of                          Just s@SourceNote{} -> sourceName s                          _otherwise -> showSDocDump df $ ppr $ dblLabel prc@@ -195,10 +196,10 @@   goodParent _ = True  -- | Generate DWARF info for a block-blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo-blockToDwarf df blk-  = DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk)-                              ++ map (blockToDwarf df) (dblBlocks blk)+blockToDwarf :: DebugBlock -> DwarfInfo+blockToDwarf blk+  = DwarfBlock { dwChildren = concatMap tickToDwarf (dblTicks blk)+                              ++ map blockToDwarf (dblBlocks blk)                , dwLabel    = dblCLabel blk                , dwMarker   = marker                }@@ -207,9 +208,9 @@       | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk       | otherwise                 = Nothing   -- block was optimized out -tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]-tickToDwarf _  (SourceNote ss _) = [DwarfSrcNote ss]-tickToDwarf _ _ = []+tickToDwarf :: Tickish () -> [DwarfInfo]+tickToDwarf  (SourceNote ss _) = [DwarfSrcNote ss]+tickToDwarf _ = []  -- | Generates the data for the debug frame section, which encodes the -- desired stack unwind behaviour for the debugger
compiler/GHC/CmmToAsm/Dwarf/Constants.hs view
@@ -144,20 +144,20 @@  -- * Dwarf section declarations dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,-  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc-dwarfInfoSection    = dwarfSection "info"-dwarfAbbrevSection  = dwarfSection "abbrev"-dwarfLineSection    = dwarfSection "line"-dwarfFrameSection   = dwarfSection "frame"-dwarfGhcSection     = dwarfSection "ghc"-dwarfARangesSection = dwarfSection "aranges"+  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc+dwarfInfoSection    platform = dwarfSection platform "info"+dwarfAbbrevSection  platform = dwarfSection platform "abbrev"+dwarfLineSection    platform = dwarfSection platform "line"+dwarfFrameSection   platform = dwarfSection platform "frame"+dwarfGhcSection     platform = dwarfSection platform "ghc"+dwarfARangesSection platform = dwarfSection platform "aranges" -dwarfSection :: String -> SDoc-dwarfSection name = sdocWithPlatform $ \plat ->-  case platformOS plat of+dwarfSection :: Platform -> String -> SDoc+dwarfSection platform name =+  case platformOS platform of     os | osElfTarget os        -> text "\t.section .debug_" <> text name <> text ",\"\","-          <> sectionType "progbits"+          <> sectionType platform "progbits"        | osMachOTarget os        -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug"        | otherwise
compiler/GHC/CmmToAsm/Dwarf/Types.hs view
@@ -31,9 +31,9 @@ import FastString import Outputable import GHC.Platform-import Unique+import GHC.Types.Unique import GHC.Platform.Reg-import SrcLoc+import GHC.Types.SrcLoc import Util  import GHC.CmmToAsm.Dwarf.Constants@@ -90,8 +90,8 @@ -- | Abbreviation declaration. This explains the binary encoding we -- use for representing 'DwarfInfo'. Be aware that this must be updated -- along with 'pprDwarfInfo'.-pprAbbrevDecls :: Bool -> SDoc-pprAbbrevDecls haveDebugLine =+pprAbbrevDecls :: Platform -> Bool -> SDoc+pprAbbrevDecls platform haveDebugLine =   let mkAbbrev abbr tag chld flds =         let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form         in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$@@ -106,7 +106,7 @@            , (dW_AT_high_pc, dW_FORM_addr)            , (dW_AT_frame_base, dW_FORM_block1)            ]-  in dwarfAbbrevSection $$+  in dwarfAbbrevSection platform $$      ptext dwarfAbbrevLabel <> colon $$      mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes        ([(dW_AT_name,     dW_FORM_string)@@ -142,8 +142,8 @@      pprByte 0  -- | Generate assembly for DWARF data-pprDwarfInfo :: Bool -> DwarfInfo -> SDoc-pprDwarfInfo haveSrc d+pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc+pprDwarfInfo platform haveSrc d   = case d of       DwarfCompileUnit {}  -> hasChildren       DwarfSubprogram {}   -> hasChildren@@ -151,36 +151,36 @@       DwarfSrcNote {}      -> noChildren   where     hasChildren =-        pprDwarfInfoOpen haveSrc d $$-        vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$+        pprDwarfInfoOpen platform haveSrc d $$+        vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$         pprDwarfInfoClose-    noChildren = pprDwarfInfoOpen haveSrc d+    noChildren = pprDwarfInfoOpen platform haveSrc d  -- | Prints assembler data corresponding to DWARF info records. Note -- that the binary format of this is parameterized in @abbrevDecls@ and -- has to be kept in synch.-pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc-pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel+pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc+pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel                                            highLabel lineLbl) =   pprAbbrev DwAbbrCompileUnit   $$ pprString name   $$ pprString producer   $$ pprData4 dW_LANG_Haskell   $$ pprString compDir-  $$ pprWord (ppr lowLabel)-  $$ pprWord (ppr highLabel)+  $$ pprWord platform (ppr lowLabel)+  $$ pprWord platform (ppr highLabel)   $$ if haveSrc-     then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)+     then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)      else empty-pprDwarfInfoOpen _ (DwarfSubprogram _ name label+pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label                                     parent) = sdocWithDynFlags $ \df ->   ppr (mkAsmTempDieLabel label) <> colon   $$ pprAbbrev abbrev   $$ pprString name   $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))   $$ pprFlag (externallyVisibleCLabel label)-  $$ pprWord (ppr label)-  $$ pprWord (ppr $ mkAsmTempEndLabel label)+  $$ pprWord platform (ppr label)+  $$ pprWord platform (ppr $ mkAsmTempEndLabel label)   $$ pprByte 1   $$ pprByte dW_OP_call_frame_cfa   $$ parentValue@@ -188,18 +188,18 @@     abbrev = case parent of Nothing -> DwAbbrSubprogram                             Just _  -> DwAbbrSubprogramWithParent     parentValue = maybe empty pprParentDie parent-    pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel)-pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->+    pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel)+pprDwarfInfoOpen _ _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->   ppr (mkAsmTempDieLabel label) <> colon   $$ pprAbbrev DwAbbrBlockWithoutCode   $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))-pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->+pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->   ppr (mkAsmTempDieLabel label) <> colon   $$ pprAbbrev DwAbbrBlock   $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))-  $$ pprWord (ppr marker)-  $$ pprWord (ppr $ mkAsmTempEndLabel marker)-pprDwarfInfoOpen _ (DwarfSrcNote ss) =+  $$ pprWord platform (ppr marker)+  $$ pprWord platform (ppr $ mkAsmTempEndLabel marker)+pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =   pprAbbrev DwAbbrGhcSrcNote   $$ pprString' (ftext $ srcSpanFile ss)   $$ pprData4 (fromIntegral $ srcSpanStartLine ss)@@ -222,9 +222,9 @@  -- | Print assembler directives corresponding to a DWARF @.debug_aranges@ -- address table entry.-pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc-pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->-  let wordSize = platformWordSizeInBytes plat+pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc+pprDwarfARanges platform arngs unitU =+  let wordSize = platformWordSizeInBytes platform       paddingSize = 4 :: Int       -- header is 12 bytes long.       -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).@@ -234,19 +234,19 @@       initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize   in pprDwWord (ppr initialLength)      $$ pprHalf 2-     $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)-                      (ptext dwarfInfoLabel)+     $$ sectionOffset platform (ppr $ mkAsmTempLabel $ unitU)+                               (ptext dwarfInfoLabel)      $$ pprByte (fromIntegral wordSize)      $$ pprByte 0      $$ pad paddingSize      -- body-     $$ vcat (map pprDwarfARange arngs)+     $$ vcat (map (pprDwarfARange platform) arngs)      -- terminus-     $$ pprWord (char '0')-     $$ pprWord (char '0')+     $$ pprWord platform (char '0')+     $$ pprWord platform (char '0') -pprDwarfARange :: DwarfARange -> SDoc-pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length+pprDwarfARange :: Platform -> DwarfARange -> SDoc+pprDwarfARange platform arng = pprWord platform (ppr $ dwArngStartLabel arng) $$ pprWord platform length   where     length = ppr (dwArngEndLabel arng)              <> char '-' <> ppr (dwArngStartLabel arng)@@ -286,21 +286,20 @@ -- | Header for the @.debug_frame@ section. Here we emit the "Common -- Information Entry" record that establishes general call frame -- parameters and the default stack layout.-pprDwarfFrame :: DwarfFrame -> SDoc-pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}-  = sdocWithPlatform $ \plat ->-    let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")+pprDwarfFrame :: Platform -> DwarfFrame -> SDoc+pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}+  = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")         cieEndLabel = mkAsmTempEndLabel cieLabel         length      = ppr cieEndLabel <> char '-' <> ppr cieStartLabel-        spReg       = dwarfGlobalRegNo plat Sp-        retReg      = dwarfReturnRegNo plat-        wordSize    = platformWordSizeInBytes plat+        spReg       = dwarfGlobalRegNo platform Sp+        retReg      = dwarfReturnRegNo platform+        wordSize    = platformWordSizeInBytes platform         pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc-        pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)+        pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw)          -- Preserve C stack pointer: This necessary to override that default         -- unwinding behavior of setting $sp = CFA.-        preserveSp = case platformArch plat of+        preserveSp = case platformArch platform of           ArchX86    -> pprByte dW_CFA_same_value $$ pprLEBWord 4           ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7           _          -> empty@@ -333,16 +332,16 @@             , pprLEBWord (fromIntegral spReg)             , pprLEBWord 0             ] $$-       wordAlign $$+       wordAlign platform $$        ppr cieEndLabel <> colon $$        -- Procedure unwind tables-       vcat (map (pprFrameProc cieLabel cieInit) procs)+       vcat (map (pprFrameProc platform cieLabel cieInit) procs)  -- | Writes a "Frame Description Entry" for a procedure. This consists -- mainly of referencing the CIE and writing state machine -- instructions to describe how the frame base (CFA) changes.-pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc-pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)+pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc+pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)   = let fdeLabel    = mkAsmTempDerivedLabel procLbl (fsLit "_fde")         fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")         procEnd     = mkAsmTempEndLabel procLbl@@ -353,20 +352,20 @@             , ppr fdeLabel <> colon             , pprData4' (ppr frameLbl <> char '-' <>                          ptext dwarfFrameLabel)    -- Reference to CIE-            , pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer-            , pprWord (ppr procEnd <> char '-' <>-                       ppr procLbl <> ifInfo "+1") -- Block byte length+            , pprWord platform (ppr procLbl <> ifInfo "-1") -- Code pointer+            , pprWord platform (ppr procEnd <> char '-' <>+                                 ppr procLbl <> ifInfo "+1") -- Block byte length             ] $$-       vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$-       wordAlign $$+       vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$+       wordAlign platform $$        ppr fdeEndLabel <> colon  -- | Generates unwind information for a block. We only generate -- instructions where unwind information actually changes. This small -- optimisations saves a lot of space, as subsequent blocks often have -- the same unwind information.-pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc-pprFrameBlock (DwarfFrameBlock hasInfo uws0) =+pprFrameBlock :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc+pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) =     vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0   where     pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc@@ -393,9 +392,8 @@                       needsOffset = firstDecl && hasInfo                       lblDoc = ppr lbl <>                                if needsOffset then text "-1" else empty-                      doc = sdocWithPlatform $ \plat ->-                           pprByte dW_CFA_set_loc $$ pprWord lblDoc $$-                           vcat (map (uncurry $ pprSetUnwind plat) changed)+                      doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$+                            vcat (map (uncurry $ pprSetUnwind platform) changed)                   in (doc, uws)  -- Note [Info Offset]@@ -452,8 +450,8 @@     else pprByte dW_CFA_def_cfa_sf $$          pprLEBRegNo plat s' $$          pprLEBInt o'-pprSetUnwind _    Sp (_, Just uw)-  = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw+pprSetUnwind plat Sp (_, Just uw)+  = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw pprSetUnwind plat g  (_, Just (UwDeref (UwReg Sp o)))   | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case   = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$@@ -465,7 +463,7 @@ pprSetUnwind plat g  (_, Just (UwDeref uw))   = pprByte dW_CFA_expression $$     pprLEBRegNo plat g $$-    pprUnwindExpr True uw+    pprUnwindExpr plat True uw pprSetUnwind plat g  (_, Just (UwReg g' 0))   | g == g'   = pprByte dW_CFA_same_value $$@@ -473,7 +471,7 @@ pprSetUnwind plat g  (_, Just uw)   = pprByte dW_CFA_val_expression $$     pprLEBRegNo plat g $$-    pprUnwindExpr True uw+    pprUnwindExpr plat True uw  -- | Print the register number of the given 'GlobalReg' as an unsigned LEB128 -- encoded number.@@ -483,20 +481,19 @@ -- | Generates a DWARF expression for the given unwind expression. If -- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets -- mentioned.-pprUnwindExpr :: Bool -> UnwindExpr -> SDoc-pprUnwindExpr spIsCFA expr-  = sdocWithPlatform $ \plat ->-    let pprE (UwConst i)+pprUnwindExpr :: Platform -> Bool -> UnwindExpr -> SDoc+pprUnwindExpr platform spIsCFA expr+  = let pprE (UwConst i)           | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)           | otherwise        = pprByte dW_OP_consts $$ pprLEBInt i -- lazy...         pprE (UwReg Sp i) | spIsCFA                              = if i == 0                                then pprByte dW_OP_call_frame_cfa                                else pprE (UwPlus (UwReg Sp 0) (UwConst i))-        pprE (UwReg g i)      = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$+        pprE (UwReg g i)      = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$                                pprLEBInt i         pprE (UwDeref u)      = pprE u $$ pprByte dW_OP_deref-        pprE (UwLabel l)      = pprByte dW_OP_addr $$ pprWord (ppr l)+        pprE (UwLabel l)      = pprByte dW_OP_addr $$ pprWord platform (ppr l)         pprE (UwPlus u1 u2)   = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus         pprE (UwMinus u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus         pprE (UwTimes u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul@@ -514,8 +511,8 @@   -- | Align assembly at (machine) word boundary-wordAlign :: SDoc-wordAlign = sdocWithPlatform $ \plat ->+wordAlign :: Platform -> SDoc+wordAlign plat =   text "\t.align " <> case platformOS plat of     OSDarwin -> case platformWordSize plat of       PW8 -> char '3'@@ -549,11 +546,11 @@  -- | Assembly for a machine word of dynamic data. Depends on the -- architecture we are currently generating code for.-pprWord :: SDoc -> SDoc-pprWord s = (<> s) . sdocWithPlatform $ \plat ->+pprWord :: Platform -> SDoc -> SDoc+pprWord plat s =   case platformWordSize plat of-    PW4 -> text "\t.long "-    PW8 -> text "\t.quad "+    PW4 -> text "\t.long " <> s+    PW8 -> text "\t.quad " <> s  -- | Prints a number in "little endian base 128" format. The idea is -- to optimize for small numbers by stopping once all further bytes@@ -604,8 +601,8 @@ -- us to just reference the target directly, and will figure out on -- their own that we actually need an offset. Finally, Windows has -- a special directive to refer to relative offsets. Fun.-sectionOffset :: SDoc -> SDoc -> SDoc-sectionOffset target section = sdocWithPlatform $ \plat ->+sectionOffset :: Platform -> SDoc -> SDoc -> SDoc+sectionOffset plat target section =   case platformOS plat of     OSDarwin  -> pprDwWord (target <> char '-' <> section)     OSMinGW32 -> text "\t.secrel32 " <> target
compiler/GHC/CmmToAsm/Instr.hs view
@@ -16,15 +16,16 @@  import GhcPrelude +import GHC.Platform import GHC.Platform.Reg  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label-import GHC.Driver.Session import GHC.Cmm hiding (topInfoTable)-import GHC.Platform +import GHC.CmmToAsm.Config+ -- | Holds a list of source and destination registers used by a --      particular instruction. --@@ -132,7 +133,7 @@          -- | An instruction to spill a register into a spill slot.         mkSpillInstr-                :: DynFlags+                :: NCGConfig                 -> Reg          -- ^ the reg to spill                 -> Int          -- ^ the current stack delta                 -> Int          -- ^ spill slot to use@@ -141,7 +142,7 @@          -- | An instruction to reload a register from a spill slot.         mkLoadInstr-                :: DynFlags+                :: NCGConfig                 -> Reg          -- ^ the reg to reload.                 -> Int          -- ^ the current stack delta                 -> Int          -- ^ the spill slot to use
compiler/GHC/CmmToAsm/Monad.hs view
@@ -16,6 +16,7 @@          NatM, -- instance Monad         initNat,+        initConfig,         addImportNat,         addNodeBetweenNat,         addImmediateSuccessorNat,@@ -23,6 +24,8 @@         getUniqueNat,         mapAccumLNat,         setDeltaNat,+        getConfig,+        getPlatform,         getDeltaNat,         getThisModuleNat,         getBlockIdNat,@@ -45,9 +48,11 @@  import GhcPrelude +import GHC.Platform import GHC.Platform.Reg import GHC.CmmToAsm.Format import GHC.CmmToAsm.Reg.Target+import GHC.CmmToAsm.Config  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections@@ -55,11 +60,11 @@ import GHC.Cmm.CLabel           ( CLabel ) import GHC.Cmm.DebugBlock import FastString       ( FastString )-import UniqFM-import UniqSupply-import Unique           ( Unique )+import GHC.Types.Unique.FM+import GHC.Types.Unique.Supply+import GHC.Types.Unique         ( Unique ) import GHC.Driver.Session-import Module+import GHC.Types.Module  import Control.Monad    ( ap ) @@ -69,6 +74,7 @@ import GHC.CmmToAsm.CFG  data NcgImpl statics instr jumpDest = NcgImpl {+    ncgConfig                 :: !NCGConfig,     cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],     generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),     getJumpDestBlockId        :: jumpDest -> Maybe BlockId,@@ -102,6 +108,7 @@                 natm_imports     :: [(CLabel)],                 natm_pic         :: Maybe Reg,                 natm_dflags      :: DynFlags,+                natm_config      :: NCGConfig,                 natm_this_module :: Module,                 natm_modloc      :: ModLocation,                 natm_fileid      :: DwarfFiles,@@ -130,6 +137,7 @@                         , natm_imports = []                         , natm_pic = Nothing                         , natm_dflags = dflags+                        , natm_config = initConfig dflags                         , natm_this_module = this_mod                         , natm_modloc = loc                         , natm_fileid = dwf@@ -137,6 +145,24 @@                         , natm_cfg = cfg                         } +-- | Initialize the native code generator configuration from the DynFlags+initConfig :: DynFlags -> NCGConfig+initConfig dflags = NCGConfig+   { ncgPlatform            = targetPlatform dflags+   , ncgProcAlignment       = cmmProcAlignment dflags+   , ncgDebugLevel          = debugLevel dflags+   , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags+   , ncgPIC                 = positionIndependent dflags+   , ncgSplitSections       = gopt Opt_SplitSections dflags+   , ncgSpillPreallocSize   = rESERVED_C_STACK_BYTES dflags+   , ncgRegsIterative       = gopt Opt_RegsIterative dflags+   , ncgAsmLinting          = gopt Opt_DoAsmLinting dflags+   , ncgDumpRegAllocStages  = dopt Opt_D_dump_asm_regalloc_stages dflags+   , ncgDumpAsmStats        = dopt Opt_D_dump_asm_stats dflags+   , ncgDumpAsmConflicts    = dopt Opt_D_dump_asm_conflicts dflags+   }++ initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m         = case unNat m init_st of { (r,st) -> (r,st) }@@ -232,8 +258,9 @@ -- | Place `succ` after `block` and change any edges --   block -> X to `succ` -> X addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()-addImmediateSuccessorNat block succ-        = updateCfgNat (addImmediateSuccessor block succ)+addImmediateSuccessorNat block succ = do+   dflags <- getDynFlags+   updateCfgNat (addImmediateSuccessor dflags block succ)  getBlockIdNat :: NatM BlockId getBlockIdNat@@ -249,16 +276,16 @@ getNewRegNat :: Format -> NatM Reg getNewRegNat rep  = do u <- getUniqueNat-      dflags <- getDynFlags-      return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)+      platform <- getPlatform+      return (RegVirtual $ targetMkVirtualReg platform u rep)   getNewRegPairNat :: Format -> NatM (Reg,Reg) getNewRegPairNat rep  = do u <- getUniqueNat-      dflags <- getDynFlags-      let vLo = targetMkVirtualReg (targetPlatform dflags) u rep-      let lo  = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep+      platform <- getPlatform+      let vLo = targetMkVirtualReg platform u rep+      let lo  = RegVirtual $ targetMkVirtualReg platform u rep       let hi  = RegVirtual $ getHiVirtualRegFromLo vLo       return (lo, hi) @@ -281,6 +308,14 @@ getModLoc :: NatM ModLocation getModLoc         = NatM $ \ st -> (natm_modloc st, st)++-- | Get native code generator configuration+getConfig :: NatM NCGConfig+getConfig = NatM $ \st -> (natm_config st, st)++-- | Get target platform from native code generator configuration+getPlatform :: NatM Platform+getPlatform = ncgPlatform <$> getConfig  getFileId :: FastString -> NatM Int getFileId f = NatM $ \st ->
compiler/GHC/CmmToAsm/PIC.hs view
@@ -57,6 +57,7 @@ import GHC.CmmToAsm.Instr import GHC.Platform.Reg import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Config   import GHC.Cmm.Dataflow.Collections@@ -69,8 +70,8 @@ import GHC.Cmm.CLabel           ( mkForeignLabel )  -import BasicTypes-import Module+import GHC.Types.Basic+import GHC.Types.Module  import Outputable @@ -119,10 +120,12 @@    | otherwise   = do this_mod <- getThisModule+       let config   = initConfig dflags+           platform = ncgPlatform config        case howToAccessLabel                 dflags-                (platformArch $ targetPlatform dflags)-                (platformOS   $ targetPlatform dflags)+                (platformArch platform)+                (platformOS   platform)                 this_mod                 referenceKind lbl of @@ -134,11 +137,11 @@         AccessViaSymbolPtr -> do               let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl               addImport symbolPtr-              return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags)+              return $ CmmLoad (cmmMakePicReference config symbolPtr) (bWord platform)          AccessDirectly -> case referenceKind of                 -- for data, we might have to make some calculations:-              DataReference -> return $ cmmMakePicReference dflags lbl+              DataReference -> return $ cmmMakePicReference config lbl                 -- all currently supported processors support                 -- PC-relative branch and call instructions,                 -- so just jump there if it's a call or a jump@@ -152,42 +155,44 @@ -- offset to our base register; this offset is calculated by -- the function picRelative in the platform-dependent part below. -cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr-cmmMakePicReference dflags lbl+cmmMakePicReference :: NCGConfig -> CLabel -> CmmExpr+cmmMakePicReference config lbl+  -- Windows doesn't need PIC,+  -- everything gets relocated at runtime+  | OSMinGW32 <- platformOS platform+  = CmmLit $ CmmLabel lbl -        -- Windows doesn't need PIC,-        -- everything gets relocated at runtime-        | OSMinGW32 <- platformOS $ targetPlatform dflags-        = CmmLit $ CmmLabel lbl+  | OSAIX <- platformOS platform+  = CmmMachOp (MO_Add W32)+          [ CmmReg (CmmGlobal PicBaseReg)+          , CmmLit $ picRelative (wordWidth platform)+                          (platformArch platform)+                          (platformOS   platform)+                          lbl ] -        | OSAIX <- platformOS $ targetPlatform dflags-        = CmmMachOp (MO_Add W32)-                [ CmmReg (CmmGlobal PicBaseReg)-                , CmmLit $ picRelative dflags-                                (platformArch   $ targetPlatform dflags)-                                (platformOS     $ targetPlatform dflags)-                                lbl ]+  -- both ABI versions default to medium code model+  | ArchPPC_64 _ <- platformArch platform+  = CmmMachOp (MO_Add W32) -- code model medium+          [ CmmReg (CmmGlobal PicBaseReg)+          , CmmLit $ picRelative (wordWidth platform)+                          (platformArch platform)+                          (platformOS   platform)+                          lbl ] -        -- both ABI versions default to medium code model-        | ArchPPC_64 _ <- platformArch $ targetPlatform dflags-        = CmmMachOp (MO_Add W32) -- code model medium-                [ CmmReg (CmmGlobal PicBaseReg)-                , CmmLit $ picRelative dflags-                                (platformArch   $ targetPlatform dflags)-                                (platformOS     $ targetPlatform dflags)-                                lbl ]+  | (ncgPIC config || ncgExternalDynamicRefs config)+      && absoluteLabel lbl+  = CmmMachOp (MO_Add (wordWidth platform))+          [ CmmReg (CmmGlobal PicBaseReg)+          , CmmLit $ picRelative (wordWidth platform)+                          (platformArch platform)+                          (platformOS   platform)+                          lbl ] -        | (positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags)-            && absoluteLabel lbl-        = CmmMachOp (MO_Add (wordWidth dflags))-                [ CmmReg (CmmGlobal PicBaseReg)-                , CmmLit $ picRelative dflags-                                (platformArch   $ targetPlatform dflags)-                                (platformOS     $ targetPlatform dflags)-                                lbl ]+  | otherwise+  = CmmLit $ CmmLabel lbl+  where+    platform = ncgPlatform config -        | otherwise-        = CmmLit $ CmmLabel lbl   absoluteLabel :: CLabel -> Bool@@ -404,7 +409,7 @@ -- | Says what we have to add to our 'PIC base register' in order to --      get the address of a label. -picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit+picRelative :: Width -> Arch -> OS -> CLabel -> CmmLit  -- Darwin, but not x86_64: -- The PIC base register points to the PIC base label at the beginning@@ -413,15 +418,15 @@ -- We have already made sure that all labels that are not from the current -- module are accessed indirectly ('as' can't calculate differences between -- undefined labels).-picRelative dflags arch OSDarwin lbl+picRelative width arch OSDarwin lbl         | arch /= ArchX86_64-        = CmmLabelDiffOff lbl mkPicBaseLabel 0 (wordWidth dflags)+        = CmmLabelDiffOff lbl mkPicBaseLabel 0 width  -- On AIX we use an indirect local TOC anchored by 'gotLabel'. -- This way we use up only one global TOC entry per compilation-unit -- (this is quite similar to GCC's @-mminimal-toc@ compilation mode)-picRelative dflags _ OSAIX lbl-        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)+picRelative width _ OSAIX lbl+        = CmmLabelDiffOff lbl gotLabel 0 width  -- PowerPC Linux: -- The PIC base register points to our fake GOT. Use a label difference@@ -429,9 +434,9 @@ -- We have made sure that *everything* is accessed indirectly, so this -- is only used for offsets from the GOT to symbol pointers inside the -- GOT.-picRelative dflags ArchPPC os lbl+picRelative width ArchPPC os lbl         | osElfTarget os-        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)+        = CmmLabelDiffOff lbl gotLabel 0 width   -- Most Linux versions:@@ -453,14 +458,14 @@           in    result  picRelative _ _ _ _-        = panic "PositionIndependentCode.picRelative undefined for this platform"+        = panic "GHC.CmmToAsm.PIC.picRelative undefined for this platform"    -------------------------------------------------------------------------------- -needImportedSymbols :: DynFlags -> Arch -> OS -> Bool-needImportedSymbols dflags arch os+needImportedSymbols :: NCGConfig -> Bool+needImportedSymbols config         | os    == OSDarwin         , arch  /= ArchX86_64         = True@@ -471,7 +476,7 @@         -- PowerPC Linux: -fPIC or -dynamic         | osElfTarget os         , arch  == ArchPPC-        = positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags+        = ncgPIC config || ncgExternalDynamicRefs config          -- PowerPC 64 Linux: always         | osElfTarget os@@ -481,11 +486,15 @@         -- i386 (and others?): -dynamic but not -fPIC         | osElfTarget os         , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2-        = gopt Opt_ExternalDynamicRefs dflags &&-          not (positionIndependent dflags)+        = ncgExternalDynamicRefs config &&+          not (ncgPIC config)          | otherwise         = False+   where+      platform = ncgPlatform config+      arch     = platformArch platform+      os       = platformOS   platform  -- gotLabel -- The label used to refer to our "fake GOT" from@@ -499,13 +508,16 @@   ---------------------------------------------------------------------------------+-- Emit GOT declaration+-- Output whatever needs to be output once per .s file.+-- -- We don't need to declare any offset tables. -- However, for PIC on x86, we need a small helper function.-pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc-pprGotDeclaration dflags ArchX86 OSDarwin-        | positionIndependent dflags-        = vcat [+pprGotDeclaration :: NCGConfig -> SDoc+pprGotDeclaration config = case (arch,os) of+   (ArchX86, OSDarwin)+        | ncgPIC config+        -> vcat [                 text ".section __TEXT,__textcoal_nt,coalesced,no_toc",                 text ".weak_definition ___i686.get_pc_thunk.ax",                 text ".private_extern ___i686.get_pc_thunk.ax",@@ -513,48 +525,49 @@                 text "\tmovl (%esp), %eax",                 text "\tret" ] -pprGotDeclaration _ _ OSDarwin-        = empty+   (_, OSDarwin) -> empty --- Emit XCOFF TOC section-pprGotDeclaration _ _ OSAIX-        = vcat $ [ text ".toc"-                 , text ".tc ghc_toc_table[TC],.LCTOC1"-                 , text ".csect ghc_toc_table[RW]"-                   -- See Note [.LCTOC1 in PPC PIC code]-                 , text ".set .LCTOC1,$+0x8000"-                 ]+   -- Emit XCOFF TOC section+   (_, OSAIX)+        -> vcat $ [ text ".toc"+                  , text ".tc ghc_toc_table[TC],.LCTOC1"+                  , text ".csect ghc_toc_table[RW]"+                    -- See Note [.LCTOC1 in PPC PIC code]+                  , text ".set .LCTOC1,$+0x8000"+                  ]  --- PPC 64 ELF v1 needs a Table Of Contents (TOC)-pprGotDeclaration _ (ArchPPC_64 ELF_V1) _-        = text ".section \".toc\",\"aw\""--- In ELF v2 we also need to tell the assembler that we want ABI--- version 2. This would normally be done at the top of the file--- right after a file directive, but I could not figure out how--- to do that.-pprGotDeclaration _ (ArchPPC_64 ELF_V2) _-        = vcat [ text ".abiversion 2",-                 text ".section \".toc\",\"aw\""-               ]+   -- PPC 64 ELF v1 needs a Table Of Contents (TOC)+   (ArchPPC_64 ELF_V1, _)+        -> text ".section \".toc\",\"aw\"" --- Emit GOT declaration--- Output whatever needs to be output once per .s file.-pprGotDeclaration dflags arch os+   -- In ELF v2 we also need to tell the assembler that we want ABI+   -- version 2. This would normally be done at the top of the file+   -- right after a file directive, but I could not figure out how+   -- to do that.+   (ArchPPC_64 ELF_V2, _)+        -> vcat [ text ".abiversion 2",+                  text ".section \".toc\",\"aw\""+                ]++   (arch, os)         | osElfTarget os         , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2-        , not (positionIndependent dflags)-        = empty+        , not (ncgPIC config)+        -> empty          | osElfTarget os         , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2-        = vcat [+        -> vcat [                 -- See Note [.LCTOC1 in PPC PIC code]                 text ".section \".got2\",\"aw\"",                 text ".LCTOC1 = .+32768" ] -pprGotDeclaration _ _ _-        = panic "pprGotDeclaration: no match"+   _ -> panic "pprGotDeclaration: no match"+ where+   platform = ncgPlatform config+   arch     = platformArch platform+   os       = platformOS   platform   --------------------------------------------------------------------------------@@ -563,43 +576,44 @@ -- and one for non-PIC. -- -pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc-pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_arch = ArchX86, platformMini_os = OSDarwin } }) importedLbl+pprImportedSymbol :: DynFlags -> NCGConfig -> CLabel -> SDoc+pprImportedSymbol dflags config importedLbl = case (arch,os) of+   (ArchX86, OSDarwin)         | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl-        = case positionIndependent dflags of-           False ->-            vcat [-                text ".symbol_stub",-                text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),-                    text "\t.indirect_symbol" <+> pprCLabel dflags lbl,-                    text "\tjmp *L" <> pprCLabel dflags lbl-                        <> text "$lazy_ptr",-                text "L" <> pprCLabel dflags lbl-                    <> text "$stub_binder:",-                    text "\tpushl $L" <> pprCLabel dflags lbl-                        <> text "$lazy_ptr",-                    text "\tjmp dyld_stub_binding_helper"-            ]-           True ->-            vcat [-                text ".section __TEXT,__picsymbolstub2,"-                    <> text "symbol_stubs,pure_instructions,25",-                text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),-                    text "\t.indirect_symbol" <+> pprCLabel dflags lbl,-                    text "\tcall ___i686.get_pc_thunk.ax",-                text "1:",-                    text "\tmovl L" <> pprCLabel dflags lbl-                        <> text "$lazy_ptr-1b(%eax),%edx",-                    text "\tjmp *%edx",-                text "L" <> pprCLabel dflags lbl-                    <> text "$stub_binder:",-                    text "\tlea L" <> pprCLabel dflags lbl-                        <> text "$lazy_ptr-1b(%eax),%eax",-                    text "\tpushl %eax",-                    text "\tjmp dyld_stub_binding_helper"-            ]-          $+$ vcat [        text ".section __DATA, __la_sym_ptr"-                    <> (if positionIndependent dflags then int 2 else int 3)+        -> if not pic+             then+              vcat [+                  text ".symbol_stub",+                  text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),+                      text "\t.indirect_symbol" <+> pprCLabel dflags lbl,+                      text "\tjmp *L" <> pprCLabel dflags lbl+                          <> text "$lazy_ptr",+                  text "L" <> pprCLabel dflags lbl+                      <> text "$stub_binder:",+                      text "\tpushl $L" <> pprCLabel dflags lbl+                          <> text "$lazy_ptr",+                      text "\tjmp dyld_stub_binding_helper"+              ]+             else+              vcat [+                  text ".section __TEXT,__picsymbolstub2,"+                      <> text "symbol_stubs,pure_instructions,25",+                  text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),+                      text "\t.indirect_symbol" <+> pprCLabel dflags lbl,+                      text "\tcall ___i686.get_pc_thunk.ax",+                  text "1:",+                      text "\tmovl L" <> pprCLabel dflags lbl+                          <> text "$lazy_ptr-1b(%eax),%edx",+                      text "\tjmp *%edx",+                  text "L" <> pprCLabel dflags lbl+                      <> text "$stub_binder:",+                      text "\tlea L" <> pprCLabel dflags lbl+                          <> text "$lazy_ptr-1b(%eax),%eax",+                      text "\tpushl %eax",+                      text "\tjmp dyld_stub_binding_helper"+              ]+           $+$ vcat [        text ".section __DATA, __la_sym_ptr"+                    <> (if pic then int 2 else int 3)                     <> text ",lazy_symbol_pointers",                 text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"),                     text "\t.indirect_symbol" <+> pprCLabel dflags lbl,@@ -607,71 +621,68 @@                     <> text "$stub_binder"]          | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl-        = vcat [+        -> vcat [                 text ".non_lazy_symbol_pointer",                 char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:",                 text "\t.indirect_symbol" <+> pprCLabel dflags lbl,                 text "\t.long\t0"]          | otherwise-        = empty+        -> empty +   (_, OSDarwin) -> empty -pprImportedSymbol _ (Platform { platformMini = PlatformMini { platformMini_os = OSDarwin } }) _-        = empty --- XCOFF / AIX------ Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To--- workaround the limitation of a global TOC we use an indirect TOC--- with the label `ghc_toc_table`.------ See also GCC's `-mminimal-toc` compilation mode or--- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/------ NB: No DSO-support yet+   -- XCOFF / AIX+   --+   -- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To+   -- workaround the limitation of a global TOC we use an indirect TOC+   -- with the label `ghc_toc_table`.+   --+   -- See also GCC's `-mminimal-toc` compilation mode or+   -- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/+   --+   -- NB: No DSO-support yet -pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_os = OSAIX } }) importedLbl-        = case dynamicLinkerLabelInfo importedLbl of+   (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)               -> vcat [                    text "LC.." <> pprCLabel dflags lbl <> char ':',                    text "\t.long" <+> pprCLabel dflags lbl ]             _ -> empty --- ELF / Linux------ In theory, we don't need to generate any stubs or symbol pointers--- by hand for Linux.------ Reality differs from this in two areas.------ 1) If we just use a dynamically imported symbol directly in a read-only---    section of the main executable (as GCC does), ld generates R_*_COPY---    relocations, which are fundamentally incompatible with reversed info---    tables. Therefore, we need a table of imported addresses in a writable---    section.---    The "official" GOT mechanism (label@got) isn't intended to be used---    in position dependent code, so we have to create our own "fake GOT"---    when not Opt_PIC && WayDyn `elem` ways dflags.------ 2) PowerPC Linux is just plain broken.---    While it's theoretically possible to use GOT offsets larger---    than 16 bit, the standard crt*.o files don't, which leads to---    linker errors as soon as the GOT size exceeds 16 bit.---    Also, the assembler doesn't support @gotoff labels.---    In order to be able to use a larger GOT, we have to circumvent the---    entire GOT mechanism and do it ourselves (this is also what GCC does).+   -- ELF / Linux+   --+   -- In theory, we don't need to generate any stubs or symbol pointers+   -- by hand for Linux.+   --+   -- Reality differs from this in two areas.+   --+   -- 1) If we just use a dynamically imported symbol directly in a read-only+   --    section of the main executable (as GCC does), ld generates R_*_COPY+   --    relocations, which are fundamentally incompatible with reversed info+   --    tables. Therefore, we need a table of imported addresses in a writable+   --    section.+   --    The "official" GOT mechanism (label@got) isn't intended to be used+   --    in position dependent code, so we have to create our own "fake GOT"+   --    when not Opt_PIC && WayDyn `elem` ways dflags.+   --+   -- 2) PowerPC Linux is just plain broken.+   --    While it's theoretically possible to use GOT offsets larger+   --    than 16 bit, the standard crt*.o files don't, which leads to+   --    linker errors as soon as the GOT size exceeds 16 bit.+   --    Also, the assembler doesn't support @gotoff labels.+   --    In order to be able to use a larger GOT, we have to circumvent the+   --    entire GOT mechanism and do it ourselves (this is also what GCC does).  --- When needImportedSymbols is defined,--- the NCG will keep track of all DynamicLinkerLabels it uses--- and output each of them using pprImportedSymbol.+   -- When needImportedSymbols is defined,+   -- the NCG will keep track of all DynamicLinkerLabels it uses+   -- and output each of them using pprImportedSymbol. -pprImportedSymbol dflags platform@(Platform { platformMini = PlatformMini { platformMini_arch = ArchPPC_64 _ } })-                  importedLbl-        | osElfTarget (platformOS platform)-        = case dynamicLinkerLabelInfo importedLbl of+   (ArchPPC_64 _, _)+        | osElfTarget os+        -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)               -> vcat [                    text ".section \".toc\", \"aw\"",@@ -679,11 +690,10 @@                    text "\t.quad" <+> pprCLabel dflags lbl ]             _ -> empty -pprImportedSymbol dflags platform importedLbl-        | osElfTarget (platformOS platform)-        = case dynamicLinkerLabelInfo importedLbl of+   _ | osElfTarget os+     -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)-              -> let symbolSize = case wordWidth dflags of+              -> let symbolSize = case ncgWordWidth config of                          W32 -> sLit "\t.long"                          W64 -> sLit "\t.quad"                          _ -> panic "Unknown wordRep in pprImportedSymbol"@@ -696,8 +706,12 @@             -- PLT code stubs are generated automatically by the dynamic linker.             _ -> empty -pprImportedSymbol _ _ _-        = panic "PIC.pprImportedSymbol: no match"+   _ -> panic "PIC.pprImportedSymbol: no match"+ where+   platform = ncgPlatform config+   arch     = platformArch platform+   os       = platformOS   platform+   pic      = ncgPIC config  -------------------------------------------------------------------------------- -- Generate code to calculate the address that should be put in the
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -33,11 +33,12 @@ import GHC.CmmToAsm.Monad    ( NatM, getNewRegNat, getNewLabelNat    , getBlockIdNat, getPicBaseNat, getNewRegPairNat-   , getPicBaseMaybeNat+   , getPicBaseMaybeNat, getPlatform, initConfig    ) import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Config import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target@@ -62,7 +63,7 @@ import Data.Bits import Data.Word -import BasicTypes+import GHC.Types.Basic import FastString import Util @@ -81,11 +82,11 @@ cmmTopCodeGen (CmmProc info lab live graph) = do   let blocks = toBlockListEntryFirst graph   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks-  dflags <- getDynFlags+  platform <- getPlatform   let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)       tops = proc : concat statics-      os   = platformOS $ targetPlatform dflags-      arch = platformArch $ targetPlatform dflags+      os   = platformOS platform+      arch = platformArch platform   case arch of     ArchPPC | os == OSAIX -> return tops             | otherwise -> do@@ -149,6 +150,7 @@ stmtToInstrs :: CmmNode e x -> NatM InstrBlock stmtToInstrs stmt = do   dflags <- getDynFlags+  platform <- getPlatform   case stmt of     CmmComment s   -> return (unitOL (COMMENT s))     CmmTick {}     -> return nilOL@@ -156,18 +158,18 @@      CmmAssign reg src       | isFloatType ty -> assignReg_FltCode format reg src-      | target32Bit (targetPlatform dflags) &&+      | target32Bit platform &&         isWord64 ty    -> assignReg_I64Code      reg src       | otherwise      -> assignReg_IntCode format reg src-        where ty = cmmRegType dflags reg+        where ty = cmmRegType platform reg               format = cmmTypeFormat ty      CmmStore addr src       | isFloatType ty -> assignMem_FltCode format addr src-      | target32Bit (targetPlatform dflags) &&+      | target32Bit platform &&         isWord64 ty    -> assignMem_I64Code      addr src       | otherwise      -> assignMem_IntCode format addr src-        where ty = cmmExprType dflags src+        where ty = cmmExprType platform src               format = cmmTypeFormat ty      CmmUnsafeForeignCall target result_regs args@@ -178,18 +180,14 @@       b1 <- genCondJump true arg prediction       b2 <- genBranch false       return (b1 `appOL` b2)-    CmmSwitch arg ids -> do dflags <- getDynFlags-                            genSwitch dflags arg ids+    CmmSwitch arg ids -> genSwitch dflags arg ids     CmmCall { cml_target = arg-            , cml_args_regs = gregs } -> do-                                dflags <- getDynFlags-                                genJump arg (jumpRegs dflags gregs)+            , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)     _ ->       panic "stmtToInstrs: statement should have been cps'd away" -jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]-jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]-    where platform = targetPlatform dflags+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.@@ -230,8 +228,8 @@         -- platform.  Hence ...  -- | Convert a BlockId to some CmmStatic data-jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic-jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))+jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic+jumpTableEntry config Nothing   = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)     where blockLabel = blockLbl blockid @@ -242,10 +240,10 @@  -- Expand CmmRegOff.  ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff?-mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr-mangleIndexTree dflags (CmmRegOff reg off)+mangleIndexTree :: Platform -> CmmExpr -> CmmExpr+mangleIndexTree platform (CmmRegOff reg off)   = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-  where width = typeWidth (cmmRegType dflags reg)+  where width = typeWidth (cmmRegType platform reg)  mangleIndexTree _ _         = panic "PPC.CodeGen.mangleIndexTree: no match"@@ -399,67 +397,68 @@     return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)                          rlo iselExpr64 expr-   = pprPanic "iselExpr64(powerpc)" (pprExpr expr)+   = do+     platform <- getPlatform+     pprPanic "iselExpr64(powerpc)" (pprExpr platform expr)    getRegister :: CmmExpr -> NatM Register getRegister e = do dflags <- getDynFlags-                   getRegister' dflags e+                   getRegister' dflags (targetPlatform dflags) e -getRegister' :: DynFlags -> CmmExpr -> NatM Register+getRegister' :: DynFlags -> Platform -> CmmExpr -> NatM Register -getRegister' dflags (CmmReg (CmmGlobal PicBaseReg))-  | OSAIX <- platformOS (targetPlatform dflags) = do+getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg))+  | OSAIX <- platformOS platform = do         let code dst = toOL [ LD II32 dst tocAddr ]             tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))         return (Any II32 code)-  | target32Bit (targetPlatform dflags) = do-      reg <- getPicBaseNat $ archWordFormat (target32Bit (targetPlatform dflags))-      return (Fixed (archWordFormat (target32Bit (targetPlatform dflags)))+  | target32Bit platform = do+      reg <- getPicBaseNat $ archWordFormat (target32Bit platform)+      return (Fixed (archWordFormat (target32Bit platform))                     reg nilOL)   | otherwise = return (Fixed II64 toc nilOL) -getRegister' dflags (CmmReg reg)-  = return (Fixed (cmmTypeFormat (cmmRegType dflags reg))-                  (getRegisterReg (targetPlatform dflags) reg) nilOL)+getRegister' _ platform (CmmReg reg)+  = return (Fixed (cmmTypeFormat (cmmRegType platform reg))+                  (getRegisterReg platform reg) nilOL) -getRegister' dflags tree@(CmmRegOff _ _)-  = getRegister' dflags (mangleIndexTree dflags tree)+getRegister' dflags platform tree@(CmmRegOff _ _)+  = getRegister' dflags platform (mangleIndexTree platform tree)      -- for 32-bit architectures, support some 64 -> 32 bit conversions:     -- TO_W_(x), TO_W_(x >> 32) -getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32)+getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32)                      [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | target32Bit (targetPlatform dflags) = do+ | target32Bit platform = do   ChildCode64 code rlo <- iselExpr64 x   return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32)+getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32)                      [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | target32Bit (targetPlatform dflags) = do+ | target32Bit platform = do   ChildCode64 code rlo <- iselExpr64 x   return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x])- | target32Bit (targetPlatform dflags) = do+getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [x])+ | target32Bit platform = do   ChildCode64 code rlo <- iselExpr64 x   return $ Fixed II32 rlo code -getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x])- | target32Bit (targetPlatform dflags) = do+getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x])+ | target32Bit platform = do   ChildCode64 code rlo <- iselExpr64 x   return $ Fixed II32 rlo code -getRegister' dflags (CmmLoad mem pk)+getRegister' _ platform (CmmLoad mem pk)  | not (isWord64 pk) = do-        let platform = targetPlatform dflags         Amode addr addr_code <- getAmode D mem         let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)                        addr_code `snocOL` LD format dst addr         return (Any format code)- | not (target32Bit (targetPlatform dflags)) = do+ | not (target32Bit platform) = do         Amode addr addr_code <- getAmode DS mem         let code dst = addr_code `snocOL` LD II64 dst addr         return (Any II64 code)@@ -467,50 +466,50 @@           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)) -getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps+getRegister' dflags platform (CmmMachOp mop [x]) -- unary MachOps   = case mop of       MO_Not rep   -> triv_ucode_int rep NOT @@ -540,19 +539,19 @@         triv_ucode_float width instr = trivialUCode (floatFormat  width) instr x          conversionNop new_format expr-            = do e_code <- getRegister' dflags expr+            = do e_code <- getRegister' dflags platform expr                  return (swizzleRegisterRep e_code new_format)          clearLeft from to             = do (src1, code1) <- getSomeReg x-                 let arch_fmt  = intFormat (wordWidth dflags)-                     arch_bits = widthInBits (wordWidth dflags)+                 let arch_fmt  = intFormat (wordWidth platform)+                     arch_bits = widthInBits (wordWidth platform)                      size      = widthInBits from                      code dst  = code1 `snocOL`                                  CLRLI arch_fmt dst src1 (arch_bits - size)                  return (Any (intFormat to) code) -getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps+getRegister' _ _ (CmmMachOp mop [x, y]) -- dyadic PrimOps   = case mop of       MO_F_Eq _ -> condFltReg EQQ x y       MO_F_Ne _ -> condFltReg NE  x y@@ -656,16 +655,15 @@       return (Any fmt code)  -getRegister' _ (CmmLit (CmmInt i rep))+getRegister' _ _ (CmmLit (CmmInt i rep))   | Just imm <- makeImmediate rep True i   = let         code dst = unitOL (LI dst imm)     in         return (Any (intFormat rep) code) -getRegister' _ (CmmLit (CmmFloat f frep)) = do+getRegister' dflags _ (CmmLit (CmmFloat f frep)) = do     lbl <- getNewLabelNat-    dflags <- getDynFlags     dynRef <- cmmMakeDynamicReference dflags DataReference lbl     Amode addr addr_code <- getAmode D dynRef     let format = floatFormat frep@@ -675,9 +673,9 @@             `consOL` (addr_code `snocOL` LD format dst addr)     return (Any format code) -getRegister' dflags (CmmLit lit)-  | target32Bit (targetPlatform dflags)-  = let rep = cmmLitType dflags lit+getRegister' dflags platform (CmmLit lit)+  | target32Bit platform+  = let rep = cmmLitType platform lit         imm = litToImm lit         code dst = toOL [               LIS dst (HA imm),@@ -686,17 +684,16 @@     in return (Any (cmmTypeFormat rep) code)   | otherwise   = do lbl <- getNewLabelNat-       dflags <- getDynFlags        dynRef <- cmmMakeDynamicReference dflags DataReference lbl        Amode addr addr_code <- getAmode D dynRef-       let rep = cmmLitType dflags lit+       let rep = cmmLitType platform lit            format = cmmTypeFormat rep            code dst =             LDATA (Section ReadOnlyData lbl) (RawCmmStatics lbl [CmmStaticLit lit])             `consOL` (addr_code `snocOL` LD format dst addr)        return (Any format code) -getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other)+getRegister' _ platform other = pprPanic "getRegister(ppc)" (pprExpr platform other)      -- extend?Rep: wrap integer expression of type `from`     -- in a conversion to `to`@@ -742,8 +739,8 @@  getAmode :: InstrForm -> CmmExpr -> NatM Amode getAmode inf tree@(CmmRegOff _ _)-  = do dflags <- getDynFlags-       getAmode inf (mangleIndexTree dflags tree)+  = do platform <- getPlatform+       getAmode inf (mangleIndexTree platform tree)  getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])   | Just off <- makeImmediate W32 True (-i)@@ -801,11 +798,11 @@    -- (needed for PIC) getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit])   = do-        dflags <- getDynFlags+        platform <- getPlatform         (src, srcCode) <- getSomeReg x         let imm = litToImm lit         case () of-            _ | OSAIX <- platformOS (targetPlatform dflags)+            _ | OSAIX <- platformOS platform               , isCmmLabelType lit ->                     -- HA16/LO16 relocations on labels not supported on AIX                     return (Amode (AddrRegImm src imm) srcCode)@@ -821,8 +818,8 @@  getAmode _ (CmmLit lit)   = do-        dflags <- getDynFlags-        case platformArch $ targetPlatform dflags of+        platform <- getPlatform+        case platformArch platform of              ArchPPC -> do                  tmp <- getNewRegNat II32                  let imm = litToImm lit@@ -911,8 +908,8 @@  condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode condIntCode cond width x y = do-  dflags <- getDynFlags-  condIntCode' (target32Bit (targetPlatform dflags)) cond width x y+  platform <- getPlatform+  condIntCode' (target32Bit platform) cond width x y  condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode @@ -1708,12 +1705,13 @@                        `snocOL` BCTRL usedRegs                        `appOL`  codeAfter)     where-        platform = targetPlatform dflags+        config   = initConfig dflags+        platform = ncgPlatform config          uses_pic_base_implicitly = do             -- See Note [implicit register in PPC PIC code]             -- on why we claim to use PIC register here-            when (positionIndependent dflags && target32Bit platform) $ do+            when (ncgPIC config && target32Bit platform) $ do                 _ <- getPicBaseNat $ archWordFormat True                 return () @@ -1739,7 +1737,7 @@                                         argReps                                 _ -> panic "genCall': unknown calling conv." -        argReps = map (cmmExprType dflags) args+        argReps = map (cmmExprType platform) args         (argHints, _) = foreignTargetHints target          roundTo a x | x `mod` a == 0 = x@@ -1749,13 +1747,13 @@          -- TODO: Do not create a new stack frame if delta is too large.         move_sp_down finalStack-               | delta > stackFrameHeaderSize dflags =+               | delta > stackFrameHeaderSize platform =                         toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))),                               DELTA (-delta)]                | otherwise = nilOL                where delta = stackDelta finalStack         move_sp_up finalStack-               | delta > stackFrameHeaderSize dflags =+               | delta > stackFrameHeaderSize platform =                         toOL [ADD sp sp (RIImm (ImmInt delta)),                               DELTA 0]                | otherwise = nilOL@@ -1851,10 +1849,10 @@                               accumUsed             where                 arg_pro-                   | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth dflags)) [arg]+                   | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth platform)) [arg]                    | otherwise      = arg                 format_pro-                   | isBitsType rep = intFormat (wordWidth dflags)+                   | isBitsType rep = intFormat (wordWidth platform)                    | otherwise      = cmmTypeFormat rep                 conv_op = case hint of                             SignedHint -> MO_SS_Conv@@ -1937,11 +1935,11 @@                 [dest]                     | reduceToFF32 && isFloat32 rep   -> unitOL (FRSP r_dest f1)                     | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)-                    | isWord64 rep && target32Bit (targetPlatform dflags)+                    | isWord64 rep && target32Bit platform                        -> toOL [MR (getHiVRegFromLo r_dest) r3,                                 MR r_dest r4]                     | otherwise -> unitOL (MR r_dest r3)-                    where rep = cmmRegType dflags (CmmLocal dest)+                    where rep = cmmRegType platform (CmmLocal dest)                           r_dest = getRegisterReg platform (CmmLocal dest)                 _ -> panic "genCCall' moveResult: Bad dest_regs" @@ -2045,11 +2043,11 @@  genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock genSwitch dflags expr targets-  | OSAIX <- platformOS (targetPlatform dflags)+  | OSAIX <- platformOS platform   = do-        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)-        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags-            sha = if target32Bit $ targetPlatform dflags then 2 else 3+        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)+        let fmt = archWordFormat $ target32Bit platform+            sha = if target32Bit platform then 2 else 3         tmp <- getNewRegNat fmt         lbl <- getNewLabelNat         dynRef <- cmmMakeDynamicReference dflags DataReference lbl@@ -2062,11 +2060,11 @@                     ]         return code -  | (positionIndependent dflags) || (not $ target32Bit $ targetPlatform dflags)+  | (ncgPIC config) || (not $ target32Bit platform)   = do-        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)-        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags-            sha = if target32Bit $ targetPlatform dflags then 2 else 3+        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)+        let fmt = archWordFormat $ target32Bit platform+            sha = if target32Bit platform then 2 else 3         tmp <- getNewRegNat fmt         lbl <- getNewLabelNat         dynRef <- cmmMakeDynamicReference dflags DataReference lbl@@ -2081,9 +2079,9 @@         return code   | otherwise   = do-        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)-        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags-            sha = if target32Bit $ targetPlatform dflags then 2 else 3+        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)+        let fmt = archWordFormat $ target32Bit platform+            sha = if target32Bit platform then 2 else 3         tmp <- getNewRegNat fmt         lbl <- getNewLabelNat         let code = e_code `appOL` toOL [@@ -2094,21 +2092,23 @@                             BCTR ids (Just lbl) []                     ]         return code-  where (offset, ids) = switchTargetsToTable targets+  where+    (offset, ids) = switchTargetsToTable targets+    platform      = ncgPlatform config+    config        = initConfig dflags -generateJumpTableForInstr :: DynFlags -> Instr+generateJumpTableForInstr :: NCGConfig -> Instr                           -> Maybe (NatCmmDecl RawCmmStatics Instr)-generateJumpTableForInstr dflags (BCTR ids (Just lbl) _) =+generateJumpTableForInstr config (BCTR ids (Just lbl) _) =     let jumpTable-            | (positionIndependent dflags)-              || (not $ target32Bit $ targetPlatform dflags)+            | (ncgPIC config) || (not $ target32Bit $ ncgPlatform config)             = map jumpTableEntryRel ids-            | otherwise = map (jumpTableEntry dflags) ids+            | otherwise = map (jumpTableEntry config) ids                 where jumpTableEntryRel Nothing-                        = CmmStaticLit (CmmInt 0 (wordWidth dflags))+                        = CmmStaticLit (CmmInt 0 (ncgWordWidth config))                       jumpTableEntryRel (Just blockid)                         = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0-                                         (wordWidth dflags))+                                         (ncgWordWidth config))                             where blockLabel = blockLbl blockid     in Just (CmmData (Section ReadOnlyData lbl) (RawCmmStatics lbl jumpTable)) generateJumpTableForInstr _ _ = Nothing@@ -2124,7 +2124,7 @@ condReg :: NatM CondCode -> NatM Register condReg getCond = do     CondCode _ cond cond_code <- getCond-    dflags <- getDynFlags+    platform <- getPlatform     let         code dst = cond_code             `appOL` negate_code@@ -2151,7 +2151,7 @@             GU  -> (1, False)             _   -> panic "PPC.CodeGen.codeReg: no match" -        format = archWordFormat $ target32Bit $ targetPlatform dflags+        format = archWordFormat $ target32Bit platform     return (Any format code)  condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register@@ -2324,8 +2324,8 @@  coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register coerceInt2FP fromRep toRep x = do-    dflags <- getDynFlags-    let arch =  platformArch $ targetPlatform dflags+    platform <- getPlatform+    let arch = platformArch platform     coerceInt2FP' arch fromRep toRep x  coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register@@ -2335,6 +2335,7 @@     itmp <- getNewRegNat II32     ftmp <- getNewRegNat FF64     dflags <- getDynFlags+    platform <- getPlatform     dynRef <- cmmMakeDynamicReference dflags DataReference lbl     Amode addr addr_code <- getAmode D dynRef     let@@ -2343,10 +2344,10 @@                                  [CmmStaticLit (CmmInt 0x43300000 W32),                                   CmmStaticLit (CmmInt 0x80000000 W32)],                 XORIS itmp src (ImmInt 0x8000),-                ST II32 itmp (spRel dflags 3),+                ST II32 itmp (spRel platform 3),                 LIS itmp (ImmInt 0x4330),-                ST II32 itmp (spRel dflags 2),-                LD FF64 ftmp (spRel dflags 2)+                ST II32 itmp (spRel platform 2),+                LD FF64 ftmp (spRel platform 2)             ] `appOL` addr_code `appOL` toOL [                 LD FF64 dst addr,                 FSUB FF64 dst ftmp dst@@ -2372,11 +2373,11 @@ -- So it is fine. coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do     (src, code) <- getSomeReg x-    dflags <- getDynFlags+    platform <- getPlatform     let         code' dst = code `appOL` maybe_exts `appOL` toOL [-                ST II64 src (spRel dflags 3),-                LD FF64 dst (spRel dflags 3),+                ST II64 src (spRel platform 3),+                LD FF64 dst (spRel platform 3),                 FCFID dst dst             ] `appOL` maybe_frsp dst @@ -2400,13 +2401,13 @@  coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register coerceFP2Int fromRep toRep x = do-    dflags <- getDynFlags-    let arch =  platformArch $ targetPlatform dflags+    platform <- getPlatform+    let arch =  platformArch platform     coerceFP2Int' arch fromRep toRep x  coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register coerceFP2Int' ArchPPC _ toRep x = do-    dflags <- getDynFlags+    platform <- getPlatform     -- the reps don't really matter: F*->FF64 and II32->I* are no-ops     (src, code) <- getSomeReg x     tmp <- getNewRegNat FF64@@ -2415,13 +2416,13 @@                 -- convert to int in FP reg             FCTIWZ tmp src,                 -- store value (64bit) from FP to stack-            ST FF64 tmp (spRel dflags 2),+            ST FF64 tmp (spRel platform 2),                 -- read low word of value (high word is undefined)-            LD II32 dst (spRel dflags 3)]+            LD II32 dst (spRel platform 3)]     return (Any (intFormat toRep) code')  coerceFP2Int' (ArchPPC_64 _) _ toRep x = do-    dflags <- getDynFlags+    platform <- getPlatform     -- the reps don't really matter: F*->FF64 and II64->I* are no-ops     (src, code) <- getSomeReg x     tmp <- getNewRegNat FF64@@ -2430,8 +2431,8 @@                 -- convert to int in FP reg             FCTIDZ tmp src,                 -- store value (64bit) from FP to compiler word on stack-            ST FF64 tmp (spRel dflags 3),-            LD II64 dst (spRel dflags 3)]+            ST FF64 tmp (spRel platform 3),+            LD II64 dst (spRel platform 3)]     return (Any (intFormat toRep) code')  coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch"
compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -31,6 +31,7 @@ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Format import GHC.CmmToAsm.Reg.Target+import GHC.CmmToAsm.Config import GHC.Platform.Reg.Class import GHC.Platform.Reg @@ -38,15 +39,14 @@ import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label-import GHC.Driver.Session import GHC.Cmm import GHC.Cmm.Info import FastString import GHC.Cmm.CLabel import Outputable import GHC.Platform-import UniqFM (listToUFM, lookupUFM)-import UniqSupply+import GHC.Types.Unique.FM (listToUFM, lookupUFM)+import GHC.Types.Unique.Supply  import Control.Monad (replicateM) import Data.Maybe (fromMaybe)@@ -534,15 +534,15 @@  -- | An instruction to spill a register into a spill slot. ppc_mkSpillInstr-   :: DynFlags+   :: NCGConfig    -> Reg       -- register to spill    -> Int       -- current stack delta    -> Int       -- spill slot to use    -> Instr -ppc_mkSpillInstr dflags reg delta slot-  = let platform = targetPlatform dflags-        off      = spillSlotToOffset dflags slot+ppc_mkSpillInstr config reg delta slot+  = let platform = ncgPlatform config+        off      = spillSlotToOffset platform slot         arch     = platformArch platform     in     let fmt = case targetClassOfReg platform reg of@@ -559,15 +559,15 @@   ppc_mkLoadInstr-   :: DynFlags+   :: NCGConfig    -> Reg       -- register to load    -> Int       -- current stack delta    -> Int       -- spill slot to use    -> Instr -ppc_mkLoadInstr dflags reg delta slot-  = let platform = targetPlatform dflags-        off      = spillSlotToOffset dflags slot+ppc_mkLoadInstr config reg delta slot+  = let platform = ncgPlatform config+        off      = spillSlotToOffset platform slot         arch     = platformArch platform     in     let fmt = case targetClassOfReg platform reg of@@ -585,8 +585,8 @@  -- | The size of a minimal stackframe header including minimal -- parameter save area.-stackFrameHeaderSize :: DynFlags -> Int-stackFrameHeaderSize dflags+stackFrameHeaderSize :: Platform -> Int+stackFrameHeaderSize platform   = case platformOS platform of       OSAIX    -> 24 + 8 * 4       _ -> case platformArch platform of@@ -595,7 +595,6 @@              ArchPPC_64 ELF_V1 -> 48 + 8 * 8              ArchPPC_64 ELF_V2 -> 32 + 8 * 8              _ -> panic "PPC.stackFrameHeaderSize: not defined for this OS"-     where platform = targetPlatform dflags  -- | The maximum number of bytes required to spill a register. PPC32 -- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and@@ -606,11 +605,12 @@ spillSlotSize = 8  -- | The number of spill slots available without allocating more.-maxSpillSlots :: DynFlags -> Int-maxSpillSlots dflags-    = ((rESERVED_C_STACK_BYTES dflags - stackFrameHeaderSize dflags)-       `div` spillSlotSize) - 1---     = 0 -- useful for testing allocMoreStack+maxSpillSlots :: NCGConfig -> Int+maxSpillSlots config+--  = 0 -- useful for testing allocMoreStack+    = let platform = ncgPlatform config+      in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform)+         `div` spillSlotSize) - 1  -- | The number of bytes that the stack pointer should be aligned -- to. This is 16 both on PPC32 and PPC64 ELF (see ELF processor@@ -619,9 +619,9 @@ stackAlign = 16  -- | Convert a spill slot number to a *byte* offset, with no sign.-spillSlotToOffset :: DynFlags -> Int -> Int-spillSlotToOffset dflags slot-   = stackFrameHeaderSize dflags + spillSlotSize * slot+spillSlotToOffset :: Platform -> Int -> Int+spillSlotToOffset platform slot+   = stackFrameHeaderSize platform + spillSlotSize * slot   --------------------------------------------------------------------------------
compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -20,882 +20,984 @@ import GHC.Platform.Reg import GHC.Platform.Reg.Class import GHC.CmmToAsm.Reg.Target--import GHC.Cmm hiding (topInfoTable)-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label--import GHC.Cmm.BlockId-import GHC.Cmm.CLabel-import GHC.Cmm.Ppr.Expr () -- For Outputable instances--import Unique                ( pprUniqueAlways, getUnique )-import GHC.Platform-import FastString-import Outputable-import GHC.Driver.Session--import Data.Word-import Data.Int-import Data.Bits---- -------------------------------------------------------------------------------- Printing this stuff out--pprNatCmmDecl :: NatCmmDecl RawCmmStatics Instr -> SDoc-pprNatCmmDecl (CmmData section dats) =-  pprSectionAlign section $$ pprDatas dats--pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =-  case topInfoTable proc of-    Nothing ->-       sdocWithPlatform $ \platform ->-         -- special case for code without info table:-         pprSectionAlign (Section Text lbl) $$-         (case platformArch platform of-            ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl-            ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl-            _ -> pprLabel lbl) $$ -- blocks guaranteed not null,-                                     -- so label needed-         vcat (map (pprBasicBlock top_info) blocks)--    Just (RawCmmStatics info_lbl _) ->-      sdocWithPlatform $ \platform ->-      pprSectionAlign (Section Text info_lbl) $$-      (if platformHasSubsectionsViaSymbols platform-          then ppr (mkDeadStripPreventer info_lbl) <> char ':'-          else empty) $$-      vcat (map (pprBasicBlock top_info) blocks) $$-      -- above: Even the first block gets a label, because with branch-chain-      -- elimination, it might be the target of a goto.-      (if platformHasSubsectionsViaSymbols platform-       then-       -- See Note [Subsections Via Symbols] in X86/Ppr.hs-                text "\t.long "-            <+> ppr info_lbl-            <+> char '-'-            <+> ppr (mkDeadStripPreventer info_lbl)-       else empty)--pprFunctionDescriptor :: CLabel -> SDoc-pprFunctionDescriptor lab = pprGloblDecl lab-                        $$  text "\t.section \".opd\", \"aw\""-                        $$  text "\t.align 3"-                        $$  ppr lab <> char ':'-                        $$  text "\t.quad ."-                        <>  ppr lab-                        <>  text ",.TOC.@tocbase,0"-                        $$  text "\t.previous"-                        $$  text "\t.type"-                        <+> ppr lab-                        <>  text ", @function"-                        $$  char '.' <> ppr lab <> char ':'--pprFunctionPrologue :: CLabel ->SDoc-pprFunctionPrologue lab =  pprGloblDecl lab-                        $$  text ".type "-                        <> ppr lab-                        <> text ", @function"-                        $$ ppr lab <> char ':'-                        $$ text "0:\taddis\t" <> pprReg toc-                        <> text ",12,.TOC.-0b@ha"-                        $$ text "\taddi\t" <> pprReg toc-                        <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"-                        $$ text "\t.localentry\t" <> ppr lab-                        <> text ",.-" <> ppr lab--pprBasicBlock :: LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc-pprBasicBlock info_env (BasicBlock blockid instrs)-  = maybe_infotable $$-    pprLabel (blockLbl blockid) $$-    vcat (map pprInstr instrs)-  where-    maybe_infotable = case mapLookup blockid info_env of-       Nothing   -> empty-       Just (RawCmmStatics info_lbl info) ->-           pprAlignForSection Text $$-           vcat (map pprData info) $$-           pprLabel info_lbl----pprDatas :: RawCmmStatics -> SDoc--- See note [emit-time elimination of static indirections] in CLabel.-pprDatas (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])-  | lbl == mkIndStaticInfoLabel-  , let labelInd (CmmLabelOff l _) = Just l-        labelInd (CmmLabel l) = Just l-        labelInd _ = Nothing-  , Just ind' <- labelInd ind-  , alias `mayRedirectTo` ind'-  = pprGloblDecl alias-    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')-pprDatas (RawCmmStatics lbl dats) = vcat (pprLabel lbl : map pprData dats)--pprData :: CmmStatic -> SDoc-pprData (CmmString str)          = pprBytes str-pprData (CmmUninitialised bytes) = text ".space " <> int bytes-pprData (CmmStaticLit lit)       = pprDataItem lit--pprGloblDecl :: CLabel -> SDoc-pprGloblDecl lbl-  | not (externallyVisibleCLabel lbl) = empty-  | otherwise = text ".globl " <> ppr lbl--pprTypeAndSizeDecl :: CLabel -> SDoc-pprTypeAndSizeDecl lbl-  = sdocWithPlatform $ \platform ->-    if platformOS platform == OSLinux && externallyVisibleCLabel lbl-    then text ".type " <>-         ppr lbl <> text ", @object"-    else empty--pprLabel :: CLabel -> SDoc-pprLabel lbl = pprGloblDecl lbl-            $$ pprTypeAndSizeDecl lbl-            $$ (ppr lbl <> char ':')---- -------------------------------------------------------------------------------- pprInstr: print an 'Instr'--instance Outputable Instr where-    ppr instr = pprInstr instr---pprReg :: Reg -> SDoc--pprReg r-  = case r of-      RegReal    (RealRegSingle i) -> ppr_reg_no i-      RegReal    (RealRegPair{})   -> panic "PPC.pprReg: no reg pairs on this arch"-      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u-      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u--  where-    ppr_reg_no :: Int -> SDoc-    ppr_reg_no i-         | i <= 31   = int i      -- GPRs-         | i <= 63   = int (i-32) -- FPRs-         | otherwise = text "very naughty powerpc register"----pprFormat :: Format -> SDoc-pprFormat x- = ptext (case x of-                II8  -> sLit "b"-                II16 -> sLit "h"-                II32 -> sLit "w"-                II64 -> sLit "d"-                FF32 -> sLit "fs"-                FF64 -> sLit "fd")---pprCond :: Cond -> SDoc-pprCond c- = ptext (case c of {-                ALWAYS  -> sLit "";-                EQQ     -> sLit "eq";  NE    -> sLit "ne";-                LTT     -> sLit "lt";  GE    -> sLit "ge";-                GTT     -> sLit "gt";  LE    -> sLit "le";-                LU      -> sLit "lt";  GEU   -> sLit "ge";-                GU      -> sLit "gt";  LEU   -> sLit "le"; })---pprImm :: Imm -> SDoc--pprImm (ImmInt i)     = int i-pprImm (ImmInteger i) = integer i-pprImm (ImmCLbl l)    = ppr l-pprImm (ImmIndex l i) = ppr l <> char '+' <> int i-pprImm (ImmLit s)     = s--pprImm (ImmFloat _)  = text "naughty float immediate"-pprImm (ImmDouble _) = text "naughty double immediate"--pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b-pprImm (ImmConstantDiff a b) = pprImm a <> char '-'-                   <> lparen <> pprImm b <> rparen--pprImm (LO (ImmInt i))     = pprImm (LO (ImmInteger (toInteger i)))-pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16))-  where-    lo16 = fromInteger (i .&. 0xffff) :: Int16--pprImm (LO i)-  = pprImm i <> text "@l"--pprImm (HI i)-  = pprImm i <> text "@h"--pprImm (HA (ImmInt i))     = pprImm (HA (ImmInteger (toInteger i)))-pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16)-  where-    ha16 = if lo16 >= 0x8000 then hi16+1 else hi16-    hi16 = (i `shiftR` 16)-    lo16 = i .&. 0xffff--pprImm (HA i)-  = pprImm i <> text "@ha"--pprImm (HIGHERA i)-  = pprImm i <> text "@highera"--pprImm (HIGHESTA i)-  = pprImm i <> text "@highesta"---pprAddr :: AddrMode -> SDoc-pprAddr (AddrRegReg r1 r2)-  = pprReg r1 <> char ',' <+> pprReg r2-pprAddr (AddrRegImm r1 (ImmInt i))-  = hcat [ int i, char '(', pprReg r1, char ')' ]-pprAddr (AddrRegImm r1 (ImmInteger i))-  = hcat [ integer i, char '(', pprReg r1, char ')' ]-pprAddr (AddrRegImm r1 imm)-  = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]---pprSectionAlign :: Section -> SDoc-pprSectionAlign sec@(Section seg _) =- sdocWithPlatform $ \platform ->-   pprSectionHeader platform sec $$-   pprAlignForSection seg---- | Print appropriate alignment for the given section type.-pprAlignForSection :: SectionType -> SDoc-pprAlignForSection seg =- sdocWithPlatform $ \platform ->- let ppc64    = not $ target32Bit platform- in ptext $ case seg of-       Text              -> sLit ".align 2"-       Data-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"-       ReadOnlyData-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"-       RelocatableReadOnlyData-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"-       UninitialisedData-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"-       ReadOnlyData16    -> sLit ".align 4"-       -- TODO: This is copied from the ReadOnlyData case, but it can likely be-       -- made more efficient.-       CString-        | ppc64          -> sLit ".align 3"-        | otherwise      -> sLit ".align 2"-       OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section"--pprDataItem :: CmmLit -> SDoc-pprDataItem lit-  = sdocWithDynFlags $ \dflags ->-    vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit dflags)-    where-        imm = litToImm lit-        archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags--        ppr_item II8   _ _ = [text "\t.byte\t" <> pprImm imm]--        ppr_item II32  _ _ = [text "\t.long\t" <> pprImm imm]--        ppr_item II64 _ dflags-           | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm]---        ppr_item FF32 (CmmFloat r _) _-           = let bs = floatToBytes (fromRational r)-             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs--        ppr_item FF64 (CmmFloat r _) _-           = let bs = doubleToBytes (fromRational r)-             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs--        ppr_item II16 _ _      = [text "\t.short\t" <> pprImm imm]--        ppr_item II64 (CmmInt x _) dflags-           | not(archPPC_64 dflags) =-                [text "\t.long\t"-                    <> int (fromIntegral-                        (fromIntegral (x `shiftR` 32) :: Word32)),-                 text "\t.long\t"-                    <> int (fromIntegral (fromIntegral x :: Word32))]--        ppr_item _ _ _-                = panic "PPC.Ppr.pprDataItem: no match"---pprInstr :: Instr -> SDoc--pprInstr (COMMENT _) = empty -- nuke 'em-{--pprInstr (COMMENT s) =-     if platformOS platform == OSLinux-     then text "# " <> ftext s-     else text "; " <> ftext s--}-pprInstr (DELTA d)-   = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))--pprInstr (NEWBLOCK _)-   = panic "PprMach.pprInstr: NEWBLOCK"--pprInstr (LDATA _ _)-   = panic "PprMach.pprInstr: LDATA"--{--pprInstr (SPILL reg slot)-   = hcat [-           text "\tSPILL",-        char '\t',-        pprReg reg,-        comma,-        text "SLOT" <> parens (int slot)]--pprInstr (RELOAD slot reg)-   = hcat [-           text "\tRELOAD",-        char '\t',-        text "SLOT" <> parens (int slot),-        comma,-        pprReg reg]--}--pprInstr (LD fmt reg addr) = hcat [-        char '\t',-        text "l",-        ptext (case fmt of-            II8  -> sLit "bz"-            II16 -> sLit "hz"-            II32 -> sLit "wz"-            II64 -> sLit "d"-            FF32 -> sLit "fs"-            FF64 -> sLit "fd"-            ),-        case addr of AddrRegImm _ _ -> empty-                     AddrRegReg _ _ -> char 'x',-        char '\t',-        pprReg reg,-        text ", ",-        pprAddr addr-    ]--pprInstr (LDFAR fmt reg (AddrRegImm source off)) =-   sdocWithPlatform $ \platform -> vcat [-         pprInstr (ADDIS (tmpReg platform) source (HA off)),-         pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))-    ]-pprInstr (LDFAR _ _ _) =-   panic "PPC.Ppr.pprInstr LDFAR: no match"--pprInstr (LDR fmt reg1 addr) = hcat [-  text "\tl",-  case fmt of-    II32 -> char 'w'-    II64 -> char 'd'-    _    -> panic "PPC.Ppr.Instr LDR: no match",-  text "arx\t",-  pprReg reg1,-  text ", ",-  pprAddr addr-  ]--pprInstr (LA fmt reg addr) = hcat [-        char '\t',-        text "l",-        ptext (case fmt of-            II8  -> sLit "ba"-            II16 -> sLit "ha"-            II32 -> sLit "wa"-            II64 -> sLit "d"-            FF32 -> sLit "fs"-            FF64 -> sLit "fd"-            ),-        case addr of AddrRegImm _ _ -> empty-                     AddrRegReg _ _ -> char 'x',-        char '\t',-        pprReg reg,-        text ", ",-        pprAddr addr-    ]-pprInstr (ST fmt reg addr) = hcat [-        char '\t',-        text "st",-        pprFormat fmt,-        case addr of AddrRegImm _ _ -> empty-                     AddrRegReg _ _ -> char 'x',-        char '\t',-        pprReg reg,-        text ", ",-        pprAddr addr-    ]-pprInstr (STFAR fmt reg (AddrRegImm source off)) =-   sdocWithPlatform $ \platform -> vcat [-         pprInstr (ADDIS (tmpReg platform) source (HA off)),-         pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))-    ]-pprInstr (STFAR _ _ _) =-   panic "PPC.Ppr.pprInstr STFAR: no match"-pprInstr (STU fmt reg addr) = hcat [-        char '\t',-        text "st",-        pprFormat fmt,-        char 'u',-        case addr of AddrRegImm _ _ -> empty-                     AddrRegReg _ _ -> char 'x',-        char '\t',-        pprReg reg,-        text ", ",-        pprAddr addr-    ]-pprInstr (STC fmt reg1 addr) = hcat [-  text "\tst",-  case fmt of-    II32 -> char 'w'-    II64 -> char 'd'-    _    -> panic "PPC.Ppr.Instr STC: no match",-  text "cx.\t",-  pprReg reg1,-  text ", ",-  pprAddr addr-  ]-pprInstr (LIS reg imm) = hcat [-        char '\t',-        text "lis",-        char '\t',-        pprReg reg,-        text ", ",-        pprImm imm-    ]-pprInstr (LI reg imm) = hcat [-        char '\t',-        text "li",-        char '\t',-        pprReg reg,-        text ", ",-        pprImm imm-    ]-pprInstr (MR reg1 reg2)-    | reg1 == reg2 = empty-    | otherwise = hcat [-        char '\t',-        sdocWithPlatform $ \platform ->-        case targetClassOfReg platform reg1 of-            RcInteger -> text "mr"-            _ -> text "fmr",-        char '\t',-        pprReg reg1,-        text ", ",-        pprReg reg2-    ]-pprInstr (CMP fmt reg ri) = hcat [-        char '\t',-        op,-        char '\t',-        pprReg reg,-        text ", ",-        pprRI ri-    ]-    where-        op = hcat [-                text "cmp",-                pprFormat fmt,-                case ri of-                    RIReg _ -> empty-                    RIImm _ -> char 'i'-            ]-pprInstr (CMPL fmt reg ri) = hcat [-        char '\t',-        op,-        char '\t',-        pprReg reg,-        text ", ",-        pprRI ri-    ]-    where-        op = hcat [-                text "cmpl",-                pprFormat fmt,-                case ri of-                    RIReg _ -> empty-                    RIImm _ -> char 'i'-            ]-pprInstr (BCC cond blockid prediction) = hcat [-        char '\t',-        text "b",-        pprCond cond,-        pprPrediction prediction,-        char '\t',-        ppr lbl-    ]-    where lbl = mkLocalBlockLabel (getUnique blockid)-          pprPrediction p = case p of-            Nothing    -> empty-            Just True  -> char '+'-            Just False -> char '-'--pprInstr (BCCFAR cond blockid prediction) = vcat [-        hcat [-            text "\tb",-            pprCond (condNegate cond),-            neg_prediction,-            text "\t$+8"-        ],-        hcat [-            text "\tb\t",-            ppr lbl-        ]-    ]-    where lbl = mkLocalBlockLabel (getUnique blockid)-          neg_prediction = case prediction of-            Nothing    -> empty-            Just True  -> char '-'-            Just False -> char '+'--pprInstr (JMP lbl _)-  -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"-  | isForeignLabel lbl = panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"-  | otherwise =-    hcat [ -- an alias for b that takes a CLabel-        char '\t',-        text "b",-        char '\t',-        ppr lbl-    ]--pprInstr (MTCTR reg) = hcat [-        char '\t',-        text "mtctr",-        char '\t',-        pprReg reg-    ]-pprInstr (BCTR _ _ _) = hcat [-        char '\t',-        text "bctr"-    ]-pprInstr (BL lbl _) = do-    sdocWithPlatform $ \platform -> case platformOS platform of-        OSAIX ->-          -- On AIX, "printf" denotes a function-descriptor (for use-          -- by function pointers), whereas the actual entry-code-          -- address is denoted by the dot-prefixed ".printf" label.-          -- Moreover, the PPC NCG only ever emits a BL instruction-          -- for calling C ABI functions. Most of the time these calls-          -- originate from FFI imports and have a 'ForeignLabel',-          -- but when profiling the codegen inserts calls via-          -- 'emitRtsCallGen' which are 'CmmLabel's even though-          -- they'd technically be more like 'ForeignLabel's.-          hcat [-            text "\tbl\t.",-            ppr lbl-          ]-        _ ->-          hcat [-            text "\tbl\t",-            ppr lbl-          ]-pprInstr (BCTRL _) = hcat [-        char '\t',-        text "bctrl"-    ]-pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri-pprInstr (ADDIS reg1 reg2 imm) = hcat [-        char '\t',-        text "addis",-        char '\t',-        pprReg reg1,-        text ", ",-        pprReg reg2,-        text ", ",-        pprImm imm-    ]--pprInstr (ADDO reg1 reg2 reg3) = pprLogic (sLit "addo") reg1 reg2 (RIReg reg3)-pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)-pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)-pprInstr (ADDZE reg1 reg2) = pprUnary (sLit "addze") reg1 reg2-pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)-pprInstr (SUBFO reg1 reg2 reg3) = pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3)-pprInstr (SUBFC reg1 reg2 ri) = hcat [-        char '\t',-        text "subf",-        case ri of-            RIReg _ -> empty-            RIImm _ -> char 'i',-        text "c\t",-        pprReg reg1,-        text ", ",-        pprReg reg2,-        text ", ",-        pprRI ri-    ]-pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)-pprInstr (MULL fmt reg1 reg2 ri) = pprMul fmt reg1 reg2 ri-pprInstr (MULLO fmt reg1 reg2 reg3) = hcat [-        char '\t',-        text "mull",-        case fmt of-          II32 -> char 'w'-          II64 -> char 'd'-          _    -> panic "PPC: illegal format",-        text "o\t",-        pprReg reg1,-        text ", ",-        pprReg reg2,-        text ", ",-        pprReg reg3-    ]-pprInstr (MFOV fmt reg) = vcat [-        hcat [-            char '\t',-            text "mfxer",-            char '\t',-            pprReg reg-            ],-        hcat [-            char '\t',-            text "extr",-            case fmt of-              II32 -> char 'w'-              II64 -> char 'd'-              _    -> panic "PPC: illegal format",-            text "i\t",-            pprReg reg,-            text ", ",-            pprReg reg,-            text ", 1, ",-            case fmt of-              II32 -> text "1"-              II64 -> text "33"-              _    -> panic "PPC: illegal format"-            ]-        ]--pprInstr (MULHU fmt reg1 reg2 reg3) = hcat [-        char '\t',-        text "mulh",-        case fmt of-          II32 -> char 'w'-          II64 -> char 'd'-          _    -> panic "PPC: illegal format",-        text "u\t",-        pprReg reg1,-        text ", ",-        pprReg reg2,-        text ", ",-        pprReg reg3-    ]--pprInstr (DIV fmt sgn reg1 reg2 reg3) = pprDiv fmt sgn reg1 reg2 reg3--        -- for some reason, "andi" doesn't exist.-        -- we'll use "andi." instead.-pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [-        char '\t',-        text "andi.",-        char '\t',-        pprReg reg1,-        text ", ",-        pprReg reg2,-        text ", ",-        pprImm imm-    ]-pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri-pprInstr (ANDC reg1 reg2 reg3) = pprLogic (sLit "andc") reg1 reg2 (RIReg reg3)-pprInstr (NAND reg1 reg2 reg3) = pprLogic (sLit "nand") reg1 reg2 (RIReg reg3)--pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri-pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri--pprInstr (ORIS reg1 reg2 imm) = hcat [-        char '\t',-        text "oris",-        char '\t',-        pprReg reg1,-        text ", ",-        pprReg reg2,-        text ", ",-        pprImm imm-    ]--pprInstr (XORIS reg1 reg2 imm) = hcat [-        char '\t',-        text "xoris",-        char '\t',-        pprReg reg1,-        text ", ",-        pprReg reg2,-        text ", ",-        pprImm imm-    ]--pprInstr (EXTS fmt reg1 reg2) = hcat [-        char '\t',-        text "exts",-        pprFormat fmt,-        char '\t',-        pprReg reg1,-        text ", ",-        pprReg reg2-    ]-pprInstr (CNTLZ fmt reg1 reg2) = hcat [-        char '\t',-        text "cntlz",-        case fmt of-          II32 -> char 'w'-          II64 -> char 'd'-          _    -> panic "PPC: illegal format",-        char '\t',-        pprReg reg1,-        text ", ",-        pprReg reg2-    ]--pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2-pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2--pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =-    -- Handle the case where we are asked to shift a 32 bit register by-    -- less than zero or more than 31 bits. We convert this into a clear-    -- of the destination register.-    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900-    pprInstr (XOR reg1 reg2 (RIReg reg2))--pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =-    -- As above for SR, but for left shifts.-    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870-    pprInstr (XOR reg1 reg2 (RIReg reg2))--pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 =-    -- PT: I don't know what to do for negative shift amounts:-    -- For now just panic.-    ---    -- For shift amounts greater than 31 set all bit to the-    -- value of the sign bit, this also what sraw does.-    pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))--pprInstr (SL fmt reg1 reg2 ri) =-         let op = case fmt of-                       II32 -> "slw"-                       II64 -> "sld"-                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"-         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)--pprInstr (SR fmt reg1 reg2 ri) =-         let op = case fmt of-                       II32 -> "srw"-                       II64 -> "srd"-                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"-         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)--pprInstr (SRA fmt reg1 reg2 ri) =-         let op = case fmt of-                       II32 -> "sraw"-                       II64 -> "srad"-                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"-         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)--pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [-        text "\trlwinm\t",-        pprReg reg1,-        text ", ",-        pprReg reg2,-        text ", ",-        int sh,-        text ", ",-        int mb,-        text ", ",-        int me-    ]--pprInstr (CLRLI fmt reg1 reg2 n) = hcat [-        text "\tclrl",-        pprFormat fmt,-        text "i ",-        pprReg reg1,-        text ", ",-        pprReg reg2,-        text ", ",-        int n-    ]-pprInstr (CLRRI fmt reg1 reg2 n) = hcat [-        text "\tclrr",-        pprFormat fmt,-        text "i ",-        pprReg reg1,-        text ", ",-        pprReg reg2,-        text ", ",-        int n-    ]--pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3-pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3-pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3-pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3-pprInstr (FABS reg1 reg2) = pprUnary (sLit "fabs") reg1 reg2-pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2--pprInstr (FCMP reg1 reg2) = hcat [-        char '\t',-        text "fcmpu\t0, ",-            -- Note: we're using fcmpu, not fcmpo-            -- The difference is with fcmpo, compare with NaN is an invalid operation.-            -- We don't handle invalid fp ops, so we don't care.-            -- Moreover, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for-            -- better portability since some non-GNU assembler (such as-            -- IBM's `as`) tend not to support the symbolic register name cr0.-            -- This matches the syntax that GCC seems to emit for PPC targets.-        pprReg reg1,-        text ", ",-        pprReg reg2-    ]--pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2-pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2-pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2-pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2--pprInstr (CRNOR dst src1 src2) = hcat [-        text "\tcrnor\t",-        int dst,-        text ", ",-        int src1,-        text ", ",-        int src2-    ]--pprInstr (MFCR reg) = hcat [-        char '\t',-        text "mfcr",-        char '\t',-        pprReg reg-    ]--pprInstr (MFLR reg) = hcat [-        char '\t',-        text "mflr",-        char '\t',-        pprReg reg-    ]--pprInstr (FETCHPC reg) = vcat [-        text "\tbcl\t20,31,1f",-        hcat [ text "1:\tmflr\t", pprReg reg ]-    ]--pprInstr HWSYNC = text "\tsync"--pprInstr ISYNC  = text "\tisync"--pprInstr LWSYNC = text "\tlwsync"--pprInstr NOP = text "\tnop"-+import GHC.CmmToAsm.Config++import GHC.Cmm hiding (topInfoTable)+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label++import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Ppr.Expr () -- For Outputable instances++import GHC.Types.Unique ( pprUniqueAlways, getUnique )+import GHC.Platform+import FastString+import Outputable+import GHC.Driver.Session (targetPlatform)++import Data.Word+import Data.Int+import Data.Bits++-- -----------------------------------------------------------------------------+-- Printing this stuff out++pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc+pprNatCmmDecl config (CmmData section dats) =+  pprSectionAlign config section+  $$ pprDatas (ncgPlatform config) dats++pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  let platform = ncgPlatform config in+  case topInfoTable proc of+    Nothing ->+         -- special case for code without info table:+         pprSectionAlign config (Section Text lbl) $$+         (case platformArch platform of+            ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl+            ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl+            _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null,+                                           -- so label needed+         vcat (map (pprBasicBlock platform top_info) blocks)++    Just (RawCmmStatics info_lbl _) ->+      pprSectionAlign config (Section Text info_lbl) $$+      (if platformHasSubsectionsViaSymbols platform+          then ppr (mkDeadStripPreventer info_lbl) <> char ':'+          else empty) $$+      vcat (map (pprBasicBlock platform top_info) blocks) $$+      -- above: Even the first block gets a label, because with branch-chain+      -- elimination, it might be the target of a goto.+      (if platformHasSubsectionsViaSymbols platform+       then+       -- See Note [Subsections Via Symbols] in X86/Ppr.hs+                text "\t.long "+            <+> ppr info_lbl+            <+> char '-'+            <+> ppr (mkDeadStripPreventer info_lbl)+       else empty)++pprFunctionDescriptor :: CLabel -> SDoc+pprFunctionDescriptor lab = pprGloblDecl lab+                        $$  text "\t.section \".opd\", \"aw\""+                        $$  text "\t.align 3"+                        $$  ppr lab <> char ':'+                        $$  text "\t.quad ."+                        <>  ppr lab+                        <>  text ",.TOC.@tocbase,0"+                        $$  text "\t.previous"+                        $$  text "\t.type"+                        <+> ppr lab+                        <>  text ", @function"+                        $$  char '.' <> ppr lab <> char ':'++pprFunctionPrologue :: CLabel ->SDoc+pprFunctionPrologue lab =  pprGloblDecl lab+                        $$  text ".type "+                        <> ppr lab+                        <> text ", @function"+                        $$ ppr lab <> char ':'+                        $$ text "0:\taddis\t" <> pprReg toc+                        <> text ",12,.TOC.-0b@ha"+                        $$ text "\taddi\t" <> pprReg toc+                        <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"+                        $$ text "\t.localentry\t" <> ppr lab+                        <> text ",.-" <> ppr lab++pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc+pprBasicBlock platform info_env (BasicBlock blockid instrs)+  = maybe_infotable $$+    pprLabel platform (blockLbl blockid) $$+    vcat (map (pprInstr platform) instrs)+  where+    maybe_infotable = case mapLookup blockid info_env of+       Nothing   -> empty+       Just (RawCmmStatics info_lbl info) ->+           pprAlignForSection platform Text $$+           vcat (map (pprData platform) info) $$+           pprLabel platform info_lbl++++pprDatas :: Platform -> RawCmmStatics -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas _platform (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind'+  = pprGloblDecl alias+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')+pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)++pprData :: Platform -> CmmStatic -> SDoc+pprData platform d = case d of+   CmmString str          -> pprBytes str+   CmmUninitialised bytes -> text ".space " <> int bytes+   CmmStaticLit lit       -> pprDataItem platform lit++pprGloblDecl :: CLabel -> SDoc+pprGloblDecl lbl+  | not (externallyVisibleCLabel lbl) = empty+  | otherwise = text ".globl " <> ppr lbl++pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc+pprTypeAndSizeDecl platform lbl+  = if platformOS platform == OSLinux && externallyVisibleCLabel lbl+    then text ".type " <>+         ppr lbl <> text ", @object"+    else empty++pprLabel :: Platform -> CLabel -> SDoc+pprLabel platform lbl =+   pprGloblDecl lbl+   $$ pprTypeAndSizeDecl platform lbl+   $$ (ppr lbl <> char ':')++-- -----------------------------------------------------------------------------+-- pprInstr: print an 'Instr'++instance Outputable Instr where+    ppr instr = sdocWithDynFlags $ \dflags ->+                  pprInstr (targetPlatform dflags) instr+++pprReg :: Reg -> SDoc++pprReg r+  = case r of+      RegReal    (RealRegSingle i) -> ppr_reg_no i+      RegReal    (RealRegPair{})   -> panic "PPC.pprReg: no reg pairs on this arch"+      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u+      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u++  where+    ppr_reg_no :: Int -> SDoc+    ppr_reg_no i+         | i <= 31   = int i      -- GPRs+         | i <= 63   = int (i-32) -- FPRs+         | otherwise = text "very naughty powerpc register"++++pprFormat :: Format -> SDoc+pprFormat x+ = ptext (case x of+                II8  -> sLit "b"+                II16 -> sLit "h"+                II32 -> sLit "w"+                II64 -> sLit "d"+                FF32 -> sLit "fs"+                FF64 -> sLit "fd")+++pprCond :: Cond -> SDoc+pprCond c+ = ptext (case c of {+                ALWAYS  -> sLit "";+                EQQ     -> sLit "eq";  NE    -> sLit "ne";+                LTT     -> sLit "lt";  GE    -> sLit "ge";+                GTT     -> sLit "gt";  LE    -> sLit "le";+                LU      -> sLit "lt";  GEU   -> sLit "ge";+                GU      -> sLit "gt";  LEU   -> sLit "le"; })+++pprImm :: Imm -> SDoc++pprImm (ImmInt i)     = int i+pprImm (ImmInteger i) = integer i+pprImm (ImmCLbl l)    = ppr l+pprImm (ImmIndex l i) = ppr l <> char '+' <> int i+pprImm (ImmLit s)     = s++pprImm (ImmFloat _)  = text "naughty float immediate"+pprImm (ImmDouble _) = text "naughty double immediate"++pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'+                   <> lparen <> pprImm b <> rparen++pprImm (LO (ImmInt i))     = pprImm (LO (ImmInteger (toInteger i)))+pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16))+  where+    lo16 = fromInteger (i .&. 0xffff) :: Int16++pprImm (LO i)+  = pprImm i <> text "@l"++pprImm (HI i)+  = pprImm i <> text "@h"++pprImm (HA (ImmInt i))     = pprImm (HA (ImmInteger (toInteger i)))+pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16)+  where+    ha16 = if lo16 >= 0x8000 then hi16+1 else hi16+    hi16 = (i `shiftR` 16)+    lo16 = i .&. 0xffff++pprImm (HA i)+  = pprImm i <> text "@ha"++pprImm (HIGHERA i)+  = pprImm i <> text "@highera"++pprImm (HIGHESTA i)+  = pprImm i <> text "@highesta"+++pprAddr :: AddrMode -> SDoc+pprAddr (AddrRegReg r1 r2)+  = pprReg r1 <> char ',' <+> pprReg r2+pprAddr (AddrRegImm r1 (ImmInt i))+  = hcat [ int i, char '(', pprReg r1, char ')' ]+pprAddr (AddrRegImm r1 (ImmInteger i))+  = hcat [ integer i, char '(', pprReg r1, char ')' ]+pprAddr (AddrRegImm r1 imm)+  = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]+++pprSectionAlign :: NCGConfig -> Section -> SDoc+pprSectionAlign config sec@(Section seg _) =+   pprSectionHeader config sec $$+   pprAlignForSection (ncgPlatform config) seg++-- | Print appropriate alignment for the given section type.+pprAlignForSection :: Platform -> SectionType -> SDoc+pprAlignForSection platform seg =+ let ppc64    = not $ target32Bit platform+ in ptext $ case seg of+       Text              -> sLit ".align 2"+       Data+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       ReadOnlyData+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       RelocatableReadOnlyData+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       UninitialisedData+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       ReadOnlyData16    -> sLit ".align 4"+       -- TODO: This is copied from the ReadOnlyData case, but it can likely be+       -- made more efficient.+       CString+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section"++pprDataItem :: Platform -> CmmLit -> SDoc+pprDataItem platform lit+  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+    where+        imm = litToImm lit+        archPPC_64 = not $ target32Bit platform++        ppr_item II8  _ = [text "\t.byte\t" <> pprImm imm]+        ppr_item II16 _ = [text "\t.short\t" <> pprImm imm]+        ppr_item II32 _ = [text "\t.long\t" <> pprImm imm]+        ppr_item II64 _+           | archPPC_64 = [text "\t.quad\t" <> pprImm imm]++        ppr_item II64 (CmmInt x _)+           | not archPPC_64 =+                [text "\t.long\t"+                    <> int (fromIntegral+                        (fromIntegral (x `shiftR` 32) :: Word32)),+                 text "\t.long\t"+                    <> int (fromIntegral (fromIntegral x :: Word32))]+++        ppr_item FF32 (CmmFloat r _)+           = let bs = floatToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs++        ppr_item FF64 (CmmFloat r _)+           = let bs = doubleToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs++        ppr_item _ _+                = panic "PPC.Ppr.pprDataItem: no match"+++pprInstr :: Platform -> Instr -> SDoc+pprInstr platform instr = case instr of++   COMMENT _+      -> empty -- nuke 'em++   -- COMMENT s+   --    -> if platformOS platform == OSLinux+   --          then text "# " <> ftext s+   --          else text "; " <> ftext s++   DELTA d+      -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d)))++   NEWBLOCK _+      -> panic "PprMach.pprInstr: NEWBLOCK"++   LDATA _ _+      -> panic "PprMach.pprInstr: LDATA"++{-+   SPILL reg slot+      -> hcat [+              text "\tSPILL",+           char '\t',+           pprReg reg,+           comma,+           text "SLOT" <> parens (int slot)]++   RELOAD slot reg+      -> hcat [+              text "\tRELOAD",+           char '\t',+           text "SLOT" <> parens (int slot),+           comma,+           pprReg reg]+-}++   LD fmt reg addr+      -> hcat [+           char '\t',+           text "l",+           ptext (case fmt of+               II8  -> sLit "bz"+               II16 -> sLit "hz"+               II32 -> sLit "wz"+               II64 -> sLit "d"+               FF32 -> sLit "fs"+               FF64 -> sLit "fd"+               ),+           case addr of AddrRegImm _ _ -> empty+                        AddrRegReg _ _ -> char 'x',+           char '\t',+           pprReg reg,+           text ", ",+           pprAddr addr+       ]++   LDFAR fmt reg (AddrRegImm source off)+      -> vcat+            [ pprInstr platform (ADDIS (tmpReg platform) source (HA off))+            , pprInstr platform (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))+            ]++   LDFAR _ _ _+      -> panic "PPC.Ppr.pprInstr LDFAR: no match"++   LDR fmt reg1 addr+      -> hcat [+           text "\tl",+           case fmt of+             II32 -> char 'w'+             II64 -> char 'd'+             _    -> panic "PPC.Ppr.Instr LDR: no match",+           text "arx\t",+           pprReg reg1,+           text ", ",+           pprAddr addr+           ]++   LA fmt reg addr+      -> hcat [+           char '\t',+           text "l",+           ptext (case fmt of+               II8  -> sLit "ba"+               II16 -> sLit "ha"+               II32 -> sLit "wa"+               II64 -> sLit "d"+               FF32 -> sLit "fs"+               FF64 -> sLit "fd"+               ),+           case addr of AddrRegImm _ _ -> empty+                        AddrRegReg _ _ -> char 'x',+           char '\t',+           pprReg reg,+           text ", ",+           pprAddr addr+           ]++   ST fmt reg addr+      -> hcat [+           char '\t',+           text "st",+           pprFormat fmt,+           case addr of AddrRegImm _ _ -> empty+                        AddrRegReg _ _ -> char 'x',+           char '\t',+           pprReg reg,+           text ", ",+           pprAddr addr+           ]++   STFAR fmt reg (AddrRegImm source off)+      -> vcat [ pprInstr platform (ADDIS (tmpReg platform) source (HA off))+              , pprInstr platform (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))+              ]++   STFAR _ _ _+      -> panic "PPC.Ppr.pprInstr STFAR: no match"++   STU fmt reg addr+      -> hcat [+           char '\t',+           text "st",+           pprFormat fmt,+           char 'u',+           case addr of AddrRegImm _ _ -> empty+                        AddrRegReg _ _ -> char 'x',+           char '\t',+           pprReg reg,+           text ", ",+           pprAddr addr+           ]++   STC fmt reg1 addr+      -> hcat [+           text "\tst",+           case fmt of+             II32 -> char 'w'+             II64 -> char 'd'+             _    -> panic "PPC.Ppr.Instr STC: no match",+           text "cx.\t",+           pprReg reg1,+           text ", ",+           pprAddr addr+           ]++   LIS reg imm+      -> hcat [+           char '\t',+           text "lis",+           char '\t',+           pprReg reg,+           text ", ",+           pprImm imm+           ]++   LI reg imm+      -> hcat [+           char '\t',+           text "li",+           char '\t',+           pprReg reg,+           text ", ",+           pprImm imm+           ]++   MR reg1 reg2+    | reg1 == reg2 -> empty+    | otherwise    -> hcat [+        char '\t',+        case targetClassOfReg platform reg1 of+            RcInteger -> text "mr"+            _ -> text "fmr",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2+        ]++   CMP fmt reg ri+      -> hcat [+           char '\t',+           op,+           char '\t',+           pprReg reg,+           text ", ",+           pprRI ri+           ]+         where+           op = hcat [+                   text "cmp",+                   pprFormat fmt,+                   case ri of+                       RIReg _ -> empty+                       RIImm _ -> char 'i'+               ]++   CMPL fmt reg ri+      -> hcat [+           char '\t',+           op,+           char '\t',+           pprReg reg,+           text ", ",+           pprRI ri+           ]+          where+              op = hcat [+                      text "cmpl",+                      pprFormat fmt,+                      case ri of+                          RIReg _ -> empty+                          RIImm _ -> char 'i'+                  ]++   BCC cond blockid prediction+      -> hcat [+           char '\t',+           text "b",+           pprCond cond,+           pprPrediction prediction,+           char '\t',+           ppr lbl+           ]+         where lbl = mkLocalBlockLabel (getUnique blockid)+               pprPrediction p = case p of+                 Nothing    -> empty+                 Just True  -> char '+'+                 Just False -> char '-'++   BCCFAR cond blockid prediction+      -> vcat [+           hcat [+               text "\tb",+               pprCond (condNegate cond),+               neg_prediction,+               text "\t$+8"+           ],+           hcat [+               text "\tb\t",+               ppr lbl+           ]+          ]+          where lbl = mkLocalBlockLabel (getUnique blockid)+                neg_prediction = case prediction of+                  Nothing    -> empty+                  Just True  -> char '-'+                  Just False -> char '+'++   JMP lbl _+     -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"+     | isForeignLabel lbl -> panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"+     | otherwise ->+       hcat [ -- an alias for b that takes a CLabel+           char '\t',+           text "b",+           char '\t',+           ppr lbl+       ]++   MTCTR reg+      -> hcat [+           char '\t',+           text "mtctr",+           char '\t',+           pprReg reg+        ]++   BCTR _ _ _+      -> hcat [+           char '\t',+           text "bctr"+         ]++   BL lbl _+      -> case platformOS platform of+           OSAIX ->+             -- On AIX, "printf" denotes a function-descriptor (for use+             -- by function pointers), whereas the actual entry-code+             -- address is denoted by the dot-prefixed ".printf" label.+             -- Moreover, the PPC NCG only ever emits a BL instruction+             -- for calling C ABI functions. Most of the time these calls+             -- originate from FFI imports and have a 'ForeignLabel',+             -- but when profiling the codegen inserts calls via+             -- 'emitRtsCallGen' which are 'CmmLabel's even though+             -- they'd technically be more like 'ForeignLabel's.+             hcat [+               text "\tbl\t.",+               ppr lbl+             ]+           _ ->+             hcat [+               text "\tbl\t",+               ppr lbl+             ]++   BCTRL _+      -> hcat [+             char '\t',+             text "bctrl"+         ]++   ADD reg1 reg2 ri+      -> pprLogic (sLit "add") reg1 reg2 ri++   ADDIS reg1 reg2 imm+      -> hcat [+           char '\t',+           text "addis",+           char '\t',+           pprReg reg1,+           text ", ",+           pprReg reg2,+           text ", ",+           pprImm imm+           ]++   ADDO reg1 reg2 reg3+      -> pprLogic (sLit "addo") reg1 reg2 (RIReg reg3)++   ADDC reg1 reg2 reg3+      -> pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)++   ADDE reg1 reg2 reg3+      -> pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)++   ADDZE reg1 reg2+      -> pprUnary (sLit "addze") reg1 reg2++   SUBF reg1 reg2 reg3+      -> pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)++   SUBFO reg1 reg2 reg3+      -> pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3)++   SUBFC reg1 reg2 ri+      -> hcat [+           char '\t',+           text "subf",+           case ri of+               RIReg _ -> empty+               RIImm _ -> char 'i',+           text "c\t",+           pprReg reg1,+           text ", ",+           pprReg reg2,+           text ", ",+           pprRI ri+           ]++   SUBFE reg1 reg2 reg3+      -> pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)++   MULL fmt reg1 reg2 ri+      -> pprMul fmt reg1 reg2 ri++   MULLO fmt reg1 reg2 reg3+      -> hcat [+             char '\t',+             text "mull",+             case fmt of+               II32 -> char 'w'+               II64 -> char 'd'+               _    -> panic "PPC: illegal format",+             text "o\t",+             pprReg reg1,+             text ", ",+             pprReg reg2,+             text ", ",+             pprReg reg3+         ]++   MFOV fmt reg+      -> vcat [+           hcat [+               char '\t',+               text "mfxer",+               char '\t',+               pprReg reg+               ],+           hcat [+               char '\t',+               text "extr",+               case fmt of+                 II32 -> char 'w'+                 II64 -> char 'd'+                 _    -> panic "PPC: illegal format",+               text "i\t",+               pprReg reg,+               text ", ",+               pprReg reg,+               text ", 1, ",+               case fmt of+                 II32 -> text "1"+                 II64 -> text "33"+                 _    -> panic "PPC: illegal format"+               ]+           ]++   MULHU fmt reg1 reg2 reg3+      -> hcat [+            char '\t',+            text "mulh",+            case fmt of+              II32 -> char 'w'+              II64 -> char 'd'+              _    -> panic "PPC: illegal format",+            text "u\t",+            pprReg reg1,+            text ", ",+            pprReg reg2,+            text ", ",+            pprReg reg3+        ]++   DIV fmt sgn reg1 reg2 reg3+      -> pprDiv fmt sgn reg1 reg2 reg3++        -- for some reason, "andi" doesn't exist.+        -- we'll use "andi." instead.+   AND reg1 reg2 (RIImm imm)+      -> hcat [+            char '\t',+            text "andi.",+            char '\t',+            pprReg reg1,+            text ", ",+            pprReg reg2,+            text ", ",+            pprImm imm+        ]++   AND reg1 reg2 ri+      -> pprLogic (sLit "and") reg1 reg2 ri++   ANDC reg1 reg2 reg3+      -> pprLogic (sLit "andc") reg1 reg2 (RIReg reg3)++   NAND reg1 reg2 reg3+      -> pprLogic (sLit "nand") reg1 reg2 (RIReg reg3)++   OR reg1 reg2 ri+      -> pprLogic (sLit "or") reg1 reg2 ri++   XOR reg1 reg2 ri+      -> pprLogic (sLit "xor") reg1 reg2 ri++   ORIS reg1 reg2 imm+      -> hcat [+            char '\t',+            text "oris",+            char '\t',+            pprReg reg1,+            text ", ",+            pprReg reg2,+            text ", ",+            pprImm imm+        ]++   XORIS reg1 reg2 imm+      -> hcat [+            char '\t',+            text "xoris",+            char '\t',+            pprReg reg1,+            text ", ",+            pprReg reg2,+            text ", ",+            pprImm imm+        ]++   EXTS fmt reg1 reg2+      -> hcat [+           char '\t',+           text "exts",+           pprFormat fmt,+           char '\t',+           pprReg reg1,+           text ", ",+           pprReg reg2+         ]++   CNTLZ fmt reg1 reg2+      -> hcat [+           char '\t',+           text "cntlz",+           case fmt of+             II32 -> char 'w'+             II64 -> char 'd'+             _    -> panic "PPC: illegal format",+           char '\t',+           pprReg reg1,+           text ", ",+           pprReg reg2+         ]++   NEG reg1 reg2+      -> pprUnary (sLit "neg") reg1 reg2++   NOT reg1 reg2+      -> pprUnary (sLit "not") reg1 reg2++   SR II32 reg1 reg2 (RIImm (ImmInt i))+    -- Handle the case where we are asked to shift a 32 bit register by+    -- less than zero or more than 31 bits. We convert this into a clear+    -- of the destination register.+    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900+      | i < 0  || i > 31 -> pprInstr platform (XOR reg1 reg2 (RIReg reg2))++   SL II32 reg1 reg2 (RIImm (ImmInt i))+    -- As above for SR, but for left shifts.+    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870+      | i < 0  || i > 31 -> pprInstr platform (XOR reg1 reg2 (RIReg reg2))++   SRA II32 reg1 reg2 (RIImm (ImmInt i))+    -- PT: I don't know what to do for negative shift amounts:+    -- For now just panic.+    --+    -- For shift amounts greater than 31 set all bit to the+    -- value of the sign bit, this also what sraw does.+      | i > 31 -> pprInstr platform (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))++   SL fmt reg1 reg2 ri+      -> let op = case fmt of+                       II32 -> "slw"+                       II64 -> "sld"+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)++   SR fmt reg1 reg2 ri+      -> let op = case fmt of+                       II32 -> "srw"+                       II64 -> "srd"+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)++   SRA fmt reg1 reg2 ri+      -> let op = case fmt of+                       II32 -> "sraw"+                       II64 -> "srad"+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)++   RLWINM reg1 reg2 sh mb me+      -> hcat [+             text "\trlwinm\t",+             pprReg reg1,+             text ", ",+             pprReg reg2,+             text ", ",+             int sh,+             text ", ",+             int mb,+             text ", ",+             int me+         ]++   CLRLI fmt reg1 reg2 n+      -> hcat [+            text "\tclrl",+            pprFormat fmt,+            text "i ",+            pprReg reg1,+            text ", ",+            pprReg reg2,+            text ", ",+            int n+        ]++   CLRRI fmt reg1 reg2 n+      -> hcat [+            text "\tclrr",+            pprFormat fmt,+            text "i ",+            pprReg reg1,+            text ", ",+            pprReg reg2,+            text ", ",+            int n+        ]++   FADD fmt reg1 reg2 reg3+      -> pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3++   FSUB fmt reg1 reg2 reg3+      -> pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3++   FMUL fmt reg1 reg2 reg3+      -> pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3++   FDIV fmt reg1 reg2 reg3+      -> pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3++   FABS reg1 reg2+      -> pprUnary (sLit "fabs") reg1 reg2++   FNEG reg1 reg2+      -> pprUnary (sLit "fneg") reg1 reg2++   FCMP reg1 reg2+      -> hcat [+           char '\t',+           text "fcmpu\t0, ",+               -- Note: we're using fcmpu, not fcmpo+               -- The difference is with fcmpo, compare with NaN is an invalid operation.+               -- We don't handle invalid fp ops, so we don't care.+               -- Moreover, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for+               -- better portability since some non-GNU assembler (such as+               -- IBM's `as`) tend not to support the symbolic register name cr0.+               -- This matches the syntax that GCC seems to emit for PPC targets.+           pprReg reg1,+           text ", ",+           pprReg reg2+         ]++   FCTIWZ reg1 reg2+      -> pprUnary (sLit "fctiwz") reg1 reg2++   FCTIDZ reg1 reg2+      -> pprUnary (sLit "fctidz") reg1 reg2++   FCFID reg1 reg2+      -> pprUnary (sLit "fcfid") reg1 reg2++   FRSP reg1 reg2+      -> pprUnary (sLit "frsp") reg1 reg2++   CRNOR dst src1 src2+      -> hcat [+           text "\tcrnor\t",+           int dst,+           text ", ",+           int src1,+           text ", ",+           int src2+         ]++   MFCR reg+      -> hcat [+             char '\t',+             text "mfcr",+             char '\t',+             pprReg reg+         ]++   MFLR reg+      -> hcat [+           char '\t',+           text "mflr",+           char '\t',+           pprReg reg+         ]++   FETCHPC reg+      -> vcat [+             text "\tbcl\t20,31,1f",+             hcat [ text "1:\tmflr\t", pprReg reg ]+         ]++   HWSYNC+      -> text "\tsync"++   ISYNC+      -> text "\tisync"++   LWSYNC+      -> text "\tlwsync"++   NOP+      -> text "\tnop"  pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc pprLogic op reg1 reg2 ri = hcat [
compiler/GHC/CmmToAsm/PPC/RegInfo.hs view
@@ -27,7 +27,7 @@ import GHC.Cmm import GHC.Cmm.CLabel -import Unique+import GHC.Types.Unique import Outputable (ppr, text, Outputable, (<>))  data JumpDest = DestBlockId BlockId
compiler/GHC/CmmToAsm/PPC/Regs.hs view
@@ -57,10 +57,9 @@  import GHC.Cmm import GHC.Cmm.CLabel           ( CLabel )-import Unique+import GHC.Types.Unique  import GHC.Platform.Regs-import GHC.Driver.Session import Outputable import GHC.Platform @@ -199,11 +198,11 @@ -- temporaries and for excess call arguments.  @fpRel@, where -- applicable, is the same but for the frame pointer. -spRel :: DynFlags+spRel :: Platform       -> Int    -- desired stack offset in words, positive or negative       -> AddrMode -spRel dflags n = AddrRegImm sp (ImmInt (n * wORD_SIZE dflags))+spRel platform n = AddrRegImm sp (ImmInt (n * platformWordSizeInBytes platform))   -- argRegs is the set of regs which are read for an n-argument call to C.
compiler/GHC/CmmToAsm/Ppr.hs view
@@ -25,6 +25,7 @@ import AsmUtils import GHC.Cmm.CLabel import GHC.Cmm+import GHC.CmmToAsm.Config import GHC.Driver.Session import FastString import Outputable@@ -203,48 +204,49 @@ -- identical strings in the linker. With -split-sections each string also gets -- a unique section to allow strings from unused code to be GC'd. -pprSectionHeader :: Platform -> Section -> SDoc-pprSectionHeader platform (Section t suffix) =- case platformOS platform of+pprSectionHeader :: NCGConfig -> Section -> SDoc+pprSectionHeader config (Section t suffix) =+ case platformOS (ncgPlatform config) of    OSAIX     -> pprXcoffSectionHeader t    OSDarwin  -> pprDarwinSectionHeader t-   OSMinGW32 -> pprGNUSectionHeader (char '$') t suffix-   _         -> pprGNUSectionHeader (char '.') t suffix+   OSMinGW32 -> pprGNUSectionHeader config (char '$') t suffix+   _         -> pprGNUSectionHeader config (char '.') t suffix -pprGNUSectionHeader :: SDoc -> SectionType -> CLabel -> SDoc-pprGNUSectionHeader sep t suffix = sdocWithDynFlags $ \dflags ->-  let splitSections = gopt Opt_SplitSections dflags-      subsection | splitSections = sep <> ppr suffix-                 | otherwise     = empty-  in  text ".section " <> ptext (header dflags) <> subsection <>-      flags dflags+pprGNUSectionHeader :: NCGConfig -> SDoc -> SectionType -> CLabel -> SDoc+pprGNUSectionHeader config sep t suffix =+  text ".section " <> ptext header <> subsection <> flags   where-    header dflags = case t of+    platform      = ncgPlatform config+    splitSections = ncgSplitSections config+    subsection+      | splitSections = sep <> ppr suffix+      | otherwise     = empty+    header = case t of       Text -> sLit ".text"       Data -> sLit ".data"-      ReadOnlyData  | OSMinGW32 <- platformOS (targetPlatform dflags)+      ReadOnlyData  | OSMinGW32 <- platformOS platform                                 -> sLit ".rdata"                     | otherwise -> sLit ".rodata"-      RelocatableReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags)+      RelocatableReadOnlyData | OSMinGW32 <- platformOS platform                                 -- Concept does not exist on Windows,                                 -- So map these to R/O data.                                           -> sLit ".rdata$rel.ro"                               | otherwise -> sLit ".data.rel.ro"       UninitialisedData -> sLit ".bss"-      ReadOnlyData16 | OSMinGW32 <- platformOS (targetPlatform dflags)+      ReadOnlyData16 | OSMinGW32 <- platformOS platform                                  -> sLit ".rdata$cst16"                      | otherwise -> sLit ".rodata.cst16"       CString-        | OSMinGW32 <- platformOS (targetPlatform dflags)+        | OSMinGW32 <- platformOS platform                     -> sLit ".rdata"         | otherwise -> sLit ".rodata.str"       OtherSection _ ->         panic "PprBase.pprGNUSectionHeader: unknown section type"-    flags dflags = case t of+    flags = case t of       CString-        | OSMinGW32 <- platformOS (targetPlatform dflags)+        | OSMinGW32 <- platformOS platform                     -> empty-        | otherwise -> text ",\"aMS\"," <> sectionType "progbits" <> text ",1"+        | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1"       _ -> empty  -- XCOFF doesn't support relocating label-differences, so we place all
compiler/GHC/CmmToAsm/Reg/Graph.hs view
@@ -16,16 +16,16 @@ import GHC.CmmToAsm.Reg.Graph.TrivColorable import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Reg.Target+import GHC.CmmToAsm.Config import GHC.Platform.Reg.Class import GHC.Platform.Reg  import Bag-import GHC.Driver.Session import Outputable import GHC.Platform-import UniqFM-import UniqSet-import UniqSupply+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Types.Unique.Supply import Util (seqList) import GHC.CmmToAsm.CFG @@ -45,7 +45,7 @@ -- | The top level of the graph coloring register allocator. regAlloc         :: (Outputable statics, Outputable instr, Instruction instr)-        => DynFlags+        => NCGConfig         -> UniqFM (UniqSet RealReg)     -- ^ registers we can use for allocation         -> UniqSet Int                  -- ^ set of available spill slots.         -> Int                          -- ^ current number of spill slots@@ -56,18 +56,15 @@            -- ^ code with registers allocated, additional stacks required            -- and stats for each stage of allocation -regAlloc dflags regsFree slotsFree slotsCount code cfg+regAlloc config regsFree slotsFree slotsCount code cfg  = do-        -- TODO: the regClass function is currently hard coded to the default-        --       target architecture. Would prefer to determine this from dflags.-        --       There are other uses of targetRegClass later in this module.-        let platform = targetPlatform dflags+        let platform = ncgPlatform config             triv = trivColorable platform                         (targetVirtualRegSqueeze platform)                         (targetRealRegSqueeze platform)          (code_final, debug_codeGraphs, slotsCount', _)-                <- regAlloc_spin dflags 0+                <- regAlloc_spin config 0                         triv                         regsFree slotsFree slotsCount [] code cfg @@ -94,7 +91,7 @@            (Instruction instr,             Outputable instr,             Outputable statics)-        => DynFlags+        => NCGConfig         -> Int  -- ^ Number of solver iterations we've already performed.         -> Color.Triv VirtualReg RegClass RealReg                 -- ^ Function for calculating whether a register is trivially@@ -110,17 +107,18 @@                   , Int                  -- Slots in use                   , Color.Graph VirtualReg RegClass RealReg) -regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg+regAlloc_spin config spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg  = do-        let platform = targetPlatform dflags+        let platform = ncgPlatform config          -- If any of these dump flags are turned on we want to hang on to         -- intermediate structures in the allocator - otherwise tell the         -- allocator to ditch them early so we don't end up creating space leaks.         let dump = or-                [ dopt Opt_D_dump_asm_regalloc_stages dflags-                , dopt Opt_D_dump_asm_stats dflags-                , dopt Opt_D_dump_asm_conflicts dflags ]+                [ ncgDumpRegAllocStages config+                , ncgDumpAsmStats       config+                , ncgDumpAsmConflicts   config+                ]          -- Check that we're not running off down the garden path.         when (spinCount > maxSpinCount)@@ -161,14 +159,16 @@                  then   Just $ RegAllocStatsStart                         { raLiveCmm     = code                         , raGraph       = graph-                        , raSpillCosts  = spillCosts }+                        , raSpillCosts  = spillCosts+                        , raPlatform    = platform+                        }                  else   Nothing          -- Try and color the graph.         let (graph_colored, rsSpill, rmCoalesce)                 = {-# SCC "ColorGraph" #-}                   Color.colorGraph-                       (gopt Opt_RegsIterative dflags)+                       (ncgRegsIterative config)                        spinCount                        regsFree triv spill graph @@ -193,7 +193,7 @@                 -- if -fasm-lint is turned on then validate the graph.                 -- This checks for bugs in the graph allocator itself.                 let graph_colored_lint  =-                        if gopt Opt_DoAsmLinting dflags+                        if ncgAsmLinting config                                 then Color.validateGraph (text "")                                         True    -- Require all nodes to be colored.                                         graph_colored@@ -215,7 +215,7 @@                 -- Also rewrite SPILL/RELOAD meta instructions into real machine                 -- instructions along the way                 let code_final-                        = map (stripLive dflags) code_spillclean+                        = map (stripLive config) code_spillclean                  -- Record what happened in this stage for debugging                 let stat@@ -229,7 +229,9 @@                         , raSpillClean          = code_spillclean                         , raFinal               = code_final                         , raSRMs                = foldl' addSRM (0, 0, 0)-                                                $ map countSRMs code_spillclean }+                                                $ map countSRMs code_spillclean+                        , raPlatform    = platform+                     }                  -- Bundle up all the register allocator statistics.                 --   .. but make sure to drop them on the floor if they're not@@ -251,7 +253,7 @@          else do                 -- if -fasm-lint is turned on then validate the graph                 let graph_colored_lint  =-                        if gopt Opt_DoAsmLinting dflags+                        if ncgAsmLinting config                                 then Color.validateGraph (text "")                                         False   -- don't require nodes to be colored                                         graph_colored@@ -289,7 +291,7 @@                 -- Ensure all the statistics are evaluated, to avoid space leaks.                 seqList statList (return ()) -                regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'+                regAlloc_spin config (spinCount + 1) triv regsFree slotsFree'                               slotsCount' statList code_relive cfg
compiler/GHC/CmmToAsm/Reg/Graph/Base.hs view
@@ -24,9 +24,9 @@  import GhcPrelude -import UniqSet-import UniqFM-import Unique+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+import GHC.Types.Unique import MonadUtils (concatMapM)
compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs view
@@ -12,9 +12,9 @@ import GHC.Cmm import Bag import Digraph-import UniqFM-import UniqSet-import UniqSupply+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Types.Unique.Supply   -- | Do register coalescing on this top level thing
compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs view
@@ -18,10 +18,10 @@  import MonadUtils import State-import Unique-import UniqFM-import UniqSet-import UniqSupply+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Types.Unique.Supply import Outputable import GHC.Platform
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -37,9 +37,9 @@  import GHC.Cmm.BlockId import GHC.Cmm-import UniqSet-import UniqFM-import Unique+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+import GHC.Types.Unique import State import Outputable import GHC.Platform
compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -25,8 +25,8 @@ import GHC.Cmm.Dataflow.Collections (mapLookup) import GHC.Cmm.Dataflow.Label import GHC.Cmm-import UniqFM-import UniqSet+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set import Digraph          (flattenSCCs) import Outputable import GHC.Platform
compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -27,10 +27,11 @@ import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target+import GHC.Platform  import Outputable-import UniqFM-import UniqSet+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set import State  -- | Holds interesting statistics from the register allocator.@@ -45,9 +46,13 @@         , raGraph       :: Color.Graph VirtualReg RegClass RealReg            -- | Information to help choose which regs to spill.-        , raSpillCosts  :: SpillCostInfo }+        , raSpillCosts  :: SpillCostInfo +          -- | Target platform+        , raPlatform    :: !Platform+        } +         -- Information about an intermediate graph.         -- This is one that we couldn't color, so had to insert spill code         -- instruction stream.@@ -98,23 +103,27 @@         , raFinal         :: [NatCmmDecl statics instr]            -- | Spill\/reload\/reg-reg moves present in this code.-        , raSRMs          :: (Int, Int, Int) }+        , raSRMs          :: (Int, Int, Int) +          -- | Target platform+        , raPlatform    :: !Platform+        } + instance (Outputable statics, Outputable instr)        => Outputable (RegAllocStats statics instr) where - ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform ->-           text "#  Start"+ ppr (s@RegAllocStatsStart{})+    =      text "#  Start"         $$ text "#  Native code with liveness information."         $$ ppr (raLiveCmm s)         $$ text ""         $$ text "#  Initial register conflict graph."         $$ Color.dotGraph-                (targetRegDotColor platform)-                (trivColorable platform-                        (targetVirtualRegSqueeze platform)-                        (targetRealRegSqueeze platform))+                (targetRegDotColor (raPlatform s))+                (trivColorable (raPlatform s)+                        (targetVirtualRegSqueeze (raPlatform s))+                        (targetRealRegSqueeze (raPlatform s)))                 (raGraph s)  @@ -140,8 +149,7 @@    ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })-    = sdocWithPlatform $ \platform ->-           text "#  Colored"+    =      text "#  Colored"          $$ text "#  Code with liveness information."         $$ ppr (raCode s)@@ -149,10 +157,10 @@          $$ text "#  Register conflict graph (colored)."         $$ Color.dotGraph-                (targetRegDotColor platform)-                (trivColorable platform-                        (targetVirtualRegSqueeze platform)-                        (targetRealRegSqueeze platform))+                (targetRegDotColor (raPlatform s))+                (trivColorable (raPlatform s)+                        (targetVirtualRegSqueeze (raPlatform s))+                        (targetRealRegSqueeze (raPlatform s)))                 (raGraphColored s)         $$ text ""
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -15,7 +15,7 @@  import GraphBase -import UniqSet+import GHC.Types.Unique.Set import GHC.Platform import Panic
compiler/GHC/CmmToAsm/Reg/Graph/X86.hs view
@@ -18,7 +18,7 @@ import GhcPrelude  import GHC.CmmToAsm.Reg.Graph.Base  (Reg(..), RegSub(..), RegClass(..))-import UniqSet+import GHC.Types.Unique.Set  import qualified Data.Array as A
compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -119,6 +119,7 @@ import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Config import GHC.Platform.Reg  import GHC.Cmm.BlockId@@ -126,11 +127,10 @@ import GHC.Cmm hiding (RegSet)  import Digraph-import GHC.Driver.Session-import Unique-import UniqSet-import UniqFM-import UniqSupply+import GHC.Types.Unique+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+import GHC.Types.Unique.Supply import Outputable import GHC.Platform @@ -144,7 +144,7 @@ -- Allocate registers regAlloc         :: (Outputable instr, Instruction instr)-        => DynFlags+        => NCGConfig         -> LiveCmmDecl statics instr         -> UniqSM ( NatCmmDecl statics instr                   , Maybe Int  -- number of extra stack slots required,@@ -163,19 +163,19 @@                  , Nothing                  , Nothing ) -regAlloc dflags (CmmProc static lbl live sccs)+regAlloc config (CmmProc static lbl live sccs)         | LiveInfo info entry_ids@(first_id:_) block_live _ <- static         = do                 -- do register allocation on each component.                 (final_blocks, stats, stack_use)-                        <- linearRegAlloc dflags entry_ids block_live sccs+                        <- linearRegAlloc config entry_ids block_live sccs                  -- make sure the block that was first in the input list                 --      stays at the front of the output                 let ((first':_), rest')                                 = partition ((== first_id) . blockId) final_blocks -                let max_spill_slots = maxSpillSlots dflags+                let max_spill_slots = maxSpillSlots config                     extra_stack                       | stack_use > max_spill_slots                       = Just (stack_use - max_spill_slots)@@ -201,7 +201,7 @@ -- linearRegAlloc         :: (Outputable instr, Instruction instr)-        => DynFlags+        => NCGConfig         -> [BlockId] -- ^ entry points         -> BlockMap RegSet               -- ^ live regs on entry to each basic block@@ -209,7 +209,7 @@               -- ^ instructions annotated with "deaths"         -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) -linearRegAlloc dflags entry_ids block_live sccs+linearRegAlloc config entry_ids block_live sccs  = case platformArch platform of       ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)       ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)@@ -226,22 +226,22 @@       ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"       ArchUnknown    -> panic "linearRegAlloc ArchUnknown"  where-  go f = linearRegAlloc' dflags f entry_ids block_live sccs-  platform = targetPlatform dflags+  go f = linearRegAlloc' config f entry_ids block_live sccs+  platform = ncgPlatform config  linearRegAlloc'         :: (FR freeRegs, Outputable instr, Instruction instr)-        => DynFlags+        => NCGConfig         -> freeRegs         -> [BlockId]                    -- ^ entry points         -> BlockMap RegSet              -- ^ live regs on entry to each basic block         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"         -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) -linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs+linearRegAlloc' config initFreeRegs entry_ids block_live sccs  = do   us      <- getUniqueSupplyM         let (_, stack, stats, blocks) =-                runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us+                runR config mapEmpty initFreeRegs emptyRegMap emptyStackMap us                     $ linearRA_SCCs entry_ids block_live [] sccs         return  (blocks, stats, getStackUse stack) @@ -342,9 +342,8 @@ initBlock :: FR freeRegs           => BlockId -> BlockMap RegSet -> RegM freeRegs () initBlock id block_live- = do   dflags <- getDynFlags-        let platform = targetPlatform dflags-        block_assig     <- getBlockAssigR+ = do   platform    <- getPlatform+        block_assig <- getBlockAssigR         case mapLookup id block_assig of                 -- no prior info about this block: we must consider                 -- any fixed regs to be allocated, but we can ignore@@ -487,8 +486,7 @@           -> RegM freeRegs ([instr], [NatBasicBlock instr])  genRaInsn block_live new_instrs block_id instr r_dying w_dying = do-  dflags <- getDynFlags-  let platform = targetPlatform dflags+  platform <- getPlatform   case regUsageOfInstr platform instr of { RU read written ->     do     let real_written    = [ rr  | (RegReal     rr) <- written ]@@ -590,8 +588,7 @@  releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () releaseRegs regs = do-  dflags <- getDynFlags-  let platform = targetPlatform dflags+  platform <- getPlatform   assig <- getAssigR   free <- getFreeRegsR   let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return ()@@ -651,8 +648,7 @@             = return (instrs, assig)       clobber assig instrs ((temp, reg) : rest)-       = do dflags <- getDynFlags-            let platform = targetPlatform dflags+       = do platform <- getPlatform              freeRegs <- getFreeRegsR             let regclass = targetClassOfRealReg platform reg@@ -693,10 +689,8 @@         = return ()  clobberRegs clobbered- = do   dflags <- getDynFlags-        let platform = targetPlatform dflags--        freeregs        <- getFreeRegsR+ = do   platform <- getPlatform+        freeregs <- getFreeRegsR         setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered          assig           <- getAssigR@@ -799,9 +793,8 @@                         -> SpillLoc                         -> RegM freeRegs ([instr], [RealReg]) allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc- = do   dflags <- getDynFlags-        let platform = targetPlatform dflags-        freeRegs                <- getFreeRegsR+ = do   platform <- getPlatform+        freeRegs <- getFreeRegsR         let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs          case freeRegs_thisClass of
compiler/GHC/CmmToAsm/Reg/Linear/Base.hs view
@@ -21,13 +21,13 @@  import GHC.CmmToAsm.Reg.Linear.StackMap import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Config import GHC.Platform.Reg -import GHC.Driver.Session import Outputable-import Unique-import UniqFM-import UniqSupply+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Supply import GHC.Cmm.BlockId  @@ -133,7 +133,9 @@         --      Just keep a list here instead of a map of regs -> reasons.         --      We don't want to slow down the allocator if we're not going to emit the stats.         , ra_spills     :: [SpillReason]-        , ra_DynFlags   :: DynFlags++        -- | Native code generator configuration+        , ra_config     :: !NCGConfig          -- | (from,fixup,to) : We inserted fixup code between from and to         , ra_fixups     :: [(BlockId,BlockId,BlockId)] }
compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs view
@@ -14,7 +14,7 @@ import GHC.Platform.Reg import GHC.Platform.Reg.Class -import GHC.Driver.Session+import GHC.CmmToAsm.Config import Panic import GHC.Platform @@ -69,21 +69,19 @@     frInitFreeRegs = SPARC.initFreeRegs     frReleaseReg   = SPARC.releaseReg -maxSpillSlots :: DynFlags -> Int-maxSpillSlots dflags-              = case platformArch (targetPlatform dflags) of-                ArchX86       -> X86.Instr.maxSpillSlots dflags-                ArchX86_64    -> X86.Instr.maxSpillSlots dflags-                ArchPPC       -> PPC.Instr.maxSpillSlots dflags-                ArchS390X     -> panic "maxSpillSlots ArchS390X"-                ArchSPARC     -> SPARC.Instr.maxSpillSlots dflags-                ArchSPARC64   -> panic "maxSpillSlots ArchSPARC64"-                ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"-                ArchARM64     -> panic "maxSpillSlots ArchARM64"-                ArchPPC_64 _  -> PPC.Instr.maxSpillSlots dflags-                ArchAlpha     -> panic "maxSpillSlots ArchAlpha"-                ArchMipseb    -> panic "maxSpillSlots ArchMipseb"-                ArchMipsel    -> panic "maxSpillSlots ArchMipsel"-                ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"-                ArchUnknown   -> panic "maxSpillSlots ArchUnknown"-+maxSpillSlots :: NCGConfig -> Int+maxSpillSlots config = case platformArch (ncgPlatform config) of+   ArchX86       -> X86.Instr.maxSpillSlots config+   ArchX86_64    -> X86.Instr.maxSpillSlots config+   ArchPPC       -> PPC.Instr.maxSpillSlots config+   ArchS390X     -> panic "maxSpillSlots ArchS390X"+   ArchSPARC     -> SPARC.Instr.maxSpillSlots config+   ArchSPARC64   -> panic "maxSpillSlots ArchSPARC64"+   ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"+   ArchARM64     -> panic "maxSpillSlots ArchARM64"+   ArchPPC_64 _  -> PPC.Instr.maxSpillSlots config+   ArchAlpha     -> panic "maxSpillSlots ArchAlpha"+   ArchMipseb    -> panic "maxSpillSlots ArchMipseb"+   ArchMipsel    -> panic "maxSpillSlots ArchMipsel"+   ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"+   ArchUnknown   -> panic "maxSpillSlots ArchUnknown"
compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs view
@@ -17,16 +17,16 @@ import GHC.CmmToAsm.Reg.Linear.FreeRegs import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Config import GHC.Platform.Reg  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import Digraph-import GHC.Driver.Session import Outputable-import Unique-import UniqFM-import UniqSet+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set  -- | For a jump instruction at the end of a block, generate fixup code so its --      vregs are in the correct regs for its destination.@@ -125,8 +125,8 @@         block_assig src_assig         to_free - = do   dflags <- getDynFlags-        let platform = targetPlatform dflags+ = do   config <- getConfig+        let platform = ncgPlatform config          -- free up the regs that are not live on entry to this block.         freeregs        <- getFreeRegsR@@ -355,8 +355,8 @@     -> RegM freeRegs instr  -- ^ move instruction.  makeMove delta vreg src dst- = do dflags <- getDynFlags-      let platform = targetPlatform dflags+ = do config <- getConfig+      let platform = ncgPlatform config        case (src, dst) of           (InReg s, InReg d) ->@@ -364,10 +364,10 @@                  return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d)           (InMem s, InReg d) ->               do recordSpill (SpillJoinRM vreg)-                 return $ mkLoadInstr dflags (RegReal d) delta s+                 return $ mkLoadInstr config (RegReal d) delta s           (InReg s, InMem d) ->               do recordSpill (SpillJoinRM vreg)-                 return $ mkSpillInstr dflags (RegReal s) delta d+                 return $ mkSpillInstr config (RegReal s) delta d           _ ->               -- we don't handle memory to memory moves.               -- they shouldn't happen because we don't share
compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs view
@@ -22,9 +22,8 @@  import GhcPrelude -import GHC.Driver.Session-import UniqFM-import Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique   -- | Identifier for a stack slot.@@ -40,8 +39,8 @@   -- | An empty stack map, with all slots available.-emptyStackMap :: DynFlags -> StackMap-emptyStackMap _ = StackMap 0 emptyUFM+emptyStackMap :: StackMap+emptyStackMap = StackMap 0 emptyUFM   -- | If this vreg unique already has a stack assignment then return the slot number,
compiler/GHC/CmmToAsm/Reg/Linear/State.hs view
@@ -30,6 +30,8 @@         getDeltaR,          getUniqueR,+        getConfig,+        getPlatform,          recordSpill,         recordFixupBlock@@ -43,12 +45,13 @@ import GHC.CmmToAsm.Reg.Linear.Base import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Config import GHC.Platform.Reg import GHC.Cmm.BlockId -import GHC.Driver.Session-import Unique-import UniqSupply+import GHC.Platform+import GHC.Types.Unique+import GHC.Types.Unique.Supply  import Control.Monad (ap) @@ -79,12 +82,16 @@ instance Monad (RegM freeRegs) where   m >>= k   =  RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s } -instance HasDynFlags (RegM a) where-    getDynFlags = RegM $ \s -> RA_Result s (ra_DynFlags s)+-- | Get native code generator configuration+getConfig :: RegM a NCGConfig+getConfig = RegM $ \s -> RA_Result s (ra_config s) +-- | Get target platform from native code generator configuration+getPlatform :: RegM a Platform+getPlatform = ncgPlatform <$> getConfig  -- | Run a computation in the RegM register allocator monad.-runR    :: DynFlags+runR    :: NCGConfig         -> BlockAssignment freeRegs         -> freeRegs         -> RegMap Loc@@ -93,7 +100,7 @@         -> RegM freeRegs a         -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) -runR dflags block_assig freeregs assig stack us thing =+runR config block_assig freeregs assig stack us thing =   case unReg thing         (RA_State                 { ra_blockassig = block_assig@@ -103,7 +110,7 @@                 , ra_stack      = stack                 , ra_us         = us                 , ra_spills     = []-                , ra_DynFlags   = dflags+                , ra_config     = config                 , ra_fixups     = [] })    of         RA_Result state returned_thing@@ -121,10 +128,9 @@ spillR :: Instruction instr        => Reg -> Unique -> RegM freeRegs (instr, Int) -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack0} ->-  let dflags = ra_DynFlags s-      (stack1,slot) = getStackSlotFor stack0 temp-      instr  = mkSpillInstr dflags reg delta slot+spillR reg temp = RegM $ \s ->+  let (stack1,slot) = getStackSlotFor (ra_stack s) temp+      instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slot   in   RA_Result s{ra_stack=stack1} (instr,slot) @@ -132,9 +138,8 @@ loadR :: Instruction instr       => Reg -> Int -> RegM freeRegs instr -loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->-  let dflags = ra_DynFlags s-  in RA_Result s (mkLoadInstr dflags reg delta slot)+loadR reg slot = RegM $ \s ->+  RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)  getFreeRegsR :: RegM freeRegs freeRegs getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs view
@@ -12,7 +12,7 @@ import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr -import UniqFM+import GHC.Types.Unique.FM import Outputable  import State
compiler/GHC/CmmToAsm/Reg/Liveness.hs view
@@ -41,21 +41,21 @@  import GHC.Platform.Reg import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Config  import GHC.Cmm.BlockId-import GHC.CmmToAsm.CFG import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm hiding (RegSet, emptyRegSet)  import Digraph-import GHC.Driver.Session import MonadUtils import Outputable import GHC.Platform-import UniqSet-import UniqFM-import UniqSupply+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+import GHC.Types.Unique.Supply import Bag import State @@ -483,11 +483,11 @@ -- | Strip away liveness information, yielding NatCmmDecl stripLive         :: (Outputable statics, Outputable instr, Instruction instr)-        => DynFlags+        => NCGConfig         -> LiveCmmDecl statics instr         -> NatCmmDecl statics instr -stripLive dflags live+stripLive config live         = stripCmm live   where  stripCmm :: (Outputable statics, Outputable instr, Instruction instr)@@ -503,7 +503,7 @@                                 = partition ((== first_id) . blockId) final_blocks             in   CmmProc info label live-                          (ListGraph $ map (stripLiveBlock dflags) $ first' : rest')+                          (ListGraph $ map (stripLiveBlock config) $ first' : rest')          -- If the proc has blocks but we don't know what the first one was, then we're dead.         stripCmm proc@@ -514,11 +514,11 @@  stripLiveBlock         :: Instruction instr-        => DynFlags+        => NCGConfig         -> LiveBasicBlock instr         -> NatBasicBlock instr -stripLiveBlock dflags (BasicBlock i lis)+stripLiveBlock config (BasicBlock i lis)  =      BasicBlock i instrs'   where  (instrs', _)@@ -529,11 +529,11 @@          spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)          = do   delta   <- get-                spillNat (mkSpillInstr dflags reg delta slot : acc) instrs+                spillNat (mkSpillInstr config reg delta slot : acc) instrs          spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)          = do   delta   <- get-                spillNat (mkLoadInstr dflags reg delta slot : acc) instrs+                spillNat (mkLoadInstr config reg delta slot : acc) instrs          spillNat acc (LiveInstr (Instr instr) _ : instrs)          | Just i <- takeDeltaInstr instr
compiler/GHC/CmmToAsm/Reg/Target.hs view
@@ -28,7 +28,7 @@ import GHC.CmmToAsm.Format  import Outputable-import Unique+import GHC.Types.Unique import GHC.Platform  import qualified GHC.CmmToAsm.X86.Regs       as X86
compiler/GHC/CmmToAsm/SPARC/Base.hs view
@@ -8,7 +8,6 @@ module GHC.CmmToAsm.SPARC.Base (         wordLength,         wordLengthInBits,-        spillAreaLength,         spillSlotSize,         extraStackArgsHere,         fits13Bits,@@ -20,7 +19,6 @@  import GhcPrelude -import GHC.Driver.Session import Panic  import Data.Int@@ -33,11 +31,6 @@ wordLengthInBits :: Int wordLengthInBits         = wordLength * 8---- Size of the available spill area-spillAreaLength :: DynFlags -> Int-spillAreaLength-        = rESERVED_C_STACK_BYTES  -- | We need 8 bytes because our largest registers are 64 bit. spillSlotSize :: Int
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs view
@@ -36,7 +36,8 @@ import GHC.CmmToAsm.SPARC.Stack import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Monad   ( NatM, getNewRegNat, getNewLabelNat )+import GHC.CmmToAsm.Monad   ( NatM, getNewRegNat, getNewLabelNat, getPlatform, getConfig )+import GHC.CmmToAsm.Config  -- Our intermediate code: import GHC.Cmm.BlockId@@ -51,7 +52,7 @@ import GHC.CmmToAsm.CPrim  -- The rest:-import BasicTypes+import GHC.Types.Basic import GHC.Driver.Session import FastString import OrdList@@ -123,7 +124,8 @@  stmtToInstrs :: CmmNode e x -> NatM InstrBlock stmtToInstrs stmt = do-  dflags <- getDynFlags+  platform <- getPlatform+  config <- getConfig   case stmt of     CmmComment s   -> return (unitOL (COMMENT s))     CmmTick {}     -> return nilOL@@ -133,14 +135,14 @@       | isFloatType ty  -> assignReg_FltCode format reg src       | isWord64 ty     -> assignReg_I64Code        reg src       | otherwise       -> assignReg_IntCode format reg src-        where ty = cmmRegType dflags reg+        where ty = cmmRegType platform reg               format = cmmTypeFormat ty      CmmStore addr src       | isFloatType ty  -> assignMem_FltCode format addr src       | isWord64 ty     -> assignMem_I64Code      addr src       | otherwise       -> assignMem_IntCode format addr src-        where ty = cmmExprType dflags src+        where ty = cmmExprType platform src               format = cmmTypeFormat ty      CmmUnsafeForeignCall target result_regs args@@ -151,8 +153,7 @@       b1 <- genCondJump true arg       b2 <- genBranch false       return (b1 `appOL` b2)-    CmmSwitch arg ids   -> do dflags <- getDynFlags-                              genSwitch dflags arg ids+    CmmSwitch arg ids   -> genSwitch config arg ids     CmmCall { cml_target = arg } -> genJump arg      _@@ -180,8 +181,8 @@   -- | Convert a BlockId to some CmmStatic data-jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic-jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))+jumpTableEntry :: Platform -> Maybe BlockId -> CmmStatic+jumpTableEntry platform Nothing = CmmStaticLit (CmmInt 0 (wordWidth platform)) jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)     where blockLabel = blockLbl blockid @@ -208,9 +209,9 @@  assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock assignReg_IntCode _ reg src = do-    dflags <- getDynFlags+    platform <- getPlatform     r <- getRegister src-    let dst = getRegisterReg (targetPlatform dflags) reg+    let dst = getRegisterReg platform reg     return $ case r of         Any _ code         -> code dst         Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst@@ -220,12 +221,12 @@ -- Floating point assignment to memory assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock assignMem_FltCode pk addr src = do-    dflags <- getDynFlags+    platform <- getPlatform     Amode dst__2 code1 <- getAmode addr     (src__2, code2) <- getSomeReg src     tmp1 <- getNewRegNat pk     let-        pk__2   = cmmExprType dflags src+        pk__2   = cmmExprType platform src         code__2 = code1 `appOL` code2 `appOL`             if   formatToWidth pk == typeWidth pk__2             then unitOL (ST pk src__2 dst__2)@@ -236,8 +237,7 @@ -- Floating point assignment to a register/temporary assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock assignReg_FltCode pk dstCmmReg srcCmmExpr = do-    dflags <- getDynFlags-    let platform = targetPlatform dflags+    platform <- getPlatform     srcRegister <- getRegister srcCmmExpr     let dstReg  = getRegisterReg platform dstCmmReg @@ -309,13 +309,13 @@ -- ----------------------------------------------------------------------------- -- Generating a table-branch -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock-genSwitch dflags expr targets-        | positionIndependent dflags+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch config expr targets+        | ncgPIC config         = error "MachCodeGen: sparc genSwitch PIC not finished\n"          | otherwise-        = do    (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset)+        = do    (e_reg, e_code) <- getSomeReg (cmmOffset (ncgPlatform config) expr offset)                  base_reg        <- getNewRegNat II32                 offset_reg      <- getNewRegNat II32@@ -338,10 +338,10 @@                         , NOP ]   where (offset, ids) = switchTargetsToTable targets -generateJumpTableForInstr :: DynFlags -> Instr+generateJumpTableForInstr :: Platform -> Instr                           -> Maybe (NatCmmDecl RawCmmStatics Instr)-generateJumpTableForInstr dflags (JMP_TBL _ ids label) =-  let jumpTable = map (jumpTableEntry dflags) ids+generateJumpTableForInstr platform (JMP_TBL _ ids label) =+  let jumpTable = map (jumpTableEntry platform) ids   in Just (CmmData (Section ReadOnlyData label) (RawCmmStatics label jumpTable)) generateJumpTableForInstr _ _ = Nothing @@ -469,21 +469,21 @@ -- | Generate code to calculate an argument, and move it into one --      or two integer vregs. arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])-arg_to_int_vregs arg = do dflags <- getDynFlags-                          arg_to_int_vregs' dflags arg+arg_to_int_vregs arg = do platform <- getPlatform+                          arg_to_int_vregs' platform arg -arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg])-arg_to_int_vregs' dflags arg+arg_to_int_vregs' :: Platform -> CmmExpr -> NatM (OrdList Instr, [Reg])+arg_to_int_vregs' platform arg          -- If the expr produces a 64 bit int, then we can just use iselExpr64-        | isWord64 (cmmExprType dflags arg)+        | isWord64 (cmmExprType platform arg)         = do    (ChildCode64 code r_lo) <- iselExpr64 arg                 let r_hi                = getHiVRegFromLo r_lo                 return (code, [r_hi, r_lo])          | otherwise         = do    (src, code)     <- getSomeReg arg-                let pk          = cmmExprType dflags arg+                let pk          = cmmExprType platform arg                  case cmmTypeFormat pk of
compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs view
@@ -27,8 +27,8 @@         -> NatM Amode  getAmode tree@(CmmRegOff _ _)-    = do dflags <- getDynFlags-         getAmode (mangleIndexTree dflags tree)+    = do platform <- getPlatform+         getAmode (mangleIndexTree platform tree)  getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)])   | fits13Bits (-i)
compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs view
@@ -23,7 +23,6 @@ import GHC.Platform.Reg  import GHC.Platform.Regs-import GHC.Driver.Session import GHC.Cmm import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Platform@@ -109,11 +108,11 @@  -- Expand CmmRegOff.  ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff?-mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr+mangleIndexTree :: Platform -> CmmExpr -> CmmExpr -mangleIndexTree dflags (CmmRegOff reg off)+mangleIndexTree platform (CmmRegOff reg off)         = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-        where width = typeWidth (cmmRegType dflags reg)+        where width = typeWidth (cmmRegType platform reg)  mangleIndexTree _ _         = panic "SPARC.CodeGen.Base.mangleIndexTree: no match"
compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs view
@@ -87,15 +87,15 @@  condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode condFltCode cond x y = do-    dflags <- getDynFlags+    platform <- getPlatform     (src1, code1) <- getSomeReg x     (src2, code2) <- getSomeReg y     tmp <- getNewRegNat FF64     let         promote x = FxTOy FF32 FF64 x tmp -        pk1   = cmmExprType dflags x-        pk2   = cmmExprType dflags y+        pk1   = cmmExprType platform x+        pk2   = cmmExprType platform y          code__2 =                 if pk1 `cmmEqType` pk2 then
compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs view
@@ -26,7 +26,6 @@ import GHC.Cmm  import Control.Monad (liftM)-import GHC.Driver.Session import OrdList import Outputable @@ -49,14 +48,13 @@ getRegister :: CmmExpr -> NatM Register  getRegister (CmmReg reg)-  = do dflags <- getDynFlags-       let platform = targetPlatform dflags-       return (Fixed (cmmTypeFormat (cmmRegType dflags reg))+  = do platform <- getPlatform+       return (Fixed (cmmTypeFormat (cmmRegType platform reg))                      (getRegisterReg platform reg) nilOL)  getRegister tree@(CmmRegOff _ _)-  = do dflags <- getDynFlags-       getRegister (mangleIndexTree dflags tree)+  = do platform <- getPlatform+       getRegister (mangleIndexTree platform tree)  getRegister (CmmMachOp (MO_UU_Conv W64 W32)              [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do@@ -483,15 +481,15 @@         -> NatM Register  trivialFCode pk instr x y = do-    dflags <- getDynFlags+    platform <- getPlatform     (src1, code1) <- getSomeReg x     (src2, code2) <- getSomeReg y     tmp <- getNewRegNat FF64     let         promote x = FxTOy FF32 FF64 x tmp -        pk1   = cmmExprType dflags x-        pk2   = cmmExprType dflags y+        pk1   = cmmExprType platform x+        pk2   = cmmExprType platform y          code__2 dst =                 if pk1 `cmmEqType` pk2 then
compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs view
@@ -24,7 +24,6 @@  import GHC.Cmm -import GHC.Driver.Session import OrdList import Outputable @@ -184,9 +183,8 @@         -- compute expr and load it into r_dst_lo         (a_reg, a_code) <- getSomeReg expr -        dflags <- getDynFlags-        let platform = targetPlatform dflags-            code        = a_code+        platform        <- getPlatform+        let code        = a_code                 `appOL` toOL                         [ mkRegRegMoveInstr platform g0    r_dst_hi     -- clear high 32 bits                         , mkRegRegMoveInstr platform a_reg r_dst_lo ]@@ -202,9 +200,8 @@         -- compute expr and load it into r_dst_lo         (a_reg, a_code) <- getSomeReg expr -        dflags          <- getDynFlags-        let platform    = targetPlatform dflags-            code        = a_code+        platform        <- getPlatform+        let code        = a_code                 `appOL` toOL                         [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi                         , mkRegRegMoveInstr platform a_reg r_dst_lo ]
compiler/GHC/CmmToAsm/SPARC/Instr.hs view
@@ -37,11 +37,11 @@ import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Config  import GHC.Cmm.CLabel import GHC.Platform.Regs import GHC.Cmm.BlockId-import GHC.Driver.Session import GHC.Cmm import FastString import Outputable@@ -369,15 +369,15 @@ -- | Make a spill instruction. --      On SPARC we spill below frame pointer leaving 2 words/spill sparc_mkSpillInstr-    :: DynFlags+    :: NCGConfig     -> Reg      -- ^ register to spill     -> Int      -- ^ current stack delta     -> Int      -- ^ spill slot to use     -> Instr -sparc_mkSpillInstr dflags reg _ slot- = let  platform = targetPlatform dflags-        off      = spillSlotToOffset dflags slot+sparc_mkSpillInstr config reg _ slot+ = let  platform = ncgPlatform config+        off      = spillSlotToOffset config slot         off_w    = 1 + (off `div` 4)         fmt      = case targetClassOfReg platform reg of                         RcInteger -> II32@@ -389,15 +389,15 @@  -- | Make a spill reload instruction. sparc_mkLoadInstr-    :: DynFlags+    :: NCGConfig     -> Reg      -- ^ register to load into     -> Int      -- ^ current stack delta     -> Int      -- ^ spill slot to use     -> Instr -sparc_mkLoadInstr dflags reg _ slot-  = let platform = targetPlatform dflags-        off      = spillSlotToOffset dflags slot+sparc_mkLoadInstr config reg _ slot+  = let platform = ncgPlatform config+        off      = spillSlotToOffset config slot         off_w    = 1 + (off `div` 4)         fmt      = case targetClassOfReg platform reg of                         RcInteger -> II32
compiler/GHC/CmmToAsm/SPARC/Ppr.hs view
@@ -36,6 +36,7 @@ import GHC.Platform.Reg import GHC.CmmToAsm.Format import GHC.CmmToAsm.Ppr+import GHC.CmmToAsm.Config  import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.Ppr() -- For Outputable instances@@ -44,7 +45,7 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Collections -import Unique           ( pprUniqueAlways )+import GHC.Types.Unique ( pprUniqueAlways ) import Outputable import GHC.Platform import FastString@@ -52,25 +53,26 @@ -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: NatCmmDecl RawCmmStatics Instr -> SDoc-pprNatCmmDecl (CmmData section dats) =-  pprSectionAlign section $$ pprDatas dats+pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc+pprNatCmmDecl config (CmmData section dats) =+  pprSectionAlign config section+  $$ pprDatas (ncgPlatform config) dats -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  let platform = ncgPlatform config in   case topInfoTable proc of     Nothing ->         -- special case for code without info table:-        pprSectionAlign (Section Text lbl) $$-        pprLabel lbl $$ -- blocks guaranteed not null, so label needed-        vcat (map (pprBasicBlock top_info) blocks)+        pprSectionAlign config (Section Text lbl) $$+        pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed+        vcat (map (pprBasicBlock platform top_info) blocks)      Just (RawCmmStatics info_lbl _) ->-      sdocWithPlatform $ \platform ->       (if platformHasSubsectionsViaSymbols platform-          then pprSectionAlign dspSection $$+          then pprSectionAlign config dspSection $$                ppr (mkDeadStripPreventer info_lbl) <> char ':'           else empty) $$-      vcat (map (pprBasicBlock top_info) blocks) $$+      vcat (map (pprBasicBlock platform top_info) blocks) $$       -- above: Even the first block gets a label, because with branch-chain       -- elimination, it might be the target of a goto.       (if platformHasSubsectionsViaSymbols platform@@ -86,23 +88,23 @@ dspSection = Section Text $     panic "subsections-via-symbols doesn't combine with split-sections" -pprBasicBlock :: LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc-pprBasicBlock info_env (BasicBlock blockid instrs)+pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc+pprBasicBlock platform info_env (BasicBlock blockid instrs)   = maybe_infotable $$-    pprLabel (blockLbl blockid) $$+    pprLabel platform (blockLbl blockid) $$     vcat (map pprInstr instrs)   where     maybe_infotable = case mapLookup blockid info_env of        Nothing   -> empty        Just (RawCmmStatics info_lbl info) ->            pprAlignForSection Text $$-           vcat (map pprData info) $$-           pprLabel info_lbl+           vcat (map (pprData platform) info) $$+           pprLabel platform info_lbl  -pprDatas :: RawCmmStatics -> SDoc+pprDatas :: Platform -> RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in CLabel.-pprDatas (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+pprDatas _platform (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])   | lbl == mkIndStaticInfoLabel   , let labelInd (CmmLabelOff l _) = Just l         labelInd (CmmLabel l) = Just l@@ -111,29 +113,29 @@   , alias `mayRedirectTo` ind'   = pprGloblDecl alias     $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')-pprDatas (RawCmmStatics lbl dats) = vcat (pprLabel lbl : map pprData dats)+pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: CmmStatic -> SDoc-pprData (CmmString str)          = pprBytes str-pprData (CmmUninitialised bytes) = text ".skip " <> int bytes-pprData (CmmStaticLit lit)       = pprDataItem lit+pprData :: Platform -> CmmStatic -> SDoc+pprData _ (CmmString str)           = pprBytes str+pprData _ (CmmUninitialised bytes)  = text ".skip " <> int bytes+pprData platform (CmmStaticLit lit) = pprDataItem platform lit  pprGloblDecl :: CLabel -> SDoc pprGloblDecl lbl   | not (externallyVisibleCLabel lbl) = empty   | otherwise = text ".global " <> ppr lbl -pprTypeAndSizeDecl :: CLabel -> SDoc-pprTypeAndSizeDecl lbl-    = sdocWithPlatform $ \platform ->-      if platformOS platform == OSLinux && externallyVisibleCLabel lbl+pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc+pprTypeAndSizeDecl platform lbl+    = if platformOS platform == OSLinux && externallyVisibleCLabel lbl       then text ".type " <> ppr lbl <> ptext (sLit ", @object")       else empty -pprLabel :: CLabel -> SDoc-pprLabel lbl = pprGloblDecl lbl-            $$ pprTypeAndSizeDecl lbl-            $$ (ppr lbl <> char ':')+pprLabel :: Platform -> CLabel -> SDoc+pprLabel platform lbl =+   pprGloblDecl lbl+   $$ pprTypeAndSizeDecl platform lbl+   $$ (ppr lbl <> char ':')  -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr'@@ -321,10 +323,9 @@ --      On SPARC all the data sections must be at least 8 byte aligned --      incase we store doubles in them. ---pprSectionAlign :: Section -> SDoc-pprSectionAlign sec@(Section seg _) =-  sdocWithPlatform $ \platform ->-    pprSectionHeader platform sec $$+pprSectionAlign :: NCGConfig -> Section -> SDoc+pprSectionAlign config sec@(Section seg _) =+    pprSectionHeader config sec $$     pprAlignForSection seg  -- | Print appropriate alignment for the given section type.@@ -344,10 +345,9 @@       OtherSection _    -> panic "PprMach.pprSectionHeader: unknown section")  -- | Pretty print a data item.-pprDataItem :: CmmLit -> SDoc-pprDataItem lit-  = sdocWithDynFlags $ \dflags ->-    vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)+pprDataItem :: Platform -> CmmLit -> SDoc+pprDataItem platform lit+  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)     where         imm = litToImm lit
compiler/GHC/CmmToAsm/SPARC/Regs.hs view
@@ -39,7 +39,7 @@ import GHC.Platform.Reg.Class import GHC.CmmToAsm.Format -import Unique+import GHC.Types.Unique import Outputable  {-
compiler/GHC/CmmToAsm/SPARC/Stack.hs view
@@ -13,8 +13,8 @@ import GHC.CmmToAsm.SPARC.Regs import GHC.CmmToAsm.SPARC.Base import GHC.CmmToAsm.SPARC.Imm+import GHC.CmmToAsm.Config -import GHC.Driver.Session import Outputable  -- | Get an AddrMode relative to the address in sp.@@ -37,15 +37,15 @@  -- | Convert a spill slot number to a *byte* offset, with no sign. ---spillSlotToOffset :: DynFlags -> Int -> Int-spillSlotToOffset dflags slot-        | slot >= 0 && slot < maxSpillSlots dflags+spillSlotToOffset :: NCGConfig -> Int -> Int+spillSlotToOffset config slot+        | slot >= 0 && slot < maxSpillSlots config         = 64 + spillSlotSize * slot          | otherwise         = pprPanic "spillSlotToOffset:"                       (   text "invalid spill location: " <> int slot-                      $$  text "maxSpillSlots:          " <> int (maxSpillSlots dflags))+                      $$  text "maxSpillSlots:          " <> int (maxSpillSlots config))   -- | The maximum number of spill slots available on the C stack.@@ -54,6 +54,6 @@ --      Why do we reserve 64 bytes, instead of using the whole thing?? --              -- BL 2009/02/15 ---maxSpillSlots :: DynFlags -> Int-maxSpillSlots dflags-        = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1+maxSpillSlots :: NCGConfig -> Int+maxSpillSlots config+        = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize) - 1
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -41,7 +41,7 @@ import GHC.CmmToAsm.X86.Instr import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.X86.Regs-import GHC.CmmToAsm.X86.Ppr (  )+import GHC.CmmToAsm.X86.Ppr import GHC.CmmToAsm.X86.RegInfo  import GHC.Platform.Regs@@ -56,17 +56,18 @@    ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat    , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat    , getPicBaseMaybeNat, getDebugBlock, getFileId-   , addImmediateSuccessorNat, updateCfgNat+   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform    ) import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Config import GHC.Platform.Reg import GHC.Platform  -- Our intermediate code:-import BasicTypes+import GHC.Types.Basic import GHC.Cmm.BlockId-import Module           ( primUnitId )+import GHC.Types.Module ( primUnitId ) import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm@@ -76,16 +77,16 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel import GHC.Core          ( Tickish(..) )-import SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )+import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )  -- The rest:-import ForeignCall      ( CCallConv(..) )+import GHC.Types.ForeignCall ( CCallConv(..) ) import OrdList import Outputable import FastString import GHC.Driver.Session import Util-import UniqSupply       ( getUniqueM )+import GHC.Types.Unique.Supply ( getUniqueM )  import Control.Monad import Data.Bits@@ -98,13 +99,13 @@  is32BitPlatform :: NatM Bool is32BitPlatform = do-    dflags <- getDynFlags-    return $ target32Bit (targetPlatform dflags)+    platform <- getPlatform+    return $ target32Bit platform  sse2Enabled :: NatM Bool sse2Enabled = do-  dflags <- getDynFlags-  case platformArch (targetPlatform dflags) of+  platform <- getPlatform+  case platformArch platform of   -- We Assume  SSE1 and SSE2 operations are available on both   -- x86 and x86_64. Historically we didn't default to SSE2 and   -- SSE1 on x86, which results in defacto nondeterminism for how@@ -132,10 +133,10 @@   let blocks = toBlockListEntryFirst graph   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks   picBaseMb <- getPicBaseMaybeNat-  dflags <- getDynFlags+  platform <- getPlatform   let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)       tops = proc : concat statics-      os   = platformOS $ targetPlatform dflags+      os   = platformOS platform    case picBaseMb of       Just picBase -> initializePicBase_x86 ArchX86 os picBase tops@@ -172,8 +173,8 @@ -}  -- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.-verifyBasicBlock :: [Instr] -> ()-verifyBasicBlock instrs+verifyBasicBlock :: Platform -> [Instr] -> ()+verifyBasicBlock platform instrs   | debugIsOn     = go False instrs   | otherwise     = ()   where@@ -193,7 +194,7 @@                                 else faultyBlockWith i     faultyBlockWith i         = pprPanic "Non control flow instructions after end of basic block."-                   (ppr i <+> text "in:" $$ vcat (map ppr instrs))+                   (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))  basicBlockCodeGen         :: CmmBlock@@ -215,7 +216,8 @@   (mid_instrs,mid_bid) <- stmtsToInstrs id stmts   (!tail_instrs,_) <- stmtToInstrs mid_bid tail   let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs-  return $! verifyBasicBlock (fromOL 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@@ -237,8 +239,8 @@ -- for details. addSpUnwindings :: Instr -> NatM (OrdList Instr) addSpUnwindings instr@(DELTA d) = do-    dflags <- getDynFlags-    if debugLevel dflags >= 1+    config <- getConfig+    if ncgDebugLevel config >= 1         then do lbl <- mkAsmTempLabel <$> getUniqueM                 let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)                 return $ toOL [ instr, UNWIND lbl unwind ]@@ -330,11 +332,11 @@              -- ^ Instructions, and bid of new block if successive              -- statements are placed in a different basic block. stmtToInstrs bid stmt = do-  dflags <- getDynFlags   is32Bit <- is32BitPlatform+  platform <- getPlatform   case stmt of     CmmUnsafeForeignCall target result_regs args-       -> genCCall dflags is32Bit target result_regs args bid+       -> genCCall is32Bit target result_regs args bid      _ -> (,Nothing) <$> case stmt of       CmmComment s   -> return (unitOL (COMMENT s))@@ -342,7 +344,7 @@        CmmUnwind regs -> do         let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable-            to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr)+            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@@ -353,14 +355,14 @@         | isFloatType ty         -> assignReg_FltCode format reg src         | is32Bit && isWord64 ty -> assignReg_I64Code      reg src         | otherwise              -> assignReg_IntCode format reg src-          where ty = cmmRegType dflags reg+          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 dflags src+          where ty = cmmExprType platform src                 format = cmmTypeFormat ty        CmmBranch id          -> return $ genBranch id@@ -368,19 +370,15 @@       --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 -> do dflags <- getDynFlags-                              genSwitch dflags arg ids+      CmmSwitch arg ids -> genSwitch arg ids       CmmCall { cml_target = arg-              , cml_args_regs = gregs } -> do-                                  dflags <- getDynFlags-                                  genJump arg (jumpRegs dflags gregs)+              , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)       _ ->         panic "stmtToInstrs: statement should have been cps'd away"  -jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]-jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]-    where platform = targetPlatform dflags+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.@@ -477,8 +475,8 @@   -- | Convert a BlockId to some CmmStatic data-jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic-jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))+jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic+jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)     where blockLabel = blockLbl blockid @@ -488,10 +486,10 @@  -- Expand CmmRegOff.  ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff?-mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr-mangleIndexTree dflags reg off+mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr+mangleIndexTree platform reg off   = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-  where width = typeWidth (cmmRegType dflags reg)+  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.@@ -638,13 +636,13 @@  -------------------------------------------------------------------------------- getRegister :: CmmExpr -> NatM Register-getRegister e = do dflags <- getDynFlags+getRegister e = do platform <- getPlatform                    is32Bit <- is32BitPlatform-                   getRegister' dflags is32Bit e+                   getRegister' platform is32Bit e -getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register+getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register -getRegister' dflags is32Bit (CmmReg reg)+getRegister' platform is32Bit (CmmReg reg)   = case reg of         CmmGlobal PicBaseReg          | is32Bit ->@@ -656,20 +654,20 @@         _ ->             do                let-                 fmt = cmmTypeFormat (cmmRegType dflags reg)+                 fmt = cmmTypeFormat (cmmRegType platform reg)                  format  = fmt                ---               let platform = targetPlatform dflags+               platform <- ncgPlatform <$> getConfig                return (Fixed format-                             (getRegisterReg platform  reg)+                             (getRegisterReg platform reg)                              nilOL)  -getRegister' dflags is32Bit (CmmRegOff r n)-  = getRegister' dflags is32Bit $ mangleIndexTree dflags r n+getRegister' platform is32Bit (CmmRegOff r n)+  = getRegister' platform is32Bit $ mangleIndexTree platform r n -getRegister' dflags is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])-  = addAlignmentCheck align <$> getRegister' dflags is32Bit e+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)@@ -765,7 +763,7 @@       return $ Any II64 (\dst -> unitOL $         LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) -getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps+getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps     case mop of       MO_F_Neg w  -> sse2NegCode w x @@ -893,7 +891,7 @@          conversionNop :: Format -> CmmExpr -> NatM Register         conversionNop new_format expr-            = do e_code <- getRegister' dflags is32Bit expr+            = do e_code <- getRegister' platform is32Bit expr                  return (swizzleRegisterRep e_code new_format)  @@ -1166,8 +1164,8 @@   -- 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' dflags is32Bit (CmmLit lit)-  | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit)+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))@@ -1182,8 +1180,8 @@         -- note2: all labels are small, because we're assuming the         -- small memory model (see gcc docs, -mcmodel=small). -getRegister' dflags _ (CmmLit lit)-  = do let format = cmmTypeFormat (cmmLitType dflags lit)+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)@@ -1236,15 +1234,15 @@ -- be modified by code to evaluate an arbitrary expression. getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock) getNonClobberedReg expr = do-  dflags <- getDynFlags   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 (targetPlatform dflags)+        | reg `elem` instrClobberedRegs platform         -> do                 tmp <- getNewRegNat rep                 return (tmp, code `snocOL` reg2reg rep reg tmp)@@ -1261,8 +1259,8 @@                 getAmode' is32Bit e  getAmode' :: Bool -> CmmExpr -> NatM Amode-getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags-                                 getAmode $ mangleIndexTree dflags r n+getAmode' _ (CmmRegOff r n) = do platform <- getPlatform+                                 getAmode $ mangleIndexTree platform r n  getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),                                                   CmmLit displacement])@@ -1326,11 +1324,12 @@ -- (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 :: DynFlags -> Bool -> CmmExpr -> NatM Amode-getSimpleAmode dflags is32Bit addr+getSimpleAmode :: Bool -> CmmExpr -> NatM Amode+getSimpleAmode is32Bit addr     | is32Bit = do         addr_code <- getAnyReg addr-        addr_r <- getNewRegNat (intFormat (wordWidth dflags))+        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@@ -1361,7 +1360,7 @@  getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) getNonClobberedOperand (CmmLit lit) = do-  if  isSuitableFloatingPointLit lit+  if isSuitableFloatingPointLit lit     then do       let CmmFloat _ w = lit       Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit@@ -1369,8 +1368,8 @@      else do    is32Bit <- is32BitPlatform-  dflags <- getDynFlags-  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))+  platform <- getPlatform+  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))     then return (OpImm (litToImm lit), nilOL)     else getNonClobberedOperand_generic (CmmLit lit) @@ -1383,8 +1382,7 @@       -- or if 64bit       --  this could use some eyeballs or i'll need to stare at it more later     then do-      dflags <- getDynFlags-      let platform = targetPlatform dflags+      platform <- ncgPlatform <$> getConfig       Amode src mem_code <- getAmode mem       (src',save_code) <-         if (amodeCouldBeClobbered platform src)@@ -1429,8 +1427,8 @@     else do    is32Bit <- is32BitPlatform-  dflags <- getDynFlags-  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))+  platform <- getPlatform+  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))     then return (OpImm (litToImm lit), nilOL)     else getOperand_generic (CmmLit lit) @@ -1477,7 +1475,8 @@   lbl <- getNewLabelNat   let rosection = Section ReadOnlyData lbl   dflags <- getDynFlags-  (addr, addr_code) <- if target32Bit (targetPlatform dflags)+  platform <- getPlatform+  (addr, addr_code) <- if target32Bit platform                        then do dynRef <- cmmMakeDynamicReference                                              dflags                                              DataReference@@ -1622,34 +1621,34 @@ -- anything vs operand condIntCode' is32Bit cond x y  | isOperand is32Bit y = do-    dflags <- getDynFlags+    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 dflags x)) y_op (OpReg x_reg)+                  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-    dflags <- getDynFlags+    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 dflags x)) x_op (OpReg y_reg)+                  CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)     return (CondCode False revcond code)  -- anything vs anything condIntCode' _ cond x y = do-  dflags <- getDynFlags+  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 dflags x)) (OpReg y_reg) x_op+                  CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op   return (CondCode False cond code)  @@ -1666,13 +1665,13 @@   -- an operand, but the right must be a reg.  We can probably do better   -- than this general case...   condFltCode_sse2 = do-    dflags <- getDynFlags+    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 dflags x) y_op (OpReg x_reg)+                  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)@@ -1742,14 +1741,12 @@ -- Assign; dst is a reg, rhs is mem assignReg_IntCode pk reg (CmmLoad src _) = do   load_code <- intLoadCode (MOV pk) src-  dflags <- getDynFlags-  let platform = targetPlatform dflags+  platform <- ncgPlatform <$> getConfig   return (load_code (getRegisterReg platform reg))  -- dst is a reg, but src could be anything assignReg_IntCode _ reg src = do-  dflags <- getDynFlags-  let platform = targetPlatform dflags+  platform <- ncgPlatform <$> getConfig   code <- getAnyReg src   return (code (getRegisterReg platform reg)) @@ -1768,9 +1765,8 @@ -- Floating point assignment to a register/temporary assignReg_FltCode _ reg src = do   src_code <- getAnyReg src-  dflags <- getDynFlags-  let platform = targetPlatform dflags-  return (src_code (getRegisterReg platform  reg))+  platform <- ncgPlatform <$> getConfig+  return (src_code (getRegisterReg platform reg))   genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock@@ -1997,8 +1993,7 @@ -- to take/return a block id.  genCCall-    :: DynFlags-    -> Bool                     -- 32 bit platform?+    :: Bool                     -- 32 bit platform?     -> ForeignTarget            -- function to call     -> [CmmFormal]        -- where to put the result     -> [CmmActual]        -- arguments (of mixed type)@@ -2007,16 +2002,16 @@  -- First we deal with cases which might introduce new blocks in the stream. -genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop))+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 dflags is32Bit addr  -- See genCCall for MO_Cmpxchg+        else getSimpleAmode is32Bit addr  -- See genCCall for MO_Cmpxchg     arg <- getNewRegNat format     arg_code <- getAnyReg n-    let platform = targetPlatform dflags-        dst_r    = getRegisterReg platform  (CmmLocal dst)+    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@@ -2080,9 +2075,10 @@                 lbl2)     format = intFormat width -genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid+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@@ -2094,9 +2090,10 @@       --  bid -> lbl2       --  bid -> lbl1 -> lbl2       --  We also changes edges originating at bid to start at lbl2 instead.+      dflags <- getDynFlags       updateCfgNat (addWeightEdge bid lbl1 110 .                     addWeightEdge lbl1 lbl2 110 .-                    addImmediateSuccessor bid lbl2)+                    addImmediateSuccessor dflags bid lbl2)        -- The following instruction sequence corresponds to the pseudo-code       --@@ -2125,8 +2122,9 @@    | otherwise = do     code_src <- getAnyReg src+    platform <- ncgPlatform <$> getConfig     let dst_r = getRegisterReg platform (CmmLocal dst)-+    dflags <- getDynFlags     if isBmi2Enabled dflags     then do         src_r <- getNewRegNat (intFormat width)@@ -2158,9 +2156,9 @@         return (instrs, Nothing)   where     bw = widthInBits width-    platform = targetPlatform dflags -genCCall dflags bits mop dst args bid = do+genCCall bits mop dst args bid = do+  dflags <- getDynFlags   instr <- genCCall' dflags bits mop dst args bid   return (instr, Nothing) @@ -2187,11 +2185,12 @@         return $ code_dst dst_r `appOL` code_src src_r `appOL`             go dst_r src_r tmp_r (fromInteger n)   where+    platform = targetPlatform dflags     -- The number of instructions we will generate (approx). We need 2     -- instructions per move.     insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) -    maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported+    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported     effectiveAlignment = min (alignmentOf align) maxAlignment     format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment @@ -2243,7 +2242,8 @@           return $ code_dst dst_r `appOL`                    go4 dst_r (fromInteger n)   where-    maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported+    platform = targetPlatform dflags+    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@@ -2326,8 +2326,8 @@                               ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))                   -- prefetch always takes an address -genCCall' dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do-    let platform = targetPlatform dflags+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@@ -2351,7 +2351,7 @@ genCCall' dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]          args@[src] bid = do     sse4_2 <- sse4_2Enabled-    let platform = targetPlatform dflags+    platform <- ncgPlatform <$> getConfig     if sse4_2         then do code_src <- getAnyReg src                 src_r <- getNewRegNat format@@ -2381,7 +2381,7 @@  genCCall' dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]          args@[src, mask] bid = do-    let platform = targetPlatform dflags+    platform <- ncgPlatform <$> getConfig     if isBmi2Enabled dflags         then do code_src  <- getAnyReg src                 code_mask <- getAnyReg mask@@ -2414,7 +2414,7 @@  genCCall' dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]          args@[src, mask] bid = do-    let platform = targetPlatform dflags+    platform <- ncgPlatform <$> getConfig     if isBmi2Enabled dflags         then do code_src  <- getAnyReg src                 code_mask <- getAnyReg mask@@ -2456,6 +2456,7 @@    | otherwise = do     code_src <- getAnyReg src+    platform <- ncgPlatform <$> getConfig     let dst_r = getRegisterReg platform (CmmLocal dst)     if isBmi2Enabled dflags         then do@@ -2486,7 +2487,6 @@                          -- took care of implicitly clearing the upper bits   where     bw = widthInBits width-    platform = targetPlatform dflags     lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))  genCCall' dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do@@ -2499,9 +2499,9 @@   where     lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width)) -genCCall' dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do+genCCall' _ _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do   load_code <- intLoadCode (MOV (intFormat width)) addr-  let platform = targetPlatform dflags+  platform <- ncgPlatform <$> getConfig    return (load_code (getRegisterReg platform  (CmmLocal dst))) @@ -2509,17 +2509,17 @@     code <- assignMem_IntCode (intFormat width) addr val     return $ code `snocOL` MFENCE -genCCall' dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do+genCCall' _ is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do     -- 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.-    Amode amode addr_code <- getSimpleAmode dflags is32Bit addr+    Amode amode addr_code <- getSimpleAmode is32Bit addr     newval <- getNewRegNat format     newval_code <- getAnyReg new     oldval <- getNewRegNat format     oldval_code <- getAnyReg old-    let platform = targetPlatform dflags-        dst_r    = getRegisterReg platform  (CmmLocal dst)+    platform <- getPlatform+    let dst_r    = getRegisterReg platform  (CmmLocal dst)         code     = toOL                    [ MOV format (OpReg oldval) (OpReg eax)                    , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))@@ -2531,8 +2531,7 @@     format = intFormat width  genCCall' _ is32Bit target dest_regs args bid = do-  dflags <- getDynFlags-  let platform = targetPlatform dflags+  platform <- ncgPlatform <$> getConfig   case (target, dest_regs) of     -- void return type prim op     (PrimTarget op, []) ->@@ -2641,8 +2640,8 @@         _ -> panic "genCCall: Wrong number of arguments/results for imul2"      _ -> if is32Bit-         then genCCall32' dflags target dest_regs args-         else genCCall64' dflags target dest_regs args+         then genCCall32' target dest_regs args+         else genCCall64' target dest_regs args    where divOp1 platform signed width results [arg_x, arg_y]             = divOp platform signed width results Nothing arg_x arg_y@@ -2721,22 +2720,82 @@ -- 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' :: DynFlags-            -> ForeignTarget            -- function to call+genCCall32' :: ForeignTarget            -- function to call             -> [CmmFormal]        -- where to put the result             -> [CmmActual]        -- arguments (of mixed type)             -> NatM InstrBlock-genCCall32' dflags target dest_regs args = do-        let-            prom_args = map (maybePromoteCArg dflags W32) args+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.+                ASSERT((typeWidth arg_ty) <= W32) return ()+                (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 dflags) (reverse args)-            raw_arg_size        = sum sizes + wORD_SIZE dflags+            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 - wORD_SIZE dflags+            tot_arg_size        = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform++         delta0 <- getDeltaNat         setDeltaNat (delta0 - arg_pad_size) @@ -2753,7 +2812,7 @@                where fn_imm = ImmCLbl lbl             ForeignTarget expr conv                -> do { (dyn_r, dyn_c) <- getSomeReg expr-                     ; ASSERT( isWord32 (cmmExprType dflags expr) )+                     ; ASSERT( isWord32 (cmmExprType platform expr) )                        return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }             PrimTarget _                 -> panic $ "genCCall: Can't handle PrimTarget call type here, error "@@ -2785,9 +2844,6 @@                    )         setDeltaNat delta0 -        dflags <- getDynFlags-        let platform = targetPlatform dflags-         let             -- assign the results, if necessary             assign_code []     = nilOL@@ -2818,196 +2874,23 @@                     w  = typeWidth ty                     b  = widthInBytes w                     r_dest_hi = getHiVRegFromLo r_dest-                    r_dest    = getRegisterReg platform  (CmmLocal 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) -      where-        -- 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 dflags))--        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.-            ASSERT((typeWidth arg_ty) <= W32) return ()-            (operand, code) <- getOperand arg-            delta <- getDeltaNat-            setDeltaNat (delta-size)-            return (code `snocOL`-                    PUSH II32 operand `snocOL`-                    DELTA (delta-size))--          where-             arg_ty = cmmExprType dflags arg-             size = arg_size_bytes arg_ty -- Byte size--genCCall64' :: DynFlags-            -> ForeignTarget      -- function to call+genCCall64' :: ForeignTarget      -- function to call             -> [CmmFormal]        -- where to put the result             -> [CmmActual]        -- arguments (of mixed type)             -> NatM InstrBlock-genCCall64' dflags target dest_regs args = do+genCCall64' target dest_regs args = do+    platform <- getPlatform     -- load up the register arguments-    let prom_args = map (maybePromoteCArg dflags W32) args--    (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]-    (real_size, adjust_rsp) <--        if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0-            then return (tot_arg_size, nilOL)-            else do -- we need to adjust...-                delta <- getDeltaNat-                setDeltaNat (delta - wORD_SIZE dflags)-                return (tot_arg_size + wORD_SIZE dflags, toOL [-                                SUB II64 (OpImm (ImmInt (wORD_SIZE dflags))) (OpReg rsp),-                                DELTA (delta - wORD_SIZE dflags) ])--    -- 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 (wordWidth dflags)) (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)--  where platform = targetPlatform dflags-        arg_size = 8 -- always, at the mo-+    let prom_args = map (maybePromoteCArg platform W32) args -        load_args :: [CmmExpr]+    let load_args :: [CmmExpr]                   -> [Reg]         -- int regs avail for args                   -> [Reg]         -- FP regs avail for args                   -> InstrBlock    -- code computing args@@ -3065,7 +2948,7 @@                       acode' = acode `snocOL` reg2reg arg_fmt tmp r                     return (code',acode') -              arg_rep = cmmExprType dflags arg+              arg_rep = cmmExprType platform arg               arg_fmt = cmmTypeFormat arg_rep          load_args_win :: [CmmExpr]@@ -3096,8 +2979,10 @@                  load_args_win rest (ireg : usedInt) usedFP regs                                (code `appOL` arg_code ireg)             where-              arg_rep = cmmExprType dflags arg+              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@@ -3105,9 +2990,9 @@              delta <- getDeltaNat              setDeltaNat (delta-arg_size)              let code' = code `appOL` arg_code `appOL` toOL [-                            SUB (intFormat (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp),+                            SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),                             DELTA (delta-arg_size),-                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel dflags 0))]+                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]              push_args rest code'             | otherwise = do@@ -3123,22 +3008,135 @@                                     DELTA (delta-arg_size)]              push_args rest code'             where-              arg_rep = cmmExprType dflags arg+              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 * wORD_SIZE dflags))) (OpReg rsp),+                         SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),                          DELTA (delta - n * arg_size)] -maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr-maybePromoteCArg dflags wto arg+    (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 dflags arg+   wfrom = cmmExprWidth platform arg  outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual]                -> NatM InstrBlock@@ -3250,17 +3248,19 @@ -- ----------------------------------------------------------------------------- -- Generating a table-branch -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch dflags expr targets-  | positionIndependent dflags-  = do-        (reg,e_code) <- getNonClobberedReg (cmmOffset dflags expr offset)+genSwitch expr targets = do+  config <- getConfig+  dflags <- getDynFlags+  let platform = ncgPlatform config+  if ncgPIC config+  then do+        (reg,e_code) <- getNonClobberedReg (cmmOffset platform expr offset)            -- getNonClobberedReg because it needs to survive across t_code         lbl <- getNewLabelNat-        dflags <- getDynFlags-        let is32bit = target32Bit (targetPlatform dflags)-            os = platformOS (targetPlatform dflags)+        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.@@ -3275,12 +3275,12 @@         dynRef <- cmmMakeDynamicReference dflags DataReference lbl         (tableReg,t_code) <- getSomeReg $ dynRef         let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)-                                       (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0))+                                       (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) -        offsetReg <- getNewRegNat (intFormat (wordWidth dflags))+        offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))         return $ if is32bit || os == OSDarwin                  then e_code `appOL` t_code `appOL` toOL [-                                ADD (intFormat (wordWidth dflags)) op (OpReg tableReg),+                                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@@ -3291,16 +3291,15 @@                       -- PprMach.hs/pprDataItem once binutils 2.17 is standard.                       e_code `appOL` t_code `appOL` toOL [                                MOVSxL II32 op (OpReg offsetReg),-                               ADD (intFormat (wordWidth dflags))+                               ADD (intFormat (platformWordWidth platform))                                    (OpReg offsetReg)                                    (OpReg tableReg),                                JMP_TBL (OpReg tableReg) ids rosection lbl                        ]-  | otherwise-  = do-        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)+  else do+        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)         lbl <- getNewLabelNat-        let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl))+        let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))             code = e_code `appOL` toOL [                     JMP_TBL op ids (Section ReadOnlyData lbl) lbl                  ]@@ -3309,27 +3308,27 @@     (offset, blockIds) = switchTargetsToTable targets     ids = map (fmap DestBlockId) blockIds -generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)-generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl)+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 dflags blockIds section lbl)+      in Just (createJumpTable config blockIds section lbl) generateJumpTableForInstr _ _ = Nothing -createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel+createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel                 -> GenCmmDecl (Alignment, RawCmmStatics) h g-createJumpTable dflags ids section lbl+createJumpTable config ids section lbl     = let jumpTable-            | positionIndependent dflags =-                  let ww = wordWidth dflags+            | 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 dflags) ids+            | otherwise = map (jumpTableEntry config) ids       in CmmData section (mkAlignment 1, RawCmmStatics lbl jumpTable)  extractUnwindPoints :: [Instr] -> [UnwindPoint]
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -27,6 +27,7 @@ import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target+import GHC.CmmToAsm.Config  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections@@ -37,12 +38,11 @@ import Outputable import GHC.Platform -import BasicTypes       (Alignment)+import GHC.Types.Basic (Alignment) import GHC.Cmm.CLabel-import GHC.Driver.Session-import UniqSet-import Unique-import UniqSupply+import GHC.Types.Unique.Set+import GHC.Types.Unique+import GHC.Types.Unique.Supply import GHC.Cmm.DebugBlock (UnwindTable)  import Control.Monad@@ -660,50 +660,51 @@ -- ----------------------------------------------------------------------------- -- | Make a spill instruction. x86_mkSpillInstr-    :: DynFlags+    :: NCGConfig     -> Reg      -- register to spill     -> Int      -- current stack delta     -> Int      -- spill slot to use     -> Instr -x86_mkSpillInstr dflags reg delta slot+x86_mkSpillInstr config reg delta slot   = let off     = spillSlotToOffset platform slot - delta     in     case targetClassOfReg platform reg of            RcInteger   -> MOV (archWordFormat is32Bit)-                              (OpReg reg) (OpAddr (spRel dflags off))-           RcDouble    -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off))+                              (OpReg reg) (OpAddr (spRel platform off))+           RcDouble    -> MOV FF64 (OpReg reg) (OpAddr (spRel platform off))            _         -> panic "X86.mkSpillInstr: no match"-    where platform = targetPlatform dflags+    where platform = ncgPlatform config           is32Bit = target32Bit platform  -- | Make a spill reload instruction. x86_mkLoadInstr-    :: DynFlags+    :: NCGConfig     -> Reg      -- register to load     -> Int      -- current stack delta     -> Int      -- spill slot to use     -> Instr -x86_mkLoadInstr dflags reg delta slot+x86_mkLoadInstr config reg delta slot   = let off     = spillSlotToOffset platform slot - delta     in         case targetClassOfReg platform reg of               RcInteger -> MOV (archWordFormat is32Bit)-                               (OpAddr (spRel dflags off)) (OpReg reg)-              RcDouble  -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg)+                               (OpAddr (spRel platform off)) (OpReg reg)+              RcDouble  -> MOV FF64 (OpAddr (spRel platform off)) (OpReg reg)               _           -> panic "X86.x86_mkLoadInstr"-    where platform = targetPlatform dflags+    where platform = ncgPlatform config           is32Bit = target32Bit platform  spillSlotSize :: Platform -> Int-spillSlotSize dflags = if is32Bit then 12 else 8-    where is32Bit = target32Bit dflags+spillSlotSize platform+   | target32Bit platform = 12+   | otherwise            = 8 -maxSpillSlots :: DynFlags -> Int-maxSpillSlots dflags-    = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize (targetPlatform dflags)) - 1---     = 0 -- useful for testing allocMoreStack+maxSpillSlots :: NCGConfig -> Int+maxSpillSlots config+    = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize (ncgPlatform config)) - 1+--  = 0 -- useful for testing allocMoreStack  -- number of bytes that the stack pointer should be aligned to stackAlign :: Int
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -28,6 +28,7 @@ import GHC.CmmToAsm.X86.Instr import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Config import GHC.CmmToAsm.Format import GHC.Platform.Reg import GHC.CmmToAsm.Ppr@@ -35,12 +36,12 @@  import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label-import BasicTypes       (Alignment, mkAlignment, alignmentBytes)+import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Driver.Session import GHC.Cmm              hiding (topInfoTable) import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import Unique           ( pprUniqueAlways )+import GHC.Types.Unique ( pprUniqueAlways ) import GHC.Platform import FastString import Outputable@@ -69,36 +70,36 @@ -- .subsections_via_symbols and -dead_strip can be found at -- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101> -pprProcAlignment :: SDoc-pprProcAlignment = sdocWithDynFlags $ \dflags ->-  (maybe empty (pprAlign . mkAlignment) (cmmProcAlignment dflags))+pprProcAlignment :: NCGConfig -> SDoc+pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)+   where+      platform = ncgPlatform config -pprNatCmmDecl :: NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc-pprNatCmmDecl (CmmData section dats) =-  pprSectionAlign section $$ pprDatas dats+pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc+pprNatCmmDecl config (CmmData section dats) =+  pprSectionAlign config section $$ pprDatas config dats -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =-  sdocWithDynFlags $ \dflags ->-  pprProcAlignment $$+pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  let platform = ncgPlatform config in+  pprProcAlignment config $$   case topInfoTable proc of     Nothing ->         -- special case for code without info table:-        pprSectionAlign (Section Text lbl) $$-        pprProcAlignment $$-        pprLabel lbl $$ -- blocks guaranteed not null, so label needed-        vcat (map (pprBasicBlock top_info) blocks) $$-        (if debugLevel dflags > 0+        pprSectionAlign config (Section Text lbl) $$+        pprProcAlignment config $$+        pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed+        vcat (map (pprBasicBlock config top_info) blocks) $$+        (if ncgDebugLevel config > 0          then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$-        pprSizeDecl lbl+        pprSizeDecl platform lbl      Just (RawCmmStatics info_lbl _) ->-      sdocWithPlatform $ \platform ->-      pprSectionAlign (Section Text info_lbl) $$-      pprProcAlignment $$+      pprSectionAlign config (Section Text info_lbl) $$+      pprProcAlignment config $$       (if platformHasSubsectionsViaSymbols platform           then ppr (mkDeadStripPreventer info_lbl) <> char ':'           else empty) $$-      vcat (map (pprBasicBlock top_info) blocks) $$+      vcat (map (pprBasicBlock config top_info) blocks) $$       -- above: Even the first block gets a label, because with branch-chain       -- elimination, it might be the target of a goto.       (if platformHasSubsectionsViaSymbols platform@@ -108,51 +109,49 @@             <+> char '-'             <+> ppr (mkDeadStripPreventer info_lbl)        else empty) $$-      pprSizeDecl info_lbl+      pprSizeDecl platform info_lbl  -- | Output the ELF .size directive.-pprSizeDecl :: CLabel -> SDoc-pprSizeDecl lbl- = sdocWithPlatform $ \platform ->-   if osElfTarget (platformOS platform)+pprSizeDecl :: Platform -> CLabel -> SDoc+pprSizeDecl platform lbl+ = if osElfTarget (platformOS platform)    then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl    else empty -pprBasicBlock :: LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc-pprBasicBlock info_env (BasicBlock blockid instrs)+pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc+pprBasicBlock config info_env (BasicBlock blockid instrs)   = maybe_infotable $-    pprLabel asmLbl $$-    vcat (map pprInstr instrs) $$-    (sdocOption sdocDebugLevel $ \level ->-        if level > 0-           then ppr (mkAsmTempEndLabel asmLbl) <> char ':'-           else empty+    pprLabel platform asmLbl $$+    vcat (map (pprInstr platform) instrs) $$+    (if ncgDebugLevel config > 0+      then ppr (mkAsmTempEndLabel asmLbl) <> char ':'+      else empty     )   where     asmLbl = blockLbl blockid+    platform = ncgPlatform config     maybe_infotable c = case mapLookup blockid info_env of        Nothing -> c        Just (RawCmmStatics infoLbl info) ->-           pprAlignForSection Text $$+           pprAlignForSection platform Text $$            infoTableLoc $$-           vcat (map pprData info) $$-           pprLabel infoLbl $$+           vcat (map (pprData config) info) $$+           pprLabel platform infoLbl $$            c $$-           (sdocOption sdocDebugLevel $ \level ->-               if level > 0-                  then ppr (mkAsmTempEndLabel infoLbl) <> char ':'-                  else empty+           (if ncgDebugLevel config > 0+               then ppr (mkAsmTempEndLabel infoLbl) <> char ':'+               else empty            )     -- Make sure the info table has the right .loc for the block     -- coming right after it. See [Note: Info Offset]     infoTableLoc = case instrs of-      (l@LOCATION{} : _) -> pprInstr l+      (l@LOCATION{} : _) -> pprInstr platform l       _other             -> empty  -pprDatas :: (Alignment, RawCmmStatics) -> SDoc+pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc -- See note [emit-time elimination of static indirections] in CLabel.-pprDatas (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+pprDatas _config (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])   | lbl == mkIndStaticInfoLabel   , let labelInd (CmmLabelOff l _) = Just l         labelInd (CmmLabel l) = Just l@@ -162,18 +161,21 @@   = pprGloblDecl alias     $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas (align, (RawCmmStatics lbl dats))- = vcat (pprAlign align : pprLabel lbl : map pprData dats)+pprDatas config (align, (RawCmmStatics lbl dats))+ = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats)+   where+      platform = ncgPlatform config -pprData :: CmmStatic -> SDoc-pprData (CmmString str) = pprBytes str+pprData :: NCGConfig -> CmmStatic -> SDoc+pprData _config (CmmString str) = pprBytes str -pprData (CmmUninitialised bytes)- = sdocWithPlatform $ \platform ->-   if platformOS platform == OSDarwin then text ".space " <> int bytes-                                      else text ".skip "  <> int bytes+pprData config (CmmUninitialised bytes)+ = let platform = ncgPlatform config+   in if platformOS platform == OSDarwin+         then text ".space " <> int bytes+         else text ".skip "  <> int bytes -pprData (CmmStaticLit lit) = pprDataItem lit+pprData config (CmmStaticLit lit) = pprDataItem config lit  pprGloblDecl :: CLabel -> SDoc pprGloblDecl lbl@@ -238,24 +240,23 @@       isInfoTableLabel lbl && not (isConInfoTableLabel lbl)  -pprTypeDecl :: CLabel -> SDoc-pprTypeDecl lbl-    = sdocWithPlatform $ \platform ->-      if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl+pprTypeDecl :: Platform -> CLabel -> SDoc+pprTypeDecl platform lbl+    = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl       then         sdocWithDynFlags $ \df ->           text ".type " <> ppr lbl <> ptext (sLit  ", ") <> pprLabelType' df lbl       else empty -pprLabel :: CLabel -> SDoc-pprLabel lbl = pprGloblDecl lbl-            $$ pprTypeDecl lbl-            $$ (ppr lbl <> char ':')+pprLabel :: Platform -> CLabel -> SDoc+pprLabel platform lbl =+   pprGloblDecl lbl+   $$ pprTypeDecl platform lbl+   $$ (ppr lbl <> char ':') -pprAlign :: Alignment -> SDoc-pprAlign alignment-        = sdocWithPlatform $ \platform ->-          text ".align " <> int (alignmentOn platform)+pprAlign :: Platform -> Alignment -> SDoc+pprAlign platform alignment+        = text ".align " <> int (alignmentOn platform)   where         bytes = alignmentBytes alignment         alignmentOn platform = if platformOS platform == OSDarwin@@ -269,18 +270,15 @@         log2 8 = 3         log2 n = 1 + log2 (n `quot` 2) --- -------------------------------------------------------------------------------- pprInstr: print an 'Instr'- instance Outputable Instr where-    ppr instr = pprInstr instr+    ppr instr = sdocWithDynFlags $ \dflags ->+                  pprInstr (targetPlatform dflags) instr  -pprReg :: Format -> Reg -> SDoc-pprReg f r+pprReg :: Platform -> Format -> Reg -> SDoc+pprReg platform f r   = case r of       RegReal    (RealRegSingle i) ->-          sdocWithPlatform $ \platform ->           if target32Bit platform then ppr32_reg_no f i                                   else ppr64_reg_no f i       RegReal    (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"@@ -439,8 +437,8 @@   -pprAddr :: AddrMode -> SDoc-pprAddr (ImmAddr imm off)+pprAddr :: Platform -> AddrMode -> SDoc+pprAddr _platform (ImmAddr imm off)   = let pp_imm = pprImm imm     in     if (off == 0) then@@ -450,12 +448,11 @@     else         pp_imm <> char '+' <> int off -pprAddr (AddrBaseIndex base index displacement)-  = sdocWithPlatform $ \platform ->-    let+pprAddr platform (AddrBaseIndex base index displacement)+  = let         pp_disp  = ppr_disp displacement         pp_off p = pp_disp <> char '(' <> p <> char ')'-        pp_reg r = pprReg (archWordFormat (target32Bit platform)) r+        pp_reg r = pprReg platform (archWordFormat (target32Bit platform)) r     in     case (base, index) of       (EABaseNone,  EAIndexNone) -> pp_disp@@ -471,18 +468,16 @@     ppr_disp imm        = pprImm imm  -- | Print section header and appropriate alignment for that section.-pprSectionAlign :: Section -> SDoc-pprSectionAlign (Section (OtherSection _) _) =+pprSectionAlign :: NCGConfig -> Section -> SDoc+pprSectionAlign _config (Section (OtherSection _) _) =      panic "X86.Ppr.pprSectionAlign: unknown section"-pprSectionAlign sec@(Section seg _) =-  sdocWithPlatform $ \platform ->-    pprSectionHeader platform sec $$-    pprAlignForSection seg+pprSectionAlign config sec@(Section seg _) =+    pprSectionHeader config sec $$+    pprAlignForSection (ncgPlatform config) seg  -- | Print appropriate alignment for the given section type.-pprAlignForSection :: SectionType -> SDoc-pprAlignForSection seg =-  sdocWithPlatform $ \platform ->+pprAlignForSection :: Platform -> SectionType -> SDoc+pprAlignForSection platform seg =     text ".align " <>     case platformOS platform of       -- Darwin: alignments are given as shifts.@@ -511,14 +506,11 @@            CString           -> int 1            _                 -> int 8 -pprDataItem :: CmmLit -> SDoc-pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit--pprDataItem' :: DynFlags -> CmmLit -> SDoc-pprDataItem' dflags lit-  = vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)+pprDataItem :: NCGConfig -> CmmLit -> SDoc+pprDataItem config lit+  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)     where-        platform = targetPlatform dflags+        platform = ncgPlatform config         imm = litToImm lit          -- These seem to be common:@@ -577,38 +569,38 @@ asmComment :: SDoc -> SDoc asmComment c = whenPprDebug $ text "# " <> c -pprInstr :: Instr -> SDoc--pprInstr (COMMENT s)-   = asmComment (ftext s)+pprInstr :: Platform -> Instr -> SDoc+pprInstr platform i = case i of+   COMMENT s+      -> asmComment (ftext s) -pprInstr (LOCATION file line col _name)-   = text "\t.loc " <> ppr file <+> ppr line <+> ppr col+   LOCATION file line col _name+      -> text "\t.loc " <> ppr file <+> ppr line <+> ppr col -pprInstr (DELTA d)-   = asmComment $ text ("\tdelta = " ++ show d)+   DELTA d+      -> asmComment $ text ("\tdelta = " ++ show d) -pprInstr (NEWBLOCK _)-   = panic "PprMach.pprInstr: NEWBLOCK"+   NEWBLOCK _+      -> panic "pprInstr: NEWBLOCK" -pprInstr (UNWIND lbl d)-   = asmComment (text "\tunwind = " <> ppr d)-     $$ ppr lbl <> colon+   UNWIND lbl d+      -> asmComment (text "\tunwind = " <> ppr d)+         $$ ppr lbl <> colon -pprInstr (LDATA _ _)-   = panic "PprMach.pprInstr: LDATA"+   LDATA _ _+      -> panic "pprInstr: LDATA"  {--pprInstr (SPILL reg slot)-   = hcat [-        text "\tSPILL",-        char ' ',-        pprUserReg reg,-        comma,-        text "SLOT" <> parens (int slot)]+   SPILL reg slot+      -> hcat [+           text "\tSPILL",+           char ' ',+           pprUserReg reg,+           comma,+           text "SLOT" <> parens (int slot)] -pprInstr (RELOAD slot reg)-   = hcat [+   RELOAD slot reg+      -> hcat [         text "\tRELOAD",         char ' ',         text "SLOT" <> parens (int slot),@@ -616,120 +608,170 @@         pprUserReg reg] -} --- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper.--- The code generator catches most of these already, but not all.-pprInstr (MOV format (OpImm (ImmInt 0)) dst@(OpReg _))-  = pprInstr (XOR format' dst dst)-  where format' = case format of-          II64 -> II32          -- 32-bit version is equivalent, and smaller-          _    -> format-pprInstr (MOV format src dst)-  = pprFormatOpOp (sLit "mov") format src dst+   -- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper.+   -- The code generator catches most of these already, but not all.+   MOV format (OpImm (ImmInt 0)) dst@(OpReg _)+     -> pprInstr platform (XOR format' dst dst)+        where format' = case format of+                II64 -> II32          -- 32-bit version is equivalent, and smaller+                _    -> format -pprInstr (CMOV cc format src dst)-  = pprCondOpReg (sLit "cmov") format cc src dst+   MOV format src dst+     -> pprFormatOpOp (sLit "mov") format src dst -pprInstr (MOVZxL II32 src dst) = pprFormatOpOp (sLit "mov") II32 src dst+   CMOV cc format src dst+     -> pprCondOpReg (sLit "cmov") format cc src dst++   MOVZxL II32 src dst+      -> pprFormatOpOp (sLit "mov") II32 src dst         -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple         -- movl.  But we represent it as a MOVZxL instruction, because         -- the reg alloc would tend to throw away a plain reg-to-reg         -- move, and we still want it to do that. -pprInstr (MOVZxL formats src dst)-  = pprFormatOpOpCoerce (sLit "movz") formats II32 src dst+   MOVZxL formats src dst+      -> pprFormatOpOpCoerce (sLit "movz") formats II32 src dst         -- zero-extension only needs to extend to 32 bits: on x86_64,         -- the remaining zero-extension to 64 bits is automatic, and the 32-bit         -- instruction is shorter. -pprInstr (MOVSxL formats src dst)-  = sdocWithPlatform $ \platform ->-    pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst+   MOVSxL formats src dst+      -> pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst --- here we do some patching, since the physical registers are only set late--- in the code generation.-pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))-  | reg1 == reg3-  = pprFormatOpOp (sLit "add") format (OpReg reg2) dst+   -- here we do some patching, since the physical registers are only set late+   -- in the code generation.+   LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)+      | reg1 == reg3+      -> pprFormatOpOp (sLit "add") format (OpReg reg2) dst -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))-  | reg2 == reg3-  = pprFormatOpOp (sLit "add") format (OpReg reg1) dst+   LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)+      | reg2 == reg3+      -> pprFormatOpOp (sLit "add") format (OpReg reg1) dst -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))-  | reg1 == reg3-  = pprInstr (ADD format (OpImm displ) dst)+   LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)+      | reg1 == reg3+      -> pprInstr platform (ADD format (OpImm displ) dst) -pprInstr (LEA format src dst) = pprFormatOpOp (sLit "lea") format src dst+   LEA format src dst+      -> pprFormatOpOp (sLit "lea") format src dst -pprInstr (ADD format (OpImm (ImmInt (-1))) dst)-  = pprFormatOp (sLit "dec") format dst-pprInstr (ADD format (OpImm (ImmInt 1)) dst)-  = pprFormatOp (sLit "inc") format dst-pprInstr (ADD format src dst) = pprFormatOpOp (sLit "add") format src dst-pprInstr (ADC format src dst) = pprFormatOpOp (sLit "adc") format src dst-pprInstr (SUB format src dst) = pprFormatOpOp (sLit "sub") format src dst-pprInstr (SBB format src dst) = pprFormatOpOp (sLit "sbb") format src dst-pprInstr (IMUL format op1 op2) = pprFormatOpOp (sLit "imul") format op1 op2+   ADD format (OpImm (ImmInt (-1))) dst+      -> pprFormatOp (sLit "dec") format dst -pprInstr (ADD_CC format src dst)-  = pprFormatOpOp (sLit "add") format src dst-pprInstr (SUB_CC format src dst)-  = pprFormatOpOp (sLit "sub") format src dst+   ADD format (OpImm (ImmInt 1)) dst+      -> pprFormatOp (sLit "inc") format dst -{- A hack.  The Intel documentation says that "The two and three-   operand forms [of IMUL] may also be used with unsigned operands-   because the lower half of the product is the same regardless if-   (sic) the operands are signed or unsigned.  The CF and OF flags,-   however, cannot be used to determine if the upper half of the-   result is non-zero."  So there.--}+   ADD format src dst+      -> pprFormatOpOp (sLit "add") format src dst --- Use a 32-bit instruction when possible as it saves a byte.--- Notably, extracting the tag bits of a pointer has this form.--- TODO: we could save a byte in a subsequent CMP instruction too,--- but need something like a peephole pass for this-pprInstr (AND II64 src@(OpImm (ImmInteger mask)) dst)-  | 0 <= mask && mask < 0xffffffff-    = pprInstr (AND II32 src dst)-pprInstr (AND FF32 src dst) = pprOpOp (sLit "andps") FF32 src dst-pprInstr (AND FF64 src dst) = pprOpOp (sLit "andpd") FF64 src dst-pprInstr (AND format src dst) = pprFormatOpOp (sLit "and") format src dst-pprInstr (OR  format src dst) = pprFormatOpOp (sLit "or")  format src dst+   ADC format src dst+      -> pprFormatOpOp (sLit "adc") format src dst -pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst-pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst-pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor")  format src dst+   SUB format src dst+      -> pprFormatOpOp (sLit "sub") format src dst -pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst)-pprInstr (LZCNT format src dst)  = pprOpOp (sLit "lzcnt")  format src (OpReg dst)-pprInstr (TZCNT format src dst)  = pprOpOp (sLit "tzcnt")  format src (OpReg dst)-pprInstr (BSF format src dst)    = pprOpOp (sLit "bsf")    format src (OpReg dst)-pprInstr (BSR format src dst)    = pprOpOp (sLit "bsr")    format src (OpReg dst)+   SBB format src dst+      -> pprFormatOpOp (sLit "sbb") format src dst -pprInstr (PDEP format src mask dst)   = pprFormatOpOpReg (sLit "pdep") format src mask dst-pprInstr (PEXT format src mask dst)   = pprFormatOpOpReg (sLit "pext") format src mask dst+   IMUL format op1 op2+      -> pprFormatOpOp (sLit "imul") format op1 op2 -pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src-pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src-pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src-pprInstr (PREFETCH Lvl2 format src) = pprFormatOp_ (sLit "prefetcht2") format src+   ADD_CC format src dst+      -> pprFormatOpOp (sLit "add") format src dst -pprInstr (NOT format op) = pprFormatOp (sLit "not") format op-pprInstr (BSWAP format op) = pprFormatOp (sLit "bswap") format (OpReg op)-pprInstr (NEGI format op) = pprFormatOp (sLit "neg") format op+   SUB_CC format src dst+      -> pprFormatOpOp (sLit "sub") format src dst -pprInstr (SHL format src dst) = pprShift (sLit "shl") format src dst-pprInstr (SAR format src dst) = pprShift (sLit "sar") format src dst-pprInstr (SHR format src dst) = pprShift (sLit "shr") format src dst+   -- Use a 32-bit instruction when possible as it saves a byte.+   -- Notably, extracting the tag bits of a pointer has this form.+   -- TODO: we could save a byte in a subsequent CMP instruction too,+   -- but need something like a peephole pass for this+   AND II64 src@(OpImm (ImmInteger mask)) dst+      | 0 <= mask && mask < 0xffffffff+      -> pprInstr platform (AND II32 src dst) -pprInstr (BT  format imm src) = pprFormatImmOp (sLit "bt") format imm src+   AND FF32 src dst+      -> pprOpOp (sLit "andps") FF32 src dst -pprInstr (CMP format src dst)-  | isFloatFormat format =  pprFormatOpOp (sLit "ucomi") format src dst -- SSE2-  | otherwise     =  pprFormatOpOp (sLit "cmp")   format src dst+   AND FF64 src dst+      -> pprOpOp (sLit "andpd") FF64 src dst -pprInstr (TEST format src dst) = sdocWithPlatform $ \platform ->-  let format' = case (src,dst) of+   AND format src dst+      -> pprFormatOpOp (sLit "and") format src dst++   OR  format src dst+      -> pprFormatOpOp (sLit "or")  format src dst++   XOR FF32 src dst+      -> pprOpOp (sLit "xorps") FF32 src dst++   XOR FF64 src dst+      ->  pprOpOp (sLit "xorpd") FF64 src dst++   XOR format src dst+      -> pprFormatOpOp (sLit "xor") format src dst++   POPCNT format src dst+      -> pprOpOp (sLit "popcnt") format src (OpReg dst)++   LZCNT format src dst+      ->  pprOpOp (sLit "lzcnt") format src (OpReg dst)++   TZCNT format src dst+      -> pprOpOp (sLit "tzcnt") format src (OpReg dst)++   BSF format src dst+      -> pprOpOp (sLit "bsf") format src (OpReg dst)++   BSR format src dst+      -> pprOpOp (sLit "bsr") format src (OpReg dst)++   PDEP format src mask dst+      -> pprFormatOpOpReg (sLit "pdep") format src mask dst++   PEXT format src mask dst+      -> pprFormatOpOpReg (sLit "pext") format src mask dst++   PREFETCH NTA format src+      -> pprFormatOp_ (sLit "prefetchnta") format src++   PREFETCH Lvl0 format src+      -> pprFormatOp_ (sLit "prefetcht0") format src++   PREFETCH Lvl1 format src+      -> pprFormatOp_ (sLit "prefetcht1") format src++   PREFETCH Lvl2 format src+      -> pprFormatOp_ (sLit "prefetcht2") format src++   NOT format op+      -> pprFormatOp (sLit "not") format op++   BSWAP format op+      -> pprFormatOp (sLit "bswap") format (OpReg op)++   NEGI format op+      -> pprFormatOp (sLit "neg") format op++   SHL format src dst+      -> pprShift (sLit "shl") format src dst++   SAR format src dst+      -> pprShift (sLit "sar") format src dst++   SHR format src dst+      -> pprShift (sLit "shr") format src dst++   BT format imm src+      -> pprFormatImmOp (sLit "bt") format imm src++   CMP format src dst+     | isFloatFormat format -> pprFormatOpOp (sLit "ucomi") format src dst -- SSE2+     | otherwise            -> pprFormatOpOp (sLit "cmp")   format src dst++   TEST format src dst+      -> pprFormatOpOp (sLit "test") format' src dst+         where         -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'.         -- We can replace them by equivalent, but smaller instructions         -- by reducing the size of the immediate operand as far as possible.@@ -740,275 +782,308 @@         -- to be completely equivalent to the original; in particular so         -- that the signed comparison condition bits are the same as they         -- would be if doing a full word comparison. See #13425.-        (OpImm (ImmInteger mask), OpReg dstReg)-          | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg-        _ -> format-  in pprFormatOpOp (sLit "test") format' src dst-  where-    minSizeOfReg platform (RegReal (RealRegSingle i))-      | target32Bit platform && i <= 3        = II8  -- al, bl, cl, dl-      | target32Bit platform && i <= 7        = II16 -- si, di, bp, sp-      | not (target32Bit platform) && i <= 15 = II8  -- al .. r15b-    minSizeOfReg _ _ = format                 -- other+          format' = case (src,dst) of+           (OpImm (ImmInteger mask), OpReg dstReg)+             | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg+           _ -> format+          minSizeOfReg platform (RegReal (RealRegSingle i))+            | target32Bit platform && i <= 3        = II8  -- al, bl, cl, dl+            | target32Bit platform && i <= 7        = II16 -- si, di, bp, sp+            | not (target32Bit platform) && i <= 15 = II8  -- al .. r15b+          minSizeOfReg _ _ = format                 -- other -pprInstr (PUSH format op) = pprFormatOp (sLit "push") format op-pprInstr (POP format op) = pprFormatOp (sLit "pop") format op+   PUSH format op+      -> pprFormatOp (sLit "push") format op +   POP format op+      -> pprFormatOp (sLit "pop") format op+ -- both unused (SDM):--- pprInstr PUSHA = text "\tpushal"--- pprInstr POPA = text "\tpopal"+-- PUSHA -> text "\tpushal"+-- POPA  -> text "\tpopal" -pprInstr NOP = text "\tnop"-pprInstr (CLTD II8) = text "\tcbtw"-pprInstr (CLTD II16) = text "\tcwtd"-pprInstr (CLTD II32) = text "\tcltd"-pprInstr (CLTD II64) = text "\tcqto"-pprInstr (CLTD x) = panic $ "pprInstr: " ++ show x+   NOP+      -> text "\tnop" -pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)+   CLTD II8+      -> text "\tcbtw" -pprInstr (JXX cond blockid)-  = pprCondInstr (sLit "j") cond (ppr lab)-  where lab = blockLbl blockid+   CLTD II16+      -> text "\tcwtd" -pprInstr        (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)+   CLTD II32+      -> text "\tcltd" -pprInstr        (JMP (OpImm imm) _) = text "\tjmp " <> pprImm imm-pprInstr (JMP op _)          = sdocWithPlatform $ \platform ->-                               text "\tjmp *"-                                   <> pprOperand (archWordFormat (target32Bit platform)) op-pprInstr (JMP_TBL op _ _ _)  = pprInstr (JMP op [])-pprInstr        (CALL (Left imm) _)    = text "\tcall " <> pprImm imm-pprInstr (CALL (Right reg) _)   = sdocWithPlatform $ \platform ->-                                  text "\tcall *"-                                      <> pprReg (archWordFormat (target32Bit platform)) reg+   CLTD II64+      -> text "\tcqto" -pprInstr (IDIV fmt op)   = pprFormatOp (sLit "idiv") fmt op-pprInstr (DIV fmt op)    = pprFormatOp (sLit "div")  fmt op-pprInstr (IMUL2 fmt op)  = pprFormatOp (sLit "imul") fmt op+   CLTD x+      -> panic $ "pprInstr: CLTD " ++ show x --- x86_64 only-pprInstr (MUL format op1 op2) = pprFormatOpOp (sLit "mul") format op1 op2-pprInstr (MUL2 format op) = pprFormatOp (sLit "mul") format op+   SETCC cond op+      -> pprCondInstr (sLit "set") cond (pprOperand platform II8 op) -pprInstr (FDIV format op1 op2) = pprFormatOpOp (sLit "div") format op1 op2-pprInstr (SQRT format op1 op2) = pprFormatOpReg (sLit "sqrt") format op1 op2+   JXX cond blockid+      -> pprCondInstr (sLit "j") cond (ppr lab)+         where lab = blockLbl blockid -pprInstr (CVTSS2SD from to)      = pprRegReg (sLit "cvtss2sd") from to-pprInstr (CVTSD2SS from to)      = pprRegReg (sLit "cvtsd2ss") from to-pprInstr (CVTTSS2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to-pprInstr (CVTTSD2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to-pprInstr (CVTSI2SS fmt from to)   = pprFormatOpReg (sLit "cvtsi2ss") fmt from to-pprInstr (CVTSI2SD fmt from to)   = pprFormatOpReg (sLit "cvtsi2sd") fmt from to+   JXX_GBL cond imm+      -> pprCondInstr (sLit "j") cond (pprImm imm) -    -- FETCHGOT for PIC on ELF platforms-pprInstr (FETCHGOT reg)-   = vcat [ text "\tcall 1f",-            hcat [ text "1:\tpopl\t", pprReg II32 reg ],-            hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ",-                   pprReg II32 reg ]-          ]+   JMP (OpImm imm) _+      -> text "\tjmp " <> pprImm imm -    -- FETCHPC for PIC on Darwin/x86-    -- get the instruction pointer into a register-    -- (Terminology note: the IP is called Program Counter on PPC,-    --  and it's a good thing to use the same name on both platforms)-pprInstr (FETCHPC reg)-   = vcat [ text "\tcall 1f",-            hcat [ text "1:\tpopl\t", pprReg II32 reg ]-          ]+   JMP op _+      -> text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op +   JMP_TBL op _ _ _+      -> pprInstr platform (JMP op []) --- the--- GST fmt src addr ==> FLD dst ; FSTPsz addr-pprInstr g@(X87Store fmt  addr)- = pprX87 g (hcat [gtab,-                 text "fstp", pprFormat_x87 fmt, gsp, pprAddr addr])+   CALL (Left imm) _+      -> text "\tcall " <> pprImm imm +   CALL (Right reg) _+      -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg --- Atomics+   IDIV fmt op+      -> pprFormatOp (sLit "idiv") fmt op -pprInstr (LOCK i) = text "\tlock" $$ pprInstr i+   DIV fmt op+      -> pprFormatOp (sLit "div")  fmt op -pprInstr MFENCE = text "\tmfence"+   IMUL2 fmt op+      -> pprFormatOp (sLit "imul") fmt op -pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst+   -- x86_64 only+   MUL format op1 op2+      -> pprFormatOpOp (sLit "mul") format op1 op2 -pprInstr (CMPXCHG format src dst)-   = pprFormatOpOp (sLit "cmpxchg") format src dst+   MUL2 format op+      -> pprFormatOp (sLit "mul") format op +   FDIV format op1 op2+      -> pprFormatOpOp (sLit "div") format op1 op2 +   SQRT format op1 op2+      -> pprFormatOpReg (sLit "sqrt") format op1 op2 ------------------------------ some left over+   CVTSS2SD from to+      -> pprRegReg (sLit "cvtss2sd") from to +   CVTSD2SS from to+      -> pprRegReg (sLit "cvtsd2ss") from to +   CVTTSS2SIQ fmt from to+      -> pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to -gtab :: SDoc-gtab  = char '\t'+   CVTTSD2SIQ fmt from to+      -> pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to -gsp :: SDoc-gsp   = char ' '+   CVTSI2SS fmt from to+      -> pprFormatOpReg (sLit "cvtsi2ss") fmt from to +   CVTSI2SD fmt from to+      -> pprFormatOpReg (sLit "cvtsi2sd") fmt from to +       -- FETCHGOT for PIC on ELF platforms+   FETCHGOT reg+      -> vcat [ text "\tcall 1f",+                hcat [ text "1:\tpopl\t", pprReg platform II32 reg ],+                hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ",+                       pprReg platform II32 reg ]+              ] -pprX87 :: Instr -> SDoc -> SDoc-pprX87 fake actual-   = (char '#' <> pprX87Instr fake) $$ actual+    -- FETCHPC for PIC on Darwin/x86+    -- get the instruction pointer into a register+    -- (Terminology note: the IP is called Program Counter on PPC,+    --  and it's a good thing to use the same name on both platforms)+   FETCHPC reg+      -> vcat [ text "\tcall 1f",+                hcat [ text "1:\tpopl\t", pprReg platform II32 reg ]+              ] -pprX87Instr :: Instr -> SDoc-pprX87Instr (X87Store fmt  dst) = pprFormatAddr (sLit "gst") fmt  dst-pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match"+   -- the+   -- GST fmt src addr ==> FLD dst ; FSTPsz addr+   g@(X87Store fmt  addr)+      -> pprX87 g (hcat [gtab, text "fstp", pprFormat_x87 fmt, gsp, pprAddr platform addr]) -pprDollImm :: Imm -> SDoc-pprDollImm i = text "$" <> pprImm i+   -- Atomics+   LOCK i+      -> text "\tlock" $$ pprInstr platform i +   MFENCE+      -> text "\tmfence" -pprOperand :: Format -> Operand -> SDoc-pprOperand f (OpReg r)   = pprReg f r-pprOperand _ (OpImm i)   = pprDollImm i-pprOperand _ (OpAddr ea) = pprAddr ea+   XADD format src dst+      -> pprFormatOpOp (sLit "xadd") format src dst +   CMPXCHG format src dst+      -> pprFormatOpOp (sLit "cmpxchg") format src dst -pprMnemonic_  :: PtrString -> SDoc-pprMnemonic_ name =-   char '\t' <> ptext name <> space +  where+   gtab :: SDoc+   gtab  = char '\t' -pprMnemonic  :: PtrString -> Format -> SDoc-pprMnemonic name format =-   char '\t' <> ptext name <> pprFormat format <> space+   gsp :: SDoc+   gsp   = char ' '  -pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc-pprFormatImmOp name format imm op1-  = hcat [-        pprMnemonic name format,-        char '$',-        pprImm imm,-        comma,-        pprOperand format op1-    ] +   pprX87 :: Instr -> SDoc -> SDoc+   pprX87 fake actual+      = (char '#' <> pprX87Instr fake) $$ actual -pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc-pprFormatOp_ name format op1-  = hcat [-        pprMnemonic_ name ,-        pprOperand format op1-    ]+   pprX87Instr :: Instr -> SDoc+   pprX87Instr (X87Store fmt dst) = pprFormatAddr (sLit "gst") fmt dst+   pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" -pprFormatOp :: PtrString -> Format -> Operand -> SDoc-pprFormatOp name format op1-  = hcat [-        pprMnemonic name format,-        pprOperand format op1-    ]+   pprDollImm :: Imm -> SDoc+   pprDollImm i = text "$" <> pprImm i  -pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc-pprFormatOpOp name format op1 op2-  = hcat [-        pprMnemonic name format,-        pprOperand format op1,-        comma,-        pprOperand format op2-    ]+   pprOperand :: Platform -> Format -> Operand -> SDoc+   pprOperand platform f op = case op of+      OpReg r   -> pprReg platform f r+      OpImm i   -> pprDollImm i+      OpAddr ea -> pprAddr platform ea  -pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc-pprOpOp name format op1 op2-  = hcat [-        pprMnemonic_ name,-        pprOperand format op1,-        comma,-        pprOperand format op2-    ]+   pprMnemonic_  :: PtrString -> SDoc+   pprMnemonic_ name =+      char '\t' <> ptext name <> space  +   pprMnemonic  :: PtrString -> Format -> SDoc+   pprMnemonic name format =+      char '\t' <> ptext name <> pprFormat format <> space -pprRegReg :: PtrString -> Reg -> Reg -> SDoc-pprRegReg name reg1 reg2-  = sdocWithPlatform $ \platform ->-    hcat [-        pprMnemonic_ name,-        pprReg (archWordFormat (target32Bit platform)) reg1,-        comma,-        pprReg (archWordFormat (target32Bit platform)) reg2-    ] +   pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc+   pprFormatImmOp name format imm op1+     = hcat [+           pprMnemonic name format,+           char '$',+           pprImm imm,+           comma,+           pprOperand platform format op1+       ] -pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc-pprFormatOpReg name format op1 reg2-  = sdocWithPlatform $ \platform ->-    hcat [-        pprMnemonic name format,-        pprOperand format op1,-        comma,-        pprReg (archWordFormat (target32Bit platform)) reg2-    ] -pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc-pprCondOpReg name format cond op1 reg2-  = hcat [-        char '\t',-        ptext name,-        pprCond cond,-        space,-        pprOperand format op1,-        comma,-        pprReg format reg2-    ]+   pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc+   pprFormatOp_ name format op1+     = hcat [+           pprMnemonic_ name ,+           pprOperand platform format op1+       ] -pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc-pprFormatFormatOpReg name format1 format2 op1 reg2-  = hcat [-        pprMnemonic name format2,-        pprOperand format1 op1,-        comma,-        pprReg format2 reg2-    ]+   pprFormatOp :: PtrString -> Format -> Operand -> SDoc+   pprFormatOp name format op1+     = hcat [+           pprMnemonic name format,+           pprOperand platform format op1+       ] -pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc-pprFormatOpOpReg name format op1 op2 reg3-  = hcat [-        pprMnemonic name format,-        pprOperand format op1,-        comma,-        pprOperand format op2,-        comma,-        pprReg format reg3-    ] +   pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc+   pprFormatOpOp name format op1 op2+     = hcat [+           pprMnemonic name format,+           pprOperand platform format op1,+           comma,+           pprOperand platform format op2+       ]  -pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc-pprFormatAddr name format  op-  = hcat [-        pprMnemonic name format,-        comma,-        pprAddr op-    ]+   pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc+   pprOpOp name format op1 op2+     = hcat [+           pprMnemonic_ name,+           pprOperand platform format op1,+           comma,+           pprOperand platform format op2+       ] -pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc-pprShift name format src dest-  = hcat [-        pprMnemonic name format,-        pprOperand II8 src,  -- src is 8-bit sized-        comma,-        pprOperand format dest-    ]+   pprRegReg :: PtrString -> Reg -> Reg -> SDoc+   pprRegReg name reg1 reg2+     = hcat [+           pprMnemonic_ name,+           pprReg platform (archWordFormat (target32Bit platform)) reg1,+           comma,+           pprReg platform (archWordFormat (target32Bit platform)) reg2+       ]  -pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc-pprFormatOpOpCoerce name format1 format2 op1 op2-  = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space,-        pprOperand format1 op1,-        comma,-        pprOperand format2 op2-    ]+   pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc+   pprFormatOpReg name format op1 reg2+     = hcat [+           pprMnemonic name format,+           pprOperand platform format op1,+           comma,+           pprReg platform (archWordFormat (target32Bit platform)) reg2+       ] +   pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc+   pprCondOpReg name format cond op1 reg2+     = hcat [+           char '\t',+           ptext name,+           pprCond cond,+           space,+           pprOperand platform format op1,+           comma,+           pprReg platform format reg2+       ] -pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc-pprCondInstr name cond arg-  = hcat [ char '\t', ptext name, pprCond cond, space, arg]+   pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc+   pprFormatFormatOpReg name format1 format2 op1 reg2+     = hcat [+           pprMnemonic name format2,+           pprOperand platform format1 op1,+           comma,+           pprReg platform format2 reg2+       ]++   pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc+   pprFormatOpOpReg name format op1 op2 reg3+     = hcat [+           pprMnemonic name format,+           pprOperand platform format op1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3+       ]++++   pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc+   pprFormatAddr name format  op+     = hcat [+           pprMnemonic name format,+           comma,+           pprAddr platform op+       ]++   pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc+   pprShift name format src dest+     = hcat [+           pprMnemonic name format,+           pprOperand platform II8 src,  -- src is 8-bit sized+           comma,+           pprOperand platform format dest+       ]+++   pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc+   pprFormatOpOpCoerce name format1 format2 op1 op2+     = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space,+           pprOperand platform format1 op1,+           comma,+           pprOperand platform format2 op2+       ]+++   pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc+   pprCondInstr name cond arg+     = hcat [ char '\t', ptext name, pprCond cond, space, arg]
compiler/GHC/CmmToAsm/X86/RegInfo.hs view
@@ -15,9 +15,9 @@  import Outputable import GHC.Platform-import Unique+import GHC.Types.Unique -import UniqFM+import GHC.Types.Unique.FM import GHC.CmmToAsm.X86.Regs
compiler/GHC/CmmToAsm/X86/Regs.hs view
@@ -57,7 +57,6 @@  import GHC.Cmm import GHC.Cmm.CLabel           ( CLabel )-import GHC.Driver.Session import Outputable import GHC.Platform @@ -188,11 +187,11 @@ -- applicable, is the same but for the frame pointer.  -spRel :: DynFlags+spRel :: Platform       -> Int -- ^ desired stack offset in bytes, positive or negative       -> AddrMode-spRel dflags n- | target32Bit (targetPlatform dflags)+spRel platform n+ | target32Bit platform     = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n)  | otherwise     = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n)
compiler/GHC/CmmToC.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}+{-# LANGUAGE LambdaCase #-}  ----------------------------------------------------------------------------- --@@ -29,7 +30,7 @@  import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import ForeignCall+import GHC.Types.ForeignCall import GHC.Cmm hiding (pprBBlock) import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Cmm.Dataflow.Block@@ -44,9 +45,9 @@ import FastString import Outputable import GHC.Platform-import UniqSet-import UniqFM-import Unique+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+import GHC.Types.Unique import Util  -- The rest@@ -68,7 +69,7 @@ -- Top level  writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()-writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine)+writeC dflags handle cmm = printForC dflags handle (pprC dflags cmm $$ blankLine)  -- -------------------------------------------------------------------------- -- Now do some real work@@ -76,57 +77,59 @@ -- for fun, we could call cmmToCmm over the tops... -- -pprC :: RawCmmGroup -> SDoc-pprC tops = vcat $ intersperse blankLine $ map pprTop tops+pprC :: DynFlags -> RawCmmGroup -> SDoc+pprC dflags tops = vcat $ intersperse blankLine $ map (pprTop dflags) tops  -- -- top level procs ---pprTop :: RawCmmDecl -> SDoc-pprTop (CmmProc infos clbl _in_live_regs graph) =-+pprTop :: DynFlags -> RawCmmDecl -> SDoc+pprTop dflags = \case+  (CmmProc infos clbl _in_live_regs graph) ->     (case mapLookup (g_entry graph) infos of        Nothing -> empty        Just (RawCmmStatics info_clbl info_dat) ->-           pprDataExterns info_dat $$-           pprWordArray info_is_in_rodata info_clbl info_dat) $$+           pprDataExterns platform info_dat $$+           pprWordArray dflags info_is_in_rodata info_clbl info_dat) $$     (vcat [            blankLine,            extern_decls,            (if (externallyVisibleCLabel clbl)                     then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,            nest 8 temp_decls,-           vcat (map pprBBlock blocks),+           vcat (map (pprBBlock dflags) blocks),            rbrace ]     )-  where+    where         -- info tables are always in .rodata         info_is_in_rodata = True         blocks = toBlockListEntryFirst graph-        (temp_decls, extern_decls) = pprTempAndExternDecls blocks+        (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks  --- Chunks of static data.+  -- Chunks of static data. --- We only handle (a) arrays of word-sized things and (b) strings.+  -- We only handle (a) arrays of word-sized things and (b) strings. -pprTop (CmmData section (RawCmmStatics lbl [CmmString str])) =-  pprExternDecl lbl $$-  hcat [-    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,-    text "[] = ", pprStringInCStyle str, semi-  ]+  (CmmData section (RawCmmStatics lbl [CmmString str])) ->+    pprExternDecl platform lbl $$+    hcat [+      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,+      text "[] = ", pprStringInCStyle str, semi+    ] -pprTop (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) =-  pprExternDecl lbl $$-  hcat [-    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,-    brackets (int size), semi-  ]+  (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) ->+    pprExternDecl platform lbl $$+    hcat [+      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,+      brackets (int size), semi+    ] -pprTop (CmmData section (RawCmmStatics lbl lits)) =-  pprDataExterns lits $$-  pprWordArray (isSecConstant section) lbl lits+  (CmmData section (RawCmmStatics lbl lits)) ->+    pprDataExterns platform lits $$+    pprWordArray dflags (isSecConstant section) lbl lits+  where+    platform = targetPlatform dflags  -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump.@@ -135,10 +138,10 @@ -- as many jumps as possible into fall throughs. -- -pprBBlock :: CmmBlock -> SDoc-pprBBlock block =+pprBBlock :: DynFlags -> CmmBlock -> SDoc+pprBBlock dflags block =   nest 4 (pprBlockId (entryLabel block) <> colon) $$-  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)+  nest 8 (vcat (map (pprStmt dflags) (blockToList nodes)) $$ pprStmt dflags last)  where   (_, nodes, last)  = blockSplit block @@ -146,18 +149,19 @@ -- Info tables. Just arrays of words. -- See codeGen/ClosureInfo, and nativeGen/PprMach -pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc-pprWordArray is_ro lbl ds-  = sdocWithDynFlags $ \dflags ->-    -- TODO: align closures only-    pprExternDecl lbl $$+pprWordArray :: DynFlags -> Bool -> CLabel -> [CmmStatic] -> SDoc+pprWordArray dflags is_ro lbl ds+  = -- TODO: align closures only+    pprExternDecl platform lbl $$     hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"          , space, ppr lbl, text "[]"          -- See Note [StgWord alignment]-         , pprAlignment (wordWidth dflags)+         , pprAlignment (wordWidth platform)          , text "= {" ]     $$ nest 8 (commafy (pprStatics dflags ds))     $$ text "};"+  where+    platform = targetPlatform dflags  pprAlignment :: Width -> SDoc pprAlignment words =@@ -195,10 +199,9 @@ -- Statements. -- -pprStmt :: CmmNode e x -> SDoc+pprStmt :: DynFlags -> CmmNode e x -> SDoc -pprStmt stmt =-    sdocWithDynFlags $ \dflags ->+pprStmt dflags stmt =     case stmt of     CmmEntry{}   -> empty     CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")@@ -213,15 +216,16 @@     CmmAssign dest src -> pprAssign dflags dest src      CmmStore  dest src-        | typeWidth rep == W64 && wordWidth dflags /= W64+        | typeWidth rep == W64 && wordWidth platform /= W64         -> (if isFloatType rep then text "ASSIGN_DBL"                                else ptext (sLit ("ASSIGN_Word64"))) <>-           parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi+           parens (mkP_ <> pprExpr1 dflags dest <> comma <> pprExpr dflags src) <> semi          | otherwise-        -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]+        -> hsep [ pprExpr dflags (CmmLoad dest rep), equals, pprExpr dflags src <> semi ]         where-          rep = cmmExprType dflags src+          rep = cmmExprType platform src+          platform = targetPlatform dflags      CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->         fnCall@@ -229,28 +233,29 @@         (res_hints, arg_hints) = foreignTargetHints target         hresults = zip results res_hints         hargs    = zip args arg_hints+        platform = targetPlatform dflags          ForeignConvention cconv _ _ ret = conv -        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)+        cast_fn = parens (cCast dflags (pprCFunType platform (char '*') cconv hresults hargs) fn)          -- See wiki:commentary/compiler/backends/ppr-c#prototypes         fnCall =             case fn of               CmmLit (CmmLabel lbl)                 | StdCallConv <- cconv ->-                    pprCall (ppr lbl) cconv hresults hargs+                    pprCall dflags (ppr lbl) cconv hresults hargs                         -- stdcall functions must be declared with                         -- a function type, otherwise the C compiler                         -- doesn't add the @n suffix to the label.  We                         -- can't add the @n suffix ourselves, because                         -- it isn't valid C.                 | CmmNeverReturns <- ret ->-                    pprCall cast_fn cconv hresults hargs <> semi+                    pprCall dflags cast_fn cconv hresults hargs <> semi                 | not (isMathFun lbl) ->-                    pprForeignCall (ppr lbl) cconv hresults hargs+                    pprForeignCall dflags (ppr lbl) cconv hresults hargs               _ ->-                    pprCall cast_fn cconv hresults hargs <> semi+                    pprCall dflags cast_fn cconv hresults hargs <> semi                         -- for a dynamic call, no declaration is necessary.      CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty@@ -273,39 +278,38 @@           -- builtins (see bug #5967).           | Just _align <- machOpMemcpyishAlign op           = (text ";EFF_(" <> fn <> char ')' <> semi) $$-            pprForeignCall fn cconv hresults hargs+            pprForeignCall dflags fn cconv hresults hargs           | otherwise-          = pprCall fn cconv hresults hargs+          = pprCall dflags fn cconv hresults hargs -    CmmBranch ident          -> pprBranch ident-    CmmCondBranch expr yes no _ -> pprCondBranch expr yes no-    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi-    CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->-                                pprSwitch dflags arg ids+    CmmBranch ident               -> pprBranch ident+    CmmCondBranch expr yes no _   -> pprCondBranch dflags expr yes no+    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr dflags expr) <> semi+    CmmSwitch arg ids             -> pprSwitch dflags arg ids      _other -> pprPanic "PprC.pprStmt" (ppr stmt)  type Hinted a = (a, ForeignHint) -pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]+pprForeignCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]                -> SDoc-pprForeignCall fn cconv results args = fn_call+pprForeignCall dflags fn cconv results args = fn_call   where+    platform = targetPlatform dflags     fn_call = braces (-                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi+                 pprCFunType platform (char '*' <> text "ghcFunPtr") cconv results args <> semi               $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi-              $$ pprCall (text "ghcFunPtr") cconv results args <> semi+              $$ pprCall dflags (text "ghcFunPtr") cconv results args <> semi              )-    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)+    cast_fn = parens (parens (pprCFunType platform (char '*') cconv results args) <> fn) -pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc-pprCFunType ppr_fn cconv ress args-  = sdocWithDynFlags $ \dflags ->-    let res_type [] = text "void"-        res_type [(one, hint)] = machRepHintCType (localRegType one) hint+pprCFunType :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc+pprCFunType platform ppr_fn cconv ress args+  = let res_type [] = text "void"+        res_type [(one, hint)] = machRepHintCType platform (localRegType one) hint         res_type _ = panic "pprCFunType: only void or 1 return value supported" -        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint+        arg_type (expr, hint) = machRepHintCType platform (cmmExprType platform expr) hint     in res_type ress <+>        parens (ccallConvAttribute cconv <> ppr_fn) <>        parens (commafy (map arg_type args))@@ -318,9 +322,9 @@  -- --------------------------------------------------------------------- -- conditional branches to local labels-pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc-pprCondBranch expr yes no-        = hsep [ text "if" , parens(pprExpr expr) ,+pprCondBranch :: DynFlags -> CmmExpr -> BlockId -> BlockId -> SDoc+pprCondBranch dflags expr yes no+        = hsep [ text "if" , parens(pprExpr dflags expr) ,                         text "goto", pprBlockId yes <> semi,                         text "else goto", pprBlockId no <> semi ] @@ -331,20 +335,21 @@ -- pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc pprSwitch dflags e ids-  = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace)+  = (hang (text "switch" <+> parens ( pprExpr dflags e ) <+> lbrace)                 4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace   where     (pairs, mbdef) = switchTargetsFallThrough ids+    platform = targetPlatform dflags      -- fall through case     caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix         where         do_fallthrough ix =-                 hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,+                 hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon ,                         text "/* fall through */" ]          final_branch ix =-                hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,+                hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon ,                        text "goto" , (pprBlockId ident) <> semi ]      caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"@@ -366,72 +371,73 @@ -- -- (similar invariants apply to the rest of the pretty printer). -pprExpr :: CmmExpr -> SDoc-pprExpr e = case e of-    CmmLit lit -> pprLit lit---    CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty+pprExpr :: DynFlags -> CmmExpr -> SDoc+pprExpr dflags e = case e of+    CmmLit lit      -> pprLit dflags lit+    CmmLoad e ty    -> pprLoad dflags e ty     CmmReg reg      -> pprCastReg reg     CmmRegOff reg 0 -> pprCastReg reg      -- CmmRegOff is an alias of MO_Add-    CmmRegOff reg i -> sdocWithDynFlags $ \dflags ->-                       pprCastReg reg <> char '+' <>-                       pprHexVal (fromIntegral i) (wordWidth dflags)+    CmmRegOff reg i -> pprCastReg reg <> char '+' <>+                       pprHexVal dflags (fromIntegral i) (wordWidth platform) -    CmmMachOp mop args -> pprMachOpApp mop args+    CmmMachOp mop args -> pprMachOpApp dflags mop args      CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"+  where+    platform = targetPlatform dflags   pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc pprLoad dflags e ty-  | width == W64, wordWidth dflags /= W64+  | width == W64, wordWidth platform /= W64   = (if isFloatType ty then text "PK_DBL"                        else text "PK_Word64")-    <> parens (mkP_ <> pprExpr1 e)+    <> parens (mkP_ <> pprExpr1 dflags e)    | otherwise   = case e of-        CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)+        CmmReg r | isPtrReg r && width == wordWidth platform && not (isFloatType ty)                  -> char '*' <> pprAsPtrReg r -        CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)+        CmmRegOff r 0 | isPtrReg r && width == wordWidth platform && not (isFloatType ty)                       -> char '*' <> pprAsPtrReg r -        CmmRegOff r off | isPtrReg r && width == wordWidth dflags-                        , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty)+        CmmRegOff r off | isPtrReg r && width == wordWidth platform+                        , off `rem` platformWordSizeInBytes platform == 0 && not (isFloatType ty)         -- ToDo: check that the offset is a word multiple?         --       (For tagging to work, I had to avoid unaligned loads. --ARY)-                        -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags))+                        -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift platform)) -        _other -> cLoad e ty+        _other -> cLoad dflags e ty   where     width = typeWidth ty+    platform = targetPlatform dflags -pprExpr1 :: CmmExpr -> SDoc-pprExpr1 (CmmLit lit)     = pprLit1 lit-pprExpr1 e@(CmmReg _reg)  = pprExpr e-pprExpr1 other            = parens (pprExpr other)+pprExpr1 :: DynFlags -> CmmExpr -> SDoc+pprExpr1 dflags e = case e of+   CmmLit lit  -> pprLit1 dflags lit+   CmmReg _reg -> pprExpr dflags e+   _           -> parens (pprExpr dflags e)  -- -------------------------------------------------------------------------- -- MachOp applications -pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc+pprMachOpApp :: DynFlags -> MachOp -> [CmmExpr] -> SDoc -pprMachOpApp op args+pprMachOpApp dflags op args   | isMulMayOfloOp op-  = text "mulIntMayOflo" <> parens (commafy (map pprExpr args))+  = text "mulIntMayOflo" <> parens (commafy (map (pprExpr dflags) args))   where isMulMayOfloOp (MO_U_MulMayOflo _) = True         isMulMayOfloOp (MO_S_MulMayOflo _) = True         isMulMayOfloOp _ = False -pprMachOpApp mop args+pprMachOpApp dflags mop args   | Just ty <- machOpNeedsCast mop-  = ty <> parens (pprMachOpApp' mop args)+  = ty <> parens (pprMachOpApp' dflags mop args)   | otherwise-  = pprMachOpApp' mop args+  = pprMachOpApp' dflags mop args  -- Comparisons in C have type 'int', but we want type W_ (this is what -- resultRepOfMachOp says).  The other C operations inherit their type@@ -441,24 +447,23 @@   | isComparisonMachOp mop = Just mkW_   | otherwise              = Nothing -pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc-pprMachOpApp' mop args+pprMachOpApp' :: DynFlags -> MachOp -> [CmmExpr] -> SDoc+pprMachOpApp' dflags mop args  = case args of     -- dyadic-    [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y+    [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y      -- unary-    [x]   -> pprMachOp_for_C mop <> parens (pprArg x)+    [x]   -> pprMachOp_for_C platform mop <> parens (pprArg x)      _     -> panic "PprC.pprMachOp : machop with wrong number of args"    where+    platform = targetPlatform dflags         -- Cast needed for signed integer ops-    pprArg e | signedOp    mop = sdocWithDynFlags $ \dflags ->-                                 cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e-             | needsFCasts mop = sdocWithDynFlags $ \dflags ->-                                 cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e-             | otherwise    = pprExpr1 e+    pprArg e | signedOp    mop = cCast dflags (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e+             | needsFCasts mop = cCast dflags (machRep_F_CType (typeWidth (cmmExprType platform e))) e+             | otherwise       = pprExpr1 dflags e     needsFCasts (MO_F_Eq _)   = False     needsFCasts (MO_F_Ne _)   = False     needsFCasts (MO_F_Neg _)  = True@@ -468,9 +473,9 @@ -- -------------------------------------------------------------------------- -- Literals -pprLit :: CmmLit -> SDoc-pprLit lit = case lit of-    CmmInt i rep      -> pprHexVal i rep+pprLit :: DynFlags -> CmmLit -> SDoc+pprLit dflags lit = case lit of+    CmmInt i rep      -> pprHexVal dflags i rep      CmmFloat f w       -> parens (machRep_F_CType w) <> str         where d = fromRational f :: Double@@ -496,71 +501,75 @@     where         pprCLabelAddr lbl = char '&' <> ppr lbl -pprLit1 :: CmmLit -> SDoc-pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)-pprLit1 lit@(CmmLabelDiffOff _ _ _ _) = parens (pprLit lit)-pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)-pprLit1 other = pprLit other+pprLit1 :: DynFlags -> CmmLit -> SDoc+pprLit1 dflags lit = case lit of+   (CmmLabelOff _ _)         -> parens (pprLit dflags lit)+   (CmmLabelDiffOff _ _ _ _) -> parens (pprLit dflags lit)+   (CmmFloat _ _)            -> parens (pprLit dflags lit)+   _                         -> pprLit dflags lit  -- --------------------------------------------------------------------------- -- Static data  pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]-pprStatics _ [] = []-pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)-  -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding-  | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest-  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'-  -- adjacent floats aren't padded but combined into a single word-  | wORD_SIZE dflags == 8, CmmStaticLit (CmmFloat g W32) : rest' <- rest-  = pprLit1 (floatPairToWord dflags f g) : pprStatics dflags rest'-  | wORD_SIZE dflags == 4-  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest-  | otherwise-  = pprPanic "pprStatics: float" (vcat (map ppr' rest))-    where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->-                                  ppr (cmmLitType dflags l)-          ppr' _other           = text "bad static!"-pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)-  = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest+pprStatics dflags = pprStatics'+  where+    platform    = targetPlatform dflags+    pprStatics' = \case+      [] -> []+      (CmmStaticLit (CmmFloat f W32) : rest)+        -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding+        | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest+        -> pprLit1 dflags (floatToWord dflags f) : pprStatics' rest'+        -- adjacent floats aren't padded but combined into a single word+        | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest+        -> pprLit1 dflags (floatPairToWord dflags f g) : pprStatics' rest'+        | wordWidth platform == W32+        -> pprLit1 dflags (floatToWord dflags f) : pprStatics' rest+        | otherwise+        -> pprPanic "pprStatics: float" (vcat (map ppr' rest))+          where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l)+                ppr' _other           = text "bad static!" -pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)-  | wordWidth dflags == W32-  = if wORDS_BIGENDIAN dflags-    then pprStatics dflags (CmmStaticLit (CmmInt q W32) :-                            CmmStaticLit (CmmInt r W32) : rest)-    else pprStatics dflags (CmmStaticLit (CmmInt r W32) :-                            CmmStaticLit (CmmInt q W32) : rest)-  where r = i .&. 0xffffffff-        q = i `shiftR` 32-pprStatics dflags (CmmStaticLit (CmmInt a W32) :-                   CmmStaticLit (CmmInt b W32) : rest)-  | wordWidth dflags == W64-  = if wORDS_BIGENDIAN dflags-    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) :-                            rest)-    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) :-                            rest)-pprStatics dflags (CmmStaticLit (CmmInt a W16) :-                   CmmStaticLit (CmmInt b W16) : rest)-  | wordWidth dflags == W32-  = if wORDS_BIGENDIAN dflags-    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) :-                            rest)-    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) :-                            rest)-pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)-  | w /= wordWidth dflags-  = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)-pprStatics dflags (CmmStaticLit lit : rest)-  = pprLit1 lit : pprStatics dflags rest-pprStatics _ (other : _)-  = pprPanic "pprStatics: other" (pprStatic other)+      (CmmStaticLit (CmmFloat f W64) : rest)+        -> map (pprLit1 dflags) (doubleToWords dflags f) ++ pprStatics' rest -pprStatic :: CmmStatic -> SDoc-pprStatic s = case s of+      (CmmStaticLit (CmmInt i W64) : rest)+        | wordWidth platform == W32+        -> if wORDS_BIGENDIAN dflags+           then pprStatics' (CmmStaticLit (CmmInt q W32) :+                             CmmStaticLit (CmmInt r W32) : rest)+           else pprStatics' (CmmStaticLit (CmmInt r W32) :+                             CmmStaticLit (CmmInt q W32) : rest)+           where r = i .&. 0xffffffff+                 q = i `shiftR` 32 -    CmmStaticLit lit   -> nest 4 (pprLit lit)+      (CmmStaticLit (CmmInt a W32) : CmmStaticLit (CmmInt b W32) : rest)+        | wordWidth platform == W64+        -> if wORDS_BIGENDIAN dflags+           then pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest)+           else pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest)++      (CmmStaticLit (CmmInt a W16) : CmmStaticLit (CmmInt b W16) : rest)+        | wordWidth platform == W32+        -> if wORDS_BIGENDIAN dflags+           then pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest)+           else pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest)++      (CmmStaticLit (CmmInt _ w) : _)+        | w /= wordWidth platform+        -> pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)++      (CmmStaticLit lit : rest)+        -> pprLit1 dflags lit : pprStatics' rest++      (other : _)+        -> pprPanic "pprStatics: other" (pprStatic dflags other)++pprStatic :: DynFlags -> CmmStatic -> SDoc+pprStatic dflags s = case s of++    CmmStaticLit lit   -> nest 4 (pprLit dflags lit)     CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))      -- these should be inlined, like the old .hc@@ -577,9 +586,9 @@ -- Print a MachOp in a way suitable for emitting via C. -- -pprMachOp_for_C :: MachOp -> SDoc+pprMachOp_for_C :: Platform -> MachOp -> SDoc -pprMachOp_for_C mop = case mop of+pprMachOp_for_C platform mop = case mop of          -- Integer operations         MO_Add          _ -> char '+'@@ -640,19 +649,19 @@  -- noop casts         MO_UU_Conv from to | from == to -> empty-        MO_UU_Conv _from to -> parens (machRep_U_CType to)+        MO_UU_Conv _from to -> parens (machRep_U_CType platform to)          MO_SS_Conv from to | from == to -> empty-        MO_SS_Conv _from to -> parens (machRep_S_CType to)+        MO_SS_Conv _from to -> parens (machRep_S_CType platform to)          MO_XX_Conv from to | from == to -> empty-        MO_XX_Conv _from to -> parens (machRep_U_CType to)+        MO_XX_Conv _from to -> parens (machRep_U_CType platform to)          MO_FF_Conv from to | from == to -> empty         MO_FF_Conv _from to -> parens (machRep_F_CType to)          MO_SF_Conv _from to -> parens (machRep_F_CType to)-        MO_FS_Conv _from to -> parens (machRep_S_CType to)+        MO_FS_Conv _from to -> parens (machRep_S_CType platform to)          MO_S_MulMayOflo _ -> pprTrace "offending mop:"                                 (text "MO_S_MulMayOflo")@@ -875,10 +884,11 @@  -- dest is a reg, rhs is a CmmRegOff pprAssign dflags r1 (CmmRegOff r2 off)-   | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)+   | isPtrReg r1 && isPtrReg r2 && (off `rem` platformWordSizeInBytes platform == 0)    = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]   where-        off1 = off `shiftR` wordShift dflags+        platform = targetPlatform dflags+        off1 = off `shiftR` wordShift platform          (op,off') | off >= 0  = (char '+', off1)                   | otherwise = (char '-', -off1)@@ -886,10 +896,10 @@ -- dest is a reg, rhs is anything. -- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting -- the lvalue elicits a warning from new GCC versions (3.4+).-pprAssign _ r1 r2-  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)-  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)-  | otherwise                    = mkAssign (pprExpr r2)+pprAssign dflags r1 r2+  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 dflags r2)+  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 dflags r2)+  | otherwise                    = mkAssign (pprExpr dflags r2)     where mkAssign x = if r1 == CmmGlobal BaseReg                        then text "ASSIGN_BaseReg" <> parens x <> semi                        else pprReg r1 <> text " = " <> x <> semi@@ -988,8 +998,8 @@ -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc-pprCall ppr_fn cconv results args+pprCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc+pprCall dflags ppr_fn cconv results args   | not (is_cishCC cconv)   = panic $ "pprCall: unknown calling convention" @@ -997,6 +1007,8 @@   =     ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi   where+     platform = targetPlatform dflags+      ppr_assign []           rhs = rhs      ppr_assign [(one,hint)] rhs          = pprLocalReg one <> text " = "@@ -1004,16 +1016,15 @@      ppr_assign _other _rhs = panic "pprCall: multiple results"       pprArg (expr, AddrHint)-        = cCast (text "void *") expr+        = cCast dflags (text "void *") expr         -- see comment by machRepHintCType below      pprArg (expr, SignedHint)-        = sdocWithDynFlags $ \dflags ->-          cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr+        = cCast dflags (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr      pprArg (expr, _other)-        = pprExpr expr+        = pprExpr dflags expr -     pprUnHint AddrHint   rep = parens (machRepCType rep)-     pprUnHint SignedHint rep = parens (machRepCType rep)+     pprUnHint AddrHint   rep = parens (machRepCType platform rep)+     pprUnHint SignedHint rep = parens (machRepCType platform rep)      pprUnHint _          _   = empty  -- Currently we only have these two calling conventions, but this might@@ -1029,23 +1040,23 @@ -- Find and print local and external declarations for a list of -- Cmm statements. ---pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})-pprTempAndExternDecls stmts-  = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),-     vcat (map pprExternDecl (Map.keys lbls)))+pprTempAndExternDecls :: Platform -> [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})+pprTempAndExternDecls platform stmts+  = (pprUFM (getUniqSet temps) (vcat . map (pprTempDecl platform)),+     vcat (map (pprExternDecl platform) (Map.keys lbls)))   where (temps, lbls) = runTE (mapM_ te_BB stmts) -pprDataExterns :: [CmmStatic] -> SDoc-pprDataExterns statics-  = vcat (map pprExternDecl (Map.keys lbls))+pprDataExterns :: Platform -> [CmmStatic] -> SDoc+pprDataExterns platform statics+  = vcat (map (pprExternDecl platform) (Map.keys lbls))   where (_, lbls) = runTE (mapM_ te_Static statics) -pprTempDecl :: LocalReg -> SDoc-pprTempDecl l@(LocalReg _ rep)-  = hcat [ machRepCType rep, space, pprLocalReg l, semi ]+pprTempDecl :: Platform -> LocalReg -> SDoc+pprTempDecl platform l@(LocalReg _ rep)+  = hcat [ machRepCType platform rep, space, pprLocalReg l, semi ] -pprExternDecl :: CLabel -> SDoc-pprExternDecl lbl+pprExternDecl :: Platform -> CLabel -> SDoc+pprExternDecl platform lbl   -- do not print anything for "known external" things   | not (needsCDecl lbl) = empty   | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz@@ -1072,9 +1083,9 @@   -- If the label we want to refer to is a stdcall function (on Windows) then   -- we must generate an appropriate prototype for it, so that the C compiler will   -- add the @n suffix to the label (#2276)-  stdcall_decl sz = sdocWithDynFlags $ \dflags ->+  stdcall_decl sz =         text "extern __attribute__((stdcall)) void " <> ppr lbl-        <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))+        <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))         <> semi  type TEState = (UniqSet LocalReg, Map CLabel ())@@ -1142,19 +1153,18 @@ -- --------------------------------------------------------------------- -- C types for MachReps -cCast :: SDoc -> CmmExpr -> SDoc-cCast ty expr = parens ty <> pprExpr1 expr+cCast :: DynFlags -> SDoc -> CmmExpr -> SDoc+cCast dflags ty expr = parens ty <> pprExpr1 dflags expr -cLoad :: CmmExpr -> CmmType -> SDoc-cLoad expr rep-    = sdocWithPlatform $ \platform ->-      if bewareLoadStoreAlignment (platformArch platform)-      then let decl = machRepCType rep <+> text "x" <> semi+cLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc+cLoad dflags expr rep+    = if bewareLoadStoreAlignment (platformArch platform)+      then let decl = machRepCType platform rep <+> text "x" <> semi                struct = text "struct" <+> braces (decl)                packed_attr = text "__attribute__((packed))"                cast = parens (struct <+> packed_attr <> char '*')-           in parens (cast <+> pprExpr1 expr) <> text "->x"-      else char '*' <> parens (cCast (machRepPtrCType rep) expr)+           in parens (cast <+> pprExpr1 dflags expr) <> text "->x"+      else char '*' <> parens (cCast dflags (machRepPtrCType platform rep) expr)     where -- On these platforms, unaligned loads are known to cause problems           bewareLoadStoreAlignment ArchAlpha    = True           bewareLoadStoreAlignment ArchMipseb   = True@@ -1167,53 +1177,54 @@           -- on unknown arches           bewareLoadStoreAlignment ArchUnknown  = True           bewareLoadStoreAlignment _            = False+          platform = targetPlatform dflags -isCmmWordType :: DynFlags -> CmmType -> Bool+isCmmWordType :: Platform -> CmmType -> Bool -- True of GcPtrReg/NonGcReg of native word size-isCmmWordType dflags ty = not (isFloatType ty)-                       && typeWidth ty == wordWidth dflags+isCmmWordType platform ty = not (isFloatType ty)+                            && typeWidth ty == wordWidth platform  -- This is for finding the types of foreign call arguments.  For a pointer -- argument, we always cast the argument to (void *), to avoid warnings from -- the C compiler.-machRepHintCType :: CmmType -> ForeignHint -> SDoc-machRepHintCType _   AddrHint   = text "void *"-machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)-machRepHintCType rep _other     = machRepCType rep+machRepHintCType :: Platform -> CmmType -> ForeignHint -> SDoc+machRepHintCType platform rep = \case+   AddrHint   -> text "void *"+   SignedHint -> machRep_S_CType platform (typeWidth rep)+   _other     -> machRepCType platform rep -machRepPtrCType :: CmmType -> SDoc-machRepPtrCType r- = sdocWithDynFlags $ \dflags ->-   if isCmmWordType dflags r then text "P_"-                             else machRepCType r <> char '*'+machRepPtrCType :: Platform -> CmmType -> SDoc+machRepPtrCType platform r+ = if isCmmWordType platform r+      then text "P_"+      else machRepCType platform r <> char '*' -machRepCType :: CmmType -> SDoc-machRepCType ty | isFloatType ty = machRep_F_CType w-                | otherwise      = machRep_U_CType w-                where-                  w = typeWidth ty+machRepCType :: Platform -> CmmType -> SDoc+machRepCType platform ty+   | isFloatType ty = machRep_F_CType w+   | otherwise      = machRep_U_CType platform w+   where+      w = typeWidth ty  machRep_F_CType :: Width -> SDoc machRep_F_CType W32 = text "StgFloat" -- ToDo: correct? machRep_F_CType W64 = text "StgDouble" machRep_F_CType _   = panic "machRep_F_CType" -machRep_U_CType :: Width -> SDoc-machRep_U_CType w- = sdocWithDynFlags $ \dflags ->-   case w of-   _ | w == wordWidth dflags -> text "W_"+machRep_U_CType :: Platform -> Width -> SDoc+machRep_U_CType platform w+ = case w of+   _ | w == wordWidth platform -> text "W_"    W8  -> text "StgWord8"    W16 -> text "StgWord16"    W32 -> text "StgWord32"    W64 -> text "StgWord64"    _   -> panic "machRep_U_CType" -machRep_S_CType :: Width -> SDoc-machRep_S_CType w- = sdocWithDynFlags $ \dflags ->-   case w of-   _ | w == wordWidth dflags -> text "I_"+machRep_S_CType :: Platform -> Width -> SDoc+machRep_S_CType platform w+ = case w of+   _ | w == wordWidth platform -> text "I_"    W8  -> text "StgInt8"    W16 -> text "StgInt16"    W32 -> text "StgInt32"@@ -1267,11 +1278,12 @@         writeArray arr 0 (fromRational r)         arr' <- castFloatToWord32Array arr         w32 <- readArray arr' 0-        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags))+        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth platform))     )-    where wo | wordWidth dflags == W64+    where wo | wordWidth platform == W64              , wORDS_BIGENDIAN dflags    = 32              | otherwise                 = 0+          platform = targetPlatform dflags  floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit floatPairToWord dflags r1 r2@@ -1301,7 +1313,8 @@         w64 <- readArray arr' 0         return (pprWord64 w64)     )-    where targetWidth = wordWidth dflags+    where targetWidth = wordWidth platform+          platform    = targetPlatform dflags           targetBE    = wORDS_BIGENDIAN dflags           pprWord64 w64               | targetWidth == W64 =@@ -1320,15 +1333,15 @@ -- --------------------------------------------------------------------------- -- Utils -wordShift :: DynFlags -> Int-wordShift dflags = widthInLog (wordWidth dflags)+wordShift :: Platform -> Int+wordShift platform = widthInLog (wordWidth platform)  commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs  -- Print in C hex format: 0x13fa-pprHexVal :: Integer -> Width -> SDoc-pprHexVal w rep+pprHexVal :: DynFlags -> Integer -> Width -> SDoc+pprHexVal dflags w rep   | w < 0     = parens (char '-' <>                     text "0x" <> intToDoc (-w) <> repsuffix rep)   | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep@@ -1339,7 +1352,7 @@         -- times values are unsigned.  This also helps eliminate occasional         -- warnings about integer overflow from gcc. -      repsuffix W64 = sdocWithDynFlags $ \dflags ->+      repsuffix W64 =                if cINT_SIZE       dflags == 8 then char 'U'           else if cLONG_SIZE      dflags == 8 then text "UL"           else if cLONG_LONG_SIZE dflags == 8 then text "ULL"
compiler/GHC/CmmToLlvm/Base.hs view
@@ -23,7 +23,7 @@         markStackReg, checkStackReg,         funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,         dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,-        ghcInternalFunctions,+        ghcInternalFunctions, getPlatform,          getMetaUniqueId,         setUniqMeta, getUniqMeta,@@ -54,11 +54,11 @@ import GHC.Cmm.Utils (regsOverlap) import Outputable as Outp import GHC.Platform-import UniqFM-import Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique import BufWrite   ( BufHandle )-import UniqSet-import UniqSupply+import GHC.Types.Unique.Set+import GHC.Types.Unique.Supply import ErrUtils import qualified Stream @@ -134,17 +134,18 @@   = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])                       | otherwise   = (x, [])        dflags <- getDynFlags+       platform <- getPlatform        return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs-                                 (map (toParams . getVarType) (llvmFunArgs dflags live))-                                 (llvmFunAlign dflags)+                                 (map (toParams . getVarType) (llvmFunArgs platform live))+                                 (llvmFunAlign platform)  -- | Alignment to use for functions-llvmFunAlign :: DynFlags -> LMAlign-llvmFunAlign dflags = Just (wORD_SIZE dflags)+llvmFunAlign :: Platform -> LMAlign+llvmFunAlign platform = Just (platformWordSizeInBytes platform)  -- | Alignment to use for into tables-llvmInfAlign :: DynFlags -> LMAlign-llvmInfAlign dflags = Just (wORD_SIZE dflags)+llvmInfAlign :: Platform -> LMAlign+llvmInfAlign platform = Just (platformWordSizeInBytes platform)  -- | Section to use for a function llvmFunSection :: DynFlags -> LMString -> LMSection@@ -153,12 +154,11 @@     | otherwise                     = Nothing  -- | A Function's arguments-llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]-llvmFunArgs dflags live =-    map (lmGlobalRegArg dflags) (filter isPassed allRegs)-    where platform = targetPlatform dflags-          allRegs = activeStgRegs platform-          paddedLive = map (\(_,r) -> r) $ padLiveArgs dflags live+llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]+llvmFunArgs platform live =+    map (lmGlobalRegArg platform) (filter isPassed allRegs)+    where allRegs = activeStgRegs platform+          paddedLive = map (\(_,r) -> r) $ padLiveArgs platform live           isLive r = r `elem` alwaysLive || r `elem` paddedLive           isPassed r = not (isFPR r) || isLive r @@ -217,14 +217,13 @@ -- -- Also, the returned list is not sorted in any particular order. ---padLiveArgs :: DynFlags -> LiveGlobalRegs -> [(Bool, GlobalReg)]-padLiveArgs dflags live =+padLiveArgs :: Platform -> LiveGlobalRegs -> [(Bool, GlobalReg)]+padLiveArgs plat live =       if platformUnregisterised plat         then taggedLive -- not using GHC's register convention for platform.         else padding ++ taggedLive   where     taggedLive = map (\x -> (False, x)) live-    plat = targetPlatform dflags      fprLive = filter isFPR live     padding = concatMap calcPad $ groupBy sharesClass fprLive@@ -232,7 +231,7 @@     sharesClass :: GlobalReg -> GlobalReg -> Bool     sharesClass a b = sameFPRClass a b || overlappingClass       where-        overlappingClass = regsOverlap dflags (norm a) (norm b)+        overlappingClass = regsOverlap plat (norm a) (norm b)         norm = CmmGlobal . normalizeFPRNum      calcPad :: [GlobalReg] -> [(Bool, GlobalReg)]@@ -269,8 +268,8 @@ tysToParams = map (\ty -> (ty, []))  -- | Pointer width-llvmPtrBits :: DynFlags -> Int-llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags+llvmPtrBits :: Platform -> Int+llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform  -- ---------------------------------------------------------------------------- -- * Llvm Version@@ -343,6 +342,9 @@ instance HasDynFlags LlvmM where     getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) +getPlatform :: LlvmM Platform+getPlatform = targetPlatform <$> getDynFlags+ instance MonadUnique LlvmM where     getUniqueSupplyM = do         mask <- getEnv envMask@@ -484,11 +486,12 @@ -- 'void *'). Fixes trac #5486. ghcInternalFunctions :: LlvmM () ghcInternalFunctions = do-    dflags <- getDynFlags-    mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]-    mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]-    mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]-    mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]+    platform <- getPlatform+    let w = llvmWord platform+    mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]+    mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]+    mk "memset" i8Ptr [i8Ptr, w, w]+    mk "newSpark" w [i8Ptr, i8Ptr]   where     mk n ret args = do       let n' = llvmDefLabel $ fsLit n
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -27,13 +27,13 @@  import GHC.Driver.Session import FastString-import ForeignCall+import GHC.Types.ForeignCall import Outputable hiding (panic, pprPanic) import qualified Outputable import GHC.Platform import OrdList-import UniqSupply-import Unique+import GHC.Types.Unique.Supply+import GHC.Types.Unique import Util  import Control.Monad.Trans.Class@@ -292,12 +292,14 @@ -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. genCall t@(PrimTarget op) [] args- | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do-    dflags <- getDynFlags+ | Just align <- machOpMemcpyishAlign op+ = do+   platform <- getPlatform+   runStmtsDecls $ do     let isVolTy = [i1]         isVolVal = [mkIntLit i1 0]-        argTy | MO_Memset _ <- op = [i8Ptr, i8,    llvmWord dflags, i32] ++ isVolTy-              | otherwise         = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy+        argTy | MO_Memset _ <- op = [i8Ptr, i8,    llvmWord platform, i32] ++ isVolTy+              | otherwise         = [i8Ptr, i8Ptr, llvmWord platform, i32] ++ isVolTy         funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible                              CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing @@ -396,13 +398,14 @@     genCallWithOverflow t w [dstV, dstO] [lhs, rhs]  -- Handle all other foreign calls and prim ops.-genCall target res args = runStmtsDecls $ do-    dflags <- getDynFlags+genCall target res args = do+  platform <- getPlatform+  runStmtsDecls $ do      -- parameter types     let arg_type (_, AddrHint) = i8Ptr         -- cast pointers to i8*. Llvm equivalent of void*-        arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr+        arg_type (expr, _) = cmmToLlvmType $ cmmExprType platform expr      -- ret type     let ret_type [] = LMVoid@@ -451,7 +454,7 @@     let retTy = ret_type ress_hints     let argTy = tysToParams $ map arg_type args_hints     let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible-                             lmconv retTy FixedArgs argTy (llvmFunAlign dflags)+                             lmconv retTy FixedArgs argTy (llvmFunAlign platform)       argVars <- arg_varsW args_hints ([], nilOL, [])@@ -716,11 +719,12 @@              | otherwise             = do dflags <- getDynFlags+                 platform <- getPlatform                  let op = case (getVarType v, t) of                       (LMInt n, LMInt m)                           -> if n < m then extend else LM_Trunc                       (vt, _) | isFloat vt && isFloat t-                          -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t+                          -> if llvmWidthInBits platform vt < llvmWidthInBits platform t                                 then LM_Fpext else LM_Fptrunc                       (vt, _) | isInt vt && isFloat t       -> LM_Sitofp                       (vt, _) | isFloat vt && isInt t       -> LM_Fptosi@@ -748,8 +752,9 @@ cmmPrimOpFunctions mop = do    dflags <- getDynFlags-  let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)-      intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)+  platform <- getPlatform+  let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)+      intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)       unsupported = panic ("cmmPrimOpFunctions: " ++ show mop                         ++ " not supported here") @@ -896,10 +901,10 @@     let stmts = stmts2      let ty = (pLower . getVarType) vreg-    dflags <- getDynFlags+    platform <- getPlatform     case ty of       -- Some registers are pointer types, so need to cast value to pointer-      LMPointer _ | getVarType vval == llvmWord dflags -> do+      LMPointer _ | getVarType vval == llvmWord platform -> do           (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty           let s2 = Store v vreg           return (stmts `snocOL` s1 `snocOL` s2, top2)@@ -949,10 +954,10 @@ genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr               -> LlvmM StmtData genStore_fast addr r n val-  = do dflags <- getDynFlags+  = do platform <- getPlatform        (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)        meta          <- getTBAARegMeta r-       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)+       let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt  `div` 8)        case isPointer grt && rem == 0 of             True -> do                 (vval,  stmts, top) <- exprToVar val@@ -987,9 +992,10 @@      let stmts = stmts1 `appOL` stmts2     dflags <- getDynFlags+    platform <- getPlatform     case getVarType vaddr of         -- sometimes we need to cast an int to a pointer before storing-        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do+        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do             (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty             let s2 = MetaStmt meta $ Store v vaddr             return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)@@ -998,7 +1004,7 @@             let s1 = MetaStmt meta $ Store vval vaddr             return (stmts `snocOL` s1, top1 ++ top2) -        i@(LMInt _) | i == llvmWord dflags -> do+        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@@ -1006,9 +1012,9 @@          other ->             pprPanic "genStore: ptr not right type!"-                    (PprCmm.pprExpr addr <+> text (-                        "Size of Ptr: " ++ show (llvmPtrBits dflags) ++-                        ", Size of var: " ++ show (llvmWidthInBits dflags other) +++                    (PprCmm.pprExpr platform addr <+> text (+                        "Size of Ptr: " ++ show (llvmPtrBits platform) +++                        ", Size of var: " ++ show (llvmWidthInBits platform other) ++                         ", Var: " ++ showSDoc dflags (ppr vaddr)))  @@ -1170,8 +1176,8 @@         case isPointer ty of              True  -> do                  -- Cmm wants the value, so pointer types must be cast to ints-                 dflags <- getDynFlags-                 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)+                 platform <- getPlatform+                 (v2, s2) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint v1 (llvmWord platform)                  return (v2, s1 `snocOL` s2, [])               False -> return (v1, s1, [])@@ -1180,8 +1186,8 @@         -> genMachOp opt op exprs      CmmRegOff r i-        -> do dflags <- getDynFlags-              exprToVar $ expandCmmReg dflags (r, i)+        -> do platform <- getPlatform+              exprToVar $ expandCmmReg platform (r, i)      CmmStackSlot _ _         -> panic "exprToVar: CmmStackSlot not supported!"@@ -1321,8 +1327,8 @@             let sameConv' op = do                     (v1, s1) <- doExpr ty $ Cast op vx ty                     return (v1, stmts `snocOL` s1, top)-            dflags <- getDynFlags-            let toWidth = llvmWidthInBits dflags ty+            platform <- getPlatform+            let toWidth = llvmWidthInBits platform ty             -- LLVM doesn't like trying to convert to same width, so             -- need to check for that as we do get Cmm code doing it.             case widthInBits from  of@@ -1351,12 +1357,12 @@                -> LlvmM ExprData genMachOp_fast opt op r n e   = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)-       dflags <- getDynFlags-       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)+       platform <- getPlatform+       let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt  `div` 8)        case isPointer grt && rem == 0 of             True -> do                 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]-                (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)+                (var, s3) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint ptr (llvmWord platform)                 return (var, s1 `snocOL` s2 `snocOL` s3, [])              False -> genMachOp_slow opt op e@@ -1497,7 +1503,9 @@ #endif      where-        binLlvmOp ty binOp = runExprData $ do+        binLlvmOp ty binOp = do+          platform <- getPlatform+          runExprData $ do             vx <- exprToVarW x             vy <- exprToVarW y             if getVarType vx == getVarType vy@@ -1509,7 +1517,7 @@                     dflags <- getDynFlags                     let style = mkCodeStyle CStyle                         toString doc = renderWithStyle (initSDocContext dflags style) doc-                        cmmToStr = (lines . toString . PprCmm.pprExpr)+                        cmmToStr = (lines . toString . PprCmm.pprExpr platform)                     statement $ Comment $ map fsLit $ cmmToStr x                     statement $ Comment $ map fsLit $ cmmToStr y                     doExprW (ty vx) $ binOp vx vy@@ -1528,11 +1536,12 @@         genBinComp opt cmp = do             ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)             dflags <- getDynFlags+            platform <- getPlatform             if getVarType v1 == i1                 then case i1Expected opt of                     True  -> return ed                     False -> do-                        let w_ = llvmWord dflags+                        let w_ = llvmWord platform                         (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_                         return (v2, stmts `snocOL` s1, top)                 else@@ -1548,16 +1557,18 @@         -- implementation. Its much longer due to type information/safety.         -- This should actually compile to only about 3 asm instructions.         isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData-        isSMulOK _ x y = runExprData $ do+        isSMulOK _ x y = do+          platform <- getPlatform+          dflags <- getDynFlags+          runExprData $ do             vx <- exprToVarW x             vy <- exprToVarW y -            dflags <- getDynFlags             let word  = getVarType vx-            let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)-            let shift = llvmWidthInBits dflags word-            let shift1 = toIWord dflags (shift - 1)-            let shift2 = toIWord dflags shift+            let word2 = LMInt $ 2 * (llvmWidthInBits platform $ getVarType vx)+            let shift = llvmWidthInBits platform word+            let shift1 = toIWord platform (shift - 1)+            let shift2 = toIWord platform shift              if isInt word                 then do@@ -1615,11 +1626,11 @@ genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType              -> LlvmM ExprData genLoad_fast atomic e r n ty = do-    dflags <- getDynFlags+    platform <- getPlatform     (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)     meta          <- getTBAARegMeta r     let ty'      = cmmToLlvmType ty-        (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)+        (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt  `div` 8)     case isPointer grt && rem == 0 of             True  -> do                 (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]@@ -1649,22 +1660,24 @@ -- | 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 = runExprData $ do+genLoad_slow atomic e ty meta = do+  platform <- getPlatform+  dflags <- getDynFlags+  runExprData $ do     iptr <- exprToVarW e-    dflags <- getDynFlags     case getVarType iptr of          LMPointer _ -> do                     doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr) -         i@(LMInt _) | i == llvmWord dflags -> do+         i@(LMInt _) | i == llvmWord platform -> do                     let pty = LMPointer $ cmmToLlvmType ty                     ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty                     doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)           other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"-                        (PprCmm.pprExpr e <+> text (-                            "Size of Ptr: " ++ show (llvmPtrBits dflags) ++-                            ", Size of var: " ++ show (llvmWidthInBits dflags other) +++                        (PprCmm.pprExpr platform e <+> text (+                            "Size of Ptr: " ++ show (llvmPtrBits platform) +++                            ", Size of var: " ++ show (llvmWidthInBits platform other) ++                             ", Var: " ++ showSDoc dflags (ppr iptr)))   where     loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr@@ -1688,8 +1701,9 @@ getCmmReg (CmmGlobal g)   = do onStack <- checkStackReg g        dflags <- getDynFlags+       platform <- getPlatform        if onStack-         then return (lmGlobalRegVar dflags g)+         then return (lmGlobalRegVar platform g)          else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"  -- | Return the value of a given register, as well as its type. Might@@ -1699,9 +1713,9 @@   case reg of     CmmGlobal g -> do       onStack <- checkStackReg g-      dflags <- getDynFlags+      platform <- getPlatform       if onStack then loadFromStack else do-        let r = lmGlobalRegArg dflags g+        let r = lmGlobalRegArg platform g         return (r, getVarType r, nilOL)     _ -> loadFromStack  where loadFromStack = do@@ -1751,33 +1765,33 @@  genLit _ cmm@(CmmLabel l)   = do var <- getGlobalPtr =<< strCLabel_llvm l-       dflags <- getDynFlags-       let lmty = cmmToLlvmType $ cmmLitType dflags cmm-       (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)+       platform <- getPlatform+       let lmty = cmmToLlvmType $ cmmLitType platform cmm+       (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord platform)        return (v1, unitOL s1, [])  genLit opt (CmmLabelOff label off) = do-    dflags <- getDynFlags+    platform <- getPlatform     (vlbl, stmts, stat) <- genLit opt (CmmLabel label)-    let voff = toIWord dflags off+    let voff = toIWord platform off     (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff     return (v1, stmts `snocOL` s1, stat)  genLit opt (CmmLabelDiffOff l1 l2 off w) = do-    dflags <- getDynFlags+    platform <- getPlatform     (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)     (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)-    let voff = toIWord dflags off+    let voff = toIWord platform off     let ty1 = getVarType vl1     let ty2 = getVarType vl2     if (isInt ty1) && (isInt ty2)-       && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)+       && (llvmWidthInBits platform ty1 == llvmWidthInBits platform ty2)        then do             (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2             (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff             let ty = widthToLlvmInt w             let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2-            if w /= wordWidth dflags+            if w /= wordWidth platform               then do                 (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty                 return (v3, stmts `snocOL` s3, stat1 ++ stat2)@@ -1819,7 +1833,7 @@       assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks       isLive r     = r `elem` alwaysLive || r `elem` live -  dflags <- getDynFlags+  platform <- getPlatform   stmtss <- flip mapM assignedRegs $ \reg ->     case reg of       CmmLocal (LocalReg un _) -> do@@ -1827,8 +1841,8 @@         varInsert un (pLower $ getVarType newv)         return stmts       CmmGlobal r -> do-        let reg   = lmGlobalRegVar dflags r-            arg   = lmGlobalRegArg dflags r+        let reg   = lmGlobalRegVar platform r+            arg   = lmGlobalRegArg platform r             ty    = (pLower . getVarType) reg             trash = LMLitVar $ LMUndefLit ty             rval  = if isLive r then arg else trash@@ -1845,11 +1859,11 @@ -- STG Liveness optimisation done here. funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) funEpilogue live = do-    dflags <- getDynFlags+    platform <- getPlatform      -- the bool indicates whether the register is padding.     let alwaysNeeded = map (\r -> (False, r)) alwaysLive-        livePadded = alwaysNeeded ++ padLiveArgs dflags live+        livePadded = alwaysNeeded ++ padLiveArgs platform live      -- Set to value or "undef" depending on whether the register is     -- actually live@@ -1857,7 +1871,7 @@           (v, _, s) <- getCmmRegVal (CmmGlobal r)           return (Just $ v, s)         loadUndef r = do-          let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)+          let ty = (pLower . getVarType $ lmGlobalRegVar platform r)           return (Just $ LMLitVar $ LMUndefLit ty, nilOL)     platform <- getDynFlag targetPlatform     let allRegs = activeStgRegs platform@@ -1905,9 +1919,9 @@   -- | Expand CmmRegOff-expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr-expandCmmReg dflags (reg, off)-  = let width = typeWidth (cmmRegType dflags reg)+expandCmmReg :: Platform -> (CmmReg, Int) -> CmmExpr+expandCmmReg platform (reg, off)+  = let width = typeWidth (cmmRegType platform reg)         voff  = CmmLit $ CmmInt (fromIntegral off) width     in CmmMachOp (MO_Add width) [CmmReg reg, voff] @@ -1924,8 +1938,8 @@ toI32 :: Integral a => a -> LlvmVar toI32 = mkIntLit i32 -toIWord :: Integral a => DynFlags -> a -> LlvmVar-toIWord dflags = mkIntLit (llvmWord dflags)+toIWord :: Integral a => Platform -> a -> LlvmVar+toIWord platform = mkIntLit (llvmWord platform)   -- | Error functions
compiler/GHC/CmmToLlvm/Data.hs view
@@ -169,23 +169,23 @@ -- Leave unresolved, will fix later genStaticLit cmm@(CmmLabel l) = do     var <- getGlobalPtr =<< strCLabel_llvm l-    dflags <- getDynFlags+    platform <- getPlatform     let ptr = LMStaticPointer var-        lmty = cmmToLlvmType $ cmmLitType dflags cmm+        lmty = cmmToLlvmType $ cmmLitType platform cmm     return $ LMPtoI ptr lmty  genStaticLit (CmmLabelOff label off) = do-    dflags <- getDynFlags+    platform <- getPlatform     var <- genStaticLit (CmmLabel label)-    let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)+    let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord platform)     return $ LMAdd var offset  genStaticLit (CmmLabelDiffOff l1 l2 off w) = do-    dflags <- getDynFlags+    platform <- getPlatform     var1 <- genStaticLit (CmmLabel l1)     var2 <- genStaticLit (CmmLabel l2)     let var-          | w == wordWidth dflags = LMSub var1 var2+          | w == wordWidth platform = LMSub var1 var2           | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w)         offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w)     return $ LMAdd var offset
compiler/GHC/CmmToLlvm/Ppr.hs view
@@ -20,7 +20,7 @@  import FastString import Outputable-import Unique+import GHC.Types.Unique  -- ---------------------------------------------------------------------------- -- * Top level@@ -55,8 +55,9 @@         funDec <- llvmFunSig live lbl link        dflags <- getDynFlags+       platform <- getPlatform        let buildArg = fsLit . showSDoc dflags . ppPlainName-           funArgs = map buildArg (llvmFunArgs dflags live)+           funArgs = map buildArg (llvmFunArgs platform live)            funSect = llvmFunSection dflags (decName funDec)         -- generate the info table@@ -91,7 +92,7 @@                             (Just $ LMBitc (LMStaticPointer defVar)                                            i8Ptr) -       return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])+       return (ppLlvmGlobal alias $+$ ppLlvmFunction platform fun', [])   -- | The section we are putting info tables and their entry code into, should
compiler/GHC/CmmToLlvm/Regs.hs view
@@ -16,25 +16,25 @@ import GHC.Llvm  import GHC.Cmm.Expr-import GHC.Driver.Session+import GHC.Platform import FastString import Outputable ( panic )-import Unique+import GHC.Types.Unique  -- | Get the LlvmVar function variable storing the real register-lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar-lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var"+lmGlobalRegVar :: Platform -> GlobalReg -> LlvmVar+lmGlobalRegVar platform = pVarLift . lmGlobalReg platform "_Var"  -- | Get the LlvmVar function argument storing the real register-lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar-lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg"+lmGlobalRegArg :: Platform -> GlobalReg -> LlvmVar+lmGlobalRegArg platform = lmGlobalReg platform "_Arg"  {- Need to make sure the names here can't conflict with the unique generated    names. Uniques generated names containing only base62 chars. So using say    the '_' char guarantees this. -}-lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar-lmGlobalReg dflags suf reg+lmGlobalReg :: Platform -> String -> GlobalReg -> LlvmVar+lmGlobalReg platform suf reg   = case reg of         BaseReg        -> ptrGlobal $ "Base" ++ suf         Sp             -> ptrGlobal $ "Sp" ++ suf@@ -84,8 +84,8 @@         -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc         -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg     where-        wordGlobal   name = LMNLocalVar (fsLit name) (llvmWord dflags)-        ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr dflags)+        wordGlobal   name = LMNLocalVar (fsLit name) (llvmWord platform)+        ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr platform)         floatGlobal  name = LMNLocalVar (fsLit name) LMFloat         doubleGlobal name = LMNLocalVar (fsLit name) LMDouble         xmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32))
compiler/GHC/Core/Lint.hs view
@@ -29,50 +29,51 @@ import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Stats ( coreBindsStats )-import CoreMonad+import GHC.Core.Op.Monad import Bag-import Literal-import DataCon+import GHC.Types.Literal+import GHC.Core.DataCon import TysWiredIn import TysPrim import TcType ( isFloatingTy )-import Var-import VarEnv-import VarSet-import Name-import Id-import IdInfo+import GHC.Types.Var as Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Unique.Set( nonDetEltsUniqSet )+import GHC.Types.Name+import GHC.Types.Id+import GHC.Types.Id.Info import GHC.Core.Ppr import ErrUtils-import Coercion-import SrcLoc-import Type+import GHC.Core.Coercion+import GHC.Types.SrcLoc+import GHC.Core.Type as Type import GHC.Types.RepType-import TyCoRep       -- checks validity of types/coercions-import TyCoSubst-import TyCoFVs-import TyCoPpr ( pprTyVar )-import TyCon-import CoAxiom-import BasicTypes+import GHC.Core.TyCo.Rep   -- checks validity of types/coercions+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr ( pprTyVar )+import GHC.Core.TyCon as TyCon+import GHC.Core.Coercion.Axiom+import GHC.Types.Basic import ErrUtils as Err import ListSetOps import PrelNames import Outputable import FastString import Util-import InstEnv     ( instanceDFunId )-import OptCoercion ( checkAxInstCo )-import GHC.Core.Arity ( typeArity )-import Demand ( splitStrictSig, isBotDiv )+import GHC.Core.InstEnv      ( instanceDFunId )+import GHC.Core.Coercion.Opt ( checkAxInstCo )+import GHC.Core.Arity        ( typeArity )+import GHC.Types.Demand ( splitStrictSig, isBotDiv )  import GHC.Driver.Types import GHC.Driver.Session import Control.Monad-import qualified Control.Monad.Fail as MonadFail import MonadUtils import Data.Foldable      ( toList ) import Data.List.NonEmpty ( NonEmpty )+import Data.List          ( partition ) import Data.Maybe import Pair import qualified GHC.LanguageExtensions as LangExt@@ -161,22 +162,61 @@ Note [Linting type lets] ~~~~~~~~~~~~~~~~~~~~~~~~ In the desugarer, it's very very convenient to be able to say (in effect)-        let a = Type Int in <body>-That is, use a type let.   See Note [Type let] in GHC.Core.+        let a = Type Bool in+        let x::a = True in <body>+That is, use a type let.   See Note [Type let] in CoreSyn.+One place it is used is in mkWwArgs; see Note [Join points and beta-redexes]+in GHC.Core.Op.WorkWrap.Lib.  (Maybe there are other "clients" of this feature; I'm not sure). -However, when linting <body> we need to remember that a=Int, else we might-reject a correct program.  So we carry a type substitution (in this example-[a -> Int]) and apply this substitution before comparing types.  The function+* Hence when linting <body> we need to remember that a=Int, else we+  might reject a correct program.  So we carry a type substitution (in+  this example [a -> Bool]) and apply this substitution before+  comparing types. In effect, in Lint, type equality is always+  equality-moduolo-le-subst.  This is in the le_subst field of+  LintEnv.  But nota bene:++  (SI1) The le_subst substitution is applied to types and coercions only++  (SI2) The result of that substitution is used only to check for type+        equality, to check well-typed-ness, /but is then discarded/.+        The result of substittion does not outlive the CoreLint pass.++  (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders.++* The function         lintInTy :: Type -> LintM (Type, Kind)-returns a substituted type.+  returns a substituted type. -When we encounter a binder (like x::a) we must apply the substitution-to the type of the binding variable.  lintBinders does this.+* When we encounter a binder (like x::a) we must apply the substitution+  to the type of the binding variable.  lintBinders does this. -For Ids, the type-substituted Id is added to the in_scope set (which-itself is part of the TCvSubst we are carrying down), and when we-find an occurrence of an Id, we fetch it from the in-scope set.+* Clearly we need to clone tyvar binders as we go. +* But take care (#17590)! We must also clone CoVar binders:+    let a = TYPE (ty |> cv)+    in \cv -> blah+  blindly substituting for `a` might capture `cv`.++* Alas, when cloning a coercion variable we might choose a unique+  that happens to clash with an inner Id, thus+      \cv_66 -> let wild_X7 = blah in blah+  We decide to clone `cv_66` becuase it's already in scope.  Fine,+  choose a new unique.  Aha, X7 looks good.  So we check the lambda+  body with le_subst of [cv_66 :-> cv_X7]++  This is all fine, even though we use the same unique as wild_X7.+  As (SI2) says, we do /not/ return a new lambda+     (\cv_X7 -> let wild_X7 = blah in ...)+  We simply use the le_subst subsitution in types/coercions only, when+  checking for equality.++* We still need to check that Id occurrences are bound by some+  enclosing binding.  We do /not/ use the InScopeSet for the le_subst+  for this purpose -- it contains only TyCoVars.  Instead we have a separate+  le_ids for the in-scope Id binders.++Sigh.  We might want to explore getting rid of type-let!+ Note [Bad unsafe coercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~ For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions@@ -418,9 +458,9 @@ -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintCoreBindings dflags pass local_in_scope binds-  = initL dflags flags in_scope_set $-    addLoc TopLevelBindings         $-    lintLetBndrs TopLevel binders   $+  = initL dflags flags local_in_scope $+    addLoc TopLevelBindings           $+    lintLetBndrs TopLevel binders     $         -- Put all the top-level binders in scope at the start         -- This is because transformation rules can bring something         -- into use 'unexpectedly'@@ -428,8 +468,6 @@        ; checkL (null ext_dups) (dupExtVars ext_dups)        ; mapM lint_bind binds }   where-    in_scope_set = mkInScopeSet (mkVarSet local_in_scope)-     flags = defaultLintFlags                { lf_check_global_ids = check_globals                , lf_check_inline_loop_breakers = check_lbs@@ -501,12 +539,12 @@               -> CoreExpr               -> Maybe MsgDoc   -- Nothing => OK -lintUnfolding is_compulsory dflags locn vars expr+lintUnfolding is_compulsory dflags locn var_set expr   | isEmptyBag errs = Nothing   | otherwise       = Just (pprMessageBag errs)   where-    in_scope = mkInScopeSet vars-    (_warns, errs) = initL dflags defaultLintFlags in_scope $+    vars = nonDetEltsUniqSet var_set+    (_warns, errs) = initL dflags defaultLintFlags vars $                      if is_compulsory                        -- See Note [Checking for levity polymorphism]                      then noLPChecks linter@@ -523,8 +561,7 @@   | isEmptyBag errs = Nothing   | otherwise       = Just (pprMessageBag errs)   where-    in_scope = mkInScopeSet (mkVarSet vars)-    (_warns, errs) = initL dflags defaultLintFlags in_scope linter+    (_warns, errs) = initL dflags defaultLintFlags vars linter     linter = addLoc TopLevelBindings $              lintCoreExpr expr @@ -601,7 +638,7 @@         -- We used to check that the dmdTypeDepth of a demand signature never        -- exceeds idArity, but that is an unnecessary complication, see-       -- Note [idArity varies independently of dmdTypeDepth] in DmdAnal+       -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Op.DmdAnal         -- Check that the binder's arity is within the bounds imposed by        -- the type and the strictness signature. See Note [exprArity invariant]@@ -776,7 +813,7 @@     do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'                 -- Now extend the substitution so we                 -- take advantage of it in the body-        ; extendSubstL tv ty'        $+        ; extendTvSubstL tv ty'        $           addLoc (BodyOfLetRec [tv]) $           lintCoreExpr body } } @@ -840,7 +877,7 @@                  (text "Non term variable" <+> ppr var)                  -- See GHC.Core Note [Variable occurrences in Core] -        -- Cneck that the type of the occurrence is the same+        -- Check that the type of the occurrence is the same         -- as the type of the binding site         ; ty   <- applySubstTy (idType var)         ; var' <- lookupIdInScope var@@ -1049,7 +1086,7 @@         ; in_scope <- getInScope         -- substTy needs the set of tyvars in scope to avoid generating         -- uniques that are already in scope.-        -- See Note [The substitution invariant] in TyCoSubst+        -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst         ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }    | otherwise@@ -1108,7 +1145,7 @@      -- Check that the scrutinee is not a floating-point type      -- if there are any literal alternatives      -- See GHC.Core Note [Case expression invariants] item (5)-     -- See Note [Rules for floating-point comparisons] in PrelRules+     -- See Note [Rules for floating-point comparisons] in GHC.Core.Op.ConstantFold      ; let isLitPat (LitAlt _, _ , _) = True            isLitPat _                 = False      ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)@@ -1296,13 +1333,14 @@        ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)            (mkNonTopExternalNameMsg id) -       ; (ty, k) <- addLoc (IdTy id) $-                    lintInTy (idType id)+       ; (id_ty, k) <- addLoc (IdTy id) $+                       lintInTy (idType id)+       ; let id' = setIdType id id_ty            -- See Note [Levity polymorphism invariants] in GHC.Core        ; lintL (isJoinId id || not (lf_check_levity_poly flags) || not (isKindLevPoly k))            (text "Levity-polymorphic binder:" <+>-                 (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))+                 (ppr id <+> dcolon <+> parens (ppr id_ty <+> dcolon <+> ppr k)))         -- Check that a join-id is a not-top-level let-binding        ; when (isJoinId id) $@@ -1311,11 +1349,10 @@         -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2);        -- if so, it should be a CoVar, and checked by lintCoVarBndr-       ; lintL (not (isCoVarType ty))-               (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr ty)+       ; lintL (not (isCoVarType id_ty))+               (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) -       ; let id' = setIdType id ty-       ; addInScopeVar id' $ (linterF id') }+       ; addInScopeId id' $ (linterF id') }   where     is_top_lvl = isTopLevel top_lvl     is_let_bind = case bind_site of@@ -1338,8 +1375,7 @@   | isEmptyBag errs = Nothing   | otherwise       = Just (pprMessageBag errs)   where-    in_scope = emptyInScopeSet-    (_warns, errs) = initL dflags defaultLintFlags in_scope linter+    (_warns, errs) = initL dflags defaultLintFlags vars linter     linter = lintBinders LambdaBind vars $ \_ ->              mapM_ lintInTy tys @@ -1351,7 +1387,8 @@   = addLoc (InType ty) $     do  { ty' <- applySubstTy ty         ; k  <- lintType ty'-        ; lintKind k  -- The kind returned by lintType is already+        ; addLoc (InKind ty' k) $+          lintKind k  -- The kind returned by lintType is already                       -- a LintedKind but we also want to check that                       -- k :: *, which lintKind does         ; return (ty', k) }@@ -1368,8 +1405,8 @@ -- See Note [GHC Formalism] lintType (TyVarTy tv)   = do { checkL (isTyVar tv) (mkBadTyVarMsg tv)-       ; lintTyCoVarInScope tv-       ; return (tyVarKind tv) }+       ; tv' <- lintTyCoVarInScope tv+       ; return (tyVarKind tv') }          -- We checked its kind when we added it to the envt  lintType ty@(AppTy t1 t2)@@ -1429,7 +1466,6 @@        ; checkValueKind k (text "the body of forall:" <+> ppr t)        ; return liftedTypeKind            -- We don't check variable escape here. Namely, k could refer to cv'-           -- See Note [NthCo and newtypes] in TyCoRep     }}  lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)@@ -1509,7 +1545,7 @@ -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintArrow what k1 k2   -- Eg lintArrow "type or kind `blah'" k1 k2-                       -- or lintarrow "coercion `blah'" k1 k2+                       -- or lintArrow "coercion `blah'" k1 k2   = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1))        ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result")   k2))        ; return liftedTypeKind }@@ -1548,7 +1584,7 @@ lint_app doc kfn kas     = do { in_scope <- getInScope          -- We need the in_scope set to satisfy the invariant in-         -- Note [The substitution invariant] in TyCoSubst+         -- Note [The substitution invariant] in GHC.Core.TyCo.Subst          ; foldlM (go_app in_scope) kfn kas }   where     fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc@@ -1759,7 +1795,7 @@   | isTyVar tv1   = do { (_, k2) <- lintStarCoercion kind_co        ; let tv2 = setTyVarKind tv1 k2-       ; addInScopeVar tv1 $+       ; addInScopeTyCoVar tv1 $     do {        ; (k3, k4, t1, t2, r) <- lintCoercion co        ; in_scope <- getInScope@@ -1770,7 +1806,7 @@                      -- scope. All the free vars of `t2` and `kind_co` should                      -- already be in `in_scope`, because they've been                      -- linted and `tv2` has the same unique as `tv1`.-                     -- See Note [The substitution invariant] in TyCoSubst.+                     -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst.                      unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co)              tyr = mkInvForAllTy tv2 $                    substTy subst t2@@ -1783,12 +1819,12 @@                (text "Covar can only appear in Refl and GRefl: " <+> ppr co)        ; (_, k2) <- lintStarCoercion kind_co        ; let cv2 = setVarType cv1 k2-       ; addInScopeVar cv1 $+       ; addInScopeTyCoVar cv1 $     do {        ; (k3, k4, t1, t2, r) <- lintCoercion co        ; checkValueKind k3 (text "the body of a ForAllCo over covar:" <+> ppr co)        ; checkValueKind k4 (text "the body of a ForAllCo over covar:" <+> ppr co)-           -- See Note [Weird typing rule for ForAllTy] in Type+           -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep        ; in_scope <- getInScope        ; let tyl   = mkTyCoInvForAllTy cv1 t1              r2    = coVarRole cv1@@ -1801,13 +1837,13 @@                      -- scope. All the free vars of `t2` and `kind_co` should                      -- already be in `in_scope`, because they've been                      -- linted and `cv2` has the same unique as `cv1`.-                     -- See Note [The substitution invariant] in TyCoSubst.+                     -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst.                      unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2)                                           `mkTransCo` (mkSymCo eta2))              tyr = mkTyCoInvForAllTy cv2 $                    substTy subst t2        ; return (liftedTypeKind, liftedTypeKind, tyl, tyr, r) } }-                   -- See Note [Weird typing rule for ForAllTy] in Type+                   -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep  lintCoercion co@(FunCo r co1 co2)   = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1@@ -1823,9 +1859,8 @@   = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)                   2 (text "With offending type:" <+> ppr (varType cv)))   | otherwise-  = do { lintTyCoVarInScope cv-       ; cv' <- lookupIdInScope cv-       ; lintUnliftedCoVar cv+  = do { cv' <- lintTyCoVarInScope cv+       ; lintUnliftedCoVar cv'        ; return $ coVarKindsTypesRole cv' }  -- See Note [Bad unsafe coercion]@@ -1876,11 +1911,11 @@       validateCoercion :: PrimRep -> PrimRep -> LintM ()      validateCoercion rep1 rep2-       = do { dflags <- getDynFlags+       = do { platform <- targetPlatform <$> getDynFlags             ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)                          (report "between unboxed and boxed value")-            ; checkWarnL (TyCon.primRepSizeB dflags rep1-                           == TyCon.primRepSizeB dflags rep2)+            ; checkWarnL (TyCon.primRepSizeB platform rep1+                           == TyCon.primRepSizeB platform rep2)                          (report "between unboxed values of different size")             ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)                                    (TyCon.primRepIsFloat rep2)@@ -1928,7 +1963,7 @@          { (Just (tc_s, tys_s), Just (tc_t, tys_t))              | tc_s == tc_t              , isInjectiveTyCon tc_s r-                 -- see Note [NthCo and newtypes] in TyCoRep+                 -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep              , tys_s `equalLength` tys_t              , tys_s `lengthExceeds` n              -> do { lintRole the_co tr r0@@ -1982,7 +2017,7 @@              , CoercionTy s2' <- s2              -> do { return $                        (liftedTypeKind, liftedTypeKind-                          -- See Note [Weird typing rule for ForAllTy] in Type+                          -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep                        , substTy (mkCvSubst in_scope $ unitVarEnv cv1 s1') t1                        , substTy (mkCvSubst in_scope $ unitVarEnv cv2 s2') t2                        , r) }@@ -2091,10 +2126,14 @@   = LE { le_flags :: LintFlags       -- Linting the result of this pass        , le_loc   :: [LintLocInfo]   -- Locations -       , le_subst :: TCvSubst  -- Current type substitution+       , le_subst :: TCvSubst  -- Current TyCo substitution+                               --    See Note [Linting type lets]+                               -- /Only/ substitutes for type variables;+                               --        but might clone CoVars                                -- We also use le_subst to keep track of-                               -- /all variables/ in scope, both Ids and TyVars+                               -- in-scope TyVars and CoVars +       , le_ids   :: IdSet     -- In-scope Ids        , le_joins :: IdSet     -- Join points in scope that are valid                                -- A subset of the InScopeSet in le_subst                                -- See Note [Join points]@@ -2209,16 +2248,13 @@       (<*>) = ap  instance Monad LintM where-#if !MIN_VERSION_base(4,13,0)-  fail = MonadFail.fail-#endif   m >>= k  = LintM (\ env errs ->                        let (res, errs') = unLintM m env errs in                          case res of                            Just r -> unLintM (k r) env errs'                            Nothing -> (Nothing, errs')) -instance MonadFail.MonadFail LintM where+instance MonadFail LintM where     fail err = failWithL (text err)  instance HasDynFlags LintM where@@ -2238,19 +2274,22 @@   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)   | TopLevelBindings   | InType Type         -- Inside a type+  | InKind Type Kind    -- Inside a kind   | InCo   Coercion     -- Inside a coercion -initL :: DynFlags -> LintFlags -> InScopeSet+initL :: DynFlags -> LintFlags -> [Var]        -> LintM a -> WarnsAndErrs    -- Warnings and errors-initL dflags flags in_scope m+initL dflags flags vars m   = case unLintM m env (emptyBag, emptyBag) of       (Just _, errs) -> errs       (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs                              | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++                                                       "without reporting an error message") empty   where+    (tcvs, ids) = partition isTyCoVar vars     env = LE { le_flags = flags-             , le_subst = mkEmptyTCvSubst in_scope+             , le_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tcvs))+             , le_ids   = mkVarSet ids              , le_joins = emptyVarSet              , le_loc = []              , le_dynflags = dflags }@@ -2330,16 +2369,23 @@     is_case_pat (LE { le_loc = CasePat {} : _ }) = True     is_case_pat _other                           = False -addInScopeVar :: Var -> LintM a -> LintM a-addInScopeVar var m+addInScopeTyCoVar :: Var -> LintM a -> LintM a+addInScopeTyCoVar var m   = LintM $ \ env errs ->-    unLintM m (env { le_subst = extendTCvInScope (le_subst env) var-                   , le_joins = delVarSet        (le_joins env) var-               }) errs+    unLintM m (env { le_subst = extendTCvInScope (le_subst env) var }) errs -extendSubstL :: TyVar -> Type -> LintM a -> LintM a-extendSubstL tv ty m+addInScopeId :: Id -> LintM a -> LintM a+addInScopeId id m   = LintM $ \ env errs ->+    unLintM m (env { le_ids   = extendVarSet (le_ids env) id+                   , le_joins = delVarSet    (le_joins env) id }) errs++getInScopeIds :: LintM IdSet+getInScopeIds = LintM (\env errs -> (Just (le_ids env), errs))++extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a+extendTvSubstL tv ty m+  = LintM $ \ env errs ->     unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs  updateTCvSubst :: TCvSubst -> LintM a -> LintM a@@ -2378,8 +2424,8 @@  lookupIdInScope :: Id -> LintM Id lookupIdInScope id_occ-  = do { subst <- getTCvSubst-       ; case lookupInScope (getTCvInScope subst) id_occ of+  = do { in_scope_ids <- getInScopeIds+       ; case lookupVarSet in_scope_ids id_occ of            Just id_bnd  -> do { checkL (not (bad_global id_bnd)) global_in_scope                               ; return id_bnd }            Nothing -> do { checkL (not is_local) local_out_of_scope@@ -2411,12 +2457,14 @@             Just id' -> return (isJoinId_maybe id')             Nothing  -> return Nothing } -lintTyCoVarInScope :: TyCoVar -> LintM ()+lintTyCoVarInScope :: TyCoVar -> LintM TyCoVar lintTyCoVarInScope var   = do { subst <- getTCvSubst-       ; lintL (var `isInScope` subst)-               (hang (text "The variable" <+> pprBndr LetBind var)-                   2 (text "is out of scope")) }+       ; case lookupInScope (getTCvInScope subst) var of+            Just var' -> return var'+            Nothing -> failWithL $+                       hang (text "The TyCo variable" <+> pprBndr LetBind var)+                          2 (text "is out of scope") }  ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage@@ -2482,6 +2530,8 @@   = (noSrcLoc, Outputable.empty) dumpLoc (InType ty)   = (noSrcLoc, text "In the type" <+> quotes (ppr ty))+dumpLoc (InKind ty ki)+  = (noSrcLoc, text "In the kind of" <+> parens (ppr ty <+> dcolon <+> ppr ki)) dumpLoc (InCo co)   = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) @@ -2729,9 +2779,8 @@ mkBndrOccTypeMismatchMsg :: Var -> Var -> OutType -> OutType -> SDoc mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty   = vcat [ text "Mismatch in type between binder and occurrence"-         , text "Var:" <+> ppr bndr-         , text "Binder type:" <+> ppr bndr_ty-         , text "Occurrence type:" <+> ppr var_ty+         , text "Binder:" <+> ppr bndr <+> dcolon <+> ppr bndr_ty+         , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr var_ty          , text "  Before subst:" <+> ppr (idType var) ]  mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc@@ -2784,7 +2833,7 @@     let binds = flattenBinds $ mg_binds nguts         binds' = flattenBinds $ mg_binds nguts'         (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'-    when (not (null diffs)) $ CoreMonad.putMsg $ vcat+    when (not (null diffs)) $ GHC.Core.Op.Monad.putMsg $ vcat       [ lint_banner "warning" pname       , text "Core changes with annotations:"       , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs
+ compiler/GHC/Core/Op/CSE.hs view
@@ -0,0 +1,799 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section{Common subexpression}+-}++{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}++module GHC.Core.Op.CSE (cseProgram, cseOneExpr) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core.Subst+import GHC.Types.Var    ( Var )+import GHC.Types.Var.Env ( mkInScopeSet )+import GHC.Types.Id     ( Id, idType, idHasRules+                        , idInlineActivation, setInlineActivation+                        , zapIdOccInfo, zapIdUsageInfo, idInlinePragma+                        , isJoinId, isJoinId_maybe )+import GHC.Core.Utils   ( mkAltExpr, eqExpr+                        , exprIsTickedString+                        , stripTicksE, stripTicksT, mkTicks )+import GHC.Core.FVs     ( exprFreeVars )+import GHC.Core.Type    ( tyConAppArgs )+import GHC.Core+import Outputable+import GHC.Types.Basic+import GHC.Core.Map+import Util             ( filterOut, equalLength, debugIsOn )+import Data.List        ( mapAccumL )++{-+                        Simple common sub-expression+                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see+        x1 = C a b+        x2 = C x1 b+we build up a reverse mapping:   C a b  -> x1+                                 C x1 b -> x2+and apply that to the rest of the program.++When we then see+        y1 = C a b+        y2 = C y1 b+we replace the C a b with x1.  But then we *dont* want to+add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1+so that a subsequent binding+        y2 = C y1 b+will get transformed to C x1 b, and then to x2.++So we carry an extra var->var substitution which we apply *before* looking up in the+reverse mapping.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+We have to be careful about shadowing.+For example, consider+        f = \x -> let y = x+x in+                      h = \x -> x+x+                  in ...++Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no+shadowing, but it doesn't any more (it proved too hard), so we clone as we go.+We can simply add clones to the substitution already described.+++Note [CSE for bindings]+~~~~~~~~~~~~~~~~~~~~~~~+Let-bindings have two cases, implemented by addBinding.++* SUBSTITUTE: applies when the RHS is a variable++     let x = y in ...(h x)....++  Here we want to extend the /substitution/ with x -> y, so that the+  (h x) in the body might CSE with an enclosing (let v = h y in ...).+  NB: the substitution maps InIds, so we extend the substitution with+      a binding for the original InId 'x'++  How can we have a variable on the RHS? Doesn't the simplifier inline them?++    - First, the original RHS might have been (g z) which has CSE'd+      with an enclosing (let y = g z in ...).  This is super-important.+      See #5996:+         x1 = C a b+         x2 = C x1 b+         y1 = C a b+         y2 = C y1 b+      Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to+      the substitution so that we can CSE the binding for y2.++    - Second, we use addBinding for case expression scrutinees too;+      see Note [CSE for case expressions]++* EXTEND THE REVERSE MAPPING: applies in all other cases++     let x = h y in ...(h y)...++  Here we want to extend the /reverse mapping (cs_map)/ so that+  we CSE the (h y) call to x.++  Note that we use EXTEND even for a trivial expression, provided it+  is not a variable or literal. In particular this /includes/ type+  applications. This can be important (#13156); e.g.+     case f @ Int of { r1 ->+     case f @ Int of { r2 -> ...+  Here we want to common-up the two uses of (f @ Int) so we can+  remove one of the case expressions.++  See also Note [Corner case for case expressions] for another+  reason not to use SUBSTITUTE for all trivial expressions.++Notice that+  - The SUBSTITUTE situation extends the substitution (cs_subst)+  - The EXTEND situation extends the reverse mapping (cs_map)++Notice also that in the SUBSTITUTE case we leave behind a binding+  x = y+even though we /also/ carry a substitution x -> y.  Can we just drop+the binding instead?  Well, not at top level! See Note [Top level and+postInlineUnconditionally] in GHC.Core.Op.Simplify.Utils; and in any+case CSE applies only to the /bindings/ of the program, and we leave+it to the simplifier to propate effects to the RULES. Finally, it+doesn't seem worth the effort to discard the nested bindings because+the simplifier will do it next.++Note [CSE for case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  case scrut_expr of x { ...alts... }+This is very like a strict let-binding+  let !x = scrut_expr in ...+So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a+result all the stuff under Note [CSE for bindings] applies directly.++For example:++* Trivial scrutinee+     f = \x -> case x of wild {+                 (a:as) -> case a of wild1 {+                             (p,q) -> ...(wild1:as)...++  Here, (wild1:as) is morally the same as (a:as) and hence equal to+  wild. But that's not quite obvious.  In the rest of the compiler we+  want to keep it as (wild1:as), but for CSE purpose that's a bad+  idea.++  By using addBinding we add the binding (wild1 -> a) to the substitution,+  which does exactly the right thing.++  (Notice this is exactly backwards to what the simplifier does, which+  is to try to replaces uses of 'a' with uses of 'wild1'.)++  This is the main reason that addBinding is called with a trivial rhs.++* Non-trivial scrutinee+     case (f x) of y { pat -> ...let z = f x in ... }++  By using addBinding we'll add (f x :-> y) to the cs_map, and+  thereby CSE the inner (f x) to y.++Note [CSE for INLINE and NOINLINE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are some subtle interactions of CSE with functions that the user+has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)+Consider++        yes :: Int  {-# NOINLINE yes #-}+        yes = undefined++        no :: Int   {-# NOINLINE no #-}+        no = undefined++        foo :: Int -> Int -> Int  {-# NOINLINE foo #-}+        foo m n = n++        {-# RULES "foo/no" foo no = id #-}++        bar :: Int -> Int+        bar = foo yes++We do not expect the rule to fire.  But if we do CSE, then we risk+getting yes=no, and the rule does fire.  Actually, it won't because+NOINLINE means that 'yes' will never be inlined, not even if we have+yes=no.  So that's fine (now; perhaps in the olden days, yes=no would+have substituted even if 'yes' was NOINLINE).++But we do need to take care.  Consider++        {-# NOINLINE bar #-}+        bar = <rhs>     -- Same rhs as foo++        foo = <rhs>++If CSE produces+        foo = bar+then foo will never be inlined to <rhs> (when it should be, if <rhs>+is small).  The conclusion here is this:++   We should not add+       <rhs> :-> bar+  to the CSEnv if 'bar' has any constraints on when it can inline;+  that is, if its 'activation' not always active.  Otherwise we+  might replace <rhs> by 'bar', and then later be unable to see that it+  really was <rhs>.++An except to the rule is when the INLINE pragma is not from the user, e.g. from+WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec+is then true.++Note that we do not (currently) do CSE on the unfolding stored inside+an Id, even if it is a 'stable' unfolding.  That means that when an+unfolding happens, it is always faithful to what the stable unfolding+originally was.++Note [CSE for stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   {-# Unf = Stable (\pq. build blah) #-}+   foo = x++Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.+(Turns out that this actually happens for the enumFromTo method of+the Integer instance of Enum in GHC.Enum.)  Suppose moreover that foo's+stable unfolding originates from an INLINE or INLINEABLE pragma on foo.+Then we obviously do NOT want to extend the substitution with (foo->x),+because we promised to inline foo as what the user wrote.  See similar Note+[Stable unfoldings and postInlineUnconditionally] in GHC.Core.Op.Simplify.Utils.++Nor do we want to change the reverse mapping. Suppose we have++   {-# Unf = Stable (\pq. build blah) #-}+   foo = <expr>+   bar = <expr>++There could conceivably be merit in rewriting the RHS of bar:+   bar = foo+but now bar's inlining behaviour will change, and importing+modules might see that.  So it seems dodgy and we don't do it.++Stable unfoldings are also created during worker/wrapper when we decide+that a function's definition is so small that it should always inline.+In this case we still want to do CSE (#13340). Hence the use of+isAnyInlinePragma rather than isStableUnfolding.++Note [Corner case for case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is another reason that we do not use SUBSTITUTE for+all trivial expressions. Consider+   case x |> co of (y::Array# Int) { ... }++We do not want to extend the substitution with (y -> x |> co); since y+is of unlifted type, this would destroy the let/app invariant if (x |>+co) was not ok-for-speculation.++But surely (x |> co) is ok-for-speculation, because it's a trivial+expression, and x's type is also unlifted, presumably.  Well, maybe+not if you are using unsafe casts.  I actually found a case where we+had+   (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)++Note [CSE for join points?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not be naive about join points in CSE:+   join j = e in+   if b then jump j else 1 + e+The expression (1 + jump j) is not good (see Note [Invariants on join points] in+GHC.Core). This seems to come up quite seldom, but it happens (first seen+compiling ppHtml in Haddock.Backends.Xhtml).++We could try and be careful by tracking which join points are still valid at+each subexpression, but since join points aren't allocated or shared, there's+less to gain by trying to CSE them. (#13219)++Note [Look inside join-point binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Another way how CSE for join points is tricky is++  let join foo x = (x, 42)+      join bar x = (x, 42)+  in … jump foo 1 … jump bar 2 …++naively, CSE would turn this into++  let join foo x = (x, 42)+      join bar = foo+  in … jump foo 1 … jump bar 2 …++but now bar is a join point that claims arity one, but its right-hand side+is not a lambda, breaking the join-point invariant (this was #15002).++So `cse_bind` must zoom past the lambdas of a join point (using+`collectNBinders`) and resume searching for CSE opportunities only in+the body of the join point.++Note [CSE for recursive bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f = \x ... f....+  g = \y ... g ...+where the "..." are identical.  Could we CSE them?  In full generality+with mutual recursion it's quite hard; but for self-recursive bindings+(which are very common) it's rather easy:++* Maintain a separate cs_rec_map, that maps+      (\f. (\x. ...f...) ) -> f+  Note the \f in the domain of the mapping!++* When we come across the binding for 'g', look up (\g. (\y. ...g...))+  Bingo we get a hit.  So we can replace the 'g' binding with+     g = f++We can't use cs_map for this, because the key isn't an expression of+the program; it's a kind of synthetic key for recursive bindings.+++************************************************************************+*                                                                      *+\section{Common subexpression}+*                                                                      *+************************************************************************+-}++cseProgram :: CoreProgram -> CoreProgram+cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)++cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind)+cseBind toplevel env (NonRec b e)+  = (env2, NonRec b2 e2)+  where+    (env1, b1)       = addBinder env b+    (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1++cseBind toplevel env (Rec [(in_id, rhs)])+  | noCSE in_id+  = (env1, Rec [(out_id, rhs')])++  -- See Note [CSE for recursive bindings]+  | Just previous <- lookupCSRecEnv env out_id rhs''+  , let previous' = mkTicks ticks previous+        out_id'   = delayInlining toplevel out_id+  = -- We have a hit in the recursive-binding cache+    (extendCSSubst env1 in_id previous', NonRec out_id' previous')++  | otherwise+  = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])++  where+    (env1, [out_id]) = addRecBinders env [in_id]+    rhs'  = cseExpr env1 rhs+    rhs'' = stripTicksE tickishFloatable rhs'+    ticks = stripTicksT tickishFloatable rhs'+    id_expr'  = varToCoreExpr out_id+    zapped_id = zapIdUsageInfo out_id++cseBind toplevel env (Rec pairs)+  = (env2, Rec pairs')+  where+    (env1, bndrs1) = addRecBinders env (map fst pairs)+    (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)++    do_one env (pr, b1) = cse_bind toplevel env pr b1++-- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer+-- to @in_id@ (@out_id@, created from addBinder or addRecBinders),+-- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd)+-- binding to the 'CSEnv', so that we attempt to CSE any expressions+-- which are equal to @out_rhs@.+cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))+cse_bind toplevel env (in_id, in_rhs) out_id+  | isTopLevel toplevel, exprIsTickedString in_rhs+      -- See Note [Take care with literal strings]+  = (env', (out_id', in_rhs))++  | Just arity <- isJoinId_maybe in_id+      -- See Note [Look inside join-point binders]+  = let (params, in_body) = collectNBinders arity in_rhs+        (env', params') = addBinders env params+        out_body = tryForCSE env' in_body+    in (env, (out_id, mkLams params' out_body))++  | otherwise+  = (env', (out_id'', out_rhs))+  where+    (env', out_id') = addBinding env in_id out_id out_rhs+    (cse_done, out_rhs) = try_for_cse env in_rhs+    out_id'' | cse_done  = delayInlining toplevel out_id'+             | otherwise = out_id'++delayInlining :: TopLevelFlag -> Id -> Id+-- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already+-- See Note [Delay inlining after CSE]+delayInlining top_lvl bndr+  | isTopLevel top_lvl+  , isAlwaysActive (idInlineActivation bndr)+  , idHasRules bndr  -- Only if the Id has some RULES,+                     -- which might otherwise get lost+       -- These rules are probably auto-generated specialisations,+       -- since Ids with manual rules usually have manually-inserted+       -- delayed inlining anyway+  = bndr `setInlineActivation` activeAfterInitial+  | otherwise+  = bndr++addBinding :: CSEnv                      -- Includes InId->OutId cloning+           -> InVar                      -- Could be a let-bound type+           -> OutId -> OutExpr           -- Processed binding+           -> (CSEnv, OutId)             -- Final env, final bndr+-- 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.+addBinding env in_id out_id rhs'+  | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)+  | noCSE in_id      = (env,                              out_id)+  | use_subst        = (extendCSSubst env in_id rhs',     out_id)+  | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)+  where+    id_expr'  = varToCoreExpr out_id+    zapped_id = zapIdUsageInfo out_id+       -- Putting the Id into the cs_map makes it possible that+       -- it'll become shared more than it is now, which would+       -- invalidate (the usage part of) its demand info.+       --    This caused #100218.+       -- Easiest thing is to zap the usage info; subsequently+       -- performing late demand-analysis will restore it.  Don't zap+       -- the strictness info; it's not necessary to do so, and losing+       -- it is bad for performance if you don't do late demand+       -- analysis++    -- Should we use SUBSTITUTE or EXTEND?+    -- See Note [CSE for bindings]+    use_subst = case rhs' of+                   Var {} -> True+                   _      -> False++-- | Given a binder `let x = e`, this function+-- determines whether we should add `e -> x` to the cs_map+noCSE :: InId -> Bool+noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&+            not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))+             -- See Note [CSE for INLINE and NOINLINE]+         || isAnyInlinePragma (idInlinePragma id)+             -- See Note [CSE for stable unfoldings]+         || isJoinId id+             -- See Note [CSE for join points?]+++{- Note [Take care with literal strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example:++  x = "foo"#+  y = "foo"#+  ...x...y...x...y....++We would normally turn this into:++  x = "foo"#+  y = x+  ...x...x...x...x....++But this breaks an invariant of Core, namely that the RHS of a top-level binding+of type Addr# must be a string literal, not another variable. See Note+[Core top-level string literals] in GHC.Core.++For this reason, we special case top-level bindings to literal strings and leave+the original RHS unmodified. This produces:++  x = "foo"#+  y = "foo"#+  ...x...x...x...x....++Now 'y' will be discarded as dead code, and we are done.++The net effect is that for the y-binding we want to+  - Use SUBSTITUTE, by extending the substitution with  y :-> x+  - but leave the original binding for y undisturbed++This is done by cse_bind.  I got it wrong the first time (#13367).++Note [Delay inlining after CSE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose (#15445) we have+   f,g :: Num a => a -> a+   f x = ...f (x-1).....+   g y = ...g (y-1) ....++and we make some specialisations of 'g', either automatically, or via+a SPECIALISE pragma.  Then CSE kicks in and notices that the RHSs of+'f' and 'g' are identical, so we get+   f x = ...f (x-1)...+   g = f+   {-# RULES g @Int _ = $sg #-}++Now there is terrible danger that, in an importing module, we'll inline+'g' before we have a chance to run its specialisation!++Solution: during CSE, after a "hit" in the CSE cache+  * when adding a binding+        g = f+  * for a top-level function g+  * and g has specialisation RULES+add a NOINLINE[2] activation to it, to ensure it's not inlined+right away.++Notes:+* Why top level only?  Because for nested bindings we are already past+  phase 2 and will never return there.++* Why "only if g has RULES"?  Because there is no point in+  doing this if there are no RULES; and other things being+  equal it delays optimisation to delay inlining (#17409)+++---- Historical note ---++This patch is simpler and more direct than an earlier+version:++  commit 2110738b280543698407924a16ac92b6d804dc36+  Author: Simon Peyton Jones <simonpj@microsoft.com>+  Date:   Mon Jul 30 13:43:56 2018 +0100++  Don't inline functions with RULES too early++We had to revert this patch because it made GHC itself slower.++Why? It delayed inlining of /all/ functions with RULES, and that was+very bad in TcFlatten.flatten_ty_con_app++* It delayed inlining of liftM+* That delayed the unravelling of the recursion in some dictionary+  bindings.+* That delayed some eta expansion, leaving+     flatten_ty_con_app = \x y. let <stuff> in \z. blah+* That allowed the float-out pass to put sguff between+  the \y and \z.+* And that permanently stopped eta expansion of the function,+  even once <stuff> was simplified.++-}++tryForCSE :: CSEnv -> InExpr -> OutExpr+tryForCSE env expr = snd (try_for_cse env expr)++try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr)+-- (False, e') => We did not CSE the entire expression,+--                but we might have CSE'd some sub-expressions,+--                yielding e'+--+-- (True, te') => We CSE'd the entire expression,+--                yielding the trivial expression te'+try_for_cse env expr+  | Just e <- lookupCSEnv env expr'' = (True,  mkTicks ticks e)+  | otherwise                        = (False, expr')+    -- The varToCoreExpr is needed if we have+    --   case e of xco { ...case e of yco { ... } ... }+    -- Then CSE will substitute yco -> xco;+    -- but these are /coercion/ variables+  where+    expr'  = cseExpr env expr+    expr'' = stripTicksE tickishFloatable expr'+    ticks  = stripTicksT tickishFloatable expr'+    -- We don't want to lose the source notes when a common sub+    -- expression gets eliminated. Hence we push all (!) of them on+    -- top of the replaced sub-expression. This is probably not too+    -- useful in practice, but upholds our semantics.++-- | Runs CSE on a single expression.+--+-- This entry point is not used in the compiler itself, but is provided+-- as a convenient entry point for users of the GHC API.+cseOneExpr :: InExpr -> OutExpr+cseOneExpr e = cseExpr env e+  where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }++cseExpr :: CSEnv -> InExpr -> OutExpr+cseExpr env (Type t)              = Type (substTy (csEnvSubst env) t)+cseExpr env (Coercion c)          = Coercion (substCo (csEnvSubst env) c)+cseExpr _   (Lit lit)             = Lit lit+cseExpr env (Var v)               = lookupSubst env v+cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)+cseExpr env (Tick t e)            = Tick t (cseExpr env e)+cseExpr env (Cast e co)           = Cast (tryForCSE env e) (substCo (csEnvSubst env) co)+cseExpr env (Lam b e)             = let (env', b') = addBinder env b+                                    in Lam b' (cseExpr env' e)+cseExpr env (Let bind e)          = let (env', bind') = cseBind NotTopLevel env bind+                                    in Let bind' (cseExpr env' e)+cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts++cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr+cseCase env scrut bndr ty alts+  = Case scrut1 bndr3 ty' $+    combineAlts alt_env (map cse_alt alts)+  where+    ty' = substTy (csEnvSubst env) ty+    scrut1 = tryForCSE env scrut++    bndr1 = zapIdOccInfo bndr+      -- Zapping the OccInfo is needed because the extendCSEnv+      -- in cse_alt may mean that a dead case binder+      -- becomes alive, and Lint rejects that+    (env1, bndr2)    = addBinder env bndr1+    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1+         -- addBinding: see Note [CSE for case expressions]++    con_target :: OutExpr+    con_target = lookupSubst alt_env bndr++    arg_tys :: [OutType]+    arg_tys = tyConAppArgs (idType bndr3)++    -- See Note [CSE for case alternatives]+    cse_alt (DataAlt con, args, rhs)+        = (DataAlt con, args', tryForCSE new_env rhs)+        where+          (env', args') = addBinders alt_env args+          new_env       = extendCSEnv env' con_expr con_target+          con_expr      = mkAltExpr (DataAlt con) args' arg_tys++    cse_alt (con, args, rhs)+        = (con, args', tryForCSE env' rhs)+        where+          (env', args') = addBinders alt_env args++combineAlts :: CSEnv -> [OutAlt] -> [OutAlt]+-- See Note [Combine case alternatives]+combineAlts env alts+  | (Just alt1, rest_alts) <- find_bndr_free_alt alts+  , (_,bndrs1,rhs1) <- alt1+  , let filtered_alts = filterOut (identical_alt rhs1) rest_alts+  , not (equalLength rest_alts filtered_alts)+  = ASSERT2( null bndrs1, ppr alts )+    (DEFAULT, [], rhs1) : filtered_alts++  | otherwise+  = alts+  where+    in_scope = substInScope (csEnvSubst env)++    find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt])+       -- The (Just alt) is a binder-free alt+       -- See Note [Combine case alts: awkward corner]+    find_bndr_free_alt []+      = (Nothing, [])+    find_bndr_free_alt (alt@(_,bndrs,_) : alts)+      | null bndrs = (Just alt, alts)+      | otherwise  = case find_bndr_free_alt alts of+                       (mb_bf, alts) -> (mb_bf, alt:alts)++    identical_alt rhs1 (_,_,rhs) = eqExpr in_scope rhs1 rhs+       -- Even if this alt has binders, they will have been cloned+       -- If any of these binders are mentioned in 'rhs', then+       -- 'rhs' won't compare equal to 'rhs1' (which is from an+       -- alt with no binders).++{- Note [CSE for case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   case e of x+            K1 y -> ....(K1 y)...+            K2   -> ....K2....++We definitely want to CSE that (K1 y) into just x.++But what about the lone K2?  At first you would think "no" because+turning K2 into 'x' increases the number of live variables.  But++* Turning K2 into x increases the chance of combining identical alts.+  Example      case xs of+                  (_:_) -> f xs+                  []    -> f []+  See #17901 and simplCore/should_compile/T17901 for more examples+  of this kind.++* The next run of the simplifier will turn 'x' back into K2, so we won't+  permanently bloat the free-var count.+++Note [Combine case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+combineAlts is just a more heavyweight version of the use of+combineIdenticalAlts in GHC.Core.Op.Simplify.Utils.prepareAlts.  The basic idea is+to transform++    DEFAULT -> e1+    K x     -> e1+    W y z   -> e2+===>+   DEFAULT -> e1+   W y z   -> e2++In the simplifier we use cheapEqExpr, because it is called a lot.+But here in CSE we use the full eqExpr.  After all, two alternatives usually+differ near the root, so it probably isn't expensive to compare the full+alternative.  It seems like the same kind of thing that CSE is supposed+to be doing, which is why I put it here.++I actually saw some examples in the wild, where some inlining made e1 too+big for cheapEqExpr to catch it.++Note [Combine case alts: awkward corner]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We would really like to check isDeadBinder on the binders in the+alternative.  But alas, the simplifer zaps occ-info on binders in case+alternatives; see Note [Case alternative occ info] in GHC.Core.Op.Simplify.++* One alternative (perhaps a good one) would be to do OccAnal+  just before CSE.  Then perhaps we could get rid of combineIdenticalAlts+  in the Simplifier, which might save work.++* Another would be for CSE to return free vars as it goes.++* But the current solution is to find a nullary alternative (including+  the DEFAULT alt, if any). This will not catch+      case x of+        A y   -> blah+        B z p -> blah+  where no alternative is nullary or DEFAULT.  But the current+  solution is at least cheap.+++************************************************************************+*                                                                      *+\section{The CSE envt}+*                                                                      *+************************************************************************+-}++data CSEnv+  = CS { cs_subst :: Subst  -- Maps InBndrs to OutExprs+            -- The substitution variables to+            -- /trivial/ OutExprs, not arbitrary expressions++       , cs_map   :: CoreMap OutExpr   -- The reverse mapping+            -- Maps a OutExpr to a /trivial/ OutExpr+            -- The key of cs_map is stripped of all Ticks++       , cs_rec_map :: CoreMap OutExpr+            -- See Note [CSE for recursive bindings]+       }++emptyCSEnv :: CSEnv+emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap+                , cs_subst = emptySubst }++lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr+lookupCSEnv (CS { cs_map = csmap }) expr+  = lookupCoreMap csmap expr++extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv+extendCSEnv cse expr triv_expr+  = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }+  where+    sexpr = stripTicksE tickishFloatable expr++extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv+-- See Note [CSE for recursive bindings]+extendCSRecEnv cse bndr expr triv_expr+  = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr }++lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr+-- See Note [CSE for recursive bindings]+lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr+  = lookupCoreMap csmap (Lam bndr expr)++csEnvSubst :: CSEnv -> Subst+csEnvSubst = cs_subst++lookupSubst :: CSEnv -> Id -> OutExpr+lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x++extendCSSubst :: CSEnv -> Id  -> CoreExpr -> CSEnv+extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }++-- | Add clones to the substitution to deal with shadowing.  See+-- Note [Shadowing] for more details.  You should call this whenever+-- you go under a binder.+addBinder :: CSEnv -> Var -> (CSEnv, Var)+addBinder cse v = (cse { cs_subst = sub' }, v')+                where+                  (sub', v') = substBndr (cs_subst cse) v++addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])+addBinders cse vs = (cse { cs_subst = sub' }, vs')+                where+                  (sub', vs') = substBndrs (cs_subst cse) vs++addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])+addRecBinders cse vs = (cse { cs_subst = sub' }, vs')+                where+                  (sub', vs') = substRecBndrs (cs_subst cse) vs
+ compiler/GHC/Core/Op/CallArity.hs view
@@ -0,0 +1,763 @@+--+-- Copyright (c) 2014 Joachim Breitner+--++module GHC.Core.Op.CallArity+    ( callArityAnalProgram+    , callArityRHS -- for testing+    ) where++import GhcPrelude++import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Driver.Session ( DynFlags )++import GHC.Types.Basic+import GHC.Core+import GHC.Types.Id+import GHC.Core.Arity ( typeArity )+import GHC.Core.Utils ( exprIsCheap, exprIsTrivial )+import UnVarGraph+import GHC.Types.Demand+import Util++import Control.Arrow ( first, second )+++{-+%************************************************************************+%*                                                                      *+              Call Arity Analysis+%*                                                                      *+%************************************************************************++Note [Call Arity: The goal]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++The goal of this analysis is to find out if we can eta-expand a local function,+based on how it is being called. The motivating example is this code,+which comes up when we implement foldl using foldr, and do list fusion:++    let go = \x -> let d = case ... of+                              False -> go (x+1)+                              True  -> id+                   in \z -> d (x + z)+    in go 1 0++If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of+partial function applications, which would be bad.++The function `go` has a type of arity two, but only one lambda is manifest.+Furthermore, an analysis that only looks at the RHS of go cannot be sufficient+to eta-expand go: If `go` is ever called with one argument (and the result used+multiple times), we would be doing the work in `...` multiple times.++So `callArityAnalProgram` looks at the whole let expression to figure out if+all calls are nice, i.e. have a high enough arity. It then stores the result in+the `calledArity` field of the `IdInfo` of `go`, which the next simplifier+phase will eta-expand.++The specification of the `calledArity` field is:++    No work will be lost if you eta-expand me to the arity in `calledArity`.++What we want to know for a variable+-----------------------------------++For every let-bound variable we'd like to know:+  1. A lower bound on the arity of all calls to the variable, and+  2. whether the variable is being called at most once or possible multiple+     times.++It is always ok to lower the arity, or pretend that there are multiple calls.+In particular, "Minimum arity 0 and possible called multiple times" is always+correct.+++What we want to know from an expression+---------------------------------------++In order to obtain that information for variables, we analyze expression and+obtain bits of information:++ I.  The arity analysis:+     For every variable, whether it is absent, or called,+     and if called, which what arity.++ II. The Co-Called analysis:+     For every two variables, whether there is a possibility that both are being+     called.+     We obtain as a special case: For every variables, whether there is a+     possibility that it is being called twice.++For efficiency reasons, we gather this information only for a set of+*interesting variables*, to avoid spending time on, e.g., variables from pattern matches.++The two analysis are not completely independent, as a higher arity can improve+the information about what variables are being called once or multiple times.++Note [Analysis I: The arity analysis]+------------------------------------++The arity analysis is quite straight forward: The information about an+expression is an+    VarEnv Arity+where absent variables are bound to Nothing and otherwise to a lower bound to+their arity.++When we analyze an expression, we analyze it with a given context arity.+Lambdas decrease and applications increase the incoming arity. Analysizing a+variable will put that arity in the environment. In lets or cases all the+results from the various subexpressions are lubed, which takes the point-wise+minimum (considering Nothing an infinity).+++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+we need to know which variables are possibly called together.++The data structure here is an undirected graph of variables, which is provided+by the abstract+    UnVarGraph++It is safe to return a larger graph, i.e. one with more edges. The worst case+(i.e. the least useful and always correct result) is the complete graph on all+free variables, which means that anything can be called together with anything+(including itself).++Notation for the following:+C(e)  is the co-called result for e.+G₁∪G₂ is the union of two graphs+fv    is the set of free variables (conveniently the domain of the arity analysis result)+S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ }+S²    is the complete graph on the set of variables S, S² = S×S+C'(e) is a variant for bound expression:+      If e is called at most once, or it is and stays a thunk (after the analysis),+      it is simply C(e). Otherwise, the expression can be called multiple times+      and we return (fv e)²++The interesting cases of the analysis:+ * Var v:+   No other variables are being called.+   Return {} (the empty graph)+ * Lambda v e, under arity 0:+   This means that e can be evaluated many times and we cannot get+   any useful co-call information.+   Return (fv e)²+ * Case alternatives alt₁,alt₂,...:+   Only one can be execuded, so+   Return (alt₁ ∪ alt₂ ∪...)+ * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂:+   We get the results from both sides, with the argument evaluated at most once.+   Additionally, anything called by e₁ can possibly be called with anything+   from e₂.+   Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂)+ * App e₁ x:+   As this is already in A-normal form, CorePrep will not separately lambda+   bind (and hence share) x. So we conservatively assume multiple calls to x here+   Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)}+ * Let v = rhs in body:+   In addition to the results from the subexpressions, add all co-calls from+   everything that the body calls together with v to everything that is called+   by v.+   Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)}+ * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body+   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].++   Let V = {v₁,...vₙ}.+   Assume that the vs have been analysed with an incoming demand and+   cardinality consistent with the final result (this is the fixed-pointing).+   Again we can use the results from all subexpressions.+   In addition, for every variable vᵢ, we need to find out what it is called+   with (call this set Sᵢ). There are two cases:+    * If vᵢ is a function, we need to go through all right-hand-sides and bodies,+      and collect every variable that is called together with any variable from V:+      Sᵢ = {v' | j ∈ {1,...,n},      {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }+    * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to+      exclude it from this set:+      Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }+   Finally, combine all this:+   Return: C(body) ∪+           C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪+           (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ)++Using the result: Eta-Expansion+-------------------------------++We use the result of these two analyses to decide whether we can eta-expand the+rhs of a let-bound variable.++If the variable is already a function (exprIsCheap), and all calls to the+variables have a higher arity than the current manifest arity (i.e. the number+of lambdas), expand.++If the variable is a thunk we must be careful: Eta-Expansion will prevent+sharing of work, so this is only safe if there is at most one call to the+function. Therefore, we check whether {v,v} ∈ G.++    Example:++        let n = case .. of .. -- A thunk!+        in n 0 + n 1++    vs.++        let n = case .. of ..+        in case .. of T -> n 0+                      F -> n 1++    We are only allowed to eta-expand `n` if it is going to be called at most+    once in the body of the outer let. So we need to know, for each variable+    individually, that it is going to be called at most once.+++Why the co-call graph?+----------------------++Why is it not sufficient to simply remember which variables are called once and+which are called multiple times? It would be in the previous example, but consider++        let n = case .. of ..+        in case .. of+            True -> let go = \y -> case .. of+                                     True -> go (y + n 1)+                                     False > n+                    in go 1+            False -> n++vs.++        let n = case .. of ..+        in case .. of+            True -> let go = \y -> case .. of+                                     True -> go (y+1)+                                     False > n+                    in go 1+            False -> n++In both cases, the body and the rhs of the inner let call n at most once.+But only in the second case that holds for the whole expression! The+crucial difference is that in the first case, the rhs of `go` can call+*both* `go` and `n`, and hence can call `n` multiple times as it recurses,+while in the second case find out that `go` and `n` are not called together.+++Why co-call information for functions?+--------------------------------------++Although for eta-expansion we need the information only for thunks, we still+need to know whether functions are being called once or multiple times, and+together with what other functions.++    Example:++        let n = case .. of ..+            f x = n (x+1)+        in f 1 + f 2++    vs.++        let n = case .. of ..+            f x = n (x+1)+        in case .. of T -> f 0+                      F -> f 1++    Here, the body of f calls n exactly once, but f itself is being called+    multiple times, so eta-expansion is not allowed.+++Note [Analysis type signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The work-hourse of the analysis is the function `callArityAnal`, with the+following type:++    type CallArityRes = (UnVarGraph, VarEnv Arity)+    callArityAnal ::+        Arity ->  -- The arity this expression is called with+        VarSet -> -- The set of interesting variables+        CoreExpr ->  -- The expression to analyse+        (CallArityRes, CoreExpr)++and the following specification:++  ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr++                            <=>++  Assume the expression `expr` is being passed `arity` arguments. Then it holds that+    * The domain of `callArityEnv` is a subset of `interestingIds`.+    * Any variable from `interestingIds` that is not mentioned in the `callArityEnv`+      is absent, i.e. not called at all.+    * Every call from `expr` to a variable bound to n in `callArityEnv` has at+      least n value arguments.+    * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`,+      then in no execution of `expr` both are being called.+  Furthermore, expr' is expr with the callArity field of the `IdInfo` updated.+++Note [Which variables are interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The analysis would quickly become prohibitive expensive if we would analyse all+variables; for most variables we simply do not care about how often they are+called, i.e. variables bound in a pattern match. So interesting are variables that are+ * top-level or let bound+ * and possibly functions (typeArity > 0)++Note [Taking boring variables into account]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++If we decide that the variable bound in `let x = e1 in e2` is not interesting,+the analysis of `e2` will not report anything about `x`. To ensure that+`callArityBind` does still do the right thing we have to take that into account+every time we would be lookup up `x` in the analysis result of `e2`.+  * Instead of calling lookupCallArityRes, we return (0, True), indicating+    that this variable might be called many times with no arguments.+  * Instead of checking `calledWith x`, we assume that everything can be called+    with it.+  * In the recursive case, when calclulating the `cross_calls`, if there is+    any boring variable in the recursive group, we ignore all co-call-results+    and directly go to a very conservative assumption.++The last point has the nice side effect that the relatively expensive+integration of co-call results in a recursive groups is often skipped. This+helped to avoid the compile time blowup in some real-world code with large+recursive groups (#10293).++Note [Recursion and fixpointing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++For a mutually recursive let, we begin by+ 1. analysing the body, using the same incoming arity as for the whole expression.+ 2. Then we iterate, memoizing for each of the bound variables the last+    analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes.+ 3. We combine the analysis result from the body and the memoized results for+    the arguments (if already present).+ 4. For each variable, we find out the incoming arity and whether it is called+    once, based on the current analysis result. If this differs from the+    memoized results, we re-analyse the rhs and update the memoized table.+ 5. If nothing had to be reanalyzed, we are done.+    Otherwise, repeat from step 3.+++Note [Thunks in recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We never eta-expand a thunk in a recursive group, on the grounds that if it is+part of a recursive group, then it will be called multiple times.++This is not necessarily true, e.g.  it would be safe to eta-expand t2 (but not+t1) in the following code:++  let go x = t1+      t1 = if ... then t2 else ...+      t2 = if ... then go 1 else ...+  in go 0++Detecting this would require finding out what variables are only ever called+from thunks. While this is certainly possible, we yet have to see this to be+relevant in the wild.+++Note [Analysing top-level binds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We can eta-expand top-level-binds if they are not exported, as we see all calls+to them. The plan is as follows: Treat the top-level binds as nested lets around+a body representing “all external calls”, which returns a pessimistic+CallArityRes (the co-call graph is the complete graph, all arityies 0).++Note [Trimming arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In the Call Arity papers, we are working on an untyped lambda calculus with no+other id annotations, where eta-expansion is always possible. But this is not+the case for Core!+ 1. We need to ensure the invariant+      callArity e <= typeArity (exprType e)+    for the same reasons that exprArity needs this invariant (see Note+    [exprArity invariant] in GHC.Core.Arity).++    If we are not doing that, a too-high arity annotation will be stored with+    the id, confusing the simplifier later on.++ 2. Eta-expanding a right hand side might invalidate existing annotations. In+    particular, if an id has a strictness annotation of <...><...>b, then+    passing two arguments to it will definitely bottom out, so the simplifier+    will throw away additional parameters. This conflicts with Call Arity! So+    we ensure that we never eta-expand such a value beyond the number of+    arguments mentioned in the strictness signature.+    See #10176 for a real-world-example.++Note [What is a thunk]+~~~~~~~~~~~~~~~~~~~~~~++Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a+thunk, not eta-expanded, to avoid losing any sharing. This is also how the+published papers on Call Arity describe it.++In practice, there are thunks that do a just little work, such as+pattern-matching on a variable, and the benefits of eta-expansion likely+outweigh the cost of doing that repeatedly. Therefore, this implementation of+Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk.++Note [Call Arity and Join Points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The Call Arity analysis does not care about join points, and treats them just+like normal functions. This is ok.++The analysis *could* make use of the fact that join points are always evaluated+in the same context as the join-binding they are defined in and are always+one-shot, and handle join points separately, as suggested in+https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870.+This *might* be more efficient (for example, join points would not have to be+considered interesting variables), but it would also add redundant code. So for+now we do not do that.++The simplifier never eta-expands join points (it instead pushes extra arguments from+an eta-expanded context into the join point’s RHS), so the call arity+annotation on join points is not actually used. As it would be equally valid+(though less efficient) to eta-expand join points, this is the simplifier's+choice, and hence Call Arity sets the call arity for join points as well.+-}++-- Main entry point++callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram+callArityAnalProgram _dflags binds = binds'+  where+    (_, binds') = callArityTopLvl [] emptyVarSet binds++-- See Note [Analysing top-level-binds]+callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])+callArityTopLvl exported _ []+    = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])+      , [] )+callArityTopLvl exported int1 (b:bs)+    = (ae2, b':bs')+  where+    int2 = bindersOf b+    exported' = filter isExportedId int2 ++ exported+    int' = int1 `addInterestingBinds` b+    (ae1, bs') = callArityTopLvl exported' int' bs+    (ae2, b')  = callArityBind (boringBinds b) ae1 int1 b+++callArityRHS :: CoreExpr -> CoreExpr+callArityRHS = snd . callArityAnal 0 emptyVarSet++-- The main analysis function. See Note [Analysis type signature]+callArityAnal ::+    Arity ->  -- The arity this expression is called with+    VarSet -> -- The set of interesting variables+    CoreExpr ->  -- The expression to analyse+    (CallArityRes, CoreExpr)+        -- How this expression uses its interesting variables+        -- and the expression with IdInfo updated++-- The trivial base cases+callArityAnal _     _   e@(Lit _)+    = (emptyArityRes, e)+callArityAnal _     _   e@(Type _)+    = (emptyArityRes, e)+callArityAnal _     _   e@(Coercion _)+    = (emptyArityRes, e)+-- The transparent cases+callArityAnal arity int (Tick t e)+    = second (Tick t) $ callArityAnal arity int e+callArityAnal arity int (Cast e co)+    = second (\e -> Cast e co) $ callArityAnal arity int e++-- The interesting case: Variables, Lambdas, Lets, Applications, Cases+callArityAnal arity int e@(Var v)+    | v `elemVarSet` int+    = (unitArityRes v arity, e)+    | otherwise+    = (emptyArityRes, e)++-- Non-value lambdas are ignored+callArityAnal arity int (Lam v e) | not (isId v)+    = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e++-- We have a lambda that may be called multiple times, so its free variables+-- can all be co-called.+callArityAnal 0     int (Lam v e)+    = (ae', Lam v e')+  where+    (ae, e') = callArityAnal 0 (int `delVarSet` v) e+    ae' = calledMultipleTimes ae+-- We have a lambda that we are calling. decrease arity.+callArityAnal arity int (Lam v e)+    = (ae, Lam v e')+  where+    (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e++-- Application. Increase arity for the called expression, nothing to know about+-- the second+callArityAnal arity int (App e (Type t))+    = second (\e -> App e (Type t)) $ callArityAnal arity int e+callArityAnal arity int (App e1 e2)+    = (final_ae, App e1' e2')+  where+    (ae1, e1') = callArityAnal (arity + 1) int e1+    (ae2, e2') = callArityAnal 0           int e2+    -- If the argument is trivial (e.g. a variable), then it will _not_ be+    -- let-bound in the Core to STG transformation (CorePrep actually),+    -- so no sharing will happen here, and we have to assume many calls.+    ae2' | exprIsTrivial e2 = calledMultipleTimes ae2+         | otherwise        = ae2+    final_ae = ae1 `both` ae2'++-- Case expression.+callArityAnal arity int (Case scrut bndr ty alts)+    = -- pprTrace "callArityAnal:Case"+      --          (vcat [ppr scrut, ppr final_ae])+      (final_ae, Case scrut' bndr ty alts')+  where+    (alt_aes, alts') = unzip $ map go alts+    go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e+                        in  (ae, (dc, bndrs, e'))+    alt_ae = lubRess alt_aes+    (scrut_ae, scrut') = callArityAnal 0 int scrut+    final_ae = scrut_ae `both` alt_ae++-- For lets, use callArityBind+callArityAnal arity int (Let bind e)+  = -- pprTrace "callArityAnal:Let"+    --          (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])+    (final_ae, Let bind' e')+  where+    int_body = int `addInterestingBinds` bind+    (ae_body, e') = callArityAnal arity int_body e+    (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind++-- Which bindings should we look at?+-- See Note [Which variables are interesting]+isInteresting :: Var -> Bool+isInteresting v = not $ null (typeArity (idType v))++interestingBinds :: CoreBind -> [Var]+interestingBinds = filter isInteresting . bindersOf++boringBinds :: CoreBind -> VarSet+boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf++addInterestingBinds :: VarSet -> CoreBind -> VarSet+addInterestingBinds int bind+    = int `delVarSetList`    bindersOf bind -- Possible shadowing+          `extendVarSetList` interestingBinds bind++-- Used for both local and top-level binds+-- Second argument is the demand from the body+callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)+-- Non-recursive let+callArityBind boring_vars ae_body int (NonRec v rhs)+  | otherwise+  = -- pprTrace "callArityBind:NonRec"+    --          (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]+    -- If v is boring, we will not find it in ae_body, but always assume (0, False)+    boring = v `elemVarSet` boring_vars++    (arity, called_once)+        | boring    = (0, False) -- See Note [Taking boring variables into account]+        | otherwise = lookupCallArityRes ae_body v+    safe_arity | called_once = arity+               | is_thunk    = 0      -- A thunk! Do not eta-expand+               | otherwise   = arity++    -- See Note [Trimming arity]+    trimmed_arity = trimArity v safe_arity++    (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs+++    ae_rhs'| called_once     = ae_rhs+           | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once+           | otherwise       = calledMultipleTimes ae_rhs++    called_by_v = domRes ae_rhs'+    called_with_v+        | boring    = domRes ae_body+        | otherwise = calledWith ae_body v `delUnVarSet` v+    final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body++    v' = v `setIdCallArity` trimmed_arity+++-- Recursive let. See Note [Recursion and fixpointing]+callArityBind boring_vars ae_body int b@(Rec binds)+  = -- (if length binds > 300 then+    -- pprTrace "callArityBind:Rec"+    --           (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $+    (final_ae, Rec binds')+  where+    -- See Note [Taking boring variables into account]+    any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds]++    int_body = int `addInterestingBinds` b+    (ae_rhs, binds') = fix initial_binds+    final_ae = bindersOf b `resDelList` ae_rhs++    initial_binds = [(i,Nothing,e) | (i,e) <- binds]++    fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)])+    fix ann_binds+        | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $+          any_change+        = fix ann_binds'+        | otherwise+        = (ae, map (\(i, _, e) -> (i, e)) ann_binds')+      where+        aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ]+        ae = callArityRecEnv any_boring aes_old ae_body++        rerun (i, mbLastRun, rhs)+            | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae)+            -- No call to this yet, so do nothing+            = (False, (i, Nothing, rhs))++            | Just (old_called_once, old_arity, _) <- mbLastRun+            , called_once == old_called_once+            , new_arity == old_arity+            -- No change, no need to re-analyze+            = (False, (i, mbLastRun, rhs))++            | 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]++                  safe_arity | is_thunk    = 0  -- See Note [Thunks in recursive groups]+                             | otherwise   = new_arity++                  -- See Note [Trimming arity]+                  trimmed_arity = trimArity i safe_arity++                  (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs++                  ae_rhs' | called_once     = ae_rhs+                          | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once+                          | otherwise       = calledMultipleTimes ae_rhs++                  i' = i `setIdCallArity` trimmed_arity++              in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs'))+          where+            -- See Note [Taking boring variables into account]+            (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False)+                                     | otherwise                  = lookupCallArityRes ae i++        (changes, ann_binds') = unzip $ map rerun ann_binds+        any_change = or changes++-- Combining the results from body and rhs, (mutually) recursive case+-- See Note [Analysis II: The Co-Called analysis]+callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes+callArityRecEnv any_boring ae_rhss ae_body+    = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $+      ae_new+  where+    vars = map fst ae_rhss++    ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body++    cross_calls+        -- See Note [Taking boring variables into account]+        | any_boring               = completeGraph (domRes ae_combined)+        -- Also, calculating cross_calls is expensive. Simply be conservative+        -- if the mutually recursive group becomes too large.+        | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined)+        | otherwise                = unionUnVarGraphs $ map cross_call ae_rhss+    cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v+      where+        is_thunk = idCallArity v == 0+        -- What rhs are relevant as happening before (or after) calling v?+        --    If v is a thunk, everything from all the _other_ variables+        --    If v is not a thunk, everything can happen.+        ae_before_v | is_thunk  = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body+                    | otherwise = ae_combined+        -- What do we want to know from these?+        -- Which calls can happen next to any recursive call.+        called_with_v+            = unionUnVarSets $ map (calledWith ae_before_v) vars+        called_by_v = domRes ae_rhs++    ae_new = first (cross_calls `unionUnVarGraph`) ae_combined++-- See Note [Trimming arity]+trimArity :: Id -> Arity -> Arity+trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]+  where+    max_arity_by_type = length (typeArity (idType v))+    max_arity_by_strsig+        | isBotDiv result_info = length demands+        | otherwise = a++    (demands, result_info) = splitStrictSig (idStrictness v)++---------------------------------------+-- Functions related to CallArityRes --+---------------------------------------++-- Result type for the two analyses.+-- See Note [Analysis I: The arity analysis]+-- and Note [Analysis II: The Co-Called analysis]+type CallArityRes = (UnVarGraph, VarEnv Arity)++emptyArityRes :: CallArityRes+emptyArityRes = (emptyUnVarGraph, emptyVarEnv)++unitArityRes :: Var -> Arity -> CallArityRes+unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity)++resDelList :: [Var] -> CallArityRes -> CallArityRes+resDelList vs ae = foldr resDel ae vs++resDel :: Var -> CallArityRes -> CallArityRes+resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v)++domRes :: CallArityRes -> UnVarSet+domRes (_, ae) = varEnvDom ae++-- In the result, find out the minimum arity and whether the variable is called+-- at most once.+lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)+lookupCallArityRes (g, ae) v+    = case lookupVarEnv ae v of+        Just a -> (a, not (g `hasLoopAt` v))+        Nothing -> (0, False)++calledWith :: CallArityRes -> Var -> UnVarSet+calledWith (g, _) v = neighbors g v++addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes+addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`)++-- Replaces the co-call graph by a complete graph (i.e. no information)+calledMultipleTimes :: CallArityRes -> CallArityRes+calledMultipleTimes res = first (const (completeGraph (domRes res))) res++-- Used for application and cases+both :: CallArityRes -> CallArityRes -> CallArityRes+both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2++-- Used when combining results from alternative cases; take the minimum+lubRes :: CallArityRes -> CallArityRes -> CallArityRes+lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2)++lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity+lubArityEnv = plusVarEnv_C min++lubRess :: [CallArityRes] -> CallArityRes+lubRess = foldl' lubRes emptyArityRes
+ compiler/GHC/Core/Op/CprAnal.hs view
@@ -0,0 +1,653 @@+{-# LANGUAGE CPP #-}++-- | Constructed Product Result analysis. Identifies functions that surely+-- return heap-allocated records on every code path, so that we can eliminate+-- said heap allocation by performing a worker/wrapper split.+--+-- See https://www.microsoft.com/en-us/research/publication/constructed-product-result-analysis-haskell/.+-- CPR analysis should happen after strictness analysis.+-- See Note [Phase ordering].+module GHC.Core.Op.CprAnal ( cprAnalProgram ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Driver.Session+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Core+import GHC.Core.Seq+import Outputable+import GHC.Types.Var.Env+import GHC.Types.Basic+import Data.List+import GHC.Core.DataCon+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram )+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.FamInstEnv+import GHC.Core.Op.WorkWrap.Lib+import Util+import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) )+import Maybes           ( isJust, isNothing )++{- Note [Constructed Product Result]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The goal of Constructed Product Result analysis is to identify functions that+surely return heap-allocated records on every code path, so that we can+eliminate said heap allocation by performing a worker/wrapper split.++@swap@ below is such a function:++  swap (a, b) = (b, a)++A @case@ on an application of @swap@, like+@case swap (10, 42) of (a, b) -> a + b@ could cancel away+(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then+say that @swap@ has the CPR property.++We can't inline recursive functions, but similar reasoning applies there:++  f x n = case n of+    0 -> (x, 0)+    _ -> f (x+1) (n-1)++Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed+product with the case. So @f@, too, has the CPR property. But we can't really+"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@+might be too big to inline (or even marked NOINLINE). We still want to exploit+the CPR property, and that is exactly what the worker/wrapper transformation+can do for us:++  $wf x n = case n of+    0 -> case (x, 0) of -> (a, b) -> (# a, b #)+    _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #)+  f x n = case $wf x n of (# a, b #) -> (a, b)++where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to:++  $wf x n = case n of+    0 -> (# x, 0 #)+    _ -> $wf (x+1) (n-1)++Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and+eliminate the heap-allocated pair constructor.++Note [Phase ordering]+~~~~~~~~~~~~~~~~~~~~~+We need to perform strictness analysis before CPR analysis, because that might+unbox some arguments, in turn leading to more constructed products.+Ideally, we would want the following pipeline:++1. Strictness+2. worker/wrapper (for strictness)+3. CPR+4. worker/wrapper (for CPR)++Currently, we omit 2. and anticipate the results of worker/wrapper.+See Note [CPR in a DataAlt case alternative]+and Note [CPR for binders that will be unboxed].+An additional w/w pass would simplify things, but probably add slight overhead.+So currently we have++1. Strictness+2. CPR+3. worker/wrapper (for strictness and CPR)+-}++--+-- * Analysing programs+--++cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram+cprAnalProgram dflags fam_envs binds = do+  let env            = emptyAnalEnv fam_envs+  let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds+  dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $+    dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr+  -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Op.DmdAnal+  seqBinds binds_plus_cpr `seq` return binds_plus_cpr++-- Analyse a (group of) top-level binding(s)+cprAnalTopBind :: AnalEnv+               -> CoreBind+               -> (AnalEnv, CoreBind)+cprAnalTopBind env (NonRec id rhs)+  = (extendAnalEnv env id' (idCprInfo id'), NonRec id' rhs')+  where+    (id', rhs') = cprAnalBind TopLevel env id rhs++cprAnalTopBind env (Rec pairs)+  = (env', Rec pairs')+  where+    (env', pairs') = cprFix TopLevel env pairs++--+-- * Analysing expressions+--++-- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from+-- "Constructed Product Result Analysis for Haskell"+cprAnal, cprAnal'+  :: AnalEnv+  -> CoreExpr            -- ^ expression to be denoted by a 'CprType'+  -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType'++cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $+                  cprAnal' env e++cprAnal' _ (Lit lit)     = (topCprType, Lit lit)+cprAnal' _ (Type ty)     = (topCprType, Type ty)      -- Doesn't happen, in fact+cprAnal' _ (Coercion co) = (topCprType, Coercion co)++cprAnal' env (Var var)   = (cprTransform env var, Var var)++cprAnal' env (Cast e co)+  = (cpr_ty, Cast e' co)+  where+    (cpr_ty, e') = cprAnal env e++cprAnal' env (Tick t e)+  = (cpr_ty, Tick t e')+  where+    (cpr_ty, e') = cprAnal env e++cprAnal' env (App fun (Type ty))+  = (fun_ty, App fun' (Type ty))+  where+    (fun_ty, fun') = cprAnal env fun++cprAnal' env (App fun arg)+  = (res_ty, App fun' arg')+  where+    (fun_ty, fun') = cprAnal env fun+    -- In contrast to DmdAnal, there is no useful (non-nested) CPR info to be+    -- had by looking into the CprType of arg.+    (_, arg')      = cprAnal env arg+    res_ty         = applyCprTy fun_ty++cprAnal' env (Lam var body)+  | isTyVar var+  , (body_ty, body') <- cprAnal env body+  = (body_ty, Lam var body')+  | otherwise+  = (lam_ty, Lam var body')+  where+    env'             = extendAnalEnvForDemand env var (idDemandInfo var)+    (body_ty, body') = cprAnal env' body+    lam_ty           = abstractCprTy body_ty++cprAnal' env (Case scrut case_bndr ty alts)+  = (res_ty, Case scrut' case_bndr ty alts')+  where+    (_, scrut')      = cprAnal env scrut+    -- Regardless whether scrut had the CPR property or not, the case binder+    -- certainly has it. See 'extendEnvForDataAlt'.+    (alt_tys, alts') = mapAndUnzip (cprAnalAlt env scrut case_bndr) alts+    res_ty           = foldl' lubCprType botCprType alt_tys++cprAnal' env (Let (NonRec id rhs) body)+  = (body_ty, Let (NonRec id' rhs') body')+  where+    (id', rhs')      = cprAnalBind NotTopLevel env id rhs+    env'             = extendAnalEnv env id' (idCprInfo id')+    (body_ty, body') = cprAnal env' body++cprAnal' env (Let (Rec pairs) body)+  = body_ty `seq` (body_ty, Let (Rec pairs') body')+  where+    (env', pairs')   = cprFix NotTopLevel env pairs+    (body_ty, body') = cprAnal env' body++cprAnalAlt+  :: AnalEnv+  -> CoreExpr -- ^ scrutinee+  -> Id       -- ^ case binder+  -> Alt Var  -- ^ current alternative+  -> (CprType, Alt Var)+cprAnalAlt env scrut case_bndr (con@(DataAlt dc),bndrs,rhs)+  -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative]+  = (rhs_ty, (con, bndrs, rhs'))+  where+    env_alt        = extendEnvForDataAlt env scrut case_bndr dc bndrs+    (rhs_ty, rhs') = cprAnal env_alt rhs+cprAnalAlt env _ _ (con,bndrs,rhs)+  = (rhs_ty, (con, bndrs, rhs'))+  where+    (rhs_ty, rhs') = cprAnal env rhs++--+-- * CPR transformer+--++cprTransform :: AnalEnv         -- ^ The analysis environment+             -> Id              -- ^ The function+             -> CprType         -- ^ The demand type of the function+cprTransform env id+  = -- pprTrace "cprTransform" (vcat [ppr id, ppr sig])+    sig+  where+    sig+      | isGlobalId id                   -- imported function or data con worker+      = getCprSig (idCprInfo id)+      | Just sig <- lookupSigEnv env id -- local let-bound+      = getCprSig sig+      | otherwise+      = topCprType++--+-- * Bindings+--++-- Recursive bindings+cprFix :: TopLevelFlag+       -> AnalEnv                            -- Does not include bindings for this binding+       -> [(Id,CoreExpr)]+       -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info++cprFix top_lvl env orig_pairs+  = loop 1 initial_pairs+  where+    bot_sig = mkCprSig 0 botCpr+    -- See Note [Initialising strictness] in GHC.Core.Op.DmdAnal+    initial_pairs | ae_virgin env = [(setIdCprInfo id bot_sig, rhs) | (id, rhs) <- orig_pairs ]+                  | otherwise     = orig_pairs++    -- The fixed-point varies the idCprInfo field of the binders, and terminates if that+    -- annotation does not change any more.+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])+    loop n pairs+      | found_fixpoint = (final_anal_env, pairs')+      | otherwise      = loop (n+1) pairs'+      where+        found_fixpoint    = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs+        first_round       = n == 1+        pairs'            = step first_round pairs+        final_anal_env    = extendAnalEnvs env (map fst pairs')++    step :: Bool -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]+    step first_round pairs = pairs'+      where+        -- In all but the first iteration, delete the virgin flag+        start_env | first_round = env+                  | otherwise   = nonVirgin env++        start = extendAnalEnvs start_env (map fst pairs)++        (_, pairs') = mapAccumL my_downRhs start pairs++        my_downRhs env (id,rhs)+          = (env', (id', rhs'))+          where+            (id', rhs') = cprAnalBind top_lvl env id rhs+            env'        = extendAnalEnv env id (idCprInfo id')++-- | Process the RHS of the binding for a sensible arity, add the CPR signature+-- to the Id, and augment the environment with the signature as well.+cprAnalBind+  :: TopLevelFlag+  -> AnalEnv+  -> Id+  -> CoreExpr+  -> (Id, CoreExpr)+cprAnalBind top_lvl env id rhs+  = (id', rhs')+  where+    (rhs_ty, rhs')  = cprAnal env rhs+    -- possibly trim thunk CPR info+    rhs_ty'+      -- See Note [CPR for thunks]+      | stays_thunk = trimCprTy rhs_ty+      -- See Note [CPR for sum types]+      | returns_sum = trimCprTy rhs_ty+      | otherwise   = rhs_ty+    -- See Note [Arity trimming for CPR signatures]+    sig             = mkCprSigForArity (idArity id) rhs_ty'+    id'             = setIdCprInfo id sig++    -- See Note [CPR for thunks]+    stays_thunk = is_thunk && not_strict+    is_thunk    = not (exprIsHNF rhs) && not (isJoinId id)+    not_strict  = not (isStrictDmd (idDemandInfo id))+    -- See Note [CPR for sum types]+    (_, ret_ty) = splitPiTys (idType id)+    not_a_prod  = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty)+    returns_sum = not (isTopLevel top_lvl) && not_a_prod++{- Note [Arity trimming for CPR signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Although it doesn't affect correctness of the analysis per se, we have to trim+CPR signatures to idArity. Here's what might happen if we don't:++  f x = if expensive+          then \y. Box y+          else \z. Box z+  g a b = f a b++The two lambdas will have a CPR type of @1m@ (so construct a product after+applied to one argument). Thus, @f@ will have a CPR signature of @2m@+(constructs a product after applied to two arguments).+But WW will never eta-expand @f@! In this case that would amount to possibly+duplicating @expensive@ work.++(Side note: Even if @f@'s 'idArity' happened to be 2, it would not do so, see+Note [Don't eta expand in w/w].)++So @f@ will not be worker/wrappered. But @g@ also inherited its CPR signature+from @f@'s, so it *will* be WW'd:++  f x = if expensive+          then \y. Box y+          else \z. Box z+  $wg a b = case f a b of Box x -> x+  g a b = Box ($wg a b)++And the case in @g@ can never cancel away, thus we introduced extra reboxing.+Hence we always trim the CPR signature of a binding to idArity.+-}++data AnalEnv+  = AE+  { ae_sigs   :: SigEnv+  -- ^ Current approximation of signatures for local ids+  , ae_virgin :: Bool+  -- ^ True only on every first iteration in a fixed-point+  -- iteration. See Note [Initialising strictness] in "DmdAnal"+  , ae_fam_envs :: FamInstEnvs+  -- ^ Needed when expanding type families and synonyms of product types.+  }++type SigEnv = VarEnv CprSig++instance Outputable AnalEnv where+  ppr (AE { ae_sigs = env, ae_virgin = virgin })+    = text "AE" <+> braces (vcat+         [ text "ae_virgin =" <+> ppr virgin+         , text "ae_sigs =" <+> ppr env ])++emptyAnalEnv :: FamInstEnvs -> AnalEnv+emptyAnalEnv fam_envs+  = AE+  { ae_sigs = emptyVarEnv+  , ae_virgin = True+  , ae_fam_envs = fam_envs+  }++-- | Extend an environment with the strictness IDs attached to the id+extendAnalEnvs :: AnalEnv -> [Id] -> AnalEnv+extendAnalEnvs env ids+  = env { ae_sigs = sigs' }+  where+    sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ]++extendAnalEnv :: AnalEnv -> Id -> CprSig -> AnalEnv+extendAnalEnv env id sig+  = env { ae_sigs = extendVarEnv (ae_sigs env) id sig }++lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig+lookupSigEnv env id = lookupVarEnv (ae_sigs env) id++nonVirgin :: AnalEnv -> AnalEnv+nonVirgin env = env { ae_virgin = False }++-- | A version of 'extendAnalEnv' for a binder of which we don't see the RHS+-- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders).+-- In this case, we can still look at their demand to attach CPR signatures+-- anticipating the unboxing done by worker/wrapper.+-- See Note [CPR for binders that will be unboxed].+extendAnalEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv+extendAnalEnvForDemand env id dmd+  | isId id+  , Just (_, DataConAppContext { dcac_dc = dc })+      <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd+  = extendAnalEnv env id (CprSig (conCprType (dataConTag dc)))+  | otherwise+  = env+  where+    -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE+    -- function, we just assume that we aren't. That flag is only relevant+    -- to Note [Do not unpack class dictionaries], the few unboxing+    -- opportunities on dicts it prohibits are probably irrelevant to CPR.+    has_inlineable_prag = False++extendEnvForDataAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv+-- See Note [CPR in a DataAlt case alternative]+extendEnvForDataAlt env scrut case_bndr dc bndrs+  = foldl' do_con_arg env' ids_w_strs+  where+    env' = extendAnalEnv env case_bndr (CprSig case_bndr_ty)++    ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc++    tycon          = dataConTyCon dc+    is_product     = isJust (isDataProductTyCon_maybe tycon)+    is_sum         = isJust (isDataSumTyCon_maybe tycon)+    case_bndr_ty+      | is_product || is_sum = conCprType  (dataConTag dc)+      -- Any of the constructors had existentials. This is a little too+      -- conservative (after all, we only care about the particular data con),+      -- but there is no easy way to write is_sum and this won't happen much.+      | otherwise            = topCprType++    -- We could have much deeper CPR info here with Nested CPR, which could+    -- propagate available unboxed things from the scrutinee, getting rid of+    -- the is_var_scrut heuristic. See Note [CPR in a DataAlt case alternative].+    -- Giving strict binders the CPR property only makes sense for products, as+    -- the arguments in Note [CPR for binders that will be unboxed] don't apply+    -- to sums (yet); we lack WW for strict binders of sum type.+    do_con_arg env (id, str)+       | is_var scrut+       -- See Note [Add demands for strict constructors] in WorkWrap.Lib+       , let dmd = applyWhen (isMarkedStrict str) strictifyDmd (idDemandInfo id)+       = extendAnalEnvForDemand env id dmd+       | otherwise+       = env++    is_var (Cast e _) = is_var e+    is_var (Var v)    = isLocalId v+    is_var _          = False++{- Note [Safe abortion in the fixed-point iteration]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Fixed-point iteration may fail to terminate. But we cannot simply give up and+return the environment and code unchanged! We still need to do one additional+round, to ensure that all expressions have been traversed at least once, and any+unsound CPR annotations have been updated.++Note [CPR in a DataAlt case alternative]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a case alternative, we want to give some of the binders the CPR property.+Specifically++ * The case binder; inside the alternative, the case binder always has+   the CPR property, meaning that a case on it will successfully cancel.+   Example:+        f True  x = case x of y { I# x' -> if x' ==# 3+                                           then y+                                           else I# 8 }+        f False x = I# 3++   By giving 'y' the CPR property, we ensure that 'f' does too, so we get+        f b x = case fw b x of { r -> I# r }+        fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }+        fw False x = 3++   Of course there is the usual risk of re-boxing: we have 'x' available+   boxed and unboxed, but we return the unboxed version for the wrapper to+   box.  If the wrapper doesn't cancel with its caller, we'll end up+   re-boxing something that we did have available in boxed form.++ * Any strict binders with product type, can use+   Note [CPR for binders that will be unboxed]+   to anticipate worker/wrappering for strictness info.+   But we can go a little further. Consider++      data T = MkT !Int Int++      f2 (MkT x y) | y>0       = f2 (MkT x (y-1))+                   | otherwise = x++   For $wf2 we are going to unbox the MkT *and*, since it is strict, the+   first argument of the MkT; see Note [Add demands for strict constructors].+   But then we don't want box it up again when returning it!  We want+   'f2' to have the CPR property, so we give 'x' the CPR property.++ * It's a bit delicate because we're brittly anticipating worker/wrapper here.+   If the case above is scrutinising something other than an argument the+   original function, we really don't have the unboxed version available.  E.g+      g v = case foo v of+              MkT x y | y>0       -> ...+                      | otherwise -> x+   Here we don't have the unboxed 'x' available.  Hence the+   is_var_scrut test when making use of the strictness annotation.+   Slightly ad-hoc, because even if the scrutinee *is* a variable it+   might not be a onre of the arguments to the original function, or a+   sub-component thereof.  But it's simple, and nothing terrible+   happens if we get it wrong.  e.g. Trac #10694.++Note [CPR for binders that will be unboxed]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a lambda-bound variable will be unboxed by worker/wrapper (so it must be+demanded strictly), then give it a CPR signature. Here's a concrete example+('f1' in test T10482a), assuming h is strict:++  f1 :: Int -> Int+  f1 x = case h x of+          A -> x+          B -> f1 (x-1)+          C -> x+1++If we notice that 'x' is used strictly, we can give it the CPR+property; and hence f1 gets the CPR property too.  It's sound (doesn't+change strictness) to give it the CPR property because by the time 'x'+is returned (case A above), it'll have been evaluated (by the wrapper+of 'h' in the example).++Moreover, if f itself is strict in x, then we'll pass x unboxed to+f1, and so the boxed version *won't* be available; in that case it's+very helpful to give 'x' the CPR property.++Note that++  * We only want to do this for something that definitely+    has product type, else we may get over-optimistic CPR results+    (e.g. from \x -> x!).++  * This also (approximately) applies to DataAlt field binders;+    See Note [CPR in a DataAlt case alternative].++  * See Note [CPR examples]++Note [CPR for sum types]+~~~~~~~~~~~~~~~~~~~~~~~~+At the moment we do not do CPR for let-bindings that+   * non-top level+   * bind a sum type+Reason: I found that in some benchmarks we were losing let-no-escapes,+which messed it all up.  Example+   let j = \x. ....+   in case y of+        True  -> j False+        False -> j True+If we w/w this we get+   let j' = \x. ....+   in case y of+        True  -> case j' False of { (# a #) -> Just a }+        False -> case j' True of { (# a #) -> Just a }+Notice that j' is not a let-no-escape any more.++However this means in turn that the *enclosing* function+may be CPR'd (via the returned Justs).  But in the case of+sums, there may be Nothing alternatives; and that messes+up the sum-type CPR.++Conclusion: only do this for products.  It's still not+guaranteed OK for products, but sums definitely lose sometimes.++Note [CPR for thunks]+~~~~~~~~~~~~~~~~~~~~~+If the rhs is a thunk, we usually forget the CPR info, because+it is presumably shared (else it would have been inlined, and+so we'd lose sharing if w/w'd it into a function).  E.g.++        let r = case expensive of+                  (a,b) -> (b,a)+        in ...++If we marked r as having the CPR property, then we'd w/w into++        let $wr = \() -> case expensive of+                            (a,b) -> (# b, a #)+            r = case $wr () of+                  (# b,a #) -> (b,a)+        in ...++But now r is a thunk, which won't be inlined, so we are no further ahead.+But consider++        f x = let r = case expensive of (a,b) -> (b,a)+              in if foo r then r else (x,x)++Does f have the CPR property?  Well, no.++However, if the strictness analyser has figured out (in a previous+iteration) that it's strict, then we DON'T need to forget the CPR info.+Instead we can retain the CPR info and do the thunk-splitting transform+(see WorkWrap.splitThunk).++This made a big difference to PrelBase.modInt, which had something like+        modInt = \ x -> let r = ... -> I# v in+                        ...body strict in r...+r's RHS isn't a value yet; but modInt returns r in various branches, so+if r doesn't have the CPR property then neither does modInt+Another case I found in practice (in Complex.magnitude), looks like this:+                let k = if ... then I# a else I# b+                in ... body strict in k ....+(For this example, it doesn't matter whether k is returned as part of+the overall result; but it does matter that k's RHS has the CPR property.)+Left to itself, the simplifier will make a join point thus:+                let $j k = ...body strict in k...+                if ... then $j (I# a) else $j (I# b)+With thunk-splitting, we get instead+                let $j x = let k = I#x in ...body strict in k...+                in if ... then $j a else $j b+This is much better; there's a good chance the I# won't get allocated.++But what about botCpr? Consider+    lvl = error "boom"+    fac -1 = lvl+    fac 0 = 1+    fac n = n * fac (n-1)+fac won't have the CPR property here when we trim every thunk! But the+assumption is that error cases are rarely entered and we are diverging anyway,+so WW doesn't hurt.++Note [CPR examples]+~~~~~~~~~~~~~~~~~~~~+Here are some examples (stranal/should_compile/T10482a) of the+usefulness of Note [CPR in a DataAlt case alternative].  The main+point: all of these functions can have the CPR property.++    ------- f1 -----------+    -- x is used strictly by h, so it'll be available+    -- unboxed before it is returned in the True branch++    f1 :: Int -> Int+    f1 x = case h x x of+            True  -> x+            False -> f1 (x-1)++    ------- f3 -----------+    -- h is strict in x, so x will be unboxed before it+    -- is rerturned in the otherwise case.++    data T3 = MkT3 Int Int++    f1 :: T3 -> Int+    f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))+                  | otherwise = x+-}
+ compiler/GHC/Core/Op/DmdAnal.hs view
@@ -0,0 +1,1259 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++                        -----------------+                        A demand analysis+                        -----------------+-}++{-# LANGUAGE CPP #-}++module GHC.Core.Op.DmdAnal ( dmdAnalProgram ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Driver.Session+import GHC.Core.Op.WorkWrap.Lib ( findTypeShape )+import GHC.Types.Demand   -- All of it+import GHC.Core+import GHC.Core.Seq     ( seqBinds )+import Outputable+import GHC.Types.Var.Env+import GHC.Types.Basic+import Data.List        ( mapAccumL )+import GHC.Core.DataCon+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core.Utils+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.Coercion ( Coercion, coVarsOfCo )+import GHC.Core.FamInstEnv+import Util+import Maybes           ( isJust )+import TysWiredIn+import TysPrim          ( realWorldStatePrimTy )+import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) )+import GHC.Types.Unique.Set++{-+************************************************************************+*                                                                      *+\subsection{Top level stuff}+*                                                                      *+************************************************************************+-}++dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram+dmdAnalProgram dflags fam_envs binds = do+  let env             = emptyAnalEnv dflags fam_envs+  let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds+  dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $+    dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds+  -- See Note [Stamp out space leaks in demand analysis]+  seqBinds binds_plus_dmds `seq` return binds_plus_dmds++-- Analyse a (group of) top-level binding(s)+dmdAnalTopBind :: AnalEnv+               -> CoreBind+               -> (AnalEnv, CoreBind)+dmdAnalTopBind env (NonRec id rhs)+  = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs')+  where+    ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs++dmdAnalTopBind env (Rec pairs)+  = (env', Rec pairs')+  where+    (env', _, pairs')  = dmdFix TopLevel env cleanEvalDmd pairs+                -- We get two iterations automatically+                -- c.f. the NonRec case above++{- Note [Stamp out space leaks in demand analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand analysis pass outputs a new copy of the Core program in+which binders have been annotated with demand and strictness+information. It's tiresome to ensure that this information is fully+evaluated everywhere that we produce it, so we just run a single+seqBinds over the output before returning it, to ensure that there are+no references holding on to the input Core program.++This makes a ~30% reduction in peak memory usage when compiling+DynFlags (cf #9675 and #13426).++This is particularly important when we are doing late demand analysis,+since we don't do a seqBinds at any point thereafter. Hence code+generation would hold on to an extra copy of the Core program, via+unforced thunks in demand or strictness information; and it is the+most memory-intensive part of the compilation process, so this added+seqBinds makes a big difference in peak memory usage.+-}+++{-+************************************************************************+*                                                                      *+\subsection{The analyser itself}+*                                                                      *+************************************************************************++Note [Ensure demand is strict]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important not to analyse e with a lazy demand because+a) When we encounter   case s of (a,b) ->+        we demand s with U(d1d2)... but if the overall demand is lazy+        that is wrong, and we'd need to reduce the demand on s,+        which is inconvenient+b) More important, consider+        f (let x = R in x+x), where f is lazy+   We still want to mark x as demanded, because it will be when we+   enter the let.  If we analyse f's arg with a Lazy demand, we'll+   just mark x as Lazy+c) The application rule wouldn't be right either+   Evaluating (f x) in a L demand does *not* cause+   evaluation of f in a C(L) demand!+-}++-- If e is complicated enough to become a thunk, its contents will be evaluated+-- at most once, so oneify it.+dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand+dmdTransformThunkDmd e+  | exprIsTrivial e = id+  | otherwise       = oneifyDmd++-- Do not process absent demands+-- Otherwise act like in a normal demand analysis+-- See ↦* relation in the Cardinality Analysis paper+dmdAnalStar :: AnalEnv+            -> Demand   -- This one takes a *Demand*+            -> CoreExpr -- Should obey the let/app invariant+            -> (BothDmdArg, CoreExpr)+dmdAnalStar env dmd e+  | (dmd_shell, cd) <- toCleanDmd dmd+  , (dmd_ty, e')    <- dmdAnal env cd e+  = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )+    -- The argument 'e' should satisfy the let/app invariant+    -- See Note [Analysing with absent demand] in GHC.Types.Demand+    (postProcessDmdType dmd_shell dmd_ty, e')++-- Main Demand Analsysis machinery+dmdAnal, dmdAnal' :: AnalEnv+        -> CleanDemand         -- The main one takes a *CleanDemand*+        -> CoreExpr -> (DmdType, CoreExpr)++-- The CleanDemand is always strict and not absent+--    See Note [Ensure demand is strict]++dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $+                  dmdAnal' env d e++dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)+dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact+dmdAnal' _ _ (Coercion co)+  = (unitDmdType (coercionDmdEnv co), Coercion co)++dmdAnal' env dmd (Var var)+  = (dmdTransform env var dmd, Var var)++dmdAnal' env dmd (Cast e co)+  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)+  where+    (dmd_ty, e') = dmdAnal env dmd e++dmdAnal' env dmd (Tick t e)+  = (dmd_ty, Tick t e')+  where+    (dmd_ty, e') = dmdAnal env dmd e++dmdAnal' env dmd (App fun (Type ty))+  = (fun_ty, App fun' (Type ty))+  where+    (fun_ty, fun') = dmdAnal env dmd fun++-- Lots of the other code is there to make this+-- beautiful, compositional, application rule :-)+dmdAnal' env dmd (App fun arg)+  = -- This case handles value arguments (type args handled above)+    -- Crucially, coercions /are/ handled here, because they are+    -- value arguments (#10288)+    let+        call_dmd          = mkCallDmd dmd+        (fun_ty, fun')    = dmdAnal env call_dmd fun+        (arg_dmd, res_ty) = splitDmdTy fun_ty+        (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg+    in+--    pprTrace "dmdAnal:app" (vcat+--         [ text "dmd =" <+> ppr dmd+--         , text "expr =" <+> ppr (App fun arg)+--         , text "fun dmd_ty =" <+> ppr fun_ty+--         , text "arg dmd =" <+> ppr arg_dmd+--         , text "arg dmd_ty =" <+> ppr arg_ty+--         , text "res dmd_ty =" <+> ppr res_ty+--         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])+    (res_ty `bothDmdType` arg_ty, App fun' arg')++dmdAnal' env dmd (Lam var body)+  | isTyVar var+  = let+        (body_ty, body') = dmdAnal env dmd body+    in+    (body_ty, Lam var body')++  | otherwise+  = let (body_dmd, defer_and_use) = peelCallDmd dmd+          -- body_dmd: a demand to analyze the body++        (body_ty, body') = dmdAnal env body_dmd body+        (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var+    in+    (postProcessUnsat defer_and_use lam_ty, Lam var' body')++dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])+  -- Only one alternative with a product constructor+  | let tycon = dataConTyCon dc+  , isJust (isDataProductTyCon_maybe tycon)+  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon+  = let+        env_alt                  = env { ae_rec_tc = rec_tc' }+        (rhs_ty, rhs')           = dmdAnal env_alt dmd rhs+        (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs+        (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr+        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds+        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2+                | otherwise                   = alt_ty2++        -- Compute demand on the scrutinee+        -- See Note [Demand on scrutinee of a product case]+        scrut_dmd          = mkProdDmd id_dmds+        (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut+        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty+        case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd+        bndrs'             = setBndrsDemandInfo bndrs id_dmds+    in+--    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut+--                                   , text "dmd" <+> ppr dmd+--                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')+--                                   , text "id_dmds" <+> ppr id_dmds+--                                   , text "scrut_dmd" <+> ppr scrut_dmd+--                                   , text "scrut_ty" <+> ppr scrut_ty+--                                   , text "alt_ty" <+> ppr alt_ty2+--                                   , text "res_ty" <+> ppr res_ty ]) $+    (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])++dmdAnal' env dmd (Case scrut case_bndr ty alts)+  = let      -- Case expression with multiple alternatives+        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts+        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut+        (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr+                               -- NB: Base case is botDmdType, for empty case alternatives+                               --     This is a unit for lubDmdType, and the right result+                               --     when there really are no alternatives+        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty+    in+--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut+--                                   , text "scrut_ty" <+> ppr scrut_ty+--                                   , text "alt_tys" <+> ppr alt_tys+--                                   , text "alt_ty" <+> ppr alt_ty+--                                   , text "res_ty" <+> ppr res_ty ]) $+    (res_ty, Case scrut' case_bndr' ty alts')++-- Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- The following case handle the up variant.+--+-- It is very simple. For  let x = rhs in body+--   * Demand-analyse 'body' in the current environment+--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'+--   * Demand-analyse 'rhs' in 'rhs_dmd'+--+-- This is used for a non-recursive local let without manifest lambdas.+-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnal' env dmd (Let (NonRec id rhs) body)+  | useLetUp id+  = (final_ty, Let (NonRec id' rhs') body')+  where+    (body_ty, body')   = dmdAnal env dmd body+    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id+    id'                = setIdDemandInfo id id_dmd++    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs+    final_ty           = body_ty' `bothDmdType` rhs_ty++dmdAnal' env dmd (Let (NonRec id rhs) body)+  = (body_ty2, Let (NonRec id2 rhs') body')+  where+    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs+    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)+    (body_ty, body')     = dmdAnal env1 dmd body+    (body_ty1, id2)      = annotateBndr env body_ty id1+    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]++        -- If the actual demand is better than the vanilla call+        -- demand, you might think that we might do better to re-analyse+        -- the RHS with the stronger demand.+        -- But (a) That seldom happens, because it means that *every* path in+        --         the body of the let has to use that stronger demand+        -- (b) It often happens temporarily in when fixpointing, because+        --     the recursive function at first seems to place a massive demand.+        --     But we don't want to go to extra work when the function will+        --     probably iterate to something less demanding.+        -- In practice, all the times the actual demand on id2 is more than+        -- the vanilla call demand seem to be due to (b).  So we don't+        -- bother to re-analyse the RHS.++dmdAnal' env dmd (Let (Rec pairs) body)+  = let+        (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs+        (body_ty, body')        = dmdAnal env' dmd body+        body_ty1                = deleteFVs body_ty (map fst pairs)+        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]+    in+    body_ty2 `seq`+    (body_ty2,  Let (Rec pairs') body')++io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool+-- See Note [IO hack in the demand analyser]+io_hack_reqd scrut con bndrs+  | (bndr:_) <- bndrs+  , con == tupleDataCon Unboxed 2+  , idType bndr `eqType` realWorldStatePrimTy+  , (fun, _) <- collectArgs scrut+  = case fun of+      Var f -> not (isPrimOpId f)+      _     -> True+  | otherwise+  = False++dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)+dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)+  | null bndrs    -- Literals, DEFAULT, and nullary constructors+  , (rhs_ty, rhs') <- dmdAnal env dmd rhs+  = (rhs_ty, (con, [], rhs'))++  | otherwise     -- Non-nullary data constructors+  , (rhs_ty, rhs') <- dmdAnal env dmd rhs+  , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs+  , let case_bndr_dmd = findIdDemand alt_ty case_bndr+        id_dmds       = addCaseBndrDmd case_bndr_dmd dmds+  = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))+++{- Note [IO hack in the demand analyser]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a hack here for I/O operations.  Consider++     case foo x s of { (# s', r #) -> y }++Is this strict in 'y'? Often not! If foo x s performs some observable action+(including raising an exception with raiseIO#, modifying a mutable variable, or+even ending the program normally), then we must not force 'y' (which may fail+to terminate) until we have performed foo x s.++Hackish solution: spot the IO-like situation and add a virtual branch,+as if we had+     case foo x s of+        (# s, r #) -> y+        other      -> return ()+So the 'y' isn't necessarily going to be evaluated++A more complete example (#148, #1592) where this shows up is:+     do { let len = <expensive> ;+        ; when (...) (exitWith ExitSuccess)+        ; print len }++However, consider+  f x s = case getMaskingState# s of+            (# s, r #) ->+          case x of I# x2 -> ...++Here it is terribly sad to make 'f' lazy in 's'.  After all,+getMaskingState# is not going to diverge or throw an exception!  This+situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle+(on an MVar not an Int), and made a material difference.++So if the scrutinee is a primop call, we *don't* apply the+state hack:+  - If it is a simple, terminating one like getMaskingState,+    applying the hack is over-conservative.+  - If the primop is raise# then it returns bottom, so+    the case alternatives are already discarded.+  - If the primop can raise a non-IO exception, like+    divide by zero or seg-fault (eg writing an array+    out of bounds) then we don't mind evaluating 'x' first.++Note [Demand on the scrutinee of a product case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When figuring out the demand on the scrutinee of a product case,+we use the demands of the case alternative, i.e. id_dmds.+But note that these include the demand on the case binder;+see Note [Demand on case-alternative binders] in GHC.Types.Demand.+This is crucial. Example:+   f x = case x of y { (a,b) -> k y a }+If we just take scrut_demand = U(L,A), then we won't pass x to the+worker, so the worker will rebuild+     x = (a, absent-error)+and that'll crash.++Note [Aggregated demand for cardinality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use different strategies for strictness and usage/cardinality to+"unleash" demands captured on free variables by bindings. Let us+consider the example:++f1 y = let {-# NOINLINE h #-}+           h = y+       in  (h, h)++We are interested in obtaining cardinality demand U1 on |y|, as it is+used only in a thunk, and, therefore, is not going to be updated any+more. Therefore, the demand on |y|, captured and unleashed by usage of+|h| is U1. However, if we unleash this demand every time |h| is used,+and then sum up the effects, the ultimate demand on |y| will be U1 ++U1 = U. In order to avoid it, we *first* collect the aggregate demand+on |h| in the body of let-expression, and only then apply the demand+transformer:++transf[x](U) = {y |-> U1}++so the resulting demand on |y| is U1.++The situation is, however, different for strictness, where this+aggregating approach exhibits worse results because of the nature of+|both| operation for strictness. Consider the example:++f y c =+  let h x = y |seq| x+   in case of+        True  -> h True+        False -> y++It is clear that |f| is strict in |y|, however, the suggested analysis+will infer from the body of |let| that |h| is used lazily (as it is+used in one branch only), therefore lazy demand will be put on its+free variable |y|. Conversely, if the demand on |h| is unleashed right+on the spot, we will get the desired result, namely, that |f| is+strict in |y|.+++************************************************************************+*                                                                      *+                    Demand transformer+*                                                                      *+************************************************************************+-}++dmdTransform :: AnalEnv         -- The strictness environment+             -> Id              -- The function+             -> CleanDemand     -- The demand on the function+             -> DmdType         -- The demand type of the function in this context+        -- Returned DmdEnv includes the demand on+        -- this function plus demand on its free variables++dmdTransform env var dmd+  | isDataConWorkId var                          -- Data constructor+  = dmdTransformDataConSig (idArity var) (idStrictness var) dmd++  | gopt Opt_DmdTxDictSel (ae_dflags env),+    Just _ <- isClassOpId_maybe var -- Dictionary component selector+  = dmdTransformDictSelSig (idStrictness var) dmd++  | isGlobalId var                               -- Imported function+  , let res = dmdTransformSig (idStrictness var) dmd+  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])+    res++  | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing+  , let fn_ty = dmdTransformSig sig dmd+  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $+    if isTopLevel top_lvl+    then fn_ty   -- Don't record top level things+    else addVarDmd fn_ty var (mkOnceUsedDmd dmd)++  | otherwise                                    -- Local non-letrec-bound thing+  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))++{-+************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++-- Recursive bindings+dmdFix :: TopLevelFlag+       -> AnalEnv                            -- Does not include bindings for this binding+       -> CleanDemand+       -> [(Id,CoreExpr)]+       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info++dmdFix top_lvl env let_dmd orig_pairs+  = loop 1 initial_pairs+  where+    bndrs = map fst orig_pairs++    -- See Note [Initialising strictness]+    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]+                  | otherwise     = orig_pairs++    -- If fixed-point iteration does not yield a result we use this instead+    -- See Note [Safe abortion in the fixed-point iteration]+    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])+    abort = (env, lazy_fv', zapped_pairs)+      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)+            -- Note [Lazy and unleashable free variables]+            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'+            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs+            zapped_pairs = zapIdStrictness pairs'++    -- The fixed-point varies the idStrictness field of the binders, and terminates if that+    -- annotation does not change any more.+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])+    loop n pairs+      | found_fixpoint = (final_anal_env, lazy_fv, pairs')+      | n == 10        = abort+      | otherwise      = loop (n+1) pairs'+      where+        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs+        first_round       = n == 1+        (lazy_fv, pairs') = step first_round pairs+        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')++    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])+    step first_round pairs = (lazy_fv, pairs')+      where+        -- In all but the first iteration, delete the virgin flag+        start_env | first_round = env+                  | otherwise   = nonVirgin env++        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)++        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs+                -- mapAccumL: Use the new signature to do the next pair+                -- The occurrence analyser has arranged them in a good order+                -- so this can significantly reduce the number of iterations needed++        my_downRhs (env, lazy_fv) (id,rhs)+          = ((env', lazy_fv'), (id', rhs'))+          where+            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs+            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1+            env'                  = extendAnalEnv top_lvl env id (idStrictness id')+++    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]+    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]++{-+Note [Safe abortion in the fixed-point iteration]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Fixed-point iteration may fail to terminate. But we cannot simply give up and+return the environment and code unchanged! We still need to do one additional+round, for two reasons:++ * To get information on used free variables (both lazy and strict!)+   (see Note [Lazy and unleashable free variables])+ * To ensure that all expressions have been traversed at least once, and any left-over+   strictness annotations have been updated.++This final iteration does not add the variables to the strictness signature+environment, which effectively assigns them 'nopSig' (see "getStrictness")++-}++-- Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- dmdAnalRhsLetDown implements the Down variant:+--  * assuming a demand of <L,U>+--  * looking at the definition+--  * determining a strictness signature+--+-- It is used for toplevel definition, recursive definitions and local+-- non-recursive definitions that have manifest lambdas.+-- Local non-recursive definitions without a lambda are handled with LetUp.+--+-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnalRhsLetDown+  :: Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive+  -> AnalEnv -> CleanDemand+  -> Id -> CoreExpr+  -> (DmdEnv, Id, CoreExpr)+-- Process the RHS of the binding, add the strictness signature+-- to the Id, and augment the environment with the signature as well.+dmdAnalRhsLetDown rec_flag env let_dmd id rhs+  = (lazy_fv, id', rhs')+  where+    rhs_arity      = idArity id+    rhs_dmd+      -- See Note [Demand analysis for join points]+      -- See Note [Invariants on join points] invariant 2b, in GHC.Core+      --     rhs_arity matches the join arity of the join point+      | isJoinId id+      = mkCallDmds rhs_arity let_dmd+      | otherwise+      -- NB: rhs_arity+      -- See Note [Demand signatures are computed for a threshold demand based on idArity]+      = mkRhsDmd env rhs_arity rhs+    (DmdType rhs_fv rhs_dmds rhs_div, rhs')+                   = dmdAnal env rhs_dmd rhs+    -- TODO: Won't the following line unnecessarily trim down arity for join+    --       points returning a lambda in a C(S) context?+    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div)+    id'            = setIdStrictness id sig+        -- See Note [NOINLINE and strictness]+++    -- See Note [Aggregated demand for cardinality]+    rhs_fv1 = case rec_flag of+                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)+                Nothing -> rhs_fv++    -- See Note [Lazy and unleashable free variables]+    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1+    is_thunk = not (exprIsHNF rhs) && not (isJoinId id)++-- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for+-- unleashing on the given function's @rhs@, by creating+-- a call demand of @rhs_arity@+-- See Historical Note [Product demands for function body]+mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand+mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd++-- | If given the let-bound 'Id', 'useLetUp' determines whether we should+-- process the binding up (body before rhs) or down (rhs before body).+--+-- We use LetDown if there is a chance to get a useful strictness signature to+-- unleash at call sites. LetDown is generally more precise than LetUp if we can+-- correctly guess how it will be used in the body, that is, for which incoming+-- demand the strictness signature should be computed, which allows us to+-- unleash higher-order demands on arguments at call sites. This is mostly the+-- case when+--+--   * The binding takes any arguments before performing meaningful work (cf.+--     'idArity'), in which case we are interested to see how it uses them.+--   * The binding is a join point, hence acting like a function, not a value.+--     As a big plus, we know *precisely* how it will be used in the body; since+--     it's always tail-called, we can directly unleash the incoming demand of+--     the let binding on its RHS when computing a strictness signature. See+--     [Demand analysis for join points].+--+-- Thus, if the binding is not a join point and its arity is 0, we have a thunk+-- and use LetUp, implying that we have no usable demand signature available+-- when we analyse the let body.+--+-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free+-- vars at most once, regardless of how many times it was forced in the body.+-- This makes a real difference wrt. usage demands. The other reason is being+-- able to unleash a more precise product demand on its RHS once we know how the+-- thunk was used in the let body.+--+-- Characteristic examples, always assuming a single evaluation:+--+--   * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that+--     the expression uses @y@ at most once.+--   * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that+--     @b@ is absent.+--   * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that+--     the expression uses @y@ strictly, because we have @f@'s demand signature+--     available at the call site.+--   * @join exit = 2*y in if a then exit else if b then exit else 3*y@ =>+--     LetDown. Compared to LetUp, we find out that the expression uses @y@+--     strictly, because we can unleash @exit@'s signature at each call site.+--   * For a more convincing example with join points, see Note [Demand analysis+--     for join points].+--+useLetUp :: Var -> Bool+useLetUp f = idArity f == 0 && not (isJoinId f)++{- Note [Demand analysis for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   g :: (Int,Int) -> Int+   g (p,q) = p+q++   f :: T -> Int -> Int+   f x p = g (join j y = (p,y)+              in case x of+                   A -> j 3+                   B -> j 4+                   C -> (p,7))++If j was a vanilla function definition, we'd analyse its body with+evalDmd, and think that it was lazy in p.  But for join points we can+do better!  We know that j's body will (if called at all) be evaluated+with the demand that consumes the entire join-binding, in this case+the argument demand from g.  Whizzo!  g evaluates both components of+its argument pair, so p will certainly be evaluated if j is called.++For f to be strict in p, we need /all/ paths to evaluate p; in this+case the C branch does so too, so we are fine.  So, as usual, we need+to transport demands on free variables to the call site(s).  Compare+Note [Lazy and unleashable free variables].++The implementation is easy.  When analysing a join point, we can+analyse its body with the demand from the entire join-binding (written+let_dmd here).++Another win for join points!  #13543.++However, note that the strictness signature for a join point can+look a little puzzling.  E.g.++    (join j x = \y. error "urk")+    (in case v of              )+    (     A -> j 3             )  x+    (     B -> j 4             )+    (     C -> \y. blah        )++The entire thing is in a C(S) context, so j's strictness signature+will be    [A]b+meaning one absent argument, returns bottom.  That seems odd because+there's a \y inside.  But it's right because when consumed in a C(1)+context the RHS of the join point is indeed bottom.++Note [Demand signatures are computed for a threshold demand based on idArity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We compute demand signatures assuming idArity incoming arguments to approximate+behavior for when we have a call site with at least that many arguments. idArity+is /at least/ the number of manifest lambdas, but might be higher for PAPs and+trivial RHS (see Note [Demand analysis for trivial right-hand sides]).++Because idArity of a function varies independently of its cardinality properties+(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode+the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth'+(cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand). It is unsound to+unleash a demand signature when the incoming number of arguments is less than+that. See Note [What are demand signatures?] for more details on soundness.++Why idArity arguments? Because that's a conservative estimate of how many+arguments we must feed a function before it does anything interesting with them.+Also it elegantly subsumes the trivial RHS and PAP case.++There might be functions for which we might want to analyse for more incoming+arguments than idArity. Example:++  f x =+    if expensive+      then \y -> ... y ...+      else \y -> ... y ...++We'd analyse `f` under a unary call demand C(S), corresponding to idArity+being 1. That's enough to look under the manifest lambda and find out how a+unary call would use `x`, but not enough to look into the lambdas in the if+branches.++On the other hand, if we analysed for call demand C(C(S)), we'd get useful+strictness info for `y` (and more precise info on `x`) and possibly CPR+information, but++  * We would no longer be able to unleash the signature at unary call sites+  * Performing the worker/wrapper split based on this information would be+    implicitly eta-expanding `f`, playing fast and loose with divergence and+    even being unsound in the presence of newtypes, so we refrain from doing so.+    Also see Note [Don't eta expand in w/w] in GHC.Core.Op.WorkWrap.++Since we only compute one signature, we do so for arity 1. Computing multiple+signatures for different arities (i.e., polyvariance) would be entirely+possible, if it weren't for the additional runtime and implementation+complexity.++Note [idArity varies independently of dmdTypeDepth]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound+identifier. But that means we would have to zap demand signatures every time we+reset or decrease arity. That's an unnecessary dependency, because++  * The demand signature captures a semantic property that is independent of+    what the binding's current arity is+  * idArity is analysis information itself, thus volatile+  * We already *have* dmdTypeDepth, wo why not just use it to encode the+    threshold for when to unleash the signature+    (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand)++Consider the following expression, for example:++    (let go x y = `x` seq ... in go) |> co++`go` might have a strictness signature of `<S><L>`. The simplifier will identify+`go` as a nullary join point through `joinPointBinding_maybe` and float the+coercion into the binding, leading to an arity decrease:++    join go = (\x y -> `x` seq ...) |> co in go++With the CoreLint check, we would have to zap `go`'s perfectly viable strictness+signature.++Note [What are demand signatures?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand analysis interprets expressions in the abstract domain of demand+transformers. Given an incoming demand we put an expression under, its abstract+transformer gives us back a demand type denoting how other things (like+arguments and free vars) were used when the expression was evaluated.+Here's an example:++  f x y =+    if x + expensive+      then \z -> z + y * ...+      else \z -> z * ...++The abstract transformer (let's call it F_e) of the if expression (let's call it+e) would transform an incoming head demand <S,HU> into a demand type like+{x-><S,1*U>,y-><L,U>}<L,U>. In pictures:++     Demand ---F_e---> DmdType+     <S,HU>            {x-><S,1*U>,y-><L,U>}<L,U>++Let's assume that the demand transformers we compute for an expression are+correct wrt. to some concrete semantics for Core. How do demand signatures fit+in? They are strange beasts, given that they come with strict rules when to+it's sound to unleash them.++Fortunately, we can formalise the rules with Galois connections. Consider+f's strictness signature, {}<S,1*U><L,U>. It's a single-point approximation of+the actual abstract transformer of f's RHS for arity 2. So, what happens is that+we abstract *once more* from the abstract domain we already are in, replacing+the incoming Demand by a simple lattice with two elements denoting incoming+arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom+element). Here's the diagram:++     A_2 -----f_f----> DmdType+      ^                   |+      | α               γ |+      |                   v+     Demand ---F_f---> DmdType++With+  α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness+  α(_)         =  <2+  γ(ty)        =  ty+and F_f being the abstract transformer of f's RHS and f_f being the abstracted+abstract transformer computable from our demand signature simply by++  f_f(>=2) = {}<S,1*U><L,U>+  f_f(<2)  = postProcessUnsat {}<S,1*U><L,U>++where postProcessUnsat makes a proper top element out of the given demand type.++Note [Demand analysis for trivial right-hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    foo = plusInt |> co+where plusInt is an arity-2 function with known strictness.  Clearly+we want plusInt's strictness to propagate to foo!  But because it has+no manifest lambdas, it won't do so automatically, and indeed 'co' might+have type (Int->Int->Int) ~ T.++Fortunately, GHC.Core.Arity gives 'foo' arity 2, which is enough for LetDown to+forward plusInt's demand signature, and all is well (see Note [Newtype arity] in+GHC.Core.Arity)! A small example is the test case NewtypeArity.+++Historical Note [Product demands for function body]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In 2013 I spotted this example, in shootout/binary_trees:++    Main.check' = \ b z ds. case z of z' { I# ip ->+                                case ds_d13s of+                                  Main.Nil -> z'+                                  Main.Node s14k s14l s14m ->+                                    Main.check' (not b)+                                      (Main.check' b+                                         (case b {+                                            False -> I# (-# s14h s14k);+                                            True  -> I# (+# s14h s14k)+                                          })+                                         s14l)+                                     s14m   }   }   }++Here we *really* want to unbox z, even though it appears to be used boxed in+the Nil case.  Partly the Nil case is not a hot path.  But more specifically,+the whole function gets the CPR property if we do.++That motivated using a demand of C(C(C(S(L,L)))) for the RHS, where+(solely because the result was a product) we used a product demand+(albeit with lazy components) for the body. But that gives very silly+behaviour -- see #17932.   Happily it turns out now to be entirely+unnecessary: we get good results with C(C(C(S))).   So I simply+deleted the special case.++************************************************************************+*                                                                      *+\subsection{Strictness signatures and types}+*                                                                      *+************************************************************************+-}++unitDmdType :: DmdEnv -> DmdType+unitDmdType dmd_env = DmdType dmd_env [] topDiv++coercionDmdEnv :: Coercion -> DmdEnv+coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)+                    -- The VarSet from coVarsOfCo is really a VarEnv Var++addVarDmd :: DmdType -> Var -> Demand -> DmdType+addVarDmd (DmdType fv ds res) var dmd+  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res++addLazyFVs :: DmdType -> DmdEnv -> DmdType+addLazyFVs dmd_ty lazy_fvs+  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs+        -- Using bothDmdType (rather than just both'ing the envs)+        -- is vital.  Consider+        --      let f = \x -> (x,y)+        --      in  error (f 3)+        -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L+        -- demand with the bottom coming up from 'error'+        --+        -- I got a loop in the fixpointer without this, due to an interaction+        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was+        --      letrec f n x+        --          = letrec g y = x `fatbar`+        --                         letrec h z = z + ...g...+        --                         in h (f (n-1) x)+        --      in ...+        -- In the initial iteration for f, f=Bot+        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS+        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it+        -- places on its free variables.  Suppose it places none.  Then the+        --      x `fatbar` ...call to h...+        -- will give a x->V demand for x.  That turns into a L demand for x,+        -- which floats out of the defn for h.  Without the modifyEnv, that+        -- L demand doesn't get both'd with the Bot coming up from the inner+        -- call to f.  So we just get an L demand for x for g.++{-+Note [Do not strictify the argument dictionaries of a dfun]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The typechecker can tie recursive knots involving dfuns, so we do the+conservative thing and refrain from strictifying a dfun's argument+dictionaries.+-}++setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]+setBndrsDemandInfo (b:bs) (d:ds)+  | isTyVar b = b : setBndrsDemandInfo bs (d:ds)+  | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds+setBndrsDemandInfo [] ds = ASSERT( null ds ) []+setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs)++annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)+-- The returned env has the var deleted+-- The returned var is annotated with demand info+-- according to the result demand of the provided demand type+-- No effect on the argument demands+annotateBndr env dmd_ty var+  | isId var  = (dmd_ty', setIdDemandInfo var dmd)+  | otherwise = (dmd_ty, var)+  where+    (dmd_ty', dmd) = findBndrDmd env False dmd_ty var++annotateLamIdBndr :: AnalEnv+                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?+                  -> DmdType    -- Demand type of body+                  -> Id         -- Lambda binder+                  -> (DmdType,  -- Demand type of lambda+                      Id)       -- and binder annotated with demand++annotateLamIdBndr env arg_of_dfun dmd_ty id+-- For lambdas we add the demand to the argument demands+-- Only called for Ids+  = ASSERT( isId id )+    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $+    (final_ty, setIdDemandInfo id dmd)+  where+      -- Watch out!  See note [Lambda-bound unfoldings]+    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of+                 Nothing  -> main_ty+                 Just unf -> main_ty `bothDmdType` unf_ty+                          where+                             (unf_ty, _) = dmdAnalStar env dmd unf++    main_ty = addDemand dmd dmd_ty'+    (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id++deleteFVs :: DmdType -> [Var] -> DmdType+deleteFVs (DmdType fvs dmds res) bndrs+  = DmdType (delVarEnvList fvs bndrs) dmds res++{-+Note [NOINLINE and strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The strictness analyser used to have a HACK which ensured that NOINLNE+things were not strictness-analysed.  The reason was unsafePerformIO.+Left to itself, the strictness analyser would discover this strictness+for unsafePerformIO:+        unsafePerformIO:  C(U(AV))+But then consider this sub-expression+        unsafePerformIO (\s -> let r = f x in+                               case writeIORef v r s of (# s1, _ #) ->+                               (# s1, r #)+The strictness analyser will now find that r is sure to be eval'd,+and may then hoist it out.  This makes tests/lib/should_run/memo002+deadlock.++Solving this by making all NOINLINE things have no strictness info is overkill.+In particular, it's overkill for runST, which is perfectly respectable.+Consider+        f x = runST (return x)+This should be strict in x.++So the new plan is to define unsafePerformIO using the 'lazy' combinator:++        unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)++Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is+magically NON-STRICT, and is inlined after strictness analysis.  So+unsafePerformIO will look non-strict, and that's what we want.++Now we don't need the hack in the strictness analyser.  HOWEVER, this+decision does mean that even a NOINLINE function is not entirely+opaque: some aspect of its implementation leaks out, notably its+strictness.  For example, if you have a function implemented by an+error stub, but which has RULES, you may want it not to be eliminated+in favour of error!++Note [Lazy and unleashable free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We put the strict and once-used FVs in the DmdType of the Id, so+that at its call sites we unleash demands on its strict fvs.+An example is 'roll' in imaginary/wheel-sieve2+Something like this:+        roll x = letrec+                     go y = if ... then roll (x-1) else x+1+                 in+                 go ms+We want to see that roll is strict in x, which is because+go is called.   So we put the DmdEnv for x in go's DmdType.++Another example:++        f :: Int -> Int -> Int+        f x y = let t = x+1+            h z = if z==0 then t else+                  if z==1 then x+1 else+                  x + h (z-1)+        in h y++Calling h does indeed evaluate x, but we can only see+that if we unleash a demand on x at the call site for t.++Incidentally, here's a place where lambda-lifting h would+lose the cigar --- we couldn't see the joint strictness in t/x++        ON THE OTHER HAND++We don't want to put *all* the fv's from the RHS into the+DmdType. Because++ * it makes the strictness signatures larger, and hence slows down fixpointing++and++ * it is useless information at the call site anyways:+   For lazy, used-many times fv's we will never get any better result than+   that, no matter how good the actual demand on the function at the call site+   is (unless it is always absent, but then the whole binder is useless).++Therefore we exclude lazy multiple-used fv's from the environment in the+DmdType.++But now the signature lies! (Missing variables are assumed to be absent.) To+make up for this, the code that analyses the binding keeps the demand on those+variable separate (usually called "lazy_fv") and adds it to the demand of the+whole binding later.++What if we decide _not_ to store a strictness signature for a binding at all, as+we do when aborting a fixed-point iteration? The we risk losing the information+that the strict variables are being used. In that case, we take all free variables+mentioned in the (unsound) strictness signature, conservatively approximate the+demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".+++Note [Lambda-bound unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We allow a lambda-bound variable to carry an unfolding, a facility that is used+exclusively for join points; see Note [Case binders and join points].  If so,+we must be careful to demand-analyse the RHS of the unfolding!  Example+   \x. \y{=Just x}. <body>+Then if <body> uses 'y', then transitively it uses 'x', and we must not+forget that fact, otherwise we might make 'x' absent when it isn't.+++************************************************************************+*                                                                      *+\subsection{Strictness signatures}+*                                                                      *+************************************************************************+-}++type DFunFlag = Bool  -- indicates if the lambda being considered is in the+                      -- sequence of lambdas at the top of the RHS of a dfun+notArgOfDfun :: DFunFlag+notArgOfDfun = False++data AnalEnv+  = AE { ae_dflags :: DynFlags+       , ae_sigs   :: SigEnv+       , ae_virgin :: Bool    -- True on first iteration only+                              -- See Note [Initialising strictness]+       , ae_rec_tc :: RecTcChecker+       , ae_fam_envs :: FamInstEnvs+ }++        -- We use the se_env to tell us whether to+        -- record info about a variable in the DmdEnv+        -- We do so if it's a LocalId, but not top-level+        --+        -- The DmdEnv gives the demand on the free vars of the function+        -- when it is given enough args to satisfy the strictness signature++type SigEnv = VarEnv (StrictSig, TopLevelFlag)++instance Outputable AnalEnv where+  ppr (AE { ae_sigs = env, ae_virgin = virgin })+    = text "AE" <+> braces (vcat+         [ text "ae_virgin =" <+> ppr virgin+         , text "ae_sigs =" <+> ppr env ])++emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv+emptyAnalEnv dflags fam_envs+    = AE { ae_dflags = dflags+         , ae_sigs = emptySigEnv+         , ae_virgin = True+         , ae_rec_tc = initRecTc+         , ae_fam_envs = fam_envs+         }++emptySigEnv :: SigEnv+emptySigEnv = emptyVarEnv++-- | Extend an environment with the strictness IDs attached to the id+extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv+extendAnalEnvs top_lvl env vars+  = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }++extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv+extendSigEnvs top_lvl sigs vars+  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]++extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv+extendAnalEnv top_lvl env var sig+  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }++extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv+extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)++lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)+lookupSigEnv env id = lookupVarEnv (ae_sigs env) id++nonVirgin :: AnalEnv -> AnalEnv+nonVirgin env = env { ae_virgin = False }++findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])+-- Return the demands on the Ids in the [Var]+findBndrsDmds env dmd_ty bndrs+  = go dmd_ty bndrs+  where+    go dmd_ty []  = (dmd_ty, [])+    go dmd_ty (b:bs)+      | isId b    = let (dmd_ty1, dmds) = go dmd_ty bs+                        (dmd_ty2, dmd)  = findBndrDmd env False dmd_ty1 b+                    in (dmd_ty2, dmd : dmds)+      | otherwise = go dmd_ty bs++findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)+-- See Note [Trimming a demand to a type] in GHC.Types.Demand+findBndrDmd env arg_of_dfun dmd_ty id+  = (dmd_ty', dmd')+  where+    dmd' = strictify $+           trimToType starting_dmd (findTypeShape fam_envs id_ty)++    (dmd_ty', starting_dmd) = peelFV dmd_ty id++    id_ty = idType id++    strictify dmd+      | gopt Opt_DictsStrict (ae_dflags env)+             -- We never want to strictify a recursive let. At the moment+             -- annotateBndr is only call for non-recursive lets; if that+             -- changes, we need a RecFlag parameter and another guard here.+      , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]+      = strictifyDictDmd id_ty dmd+      | otherwise+      = dmd++    fam_envs = ae_fam_envs env++{- Note [Initialising strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See section 9.2 (Finding fixpoints) of the paper.++Our basic plan is to initialise the strictness of each Id in a+recursive group to "bottom", and find a fixpoint from there.  However,+this group B might be inside an *enclosing* recursive group A, in+which case we'll do the entire fixpoint shebang on for each iteration+of A. This can be illustrated by the following example:++Example:++  f [] = []+  f (x:xs) = let g []     = f xs+                 g (y:ys) = y+1 : g ys+              in g (h x)++At each iteration of the fixpoint for f, the analyser has to find a+fixpoint for the enclosed function g. In the meantime, the demand+values for g at each iteration for f are *greater* than those we+encountered in the previous iteration for f. Therefore, we can begin+the fixpoint for g not with the bottom value but rather with the+result of the previous analysis. I.e., when beginning the fixpoint+process for g, we can start from the demand signature computed for g+previously and attached to the binding occurrence of g.++To speed things up, we initialise each iteration of A (the enclosing+one) from the result of the last one, which is neatly recorded in each+binder.  That way we make use of earlier iterations of the fixpoint+algorithm. (Cunning plan.)++But on the *first* iteration we want to *ignore* the current strictness+of the Id, and start from "bottom".  Nowadays the Id can have a current+strictness, because interface files record strictness for nested bindings.+To know when we are in the first iteration, we look at the ae_virgin+field of the AnalEnv.+++Note [Final Demand Analyser run]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some of the information that the demand analyser determines is not always+preserved by the simplifier.  For example, the simplifier will happily rewrite+  \y [Demand=1*U] let x = y in x + x+to+  \y [Demand=1*U] y + y+which is quite a lie.++The once-used information is (currently) only used by the code+generator, though.  So:++ * We zap the used-once info in the worker-wrapper;+   see Note [Zapping Used Once info in WorkWrap] in+   GHC.Core.Op.WorkWrap.+   If it's not reliable, it's better not to have it at all.++ * Just before TidyCore, we add a pass of the demand analyser,+      but WITHOUT subsequent worker/wrapper and simplifier,+   right before TidyCore.  See SimplCore.getCoreToDo.++   This way, correct information finds its way into the module interface+   (strictness signatures!) and the code generator (single-entry thunks!)++Note that, in contrast, the single-call information (C1(..)) /can/ be+relied upon, as the simplifier tends to be very careful about not+duplicating actual function calls.++Also see #11731.+-}
+ compiler/GHC/Core/Op/Exitify.hs view
@@ -0,0 +1,499 @@+module GHC.Core.Op.Exitify ( exitifyProgram ) where++{-+Note [Exitification]+~~~~~~~~~~~~~~~~~~~~++This module implements Exitification. The goal is to pull as much code out of+recursive functions as possible, as the simplifier is better at inlining into+call-sites that are not in recursive functions.++Example:++  let t = foo bar+  joinrec go 0     x y = t (x*x)+          go (n-1) x y = jump go (n-1) (x+y)+  in …++We’d like to inline `t`, but that does not happen: Because t is a thunk and is+used in a recursive function, doing so might lose sharing in general. In+this case, however, `t` is on the _exit path_ of `go`, so called at most once.+How do we make this clearly visible to the simplifier?++A code path (i.e., an expression in a tail-recursive position) in a recursive+function is an exit path if it does not contain a recursive call. We can bind+this expression outside the recursive function, as a join-point.++Example result:++  let t = foo bar+  join exit x = t (x*x)+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+  in …++Now `t` is no longer in a recursive function, and good things happen!+-}++import GhcPrelude+import GHC.Types.Var+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core+import GHC.Core.Utils+import State+import GHC.Types.Unique+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Core.FVs+import FastString+import GHC.Core.Type+import Util( mapSnd )++import Data.Bifunctor+import Control.Monad++-- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them.+-- The really interesting function is exitifyRec+exitifyProgram :: CoreProgram -> CoreProgram+exitifyProgram binds = map goTopLvl binds+  where+    goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e)+    goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs)+      -- Top-level bindings are never join points++    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds++    go :: InScopeSet -> CoreExpr -> CoreExpr+    go _    e@(Var{})       = e+    go _    e@(Lit {})      = e+    go _    e@(Type {})     = e+    go _    e@(Coercion {}) = e+    go in_scope (Cast e' c) = Cast (go in_scope e') c+    go in_scope (Tick t e') = Tick t (go in_scope e')+    go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2)++    go in_scope (Lam v e')+      = Lam v (go in_scope' e')+      where in_scope' = in_scope `extendInScopeSet` v++    go in_scope (Case scrut bndr ty alts)+      = Case (go in_scope scrut) bndr ty (map go_alt alts)+      where+        in_scope1 = in_scope `extendInScopeSet` bndr+        go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs)+           where in_scope' = in_scope1 `extendInScopeSetList` pats++    go in_scope (Let (NonRec bndr rhs) body)+      = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body)+      where+        in_scope' = in_scope `extendInScopeSet` bndr++    go in_scope (Let (Rec pairs) body)+      | is_join_rec = mkLets (exitifyRec in_scope' pairs') body'+      | otherwise   = Let (Rec pairs') body'+      where+        is_join_rec = any (isJoinId . fst) pairs+        in_scope'   = in_scope `extendInScopeSetList` bindersOf (Rec pairs)+        pairs'      = mapSnd (go in_scope') pairs+        body'       = go in_scope' body+++-- | State Monad used inside `exitify`+type ExitifyM =  State [(JoinId, CoreExpr)]++-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as+--   join-points outside the joinrec.+exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]+exitifyRec in_scope pairs+  = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs']+  where+    -- We need the set of free variables of many subexpressions here, so+    -- annotate the AST with them+    -- see Note [Calculating free variables]+    ann_pairs = map (second freeVars) pairs++    -- Which are the recursive calls?+    recursive_calls = mkVarSet $ map fst pairs++    (pairs',exits) = (`runState` []) $ do+        forM ann_pairs $ \(x,rhs) -> do+            -- go past the lambdas of the join point+            let (args, body) = collectNAnnBndrs (idJoinArity x) rhs+            body' <- go args body+            let rhs' = mkLams args body'+            return (x, rhs')++    ---------------------+    -- 'go' is the main working function.+    -- It goes through the RHS (tail-call positions only),+    -- checks if there are no more recursive calls, if so, abstracts over+    -- variables bound on the way and lifts it out as a join point.+    --+    -- ExitifyM is a state monad to keep track of floated binds+    go :: [Var]           -- ^ Variables that are in-scope here, but+                          -- not in scope at the joinrec; that is,+                          -- we must potentially abstract over them.+                          -- Invariant: they are kept in dependency order+       -> CoreExprWithFVs -- ^ Current expression in tail position+       -> ExitifyM CoreExpr++    -- We first look at the expression (no matter what it shape is)+    -- and determine if we can turn it into a exit join point+    go captured ann_e+        | -- An exit expression has no recursive calls+          let fvs = dVarSetToVarSet (freeVarsOf ann_e)+        , disjointVarSet fvs recursive_calls+        = go_exit captured (deAnnotate ann_e) fvs++    -- We could not turn it into a exit join point. So now recurse+    -- into all expression where eligible exit join points might sit,+    -- i.e. into all tail-call positions:++    -- Case right hand sides are in tail-call position+    go captured (_, AnnCase scrut bndr ty alts) = do+        alts' <- forM alts $ \(dc, pats, rhs) -> do+            rhs' <- go (captured ++ [bndr] ++ pats) rhs+            return (dc, pats, rhs')+        return $ Case (deAnnotate scrut) bndr ty alts'++    go captured (_, AnnLet ann_bind body)+        -- join point, RHS and body are in tail-call position+        | AnnNonRec j rhs <- ann_bind+        , Just join_arity <- isJoinId_maybe j+        = do let (params, join_body) = collectNAnnBndrs join_arity rhs+             join_body' <- go (captured ++ params) join_body+             let rhs' = mkLams params join_body'+             body' <- go (captured ++ [j]) body+             return $ Let (NonRec j rhs') body'++        -- rec join point, RHSs and body are in tail-call position+        | AnnRec pairs <- ann_bind+        , isJoinId (fst (head pairs))+        = do let js = map fst pairs+             pairs' <- forM pairs $ \(j,rhs) -> do+                 let join_arity = idJoinArity j+                     (params, join_body) = collectNAnnBndrs join_arity rhs+                 join_body' <- go (captured ++ js ++ params) join_body+                 let rhs' = mkLams params join_body'+                 return (j, rhs')+             body' <- go (captured ++ js) body+             return $ Let (Rec pairs') body'++        -- normal Let, only the body is in tail-call position+        | otherwise+        = do body' <- go (captured ++ bindersOf bind ) body+             return $ Let bind body'+      where bind = deAnnBind ann_bind++    -- Cannot be turned into an exit join point, but also has no+    -- tail-call subexpression. Nothing to do here.+    go _ ann_e = return (deAnnotate ann_e)++    ---------------------+    go_exit :: [Var]      -- Variables captured locally+            -> CoreExpr   -- An exit expression+            -> VarSet     -- Free vars of the expression+            -> ExitifyM CoreExpr+    -- go_exit deals with a tail expression that is floatable+    -- out as an exit point; that is, it mentions no recursive calls+    go_exit captured e fvs+      -- Do not touch an expression that is already a join jump where all arguments+      -- are captured variables. See Note [Idempotency]+      -- But _do_ float join jumps with interesting arguments.+      -- See Note [Jumps can be interesting]+      | (Var f, args) <- collectArgs e+      , isJoinId f+      , all isCapturedVarArg args+      = return e++      -- Do not touch a boring expression (see Note [Interesting expression])+      | not is_interesting+      = return e++      -- Cannot float out if local join points are used, as+      -- we cannot abstract over them+      | captures_join_points+      = return e++      -- We have something to float out!+      | otherwise+      = do { -- Assemble the RHS of the exit join point+             let rhs   = mkLams abs_vars e+                 avoid = in_scope `extendInScopeSetList` captured+             -- Remember this binding under a suitable name+           ; v <- addExit avoid (length abs_vars) rhs+             -- And jump to it from here+           ; return $ mkVarApps (Var v) abs_vars }++      where+        -- Used to detect exit expressions that are already proper exit jumps+        isCapturedVarArg (Var v) = v `elem` captured+        isCapturedVarArg _ = False++        -- An interesting exit expression has free, non-imported+        -- variables from outside the recursive group+        -- See Note [Interesting expression]+        is_interesting = anyVarSet isLocalId $+                         fvs `minusVarSet` mkVarSet captured++        -- The arguments of this exit join point+        -- See Note [Picking arguments to abstract over]+        abs_vars = snd $ foldr pick (fvs, []) captured+          where+            pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc)+                               | otherwise           = (fvs',               acc)++        -- We are going to abstract over these variables, so we must+        -- zap any IdInfo they have; see #15005+        -- cf. GHC.Core.Op.SetLevels.abstractVars+        zap v | isId v = setIdInfo v vanillaIdInfo+              | otherwise = v++        -- We cannot abstract over join points+        captures_join_points = any isJoinId abs_vars+++-- Picks a new unique, which is disjoint from+--  * the free variables of the whole joinrec+--  * any bound variables (captured)+--  * any exit join points created so far.+mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId+mkExitJoinId in_scope ty join_arity = do+    fs <- get+    let avoid = in_scope `extendInScopeSetList` (map fst fs)+                         `extendInScopeSet` exit_id_tmpl -- just cosmetics+    return (uniqAway avoid exit_id_tmpl)+  where+    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty+                    `asJoinId` join_arity++addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId+addExit in_scope join_arity rhs = do+    -- Pick a suitable name+    let ty = exprType rhs+    v <- mkExitJoinId in_scope ty join_arity+    fs <- get+    put ((v,rhs):fs)+    return v++{-+Note [Interesting expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not want this to happen:++  joinrec go 0     x y = x+          go (n-1) x y = jump go (n-1) (x+y)+  in …+==>+  join exit x = x+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+  in …++because the floated exit path (`x`) is simply a parameter of `go`; there are+not useful interactions exposed this way.++Neither do we want this to happen++  joinrec go 0     x y = x+x+          go (n-1) x y = jump go (n-1) (x+y)+  in …+==>+  join exit x = x+x+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+  in …++where the floated expression `x+x` is a bit more complicated, but still not+intersting.++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])+ * 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++So we only hoist an exit expression out if it mentiones at least one free,+non-imported variable.++Note [Jumps can be interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A jump to a join point can be interesting, if its arguments contain free+non-exported variables (z in the following example):++  joinrec go 0     x y = jump j (x+z)+          go (n-1) x y = jump go (n-1) (x+y)+  in …+==>+  join exit x y = jump j (x+z)+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+++The join point itself can be interesting, even if none if its+arguments have free variables free in the joinrec.  For example++  join j p = case p of (x,y) -> x+y+  joinrec go 0     x y = jump j (x,y)+          go (n-1) x y = jump go (n-1) (x+y) y+  in …++Here, `j` would not be inlined because we do not inline something that looks+like an exit join point (see Note [Do not inline exit join points]). But+if we exitify the 'jump j (x,y)' we get++  join j p = case p of (x,y) -> x+y+  join exit x y = jump j (x,y)+  joinrec go 0     x y = jump exit x y+          go (n-1) x y = jump go (n-1) (x+y) y+  in …++and now 'j' can inline, and we get rid of the pair. Here's another+example (assume `g` to be an imported function that, on its own,+does not make this interesting):++  join j y = map f y+  joinrec go 0     x y = jump j (map g x)+          go (n-1) x y = jump go (n-1) (x+y)+  in …++Again, `j` would not be inlined because we do not inline something that looks+like an exit join point (see Note [Do not inline exit join points]).++But after exitification we have++  join j y = map f y+  join exit x = jump j (map g x)+  joinrec go 0     x y = jump j (map g x)+              go (n-1) x y = jump go (n-1) (x+y)+  in …++and now we can inline `j` and this will allow `map/map` to fire.+++Note [Idempotency]+~~~~~~~~~~~~~~~~~~++We do not want this to happen, where we replace the floated expression with+essentially the same expression:++  join exit x = t (x*x)+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+  in …+==>+  join exit x = t (x*x)+  join exit' x = jump exit x+  joinrec go 0     x y = jump exit' x+          go (n-1) x y = jump go (n-1) (x+y)+  in …++So when the RHS is a join jump, and all of its arguments are captured variables,+then we leave it in place.++Note that `jump exit x` in this example looks interesting, as `exit` is a free+variable. Therefore, idempotency does not simply follow from floating only+interesting expressions.++Note [Calculating free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have two options where to annotate the tree with free variables:++ A) The whole tree.+ B) Each individual joinrec as we come across it.++Downside of A: We pay the price on the whole module, even outside any joinrecs.+Downside of B: We pay the price per joinrec, possibly multiple times when+joinrecs are nested.++Further downside of A: If the exitify function returns annotated expressions,+it would have to ensure that the annotations are correct.++We therefore choose B, and calculate the free variables in `exitify`.+++Note [Do not inline exit join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have++  let t = foo bar+  join exit x = t (x*x)+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+  in …++we do not want the simplifier to simply inline `exit` back in (which it happily+would).++To prevent this, we need to recognize exit join points, and then disable+inlining.++Exit join points, recognizeable using `isExitJoinId` are join points with an+occurrence in a recursive group, and can be recognized (after the occurrence+analyzer ran!) using `isExitJoinId`.+This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`,+because the lambdas of a non-recursive join point are not considered for+`occ_in_lam`.  For example, in the following code, `j1` is /not/ marked+occ_in_lam, because `j2` is called only once.++  join j1 x = x+1+  join j2 y = join j1 (y+2)++To prevent inlining, we check for isExitJoinId+* In `preInlineUnconditionally` directly.+* In `simplLetUnfolding` we simply give exit join points no unfolding, which+  prevents inlining in `postInlineUnconditionally` and call sites.++Note [Placement of the exitification pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I (Joachim) experimented with multiple positions for the Exitification pass in+the Core2Core pipeline:++ A) Before the `simpl_phases`+ B) Between the `simpl_phases` and the "main" simplifier pass+ C) After demand_analyser+ D) Before the final simplification phase++Here is the table (this is without inlining join exit points in the final+simplifier run):++        Program |                       Allocs                      |                      Instrs+                | ABCD.log     A.log     B.log     C.log     D.log  | ABCD.log     A.log     B.log     C.log     D.log+----------------|---------------------------------------------------|-------------------------------------------------+ fannkuch-redux |   -99.9%     +0.0%    -99.9%    -99.9%    -99.9%  |    -3.9%     +0.5%     -3.0%     -3.9%     -3.9%+          fasta |    -0.0%     +0.0%     +0.0%     -0.0%     -0.0%  |    -8.5%     +0.0%     +0.0%     -0.0%     -8.5%+            fem |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -2.2%     -0.1%     -0.1%     -2.1%     -2.1%+           fish |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -3.1%     +0.0%     -1.1%     -1.1%     -0.0%+   k-nucleotide |   -91.3%    -91.0%    -91.0%    -91.3%    -91.3%  |    -6.3%    +11.4%    +11.4%     -6.3%     -6.2%+            scs |    -0.0%     -0.0%     -0.0%     -0.0%     -0.0%  |    -3.4%     -3.0%     -3.1%     -3.3%     -3.3%+         simple |    -6.0%      0.0%     -6.0%     -6.0%     +0.0%  |    -3.4%     +0.0%     -5.2%     -3.4%     -0.1%+  spectral-norm |    -0.0%      0.0%      0.0%     -0.0%     +0.0%  |    -2.7%     +0.0%     -2.7%     -5.4%     -5.4%+----------------|---------------------------------------------------|-------------------------------------------------+            Min |   -95.0%    -91.0%    -95.0%    -95.0%    -95.0%  |    -8.5%     -3.0%     -5.2%     -6.3%     -8.5%+            Max |    +0.2%     +0.2%     +0.2%     +0.2%     +1.5%  |    +0.4%    +11.4%    +11.4%     +0.4%     +1.5%+ Geometric Mean |    -4.7%     -2.1%     -4.7%     -4.7%     -4.6%  |    -0.4%     +0.1%     -0.1%     -0.3%     -0.2%++Position A is disqualified, as it does not get rid of the allocations in+fannkuch-redux.+Position A and B are disqualified because it increases instructions in k-nucleotide.+Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta.++Assuming we have a budget of _one_ run of Exitification, then C wins (but we+could get more from running it multiple times, as seen in fish).++Note [Picking arguments to abstract over]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When we create an exit join point, so we need to abstract over those of its+free variables that are be out-of-scope at the destination of the exit join+point. So we go through the list `captured` and pick those that are actually+free variables of the join point.++We do not just `filter (`elemVarSet` fvs) captured`, as there might be+shadowing, and `captured` may contain multiple variables with the same Unique. I+these cases we want to abstract only over the last occurrence, hence the `foldr`+(with emphasis on the `r`). This is #15110.++-}
+ compiler/GHC/Core/Op/FloatIn.hs view
@@ -0,0 +1,774 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++************************************************************************+*                                                                      *+\section[FloatIn]{Floating Inwards pass}+*                                                                      *+************************************************************************++The main purpose of @floatInwards@ is floating into branches of a+case, so that we don't allocate things, save them on the stack, and+then discover that they aren't needed in the chosen branch.+-}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fprof-auto #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Core.Op.FloatIn ( floatInwards ) where++#include "HsVersions.h"++import GhcPrelude+import GHC.Platform++import GHC.Core+import GHC.Core.Make hiding ( wrapFloats )+import GHC.Driver.Types     ( ModGuts(..) )+import GHC.Core.Utils+import GHC.Core.FVs+import GHC.Core.Op.Monad    ( CoreM )+import GHC.Types.Id         ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )+import GHC.Types.Var+import GHC.Core.Type+import GHC.Types.Var.Set+import Util+import GHC.Driver.Session+import Outputable+-- import Data.List        ( mapAccumL )+import GHC.Types.Basic      ( RecFlag(..), isRec )++{-+Top-level interface function, @floatInwards@.  Note that we do not+actually float any bindings downwards from the top-level.+-}++floatInwards :: ModGuts -> CoreM ModGuts+floatInwards pgm@(ModGuts { mg_binds = binds })+  = do { dflags <- getDynFlags+       ; let platform = targetPlatform dflags+       ; return (pgm { mg_binds = map (fi_top_bind platform) binds }) }+  where+    fi_top_bind platform (NonRec binder rhs)+      = NonRec binder (fiExpr platform [] (freeVars rhs))+    fi_top_bind platform (Rec pairs)+      = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ]+++{-+************************************************************************+*                                                                      *+\subsection{Mail from Andr\'e [edited]}+*                                                                      *+************************************************************************++{\em Will wrote: What??? I thought the idea was to float as far+inwards as possible, no matter what.  This is dropping all bindings+every time it sees a lambda of any kind.  Help! }++You are assuming we DO DO full laziness AFTER floating inwards!  We+have to [not float inside lambdas] if we don't.++If we indeed do full laziness after the floating inwards (we could+check the compilation flags for that) then I agree we could be more+aggressive and do float inwards past lambdas.++Actually we are not doing a proper full laziness (see below), which+was another reason for not floating inwards past a lambda.++This can easily be fixed.  The problem is that we float lets outwards,+but there are a few expressions which are not let bound, like case+scrutinees and case alternatives.  After floating inwards the+simplifier could decide to inline the let and the laziness would be+lost, e.g.++\begin{verbatim}+let a = expensive             ==> \b -> case expensive of ...+in \ b -> case a of ...+\end{verbatim}+The fix is+\begin{enumerate}+\item+to let bind the algebraic case scrutinees (done, I think) and+the case alternatives (except the ones with an+unboxed type)(not done, I think). This is best done in the+GHC.Core.Op.SetLevels.hs module, which tags things with their level numbers.+\item+do the full laziness pass (floating lets outwards).+\item+simplify. The simplifier inlines the (trivial) lets that were+ created but were not floated outwards.+\end{enumerate}++With the fix I think Will's suggestion that we can gain even more from+strictness by floating inwards past lambdas makes sense.++We still gain even without going past lambdas, as things may be+strict in the (new) context of a branch (where it was floated to) or+of a let rhs, e.g.+\begin{verbatim}+let a = something            case x of+in case x of                   alt1 -> case something of a -> a + a+     alt1 -> a + a      ==>    alt2 -> b+     alt2 -> b++let a = something           let b = case something of a -> a + a+in let b = a + a        ==> in (b,b)+in (b,b)+\end{verbatim}+Also, even if a is not found to be strict in the new context and is+still left as a let, if the branch is not taken (or b is not entered)+the closure for a is not built.++************************************************************************+*                                                                      *+\subsection{Main floating-inwards code}+*                                                                      *+************************************************************************+-}++type FreeVarSet  = DIdSet+type BoundVarSet = DIdSet++data FloatInBind = FB BoundVarSet FreeVarSet FloatBind+        -- The FreeVarSet is the free variables of the binding.  In the case+        -- of recursive bindings, the set doesn't include the bound+        -- variables.++type FloatInBinds = [FloatInBind]+        -- In reverse dependency order (innermost binder first)++fiExpr :: Platform+       -> FloatInBinds      -- Binds we're trying to drop+                            -- as far "inwards" as possible+       -> CoreExprWithFVs   -- Input expr+       -> CoreExpr          -- Result++fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)+                                       -- See Note [Dead bindings]+fiExpr _ to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty+fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)+fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)+fiExpr platform to_drop (_, AnnCast expr (co_ann, co))+  = wrapFloats (drop_here ++ co_drop) $+    Cast (fiExpr platform e_drop expr) co+  where+    [drop_here, e_drop, co_drop]+      = sepBindsByDropPoint platform False+          [freeVarsOf expr, freeVarsOfAnn co_ann]+          to_drop++{-+Applications: we do float inside applications, mainly because we+need to get at all the arguments.  The next simplifier run will+pull out any silly ones.+-}++fiExpr platform to_drop ann_expr@(_,AnnApp {})+  = wrapFloats drop_here $ wrapFloats extra_drop $+    mkTicks ticks $+    mkApps (fiExpr platform fun_drop ann_fun)+           (zipWith (fiExpr platform) arg_drops ann_args)+  where+    (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr+    fun_ty  = exprType (deAnnotate ann_fun)+    fun_fvs = freeVarsOf ann_fun+    arg_fvs = map freeVarsOf ann_args++    (drop_here : extra_drop : fun_drop : arg_drops)+       = sepBindsByDropPoint platform False+                             (extra_fvs : fun_fvs : arg_fvs)+                             to_drop+         -- Shortcut behaviour: if to_drop is empty,+         -- sepBindsByDropPoint returns a suitable bunch of empty+         -- lists without evaluating extra_fvs, and hence without+         -- peering into each argument++    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args+    extra_fvs0 = case ann_fun of+                   (_, AnnVar _) -> fun_fvs+                   _             -> emptyDVarSet+          -- Don't float the binding for f into f x y z; see Note [Join points]+          -- for why we *can't* do it when f is a join point. (If f isn't a+          -- join point, floating it in isn't especially harmful but it's+          -- useless since the simplifier will immediately float it back out.)++    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)+    add_arg (fun_ty, extra_fvs) (_, AnnType ty)+      = (piResultTy fun_ty ty, extra_fvs)++    add_arg (fun_ty, extra_fvs) (arg_fvs, arg)+      | noFloatIntoArg arg arg_ty+      = (res_ty, extra_fvs `unionDVarSet` arg_fvs)+      | otherwise+      = (res_ty, extra_fvs)+      where+       (arg_ty, res_ty) = splitFunTy fun_ty++{- Note [Dead bindings]+~~~~~~~~~~~~~~~~~~~~~~~+At a literal we won't usually have any floated bindings; the+only way that can happen is if the binding wrapped the literal+/in the original input program/.  e.g.+   case x of { DEFAULT -> 1# }+But, while this may be unusual it is not actually wrong, and it did+once happen (#15696).++Note [Do not destroy the let/app invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Watch out for+   f (x +# y)+We don't want to float bindings into here+   f (case ... of { x -> x +# y })+because that might destroy the let/app invariant, which requires+unlifted function arguments to be ok-for-speculation.++Note [Join points]+~~~~~~~~~~~~~~~~~~+Generally, we don't need to worry about join points - there are places we're+not allowed to float them, but since they can't have occurrences in those+places, we're not tempted.++We do need to be careful about jumps, however:++  joinrec j x y z = ... in+  jump j a b c++Previous versions often floated the definition of a recursive function into its+only non-recursive occurrence. But for a join point, this is a disaster:++  (joinrec j x y z = ... in+  jump j) a b c -- wrong!++Every jump must be exact, so the jump to j must have three arguments. Hence+we're careful not to float into the target of a jump (though we can float into+the arguments just fine).++Note [Floating in past a lambda group]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* We must be careful about floating inside a value lambda.+  That risks losing laziness.+  The float-out pass might rescue us, but then again it might not.++* We must be careful about type lambdas too.  At one time we did, and+  there is no risk of duplicating work thereby, but we do need to be+  careful.  In particular, here is a bad case (it happened in the+  cichelli benchmark:+        let v = ...+        in let f = /\t -> \a -> ...+           ==>+        let f = /\t -> let v = ... in \a -> ...+  This is bad as now f is an updatable closure (update PAP)+  and has arity 0.++* Hack alert!  We only float in through one-shot lambdas,+  not (as you might guess) through lone big lambdas.+  Reason: we float *out* past big lambdas (see the test in the Lam+  case of FloatOut.floatExpr) and we don't want to float straight+  back in again.++  It *is* important to float into one-shot lambdas, however;+  see the remarks with noFloatIntoRhs.++So we treat lambda in groups, using the following rule:++ Float in if (a) there is at least one Id,+         and (b) there are no non-one-shot Ids++ Otherwise drop all the bindings outside the group.++This is what the 'go' function in the AnnLam case is doing.++(Join points are handled similarly: a join point is considered one-shot iff+it's non-recursive, so we float only into non-recursive join points.)++Urk! if all are tyvars, and we don't float in, we may miss an+      opportunity to float inside a nested case branch+++Note [Floating coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~+We could, in principle, have a coercion binding like+   case f x of co { DEFAULT -> e1 e2 }+It's not common to have a function that returns a coercion, but nothing+in Core prohibits it.  If so, 'co' might be mentioned in e1 or e2+/only in a type/.  E.g. suppose e1 was+  let (x :: Int |> co) = blah in blah2+++But, with coercions appearing in types, there is a complication: we+might be floating in a "strict let" -- that is, a case. Case expressions+mention their return type. We absolutely can't float a coercion binding+inward to the point that the type of the expression it's about to wrap+mentions the coercion. So we include the union of the sets of free variables+of the types of all the drop points involved. If any of the floaters+bind a coercion variable mentioned in any of the types, that binder must+be dropped right away.++-}++fiExpr platform to_drop lam@(_, AnnLam _ _)+  | noFloatIntoLam bndrs       -- Dump it all here+     -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088+  = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body))++  | otherwise           -- Float inside+  = mkLams bndrs (fiExpr platform to_drop body)++  where+    (bndrs, body) = collectAnnBndrs lam++{-+We don't float lets inwards past an SCC.+        ToDo: keep info on current cc, and when passing+        one, if it is not the same, annotate all lets in binds with current+        cc, change current cc to the new one and float binds into expr.+-}++fiExpr platform to_drop (_, AnnTick tickish expr)+  | tickish `tickishScopesLike` SoftScope+  = Tick tickish (fiExpr platform to_drop expr)++  | otherwise -- Wimp out for now - we could push values in+  = wrapFloats to_drop (Tick tickish (fiExpr platform [] expr))++{-+For @Lets@, the possible ``drop points'' for the \tr{to_drop}+bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,+or~(b2), in each of the RHSs of the pairs of a @Rec@.++Note that we do {\em weird things} with this let's binding.  Consider:+\begin{verbatim}+let+    w = ...+in {+    let v = ... w ...+    in ... v .. w ...+}+\end{verbatim}+Look at the inner \tr{let}.  As \tr{w} is used in both the bind and+body of the inner let, we could panic and leave \tr{w}'s binding where+it is.  But \tr{v} is floatable further into the body of the inner let, and+{\em then} \tr{w} will also be only in the body of that inner let.++So: rather than drop \tr{w}'s binding here, we add it onto the list of+things to drop in the outer let's body, and let nature take its+course.++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+again.  (It won't go inside the lambda else we risk losing work.)+In letrec, we need to be more careful still. We don't want to transform+        let x# = y# +# 1#+        in+        letrec f = \z. ...x#...f...+        in ...+into+        letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...+because now we can't float the let out again, because a letrec+can't have unboxed bindings.++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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  let x{rule mentioning y} = rhs in body+Here y is not free in rhs or body; but we still want to dump bindings+that bind y outside the let.  So we augment extra_fvs with the+idRuleAndUnfoldingVars of x.  No need for type variables, hence not using+idFreeVars.+-}++fiExpr platform to_drop (_,AnnLet bind body)+  = fiExpr platform (after ++ new_float : before) body+           -- to_drop is in reverse dependency order+  where+    (before, new_float, after) = fiBind platform to_drop bind body_fvs+    body_fvs    = freeVarsOf body++{- Note [Floating primops]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We try to float-in a case expression over an unlifted type.  The+motivating example was #5658: in particular, this change allows+array indexing operations, which have a single DEFAULT alternative+without any binders, to be floated inward.++SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed+scalars also need to be floated inward, but unpacks have a single non-DEFAULT+alternative that binds the elements of the tuple. We now therefore also support+floating in cases with a single alternative that may bind values.++But there are wrinkles++* Which unlifted cases do we float? See PrimOp.hs+  Note [PrimOp can_fail and has_side_effects] which explains:+   - We can float-in can_fail primops, but we can't float them out.+   - But we can float a has_side_effects primop, but NOT inside a lambda,+     so for now we don't float them at all.+  Hence exprOkForSideEffects++* Because we can float can-fail primops (array indexing, division) inwards+  but not outwards, we must be careful not to transform+     case a /# b of r -> f (F# r)+  ===>+    f (case a /# b of r -> F# r)+  because that creates a new thunk that wasn't there before.  And+  because it can't be floated out (can_fail), the thunk will stay+  there.  Disaster!  (This happened in nofib 'simple' and 'scs'.)++  Solution: only float cases into the branches of other cases, and+  not into the arguments of an application, or the RHS of a let. This+  is somewhat conservative, but it's simple.  And it still hits the+  cases like #5658.   This is implemented in sepBindsByJoinPoint;+  if is_case is False we dump all floating cases right here.++* #14511 is another example of why we want to restrict float-in+  of case-expressions.  Consider+     case indexArray# a n of (# r #) -> writeArray# ma i (f r)+  Now, floating that indexing operation into the (f r) thunk will+  not create any new thunks, but it will keep the array 'a' alive+  for much longer than the programmer expected.++  So again, not floating a case into a let or argument seems like+  the Right Thing++For @Case@, the possible drop points for the 'to_drop'+bindings are:+  (a) inside the scrutinee+  (b) inside one of the alternatives/default (default FVs always /first/!).++-}++fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])+  | isUnliftedType (idType case_bndr)+  , exprOkForSideEffects (deAnnotate scrut)+      -- See Note [Floating primops]+  = wrapFloats shared_binds $+    fiExpr platform (case_float : rhs_binds) rhs+  where+    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs+                    (FloatCase scrut' case_bndr con alt_bndrs)+    scrut'     = fiExpr platform scrut_binds scrut+    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)+    scrut_fvs  = freeVarsOf scrut++    [shared_binds, scrut_binds, rhs_binds]+       = sepBindsByDropPoint platform False+           [scrut_fvs, rhs_fvs]+           to_drop++fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)+  = wrapFloats drop_here1 $+    wrapFloats drop_here2 $+    Case (fiExpr platform scrut_drops scrut) case_bndr ty+         (zipWith fi_alt alts_drops_s alts)+  where+        -- Float into the scrut and alts-considered-together just like App+    [drop_here1, scrut_drops, alts_drops]+       = sepBindsByDropPoint platform False+           [scrut_fvs, all_alts_fvs]+           to_drop++        -- Float into the alts with the is_case flag set+    (drop_here2 : alts_drops_s)+      | [ _ ] <- alts = [] : [alts_drops]+      | otherwise     = sepBindsByDropPoint platform True alts_fvs alts_drops++    scrut_fvs    = freeVarsOf scrut+    alts_fvs     = map alt_fvs alts+    all_alts_fvs = unionDVarSets alts_fvs+    alt_fvs (_con, args, rhs)+      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)+           -- Delete case_bndr and args from free vars of rhs+           -- to get free vars of alt++    fi_alt to_drop (con, args, rhs) = (con, args, fiExpr platform to_drop rhs)++------------------+fiBind :: Platform+       -> FloatInBinds      -- Binds we're trying to drop+                            -- as far "inwards" as possible+       -> CoreBindWithFVs   -- Input binding+       -> DVarSet           -- Free in scope of binding+       -> ( FloatInBinds    -- Land these before+          , FloatInBind     -- The binding itself+          , FloatInBinds)   -- Land these after++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)]+    , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself+          (FloatLet (NonRec id rhs'))+    , body_binds )                         -- Land these after++  where+    body_fvs2 = body_fvs `delDVarSet` id++    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]+    extra_fvs | noFloatIntoRhs NonRecursive id rhs+              = rule_fvs `unionDVarSet` rhs_fvs+              | otherwise+              = rule_fvs+        -- See Note [extra_fvs (1): avoid floating into RHS]+        -- 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++    [shared_binds, extra_binds, rhs_binds, body_binds]+        = sepBindsByDropPoint platform False+            [extra_fvs, rhs_fvs, body_fvs2]+            to_drop++        -- Push rhs_binds into the right hand side of the binding+    rhs'     = fiRhs platform rhs_binds id ann_rhs+    rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs+                        -- Don't forget the rule_fvs; the binding mentions them!++fiBind platform to_drop (AnnRec bindings) body_fvs+  = ( extra_binds ++ shared_binds+    , FB (mkDVarSet ids) rhs_fvs'+         (FloatLet (Rec (fi_bind rhss_binds bindings)))+    , body_binds )+  where+    (ids, rhss) = unzip bindings+    rhss_fvs = map freeVarsOf rhss++        -- See Note [extra_fvs (1,2)]+    rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids+    extra_fvs = rule_fvs `unionDVarSet`+                unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings+                              , noFloatIntoRhs Recursive bndr rhs ]++    (shared_binds:extra_binds:body_binds:rhss_binds)+        = sepBindsByDropPoint platform False+            (extra_fvs:body_fvs:rhss_fvs)+            to_drop++    rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`+               unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`+               rule_fvs         -- Don't forget the rule variables!++    -- Push rhs_binds into the right hand side of the binding+    fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss+            -> [(Id, CoreExprWithFVs)]+            -> [(Id, CoreExpr)]++    fi_bind to_drops pairs+      = [ (binder, fiRhs platform to_drop binder rhs)+        | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]++------------------+fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr+fiRhs platform to_drop bndr rhs+  | Just join_arity <- isJoinId_maybe bndr+  , let (bndrs, body) = collectNAnnBndrs join_arity rhs+  = mkLams bndrs (fiExpr platform to_drop body)+  | otherwise+  = fiExpr platform to_drop rhs++------------------+noFloatIntoLam :: [Var] -> Bool+noFloatIntoLam bndrs = any bad bndrs+  where+    bad b = isId b && not (isOneShotBndr b)+    -- Don't float inside a non-one-shot lambda++noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool+-- ^ True if it's a bad idea to float bindings into this RHS+noFloatIntoRhs is_rec bndr rhs+  | isJoinId bndr+  = isRec is_rec -- Joins are one-shot iff non-recursive++  | otherwise+  = noFloatIntoArg rhs (idType bndr)++noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool+noFloatIntoArg expr expr_ty+  | isUnliftedType expr_ty+  = True  -- See Note [Do not destroy the let/app invariant]++   | AnnLam bndr e <- expr+   , (bndrs, _) <- collectAnnBndrs e+   =  noFloatIntoLam (bndr:bndrs)  -- Wrinkle 1 (a)+   || all isTyVar (bndr:bndrs)     -- Wrinkle 1 (b)+      -- See Note [noFloatInto considerations] wrinkle 2++  | otherwise  -- Note [noFloatInto considerations] wrinkle 2+  = exprIsTrivial deann_expr || exprIsHNF deann_expr+  where+    deann_expr = deAnnotate' expr++{- Note [noFloatInto considerations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When do we want to float bindings into+   - noFloatIntoRHs: the RHS of a let-binding+   - noFloatIntoArg: the argument of a function application++Definitely don't float in if it has unlifted type; that+would destroy the let/app invariant.++* Wrinkle 1: do not float in if+     (a) any non-one-shot value lambdas+  or (b) all type lambdas+  In both cases we'll float straight back out again+  NB: Must line up with fiExpr (AnnLam...); see #7088++  (a) is important: we /must/ float into a one-shot lambda group+  (which includes join points). This makes a big difference+  for things like+     f x# = let x = I# x#+            in let j = \() -> ...x...+               in if <condition> then normal-path else j ()+  If x is used only in the error case join point, j, we must float the+  boxing constructor into it, else we box it every time which is very+  bad news indeed.++* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right+  back out again... not tragic, but a waste of time.++  For function arguments we will still end up with this+  in-then-out stuff; consider+    letrec x = e in f x+  Here x is not a HNF, so we'll produce+    f (letrec x = e in x)+  which is OK... it's not that common, and we'll end up+  floating out again, in CorePrep if not earlier.+  Still, we use exprIsTrivial to catch this case (sigh)+++************************************************************************+*                                                                      *+\subsection{@sepBindsByDropPoint@}+*                                                                      *+************************************************************************++This is the crucial function.  The idea is: We have a wad of bindings+that we'd like to distribute inside a collection of {\em drop points};+insides the alternatives of a \tr{case} would be one example of some+drop points; the RHS and body of a non-recursive \tr{let} binding+would be another (2-element) collection.++So: We're given a list of sets-of-free-variables, one per drop point,+and a list of floating-inwards bindings.  If a binding can go into+only one drop point (without suddenly making something out-of-scope),+in it goes.  If a binding is used inside {\em multiple} drop points,+then it has to go in a you-must-drop-it-above-all-these-drop-points+point.++We have to maintain the order on these drop-point-related lists.+-}++-- pprFIB :: FloatInBinds -> SDoc+-- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]++sepBindsByDropPoint+    :: Platform+    -> Bool                -- True <=> is case expression+    -> [FreeVarSet]        -- One set of FVs per drop point+                           -- Always at least two long!+    -> FloatInBinds        -- Candidate floaters+    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated+                           -- inside any drop point; the rest correspond+                           -- one-to-one with the input list of FV sets++-- Every input floater is returned somewhere in the result;+-- none are dropped, not even ones which don't seem to be+-- free in *any* of the drop-point fvs.  Why?  Because, for example,+-- a binding (let x = E in B) might have a specialised version of+-- x (say x') stored inside x, but x' isn't free in E or B.++type DropBox = (FreeVarSet, FloatInBinds)++sepBindsByDropPoint platform is_case drop_pts floaters+  | null floaters  -- Shortcut common case+  = [] : [[] | _ <- drop_pts]++  | otherwise+  = ASSERT( drop_pts `lengthAtLeast` 2 )+    go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))+  where+    n_alts = length drop_pts++    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]+        -- The *first* one in the argument list is the drop_here set+        -- The FloatInBinds in the lists are in the reverse of+        -- the normal FloatInBinds order; that is, they are the right way round!++    go [] drop_boxes = map (reverse . snd) drop_boxes++    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)+        = go binds new_boxes+        where+          -- "here" means the group of bindings dropped at the top of the fork++          (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs+                                        | (fvs, _) <- drop_boxes]++          drop_here = used_here || cant_push++          n_used_alts = count id used_in_flags -- returns number of Trues in list.++          cant_push+            | is_case   = n_used_alts == n_alts   -- Used in all, don't push+                                                  -- Remember n_alts > 1+                          || (n_used_alts > 1 && not (floatIsDupable platform bind))+                             -- floatIsDupable: see Note [Duplicating floats]++            | otherwise = floatIsCase bind || n_used_alts > 1+                             -- floatIsCase: see Note [Floating primops]++          new_boxes | drop_here = (insert here_box : fork_boxes)+                    | otherwise = (here_box : new_fork_boxes)++          new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe+                                        fork_boxes used_in_flags++          insert :: DropBox -> DropBox+          insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops)++          insert_maybe box True  = insert box+          insert_maybe box False = box++    go _ _ = panic "sepBindsByDropPoint/go"+++{- 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+     let x = I# y in+     case e of+       C -> error x+       D -> error x+       E -> ...not mentioning x...++If the thing is used in all RHSs there is nothing gained,+so we don't duplicate then.+-}++floatedBindsFVs :: FloatInBinds -> FreeVarSet+floatedBindsFVs binds = mapUnionDVarSet fbFVs binds++fbFVs :: FloatInBind -> DVarSet+fbFVs (FB _ fvs _) = fvs++wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr+-- Remember FloatInBinds is in *reverse* dependency order+wrapFloats []               e = e+wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)++floatIsDupable :: Platform -> FloatBind -> Bool+floatIsDupable platform (FloatCase scrut _ _ _) = exprIsDupable platform scrut+floatIsDupable platform (FloatLet (Rec prs))    = all (exprIsDupable platform . snd) prs+floatIsDupable platform (FloatLet (NonRec _ r)) = exprIsDupable platform r++floatIsCase :: FloatBind -> Bool+floatIsCase (FloatCase {}) = True+floatIsCase (FloatLet {})  = False
+ compiler/GHC/Core/Op/FloatOut.hs view
@@ -0,0 +1,757 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[FloatOut]{Float bindings outwards (towards the top level)}++``Long-distance'' floating of bindings towards the top level.+-}++{-# LANGUAGE CPP #-}++module GHC.Core.Op.FloatOut ( floatOutwards ) where++import GhcPrelude++import GHC.Core+import GHC.Core.Utils+import GHC.Core.Make+import GHC.Core.Arity    ( etaExpand )+import GHC.Core.Op.Monad ( FloatOutSwitches(..) )++import GHC.Driver.Session+import ErrUtils          ( dumpIfSet_dyn, DumpFormat (..) )+import GHC.Types.Id      ( Id, idArity, idType, isBottomingId,+                           isJoinId, isJoinId_maybe )+import GHC.Core.Op.SetLevels+import GHC.Types.Unique.Supply ( UniqSupply )+import Bag+import Util+import Maybes+import Outputable+import GHC.Core.Type+import qualified Data.IntMap as M++import Data.List        ( partition )++#include "HsVersions.h"++{-+        -----------------+        Overall game plan+        -----------------++The Big Main Idea is:++        To float out sub-expressions that can thereby get outside+        a non-one-shot value lambda, and hence may be shared.+++To achieve this we may need to do two things:++   a) Let-bind the sub-expression:++        f (g x)  ==>  let lvl = f (g x) in lvl++      Now we can float the binding for 'lvl'.++   b) More than that, we may need to abstract wrt a type variable++        \x -> ... /\a -> let v = ...a... in ....++      Here the binding for v mentions 'a' but not 'x'.  So we+      abstract wrt 'a', to give this binding for 'v':++            vp = /\a -> ...a...+            v  = vp a++      Now the binding for vp can float out unimpeded.+      I can't remember why this case seemed important enough to+      deal with, but I certainly found cases where important floats+      didn't happen if we did not abstract wrt tyvars.++With this in mind we can also achieve another goal: lambda lifting.+We can make an arbitrary (function) binding float to top level by+abstracting wrt *all* local variables, not just type variables, leaving+a binding that can be floated right to top level.  Whether or not this+happens is controlled by a flag.+++Random comments+~~~~~~~~~~~~~~~++At the moment we never float a binding out to between two adjacent+lambdas.  For example:++@+        \x y -> let t = x+x in ...+===>+        \x -> let t = x+x in \y -> ...+@+Reason: this is less efficient in the case where the original lambda+is never partially applied.++But there's a case I've seen where this might not be true.  Consider:+@+elEm2 x ys+  = elem' x ys+  where+    elem' _ []  = False+    elem' x (y:ys)      = x==y || elem' x ys+@+It turns out that this generates a subexpression of the form+@+        \deq x ys -> let eq = eqFromEqDict deq in ...+@+which might usefully be separated to+@+        \deq -> let eq = eqFromEqDict deq in \xy -> ...+@+Well, maybe.  We don't do this at the moment.++Note [Join points]+~~~~~~~~~~~~~~~~~~+Every occurrence of a join point must be a tail call (see Note [Invariants on+join points] in GHC.Core), so we must be careful with how far we float them. The+mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling]+in GHC.Core.Op.SetLevels. For us, the significance is that a binder might be marked to be+dropped at the nearest boundary between tail calls and non-tail calls. For+example:++  (< join j = ... in+     let x = < ... > in+     case < ... > of+       A -> ...+       B -> ...+   >) < ... > < ... >++Here the join ceilings are marked with angle brackets. Either side of an+application is a join ceiling, as is the scrutinee position of a case+expression or the RHS of a let binding (but not a join point).++Why do we *want* do float join points at all? After all, they're never+allocated, so there's no sharing to be gained by floating them. However, the+other benefit of floating is making RHSes small, and this can have a significant+impact. In particular, stream fusion has been known to produce nested loops like+this:++  joinrec j1 x1 =+    joinrec j2 x2 =+      joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...+      in jump j3 x2+    in jump j2 x1+  in jump j1 x++(Assume x1 and x2 do *not* occur free in j3.)++Here j1 and j2 are wholly superfluous---each of them merely forwards its+argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make+everything one big mutual recursion:++  joinrec j1 x1 = jump j2 x1+          j2 x2 = jump j3 x2+          j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...+  in jump j1 x++Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.+Without floating, we're stuck with three loops instead of one.++************************************************************************+*                                                                      *+\subsection[floatOutwards]{@floatOutwards@: let-floating interface function}+*                                                                      *+************************************************************************+-}++floatOutwards :: FloatOutSwitches+              -> DynFlags+              -> UniqSupply+              -> CoreProgram -> IO CoreProgram++floatOutwards float_sws dflags us pgm+  = do {+        let { annotated_w_levels = setLevels float_sws pgm us ;+              (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)+            } ;++        dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"+                  FormatCore+                  (vcat (map ppr annotated_w_levels));++        let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };++        dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"+                FormatText+                (hcat [ int tlets,  text " Lets floated to top level; ",+                        int ntlets, text " Lets floated elsewhere; from ",+                        int lams,   text " Lambda groups"]);++        return (bagToList (unionManyBags binds_s'))+    }++floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind)+floatTopBind bind+  = case (floatBind bind) of { (fs, floats, bind') ->+    let float_bag = flattenTopFloats floats+    in case bind' of+      -- bind' can't have unlifted values or join points, so can only be one+      -- value bind, rec or non-rec (see comment on floatBind)+      [Rec prs]    -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))+      [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e)+      _            -> pprPanic "floatTopBind" (ppr bind') }++{-+************************************************************************+*                                                                      *+\subsection[FloatOut-Bind]{Floating in a binding (the business end)}+*                                                                      *+************************************************************************+-}++floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind])+  -- Returns a list with either+  --   * A single non-recursive binding (value or join point), or+  --   * The following, in order:+  --     * Zero or more non-rec unlifted bindings+  --     * One or both of:+  --       * A recursive group of join binds+  --       * A recursive group of value binds+  -- See Note [Floating out of Rec rhss] for why things get arranged this way.+floatBind (NonRec (TB var _) rhs)+  = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') ->++        -- A tiresome hack:+        -- see Note [Bottoming floats: eta expansion] in GHC.Core.Op.SetLevels+    let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'+              | otherwise         = rhs'++    in (fs, rhs_floats, [NonRec var rhs'']) }++floatBind (Rec pairs)+  = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->+    let (new_ul_pairss, new_other_pairss) = unzip new_pairs+        (new_join_pairs, new_l_pairs)     = partition (isJoinId . fst)+                                                      (concat new_other_pairss)+        -- Can't put the join points and the values in the same rec group+        new_rec_binds | null new_join_pairs = [ Rec new_l_pairs    ]+                      | null new_l_pairs    = [ Rec new_join_pairs ]+                      | otherwise           = [ Rec new_l_pairs+                                              , Rec new_join_pairs ]+        new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ]+    in+    (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) }+  where+    do_pair :: (LevelledBndr, LevelledExpr)+            -> (FloatStats, FloatBinds,+                ([(Id,CoreExpr)],  -- Non-recursive unlifted value bindings+                 [(Id,CoreExpr)])) -- Join points and lifted value bindings+    do_pair (TB name spec, rhs)+      | isTopLvl dest_lvl  -- See Note [floatBind for top level]+      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->+        (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats)+                                                [(name, rhs')]))}+      | otherwise         -- Note [Floating out of Rec rhss]+      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->+        case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) ->+        case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) ->+        let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in+        (fs, rhs_floats', (ul_pairs, pairs')) }}}+      where+        dest_lvl = floatSpecLevel spec++splitRecFloats :: Bag FloatBind+               -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings+                   [(Id,CoreExpr)], -- Join points and lifted value bindings+                   Bag FloatBind)   -- A tail of further bindings+-- The "tail" begins with a case+-- See Note [Floating out of Rec rhss]+splitRecFloats fs+  = go [] [] (bagToList fs)+  where+    go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)+                                               , not (isJoinId b)+                                               = go ((b,r):ul_prs) prs fs+                                               | otherwise+                                               = go ul_prs ((b,r):prs) fs+    go ul_prs prs (FloatLet (Rec prs')   : fs) = go ul_prs (prs' ++ prs) fs+    go ul_prs prs fs                           = (reverse ul_prs, prs,+                                                  listToBag fs)+                                                   -- Order only matters for+                                                   -- non-rec++installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr+-- Note [Floating out of Rec rhss]+installUnderLambdas floats e+  | isEmptyBag floats = e+  | otherwise         = go e+  where+    go (Lam b e)                 = Lam b (go e)+    go e                         = install floats e++---------------+floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])+floatList _ [] = (zeroStats, emptyFloats, [])+floatList f (a:as) = case f a            of { (fs_a,  binds_a,  b)  ->+                     case floatList f as of { (fs_as, binds_as, bs) ->+                     (fs_a `add_stats` fs_as, binds_a `plusFloats`  binds_as, b:bs) }}++{-+Note [Floating out of Rec rhss]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   Rec { f<1,0> = \xy. body }+From the body we may get some floats. The ones with level <1,0> must+stay here, since they may mention f.  Ideally we'd like to make them+part of the Rec block pairs -- but we can't if there are any+FloatCases involved.++Nor is it a good idea to dump them in the rhs, but outside the lambda+    f = case x of I# y -> \xy. body+because now f's arity might get worse, which is Not Good. (And if+there's an SCC around the RHS it might not get better again.+See #5342.)++So, gruesomely, we split the floats into+ * the outer FloatLets, which can join the Rec, and+ * an inner batch starting in a FloatCase, which are then+   pushed *inside* the lambdas.+This loses full-laziness the rare situation where there is a+FloatCase and a Rec interacting.++If there are unlifted FloatLets (that *aren't* join points) among the floats,+we can't add them to the recursive group without angering Core Lint, but since+they must be ok-for-speculation, they can't actually be making any recursive+calls, so we can safely pull them out and keep them non-recursive.++(Why is something getting floated to <1,0> that doesn't make a recursive call?+The case that came up in testing was that f *and* the unlifted binding were+getting floated *to the same place*:++  \x<2,0> ->+    ... <3,0>+    letrec { f<F<2,0>> =+      ... let x'<F<2,0>> = x +# 1# in ...+    } in ...++Everything gets labeled "float to <2,0>" because it all depends on x, but this+makes f and x' look mutually recursive when they're not.++The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the+wip/join-points branch.++TODO: This can probably be solved somehow in GHC.Core.Op.SetLevels. The difference between+"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very+important.)++Note [floatBind for top level]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus+         letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... }+The binding for bar will be in the "tops" part of the floating binds,+and thus not partioned by floatBody.++We could perhaps get rid of the 'tops' component of the floating binds,+but this case works just as well.+++************************************************************************++\subsection[FloatOut-Expr]{Floating in expressions}+*                                                                      *+************************************************************************+-}++floatBody :: Level+          -> LevelledExpr+          -> (FloatStats, FloatBinds, CoreExpr)++floatBody lvl arg       -- Used rec rhss, and case-alternative rhss+  = case (floatExpr arg) of { (fsa, floats, arg') ->+    case (partitionByLevel lvl floats) of { (floats', heres) ->+        -- Dump bindings are bound here+    (fsa, floats', install heres arg') }}++-----------------++{- Note [Floating past breakpoints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We used to disallow floating out of breakpoint ticks (see #10052). However, I+think this is too restrictive.++Consider the case of an expression scoped over by a breakpoint tick,++  tick<...> (let x = ... in f x)++In this case it is completely legal to float out x, despite the fact that+breakpoint ticks are scoped,++  let x = ... in (tick<...>  f x)++The reason here is that we know that the breakpoint will still be hit when the+expression is entered since the tick still scopes over the RHS.++-}++floatExpr :: LevelledExpr+          -> (FloatStats, FloatBinds, CoreExpr)+floatExpr (Var v)   = (zeroStats, emptyFloats, Var v)+floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty)+floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co)+floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)++floatExpr (App e a)+  = case (atJoinCeiling $ floatExpr  e) of { (fse, floats_e, e') ->+    case (atJoinCeiling $ floatExpr  a) of { (fsa, floats_a, a') ->+    (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}++floatExpr lam@(Lam (TB _ lam_spec) _)+  = let (bndrs_w_lvls, body) = collectBinders lam+        bndrs                = [b | TB b _ <- bndrs_w_lvls]+        bndr_lvl             = asJoinCeilLvl (floatSpecLevel lam_spec)+        -- All the binders have the same level+        -- See GHC.Core.Op.SetLevels.lvlLamBndrs+        -- Use asJoinCeilLvl to make this the join ceiling+    in+    case (floatBody bndr_lvl body) of { (fs, floats, body') ->+    (add_to_stats fs floats, floats, mkLams bndrs body') }++floatExpr (Tick tickish expr)+  | tickish `tickishScopesLike` SoftScope -- not scoped, can just float+  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->+    (fs, floating_defns, Tick tickish expr') }++  | not (tickishCounts tickish) || tickishCanSplit tickish+  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->+    let -- Annotate bindings floated outwards past an scc expression+        -- with the cc.  We mark that cc as "duplicated", though.+        annotated_defns = wrapTick (mkNoCount tickish) floating_defns+    in+    (fs, annotated_defns, Tick tickish expr') }++  -- Note [Floating past breakpoints]+  | Breakpoint{} <- tickish+  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->+    (fs, floating_defns, Tick tickish expr') }++  | otherwise+  = pprPanic "floatExpr tick" (ppr tickish)++floatExpr (Cast expr co)+  = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->+    (fs, floating_defns, Cast expr' co) }++floatExpr (Let bind body)+  = case bind_spec of+      FloatMe dest_lvl+        -> case (floatBind bind) of { (fsb, bind_floats, binds') ->+           case (floatExpr body) of { (fse, body_floats, body') ->+           let new_bind_floats = foldr plusFloats emptyFloats+                                   (map (unitLetFloat dest_lvl) binds') in+           ( add_stats fsb fse+           , bind_floats `plusFloats` new_bind_floats+                         `plusFloats` body_floats+           , body') }}++      StayPut bind_lvl  -- See Note [Avoiding unnecessary floating]+        -> case (floatBind bind)          of { (fsb, bind_floats, binds') ->+           case (floatBody bind_lvl body) of { (fse, body_floats, body') ->+           ( add_stats fsb fse+           , bind_floats `plusFloats` body_floats+           , foldr Let body' binds' ) }}+  where+    bind_spec = case bind of+                 NonRec (TB _ s) _     -> s+                 Rec ((TB _ s, _) : _) -> s+                 Rec []                -> panic "floatExpr:rec"++floatExpr (Case scrut (TB case_bndr case_spec) ty alts)+  = case case_spec of+      FloatMe dest_lvl  -- Case expression moves+        | [(con@(DataAlt {}), bndrs, rhs)] <- alts+        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->+           case                 floatExpr rhs   of { (fsb, fdb, rhs') ->+           let+             float = unitCaseFloat dest_lvl scrut'+                          case_bndr con [b | TB b _ <- bndrs]+           in+           (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }}+        | otherwise+        -> pprPanic "Floating multi-case" (ppr alts)++      StayPut bind_lvl  -- Case expression stays put+        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->+           case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts')  ->+           (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')+           }}+  where+    float_alt bind_lvl (con, bs, rhs)+        = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->+          (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }++floatRhs :: CoreBndr+         -> LevelledExpr+         -> (FloatStats, FloatBinds, CoreExpr)+floatRhs bndr rhs+  | Just join_arity <- isJoinId_maybe bndr+  , Just (bndrs, body) <- try_collect join_arity rhs []+  = case bndrs of+      []                -> floatExpr rhs+      (TB _ lam_spec):_ ->+        let lvl = floatSpecLevel lam_spec in+        case floatBody lvl body of { (fs, floats, body') ->+        (fs, floats, mkLams [b | TB b _ <- bndrs] body') }+  | otherwise+  = atJoinCeiling $ floatExpr rhs+  where+    try_collect 0 expr      acc = Just (reverse acc, expr)+    try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc)+    try_collect _ _         _   = Nothing++{-+Note [Avoiding unnecessary floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we want to avoid floating a let unnecessarily, because+it might worsen strictness:+    let+       x = ...(let y = e in y+y)....+Here y is demanded.  If we float it outside the lazy 'x=..' then+we'd have to zap its demand info, and it may never be restored.++So at a 'let' we leave the binding right where the are unless+the binding will escape a value lambda, e.g.++(\x -> let y = fac 100 in y)++That's what the partitionByMajorLevel does in the floatExpr (Let ...)+case.++Notice, though, that we must take care to drop any bindings+from the body of the let that depend on the staying-put bindings.++We used instead to do the partitionByMajorLevel on the RHS of an '=',+in floatRhs.  But that was quite tiresome.  We needed to test for+values or trivial rhss, because (in particular) we don't want to insert+new bindings between the "=" and the "\".  E.g.+        f = \x -> let <bind> in <body>+We do not want+        f = let <bind> in \x -> <body>+(a) The simplifier will immediately float it further out, so we may+        as well do so right now; in general, keeping rhss as manifest+        values is good+(b) If a float-in pass follows immediately, it might add yet more+        bindings just after the '='.  And some of them might (correctly)+        be strict even though the 'let f' is lazy, because f, being a value,+        gets its demand-info zapped by the simplifier.+And even all that turned out to be very fragile, and broke+altogether when profiling got in the way.++So now we do the partition right at the (Let..) itself.++************************************************************************+*                                                                      *+\subsection{Utility bits for floating stats}+*                                                                      *+************************************************************************++I didn't implement this with unboxed numbers.  I don't want to be too+strict in this stuff, as it is rarely turned on.  (WDP 95/09)+-}++data FloatStats+  = FlS Int  -- Number of top-floats * lambda groups they've been past+        Int  -- Number of non-top-floats * lambda groups they've been past+        Int  -- Number of lambda (groups) seen++get_stats :: FloatStats -> (Int, Int, Int)+get_stats (FlS a b c) = (a, b, c)++zeroStats :: FloatStats+zeroStats = FlS 0 0 0++sum_stats :: [FloatStats] -> FloatStats+sum_stats xs = foldr add_stats zeroStats xs++add_stats :: FloatStats -> FloatStats -> FloatStats+add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)+  = FlS (a1 + a2) (b1 + b2) (c1 + c2)++add_to_stats :: FloatStats -> FloatBinds -> FloatStats+add_to_stats (FlS a b c) (FB tops ceils others)+  = FlS (a + lengthBag tops)+        (b + lengthBag ceils + lengthBag (flattenMajor others))+        (c + 1)++{-+************************************************************************+*                                                                      *+\subsection{Utility bits for floating}+*                                                                      *+************************************************************************++Note [Representation of FloatBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The FloatBinds types is somewhat important.  We can get very large numbers+of floating bindings, often all destined for the top level.  A typical example+is     x = [4,2,5,2,5, .... ]+Then we get lots of small expressions like (fromInteger 4), which all get+lifted to top level.++The trouble is that+  (a) we partition these floating bindings *at every binding site*+  (b) GHC.Core.Op.SetLevels introduces a new bindings site for every float+So we had better not look at each binding at each binding site!++That is why MajorEnv is represented as a finite map.++We keep the bindings destined for the *top* level separate, because+we float them out even if they don't escape a *value* lambda; see+partitionByMajorLevel.+-}++type FloatLet = CoreBind        -- INVARIANT: a FloatLet is always lifted+type MajorEnv = M.IntMap MinorEnv         -- Keyed by major level+type MinorEnv = M.IntMap (Bag FloatBind)  -- Keyed by minor level++data FloatBinds  = FB !(Bag FloatLet)           -- Destined for top level+                      !(Bag FloatBind)          -- Destined for join ceiling+                      !MajorEnv                 -- Other levels+     -- See Note [Representation of FloatBinds]++instance Outputable FloatBinds where+  ppr (FB fbs ceils defs)+      = text "FB" <+> (braces $ vcat+           [ text "tops ="     <+> ppr fbs+           , text "ceils ="    <+> ppr ceils+           , text "non-tops =" <+> ppr defs ])++flattenTopFloats :: FloatBinds -> Bag CoreBind+flattenTopFloats (FB tops ceils defs)+  = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )+    ASSERT2( isEmptyBag ceils, ppr ceils )+    tops++addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]+addTopFloatPairs float_bag prs+  = foldr add prs float_bag+  where+    add (NonRec b r) prs  = (b,r):prs+    add (Rec prs1)   prs2 = prs1 ++ prs2++flattenMajor :: MajorEnv -> Bag FloatBind+flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag++flattenMinor :: MinorEnv -> Bag FloatBind+flattenMinor = M.foldr unionBags emptyBag++emptyFloats :: FloatBinds+emptyFloats = FB emptyBag emptyBag M.empty++unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds+unitCaseFloat (Level major minor t) e b con bs+  | t == JoinCeilLvl+  = FB emptyBag floats M.empty+  | otherwise+  = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats))+  where+    floats = unitBag (FloatCase e b con bs)++unitLetFloat :: Level -> FloatLet -> FloatBinds+unitLetFloat lvl@(Level major minor t) b+  | isTopLvl lvl     = FB (unitBag b) emptyBag M.empty+  | t == JoinCeilLvl = FB emptyBag floats M.empty+  | otherwise        = FB emptyBag emptyBag (M.singleton major+                                              (M.singleton minor floats))+  where+    floats = unitBag (FloatLet b)++plusFloats :: FloatBinds -> FloatBinds -> FloatBinds+plusFloats (FB t1 c1 l1) (FB t2 c2 l2)+  = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)++plusMajor :: MajorEnv -> MajorEnv -> MajorEnv+plusMajor = M.unionWith plusMinor++plusMinor :: MinorEnv -> MinorEnv -> MinorEnv+plusMinor = M.unionWith unionBags++install :: Bag FloatBind -> CoreExpr -> CoreExpr+install defn_groups expr+  = foldr wrapFloat expr defn_groups++partitionByLevel+        :: Level                -- Partitioning level+        -> FloatBinds           -- Defns to be divided into 2 piles...+        -> (FloatBinds,         -- Defns  with level strictly < partition level,+            Bag FloatBind)      -- The rest++{-+--       ---- partitionByMajorLevel ----+-- Float it if we escape a value lambda,+--     *or* if we get to the top level+--     *or* if it's a case-float and its minor level is < current+--+-- If we can get to the top level, say "yes" anyway. This means that+--      x = f e+-- transforms to+--    lvl = e+--    x = f lvl+-- which is as it should be++partitionByMajorLevel (Level major _) (FB tops defns)+  = (FB tops outer, heres `unionBags` flattenMajor inner)+  where+    (outer, mb_heres, inner) = M.splitLookup major defns+    heres = case mb_heres of+               Nothing -> emptyBag+               Just h  -> flattenMinor h+-}++partitionByLevel (Level major minor typ) (FB tops ceils defns)+  = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min),+     here_min `unionBags` here_ceil+              `unionBags` flattenMinor inner_min+              `unionBags` flattenMajor inner_maj)++  where+    (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns+    (outer_min, mb_here_min, inner_min) = case mb_here_maj of+                                            Nothing -> (M.empty, Nothing, M.empty)+                                            Just min_defns -> M.splitLookup minor min_defns+    here_min = mb_here_min `orElse` emptyBag+    (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag)+                        | otherwise          = (emptyBag, ceils)++-- Like partitionByLevel, but instead split out the bindings that are marked+-- to float to the nearest join ceiling (see Note [Join points])+partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind)+partitionAtJoinCeiling (FB tops ceils defs)+  = (FB tops emptyBag defs, ceils)++-- Perform some action at a join ceiling, i.e., don't let join points float out+-- (see Note [Join points])+atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr)+              -> (FloatStats, FloatBinds, CoreExpr)+atJoinCeiling (fs, floats, expr')+  = (fs, floats', install ceils expr')+  where+    (floats', ceils) = partitionAtJoinCeiling floats++wrapTick :: Tickish Id -> FloatBinds -> FloatBinds+wrapTick t (FB tops ceils defns)+  = FB (mapBag wrap_bind tops) (wrap_defns ceils)+       (M.map (M.map wrap_defns) defns)+  where+    wrap_defns = mapBag wrap_one++    wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)+    wrap_bind (Rec pairs)         = Rec (mapSnd maybe_tick pairs)++    wrap_one (FloatLet bind)      = FloatLet (wrap_bind bind)+    wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs++    maybe_tick e | exprIsHNF e = tickHNFArgs t e+                 | otherwise   = mkTick t e+      -- we don't need to wrap a tick around an HNF when we float it+      -- outside a tick: that is an invariant of the tick semantics+      -- Conversely, inlining of HNFs inside an SCC is allowed, and+      -- indeed the HNF we're floating here might well be inlined back+      -- again, and we don't want to end up with duplicate ticks.
+ compiler/GHC/Core/Op/LiberateCase.hs view
@@ -0,0 +1,442 @@+{-+(c) The AQUA Project, Glasgow University, 1994-1998++\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}+-}++{-# LANGUAGE CPP #-}+module GHC.Core.Op.LiberateCase ( liberateCase ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Driver.Session+import GHC.Core+import GHC.Core.Unfold  ( couldBeSmallEnoughToInline )+import TysWiredIn       ( unitDataConId )+import GHC.Types.Id+import GHC.Types.Var.Env+import Util             ( notNull )++{-+The liberate-case transformation+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module walks over @Core@, and looks for @case@ on free variables.+The criterion is:+        if there is case on a free on the route to the recursive call,+        then the recursive call is replaced with an unfolding.++Example++   f = \ t -> case v of+                 V a b -> a : f t++=> the inner f is replaced.++   f = \ t -> case v of+                 V a b -> a : (letrec+                                f =  \ t -> case v of+                                               V a b -> a : f t+                               in f) t+(note the NEED for shadowing)++=> Simplify++  f = \ t -> case v of+                 V a b -> a : (letrec+                                f = \ t -> a : f t+                               in f t)++Better code, because 'a' is  free inside the inner letrec, rather+than needing projection from v.++Note that this deals with *free variables*.  SpecConstr deals with+*arguments* that are of known form.  E.g.++        last []     = error+        last (x:[]) = x+        last (x:xs) = last xs+++Note [Scrutinee with cast]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+    f = \ t -> case (v `cast` co) of+                 V a b -> a : f t++Exactly the same optimisation (unrolling one call to f) will work here,+despite the cast.  See mk_alt_env in the Case branch of libCase.+++To think about (Apr 94)+~~~~~~~~~~~~~~+Main worry: duplicating code excessively.  At the moment we duplicate+the entire binding group once at each recursive call.  But there may+be a group of recursive calls which share a common set of evaluated+free variables, in which case the duplication is a plain waste.++Another thing we could consider adding is some unfold-threshold thing,+so that we'll only duplicate if the size of the group rhss isn't too+big.++Data types+~~~~~~~~~~+The ``level'' of a binder tells how many+recursive defns lexically enclose the binding+A recursive defn "encloses" its RHS, not its+scope.  For example:+\begin{verbatim}+        letrec f = let g = ... in ...+        in+        let h = ...+        in ...+\end{verbatim}+Here, the level of @f@ is zero, the level of @g@ is one,+and the level of @h@ is zero (NB not one).+++************************************************************************+*                                                                      *+         Top-level code+*                                                                      *+************************************************************************+-}++liberateCase :: DynFlags -> CoreProgram -> CoreProgram+liberateCase dflags binds = do_prog (initEnv dflags) binds+  where+    do_prog _   [] = []+    do_prog env (bind:binds) = bind' : do_prog env' binds+                             where+                               (env', bind') = libCaseBind env bind++{-+************************************************************************+*                                                                      *+         Main payload+*                                                                      *+************************************************************************++Bindings+~~~~~~~~+-}++libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)++libCaseBind env (NonRec binder rhs)+  = (addBinders env [binder], NonRec binder (libCase env rhs))++libCaseBind env (Rec pairs)+  = (env_body, Rec pairs')+  where+    binders = map fst pairs++    env_body = addBinders env binders++    pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]++        -- We extend the rec-env by binding each Id to its rhs, first+        -- processing the rhs with an *un-extended* environment, so+        -- that the same process doesn't occur for ever!+    env_rhs | is_dupable_bind = addRecBinds env dup_pairs+            | otherwise       = env++    dup_pairs = [ (localiseId binder, libCase env_body rhs)+                | (binder, rhs) <- pairs ]+        -- localiseID : see Note [Need to localiseId in libCaseBind]++    is_dupable_bind = small_enough && all ok_pair pairs++    -- Size: we are going to duplicate dup_pairs; to find their+    --       size, build a fake binding (let { dup_pairs } in (),+    --       and find the size of that+    -- See Note [Small enough]+    small_enough = case bombOutSize env of+                      Nothing   -> True   -- Infinity+                      Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $+                                   Let (Rec dup_pairs) (Var unitDataConId)++    ok_pair (id,_)+        =  idArity id > 0          -- Note [Only functions!]+        && not (isBottomingId id)  -- Note [Not bottoming ids]++{- Note [Not bottoming Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do not specialise error-functions (this is unusual, but I once saw it,+(actually in Data.Typable.Internal)++Note [Only functions!]+~~~~~~~~~~~~~~~~~~~~~~+Consider the following code++       f = g (case v of V a b -> a : t f)++where g is expensive. If we aren't careful, liberate case will turn this into++       f = g (case v of+               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)+                                in f)+             )++Yikes! We evaluate g twice. This leads to a O(2^n) explosion+if g calls back to the same code recursively.++Solution: make sure that we only do the liberate-case thing on *functions*++Note [Small enough]+~~~~~~~~~~~~~~~~~~~+Consider+  \fv. letrec+         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...+         g = \y. SMALL...f...++Then we *can* in principle do liberate-case on 'g' (small RHS) but not+for 'f' (too big).  But doing so is not profitable, because duplicating+'g' at its call site in 'f' doesn't get rid of any cases.  So we just+ask for the whole group to be small enough.++Note [Need to localiseId in libCaseBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The call to localiseId is needed for two subtle reasons+(a)  Reset the export flags on the binders so+        that we don't get name clashes on exported things if the+        local binding floats out to top level.  This is most unlikely+        to happen, since the whole point concerns free variables.+        But resetting the export flag is right regardless.++(b)  Make the name an Internal one.  External Names should never be+        nested; if it were floated to the top level, we'd get a name+        clash at code generation time.++Expressions+~~~~~~~~~~~+-}++libCase :: LibCaseEnv+        -> CoreExpr+        -> CoreExpr++libCase env (Var v)             = libCaseApp env v []+libCase _   (Lit lit)           = Lit lit+libCase _   (Type ty)           = Type ty+libCase _   (Coercion co)       = Coercion co+libCase env e@(App {})          | let (fun, args) = collectArgs e+                                , Var v <- fun+                                = libCaseApp env v args+libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)+libCase env (Tick tickish body) = Tick tickish (libCase env body)+libCase env (Cast e co)         = Cast (libCase env e) co++libCase env (Lam binder body)+  = Lam binder (libCase (addBinders env [binder]) body)++libCase env (Let bind body)+  = Let bind' (libCase env_body body)+  where+    (env_body, bind') = libCaseBind env bind++libCase env (Case scrut bndr ty alts)+  = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)+  where+    env_alts = addBinders (mk_alt_env scrut) [bndr]+    mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var+    mk_alt_env (Cast scrut _)  = mk_alt_env scrut       -- Note [Scrutinee with cast]+    mk_alt_env _               = env++libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)+                         -> (AltCon, [CoreBndr], CoreExpr)+libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)++{-+Ids+~~~++To unfold, we can't just wrap the id itself in its binding if it's a join point:++  jump j a b c  =>  (joinrec j x y z = ... in jump j) a b c -- wrong!!!++Every jump must provide all arguments, so we have to be careful to wrap the+whole jump instead:++  jump j a b c  =>  joinrec j x y z = ... in jump j a b c -- right++-}++libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr+libCaseApp env v args+  | Just the_bind <- lookupRecId env v  -- It's a use of a recursive thing+  , notNull free_scruts                 -- with free vars scrutinised in RHS+  = Let the_bind expr'++  | otherwise+  = expr'++  where+    rec_id_level = lookupLevel env v+    free_scruts  = freeScruts env rec_id_level+    expr'        = mkApps (Var v) (map (libCase env) args)++freeScruts :: LibCaseEnv+           -> LibCaseLevel      -- Level of the recursive Id+           -> [Id]              -- Ids that are scrutinised between the binding+                                -- of the recursive Id and here+freeScruts env rec_bind_lvl+  = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env+       , scrut_bind_lvl <= rec_bind_lvl+       , scrut_at_lvl > rec_bind_lvl]+        -- Note [When to specialise]+        -- Note [Avoiding fruitless liberate-case]++{-+Note [When to specialise]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f = \x. letrec g = \y. case x of+                           True  -> ... (f a) ...+                           False -> ... (g b) ...++We get the following levels+          f  0+          x  1+          g  1+          y  2++Then 'x' is being scrutinised at a deeper level than its binding, so+it's added to lc_sruts:  [(x,1)]++We do *not* want to specialise the call to 'f', because 'x' is not free+in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).++We *do* want to specialise the call to 'g', because 'x' is free in g.+Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).++Note [Avoiding fruitless liberate-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider also:+  f = \x. case top_lvl_thing of+                I# _ -> let g = \y. ... g ...+                        in ...++Here, top_lvl_thing is scrutinised at a level (1) deeper than its+binding site (0).  Nevertheless, we do NOT want to specialise the call+to 'g' because all the structure in its free variables is already+visible at the definition site for g.  Hence, when considering specialising+an occurrence of 'g', we want to check that there's a scruted-var v st++   a) v's binding site is *outside* g+   b) v's scrutinisation site is *inside* g+++************************************************************************+*                                                                      *+        Utility functions+*                                                                      *+************************************************************************+-}++addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv+addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders+  = env { lc_lvl_env = lvl_env' }+  where+    lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)++addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv+addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env,+                             lc_rec_env = rec_env}) pairs+  = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' }+  where+    lvl'     = lvl + 1+    lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]+    rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]++addScrutedVar :: LibCaseEnv+              -> Id             -- This Id is being scrutinised by a case expression+              -> LibCaseEnv++addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,+                                lc_scruts = scruts }) scrut_var+  | bind_lvl < lvl+  = env { lc_scruts = scruts' }+        -- Add to scruts iff the scrut_var is being scrutinised at+        -- a deeper level than its defn++  | otherwise = env+  where+    scruts'  = (scrut_var, bind_lvl, lvl) : scruts+    bind_lvl = case lookupVarEnv lvl_env scrut_var of+                 Just lvl -> lvl+                 Nothing  -> topLevel++lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind+lookupRecId env id = lookupVarEnv (lc_rec_env env) id++lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel+lookupLevel env id+  = case lookupVarEnv (lc_lvl_env env) id of+      Just lvl -> lvl+      Nothing  -> topLevel++{-+************************************************************************+*                                                                      *+         The environment+*                                                                      *+************************************************************************+-}++type LibCaseLevel = Int++topLevel :: LibCaseLevel+topLevel = 0++data LibCaseEnv+  = LibCaseEnv {+        lc_dflags :: DynFlags,++        lc_lvl :: LibCaseLevel, -- Current level+                -- The level is incremented when (and only when) going+                -- inside the RHS of a (sufficiently small) recursive+                -- function.++        lc_lvl_env :: IdEnv LibCaseLevel,+                -- Binds all non-top-level in-scope Ids (top-level and+                -- imported things have a level of zero)++        lc_rec_env :: IdEnv CoreBind,+                -- Binds *only* recursively defined ids, to their own+                -- binding group, and *only* in their own RHSs++        lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]+                -- Each of these Ids was scrutinised by an enclosing+                -- case expression, at a level deeper than its binding+                -- level.+                --+                -- The first LibCaseLevel is the *binding level* of+                --   the scrutinised Id,+                -- The second is the level *at which it was scrutinised*.+                --   (see Note [Avoiding fruitless liberate-case])+                -- The former is a bit redundant, since you could always+                -- look it up in lc_lvl_env, but it's just cached here+                --+                -- The order is insignificant; it's a bag really+                --+                -- There's one element per scrutinisation;+                --    in principle the same Id may appear multiple times,+                --    although that'd be unusual:+                --       case x of { (a,b) -> ....(case x of ...) .. }+        }++initEnv :: DynFlags -> LibCaseEnv+initEnv dflags+  = LibCaseEnv { lc_dflags = dflags,+                 lc_lvl = 0,+                 lc_lvl_env = emptyVarEnv,+                 lc_rec_env = emptyVarEnv,+                 lc_scruts = [] }++-- Bomb-out size for deciding if+-- potential liberatees are too big.+-- (passed in from cmd-line args)+bombOutSize :: LibCaseEnv -> Maybe Int+bombOutSize = liberateCaseThreshold . lc_dflags
+ compiler/GHC/Core/Op/SetLevels.hs view
@@ -0,0 +1,1771 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section{GHC.Core.Op.SetLevels}++                ***************************+                        Overview+                ***************************++1. We attach binding levels to Core bindings, in preparation for floating+   outwards (@FloatOut@).++2. We also let-ify many expressions (notably case scrutinees), so they+   will have a fighting chance of being floated sensible.++3. Note [Need for cloning during float-out]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   We clone the binders of any floatable let-binding, so that when it is+   floated out it will be unique. Example+      (let x=2 in x) + (let x=3 in x)+   we must clone before floating so we get+      let x1=2 in+      let x2=3 in+      x1+x2++   NOTE: this can't be done using the uniqAway idea, because the variable+         must be unique in the whole program, not just its current scope,+         because two variables in different scopes may float out to the+         same top level place++   NOTE: Very tiresomely, we must apply this substitution to+         the rules stored inside a variable too.++   We do *not* clone top-level bindings, because some of them must not change,+   but we *do* clone bindings that are heading for the top level++4. Note [Binder-swap during float-out]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   In the expression+        case x of wild { p -> ...wild... }+   we substitute x for wild in the RHS of the case alternatives:+        case x of wild { p -> ...x... }+   This means that a sub-expression involving x is not "trapped" inside the RHS.+   And it's not inconvenient because we already have a substitution.++  Note that this is EXACTLY BACKWARDS from the what the simplifier does.+  The simplifier tries to get rid of occurrences of x, in favour of wild,+  in the hope that there will only be one remaining occurrence of x, namely+  the scrutinee of the case, and we can inline it.+-}++{-# LANGUAGE CPP, MultiWayIf #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+module GHC.Core.Op.SetLevels (+        setLevels,++        Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,+        LevelledBind, LevelledExpr, LevelledBndr,+        FloatSpec(..), floatSpecLevel,++        incMinorLvl, ltMajLvl, ltLvl, isTopLvl+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core+import GHC.Core.Op.Monad ( FloatOutSwitches(..) )+import GHC.Core.Utils   ( exprType, exprIsHNF+                        , exprOkForSpeculation+                        , exprIsTopLevelBindable+                        , isExprLevPoly+                        , collectMakeStaticArgs+                        )+import GHC.Core.Arity   ( exprBotStrictness_maybe )+import GHC.Core.FVs     -- all of it+import GHC.Core.Subst+import GHC.Core.Make    ( sortQuantVars )++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Unique.Set   ( nonDetFoldUniqSet )+import GHC.Types.Unique.DSet  ( getUniqDSet )+import GHC.Types.Var.Env+import GHC.Types.Literal      ( litIsTrivial )+import GHC.Types.Demand       ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )+import GHC.Types.Cpr          ( mkCprSig, botCpr )+import GHC.Types.Name         ( getOccName, mkSystemVarName )+import GHC.Types.Name.Occurrence ( occNameString )+import GHC.Core.Type    ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType+                        , mightBeUnliftedType, closeOverKindsDSet )+import GHC.Types.Basic  ( Arity, RecFlag(..), isRec )+import GHC.Core.DataCon ( dataConOrigResTy )+import TysWiredIn+import GHC.Types.Unique.Supply+import Util+import Outputable+import FastString+import GHC.Types.Unique.DFM+import FV+import Data.Maybe+import MonadUtils       ( mapAccumLM )++{-+************************************************************************+*                                                                      *+\subsection{Level numbers}+*                                                                      *+************************************************************************+-}++type LevelledExpr = TaggedExpr FloatSpec+type LevelledBind = TaggedBind FloatSpec+type LevelledBndr = TaggedBndr FloatSpec++data Level = Level Int  -- Level number of enclosing lambdas+                   Int  -- Number of big-lambda and/or case expressions and/or+                        -- context boundaries between+                        -- here and the nearest enclosing lambda+                   LevelType -- Binder or join ceiling?+data LevelType = BndrLvl | JoinCeilLvl deriving (Eq)++data FloatSpec+  = FloatMe Level       -- Float to just inside the binding+                        --    tagged with this level+  | StayPut Level       -- Stay where it is; binding is+                        --     tagged with this level++floatSpecLevel :: FloatSpec -> Level+floatSpecLevel (FloatMe l) = l+floatSpecLevel (StayPut l) = l++{-+The {\em level number} on a (type-)lambda-bound variable is the+nesting depth of the (type-)lambda which binds it.  The outermost lambda+has level 1, so (Level 0 0) means that the variable is bound outside any lambda.++On an expression, it's the maximum level number of its free+(type-)variables.  On a let(rec)-bound variable, it's the level of its+RHS.  On a case-bound variable, it's the number of enclosing lambdas.++Top-level variables: level~0.  Those bound on the RHS of a top-level+definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown+as ``subscripts'')...+\begin{verbatim}+a_0 = let  b_? = ...  in+           x_1 = ... b ... in ...+\end{verbatim}++The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@).+That's meant to be the level number of the enclosing binder in the+final (floated) program.  If the level number of a sub-expression is+less than that of the context, then it might be worth let-binding the+sub-expression so that it will indeed float.++If you can float to level @Level 0 0@ worth doing so because then your+allocation becomes static instead of dynamic.  We always start with+context @Level 0 0@.+++Note [FloatOut inside INLINE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:+to say "don't float anything out of here".  That's exactly what we+want for the body of an INLINE, where we don't want to float anything+out at all.  See notes with lvlMFE below.++But, check this out:++-- At one time I tried the effect of not floating anything out of an InlineMe,+-- but it sometimes works badly.  For example, consider PrelArr.done.  It+-- has the form         __inline (\d. e)+-- where e doesn't mention d.  If we float this to+--      __inline (let x = e in \d. x)+-- things are bad.  The inliner doesn't even inline it because it doesn't look+-- like a head-normal form.  So it seems a lesser evil to let things float.+-- In GHC.Core.Op.SetLevels we do set the context to (Level 0 0) when we get to an InlineMe+-- which discourages floating out.++So the conclusion is: don't do any floating at all inside an InlineMe.+(In the above example, don't float the {x=e} out of the \d.)++One particular case is that of workers: we don't want to float the+call to the worker outside the wrapper, otherwise the worker might get+inlined into the floated expression, and an importing module won't see+the worker at all.++Note [Join ceiling]+~~~~~~~~~~~~~~~~~~~+Join points can't float very far; too far, and they can't remain join points+So, suppose we have:++  f x = (joinrec j y = ... x ... in jump j x) + 1++One may be tempted to float j out to the top of f's RHS, but then the jump+would not be a tail call. Thus we keep track of a level called the *join+ceiling* past which join points are not allowed to float.++The troublesome thing is that, unlike most levels to which something might+float, there is not necessarily an identifier to which the join ceiling is+attached. Fortunately, if something is to be floated to a join ceiling, it must+be dropped at the *nearest* join ceiling. Thus each level is marked as to+whether it is a join ceiling, so that FloatOut can tell which binders are being+floated to the nearest join ceiling and which to a particular binder (or set of+binders).+-}++instance Outputable FloatSpec where+  ppr (FloatMe l) = char 'F' <> ppr l+  ppr (StayPut l) = ppr l++tOP_LEVEL :: Level+tOP_LEVEL   = Level 0 0 BndrLvl++incMajorLvl :: Level -> Level+incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl++incMinorLvl :: Level -> Level+incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl++asJoinCeilLvl :: Level -> Level+asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl++maxLvl :: Level -> Level -> Level+maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)+  | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1+  | otherwise                                      = l2++ltLvl :: Level -> Level -> Bool+ltLvl (Level maj1 min1 _) (Level maj2 min2 _)+  = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)++ltMajLvl :: Level -> Level -> Bool+    -- Tells if one level belongs to a difft *lambda* level to another+ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2++isTopLvl :: Level -> Bool+isTopLvl (Level 0 0 _) = True+isTopLvl _             = False++isJoinCeilLvl :: Level -> Bool+isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl++instance Outputable Level where+  ppr (Level maj min typ)+    = hcat [ char '<', int maj, char ',', int min, char '>'+           , ppWhen (typ == JoinCeilLvl) (char 'C') ]++instance Eq Level where+  (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2++{-+************************************************************************+*                                                                      *+\subsection{Main level-setting code}+*                                                                      *+************************************************************************+-}++setLevels :: FloatOutSwitches+          -> CoreProgram+          -> UniqSupply+          -> [LevelledBind]++setLevels float_lams binds us+  = initLvl us (do_them init_env binds)+  where+    init_env = initialEnv float_lams++    do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]+    do_them _ [] = return []+    do_them env (b:bs)+      = do { (lvld_bind, env') <- lvlTopBind env b+           ; lvld_binds <- do_them env' bs+           ; return (lvld_bind : lvld_binds) }++lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)+lvlTopBind env (NonRec bndr rhs)+  = do { rhs' <- lvl_top env NonRecursive bndr rhs+       ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]+       ; return (NonRec bndr' rhs', env') }++lvlTopBind env (Rec pairs)+  = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL+                                               (map fst pairs)+       ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs+       ; return (Rec (bndrs' `zip` rhss'), env') }++lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr+lvl_top env is_rec bndr rhs+  = lvlRhs env is_rec+           (isBottomingId bndr)+           Nothing  -- Not a join point+           (freeVars rhs)++{-+************************************************************************+*                                                                      *+\subsection{Setting expression levels}+*                                                                      *+************************************************************************++Note [Floating over-saturated applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see (f x y), and (f x) is a redex (ie f's arity is 1),+we call (f x) an "over-saturated application"++Should we float out an over-sat app, if can escape a value lambda?+It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).+But we don't want to do it for class selectors, because the work saved+is minimal, and the extra local thunks allocated cost money.++Arguably we could float even class-op applications if they were going to+top level -- but then they must be applied to a constant dictionary and+will almost certainly be optimised away anyway.+-}++lvlExpr :: LevelEnv             -- Context+        -> CoreExprWithFVs      -- Input expression+        -> LvlM LevelledExpr    -- Result expression++{-+The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing+binder.  Here's an example++        v = \x -> ...\y -> let r = case (..x..) of+                                        ..x..+                           in ..++When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's+the level of @r@, even though it's inside a level-2 @\y@.  It's+important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we+don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE+--- because it isn't a *maximal* free expression.++If there were another lambda in @r@'s rhs, it would get level-2 as well.+-}++lvlExpr env (_, AnnType ty)     = return (Type (GHC.Core.Subst.substTy (le_subst env) ty))+lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))+lvlExpr env (_, AnnVar v)       = return (lookupVar env v)+lvlExpr _   (_, AnnLit lit)     = return (Lit lit)++lvlExpr env (_, AnnCast expr (_, co)) = do+    expr' <- lvlNonTailExpr env expr+    return (Cast expr' (substCo (le_subst env) co))++lvlExpr env (_, AnnTick tickish expr) = do+    expr' <- lvlNonTailExpr env expr+    let tickish' = substTickish (le_subst env) tickish+    return (Tick tickish' expr')++lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr)++-- We don't split adjacent lambdas.  That is, given+--      \x y -> (x+1,y)+-- we don't float to give+--      \x -> let v = x+1 in \y -> (v,y)+-- Why not?  Because partial applications are fairly rare, and splitting+-- lambdas makes them more expensive.++lvlExpr env expr@(_, AnnLam {})+  = do { new_body <- lvlNonTailMFE new_env True body+       ; return (mkLams new_bndrs new_body) }+  where+    (bndrs, body)        = collectAnnBndrs expr+    (env1, bndrs1)       = substBndrsSL NonRecursive env bndrs+    (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1+        -- At one time we called a special version of collectBinders,+        -- which ignored coercions, because we don't want to split+        -- a lambda like this (\x -> coerce t (\s -> ...))+        -- This used to happen quite a bit in state-transformer programs,+        -- but not nearly so much now non-recursive newtypes are transparent.+        -- [See GHC.Core.Op.SetLevels rev 1.50 for a version with this approach.]++lvlExpr env (_, AnnLet bind body)+  = do { (bind', new_env) <- lvlBind env bind+       ; body' <- lvlExpr new_env body+           -- No point in going via lvlMFE here.  If the binding is alive+           -- (mentioned in body), and the whole let-expression doesn't+           -- float, then neither will the body+       ; return (Let bind' body') }++lvlExpr env (_, AnnCase scrut case_bndr ty alts)+  = do { scrut' <- lvlNonTailMFE env True scrut+       ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }++lvlNonTailExpr :: LevelEnv             -- Context+               -> CoreExprWithFVs      -- Input expression+               -> LvlM LevelledExpr    -- Result expression+lvlNonTailExpr env expr+  = lvlExpr (placeJoinCeiling env) expr++-------------------------------------------+lvlApp :: LevelEnv+       -> CoreExprWithFVs+       -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application+        -> LvlM LevelledExpr                   -- Result expression+lvlApp env orig_expr ((_,AnnVar fn), args)+  | floatOverSat env   -- See Note [Floating over-saturated applications]+  , arity > 0+  , arity < n_val_args+  , Nothing <- isClassOpId_maybe fn+  =  do { rargs' <- mapM (lvlNonTailMFE env False) rargs+        ; lapp'  <- lvlNonTailMFE env False lapp+        ; return (foldl' App lapp' rargs') }++  | otherwise+  = do { (_, args') <- mapAccumLM lvl_arg stricts args+            -- Take account of argument strictness; see+            -- Note [Floating to the top]+       ; return (foldl' App (lookupVar env fn) args') }+  where+    n_val_args = count (isValArg . deAnnotate) args+    arity      = idArity fn++    stricts :: [Demand]   -- True for strict /value/ arguments+    stricts = case splitStrictSig (idStrictness fn) of+                (arg_ds, _) | arg_ds `lengthExceeds` n_val_args+                            -> []+                            | otherwise+                            -> arg_ds++    -- Separate out the PAP that we are floating from the extra+    -- arguments, by traversing the spine until we have collected+    -- (n_val_args - arity) value arguments.+    (lapp, rargs) = left (n_val_args - arity) orig_expr []++    left 0 e               rargs = (e, rargs)+    left n (_, AnnApp f a) rargs+       | isValArg (deAnnotate a) = left (n-1) f (a:rargs)+       | otherwise               = left n     f (a:rargs)+    left _ _ _                   = panic "GHC.Core.Op.SetLevels.lvlExpr.left"++    is_val_arg :: CoreExprWithFVs -> Bool+    is_val_arg (_, AnnType {}) = False+    is_val_arg _               = True++    lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)+    lvl_arg strs arg | (str1 : strs') <- strs+                     , is_val_arg arg+                     = do { arg' <- lvlMFE env (isStrictDmd str1) arg+                          ; return (strs', arg') }+                     | otherwise+                     = do { arg' <- lvlMFE env False arg+                          ; return (strs, arg') }++lvlApp env _ (fun, args)+  =  -- No PAPs that we can float: just carry on with the+     -- arguments and the function.+     do { args' <- mapM (lvlNonTailMFE env False) args+        ; fun'  <- lvlNonTailExpr env fun+        ; return (foldl' App fun' args') }++-------------------------------------------+lvlCase :: LevelEnv             -- Level of in-scope names/tyvars+        -> DVarSet              -- Free vars of input scrutinee+        -> LevelledExpr         -- Processed scrutinee+        -> Id -> Type           -- Case binder and result type+        -> [CoreAltWithFVs]     -- Input alternatives+        -> LvlM LevelledExpr    -- Result expression+lvlCase env scrut_fvs scrut' case_bndr ty alts+  -- See Note [Floating single-alternative cases]+  | [(con@(DataAlt {}), bs, body)] <- alts+  , exprIsHNF (deTagExpr scrut')  -- See Note [Check the output scrutinee for exprIsHNF]+  , not (isTopLvl dest_lvl)       -- Can't have top-level cases+  , not (floatTopLvlOnly env)     -- Can float anywhere+  =     -- Always float the case if possible+        -- Unlike lets we don't insist that it escapes a value lambda+    do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)+       ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'+       ; body' <- lvlMFE rhs_env True body+       ; let alt' = (con, map (stayPut dest_lvl) bs', body')+       ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }++  | otherwise     -- Stays put+  = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]+             alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'+       ; alts' <- mapM (lvl_alt alts_env) alts+       ; return (Case scrut' case_bndr' ty' alts') }+  where+    ty' = substTy (le_subst env) ty++    incd_lvl = incMinorLvl (le_ctxt_lvl env)+    dest_lvl = maxFvLevel (const True) env scrut_fvs+            -- Don't abstract over type variables, hence const True++    lvl_alt alts_env (con, bs, rhs)+      = do { rhs' <- lvlMFE new_env True rhs+           ; return (con, bs', rhs') }+      where+        (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs++{- Note [Floating single-alternative cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+  data T a = MkT !a+  f :: T Int -> blah+  f x vs = case x of { MkT y ->+             let f vs = ...(case y of I# w -> e)...f..+             in f vs++Here we can float the (case y ...) out, because y is sure+to be evaluated, to give+  f x vs = case x of { MkT y ->+           case y of I# w ->+             let f vs = ...(e)...f..+             in f vs++That saves unboxing it every time round the loop.  It's important in+some DPH stuff where we really want to avoid that repeated unboxing in+the inner loop.++Things to note:++ * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation.++     - exrpIsHNF catches the key case of an evaluated variable++     - exprOkForSpeculation is /false/ of an evaluated variable;+       See Note [exprOkForSpeculation and evaluated variables] in GHC.Core.Utils+       So we'd actually miss the key case!++     - Nothing is gained from the extra generality of exprOkForSpeculation+       since we only consider floating a case whose single alternative+       is a DataAlt   K a b -> rhs++ * We can't float a case to top level++ * It's worth doing this float even if we don't float+   the case outside a value lambda.  Example+     case x of {+       MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)+   If we floated the cases out we could eliminate one of them.++ * We only do this with a single-alternative case+++Note [Setting levels when floating single-alternative cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Handling level-setting when floating a single-alternative case binding+is a bit subtle, as evidenced by #16978.  In particular, we must keep+in mind that we are merely moving the case and its binders, not the+body. For example, suppose 'a' is known to be evaluated and we have++  \z -> case a of+          (x,_) -> <body involving x and z>++After floating we may have:++  case a of+    (x,_) -> \z -> <body involving x and z>+      {- some expression involving x and z -}++When analysing <body involving...> we want to use the /ambient/ level,+and /not/ the destination level of the 'case a of (x,-) ->' binding.++#16978 was caused by us setting the context level to the destination+level of `x` when analysing <body>. This led us to conclude that we+needed to quantify over some of its free variables (e.g. z), resulting+in shadowing and very confusing Core Lint failures.+++Note [Check the output scrutinee for exprIsHNF]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+  case x of y {+    A -> ....(case y of alts)....+  }++Because of the binder-swap, the inner case will get substituted to+(case x of ..).  So when testing whether the scrutinee is in HNF we+must be careful to test the *result* scrutinee ('x' in this case), not+the *input* one 'y'.  The latter *is* in HNF here (because y is+evaluated), but the former is not -- and indeed we can't float the+inner case out, at least not unless x is also evaluated at its binding+site.  See #5453.++That's why we apply exprIsHNF to scrut' and not to scrut.++See Note [Floating single-alternative cases] for why+we use exprIsHNF in the first place.+-}++lvlNonTailMFE :: LevelEnv             -- Level of in-scope names/tyvars+              -> Bool                 -- True <=> strict context [body of case+                                      --   or let]+              -> CoreExprWithFVs      -- input expression+              -> LvlM LevelledExpr    -- Result expression+lvlNonTailMFE env strict_ctxt ann_expr+  = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr++lvlMFE ::  LevelEnv             -- Level of in-scope names/tyvars+        -> Bool                 -- True <=> strict context [body of case or let]+        -> CoreExprWithFVs      -- input expression+        -> LvlM LevelledExpr    -- Result expression+-- lvlMFE is just like lvlExpr, except that it might let-bind+-- the expression, so that it can itself be floated.++lvlMFE env _ (_, AnnType ty)+  = return (Type (GHC.Core.Subst.substTy (le_subst env) ty))++-- No point in floating out an expression wrapped in a coercion or note+-- If we do we'll transform  lvl = e |> co+--                       to  lvl' = e; lvl = lvl' |> co+-- and then inline lvl.  Better just to float out the payload.+lvlMFE env strict_ctxt (_, AnnTick t e)+  = do { e' <- lvlMFE env strict_ctxt e+       ; let t' = substTickish (le_subst env) t+       ; return (Tick t' e') }++lvlMFE env strict_ctxt (_, AnnCast e (_, co))+  = do  { e' <- lvlMFE env strict_ctxt e+        ; return (Cast e' (substCo (le_subst env) co)) }++lvlMFE env strict_ctxt e@(_, AnnCase {})+  | strict_ctxt       -- Don't share cases in a strict context+  = lvlExpr env e     -- See Note [Case MFEs]++lvlMFE env strict_ctxt ann_expr+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)+         -- Only floating to the top level is allowed.+  || anyDVarSet isJoinId fvs   -- If there is a free join, don't float+                               -- See Note [Free join points]+  || isExprLevPoly expr+         -- We can't let-bind levity polymorphic expressions+         -- See Note [Levity polymorphism invariants] in GHC.Core+  || notWorthFloating expr abs_vars+  || not float_me+  =     -- Don't float it out+    lvlExpr env ann_expr++  |  float_is_new_lam || exprIsTopLevelBindable expr expr_ty+         -- No wrapping needed if the type is lifted, or is a literal string+         -- or if we are wrapping it in one or more value lambdas+  = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive+                              (isJust mb_bot_str)+                              join_arity_maybe+                              ann_expr+                  -- Treat the expr just like a right-hand side+       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static+       ; let var2 = annotateBotStr var float_n_lams mb_bot_str+       ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)+                     (mkVarApps (Var var2) abs_vars)) }++  -- OK, so the float has an unlifted type (not top-level bindable)+  --     and no new value lambdas (float_is_new_lam is False)+  -- Try for the boxing strategy+  -- See Note [Floating MFEs of unlifted type]+  | escapes_value_lam+  , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions+                         -- See Note [Test cheapness with exprOkForSpeculation]+  , Just (tc, _) <- splitTyConApp_maybe expr_ty+  , Just dc <- boxingDataCon_maybe tc+  , let dc_res_ty = dataConOrigResTy dc  -- No free type variables+        [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty]+  = do { expr1 <- lvlExpr rhs_env ann_expr+       ; let l1r       = incMinorLvlFrom rhs_env+             float_rhs = mkLams abs_vars_w_lvls $+                         Case expr1 (stayPut l1r ubx_bndr) dc_res_ty+                             [(DEFAULT, [], mkConApp dc [Var ubx_bndr])]++       ; var <- newLvlVar float_rhs Nothing is_mk_static+       ; let l1u      = incMinorLvlFrom env+             use_expr = Case (mkVarApps (Var var) abs_vars)+                             (stayPut l1u bx_bndr) expr_ty+                             [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)]+       ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)+                     use_expr) }++  | otherwise          -- e.g. do not float unboxed tuples+  = lvlExpr env ann_expr++  where+    expr         = deAnnotate ann_expr+    expr_ty      = exprType expr+    fvs          = freeVarsOf ann_expr+    fvs_ty       = tyCoVarsOfType expr_ty+    is_bot       = isBottomThunk mb_bot_str+    is_function  = isFunction ann_expr+    mb_bot_str   = exprBotStrictness_maybe expr+                           -- See Note [Bottoming floats]+                           -- esp Bottoming floats (2)+    expr_ok_for_spec = exprOkForSpeculation expr+    dest_lvl     = destLevel env fvs fvs_ty is_function is_bot False+    abs_vars     = abstractVars dest_lvl env fvs++    -- float_is_new_lam: the floated thing will be a new value lambda+    -- replacing, say (g (x+4)) by (lvl x).  No work is saved, nor is+    -- allocation saved.  The benefit is to get it to the top level+    -- and hence out of the body of this function altogether, making+    -- it smaller and more inlinable+    float_is_new_lam = float_n_lams > 0+    float_n_lams     = count isId abs_vars++    (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars++    join_arity_maybe = Nothing++    is_mk_static = isJust (collectMakeStaticArgs expr)+        -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable++        -- A decision to float entails let-binding this thing, and we only do+        -- that if we'll escape a value lambda, or will go to the top level.+    float_me = saves_work || saves_alloc || is_mk_static++    -- We can save work if we can move a redex outside a value lambda+    -- But if float_is_new_lam is True, then the redex is wrapped in a+    -- a new lambda, so no work is saved+    saves_work = escapes_value_lam && not float_is_new_lam++    escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)+                  -- See Note [Escaping a value lambda]++    -- See Note [Floating to the top]+    saves_alloc =  isTopLvl dest_lvl+                && floatConsts env+                && (not strict_ctxt || is_bot || exprIsHNF expr)++isBottomThunk :: Maybe (Arity, s) -> Bool+-- See Note [Bottoming floats] (2)+isBottomThunk (Just (0, _)) = True   -- Zero arity+isBottomThunk _             = False++{- Note [Floating to the top]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are keen to float something to the top level, even if it does not+escape a value lambda (and hence save work), for two reasons:++  * Doing so makes the function smaller, by floating out+    bottoming expressions, or integer or string literals.  That in+    turn makes it easier to inline, with less duplication.++  * (Minor) Doing so may turn a dynamic allocation (done by machine+    instructions) into a static one. Minor because we are assuming+    we are not escaping a value lambda.++But do not so if:+     - the context is a strict, and+     - the expression is not a HNF, and+     - the expression is not bottoming++Exammples:++* Bottoming+      f x = case x of+              0 -> error <big thing>+              _ -> x+1+  Here we want to float (error <big thing>) to top level, abstracting+  over 'x', so as to make f's RHS smaller.++* HNF+      f = case y of+            True  -> p:q+            False -> blah+  We may as well float the (p:q) so it becomes a static data structure.++* Case scrutinee+      f = case g True of ....+  Don't float (g True) to top level; then we have the admin of a+  top-level thunk to worry about, with zero gain.++* Case alternative+      h = case y of+             True  -> g True+             False -> False+  Don't float (g True) to the top level++* Arguments+     t = f (g True)+  If f is lazy, we /do/ float (g True) because then we can allocate+  the thunk statically rather than dynamically.  But if f is strict+  we don't (see the use of idStrictness in lvlApp).  It's not clear+  if this test is worth the bother: it's only about CAFs!++It's controlled by a flag (floatConsts), because doing this too+early loses opportunities for RULES which (needless to say) are+important in some nofib programs (gcd is an example).  [SPJ note:+I think this is obsolete; the flag seems always on.]++Note [Floating join point bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Mostly we only float a join point if it can /stay/ a join point.  But+there is one exception: if it can go to the top level (#13286).+Consider+  f x = joinrec j y n = <...j y' n'...>+        in jump j x 0++Here we may just as well produce+  j y n = <....j y' n'...>+  f x = j x 0++and now there is a chance that 'f' will be inlined at its call sites.+It shouldn't make a lot of difference, but these tests+  perf/should_run/MethSharing+  simplCore/should_compile/spec-inline+and one nofib program, all improve if you do float to top, because+of the resulting inlining of f.  So ok, let's do it.++Note [Free join points]+~~~~~~~~~~~~~~~~~~~~~~~+We never float a MFE that has a free join-point variable.  You might think+this can never occur.  After all, consider+     join j x = ...+     in ....(jump j x)....+How might we ever want to float that (jump j x)?+  * If it would escape a value lambda, thus+        join j x = ... in (\y. ...(jump j x)... )+    then 'j' isn't a valid join point in the first place.++But consider+     join j x = .... in+     joinrec j2 y =  ...(jump j x)...(a+b)....++Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec.+But it is emphatically /not/ good to float the (jump j x) out:+ (a) 'j' will stop being a join point+ (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no+     work would be saved by floating it out of the \y.++Even if we floated 'j' to top level, (b) would still hold.++Bottom line: never float a MFE that has a free JoinId.++Note [Floating MFEs of unlifted type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   case f x of (r::Int#) -> blah+we'd like to float (f x). But it's not trivial because it has type+Int#, and we don't want to evaluate it too early.  But we can instead+float a boxed version+   y = case f x of r -> I# r+and replace the original (f x) with+   case (case y of I# r -> r) of r -> blah++Being able to float unboxed expressions is sometimes important; see+#12603.  I'm not sure how /often/ it is important, but it's+not hard to achieve.++We only do it for a fixed collection of types for which we have a+convenient boxing constructor (see boxingDataCon_maybe).  In+particular we /don't/ do it for unboxed tuples; it's better to float+the components of the tuple individually.++I did experiment with a form of boxing that works for any type, namely+wrapping in a function.  In our example++   let y = case f x of r -> \v. f x+   in case y void of r -> blah++It works fine, but it's 50% slower (based on some crude benchmarking).+I suppose we could do it for types not covered by boxingDataCon_maybe,+but it's more code and I'll wait to see if anyone wants it.++Note [Test cheapness with exprOkForSpeculation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't want to float very cheap expressions by boxing and unboxing.+But we use exprOkForSpeculation for the test, not exprIsCheap.+Why?  Because it's important /not/ to transform+     f (a /# 3)+to+     f (case bx of I# a -> a /# 3)+and float bx = I# (a /# 3), because the application of f no+longer obeys the let/app invariant.  But (a /# 3) is ok-for-spec+due to a special hack that says division operators can't fail+when the denominator is definitely non-zero.  And yet that+same expression says False to exprIsCheap.  Simplest way to+guarantee the let/app invariant is to use the same function!++If an expression is okay for speculation, we could also float it out+*without* boxing and unboxing, since evaluating it early is okay.+However, it turned out to usually be better not to float such expressions,+since they tend to be extremely cheap things like (x +# 1#). Even the+cost of spilling the let-bound variable to the stack across a call may+exceed the cost of recomputing such an expression. (And we can't float+unlifted bindings to top-level.)++We could try to do something smarter here, and float out expensive yet+okay-for-speculation things, such as division by non-zero constants.+But I suspect it's a narrow target.++Note [Bottoming floats]+~~~~~~~~~~~~~~~~~~~~~~~+If we see+        f = \x. g (error "urk")+we'd like to float the call to error, to get+        lvl = error "urk"+        f = \x. g lvl++But, as ever, we need to be careful:++(1) We want to float a bottoming+    expression even if it has free variables:+        f = \x. g (let v = h x in error ("urk" ++ v))+    Then we'd like to abstract over 'x' can float the whole arg of g:+        lvl = \x. let v = h x in error ("urk" ++ v)+        f = \x. g (lvl x)+    To achieve this we pass is_bot to destLevel++(2) We do not do this for lambdas that return+    bottom.  Instead we treat the /body/ of such a function specially,+    via point (1).  For example:+        f = \x. ....(\y z. if x then error y else error z)....+    ===>+        lvl = \x z y. if b then error y else error z+        f = \x. ...(\y z. lvl x z y)...+    (There is no guarantee that we'll choose the perfect argument order.)++(3) If we have a /binding/ that returns bottom, we want to float it to top+    level, even if it has free vars (point (1)), and even it has lambdas.+    Example:+       ... let { v = \y. error (show x ++ show y) } in ...+    We want to abstract over x and float the whole thing to top:+       lvl = \xy. errror (show x ++ show y)+       ...let {v = lvl x} in ...++    Then of course we don't want to separately float the body (error ...)+    as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot+    argument.++See Maessen's paper 1999 "Bottom extraction: factoring error handling out+of functional programs" (unpublished I think).++When we do this, we set the strictness and arity of the new bottoming+Id, *immediately*, for three reasons:++  * To prevent the abstracted thing being immediately inlined back in again+    via preInlineUnconditionally.  The latter has a test for bottoming Ids+    to stop inlining them, so we'd better make sure it *is* a bottoming Id!++  * So that it's properly exposed as such in the interface file, even if+    this is all happening after strictness analysis.++  * In case we do CSE with the same expression that *is* marked bottom+        lvl          = error "urk"+          x{str=bot) = error "urk"+    Here we don't want to replace 'x' with 'lvl', else we may get Lint+    errors, e.g. via a case with empty alternatives:  (case x of {})+    Lint complains unless the scrutinee of such a case is clearly bottom.++    This was reported in #11290.   But since the whole bottoming-float+    thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure+    that it'll nail all such cases.++Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tiresomely, though, the simplifier has an invariant that the manifest+arity of the RHS should be the same as the arity; but we can't call+etaExpand during GHC.Core.Op.SetLevels because it works over a decorated form of+CoreExpr.  So we do the eta expansion later, in GHC.Core.Op.FloatOut.++Note [Case MFEs]+~~~~~~~~~~~~~~~~+We don't float a case expression as an MFE from a strict context.  Why not?+Because in doing so we share a tiny bit of computation (the switch) but+in exchange we build a thunk, which is bad.  This case reduces allocation+by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.+Doesn't change any other allocation at all.++We will make a separate decision for the scrutinee and alternatives.++However this can have a knock-on effect for fusion: consider+    \v -> foldr k z (case x of I# y -> build ..y..)+Perhaps we can float the entire (case x of ...) out of the \v.  Then+fusion will not happen, but we will get more sharing.  But if we don't+float the case (as advocated here) we won't float the (build ...y..)+either, so fusion will happen.  It can be a big effect, esp in some+artificial benchmarks (e.g. integer, queens), but there is no perfect+answer.++-}++annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id+-- See Note [Bottoming floats] for why we want to add+-- bottoming information right now+--+-- n_extra are the number of extra value arguments added during floating+annotateBotStr id n_extra mb_str+  = case mb_str of+      Nothing           -> id+      Just (arity, sig) -> id `setIdArity`      (arity + n_extra)+                              `setIdStrictness` (increaseStrictSigArity n_extra sig)+                              `setIdCprInfo`    mkCprSig (arity + n_extra) botCpr++notWorthFloating :: CoreExpr -> [Var] -> Bool+-- Returns True if the expression would be replaced by+-- something bigger than it is now.  For example:+--   abs_vars = tvars only:  return True if e is trivial,+--                           but False for anything bigger+--   abs_vars = [x] (an Id): return True for trivial, or an application (f x)+--                           but False for (f x x)+--+-- One big goal is that floating should be idempotent.  Eg if+-- we replace e with (lvl79 x y) and then run FloatOut again, don't want+-- to replace (lvl79 x y) with (lvl83 x y)!++notWorthFloating e abs_vars+  = go e (count isId abs_vars)+  where+    go (Var {}) n    = n >= 0+    go (Lit lit) n   = ASSERT( n==0 )+                       litIsTrivial lit   -- Note [Floating literals]+    go (Tick t e) n  = not (tickishIsCode t) && go e n+    go (Cast e _)  n = go e n+    go (App e arg) n+       -- See Note [Floating applications to coercions]+       | Type {} <- arg = go e n+       | n==0           = False+       | is_triv arg    = go e (n-1)+       | otherwise      = False+    go _ _              = False++    is_triv (Lit {})              = True        -- Treat all literals as trivial+    is_triv (Var {})              = True        -- (ie not worth floating)+    is_triv (Cast e _)            = is_triv e+    is_triv (App e (Type {}))     = is_triv e   -- See Note [Floating applications to coercions]+    is_triv (Tick t e)            = not (tickishIsCode t) && is_triv e+    is_triv _                     = False++{-+Note [Floating literals]+~~~~~~~~~~~~~~~~~~~~~~~~+It's important to float Integer literals, so that they get shared,+rather than being allocated every time round the loop.+Hence the litIsTrivial.++Ditto literal strings (LitString), which we'd like to float to top+level, which is now possible.++Note [Floating applications to coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don’t float out variables applied only to type arguments, since the+extra binding would be pointless: type arguments are completely erased.+But *coercion* arguments aren’t (see Note [Coercion tokens] in+CoreToStg.hs and Note [Count coercion arguments in boring contexts] in+CoreUnfold.hs), so we still want to float out variables applied only to+coercion arguments.++Note [Escaping a value lambda]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to float even cheap expressions out of value lambdas,+because that saves allocation.  Consider+        f = \x.  .. (\y.e) ...+Then we'd like to avoid allocating the (\y.e) every time we call f,+(assuming e does not mention x). An example where this really makes a+difference is simplrun009.++Another reason it's good is because it makes SpecContr fire on functions.+Consider+        f = \x. ....(f (\y.e))....+After floating we get+        lvl = \y.e+        f = \x. ....(f lvl)...+and that is much easier for SpecConstr to generate a robust+specialisation for.++However, if we are wrapping the thing in extra value lambdas (in+abs_vars), then nothing is saved.  E.g.+        f = \xyz. ...(e1[y],e2)....+If we float+        lvl = \y. (e1[y],e2)+        f = \xyz. ...(lvl y)...+we have saved nothing: one pair will still be allocated for each+call of 'f'.  Hence the (not float_is_lam) in float_me.+++************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************++The binding stuff works for top level too.+-}++lvlBind :: LevelEnv+        -> CoreBindWithFVs+        -> LvlM (LevelledBind, LevelEnv)++lvlBind env (AnnNonRec bndr rhs)+  | isTyVar bndr    -- Don't do anything for TyVar binders+                    --   (simplifier gets rid of them pronto)+  || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)+                    -- so we will ignore this case for now+  || not (profitableFloat env dest_lvl)+  || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))+          -- We can't float an unlifted binding to top level (except+          -- literal strings), so we don't float it at all.  It's a+          -- bit brutal, but unlifted bindings aren't expensive either++  = -- No float+    do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs+       ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)+              (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]+       ; return (NonRec bndr' rhs', env') }++  -- Otherwise we are going to float+  | null abs_vars+  = do {  -- No type abstraction; clone existing binder+         rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive+                             is_bot mb_join_arity rhs+       ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]+       ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str+       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }++  | otherwise+  = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc+         rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive+                             is_bot mb_join_arity rhs+       ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]+       ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str+       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }++  where+    bndr_ty    = idType bndr+    ty_fvs     = tyCoVarsOfType bndr_ty+    rhs_fvs    = freeVarsOf rhs+    bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr+    abs_vars   = abstractVars dest_lvl env bind_fvs+    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join++    deann_rhs  = deAnnotate rhs+    mb_bot_str = exprBotStrictness_maybe deann_rhs+    is_bot     = isJust mb_bot_str+        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)++    n_extra    = count isId abs_vars+    mb_join_arity = isJoinId_maybe bndr+    is_join       = isJust mb_join_arity++lvlBind env (AnnRec pairs)+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)+         -- Only floating to the top level is allowed.+  || not (profitableFloat env dest_lvl)+  || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs)+       -- This mightBeUnliftedType stuff is the same test as in the non-rec case+       -- You might wonder whether we can have a recursive binding for+       -- an unlifted value -- but we can if it's a /join binding/ (#16978)+       -- (Ultimately I think we should not use GHC.Core.Op.SetLevels to+       -- float join bindings at all, but that's another story.)+  =    -- No float+    do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)+             (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs+             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r+       ; rhss' <- mapM lvl_rhs pairs+       ; return (Rec (bndrs' `zip` rhss'), env') }++  -- Otherwise we are going to float+  | null abs_vars+  = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs+       ; new_rhss <- mapM (do_rhs new_env) pairs+       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)+                , new_env) }++-- ToDo: when enabling the floatLambda stuff,+--       I think we want to stop doing this+  | [(bndr,rhs)] <- pairs+  , count isId abs_vars > 1+  = do  -- Special case for self recursion where there are+        -- several variables carried around: build a local loop:+        --      poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars+        -- This just makes the closures a bit smaller.  If we don't do+        -- this, allocation rises significantly on some programs+        --+        -- We could elaborate it for the case where there are several+        -- mutually recursive functions, but it's quite a bit more complicated+        --+        -- This all seems a bit ad hoc -- sigh+    let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars+        rhs_lvl = le_ctxt_lvl rhs_env++    (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]+    let+        (lam_bndrs, rhs_body)   = collectAnnBndrs rhs+        (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs+        (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1+    new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body+    (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]+    return (Rec [(TB poly_bndr (FloatMe dest_lvl)+                 , mkLams abs_vars_w_lvls $+                   mkLams lam_bndrs2 $+                   Let (Rec [( TB new_bndr (StayPut rhs_lvl)+                             , mkLams lam_bndrs2 new_rhs_body)])+                       (mkVarApps (Var new_bndr) lam_bndrs1))]+           , poly_env)++  | otherwise  -- Non-null abs_vars+  = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs+       ; new_rhss <- mapM (do_rhs new_env) pairs+       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)+                , new_env) }++  where+    (bndrs,rhss) = unzip pairs+    is_join  = isJoinId (head bndrs)+                -- bndrs is always non-empty and if one is a join they all are+                -- Both are checked by Lint+    is_fun   = all isFunction rhss+    is_bot   = False  -- It's odd to have an unconditionally divergent+                      -- function in a Rec, and we don't much care what+                      -- happens to it.  False is simple!++    do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive+                                        is_bot (get_join bndr)+                                        rhs++    get_join bndr | need_zap  = Nothing+                  | otherwise = isJoinId_maybe bndr+    need_zap = dest_lvl `ltLvl` joinCeilingLevel env++        -- Finding the free vars of the binding group is annoying+    bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])+                `unionDVarSet`+                (fvDVarSet $ unionsFV [ idFVs bndr+                                      | (bndr, (_,_)) <- pairs]))+               `delDVarSetList`+                bndrs++    ty_fvs   = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs+    dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join+    abs_vars = abstractVars dest_lvl env bind_fvs++profitableFloat :: LevelEnv -> Level -> Bool+profitableFloat env dest_lvl+  =  (dest_lvl `ltMajLvl` le_ctxt_lvl env)  -- Escapes a value lambda+  || isTopLvl dest_lvl                      -- Going all the way to top level+++----------------------------------------------------+-- Three help functions for the type-abstraction case++lvlRhs :: LevelEnv+       -> RecFlag+       -> Bool               -- Is this a bottoming function+       -> Maybe JoinArity+       -> CoreExprWithFVs+       -> LvlM LevelledExpr+lvlRhs env rec_flag is_bot mb_join_arity expr+  = lvlFloatRhs [] (le_ctxt_lvl env) env+                rec_flag is_bot mb_join_arity expr++lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag+            -> Bool   -- Binding is for a bottoming function+            -> Maybe JoinArity+            -> CoreExprWithFVs+            -> LvlM (Expr LevelledBndr)+-- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline+lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs+  = do { body' <- if not is_bot  -- See Note [Floating from a RHS]+                     && any isId bndrs+                  then lvlMFE  body_env True body+                  else lvlExpr body_env      body+       ; return (mkLams bndrs' body') }+  where+    (bndrs, body)     | Just join_arity <- mb_join_arity+                      = collectNAnnBndrs join_arity rhs+                      | otherwise+                      = collectAnnBndrs rhs+    (env1, bndrs1)    = substBndrsSL NonRecursive env bndrs+    all_bndrs         = abs_vars ++ bndrs1+    (body_env, bndrs') | Just _ <- mb_join_arity+                      = lvlJoinBndrs env1 dest_lvl rec all_bndrs+                      | otherwise+                      = case lvlLamBndrs env1 dest_lvl all_bndrs of+                          (env2, bndrs') -> (placeJoinCeiling env2, bndrs')+        -- The important thing here is that we call lvlLamBndrs on+        -- all these binders at once (abs_vars and bndrs), so they+        -- all get the same major level.  Otherwise we create stupid+        -- let-bindings inside, joyfully thinking they can float; but+        -- in the end they don't because we never float bindings in+        -- between lambdas++{- Note [Floating from a RHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When floating the RHS of a let-binding, we don't always want to apply+lvlMFE to the body of a lambda, as we usually do, because the entire+binding body is already going to the right place (dest_lvl).++A particular example is the top level.  Consider+   concat = /\ a -> foldr ..a.. (++) []+We don't want to float the body of the lambda to get+   lvl    = /\ a -> foldr ..a.. (++) []+   concat = /\ a -> lvl a+That would be stupid.++Previously this was avoided in a much nastier way, by testing strict_ctxt+in float_me in lvlMFE.  But that wasn't even right because it would fail+to float out the error sub-expression in+    f = \x. case x of+              True  -> error ("blah" ++ show x)+              False -> ...++But we must be careful:++* If we had+    f = \x -> factorial 20+  we /would/ want to float that (factorial 20) out!  Functions are treated+  differently: see the use of isFunction in the calls to destLevel. If+  there are only type lambdas, then destLevel will say "go to top, and+  abstract over the free tyvars" and we don't want that here.++* But if we had+    f = \x -> error (...x....)+  we would NOT want to float the bottoming expression out to give+    lvl = \x -> error (...x...)+    f = \x -> lvl x++Conclusion: use lvlMFE if there are+  * any value lambdas in the original function, and+  * this is not a bottoming function (the is_bot argument)+Use lvlExpr otherwise.  A little subtle, and I got it wrong at least twice+(e.g. #13369).+-}++{-+************************************************************************+*                                                                      *+\subsection{Deciding floatability}+*                                                                      *+************************************************************************+-}++substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])+substAndLvlBndrs is_rec env lvl bndrs+  = lvlBndrs subst_env lvl subst_bndrs+  where+    (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs++substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])+-- So named only to avoid the name clash with GHC.Core.Subst.substBndrs+substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs+  = ( env { le_subst    = subst'+          , le_env      = foldl' add_id  id_env (bndrs `zip` bndrs') }+    , bndrs')+  where+    (subst', bndrs') = case is_rec of+                         NonRecursive -> substBndrs    subst bndrs+                         Recursive    -> substRecBndrs subst bndrs++lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])+-- Compute the levels for the binders of a lambda group+lvlLamBndrs env lvl bndrs+  = lvlBndrs env new_lvl bndrs+  where+    new_lvl | any is_major bndrs = incMajorLvl lvl+            | otherwise          = incMinorLvl lvl++    is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr)+       -- The "probably" part says "don't float things out of a+       -- probable one-shot lambda"+       -- See Note [Computing one-shot info] in GHC.Types.Demand++lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]+             -> (LevelEnv, [LevelledBndr])+lvlJoinBndrs env lvl rec bndrs+  = lvlBndrs env new_lvl bndrs+  where+    new_lvl | isRec rec = incMajorLvl lvl+            | otherwise = incMinorLvl lvl+      -- Non-recursive join points are one-shot; recursive ones are not++lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])+-- The binders returned are exactly the same as the ones passed,+-- apart from applying the substitution, but they are now paired+-- with a (StayPut level)+--+-- The returned envt has le_ctxt_lvl updated to the new_lvl+--+-- All the new binders get the same level, because+-- any floating binding is either going to float past+-- all or none.  We never separate binders.+lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs+  = ( env { le_ctxt_lvl = new_lvl+          , le_join_ceil = new_lvl+          , le_lvl_env  = addLvls new_lvl lvl_env bndrs }+    , map (stayPut new_lvl) bndrs)++stayPut :: Level -> OutVar -> LevelledBndr+stayPut new_lvl bndr = TB bndr (StayPut new_lvl)++  -- Destination level is the max Id level of the expression+  -- (We'll abstract the type variables, if any.)+destLevel :: LevelEnv+          -> DVarSet    -- Free vars of the term+          -> TyCoVarSet -- Free in the /type/ of the term+                        -- (a subset of the previous argument)+          -> Bool   -- True <=> is function+          -> Bool   -- True <=> is bottom+          -> Bool   -- True <=> is a join point+          -> Level+-- INVARIANT: if is_join=True then result >= join_ceiling+destLevel env fvs fvs_ty is_function is_bot is_join+  | isTopLvl max_fv_id_level  -- Float even joins if they get to top level+                              -- See Note [Floating join point bindings]+  = tOP_LEVEL++  | is_join  -- Never float a join point past the join ceiling+             -- See Note [Join points] in GHC.Core.Op.FloatOut+  = if max_fv_id_level `ltLvl` join_ceiling+    then join_ceiling+    else max_fv_id_level++  | is_bot              -- Send bottoming bindings to the top+  = as_far_as_poss      -- regardless; see Note [Bottoming floats]+                        -- Esp Bottoming floats (1)++  | Just n_args <- floatLams env+  , n_args > 0  -- n=0 case handled uniformly by the 'otherwise' case+  , is_function+  , countFreeIds fvs <= n_args+  = as_far_as_poss  -- Send functions to top level; see+                    -- the comments with isFunction++  | otherwise = max_fv_id_level+  where+    join_ceiling    = joinCeilingLevel env+    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the+                                              -- tyvars will be abstracted++    as_far_as_poss = maxFvLevel' isId env fvs_ty+                     -- See Note [Floating and kind casts]++{- Note [Floating and kind casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   case x of+     K (co :: * ~# k) -> let v :: Int |> co+                             v = e+                         in blah++Then, even if we are abstracting over Ids, or if e is bottom, we can't+float v outside the 'co' binding.  Reason: if we did we'd get+    v' :: forall k. (Int ~# Age) => Int |> co+and now 'co' isn't in scope in that type. The underlying reason is+that 'co' is a value-level thing and we can't abstract over that in a+type (else we'd get a dependent type).  So if v's /type/ mentions 'co'+we can't float it out beyond the binding site of 'co'.++That's why we have this as_far_as_poss stuff.  Usually as_far_as_poss+is just tOP_LEVEL; but occasionally a coercion variable (which is an+Id) mentioned in type prevents this.++Example #14270 comment:15.+-}+++isFunction :: CoreExprWithFVs -> Bool+-- The idea here is that we want to float *functions* to+-- the top level.  This saves no work, but+--      (a) it can make the host function body a lot smaller,+--              and hence inlinable.+--      (b) it can also save allocation when the function is recursive:+--          h = \x -> letrec f = \y -> ...f...y...x...+--                    in f x+--     becomes+--          f = \x y -> ...(f x)...y...x...+--          h = \x -> f x x+--     No allocation for f now.+-- We may only want to do this if there are sufficiently few free+-- variables.  We certainly only want to do it for values, and not for+-- constructors.  So the simple thing is just to look for lambdas+isFunction (_, AnnLam b e) | isId b    = True+                           | otherwise = isFunction e+-- isFunction (_, AnnTick _ e)         = isFunction e  -- dubious+isFunction _                           = False++countFreeIds :: DVarSet -> Int+countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet+  -- It's OK to use nonDetFoldUDFM here because we're just counting things.+  where+    add :: Var -> Int -> Int+    add v n | isId v    = n+1+            | otherwise = n++{-+************************************************************************+*                                                                      *+\subsection{Free-To-Level Monad}+*                                                                      *+************************************************************************+-}++data LevelEnv+  = LE { le_switches :: FloatOutSwitches+       , le_ctxt_lvl :: Level           -- The current level+       , le_lvl_env  :: VarEnv Level    -- Domain is *post-cloned* TyVars and Ids+       , le_join_ceil:: Level           -- Highest level to which joins float+                                        -- Invariant: always >= le_ctxt_lvl++       -- See Note [le_subst and le_env]+       , le_subst    :: Subst           -- Domain is pre-cloned TyVars and Ids+                                        -- The Id -> CoreExpr in the Subst is ignored+                                        -- (since we want to substitute a LevelledExpr for+                                        -- an Id via le_env) but we do use the Co/TyVar substs+       , le_env      :: IdEnv ([OutVar], LevelledExpr)  -- Domain is pre-cloned Ids+    }++{- Note [le_subst and le_env]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We clone let- and case-bound variables so that they are still distinct+when floated out; hence the le_subst/le_env.  (see point 3 of the+module overview comment).  We also use these envs when making a+variable polymorphic because we want to float it out past a big+lambda.++The le_subst and le_env always implement the same mapping,+     in_x :->  out_x a b+where out_x is an OutVar, and a,b are its arguments (when+we perform abstraction at the same time as floating).++  le_subst maps to CoreExpr+  le_env   maps to LevelledExpr++Since the range is always a variable or application, there is never+any difference between the two, but sadly the types differ.  The+le_subst is used when substituting in a variable's IdInfo; the le_env+when we find a Var.++In addition the le_env records a [OutVar] of variables free in the+OutExpr/LevelledExpr, just so we don't have to call freeVars+repeatedly.  This list is always non-empty, and the first element is+out_x++The domain of the both envs is *pre-cloned* Ids, though++The domain of the le_lvl_env is the *post-cloned* Ids+-}++initialEnv :: FloatOutSwitches -> LevelEnv+initialEnv float_lams+  = LE { le_switches = float_lams+       , le_ctxt_lvl = tOP_LEVEL+       , le_join_ceil = panic "initialEnv"+       , le_lvl_env = emptyVarEnv+       , le_subst = emptySubst+       , le_env = emptyVarEnv }++addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level+addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl++addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level+addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs++floatLams :: LevelEnv -> Maybe Int+floatLams le = floatOutLambdas (le_switches le)++floatConsts :: LevelEnv -> Bool+floatConsts le = floatOutConstants (le_switches le)++floatOverSat :: LevelEnv -> Bool+floatOverSat le = floatOutOverSatApps (le_switches le)++floatTopLvlOnly :: LevelEnv -> Bool+floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)++incMinorLvlFrom :: LevelEnv -> Level+incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env)++-- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can+-- See Note [Binder-swap during float-out]+extendCaseBndrEnv :: LevelEnv+                  -> Id                 -- Pre-cloned case binder+                  -> Expr LevelledBndr  -- Post-cloned scrutinee+                  -> LevelEnv+extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })+                  case_bndr (Var scrut_var)+  = le { le_subst   = extendSubstWithVar subst case_bndr scrut_var+       , le_env     = add_id id_env (case_bndr, scrut_var) }+extendCaseBndrEnv env _ _ = env++-- See Note [Join ceiling]+placeJoinCeiling :: LevelEnv -> LevelEnv+placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })+  = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' }+  where+    lvl' = asJoinCeilLvl (incMinorLvl lvl)++maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level+maxFvLevel max_me env var_set+  = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set++maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level+-- Same but for TyCoVarSet+maxFvLevel' max_me env var_set+  = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set++maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level+maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl+  = case lookupVarEnv id_env in_var of+      Just (abs_vars, _) -> foldr max_out lvl abs_vars+      Nothing            -> max_out in_var lvl+  where+    max_out out_var lvl+        | max_me out_var = case lookupVarEnv lvl_env out_var of+                                Just lvl' -> maxLvl lvl' lvl+                                Nothing   -> lvl+        | otherwise = lvl       -- Ignore some vars depending on max_me++lookupVar :: LevelEnv -> Id -> LevelledExpr+lookupVar le v = case lookupVarEnv (le_env le) v of+                    Just (_, expr) -> expr+                    _              -> Var v++-- Level to which join points are allowed to float (boundary of current tail+-- context). See Note [Join ceiling]+joinCeilingLevel :: LevelEnv -> Level+joinCeilingLevel = le_join_ceil++abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]+        -- Find the variables in fvs, free vars of the target expression,+        -- whose level is greater than the destination level+        -- These are the ones we are going to abstract out+        --+        -- Note that to get reproducible builds, the variables need to be+        -- abstracted in deterministic order, not dependent on the values of+        -- Uniques. This is achieved by using DVarSets, deterministic free+        -- variable computation and deterministic sort.+        -- See Note [Unique Determinism] in GHC.Types.Unique for explanation of why+        -- Uniques are not deterministic.+abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs+  =  -- NB: sortQuantVars might not put duplicates next to each other+    map zap $ sortQuantVars $+    filter abstract_me      $+    dVarSetElems            $+    closeOverKindsDSet      $+    substDVarSet subst in_fvs+        -- NB: it's important to call abstract_me only on the OutIds the+        -- come from substDVarSet (not on fv, which is an InId)+  where+    abstract_me v = case lookupVarEnv lvl_env v of+                        Just lvl -> dest_lvl `ltLvl` lvl+                        Nothing  -> False++        -- We are going to lambda-abstract, so nuke any IdInfo,+        -- and add the tyvars of the Id (if necessary)+    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||+                           not (isEmptyRuleInfo (idSpecialisation v)),+                           text "absVarsOf: discarding info on" <+> ppr v )+                     setIdInfo v vanillaIdInfo+          | otherwise = v++type LvlM result = UniqSM result++initLvl :: UniqSupply -> UniqSM a -> a+initLvl = initUs_++newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]+             -> LvlM (LevelEnv, [OutId])+-- The envt is extended to bind the new bndrs to dest_lvl, but+-- the le_ctxt_lvl is unaffected+newPolyBndrs dest_lvl+             env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })+             abs_vars bndrs+ = ASSERT( all (not . isCoVar) bndrs )   -- What would we add to the CoSubst in this case. No easy answer.+   do { uniqs <- getUniquesM+      ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs+            bndr_prs  = bndrs `zip` new_bndrs+            env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs+                       , le_subst   = foldl' add_subst subst   bndr_prs+                       , le_env     = foldl' add_id    id_env  bndr_prs }+      ; return (env', new_bndrs) }+  where+    add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)+    add_id    env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)++    mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id+                             transfer_join_info bndr $+                             mkSysLocal (mkFastString str) uniq poly_ty+                           where+                             str     = "poly_" ++ occNameString (getOccName bndr)+                             poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr))++    -- If we are floating a join point to top level, it stops being+    -- a join point.  Otherwise it continues to be a join point,+    -- but we may need to adjust its arity+    dest_is_top = isTopLvl dest_lvl+    transfer_join_info bndr new_bndr+      | Just join_arity <- isJoinId_maybe bndr+      , not dest_is_top+      = new_bndr `asJoinId` join_arity + length abs_vars+      | otherwise+      = new_bndr++newLvlVar :: LevelledExpr        -- The RHS of the new binding+          -> Maybe JoinArity     -- Its join arity, if it is a join point+          -> Bool                -- True <=> the RHS looks like (makeStatic ...)+          -> LvlM Id+newLvlVar lvld_rhs join_arity_maybe is_mk_static+  = do { uniq <- getUniqueM+       ; return (add_join_info (mk_id uniq rhs_ty))+       }+  where+    add_join_info var = var `asJoinId_maybe` join_arity_maybe+    de_tagged_rhs = deTagExpr lvld_rhs+    rhs_ty        = exprType de_tagged_rhs++    mk_id uniq rhs_ty+      -- See Note [Grand plan for static forms] in StaticPtrTable.+      | is_mk_static+      = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))+                            rhs_ty+      | otherwise+      = mkSysLocal (mkFastString "lvl") uniq rhs_ty++-- | Clone the binders bound by a single-alternative case.+cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])+cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })+               new_lvl vs+  = do { us <- getUniqueSupplyM+       ; let (subst', vs') = cloneBndrs subst us vs+             -- N.B. We are not moving the body of the case, merely its case+             -- binders.  Consequently we should *not* set le_ctxt_lvl and+             -- le_join_ceil.  See Note [Setting levels when floating+             -- single-alternative cases].+             env' = env { le_lvl_env   = addLvls new_lvl lvl_env vs'+                        , le_subst     = subst'+                        , le_env       = foldl' add_id id_env (vs `zip` vs') }++       ; return (env', vs') }++cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]+             -> LvlM (LevelEnv, [OutVar])+-- See Note [Need for cloning during float-out]+-- Works for Ids bound by let(rec)+-- The dest_lvl is attributed to the binders in the new env,+-- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env+cloneLetVars is_rec+          env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })+          dest_lvl vs+  = do { us <- getUniqueSupplyM+       ; let vs1  = map zap vs+                      -- See Note [Zapping the demand info]+             (subst', vs2) = case is_rec of+                               NonRecursive -> cloneBndrs      subst us vs1+                               Recursive    -> cloneRecIdBndrs subst us vs1+             prs  = vs `zip` vs2+             env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2+                        , le_subst   = subst'+                        , le_env     = foldl' add_id id_env prs }++       ; return (env', vs2) }+  where+    zap :: Var -> Var+    zap v | isId v    = zap_join (zapIdDemandInfo v)+          | otherwise = v++    zap_join | isTopLvl dest_lvl = zapJoinId+             | otherwise         = id++add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)+add_id id_env (v, v1)+  | isTyVar v = delVarEnv    id_env v+  | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)++{-+Note [Zapping the demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+VERY IMPORTANT: we must zap the demand info if the thing is going to+float out, because it may be less demanded than at its original+binding site.  Eg+   f :: Int -> Int+   f x = let v = 3*4 in v+x+Here v is strict; but if we float v to top level, it isn't any more.++Similarly, if we're floating a join point, it won't be one anymore, so we zap+join point information as well.+-}
+ compiler/GHC/Core/Op/Simplify.hs view
@@ -0,0 +1,3667 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[Simplify]{The main module of the simplifier}+-}++{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+module GHC.Core.Op.Simplify ( simplTopBinds, simplExpr, simplRules ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Platform+import GHC.Driver.Session+import GHC.Core.Op.Simplify.Monad+import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )+import GHC.Core.Op.Simplify.Env+import GHC.Core.Op.Simplify.Utils+import GHC.Core.Op.OccurAnal ( occurAnalyseExpr )+import GHC.Core.FamInstEnv ( FamInstEnv )+import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326+import GHC.Types.Id+import GHC.Types.Id.Make   ( seqId )+import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )+import qualified GHC.Core.Make+import GHC.Types.Id.Info+import GHC.Types.Name           ( mkSystemVarName, isExternalName, getOccFS )+import GHC.Core.Coercion hiding ( substCo, substCoVar )+import GHC.Core.Coercion.Opt    ( optCoercion )+import GHC.Core.FamInstEnv      ( topNormaliseType_maybe )+import GHC.Core.DataCon+   ( DataCon, dataConWorkId, dataConRepStrictness+   , dataConRepArgTys, isUnboxedTupleCon+   , StrictnessMark (..) )+import GHC.Core.Op.Monad ( Tick(..), SimplMode(..) )+import GHC.Core+import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd+                        , mkClosedStrictSig, topDmd, botDiv )+import GHC.Types.Cpr    ( mkCprSig, botCpr )+import GHC.Core.Ppr     ( pprCoreExpr )+import GHC.Core.Unfold+import GHC.Core.Utils+import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg+                          , joinPointBinding_maybe, joinPointBindings_maybe )+import GHC.Core.Rules   ( mkRuleInfo, lookupRule, getRules )+import GHC.Types.Basic  ( TopLevelFlag(..), isNotTopLevel, isTopLevel,+                          RecFlag(..), Arity )+import MonadUtils       ( mapAccumLM, liftIO )+import GHC.Types.Var    ( isTyCoVar )+import Maybes           ( orElse )+import Control.Monad+import Outputable+import FastString+import Util+import ErrUtils+import GHC.Types.Module ( moduleName, pprModuleName )+import PrimOp           ( PrimOp (SeqOp) )+++{-+The guts of the simplifier is in this module, but the driver loop for+the simplifier is in GHC.Core.Op.Simplify.Driver++Note [The big picture]+~~~~~~~~~~~~~~~~~~~~~~+The general shape of the simplifier is this:++  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)++ * SimplEnv contains+     - Simplifier mode (which includes DynFlags for convenience)+     - Ambient substitution+     - InScopeSet++ * SimplFloats contains+     - Let-floats (which includes ok-for-spec case-floats)+     - Join floats+     - InScopeSet (including all the floats)++ * Expressions+      simplExpr :: SimplEnv -> InExpr -> SimplCont+                -> SimplM (SimplFloats, OutExpr)+   The result of simplifying an /expression/ is (floats, expr)+      - A bunch of floats (let bindings, join bindings)+      - A simplified expression.+   The overall result is effectively (let floats in expr)++ * Bindings+      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)+   The result of simplifying a binding is+     - A bunch of floats, the last of which is the simplified binding+       There may be auxiliary bindings too; see prepareRhs+     - An environment suitable for simplifying the scope of the binding++   The floats may also be empty, if the binding is inlined unconditionally;+   in that case the returned SimplEnv will have an augmented substitution.++   The returned floats and env both have an in-scope set, and they are+   guaranteed to be the same.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+The simplifier used to guarantee that the output had no shadowing, but+it does not do so any more.   (Actually, it never did!)  The reason is+documented with simplifyArgs.+++Eta expansion+~~~~~~~~~~~~~~+For eta expansion, we want to catch things like++        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r++If the \x was on the RHS of a let, we'd eta expand to bring the two+lambdas together.  And in general that's a good thing to do.  Perhaps+we should eta expand wherever we find a (value) lambda?  Then the eta+expansion at a let RHS can concentrate solely on the PAP case.++Note [In-scope set as a substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Lookups in in-scope set], an in-scope set can act as+a substitution. Specifically, it acts as a substitution from variable to+variables /with the same unique/.++Why do we need this? Well, during the course of the simplifier, we may want to+adjust inessential properties of a variable. For instance, when performing a+beta-reduction, we change++    (\x. e) u ==> let x = u in e++We typically want to add an unfolding to `x` so that it inlines to (the+simplification of) `u`.++We do that by adding the unfolding to the binder `x`, which is added to the+in-scope set. When simplifying occurrences of `x` (every occurrence!), they are+replaced by their “updated” version from the in-scope set, hence inherit the+unfolding. This happens in `SimplEnv.substId`.++Another example. Consider++   case x of y { Node a b -> ...y...+               ; Leaf v   -> ...y... }++In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we+want y's unfolding to be (Leaf v). We achieve this by adding the appropriate+unfolding to y, and re-adding it to the in-scope set. See the calls to+`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.++It's quite convenient. This way we don't need to manipulate the substitution all+the time: every update to a binder is automatically reflected to its bound+occurrences.++************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)+-- See Note [The big picture]+simplTopBinds env0 binds0+  = do  {       -- Put all the top-level binders into scope at the start+                -- so that if a transformation 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 OccurAnal.+        ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)+        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0+        ; freeTick SimplifierDone+        ; return (floats, env2) }+  where+        -- We need to track the zapped top-level binders, because+        -- they should have their fragile IdInfo zapped (notably occurrence info)+        -- That's why we run down binds and bndrs' simultaneously.+        --+    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)+    simpl_binds env []           = return (emptyFloats env, env)+    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind+                                      ; (floats, env2) <- simpl_binds env1 binds+                                      ; return (float `addFloats` floats, env2) }++    simpl_bind env (Rec pairs)+      = simplRecBind env TopLevel Nothing pairs+    simpl_bind env (NonRec b r)+      = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing+           ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }++{-+************************************************************************+*                                                                      *+        Lazy bindings+*                                                                      *+************************************************************************++simplRecBind is used for+        * recursive bindings only+-}++simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont+             -> [(InId, InExpr)]+             -> SimplM (SimplFloats, SimplEnv)+simplRecBind env0 top_lvl mb_cont pairs0+  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0+        ; (rec_floats, env1) <- go env_with_info triples+        ; return (mkRecFloats rec_floats, env1) }+  where+    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))+        -- Add the (substituted) rules to the binder+    add_rules env (bndr, rhs)+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont+             ; return (env', (bndr, bndr', rhs)) }++    go env [] = return (emptyFloats env, env)++    go env ((old_bndr, new_bndr, rhs) : pairs)+        = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont+                                                  old_bndr new_bndr rhs+             ; (floats, env2) <- go env1 pairs+             ; return (float `addFloats` floats, env2) }++{-+simplOrTopPair is used for+        * recursive bindings (whether top level or not)+        * top-level non-recursive bindings++It assumes the binder has already been simplified, but not its IdInfo.+-}++simplRecOrTopPair :: SimplEnv+                  -> TopLevelFlag -> RecFlag -> MaybeJoinCont+                  -> InId -> OutBndr -> InExpr  -- Binder and rhs+                  -> SimplM (SimplFloats, SimplEnv)++simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs+  | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env+  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}+    trace_bind "pre-inline-uncond" $+    do { tick (PreInlineUnconditionally old_bndr)+       ; return ( emptyFloats env, env' ) }++  | Just cont <- mb_cont+  = {-#SCC "simplRecOrTopPair-join" #-}+    ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )+    trace_bind "join" $+    simplJoinBind env cont old_bndr new_bndr rhs env++  | otherwise+  = {-#SCC "simplRecOrTopPair-normal" #-}+    trace_bind "normal" $+    simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env++  where+    dflags = seDynFlags env++    -- trace_bind emits a trace for each top-level binding, which+    -- helps to locate the tracing for inlining and rule firing+    trace_bind what thing_inside+      | not (dopt Opt_D_verbose_core2core dflags)+      = thing_inside+      | otherwise+      = traceAction dflags ("SimplBind " ++ what)+         (ppr old_bndr) thing_inside++--------------------------+simplLazyBind :: SimplEnv+              -> TopLevelFlag -> RecFlag+              -> InId -> OutId          -- Binder, both pre-and post simpl+                                        -- Not a JoinId+                                        -- The OutId has IdInfo, except arity, unfolding+                                        -- Ids only, no TyVars+              -> InExpr -> SimplEnv     -- The RHS and its environment+              -> SimplM (SimplFloats, SimplEnv)+-- Precondition: not a JoinId+-- Precondition: rhs obeys the let/app invariant+-- NOT used for JoinIds+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se+  = ASSERT( isId bndr )+    ASSERT2( not (isJoinId bndr), ppr bndr )+    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $+    do  { let   rhs_env     = rhs_se `setInScopeFromE` env+                (tvs, body) = case collectTyAndValBinders rhs of+                                (tvs, [], body)+                                  | surely_not_lam body -> (tvs, body)+                                _                       -> ([], rhs)++                surely_not_lam (Lam {})     = False+                surely_not_lam (Tick t e)+                  | not (tickishFloatable t) = surely_not_lam e+                   -- eta-reduction could float+                surely_not_lam _            = True+                        -- Do not do the "abstract tyvar" thing if there's+                        -- a lambda inside, because it defeats eta-reduction+                        --    f = /\a. \x. g a x+                        -- should eta-reduce.+++        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs+                -- See Note [Floating and type abstraction] in GHC.Core.Op.Simplify.Utils++        -- Simplify the RHS+        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))+        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont++              -- Never float join-floats out of a non-join let-binding+              -- So wrap the body in the join-floats right now+              -- Hence: body_floats1 consists only of let-floats+        ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0++        -- ANF-ise a constructor or PAP rhs+        -- We get at most one float per argument here+        ; (let_floats, body2) <- {-#SCC "prepareRhs" #-} prepareRhs (getMode env) top_lvl+                                            (getOccFS bndr1) (idInfo bndr1) body1+        ; let body_floats2 = body_floats1 `addLetFloats` let_floats++        ; (rhs_floats, rhs')+            <-  if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2)+                then                    -- No floating, revert to body1+                     {-#SCC "simplLazyBind-no-floating" #-}+                     do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont+                        ; return (emptyFloats env, rhs') }++                else if null tvs then   -- Simple floating+                     {-#SCC "simplLazyBind-simple-floating" #-}+                     do { tick LetFloatFromLet+                        ; return (body_floats2, body2) }++                else                    -- Do type-abstraction first+                     {-#SCC "simplLazyBind-type-abstraction-first" #-}+                     do { tick LetFloatFromLet+                        ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl+                                                                tvs' body_floats2 body2+                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds+                        ; rhs' <- mkLam env tvs' body3 rhs_cont+                        ; return (floats, rhs') }++        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)+                                             top_lvl Nothing bndr bndr1 rhs'+        ; return (rhs_floats `addFloats` bind_float, env2) }++--------------------------+simplJoinBind :: SimplEnv+              -> SimplCont+              -> InId -> OutId          -- Binder, both pre-and post simpl+                                        -- The OutId has IdInfo, except arity,+                                        --   unfolding+              -> InExpr -> SimplEnv     -- The right hand side and its env+              -> SimplM (SimplFloats, SimplEnv)+simplJoinBind env cont old_bndr new_bndr rhs rhs_se+  = do  { let rhs_env = rhs_se `setInScopeFromE` env+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont+        ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' }++--------------------------+simplNonRecX :: SimplEnv+             -> InId            -- Old binder; not a JoinId+             -> OutExpr         -- Simplified RHS+             -> SimplM (SimplFloats, SimplEnv)+-- A specialised variant of simplNonRec used when the RHS is already+-- simplified, notably in knownCon.  It uses case-binding where necessary.+--+-- Precondition: rhs satisfies the let/app invariant++simplNonRecX env bndr new_rhs+  | ASSERT2( not (isJoinId bndr), ppr bndr )+    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }+  = return (emptyFloats env, env)    --  Here c is dead, and we avoid+                                         --  creating the binding c = (a,b)++  | Coercion co <- new_rhs+  = return (emptyFloats env, extendCvSubst env bndr co)++  | otherwise+  = do  { (env', bndr') <- simplBinder env bndr+        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }+                -- simplNonRecX is only used for NotTopLevel things++--------------------------+completeNonRecX :: TopLevelFlag -> SimplEnv+                -> Bool+                -> InId                 -- Old binder; not a JoinId+                -> OutId                -- New binder+                -> OutExpr              -- Simplified RHS+                -> SimplM (SimplFloats, SimplEnv)    -- The new binding is in the floats+-- Precondition: rhs satisfies the let/app invariant+--               See Note [Core let/app invariant] in GHC.Core++completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs+  = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )+    do  { (prepd_floats, rhs1) <- prepareRhs (getMode env) top_lvl (getOccFS new_bndr)+                                             (idInfo new_bndr) new_rhs+        ; let floats = emptyFloats env `addLetFloats` prepd_floats+        ; (rhs_floats, rhs2) <-+                if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1+                then    -- Add the floats to the main env+                     do { tick LetFloatFromLet+                        ; return (floats, rhs1) }+                else    -- Do not float; wrap the floats around the RHS+                     return (emptyFloats env, wrapFloats floats rhs1)++        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)+                                             NotTopLevel Nothing+                                             old_bndr new_bndr rhs2+        ; return (rhs_floats `addFloats` bind_float, env2) }+++{- *********************************************************************+*                                                                      *+           prepareRhs, makeTrivial+*                                                                      *+************************************************************************++Note [prepareRhs]+~~~~~~~~~~~~~~~~~+prepareRhs takes a putative RHS, checks whether it's a PAP or+constructor application and, if so, converts it to ANF, so that the+resulting thing can be inlined more easily.  Thus+        x = (f a, g b)+becomes+        t1 = f a+        t2 = g b+        x = (t1,t2)++We also want to deal well cases like this+        v = (f e1 `cast` co) e2+Here we want to make e1,e2 trivial and get+        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2+That's what the 'go' loop in prepareRhs does+-}++prepareRhs :: SimplMode -> TopLevelFlag+           -> FastString   -- Base for any new variables+           -> IdInfo       -- IdInfo for the LHS of this binding+           -> OutExpr+           -> SimplM (LetFloats, OutExpr)+-- Transforms a RHS into a better RHS by adding floats+-- e.g        x = Just e+-- becomes    a = e+--            x = Just a+-- See Note [prepareRhs]+prepareRhs mode top_lvl occ info (Cast rhs co)  -- Note [Float coercions]+  | let ty1 = coercionLKind co         -- Do *not* do this if rhs has an unlifted type+  , not (isUnliftedType ty1)                 -- see Note [Float coercions (unlifted)]+  = do  { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs+        ; return (floats, Cast rhs' co) }+  where+    sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info+                                   `setCprInfo`        cprInfo info+                                   `setDemandInfo`     demandInfo info++prepareRhs mode top_lvl occ _ rhs0+  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0+        ; return (floats, rhs1) }+  where+    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)+    go n_val_args (Cast rhs co)+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; return (is_exp, floats, Cast rhs' co) }+    go n_val_args (App fun (Type ty))+        = do { (is_exp, floats, rhs') <- go n_val_args fun+             ; return (is_exp, floats, App rhs' (Type ty)) }+    go n_val_args (App fun arg)+        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun+             ; case is_exp of+                False -> return (False, emptyLetFloats, App fun arg)+                True  -> do { (floats2, arg') <- makeTrivial mode top_lvl occ arg+                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }+    go n_val_args (Var fun)+        = return (is_exp, emptyLetFloats, Var fun)+        where+          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP+                        -- See Note [CONLIKE pragma] in GHC.Types.Basic+                        -- The definition of is_exp should match that in+                        -- OccurAnal.occAnalApp++    go n_val_args (Tick t rhs)+        -- We want to be able to float bindings past this+        -- tick. Non-scoping ticks don't care.+        | tickishScoped t == NoScope+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; return (is_exp, floats, Tick t rhs') }++        -- On the other hand, for scoping ticks we need to be able to+        -- copy them on the floats, which in turn is only allowed if+        -- we can obtain non-counting ticks.+        | (not (tickishCounts t) || tickishCanSplit t)+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)+                   floats' = mapLetFloats floats tickIt+             ; return (is_exp, floats', Tick t rhs') }++    go _ other+        = return (False, emptyLetFloats, other)++{-+Note [Float coercions]+~~~~~~~~~~~~~~~~~~~~~~+When we find the binding+        x = e `cast` co+we'd like to transform it to+        x' = e+        x = x `cast` co         -- A trivial binding+There's a chance that e will be a constructor application or function, or something+like that, so moving the coercion to the usage site may well cancel the coercions+and lead to further optimisation.  Example:++     data family T a :: *+     data instance T Int = T Int++     foo :: Int -> Int -> Int+     foo m n = ...+        where+          x = T m+          go 0 = 0+          go n = case x of { T m -> go (n-m) }+                -- This case should optimise++Note [Preserve strictness when floating coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the Note [Float coercions] transformation, keep the strictness info.+Eg+        f = e `cast` co    -- f has strictness SSL+When we transform to+        f' = e             -- f' also has strictness SSL+        f = f' `cast` co   -- f still has strictness SSL++Its not wrong to drop it on the floor, but better to keep it.++Note [Float coercions (unlifted)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+BUT don't do [Float coercions] if 'e' has an unlifted type.+This *can* happen:++     foo :: Int = (error (# Int,Int #) "urk")+                  `cast` CoUnsafe (# Int,Int #) Int++If do the makeTrivial thing to the error call, we'll get+    foo = case error (# Int,Int #) "urk" of v -> v `cast` ...+But 'v' isn't in scope!++These strange casts can happen as a result of case-of-case+        bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of+                (# p,q #) -> p+q+-}++makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)+makeTrivialArg mode (ValArg e)+  = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e+       ; return (floats, ValArg e') }+makeTrivialArg _ arg+  = return (emptyLetFloats, arg)  -- CastBy, TyArg++makeTrivial :: SimplMode -> TopLevelFlag+            -> FastString  -- ^ A "friendly name" to build the new binder from+            -> OutExpr     -- ^ This expression satisfies the let/app invariant+            -> SimplM (LetFloats, OutExpr)+-- Binds the expression to a variable, if it's not trivial, returning the variable+makeTrivial mode top_lvl context expr+ = makeTrivialWithInfo mode top_lvl context vanillaIdInfo expr++makeTrivialWithInfo :: SimplMode -> TopLevelFlag+                    -> FastString  -- ^ a "friendly name" to build the new binder from+                    -> IdInfo+                    -> OutExpr     -- ^ This expression satisfies the let/app invariant+                    -> SimplM (LetFloats, OutExpr)+-- Propagate strictness and demand info to the new binder+-- Note [Preserve strictness when floating coercions]+-- Returned SimplEnv has same substitution as incoming one+makeTrivialWithInfo mode top_lvl occ_fs info expr+  | exprIsTrivial expr                          -- Already trivial+  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise+                                                --   See Note [Cannot trivialise]+  = return (emptyLetFloats, expr)++  | otherwise+  = do  { (floats, expr1) <- prepareRhs mode top_lvl occ_fs info expr+        ; if   exprIsTrivial expr1  -- See Note [Trivial after prepareRhs]+          then return (floats, expr1)+          else do+        { uniq <- getUniqueM+        ; let name = mkSystemVarName uniq occ_fs+              var  = mkLocalIdWithInfo name expr_ty info++        -- Now something very like completeBind,+        -- but without the postInlineUnconditionally part+        ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1+        ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2++        ; let final_id = addLetBndrInfo var arity is_bot unf+              bind     = NonRec final_id expr2++        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }}+   where+     expr_ty = exprType expr++bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool+-- True iff we can have a binding of this expression at this level+-- Precondition: the type is the type of the expression+bindingOk top_lvl expr expr_ty+  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty+  | otherwise          = True++{- Note [Trivial after prepareRhs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we call makeTrival on (e |> co), the recursive use of prepareRhs+may leave us with+   { a1 = e }  and   (a1 |> co)+Now the latter is trivial, so we don't want to let-bind it.++Note [Cannot trivialise]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   f :: Int -> Addr#++   foo :: Bar+   foo = Bar (f 3)++Then we can't ANF-ise foo, even though we'd like to, because+we can't make a top-level binding for the Addr# (f 3). And if+so we don't want to turn it into+   foo = let x = f 3 in Bar x+because we'll just end up inlining x back, and that makes the+simplifier loop.  Better not to ANF-ise it at all.++Literal strings are an exception.++   foo = Ptr "blob"#++We want to turn this into:++   foo1 = "blob"#+   foo = Ptr foo1++See Note [Core top-level string literals] in GHC.Core.++************************************************************************+*                                                                      *+          Completing a lazy binding+*                                                                      *+************************************************************************++completeBind+  * deals only with Ids, not TyVars+  * takes an already-simplified binder and RHS+  * is used for both recursive and non-recursive bindings+  * is used for both top-level and non-top-level bindings++It does the following:+  - tries discarding a dead binding+  - tries PostInlineUnconditionally+  - add unfolding [this is the only place we add an unfolding]+  - add arity++It does *not* attempt to do let-to-case.  Why?  Because it is used for+  - top-level bindings (when let-to-case is impossible)+  - many situations where the "rhs" is known to be a WHNF+                (so let-to-case is inappropriate).++Nor does it do the atomic-argument thing+-}++completeBind :: SimplEnv+             -> TopLevelFlag            -- Flag stuck into unfolding+             -> MaybeJoinCont           -- Required only for join point+             -> InId                    -- Old binder+             -> OutId -> OutExpr        -- New binder and RHS+             -> SimplM (SimplFloats, SimplEnv)+-- completeBind may choose to do its work+--      * by extending the substitution (e.g. let x = y in ...)+--      * or by adding to the floats in the envt+--+-- Binder /can/ be a JoinId+-- Precondition: rhs obeys the let/app invariant+completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs+ | isCoVar old_bndr+ = case new_rhs of+     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)+     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))++ | otherwise+ = ASSERT( isId new_bndr )+   do { let old_info = idInfo old_bndr+            old_unf  = unfoldingInfo old_info+            occ_info = occInfo old_info++         -- Do eta-expansion on the RHS of the binding+         -- See Note [Eta-expanding at let bindings] in GHC.Core.Op.Simplify.Utils+      ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env)+                                                          new_bndr new_rhs++        -- Simplify the unfolding+      ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr+                                           final_rhs (idType new_bndr) old_unf++      ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding+        -- See Note [In-scope set as a substitution]++      ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs++        then -- Inline and discard the binding+             do  { tick (PostInlineUnconditionally old_bndr)+                 ; return ( emptyFloats env+                          , extendIdSubst env old_bndr $+                            DoneEx final_rhs (isJoinId_maybe new_bndr)) }+                -- Use the substitution to make quite, quite sure that the+                -- substitution will happen, since we are going to discard the binding++        else -- Keep the binding+             -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $+             return (mkFloatBind env (NonRec final_bndr final_rhs)) }++addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId+addLetBndrInfo new_bndr new_arity is_bot new_unf+  = new_bndr `setIdInfo` info5+  where+    info1 = idInfo new_bndr `setArityInfo` new_arity++    -- Unfolding info: Note [Setting the new unfolding]+    info2 = info1 `setUnfoldingInfo` new_unf++    -- Demand info: Note [Setting the demand info]+    -- We also have to nuke demand info if for some reason+    -- eta-expansion *reduces* the arity of the binding to less+    -- than that of the strictness sig. This can happen: see Note [Arity decrease].+    info3 | isEvaldUnfolding new_unf+            || (case strictnessInfo info2 of+                  StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)+          = zapDemandInfo info2 `orElse` info2+          | otherwise+          = info2++    -- Bottoming bindings: see Note [Bottoming bindings]+    info4 | is_bot    = info3+                          `setStrictnessInfo`+                            mkClosedStrictSig (replicate new_arity topDmd) botDiv+                          `setCprInfo` mkCprSig new_arity botCpr+          | otherwise = info3++     -- Zap call arity info. We have used it by now (via+     -- `tryEtaExpandRhs`), and the simplifier can invalidate this+     -- information, leading to broken code later (e.g. #13479)+    info5 = zapCallArityInfo info4+++{- Note [Arity decrease]+~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking the arity of a binding should not decrease.  But it *can*+legitimately happen because of RULES.  Eg+        f = g Int+where g has arity 2, will have arity 2.  But if there's a rewrite rule+        g Int --> h+where h has arity 1, then f's arity will decrease.  Here's a real-life example,+which is in the output of Specialise:++     Rec {+        $dm {Arity 2} = \d.\x. op d+        {-# RULES forall d. $dm Int d = $s$dm #-}++        dInt = MkD .... opInt ...+        opInt {Arity 1} = $dm dInt++        $s$dm {Arity 0} = \x. op dInt }++Here opInt has arity 1; but when we apply the rule its arity drops to 0.+That's why Specialise goes to a little trouble to pin the right arity+on specialised functions too.++Note [Bottoming bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   let x = error "urk"+   in ...(case x of <alts>)...+or+   let f = \x. error (x ++ "urk")+   in ...(case f "foo" of <alts>)...++Then we'd like to drop the dead <alts> immediately.  So it's good to+propagate the info that x's RHS is bottom to x's IdInfo as rapidly as+possible.++We use tryEtaExpandRhs on every binding, and it turns ou that the+arity computation it performs (via GHC.Core.Arity.findRhsArity) already+does a simple bottoming-expression analysis.  So all we need to do+is propagate that info to the binder's IdInfo.++This showed up in #12150; see comment:16.++Note [Setting the demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the unfolding is a value, the demand info may+go pear-shaped, so we nuke it.  Example:+     let x = (a,b) in+     case x of (p,q) -> h p q x+Here x is certainly demanded. But after we've nuked+the case, we'll get just+     let x = (a,b) in h a b x+and now x is not demanded (I'm assuming h is lazy)+This really happens.  Similarly+     let f = \x -> e in ...f..f...+After inlining f at some of its call sites the original binding may+(for example) be no longer strictly demanded.+The solution here is a bit ad hoc...+++************************************************************************+*                                                                      *+\subsection[Simplify-simplExpr]{The main function: simplExpr}+*                                                                      *+************************************************************************++The reason for this OutExprStuff stuff is that we want to float *after*+simplifying a RHS, not before.  If we do so naively we get quadratic+behaviour as things float out.++To see why it's important to do it after, consider this (real) example:++        let t = f x+        in fst t+==>+        let t = let a = e1+                    b = e2+                in (a,b)+        in fst t+==>+        let a = e1+            b = e2+            t = (a,b)+        in+        a       -- Can't inline a this round, cos it appears twice+==>+        e1++Each of the ==> steps is a round of simplification.  We'd save a+whole round if we float first.  This can cascade.  Consider++        let f = g d+        in \x -> ...f...+==>+        let f = let d1 = ..d.. in \y -> e+        in \x -> ...f...+==>+        let d1 = ..d..+        in \x -> ...(\y ->e)...++Only in this second round can the \y be applied, and it+might do the same again.+-}++simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr+simplExpr env (Type ty)+  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]+       ; return (Type ty') }++simplExpr env expr+  = simplExprC env expr (mkBoringStop expr_out_ty)+  where+    expr_out_ty :: OutType+    expr_out_ty = substTy env (exprType expr)+    -- NB: Since 'expr' is term-valued, not (Type ty), this call+    --     to exprType will succeed.  exprType fails on (Type ty).++simplExprC :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM OutExpr+        -- Simplify an expression, given a continuation+simplExprC env expr cont+  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $+    do  { (floats, expr') <- simplExprF env expr cont+        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $+          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $+          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $+          return (wrapFloats floats expr') }++--------------------------------------------------+simplExprF :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM (SimplFloats, OutExpr)++simplExprF env e cont+  = {- pprTrace "simplExprF" (vcat+      [ ppr e+      , text "cont =" <+> ppr cont+      , text "inscope =" <+> ppr (seInScope env)+      , text "tvsubst =" <+> ppr (seTvSubst env)+      , text "idsubst =" <+> ppr (seIdSubst env)+      , text "cvsubst =" <+> ppr (seCvSubst env)+      ]) $ -}+    simplExprF1 env e cont++simplExprF1 :: SimplEnv -> InExpr -> SimplCont+            -> SimplM (SimplFloats, OutExpr)++simplExprF1 _ (Type ty) _+  = pprPanic "simplExprF: type" (ppr ty)+    -- simplExprF does only with term-valued expressions+    -- The (Type ty) case is handled separately by simplExpr+    -- and by the other callers of simplExprF++simplExprF1 env (Var v)        cont = {-#SCC "simplIdF" #-} simplIdF env v cont+simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont+simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont+simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont+simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont++simplExprF1 env (App fun arg) cont+  = {-#SCC "simplExprF1-App" #-} case arg of+      Type ty -> do { -- The argument type will (almost) certainly be used+                      -- in the output program, so just force it now.+                      -- See Note [Avoiding space leaks in OutType]+                      arg' <- simplType env ty++                      -- But use substTy, not simplType, to avoid forcing+                      -- the hole type; it will likely not be needed.+                      -- See Note [The hole type in ApplyToTy]+                    ; let hole' = substTy env (exprType fun)++                    ; simplExprF env fun $+                      ApplyToTy { sc_arg_ty  = arg'+                                , sc_hole_ty = hole'+                                , sc_cont    = cont } }+      _       -> simplExprF env fun $+                 ApplyToVal { sc_arg = arg, sc_env = env+                            , sc_dup = NoDup, sc_cont = cont }++simplExprF1 env expr@(Lam {}) cont+  = {-#SCC "simplExprF1-Lam" #-}+    simplLam env zapped_bndrs body cont+        -- The main issue here is under-saturated lambdas+        --   (\x1. \x2. e) arg1+        -- Here x1 might have "occurs-once" occ-info, because occ-info+        -- is computed assuming that a group of lambdas is applied+        -- all at once.  If there are too few args, we must zap the+        -- occ-info, UNLESS the remaining binders are one-shot+  where+    (bndrs, body) = collectBinders expr+    zapped_bndrs | need_to_zap = map zap bndrs+                 | otherwise   = bndrs++    need_to_zap = any zappable_bndr (drop n_args bndrs)+    n_args = countArgs cont+        -- NB: countArgs counts all the args (incl type args)+        -- and likewise drop counts all binders (incl type lambdas)++    zappable_bndr b = isId b && not (isOneShotBndr b)+    zap b | isTyVar b = b+          | otherwise = zapLamIdInfo b++simplExprF1 env (Case scrut bndr _ alts) cont+  = {-#SCC "simplExprF1-Case" #-}+    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr+                                 , sc_alts = alts+                                 , sc_env = env, sc_cont = cont })++simplExprF1 env (Let (Rec pairs) body) cont+  | Just pairs' <- joinPointBindings_maybe pairs+  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont++  | otherwise+  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont++simplExprF1 env (Let (NonRec bndr rhs) body) cont+  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)+  = {-#SCC "simplExprF1-NonRecLet-Type" #-}+    ASSERT( isTyVar bndr )+    do { ty' <- simplType env ty+       ; simplExprF (extendTvSubst env bndr ty') body cont }++  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs+  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont++  | otherwise+  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont++{- Note [Avoiding space leaks in OutType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the simplifier is run for multiple iterations, we need to ensure+that any thunks in the output of one simplifier iteration are forced+by the evaluation of the next simplifier iteration. Otherwise we may+retain multiple copies of the Core program and leak a terrible amount+of memory (as in #13426).++The simplifier is naturally strict in the entire "Expr part" of the+input Core program, because any expression may contain binders, which+we must find in order to extend the SimplEnv accordingly. But types+do not contain binders and so it is tempting to write things like++    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!++This is Bad because the result includes a thunk (substTy env ty) which+retains a reference to the whole simplifier environment; and the next+simplifier iteration will not force this thunk either, because the+line above is not strict in ty.++So instead our strategy is for the simplifier to fully evaluate+OutTypes when it emits them into the output Core program, for example++    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good+                                 ; return (Type ty') }++where the only difference from above is that simplType calls seqType+on the result of substTy.++However, SimplCont can also contain OutTypes and it's not necessarily+a good idea to force types on the way in to SimplCont, because they+may end up not being used and forcing them could be a lot of wasted+work. T5631 is a good example of this.++- For ApplyToTy's sc_arg_ty, we force the type on the way in because+  the type will almost certainly appear as a type argument in the+  output program.++- For the hole types in Stop and ApplyToTy, we force the type when we+  emit it into the output program, after obtaining it from+  contResultType. (The hole type in ApplyToTy is only directly used+  to form the result type in a new Stop continuation.)+-}++---------------------------------+-- Simplify a join point, adding the context.+-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:+--   \x1 .. xn -> e => \x1 .. xn -> E[e]+-- Note that we need the arity of the join point, since e may be a lambda+-- (though this is unlikely). See Note [Join points and case-of-case].+simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont+             -> SimplM OutExpr+simplJoinRhs env bndr expr cont+  | Just arity <- isJoinId_maybe bndr+  =  do { let (join_bndrs, join_body) = collectNBinders arity expr+        ; (env', join_bndrs') <- simplLamBndrs env join_bndrs+        ; join_body' <- simplExprC env' join_body cont+        ; return $ mkLams join_bndrs' join_body' }++  | otherwise+  = pprPanic "simplJoinRhs" (ppr bndr)++---------------------------------+simplType :: SimplEnv -> InType -> SimplM OutType+        -- Kept monadic just so we can do the seqType+        -- See Note [Avoiding space leaks in OutType]+simplType env ty+  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $+    seqType new_ty `seq` return new_ty+  where+    new_ty = substTy env ty++---------------------------------+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont+               -> SimplM (SimplFloats, OutExpr)+simplCoercionF env co cont+  = do { co' <- simplCoercion env co+       ; rebuild env (Coercion co') cont }++simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion+simplCoercion env co+  = do { dflags <- getDynFlags+       ; let opt_co = optCoercion dflags (getTCvSubst env) co+       ; seqCo opt_co `seq` return opt_co }++-----------------------------------+-- | Push a TickIt context outwards past applications and cases, as+-- long as this is a non-scoping tick, to let case and application+-- optimisations apply.++simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplTick env tickish expr cont+  -- A scoped tick turns into a continuation, so that we can spot+  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do+  -- it this way, then it would take two passes of the simplifier to+  -- reduce ((scc t (\x . e)) e').+  -- NB, don't do this with counting ticks, because if the expr is+  -- bottom, then rebuildCall will discard the continuation.++-- XXX: we cannot do this, because the simplifier assumes that+-- the context can be pushed into a case with a single branch. e.g.+--    scc<f>  case expensive of p -> e+-- becomes+--    case expensive of p -> scc<f> e+--+-- So I'm disabling this for now.  It just means we will do more+-- simplifier iterations that necessary in some cases.++--  | tickishScoped tickish && not (tickishCounts tickish)+--  = simplExprF env expr (TickIt tickish cont)++  -- For unscoped or soft-scoped ticks, we are allowed to float in new+  -- cost, so we simply push the continuation inside the tick.  This+  -- has the effect of moving the tick to the outside of a case or+  -- application context, allowing the normal case and application+  -- optimisations to fire.+  | tickish `tickishScopesLike` SoftScope+  = do { (floats, expr') <- simplExprF env expr cont+       ; return (floats, mkTick tickish expr')+       }++  -- Push tick inside if the context looks like this will allow us to+  -- do a case-of-case - see Note [case-of-scc-of-case]+  | Select {} <- cont, Just expr' <- push_tick_inside+  = simplExprF env expr' cont++  -- We don't want to move the tick, but we might still want to allow+  -- floats to pass through with appropriate wrapping (or not, see+  -- wrap_floats below)+  --- | not (tickishCounts tickish) || tickishCanSplit tickish+  -- = wrap_floats++  | otherwise+  = no_floating_past_tick++ where++  -- Try to push tick inside a case, see Note [case-of-scc-of-case].+  push_tick_inside =+    case expr0 of+      Case scrut bndr ty alts+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)+      _other -> Nothing+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)+         movable t      = not (tickishCounts t) ||+                          t `tickishScopesLike` NoScope ||+                          tickishCanSplit t+         tickScrut e    = foldr mkTick e ticks+         -- Alternatives get annotated with all ticks that scope in some way,+         -- but we don't want to count entries.+         tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope)+         ts_scope         = map mkNoCount $+                            filter (not . (`tickishScopesLike` NoScope)) ticks++  no_floating_past_tick =+    do { let (inc,outc) = splitCont cont+       ; (floats, expr1) <- simplExprF env expr inc+       ; let expr2    = wrapFloats floats expr1+             tickish' = simplTickish env tickish+       ; rebuild env (mkTick tickish' expr2) outc+       }++-- Alternative version that wraps outgoing floats with the tick.  This+-- results in ticks being duplicated, as we don't make any attempt to+-- eliminate the tick if we re-inline the binding (because the tick+-- semantics allows unrestricted inlining of HNFs), so I'm not doing+-- this any more.  FloatOut will catch any real opportunities for+-- floating.+--+--  wrap_floats =+--    do { let (inc,outc) = splitCont cont+--       ; (env', expr') <- simplExprF (zapFloats env) expr inc+--       ; let tickish' = simplTickish env tickish+--       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),+--                                   mkTick (mkNoCount tickish') rhs)+--              -- when wrapping a float with mkTick, we better zap the Id's+--              -- strictness info and arity, because it might be wrong now.+--       ; let env'' = addFloats env (mapFloats env' wrap_float)+--       ; rebuild env'' expr' (TickIt tickish' outc)+--       }+++  simplTickish env tickish+    | Breakpoint n ids <- tickish+          = Breakpoint n (map (getDoneId . substId env) ids)+    | otherwise = tickish++  -- Push type application and coercion inside a tick+  splitCont :: SimplCont -> (SimplCont, SimplCont)+  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)+    where (inc,outc) = splitCont tail+  splitCont (CastIt co c) = (CastIt co inc, outc)+    where (inc,outc) = splitCont c+  splitCont other = (mkBoringStop (contHoleType other), other)++  getDoneId (DoneId id)  = id+  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst+  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:+--+--        case scctick<code_string.r1>+--             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje+--             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->+--             (ww1_s13f, ww2_s13g, ww3_s13h)+--             }+--        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->+--        tick<code_string.f1>+--        (ww_s12Y,+--         ww1_s12Z,+--         PTTrees.PT+--           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)+--        }+--+-- We really want this case-of-case to fire, because then the 3-tuple+-- will go away (indeed, the CPR optimisation is relying on this+-- happening).  But the scctick is in the way - we need to push it+-- inside to expose the case-of-case.  So we perform this+-- transformation on the inner case:+--+--   scctick c (case e of { p1 -> e1; ...; pn -> en })+--    ==>+--   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }+--+-- So we've moved a constant amount of work out of the scc to expose+-- the case.  We only do this when the continuation is interesting: in+-- for now, it has to be another Case (maybe generalise this later).++{-+************************************************************************+*                                                                      *+\subsection{The main rebuilder}+*                                                                      *+************************************************************************+-}++rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+-- At this point the substitution in the SimplEnv should be irrelevant;+-- only the in-scope set matters+rebuild env expr cont+  = case cont of+      Stop {}          -> return (emptyFloats env, expr)+      TickIt t cont    -> rebuild env (mkTick t expr) cont+      CastIt co cont   -> rebuild env (mkCast expr co) cont+                       -- NB: mkCast implements the (Coercion co |> g) optimisation++      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }+        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont++      StrictArg { sc_fun = fun, sc_cont = cont }+        -> rebuildCall env (fun `addValArgTo` expr) cont+      StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body+                 , sc_env = se, sc_cont = cont }+        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr+                                  -- expr satisfies let/app since it started life+                                  -- in a call to simplNonRecE+              ; (floats2, expr') <- simplLam env' bs body cont+              ; return (floats1 `addFloats` floats2, expr') }++      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}+        -> rebuild env (App expr (Type ty)) cont++      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}+        -- See Note [Avoid redundant simplification]+        -> do { (_, _, arg') <- simplArg env dup_flag se arg+              ; rebuild env (App expr arg') cont }++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++{- Note [Optimising reflexivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important (for compiler performance) to get rid of reflexivity as soon+as it appears.  See #11735, #14737, and #15019.++In particular, we want to behave well on++ *  e |> co1 |> co2+    where the two happen to cancel out entirely. That is quite common;+    e.g. a newtype wrapping and unwrapping cancel.+++ * (f |> co) @t1 @t2 ... @tn x1 .. xm+   Here we wil use pushCoTyArg and pushCoValArg successively, which+   build up NthCo stacks.  Silly to do that if co is reflexive.++However, we don't want to call isReflexiveCo too much, because it uses+type equality which is expensive on big types (#14737 comment:7).++A good compromise (determined experimentally) seems to be to call+isReflexiveCo+ * when composing casts, and+ * at the end++In investigating this I saw missed opportunities for on-the-fly+coercion shrinkage. See #15090.+-}+++simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplCast env body co0 cont0+  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0+        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}+                   if isReflCo co1+                   then return cont0  -- See Note [Optimising reflexivity]+                   else addCoerce co1 cont0+        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }+  where+        -- If the first parameter is MRefl, then simplifying revealed a+        -- reflexive coercion. Omit.+        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont+        addCoerceM MRefl   cont = return cont+        addCoerceM (MCo co) cont = addCoerce co cont++        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont+        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]+          | isReflexiveCo co' = return cont+          | otherwise         = addCoerce co' cont+          where+            co' = mkTransCo co1 co2++        addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })+          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty+            -- N.B. As mentioned in Note [The hole type in ApplyToTy] this is+            -- only needed by `sc_hole_ty` which is often not forced.+            -- Consequently it is worthwhile using a lazy pattern match here to+            -- avoid unnecessary coercionKind evaluations.+          , let hole_ty = coercionLKind co+          = {-#SCC "addCoerce-pushCoTyArg" #-}+            do { tail' <- addCoerceM m_co' tail+               ; return (cont { sc_arg_ty  = arg_ty'+                              , sc_hole_ty = hole_ty  -- NB!  As the cast goes past, the+                                                      -- type of the hole changes (#16312)+                              , sc_cont    = tail' }) }++        addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se+                                      , sc_dup = dup, sc_cont = tail })+          | Just (co1, m_co2) <- pushCoValArg co+          , let new_ty = coercionRKind co1+          , not (isTypeLevPoly new_ty)  -- Without this check, we get a lev-poly arg+                                        -- See Note [Levity polymorphism invariants] in GHC.Core+                                        -- test: typecheck/should_run/EtaExpandLevPoly+          = {-#SCC "addCoerce-pushCoValArg" #-}+            do { tail' <- addCoerceM m_co2 tail+               ; if isReflCo co1+                 then return (cont { sc_cont = tail' })+                      -- Avoid simplifying if possible;+                      -- See Note [Avoiding exponential behaviour]+                 else do+               { (dup', arg_se', arg') <- simplArg env dup arg_se arg+                    -- When we build the ApplyTo we can't mix the OutCoercion+                    -- 'co' with the InExpr 'arg', so we simplify+                    -- to make it all consistent.  It's a bit messy.+                    -- But it isn't a common case.+                    -- Example of use: #995+               ; return (ApplyToVal { sc_arg  = mkCast arg' co1+                                    , sc_env  = arg_se'+                                    , sc_dup  = dup'+                                    , sc_cont = tail' }) } }++        addCoerce co cont+          | isReflexiveCo co = return cont  -- Having this at the end makes a huge+                                            -- difference in T12227, for some reason+                                            -- See Note [Optimising reflexivity]+          | otherwise        = return (CastIt co cont)++simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr+         -> SimplM (DupFlag, StaticEnv, OutExpr)+simplArg env dup_flag arg_env arg+  | isSimplified dup_flag+  = return (dup_flag, arg_env, arg)+  | otherwise+  = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg+       ; return (Simplified, zapSubstEnv arg_env, arg') }++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++simplLam env [] body cont+  = simplExprF env body cont++simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })+  = do { tick (BetaReduction bndr)+       ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont }++simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se+                                           , sc_cont = cont, sc_dup = dup })+  | isSimplified dup  -- Don't re-simplify if we've simplified it once+                      -- See Note [Avoiding exponential behaviour]+  = do  { tick (BetaReduction bndr)+        ; (floats1, env') <- simplNonRecX env zapped_bndr arg+        ; (floats2, expr') <- simplLam env' bndrs body cont+        ; return (floats1 `addFloats` floats2, expr') }++  | otherwise+  = do  { tick (BetaReduction bndr)+        ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont }+  where+    zapped_bndr  -- See Note [Zap unfolding when beta-reducing]+      | isId bndr = zapStableUnfolding bndr+      | otherwise = bndr++      -- Discard a non-counting tick on a lambda.  This may change the+      -- cost attribution slightly (moving the allocation of the+      -- lambda elsewhere), but we don't care: optimisation changes+      -- cost attribution all the time.+simplLam env bndrs body (TickIt tickish cont)+  | not (tickishCounts tickish)+  = simplLam env bndrs body cont++        -- Not enough args, so there are real lambdas left to put in the result+simplLam env bndrs body cont+  = do  { (env', bndrs') <- simplLamBndrs env bndrs+        ; body' <- simplExpr env' body+        ; new_lam <- mkLam env bndrs' body' cont+        ; rebuild env' new_lam cont }++-------------+simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- Used for lambda binders.  These sometimes have unfoldings added by+-- the worker/wrapper pass that must be preserved, because they can't+-- be reconstructed from context.  For example:+--      f x = case x of (a,b) -> fw a b x+--      fw a b x{=(a,b)} = ...+-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.+simplLamBndr env bndr+  | isId bndr && isFragileUnfolding old_unf   -- Special case+  = do { (env1, bndr1) <- simplBinder env bndr+       ; unf'          <- simplStableUnfolding env1 NotTopLevel Nothing bndr+                                               old_unf (idType bndr1)+       ; let bndr2 = bndr1 `setIdUnfolding` unf'+       ; return (modifyInScope env1 bndr2, bndr2) }++  | otherwise+  = simplBinder env bndr                -- Normal case+  where+    old_unf = idUnfolding bndr++simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs++------------------+simplNonRecE :: SimplEnv+             -> InId                    -- The binder, always an Id+                                        -- Never a join point+             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)+             -> ([InBndr], InExpr)      -- Body of the let/lambda+                                        --      \xs.e+             -> SimplCont+             -> SimplM (SimplFloats, OutExpr)++-- simplNonRecE is used for+--  * non-top-level non-recursive non-join-point lets in expressions+--  * beta reduction+--+-- simplNonRec env b (rhs, rhs_se) (bs, body) k+--   = let env in+--     cont< let b = rhs_se(rhs) in \bs.body >+--+-- It deals with strict bindings, via the StrictBind continuation,+-- which may abort the whole process+--+-- Precondition: rhs satisfies the let/app invariant+--               Note [Core let/app invariant] in GHC.Core+--+-- The "body" of the binding comes as a pair of ([InId],InExpr)+-- representing a lambda; so we recurse back to simplLam+-- Why?  Because of the binder-occ-info-zapping done before+--       the call to simplLam in simplExprF (Lam ...)++simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont+  | ASSERT( isId bndr && not (isJoinId bndr) ) True+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se+  = do { tick (PreInlineUnconditionally bndr)+       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $+         simplLam env' bndrs body cont }++  -- Deal with strict bindings+  | isStrictId bndr          -- Includes coercions+  , sm_case_case (getMode env)+  = simplExprF (rhs_se `setInScopeFromE` env) rhs+               (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body+                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })++  -- Deal with lazy bindings+  | otherwise+  = ASSERT( not (isTyVar bndr) )+    do { (env1, bndr1) <- simplNonRecBndr env bndr+       ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing+       ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se+       ; (floats2, expr') <- simplLam env3 bndrs body cont+       ; return (floats1 `addFloats` floats2, expr') }++------------------+simplRecE :: SimplEnv+          -> [(InId, InExpr)]+          -> InExpr+          -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- simplRecE is used for+--  * non-top-level recursive lets in expressions+simplRecE env pairs body cont+  = do  { let bndrs = map fst pairs+        ; MASSERT(all (not . isJoinId) bndrs)+        ; env1 <- simplRecBndrs env bndrs+                -- NB: bndrs' don't have unfoldings or rules+                -- We add them as we go down+        ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs+        ; (floats2, expr') <- simplExprF env2 body cont+        ; return (floats1 `addFloats` floats2, expr') }++{- Note [Avoiding exponential behaviour]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One way in which we can get exponential behaviour is if we simplify a+big expression, and the re-simplify it -- and then this happens in a+deeply-nested way.  So we must be jolly careful about re-simplifying+an expression.  That is why completeNonRecX does not try+preInlineUnconditionally.++Example:+  f BIG, where f has a RULE+Then+ * We simplify BIG before trying the rule; but the rule does not fire+ * We inline f = \x. x True+ * So if we did preInlineUnconditionally we'd re-simplify (BIG True)++However, if BIG has /not/ already been simplified, we'd /like/ to+simplify BIG True; maybe good things happen.  That is why++* simplLam has+    - a case for (isSimplified dup), which goes via simplNonRecX, and+    - a case for the un-simplified case, which goes via simplNonRecE++* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,+  in at least two places+    - In simplCast/addCoerce, where we check for isReflCo+    - In rebuildCall we avoid simplifying arguments before we have to+      (see Note [Trying rewrite rules])+++Note [Zap unfolding when beta-reducing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Lambda-bound variables can have stable unfoldings, such as+   $j = \x. \b{Unf=Just x}. e+See Note [Case binders and join points] below; the unfolding for lets+us optimise e better.  However when we beta-reduce it we want to+revert to using the actual value, otherwise we can end up in the+stupid situation of+          let x = blah in+          let b{Unf=Just x} = y+          in ...b...+Here it'd be far better to drop the unfolding and use the actual RHS.++************************************************************************+*                                                                      *+                     Join points+*                                                                      *+********************************************************************* -}++{- Note [Rules and unfolding for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   simplExpr (join j x = rhs                         ) cont+             (      {- RULE j (p:ps) = blah -}       )+             (      {- StableUnfolding j = blah -}   )+             (in blah                                )++Then we will push 'cont' into the rhs of 'j'.  But we should *also* push+'cont' into the RHS of+  * Any RULEs for j, e.g. generated by SpecConstr+  * Any stable unfolding for j, e.g. the result of an INLINE pragma++Simplifying rules and stable-unfoldings happens a bit after+simplifying the right-hand side, so we remember whether or not it+is a join point, and what 'cont' is, in a value of type MaybeJoinCont++#13900 was caused by forgetting to push 'cont' into the RHS+of a SpecConstr-generated RULE for a join point.+-}++type MaybeJoinCont = Maybe SimplCont+  -- Nothing => Not a join point+  -- Just k  => This is a join binding with continuation k+  -- See Note [Rules and unfolding for join points]++simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr+                     -> InExpr -> SimplCont+                     -> SimplM (SimplFloats, OutExpr)+simplNonRecJoinPoint env bndr rhs body cont+  | ASSERT( isJoinId bndr ) True+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env+  = do { tick (PreInlineUnconditionally bndr)+       ; simplExprF env' body cont }++   | otherwise+   = wrapJoinCont env cont $ \ env cont ->+     do { -- We push join_cont into the join RHS and the body;+          -- and wrap wrap_cont around the whole thing+        ; let res_ty = contResultType cont+        ; (env1, bndr1)    <- simplNonRecJoinBndr env res_ty bndr+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (Just cont)+        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env+        ; (floats2, body') <- simplExprF env3 body cont+        ; return (floats1 `addFloats` floats2, body') }+++------------------+simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]+                  -> InExpr -> SimplCont+                  -> SimplM (SimplFloats, OutExpr)+simplRecJoinPoint env pairs body cont+  = wrapJoinCont env cont $ \ env cont ->+    do { let bndrs = map fst pairs+             res_ty = contResultType cont+       ; env1 <- simplRecJoinBndrs env res_ty bndrs+               -- NB: bndrs' don't have unfoldings or rules+               -- We add them as we go down+       ; (floats1, env2)  <- simplRecBind env1 NotTopLevel (Just cont) pairs+       ; (floats2, body') <- simplExprF env2 body cont+       ; return (floats1 `addFloats` floats2, body') }++--------------------+wrapJoinCont :: SimplEnv -> SimplCont+             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))+             -> SimplM (SimplFloats, OutExpr)+-- Deal with making the continuation duplicable if necessary,+-- and with the no-case-of-case situation.+wrapJoinCont env cont thing_inside+  | contIsStop cont        -- Common case; no need for fancy footwork+  = thing_inside env cont++  | not (sm_case_case (getMode env))+    -- See Note [Join points with -fno-case-of-case]+  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))+       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1+       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont+       ; return (floats2 `addFloats` floats3, expr3) }++  | otherwise+    -- Normal case; see Note [Join points and case-of-case]+  = do { (floats1, cont')  <- mkDupableCont env cont+       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'+       ; return (floats1 `addFloats` floats2, result) }+++--------------------+trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont+-- Drop outer context from join point invocation (jump)+-- See Note [Join points and case-of-case]++trimJoinCont _ Nothing cont+  = cont -- Not a jump+trimJoinCont var (Just arity) cont+  = trim arity cont+  where+    trim 0 cont@(Stop {})+      = cont+    trim 0 cont+      = mkBoringStop (contResultType cont)+    trim n cont@(ApplyToVal { sc_cont = k })+      = cont { sc_cont = trim (n-1) k }+    trim n cont@(ApplyToTy { sc_cont = k })+      = cont { sc_cont = trim (n-1) k } -- join arity counts types!+    trim _ cont+      = pprPanic "completeCall" $ ppr var $$ ppr cont+++{- Note [Join points and case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we perform the case-of-case transform (or otherwise push continuations+inward), we want to treat join points specially. Since they're always+tail-called and we want to maintain this invariant, we can do this (for any+evaluation context E):++  E[join j = e+    in case ... of+         A -> jump j 1+         B -> jump j 2+         C -> f 3]++    -->++  join j = E[e]+  in case ... of+       A -> jump j 1+       B -> jump j 2+       C -> E[f 3]++As is evident from the example, there are two components to this behavior:++  1. When entering the RHS of a join point, copy the context inside.+  2. When a join point is invoked, discard the outer context.++We need to be very careful here to remain consistent---neither part is+optional!++We need do make the continuation E duplicable (since we are duplicating it)+with mkDupableCont.+++Note [Join points with -fno-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Supose case-of-case is switched off, and we are simplifying++    case (join j x = <j-rhs> in+          case y of+             A -> j 1+             B -> j 2+             C -> e) of <outer-alts>++Usually, we'd push the outer continuation (case . of <outer-alts>) into+both the RHS and the body of the join point j.  But since we aren't doing+case-of-case we may then end up with this totally bogus result++    join x = case <j-rhs> of <outer-alts> in+    case (case y of+             A -> j 1+             B -> j 2+             C -> e) of <outer-alts>++This would be OK in the language of the paper, but not in GHC: j is no longer+a join point.  We can only do the "push continuation into the RHS of the+join point j" if we also push the continuation right down to the /jumps/ to+j, so that it can evaporate there.  If we are doing case-of-case, we'll get to++    join x = case <j-rhs> of <outer-alts> in+    case y of+      A -> j 1+      B -> j 2+      C -> case e of <outer-alts>++which is great.++Bottom line: if case-of-case is off, we must stop pushing the continuation+inwards altogether at any join point.  Instead simplify the (join ... in ...)+with a Stop continuation, and wrap the original continuation around the+outside.  Surprisingly tricky!+++************************************************************************+*                                                                      *+                     Variables+*                                                                      *+************************************************************************+-}++simplVar :: SimplEnv -> InVar -> SimplM OutExpr+-- Look up an InVar in the environment+simplVar env var+  | isTyVar var = return (Type (substTyVar env var))+  | isCoVar var = return (Coercion (substCoVar env var))+  | otherwise+  = case substId env var of+        ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e+        DoneId var1          -> return (Var var1)+        DoneEx e _           -> return e++simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)+simplIdF env var cont+  = case substId env var of+      ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont+                                -- Don't trim; haven't already simplified e,+                                -- so the cont is not embodied in e++      DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont)++      DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont)+              -- Note [zapSubstEnv]+              -- The template is already simplified, so don't re-substitute.+              -- This is VITAL.  Consider+              --      let x = e in+              --      let y = \z -> ...x... in+              --      \ x -> ...y...+              -- We'll clone the inner \x, adding x->x' in the id_subst+              -- Then when we inline y, we must *not* replace x by x' in+              -- the inlined copy!!++---------------------------------------------------------+--      Dealing with a call site++completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)+completeCall env var cont+  | Just expr <- callSiteInline dflags var active_unf+                                lone_variable arg_infos interesting_cont+  -- Inline the variable's RHS+  = do { checkedTick (UnfoldingDone var)+       ; dump_inline expr cont+       ; simplExprF (zapSubstEnv env) expr cont }++  | otherwise+  -- Don't inline; instead rebuild the call+  = do { rule_base <- getSimplRules+       ; let info = mkArgInfo env var (getRules rule_base var)+                              n_val_args call_cont+       ; rebuildCall env info cont }++  where+    dflags = seDynFlags env+    (lone_variable, arg_infos, call_cont) = contArgs cont+    n_val_args       = length arg_infos+    interesting_cont = interestingCallContext env call_cont+    active_unf       = activeUnfolding (getMode env) var++    log_inlining doc+      = liftIO $ dumpAction dflags+           (mkUserStyle dflags alwaysQualify AllTheWay)+           (dumpOptionsFromFlag Opt_D_dump_inlinings)+           "" FormatText doc++    dump_inline unfolding cont+      | not (dopt Opt_D_dump_inlinings dflags) = return ()+      | not (dopt Opt_D_verbose_core2core dflags)+      = when (isExternalName (idName var)) $+            log_inlining $+                sep [text "Inlining done:", nest 4 (ppr var)]+      | otherwise+      = liftIO $ log_inlining $+           sep [text "Inlining done: " <> ppr var,+                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),+                              text "Cont:  " <+> ppr cont])]++rebuildCall :: SimplEnv+            -> ArgInfo+            -> SimplCont+            -> SimplM (SimplFloats, OutExpr)+-- We decided not to inline, so+--    - simplify the arguments+--    - try rewrite rules+--    - and rebuild++---------- Bottoming applications --------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont+  -- When we run out of strictness args, it means+  -- that the call is definitely bottom; see GHC.Core.Op.Simplify.Utils.mkArgInfo+  -- Then we want to discard the entire strict continuation.  E.g.+  --    * case (error "hello") of { ... }+  --    * (error "Hello") arg+  --    * f (error "Hello") where f is strict+  --    etc+  -- Then, especially in the first of these cases, we'd like to discard+  -- the continuation, leaving just the bottoming expression.  But the+  -- type might not be right, so we may have to add a coerce.+  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial+                                 -- continuation to discard, else we do it+                                 -- again and again!+  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]+    return (emptyFloats env, castBottomExpr res cont_ty)+  where+    res     = argInfoExpr fun rev_args+    cont_ty = contResultType cont++---------- Try rewrite RULES --------------+-- See Note [Trying rewrite rules]+rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args+                              , ai_rules = Just (nr_wanted, rules) }) cont+  | 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]+    -- See also Note [Rules for recursive functions]+    do { mb_match <- tryRules env rules fun (reverse rev_args) cont+       ; case mb_match of+             Just (env', rhs, cont') -> simplExprF env' rhs cont'+             Nothing                 -> rebuildCall env info' cont }+  where+    no_more_args = case cont of+                      ApplyToTy  {} -> False+                      ApplyToVal {} -> False+                      _             -> True+++---------- Simplify applications and casts --------------+rebuildCall env info (CastIt co cont)+  = rebuildCall env (addCastTo info co) cont++rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })+  = rebuildCall env (addTyArgTo info arg_ty) cont++rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty+                              , ai_strs = str:strs, ai_discs = disc:discs })+            (ApplyToVal { sc_arg = arg, sc_env = arg_se+                        , sc_dup = dup_flag, sc_cont = cont })+  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]+  = rebuildCall env (addValArgTo info' arg) cont++  | str         -- Strict argument+  , sm_case_case (getMode env)+  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $+    simplExprF (arg_se `setInScopeFromE` env) arg+               (StrictArg { sc_fun = info', sc_cci = cci_strict+                          , sc_dup = Simplified, sc_cont = cont })+                -- Note [Shadowing]++  | otherwise                           -- Lazy argument+        -- DO NOT float anything outside, hence simplExprC+        -- There is no benefit (unlike in a let-binding), and we'd+        -- have to be very careful about bogus strictness through+        -- floating a demanded let.+  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg+                             (mkLazyArgStop arg_ty cci_lazy)+        ; rebuildCall env (addValArgTo info' arg') cont }+  where+    info'  = info { ai_strs = strs, ai_discs = discs }+    arg_ty = funArgTy fun_ty++    -- Use this for lazy arguments+    cci_lazy | encl_rules = RuleArgCtxt+             | disc > 0   = DiscArgCtxt  -- Be keener here+             | otherwise  = BoringCtxt   -- Nothing interesting++    -- ..and this for strict arguments+    cci_strict | encl_rules = RuleArgCtxt+               | disc > 0   = DiscArgCtxt+               | otherwise  = RhsCtxt+      -- Why RhsCtxt?  if we see f (g x) (h x), and f is strict, we+      -- want to be a bit more eager to inline g, because it may+      -- expose an eval (on x perhaps) that can be eliminated or+      -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1+      -- It's worth an 18% improvement in allocation for this+      -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'++---------- No further useful info, revert to generic rebuild ------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont+  = rebuild env (argInfoExpr fun rev_args) cont++{- Note [Trying rewrite rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet+simplified.  We want to simplify enough arguments to allow the rules+to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone+is sufficient.  Example: class ops+   (+) dNumInt e2 e3+If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the+latter's strictness when simplifying e2, e3.  Moreover, suppose we have+  RULE  f Int = \x. x True++Then given (f Int e1) we rewrite to+   (\x. x True) e1+without simplifying e1.  Now we can inline x into its unique call site,+and absorb the True into it all in the same pass.  If we simplified+e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].++So we try to apply rules if either+  (a) no_more_args: we've run out of argument that the rules can "see"+  (b) nr_wanted: none of the rules wants any more arguments+++Note [RULES apply to simplified arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very desirable to try RULES once the arguments have been simplified, because+doing so ensures that rule cascades work in one pass.  Consider+   {-# RULES g (h x) = k x+             f (k x) = x #-}+   ...f (g (h x))...+Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If+we match f's rules against the un-simplified RHS, it won't match.  This+makes a particularly big difference when superclass selectors are involved:+        op ($p1 ($p2 (df d)))+We want all this to unravel in one sweep.++Note [Avoid redundant simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because RULES apply to simplified arguments, there's a danger of repeatedly+simplifying already-simplified arguments.  An important example is that of+        (>>=) d e1 e2+Here e1, e2 are simplified before the rule is applied, but don't really+participate in the rule firing. So we mark them as Simplified to avoid+re-simplifying them.++Note [Shadowing]+~~~~~~~~~~~~~~~~+This part of the simplifier may break the no-shadowing invariant+Consider+        f (...(\a -> e)...) (case y of (a,b) -> e')+where f is strict in its second arg+If we simplify the innermost one first we get (...(\a -> e)...)+Simplifying the second arg makes us float the case out, so we end up with+        case y of (a,b) -> f (...(\a -> e)...) e'+So the output does not have the no-shadowing invariant.  However, there is+no danger of getting name-capture, because when the first arg was simplified+we used an in-scope set that at least mentioned all the variables free in its+static environment, and that is enough.++We can't just do innermost first, or we'd end up with a dual problem:+        case x of (a,b) -> f e (...(\a -> e')...)++I spent hours trying to recover the no-shadowing invariant, but I just could+not think of an elegant way to do it.  The simplifier is already knee-deep in+continuations.  We have to keep the right in-scope set around; AND we have+to get the effect that finding (error "foo") in a strict arg position will+discard the entire application and replace it with (error "foo").  Getting+all this at once is TOO HARD!+++************************************************************************+*                                                                      *+                Rewrite rules+*                                                                      *+************************************************************************+-}++tryRules :: SimplEnv -> [CoreRule]+         -> Id -> [ArgSpec]+         -> SimplCont+         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))++tryRules env rules fn args call_cont+  | null rules+  = return Nothing++{- Disabled until we fix #8326+  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]+  , [_type_arg, val_arg] <- args+  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont+  , isDeadBinder bndr+  = do { let enum_to_tag :: CoreAlt -> CoreAlt+                -- Takes   K -> e  into   tagK# -> e+                -- where tagK# is the tag of constructor K+             enum_to_tag (DataAlt con, [], rhs)+               = ASSERT( isEnumerationTyCon (dataConTyCon con) )+                (LitAlt tag, [], rhs)+              where+                tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))+             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)++             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts+             new_bndr = setIdType bndr intPrimTy+                 -- The binder is dead, but should have the right type+      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }+-}++  | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env)+                                        (activeRule (getMode env)) fn+                                        (argInfoAppArgs args) rules+  -- Fire a rule for the function+  = do { checkedTick (RuleFired (ruleName rule))+       ; let cont' = pushSimplifiedArgs zapped_env+                                        (drop (ruleArity rule) args)+                                        call_cont+                     -- (ruleArity rule) says how+                     -- many args the rule consumed++             occ_anald_rhs = occurAnalyseExpr rule_rhs+                 -- See Note [Occurrence-analyse after rule firing]+       ; dump rule rule_rhs+       ; return (Just (zapped_env, occ_anald_rhs, cont')) }+            -- The occ_anald_rhs and cont' are all Out things+            -- hence zapping the environment++  | otherwise  -- No rule fires+  = do { nodump  -- This ensures that an empty file is written+       ; return Nothing }++  where+    dflags     = seDynFlags env+    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]++    printRuleModule rule+      = parens (maybe (text "BUILTIN")+                      (pprModuleName . moduleName)+                      (ruleModule rule))++    dump rule rule_rhs+      | dopt Opt_D_dump_rule_rewrites dflags+      = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat+          [ text "Rule:" <+> ftext (ruleName rule)+          , text "Module:" <+>  printRuleModule rule+          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))+          , text "After: " <+> pprCoreExpr rule_rhs+          , text "Cont:  " <+> ppr call_cont ]++      | dopt Opt_D_dump_rule_firings dflags+      = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $+          ftext (ruleName rule)+            <+> printRuleModule rule++      | otherwise+      = return ()++    nodump+      | dopt Opt_D_dump_rule_rewrites dflags+      = liftIO $ do+         touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites)++      | dopt Opt_D_dump_rule_firings dflags+      = liftIO $ do+         touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings)++      | otherwise+      = return ()++    log_rule dflags flag hdr details+      = liftIO $ do+         let sty = mkDumpStyle dflags alwaysQualify+         dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $+           sep [text hdr, nest 4 details]++trySeqRules :: SimplEnv+            -> OutExpr -> InExpr   -- Scrutinee and RHS+            -> SimplCont+            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))+-- See Note [User-defined RULES for seq]+trySeqRules in_env scrut rhs cont+  = do { rule_base <- getSimplRules+       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }+  where+    no_cast_scrut = drop_casts scrut+    scrut_ty  = exprType no_cast_scrut+    seq_id_ty = idType seqId+    res1_ty   = piResultTy seq_id_ty rhs_rep+    res2_ty   = piResultTy res1_ty   scrut_ty+    rhs_ty    = substTy in_env (exprType rhs)+    rhs_rep   = getRuntimeRep rhs_ty+    out_args  = [ TyArg { as_arg_ty  = rhs_rep+                        , as_hole_ty = seq_id_ty }+                , TyArg { as_arg_ty  = scrut_ty+                        , as_hole_ty = res1_ty }+                , TyArg { as_arg_ty  = rhs_ty+                        , as_hole_ty = res2_ty }+                , ValArg no_cast_scrut]+    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs+                           , sc_env = in_env, sc_cont = cont }+    -- Lazily evaluated, so we don't do most of this++    drop_casts (Cast e _) = drop_casts e+    drop_casts e          = e++{- Note [User-defined RULES for seq]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given+   case (scrut |> co) of _ -> rhs+look for rules that match the expression+   seq @t1 @t2 scrut+where scrut :: t1+      rhs   :: t2++If you find a match, rewrite it, and apply to 'rhs'.++Notice that we can simply drop casts on the fly here, which+makes it more likely that a rule will match.++See Note [User-defined RULES for seq] in GHC.Types.Id.Make.++Note [Occurrence-analyse after rule firing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+After firing a rule, we occurrence-analyse the instantiated RHS before+simplifying it.  Usually this doesn't make much difference, but it can+be huge.  Here's an example (simplCore/should_compile/T7785)++  map f (map f (map f xs)++= -- Use build/fold form of map, twice+  map f (build (\cn. foldr (mapFB c f) n+                           (build (\cn. foldr (mapFB c f) n xs))))++= -- Apply fold/build rule+  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))++= -- Beta-reduce+  -- Alas we have no occurrence-analysed, so we don't know+  -- that c is used exactly once+  map f (build (\cn. let c1 = mapFB c f in+                     foldr (mapFB c1 f) n xs))++= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)+  -- We can do this because (mapFB c n) is a PAP and hence expandable+  map f (build (\cn. let c1 = mapFB c n in+                     foldr (mapFB c (f.f)) n x))++This is not too bad.  But now do the same with the outer map, and+we get another use of mapFB, and t can interact with /both/ remaining+mapFB calls in the above expression.  This is stupid because actually+that 'c1' binding is dead.  The outer map introduces another c2. If+there is a deep stack of maps we get lots of dead bindings, and lots+of redundant work as we repeatedly simplify the result of firing rules.++The easy thing to do is simply to occurrence analyse the result of+the rule firing.  Note that this occ-anals not only the RHS of the+rule, but also the function arguments, which by now are OutExprs.+E.g.+      RULE f (g x) = x+1++Call   f (g BIG)  -->   (\x. x+1) BIG++The rule binders are lambda-bound and applied to the OutExpr arguments+(here BIG) which lack all internal occurrence info.++Is this inefficient?  Not really: we are about to walk over the result+of the rule firing to simplify it, so occurrence analysis is at most+a constant factor.++Possible improvement: occ-anal the rules when putting them in the+database; and in the simplifier just occ-anal the OutExpr arguments.+But that's more complicated and the rule RHS is usually tiny; so I'm+just doing the simple thing.++Historical note: previously we did occ-anal the rules in Rule.hs,+but failed to occ-anal the OutExpr arguments, which led to the+nasty performance problem described above.+++Note [Optimising tagToEnum#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an enumeration data type:++  data Foo = A | B | C++Then we want to transform++   case tagToEnum# x of   ==>    case x of+     A -> e1                       DEFAULT -> e1+     B -> e2                       1#      -> e2+     C -> e3                       2#      -> e3++thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT+alternative we retain it (remember it comes first).  If not the case must+be exhaustive, and we reflect that in the transformed version by adding+a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.+See #8317.++Note [Rules for recursive functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that we shouldn't apply rules for a loop breaker:+doing so might give rise to an infinite loop, because a RULE is+rather like an extra equation for the function:+     RULE:           f (g x) y = x+y+     Eqn:            f a     y = a-y++But it's too drastic to disable rules for loop breakers.+Even the foldr/build rule would be disabled, because foldr+is recursive, and hence a loop breaker:+     foldr k z (build g) = g k z+So it's up to the programmer: rules can cause divergence+++************************************************************************+*                                                                      *+                Rebuilding a case expression+*                                                                      *+************************************************************************++Note [Case elimination]+~~~~~~~~~~~~~~~~~~~~~~~+The case-elimination transformation discards redundant case expressions.+Start with a simple situation:++        case x# of      ===>   let y# = x# in e+          y# -> e++(when x#, y# are of primitive type, of course).  We can't (in general)+do this for algebraic cases, because we might turn bottom into+non-bottom!++The code in GHC.Core.Op.Simplify.Utils.prepareAlts has the effect of generalise+this idea to look for a case where we're scrutinising a variable, and we know+that only the default case can match.  For example:++        case x of+          0#      -> ...+          DEFAULT -> ...(case x of+                         0#      -> ...+                         DEFAULT -> ...) ...++Here the inner case is first trimmed to have only one alternative, the+DEFAULT, after which it's an instance of the previous case.  This+really only shows up in eliminating error-checking code.++Note that GHC.Core.Op.Simplify.Utils.mkCase combines identical RHSs.  So++        case e of       ===> case e of DEFAULT -> r+           True  -> r+           False -> r++Now again the case may be eliminated by the CaseElim transformation.+This includes things like (==# a# b#)::Bool so that we simplify+      case ==# a# b# of { True -> x; False -> x }+to just+      x+This particular example shows up in default methods for+comparison operations (e.g. in (>=) for Int.Int32)++Note [Case to let transformation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a case over a lifted type has a single alternative, and is being+used as a strict 'let' (all isDeadBinder bndrs), we may want to do+this transformation:++    case e of r       ===>   let r = e in ...r...+      _ -> ...r...++We treat the unlifted and lifted cases separately:++* Unlifted case: 'e' satisfies exprOkForSpeculation+  (ok-for-spec is needed to satisfy the let/app invariant).+  This turns     case a +# b of r -> ...r...+  into           let r = a +# b in ...r...+  and thence     .....(a +# b)....++  However, if we have+      case indexArray# a i of r -> ...r...+  we might like to do the same, and inline the (indexArray# a i).+  But indexArray# is not okForSpeculation, so we don't build a let+  in rebuildCase (lest it get floated *out*), so the inlining doesn't+  happen either.  Annoying.++* Lifted case: we need to be sure that the expression is already+  evaluated (exprIsHNF).  If it's not already evaluated+      - we risk losing exceptions, divergence or+        user-specified thunk-forcing+      - even if 'e' is guaranteed to converge, we don't want to+        create a thunk (call by need) instead of evaluating it+        right away (call by value)++  However, we can turn the case into a /strict/ let if the 'r' is+  used strictly in the body.  Then we won't lose divergence; and+  we won't build a thunk because the let is strict.+  See also Note [Case-to-let for strictly-used binders]++  NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in GHC.Core.Make.+  We want to turn+     case (absentError "foo") of r -> ...MkT r...+  into+     let r = absentError "foo" in ...MkT r...+++Note [Case-to-let for strictly-used binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have this:+   case <scrut> of r { _ -> ..r.. }++where 'r' is used strictly in (..r..), we can safely transform to+   let r = <scrut> in ...r...++This is a Good Thing, because 'r' might be dead (if the body just+calls error), or might be used just once (in which case it can be+inlined); or we might be able to float the let-binding up or down.+E.g. #15631 has an example.++Note that this can change the error behaviour.  For example, we might+transform+    case x of { _ -> error "bad" }+    --> error "bad"+which is might be puzzling if 'x' currently lambda-bound, but later gets+let-bound to (error "good").++Nevertheless, the paper "A semantics for imprecise exceptions" allows+this transformation. If you want to fix the evaluation order, use+'pseq'.  See #8900 for an example where the loss of this+transformation bit us in practice.++See also Note [Empty case alternatives] in GHC.Core.++Historical notes++There have been various earlier versions of this patch:++* By Sept 18 the code looked like this:+     || scrut_is_demanded_var scrut++    scrut_is_demanded_var :: CoreExpr -> Bool+    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s+    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)+    scrut_is_demanded_var _          = False++  This only fired if the scrutinee was a /variable/, which seems+  an unnecessary restriction. So in #15631 I relaxed it to allow+  arbitrary scrutinees.  Less code, less to explain -- but the change+  had 0.00% effect on nofib.++* Previously, in Jan 13 the code looked like this:+     || case_bndr_evald_next rhs++    case_bndr_evald_next :: CoreExpr -> Bool+      -- See Note [Case binder next]+    case_bndr_evald_next (Var v)         = v == case_bndr+    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e+    case_bndr_evald_next (App e _)       = case_bndr_evald_next e+    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e+    case_bndr_evald_next _               = False++  This patch was part of fixing #7542. See also+  Note [Eta reduction of an eval'd function] in GHC.Core.Utils.)+++Further notes about case elimination+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:       test :: Integer -> IO ()+                test = print++Turns out that this compiles to:+    Print.test+      = \ eta :: Integer+          eta1 :: Void# ->+          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->+          case hPutStr stdout+                 (PrelNum.jtos eta ($w[] @ Char))+                 eta1+          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}++Notice the strange '<' which has no effect at all. This is a funny one.+It started like this:++f x y = if x < 0 then jtos x+          else if y==0 then "" else jtos x++At a particular call site we have (f v 1).  So we inline to get++        if v < 0 then jtos x+        else if 1==0 then "" else jtos x++Now simplify the 1==0 conditional:++        if v<0 then jtos v else jtos v++Now common-up the two branches of the case:++        case (v<0) of DEFAULT -> jtos v++Why don't we drop the case?  Because it's strict in v.  It's technically+wrong to drop even unnecessary evaluations, and in practice they+may be a result of 'seq' so we *definitely* don't want to drop those.+I don't really know how to improve this situation.+++Note [FloatBinds from constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have FloatBinds coming from the constructor wrapper+(as in Note [exprIsConApp_maybe on data constructors with wrappers]),+we cannot float past them. We'd need to float the FloatBind+together with the simplify floats, unfortunately the+simplifier doesn't have case-floats. The simplest thing we can+do is to wrap all the floats here. The next iteration of the+simplifier will take care of all these cases and lets.++Given data T = MkT !Bool, this allows us to simplify+case $WMkT b of { MkT x -> f x }+to+case b of { b' -> f b' }.++We could try and be more clever (like maybe wfloats only contain+let binders, so we could float them). But the need for the+extra complication is not clear.+-}++---------------------------------------------------------+--      Eliminate the case if possible++rebuildCase, reallyRebuildCase+   :: SimplEnv+   -> OutExpr          -- Scrutinee+   -> InId             -- Case binder+   -> [InAlt]          -- Alternatives (increasing order)+   -> SimplCont+   -> SimplM (SimplFloats, OutExpr)++--------------------------------------------------+--      1. Eliminate the case if there's a known constructor+--------------------------------------------------++rebuildCase env scrut case_bndr alts cont+  | Lit lit <- scrut    -- No need for same treatment as constructors+                        -- because literals are inlined more vigorously+  , not (litIsLifted lit)+  = do  { tick (KnownBranch case_bndr)+        ; case findAlt (LitAlt lit) alts of+            Nothing           -> missingAlt env case_bndr alts cont+            Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs }++  | Just (in_scope', wfloats, con, ty_args, other_args)+      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut+        -- Works when the scrutinee is a variable with a known unfolding+        -- as well as when it's an explicit constructor application+  , let env0 = setInScopeSet env in_scope'+  = do  { tick (KnownBranch case_bndr)+        ; case findAlt (DataAlt con) alts of+            Nothing  -> missingAlt env0 case_bndr alts cont+            Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con)+                                                 `mkTyApps` ty_args+                                                 `mkApps`   other_args+                                       in simple_rhs env0 wfloats con_app bs rhs+            Just (_, bs, rhs)       -> knownCon env0 scrut wfloats con ty_args other_args+                                                case_bndr bs rhs cont+        }+  where+    simple_rhs env wfloats scrut' bs rhs =+      ASSERT( null bs )+      do { (floats1, env') <- simplNonRecX env case_bndr scrut'+             -- scrut is a constructor application,+             -- hence satisfies let/app invariant+         ; (floats2, expr') <- simplExprF env' rhs cont+         ; case wfloats of+             [] -> return (floats1 `addFloats` floats2, expr')+             _ -> return+               -- See Note [FloatBinds from constructor wrappers]+                   ( emptyFloats env,+                     GHC.Core.Make.wrapFloats wfloats $+                     wrapFloats (floats1 `addFloats` floats2) expr' )}+++--------------------------------------------------+--      2. Eliminate the case if scrutinee is evaluated+--------------------------------------------------++rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont+  -- See if we can get rid of the case altogether+  -- See Note [Case elimination]+  -- mkCase made sure that if all the alternatives are equal,+  -- then there is now only one (DEFAULT) rhs++  -- 2a.  Dropping the case altogether, if+  --      a) it binds nothing (so it's really just a 'seq')+  --      b) evaluating the scrutinee has no side effects+  | is_plain_seq+  , exprOkForSideEffects scrut+          -- The entire case is dead, so we can drop it+          -- if the scrutinee converges without having imperative+          -- side effects or raising a Haskell exception+          -- See Note [PrimOp can_fail and has_side_effects] in PrimOp+   = simplExprF env rhs cont++  -- 2b.  Turn the case into a let, if+  --      a) it binds only the case-binder+  --      b) unlifted case: the scrutinee is ok-for-speculation+  --           lifted case: the scrutinee is in HNF (or will later be demanded)+  -- See Note [Case to let transformation]+  | all_dead_bndrs+  , doCaseToLet scrut case_bndr+  = do { tick (CaseElim case_bndr)+       ; (floats1, env') <- simplNonRecX env case_bndr scrut+       ; (floats2, expr') <- simplExprF env' rhs cont+       ; return (floats1 `addFloats` floats2, expr') }++  -- 2c. Try the seq rules if+  --     a) it binds only the case binder+  --     b) a rule for seq applies+  -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make+  | is_plain_seq+  = do { mb_rule <- trySeqRules env scrut rhs cont+       ; case mb_rule of+           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'+           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }+  where+    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]+    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect++rebuildCase env scrut case_bndr alts cont+  = reallyRebuildCase env scrut case_bndr alts cont+++doCaseToLet :: OutExpr          -- Scrutinee+            -> InId             -- Case binder+            -> Bool+-- The situation is         case scrut of b { DEFAULT -> body }+-- Can we transform thus?   let { b = scrut } in body+doCaseToLet scrut case_bndr+  | isTyCoVar case_bndr    -- Respect GHC.Core+  = isTyCoArg scrut        -- Note [Core type and coercion invariant]++  | isUnliftedType (idType case_bndr)+  = exprOkForSpeculation scrut++  | otherwise  -- Scrut has a lifted type+  = exprIsHNF scrut+    || isStrictDmd (idDemandInfo case_bndr)+    -- See Note [Case-to-let for strictly-used binders]++--------------------------------------------------+--      3. Catch-all case+--------------------------------------------------++reallyRebuildCase env scrut case_bndr alts cont+  | not (sm_case_case (getMode env))+  = do { case_expr <- simplAlts env scrut case_bndr alts+                                (mkBoringStop (contHoleType cont))+       ; rebuild env case_expr cont }++  | otherwise+  = do { (floats, cont') <- mkDupableCaseCont env alts cont+       ; case_expr <- simplAlts (env `setInScopeFromF` floats)+                                scrut case_bndr alts cont'+       ; return (floats, case_expr) }++{-+simplCaseBinder checks whether the scrutinee is a variable, v.  If so,+try to eliminate uses of v in the RHSs in favour of case_bndr; that+way, there's a chance that v will now only be used once, and hence+inlined.++Historical note: we use to do the "case binder swap" in the Simplifier+so there were additional complications if the scrutinee was a variable.+Now the binder-swap stuff is done in the occurrence analyser; see+OccurAnal Note [Binder swap].++Note [knownCon occ info]+~~~~~~~~~~~~~~~~~~~~~~~~+If the case binder is not dead, then neither are the pattern bound+variables:+        case <any> of x { (a,b) ->+        case x of { (p,q) -> p } }+Here (a,b) both look dead, but come alive after the inner case is eliminated.+The point is that we bring into the envt a binding+        let x = (a,b)+after the outer case, and that makes (a,b) alive.  At least we do unless+the case binder is guaranteed dead.++Note [Case alternative occ info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are simply reconstructing a case (the common case), we always+zap the occurrence info on the binders in the alternatives.  Even+if the case binder is dead, the scrutinee is usually a variable, and *that*+can bring the case-alternative binders back to life.+See Note [Add unfolding for scrutinee]++Note [Improving seq]+~~~~~~~~~~~~~~~~~~~+Consider+        type family F :: * -> *+        type instance F Int = Int++We'd like to transform+        case e of (x :: F Int) { DEFAULT -> rhs }+===>+        case e `cast` co of (x'::Int)+           I# x# -> let x = x' `cast` sym co+                    in rhs++so that 'rhs' can take advantage of the form of x'.  Notice that Note+[Case of cast] (in OccurAnal) may then apply to the result.++We'd also like to eliminate empty types (#13468). So if++    data Void+    type instance F Bool = Void++then we'd like to transform+        case (x :: F Bool) of { _ -> error "urk" }+===>+        case (x |> co) of (x' :: Void) of {}++Nota Bene: we used to have a built-in rule for 'seq' that dropped+casts, so that+    case (x |> co) of { _ -> blah }+dropped the cast; in order to improve the chances of trySeqRules+firing.  But that works in the /opposite/ direction to Note [Improving+seq] so there's a danger of flip/flopping.  Better to make trySeqRules+insensitive to the cast, which is now is.++The need for [Improving seq] showed up in Roman's experiments.  Example:+  foo :: F Int -> Int -> Int+  foo t n = t `seq` bar n+     where+       bar 0 = 0+       bar n = bar (n - case t of TI i -> i)+Here we'd like to avoid repeated evaluating t inside the loop, by+taking advantage of the `seq`.++At one point I did transformation in LiberateCase, but it's more+robust here.  (Otherwise, there's a danger that we'll simply drop the+'seq' altogether, before LiberateCase gets to see it.)+-}++simplAlts :: SimplEnv+          -> OutExpr         -- Scrutinee+          -> InId            -- Case binder+          -> [InAlt]         -- Non-empty+          -> SimplCont+          -> SimplM OutExpr  -- Returns the complete simplified case expression++simplAlts env0 scrut case_bndr alts cont'+  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr+                                      , text "cont':" <+> ppr cont'+                                      , text "in_scope" <+> ppr (seInScope env0) ])+        ; (env1, case_bndr1) <- simplBinder env0 case_bndr+        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding+              env2       = modifyInScope env1 case_bndr2+              -- See Note [Case binder evaluated-ness]++        ; fam_envs <- getFamEnvs+        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut+                                                       case_bndr case_bndr2 alts++        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts+          -- NB: it's possible that the returned in_alts is empty: this is handled+          -- by the caller (rebuildCase) in the missingAlt function++        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts+        ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $++        ; let alts_ty' = contResultType cont'+        -- See Note [Avoiding space leaks in OutType]+        ; seqType alts_ty' `seq`+          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }+++------------------------------------+improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv+           -> OutExpr -> InId -> OutId -> [InAlt]+           -> SimplM (SimplEnv, OutExpr, OutId)+-- Note [Improving seq]+improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]+  | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)+  = do { case_bndr2 <- newId (fsLit "nt") ty2+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing+              env2 = extendIdSubst env case_bndr rhs+        ; return (env2, scrut `Cast` co, case_bndr2) }++improveSeq _ env scrut _ case_bndr1 _+  = return (env, scrut, case_bndr1)+++------------------------------------+simplAlt :: SimplEnv+         -> Maybe OutExpr  -- The scrutinee+         -> [AltCon]       -- These constructors can't be present when+                           -- matching the DEFAULT alternative+         -> OutId          -- The case binder+         -> SimplCont+         -> InAlt+         -> SimplM OutAlt++simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)+  = ASSERT( null bndrs )+    do  { let env' = addBinderUnfolding env case_bndr'+                                        (mkOtherCon imposs_deflt_cons)+                -- Record the constructors that the case-binder *can't* be.+        ; rhs' <- simplExprC env' rhs cont'+        ; return (DEFAULT, [], rhs') }++simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)+  = ASSERT( null bndrs )+    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)+        ; rhs' <- simplExprC env' rhs cont'+        ; return (LitAlt lit, [], rhs') }++simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)+  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]+          let vs_with_evals = addEvals scrut' con vs+        ; (env', vs') <- simplLamBndrs env vs_with_evals++                -- Bind the case-binder to (con args)+        ; let inst_tys' = tyConAppArgs (idType case_bndr')+              con_app :: OutExpr+              con_app   = mkConApp2 con inst_tys' vs'++        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app+        ; rhs' <- simplExprC env'' rhs cont'+        ; return (DataAlt con, vs', rhs') }++{- Note [Adding evaluatedness info to pattern-bound variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+addEvals records the evaluated-ness of the bound variables of+a case pattern.  This is *important*.  Consider++     data T = T !Int !Int++     case x of { T a b -> T (a+1) b }++We really must record that b is already evaluated so that we don't+go and re-evaluate it when constructing the result.+See Note [Data-con worker strictness] in GHC.Types.Id.Make++NB: simplLamBndrs preserves this eval info++In addition to handling data constructor fields with !s, addEvals+also records the fact that the result of seq# is always in WHNF.+See Note [seq# magic] in GHC.Core.Op.ConstantFold.  Example (#15226):++  case seq# v s of+    (# s', v' #) -> E++we want the compiler to be aware that v' is in WHNF in E.++Open problem: we don't record that v itself is in WHNF (and we can't+do it here).  The right thing is to do some kind of binder-swap;+see #15226 for discussion.+-}++addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]+-- See Note [Adding evaluatedness info to pattern-bound variables]+addEvals scrut con vs+  -- Deal with seq# applications+  | Just scr <- scrut+  , isUnboxedTupleCon con+  , [s,x] <- vs+    -- Use stripNArgs rather than collectArgsTicks to avoid building+    -- a list of arguments only to throw it away immediately.+  , Just (Var f) <- stripNArgs 4 scr+  , Just SeqOp <- isPrimOpId_maybe f+  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x+  = [s, x']++  -- Deal with banged datacon fields+addEvals _scrut con vs = go vs the_strs+    where+      the_strs = dataConRepStrictness con++      go [] [] = []+      go (v:vs') strs | isTyVar v = v : go vs' strs+      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs+      go _ _ = pprPanic "Simplify.addEvals"+                (ppr con $$+                 ppr vs  $$+                 ppr_with_length (map strdisp the_strs) $$+                 ppr_with_length (dataConRepArgTys con) $$+                 ppr_with_length (dataConRepStrictness con))+        where+          ppr_with_length list+            = ppr list <+> parens (text "length =" <+> ppr (length list))+          strdisp MarkedStrict = text "MarkedStrict"+          strdisp NotMarkedStrict = text "NotMarkedStrict"++zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id+zapIdOccInfoAndSetEvald str v =+  setCaseBndrEvald str $ -- Add eval'dness info+  zapIdOccInfo v         -- And kill occ info;+                         -- see Note [Case alternative occ info]++addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv+addAltUnfoldings env scrut case_bndr con_app+  = do { let con_app_unf = mk_simple_unf con_app+             env1 = addBinderUnfolding env case_bndr con_app_unf++             -- See Note [Add unfolding for scrutinee]+             env2 = case scrut of+                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf+                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $+                                                mk_simple_unf (Cast con_app (mkSymCo co))+                      _                      -> env1++       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])+       ; return env2 }+  where+    mk_simple_unf = mkSimpleUnfolding (seDynFlags env)++addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv+addBinderUnfolding env bndr unf+  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf+  = WARN( not (eqType (idType bndr) (exprType tmpl)),+          ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )+    modifyInScope env (bndr `setIdUnfolding` unf)++  | otherwise+  = modifyInScope env (bndr `setIdUnfolding` unf)++zapBndrOccInfo :: Bool -> Id -> Id+-- Consider  case e of b { (a,b) -> ... }+-- Then if we bind b to (a,b) in "...", and b is not dead,+-- then we must zap the deadness info on a,b+zapBndrOccInfo keep_occ_info pat_id+  | keep_occ_info = pat_id+  | otherwise     = zapIdOccInfo pat_id++{- Note [Case binder evaluated-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pin on a (OtherCon []) unfolding to the case-binder of a Case,+even though it'll be over-ridden in every case alternative with a more+informative unfolding.  Why?  Because suppose a later, less clever, pass+simply replaces all occurrences of the case binder with the binder itself;+then Lint may complain about the let/app invariant.  Example+    case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in ....+                ; K       -> blah }++The let/app invariant requires that y is evaluated in the call to+reallyUnsafePtrEq#, which it is.  But we still want that to be true if we+propagate binders to occurrences.++This showed up in #13027.++Note [Add unfolding for scrutinee]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general it's unlikely that a variable scrutinee will appear+in the case alternatives   case x of { ...x unlikely to appear... }+because the binder-swap in OccAnal has got rid of all such occurrences+See Note [Binder swap] in OccAnal.++BUT it is still VERY IMPORTANT to add a suitable unfolding for a+variable scrutinee, in simplAlt.  Here's why+   case x of y+     (a,b) -> case b of c+                I# v -> ...(f y)...+There is no occurrence of 'b' in the (...(f y)...).  But y gets+the unfolding (a,b), and *that* mentions b.  If f has a RULE+    RULE f (p, I# q) = ...+we want that rule to match, so we must extend the in-scope env with a+suitable unfolding for 'y'.  It's *essential* for rule matching; but+it's also good for case-elimintation -- suppose that 'f' was inlined+and did multi-level case analysis, then we'd solve it in one+simplifier sweep instead of two.++Exactly the same issue arises in GHC.Core.Op.SpecConstr;+see Note [Add scrutinee to ValueEnv too] in GHC.Core.Op.SpecConstr++HOWEVER, given+  case x of y { Just a -> r1; Nothing -> r2 }+we do not want to add the unfolding x -> y to 'x', which might seem cool,+since 'y' itself has different unfoldings in r1 and r2.  Reason: if we+did that, we'd have to zap y's deadness info and that is a very useful+piece of information.++So instead we add the unfolding x -> Just a, and x -> Nothing in the+respective RHSs.+++************************************************************************+*                                                                      *+\subsection{Known constructor}+*                                                                      *+************************************************************************++We are a bit careful with occurrence info.  Here's an example++        (\x* -> case x of (a*, b) -> f a) (h v, e)++where the * means "occurs once".  This effectively becomes+        case (h v, e) of (a*, b) -> f a)+and then+        let a* = h v; b = e in f a+and then+        f (h v)++All this should happen in one sweep.+-}++knownCon :: SimplEnv+         -> OutExpr                                           -- The scrutinee+         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)+         -> InId -> [InBndr] -> InExpr                        -- The alternative+         -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont+  = do  { (floats1, env1)  <- bind_args env bs dc_args+        ; (floats2, env2) <- bind_case_bndr env1+        ; (floats3, expr') <- simplExprF env2 rhs cont+        ; case dc_floats of+            [] ->+              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')+            _ ->+              return ( emptyFloats env+               -- See Note [FloatBinds from constructor wrappers]+                     , GHC.Core.Make.wrapFloats dc_floats $+                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }+  where+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId++                  -- Ugh!+    bind_args env' [] _  = return (emptyFloats env', env')++    bind_args env' (b:bs') (Type ty : args)+      = ASSERT( isTyVar b )+        bind_args (extendTvSubst env' b ty) bs' args++    bind_args env' (b:bs') (Coercion co : args)+      = ASSERT( isCoVar b )+        bind_args (extendCvSubst env' b co) bs' args++    bind_args env' (b:bs') (arg : args)+      = ASSERT( isId b )+        do { let b' = zap_occ b+             -- Note that the binder might be "dead", because it doesn't+             -- occur in the RHS; and simplNonRecX may therefore discard+             -- it via postInlineUnconditionally.+             -- Nevertheless we must keep it if the case-binder is alive,+             -- because it may be used in the con_app.  See Note [knownCon occ info]+           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant+           ; (floats2, env3)  <- bind_args env2 bs' args+           ; return (floats1 `addFloats` floats2, env3) }++    bind_args _ _ _ =+      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$+                             text "scrut:" <+> ppr scrut++       -- It's useful to bind bndr to scrut, rather than to a fresh+       -- binding      x = Con arg1 .. argn+       -- because very often the scrut is a variable, so we avoid+       -- creating, and then subsequently eliminating, a let-binding+       -- BUT, if scrut is a not a variable, we must be careful+       -- about duplicating the arg redexes; in that case, make+       -- a new con-app from the args+    bind_case_bndr env+      | isDeadBinder bndr   = return (emptyFloats env, env)+      | exprIsTrivial scrut = return (emptyFloats env+                                     , extendIdSubst env bndr (DoneEx scrut Nothing))+      | otherwise           = do { dc_args <- mapM (simplVar env) bs+                                         -- dc_ty_args are already OutTypes,+                                         -- but bs are InBndrs+                                 ; let con_app = Var (dataConWorkId dc)+                                                 `mkTyApps` dc_ty_args+                                                 `mkApps`   dc_args+                                 ; simplNonRecX env bndr con_app }++-------------------+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont+           -> SimplM (SimplFloats, OutExpr)+                -- This isn't strictly an error, although it is unusual.+                -- It's possible that the simplifier might "see" that+                -- an inner case has no accessible alternatives before+                -- it "sees" that the entire branch of an outer case is+                -- inaccessible.  So we simply put an error case here instead.+missingAlt env case_bndr _ cont+  = WARN( True, text "missingAlt" <+> ppr case_bndr )+    -- See Note [Avoiding space leaks in OutType]+    let cont_ty = contResultType cont+    in seqType cont_ty `seq`+       return (emptyFloats env, mkImpossibleExpr cont_ty)++{-+************************************************************************+*                                                                      *+\subsection{Duplicating continuations}+*                                                                      *+************************************************************************++Consider+  let x* = case e of { True -> e1; False -> e2 }+  in b+where x* is a strict binding.  Then mkDupableCont will be given+the continuation+   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop+and will split it into+   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop+   join floats:  $j1 = e1, $j2 = e2+   non_dupable:  let x* = [] in b; stop++Putting this back together would give+   let x* = let { $j1 = e1; $j2 = e2 } in+            case e of { True -> $j1; False -> $j2 }+   in b+(Of course we only do this if 'e' wants to duplicate that continuation.)+Note how important it is that the new join points wrap around the+inner expression, and not around the whole thing.++In contrast, any let-bindings introduced by mkDupableCont can wrap+around the entire thing.++Note [Bottom alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have+     case (case x of { A -> error .. ; B -> e; C -> error ..)+       of alts+then we can just duplicate those alts because the A and C cases+will disappear immediately.  This is more direct than creating+join points and inlining them away.  See #4930.+-}++--------------------+mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont+                  -> SimplM (SimplFloats, SimplCont)+mkDupableCaseCont env alts cont+  | altsWouldDup alts = mkDupableCont env cont+  | otherwise         = return (emptyFloats env, cont)++altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative+altsWouldDup []  = False        -- See Note [Bottom alternatives]+altsWouldDup [_] = False+altsWouldDup (alt:alts)+  | is_bot_alt alt = altsWouldDup alts+  | otherwise      = not (all is_bot_alt alts)+  where+    is_bot_alt (_,_,rhs) = exprIsBottom rhs++-------------------------+mkDupableCont :: SimplEnv -> SimplCont+              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with+                                       --   extra let/join-floats and in-scope variables+                        , SimplCont)   -- dup_cont: duplicable continuation++mkDupableCont env cont+  | contIsDupable cont+  = return (emptyFloats env, cont)++mkDupableCont _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn++mkDupableCont env (CastIt ty cont)+  = do  { (floats, cont') <- mkDupableCont env cont+        ; return (floats, CastIt ty cont') }++-- Duplicating ticks for now, not sure if this is good or not+mkDupableCont env (TickIt t cont)+  = do  { (floats, cont') <- mkDupableCont env cont+        ; return (floats, TickIt t cont') }++mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs+                              , sc_body = body, sc_env = se, sc_cont = cont})+  -- See Note [Duplicating StrictBind]+  = do { let sb_env = se `setInScopeFromE` env+       ; (sb_env1, bndr') <- simplBinder sb_env bndr+       ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont+          -- No need to use mkDupableCont before simplLam; we+          -- use cont once here, and then share the result if necessary++       ; let join_body = wrapFloats floats1 join_inner+             res_ty    = contResultType cont++       ; (floats2, body2)+            <- if exprIsDupable (targetPlatform (seDynFlags env)) join_body+               then return (emptyFloats env, join_body)+               else do { join_bndr <- newJoinId [bndr'] res_ty+                       ; let join_call = App (Var join_bndr) (Var bndr')+                             join_rhs  = Lam (setOneShotLambda bndr') join_body+                             join_bind = NonRec join_bndr join_rhs+                             floats    = emptyFloats env `extendFloats` join_bind+                       ; return (floats, join_call) }+       ; return ( floats2+                , StrictBind { sc_bndr = bndr', sc_bndrs = []+                             , sc_body = body2+                             , sc_env  = zapSubstEnv se `setInScopeFromF` floats2+                                         -- See Note [StaticEnv invariant] in GHC.Core.Op.Simplify.Utils+                             , sc_dup  = OkToDup+                             , sc_cont = mkBoringStop res_ty } ) }++mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })+        -- See Note [Duplicating StrictArg]+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+  = do { (floats1, cont') <- mkDupableCont env cont+       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))+                                           (ai_args info)+       ; return ( foldl' addLetFloats floats1 floats_s+                , StrictArg { sc_fun = info { ai_args = args' }+                            , sc_cci = cci+                            , sc_cont = cont'+                            , sc_dup = OkToDup} ) }++mkDupableCont env (ApplyToTy { sc_cont = cont+                             , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })+  = do  { (floats, cont') <- mkDupableCont env cont+        ; return (floats, ApplyToTy { sc_cont = cont'+                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }++mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup+                              , sc_env = se, sc_cont = cont })+  =     -- e.g.         [...hole...] (...arg...)+        --      ==>+        --              let a = ...arg...+        --              in [...hole...] a+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    do  { (floats1, cont') <- mkDupableCont env cont+        ; let env' = env `setInScopeFromF` floats1+        ; (_, se', arg') <- simplArg env' dup se arg+        ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg'+        ; let all_floats = floats1 `addLetFloats` let_floats2+        ; return ( all_floats+                 , ApplyToVal { sc_arg = arg''+                              , sc_env = se' `setInScopeFromF` all_floats+                                         -- Ensure that sc_env includes the free vars of+                                         -- arg'' in its in-scope set, even if makeTrivial+                                         -- has turned arg'' into a fresh variable+                                         -- See Note [StaticEnv invariant] in GHC.Core.Op.Simplify.Utils+                              , sc_dup = OkToDup, sc_cont = cont' }) }++mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts+                          , sc_env = se, sc_cont = cont })+  =     -- e.g.         (case [...hole...] of { pi -> ei })+        --      ===>+        --              let ji = \xij -> ei+        --              in case [...hole...] of { pi -> ji xij }+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    do  { tick (CaseOfCase case_bndr)+        ; (floats, alt_cont) <- mkDupableCaseCont env alts cont+                -- NB: We call mkDupableCaseCont here to make cont duplicable+                --     (if necessary, depending on the number of alts)+                -- And this is important: see Note [Fusing case continuations]++        ; let alt_env = se `setInScopeFromF` floats+        ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr+        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts+        -- Safe to say that there are no handled-cons for the DEFAULT case+                -- NB: simplBinder does not zap deadness occ-info, so+                -- a dead case_bndr' will still advertise its deadness+                -- This is really important because in+                --      case e of b { (# p,q #) -> ... }+                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),+                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.+                -- In the new alts we build, we have the new case binder, so it must retain+                -- its deadness.+        -- NB: we don't use alt_env further; it has the substEnv for+        --     the alternatives, and we don't want that++        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')+                                              emptyJoinFloats alts'++        ; let all_floats = floats `addJoinFloats` join_floats+                           -- Note [Duplicated env]+        ; return (all_floats+                 , Select { sc_dup  = OkToDup+                          , sc_bndr = case_bndr'+                          , sc_alts = alts''+                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats+                                      -- See Note [StaticEnv invariant] in GHC.Core.Op.Simplify.Utils+                          , sc_cont = mkBoringStop (contResultType cont) } ) }++mkDupableAlt :: Platform -> OutId+             -> JoinFloats -> OutAlt+             -> SimplM (JoinFloats, OutAlt)+mkDupableAlt platform case_bndr jfloats (con, bndrs', rhs')+  | exprIsDupable platform rhs'  -- Note [Small alternative rhs]+  = return (jfloats, (con, bndrs', rhs'))++  | otherwise+  = do  { let rhs_ty'  = exprType rhs'+              scrut_ty = idType case_bndr+              case_bndr_w_unf+                = case con of+                      DEFAULT    -> case_bndr+                      DataAlt dc -> setIdUnfolding case_bndr unf+                          where+                                 -- See Note [Case binders and join points]+                             unf = mkInlineUnfolding rhs+                             rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'++                      LitAlt {} -> WARN( True, text "mkDupableAlt"+                                                <+> ppr case_bndr <+> ppr con )+                                   case_bndr+                           -- The case binder is alive but trivial, so why has+                           -- it not been substituted away?++              final_bndrs'+                | isDeadBinder case_bndr = filter abstract_over bndrs'+                | otherwise              = bndrs' ++ [case_bndr_w_unf]++              abstract_over bndr+                  | isTyVar bndr = True -- Abstract over all type variables just in case+                  | otherwise    = not (isDeadBinder bndr)+                        -- The deadness info on the new Ids is preserved by simplBinders+              final_args = varsToCoreExprs final_bndrs'+                           -- Note [Join point abstraction]++                -- We make the lambdas into one-shot-lambdas.  The+                -- join point is sure to be applied at most once, and doing so+                -- prevents the body of the join point being floated out by+                -- the full laziness pass+              really_final_bndrs     = map one_shot final_bndrs'+              one_shot v | isId v    = setOneShotLambda v+                         | otherwise = v+              join_rhs   = mkLams really_final_bndrs rhs'++        ; join_bndr <- newJoinId final_bndrs' rhs_ty'++        ; let join_call = mkApps (Var join_bndr) final_args+              alt'      = (con, bndrs', join_call)++        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)+                 , alt') }+                -- See Note [Duplicated env]++{-+Note [Fusing case continuations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important to fuse two successive case continuations when the+first has one alternative.  That's why we call prepareCaseCont here.+Consider this, which arises from thunk splitting (see Note [Thunk+splitting] in GHC.Core.Op.WorkWrap):++      let+        x* = case (case v of {pn -> rn}) of+               I# a -> I# a+      in body++The simplifier will find+    (Var v) with continuation+            Select (pn -> rn) (+            Select [I# a -> I# a] (+            StrictBind body Stop++So we'll call mkDupableCont on+   Select [I# a -> I# a] (StrictBind body Stop)+There is just one alternative in the first Select, so we want to+simplify the rhs (I# a) with continuation (StrictBind body Stop)+Supposing that body is big, we end up with+          let $j a = <let x = I# a in body>+          in case v of { pn -> case rn of+                                 I# a -> $j a }+This is just what we want because the rn produces a box that+the case rn cancels with.++See #4957 a fuller example.++Note [Case binders and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   case (case .. ) of c {+     I# c# -> ....c....++If we make a join point with c but not c# we get+  $j = \c -> ....c....++But if later inlining scrutinises the c, thus++  $j = \c -> ... case c of { I# y -> ... } ...++we won't see that 'c' has already been scrutinised.  This actually+happens in the 'tabulate' function in wave4main, and makes a significant+difference to allocation.++An alternative plan is this:++   $j = \c# -> let c = I# c# in ...c....++but that is bad if 'c' is *not* later scrutinised.++So instead we do both: we pass 'c' and 'c#' , and record in c's inlining+(a stable unfolding) that it's really I# c#, thus++   $j = \c# -> \c[=I# c#] -> ...c....++Absence analysis may later discard 'c'.++NB: take great care when doing strictness analysis;+    see Note [Lambda-bound unfoldings] in GHC.Core.Op.DmdAnal.++Also note that we can still end up passing stuff that isn't used.  Before+strictness analysis we have+   let $j x y c{=(x,y)} = (h c, ...)+   in ...+After strictness analysis we see that h is strict, we end up with+   let $j x y c{=(x,y)} = ($wh x y, ...)+and c is unused.++Note [Duplicated env]+~~~~~~~~~~~~~~~~~~~~~+Some of the alternatives are simplified, but have not been turned into a join point+So they *must* have a zapped subst-env.  So we can't use completeNonRecX to+bind the join point, because it might to do PostInlineUnconditionally, and+we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,+but zapping it (as we do in mkDupableCont, the Select case) is safe, and+at worst delays the join-point inlining.++Note [Small alternative rhs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is worth checking for a small RHS because otherwise we+get extra let bindings that may cause an extra iteration of the simplifier to+inline back in place.  Quite often the rhs is just a variable or constructor.+The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra+iterations because the version with the let bindings looked big, and so wasn't+inlined, but after the join points had been inlined it looked smaller, and so+was inlined.++NB: we have to check the size of rhs', not rhs.+Duplicating a small InAlt might invalidate occurrence information+However, if it *is* dupable, we return the *un* simplified alternative,+because otherwise we'd need to pair it up with an empty subst-env....+but we only have one env shared between all the alts.+(Remember we must zap the subst-env before re-simplifying something).+Rather than do this we simply agree to re-simplify the original (small) thing later.++Note [Funky mkLamTypes]+~~~~~~~~~~~~~~~~~~~~~~+Notice the funky mkLamTypes.  If the constructor has existentials+it's possible that the join point will be abstracted over+type variables as well as term variables.+ Example:  Suppose we have+        data T = forall t.  C [t]+ Then faced with+        case (case e of ...) of+            C t xs::[t] -> rhs+ We get the join point+        let j :: forall t. [t] -> ...+            j = /\t \xs::[t] -> rhs+        in+        case (case e of ...) of+            C t xs::[t] -> j t xs++Note [Duplicating StrictArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We make a StrictArg duplicable simply by making all its+stored-up arguments (in sc_fun) trivial, by let-binding+them.  Thus:+        f E [..hole..]+        ==>     let a = E+                in f a [..hole..]+Now if the thing in the hole is a case expression (which is when+we'll call mkDupableCont), we'll push the function call into the+branches, which is what we want.  Now RULES for f may fire, and+call-pattern specialisation.  Here's an example from #3116+     go (n+1) (case l of+                 1  -> bs'+                 _  -> Chunk p fpc (o+1) (l-1) bs')+If we can push the call for 'go' inside the case, we get+call-pattern specialisation for 'go', which is *crucial* for+this program.++Here is the (&&) example:+        && E (case x of { T -> F; F -> T })+  ==>   let a = E in+        case x of { T -> && a F; F -> && a T }+Much better!++Notice that+  * Arguments to f *after* the strict one are handled by+    the ApplyToVal case of mkDupableCont.  Eg+        f [..hole..] E++  * We can only do the let-binding of E because the function+    part of a StrictArg continuation is an explicit syntax+    tree.  In earlier versions we represented it as a function+    (CoreExpr -> CoreEpxr) which we couldn't take apart.++Historical aide: previously we did this (where E is a+big argument:+        f E [..hole..]+        ==>     let $j = \a -> f E a+                in $j [..hole..]++But this is terrible! Here's an example:+        && E (case x of { T -> F; F -> T })+Now, && is strict so we end up simplifying the case with+an ArgOf continuation.  If we let-bind it, we get+        let $j = \v -> && E v+        in simplExpr (case x of { T -> F; F -> T })+                     (ArgOf (\r -> $j r)+And after simplifying more we get+        let $j = \v -> && E v+        in case x of { T -> $j F; F -> $j T }+Which is a Very Bad Thing+++Note [Duplicating StrictBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We make a StrictBind duplicable in a very similar way to+that for case expressions.  After all,+   let x* = e in b   is similar to    case e of x -> b++So we potentially make a join-point for the body, thus:+   let x = [] in b   ==>   join j x = b+                           in let x = [] in j x+++Note [Join point abstraction]  Historical note+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: This note is now historical, describing how (in the past) we used+to add a void argument to nullary join points.  But now that "join+point" is not a fuzzy concept but a formal syntactic construct (as+distinguished by the JoinId constructor of IdDetails), each of these+concerns is handled separately, with no need for a vestigial extra+argument.++Join points always have at least one value argument,+for several reasons++* If we try to lift a primitive-typed something out+  for let-binding-purposes, we will *caseify* it (!),+  with potentially-disastrous strictness results.  So+  instead we turn it into a function: \v -> e+  where v::Void#.  The value passed to this function is void,+  which generates (almost) no code.++* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now+  we make the join point into a function whenever used_bndrs'+  is empty.  This makes the join-point more CPR friendly.+  Consider:       let j = if .. then I# 3 else I# 4+                  in case .. of { A -> j; B -> j; C -> ... }++  Now CPR doesn't w/w j because it's a thunk, so+  that means that the enclosing function can't w/w either,+  which is a lose.  Here's the example that happened in practice:+          kgmod :: Int -> Int -> Int+          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0+                      then 78+                      else 5++* Let-no-escape.  We want a join point to turn into a let-no-escape+  so that it is implemented as a jump, and one of the conditions+  for LNE is that it's not updatable.  In CoreToStg, see+  Note [What is a non-escaping let]++* Floating.  Since a join point will be entered once, no sharing is+  gained by floating out, but something might be lost by doing+  so because it might be allocated.++I have seen a case alternative like this:+        True -> \v -> ...+It's a bit silly to add the realWorld dummy arg in this case, making+        $j = \s v -> ...+           True -> $j s+(the \v alone is enough to make CPR happy) but I think it's rare++There's a slight infelicity here: we pass the overall+case_bndr to all the join points if it's used in *any* RHS,+because we don't know its usage in each RHS separately++++************************************************************************+*                                                                      *+                    Unfoldings+*                                                                      *+************************************************************************+-}++simplLetUnfolding :: SimplEnv-> TopLevelFlag+                  -> MaybeJoinCont+                  -> InId+                  -> OutExpr -> OutType+                  -> Unfolding -> SimplM Unfolding+simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf+  | isStableUnfolding unf+  = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty+  | isExitJoinId id+  = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Op.Exitify+  | otherwise+  = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs++-------------------+mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource+               -> InId -> OutExpr -> SimplM Unfolding+mkLetUnfolding dflags top_lvl src id new_rhs+  = is_bottoming `seq`  -- See Note [Force bottoming field]+    return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)+            -- We make an  unfolding *even for loop-breakers*.+            -- Reason: (a) It might be useful to know that they are WHNF+            --         (b) In GHC.Iface.Tidy we currently assume that, if we want to+            --             expose the unfolding then indeed we *have* an unfolding+            --             to expose.  (We could instead use the RHS, but currently+            --             we don't.)  The simple thing is always to have one.+  where+    is_top_lvl   = isTopLevel top_lvl+    is_bottoming = isBottomingId id++-------------------+simplStableUnfolding :: SimplEnv -> TopLevelFlag+                     -> MaybeJoinCont  -- Just k => a join point with continuation k+                     -> InId+                     -> Unfolding -> OutType -> SimplM Unfolding+-- Note [Setting the new unfolding]+simplStableUnfolding env top_lvl mb_cont id unf rhs_ty+  = case unf of+      NoUnfolding   -> return unf+      BootUnfolding -> return unf+      OtherCon {}   -> return unf++      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }+        -> do { (env', bndrs') <- simplBinders unf_env bndrs+              ; args' <- mapM (simplExpr env') args+              ; return (mkDFunUnfolding bndrs' con args') }++      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }+        | isStableSource src+        -> do { expr' <- case mb_cont of -- See Note [Rules and unfolding for join points]+                           Just cont -> simplJoinRhs unf_env id expr cont+                           Nothing   -> simplExprC unf_env expr (mkBoringStop rhs_ty)+              ; case guide of+                  UnfWhen { ug_arity = arity+                          , ug_unsat_ok = sat_ok+                          , ug_boring_ok = boring_ok+                          }+                          -- Happens for INLINE things+                     -> let guide' =+                              UnfWhen { ug_arity = arity+                                      , ug_unsat_ok = sat_ok+                                      , ug_boring_ok =+                                          boring_ok || inlineBoringOk expr'+                                      }+                        -- Refresh the boring-ok flag, in case expr'+                        -- has got small. This happens, notably in the inlinings+                        -- for dfuns for single-method classes; see+                        -- Note [Single-method classes] in TcInstDcls.+                        -- A test case is #4138+                        -- But retain a previous boring_ok of True; e.g. see+                        -- the way it is set in calcUnfoldingGuidanceWithArity+                        in return (mkCoreUnfolding src is_top_lvl expr' guide')+                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold++                  _other              -- Happens for INLINABLE things+                     -> mkLetUnfolding dflags top_lvl src id expr' }+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE+                -- unfolding, and we need to make sure the guidance is kept up+                -- to date with respect to any changes in the unfolding.++        | otherwise -> return noUnfolding   -- Discard unstable unfoldings+  where+    dflags     = seDynFlags env+    is_top_lvl = isTopLevel top_lvl+    act        = idInlineActivation id+    unf_env    = updMode (updModeForStableUnfoldings act) env+         -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Op.Simplify.Utils++{-+Note [Force bottoming field]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to force bottoming, or the new unfolding holds+on to the old unfolding (which is part of the id).++Note [Setting the new unfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we+  should do nothing at all, but simplifying gently might get rid of+  more crap.++* If not, we make an unfolding from the new RHS.  But *only* for+  non-loop-breakers. Making loop breakers not have an unfolding at all+  means that we can avoid tests in exprIsConApp, for example.  This is+  important: if exprIsConApp says 'yes' for a recursive thing, then we+  can get into an infinite loop++If there's a stable unfolding on a loop breaker (which happens for+INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the+user did say 'INLINE'.  May need to revisit this choice.++************************************************************************+*                                                                      *+                    Rules+*                                                                      *+************************************************************************++Note [Rules in a letrec]+~~~~~~~~~~~~~~~~~~~~~~~~+After creating fresh binders for the binders of a letrec, we+substitute the RULES and add them back onto the binders; this is done+*before* processing any of the RHSs.  This is important.  Manuel found+cases where he really, really wanted a RULE for a recursive function+to apply in that function's own right-hand side.++See Note [Forming Rec groups] in OccurAnal+-}++addBndrRules :: SimplEnv -> InBndr -> OutBndr+             -> MaybeJoinCont   -- Just k for a join point binder+                                -- Nothing otherwise+             -> SimplM (SimplEnv, OutBndr)+-- Rules are added back into the bin+addBndrRules env in_id out_id mb_cont+  | null old_rules+  = return (env, out_id)+  | otherwise+  = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont+       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules+       ; return (modifyInScope env final_id, final_id) }+  where+    old_rules = ruleInfoRules (idSpecialisation in_id)++simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]+           -> MaybeJoinCont -> SimplM [CoreRule]+simplRules env mb_new_id rules mb_cont+  = mapM simpl_rule rules+  where+    simpl_rule rule@(BuiltinRule {})+      = return rule++    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args+                          , ru_fn = fn_name, ru_rhs = rhs })+      = do { (env', bndrs') <- simplBinders env bndrs+           ; let rhs_ty = substTy env' (exprType rhs)+                 rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]+                                Nothing   -> mkBoringStop rhs_ty+                                Just cont -> ASSERT2( join_ok, bad_join_msg )+                                             cont+                 rule_env = updMode updModeForRules env'+                 fn_name' = case mb_new_id of+                              Just id -> idName id+                              Nothing -> fn_name++                 -- join_ok is an assertion check that the join-arity of the+                 -- binder matches that of the rule, so that pushing the+                 -- continuation into the RHS makes sense+                 join_ok = case mb_new_id of+                             Just id | Just join_arity <- isJoinId_maybe id+                                     -> length args == join_arity+                             _ -> False+                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule+                                     , ppr (fmap isJoinId_maybe mb_new_id) ]++           ; args' <- mapM (simplExpr rule_env) args+           ; rhs'  <- simplExprC rule_env rhs rhs_cont+           ; return (rule { ru_bndrs = bndrs'+                          , ru_fn    = fn_name'+                          , ru_args  = args'+                          , ru_rhs   = rhs' }) }
+ compiler/GHC/Core/Op/Simplify/Driver.hs view
@@ -0,0 +1,1037 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[SimplCore]{Driver for simplifying @Core@ programs}+-}++{-# LANGUAGE CPP #-}++module GHC.Core.Op.Simplify.Driver ( core2core, simplifyExpr ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Driver.Session+import GHC.Core+import GHC.Driver.Types+import GHC.Core.Op.CSE  ( cseProgram )+import GHC.Core.Rules   ( mkRuleBase, unionRuleBase,+                          extendRuleBaseList, ruleCheckProgram, addRuleInfo,+                          getRules )+import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )+import GHC.Core.Op.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )+import GHC.Types.Id.Info+import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )+import GHC.Core.Utils   ( mkTicks, stripTicksTop )+import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,+                          lintAnnots )+import GHC.Core.Op.Simplify       ( simplTopBinds, simplExpr, simplRules )+import GHC.Core.Op.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )+import GHC.Core.Op.Simplify.Env+import GHC.Core.Op.Simplify.Monad+import GHC.Core.Op.Monad+import qualified ErrUtils as Err+import GHC.Core.Op.FloatIn  ( floatInwards )+import GHC.Core.Op.FloatOut ( floatOutwards )+import GHC.Core.FamInstEnv+import GHC.Types.Id+import ErrUtils         ( withTiming, withTimingD, DumpFormat (..) )+import GHC.Types.Basic  ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma )+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Core.Op.LiberateCase ( liberateCase )+import GHC.Core.Op.StaticArgs   ( doStaticArgs )+import GHC.Core.Op.Specialise   ( specProgram)+import GHC.Core.Op.SpecConstr   ( specConstrProgram)+import GHC.Core.Op.DmdAnal      ( dmdAnalProgram )+import GHC.Core.Op.CprAnal      ( cprAnalProgram )+import GHC.Core.Op.CallArity    ( callArityAnalProgram )+import GHC.Core.Op.Exitify      ( exitifyProgram )+import GHC.Core.Op.WorkWrap     ( wwTopBinds )+import GHC.Types.SrcLoc+import Util+import GHC.Types.Module+import GHC.Driver.Plugins ( withPlugins, installCoreToDos )+import GHC.Runtime.Loader -- ( initializePlugins )++import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )+import GHC.Types.Unique.FM+import Outputable+import Control.Monad+import qualified GHC.LanguageExtensions as LangExt+{-+************************************************************************+*                                                                      *+\subsection{The driver for the simplifier}+*                                                                      *+************************************************************************+-}++core2core :: HscEnv -> ModGuts -> IO ModGuts+core2core hsc_env guts@(ModGuts { mg_module  = mod+                                , mg_loc     = loc+                                , mg_deps    = deps+                                , mg_rdr_env = rdr_env })+  = do { -- make sure all plugins are loaded++       ; let builtin_passes = getCoreToDo dflags+             orph_mods = mkModuleSet (mod : dep_orphs deps)+             uniq_mask = 's'+       ;+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod+                                    orph_mods print_unqual loc $+                           do { hsc_env' <- getHscEnv+                              ; dflags' <- liftIO $ initializePlugins hsc_env'+                                                      (hsc_dflags hsc_env')+                              ; all_passes <- withPlugins dflags'+                                                installCoreToDos+                                                builtin_passes+                              ; runCorePasses all_passes guts }++       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats+             "Grand total simplifier statistics"+             FormatText+             (pprSimplCount stats)++       ; return guts2 }+  where+    dflags         = hsc_dflags hsc_env+    home_pkg_rules = hptRules hsc_env (dep_mods deps)+    hpt_rule_base  = mkRuleBase home_pkg_rules+    print_unqual   = mkPrintUnqualified dflags rdr_env+    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.+    -- This is very convienent for the users of the monad (e.g. plugins do not have to+    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may+    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which+    -- would mean our cached value would go out of date.++{-+************************************************************************+*                                                                      *+           Generating the main optimisation pipeline+*                                                                      *+************************************************************************+-}++getCoreToDo :: DynFlags -> [CoreToDo]+getCoreToDo dflags+  = flatten_todos core_todo+  where+    opt_level     = optLevel           dflags+    phases        = simplPhases        dflags+    max_iter      = maxSimplIterations dflags+    rule_check    = ruleCheck          dflags+    call_arity    = gopt Opt_CallArity                    dflags+    exitification = gopt Opt_Exitification                dflags+    strictness    = gopt Opt_Strictness                   dflags+    full_laziness = gopt Opt_FullLaziness                 dflags+    do_specialise = gopt Opt_Specialise                   dflags+    do_float_in   = gopt Opt_FloatIn                      dflags+    cse           = gopt Opt_CSE                          dflags+    spec_constr   = gopt Opt_SpecConstr                   dflags+    liberate_case = gopt Opt_LiberateCase                 dflags+    late_dmd_anal = gopt Opt_LateDmdAnal                  dflags+    late_specialise = gopt Opt_LateSpecialise             dflags+    static_args   = gopt Opt_StaticArgumentTransformation dflags+    rules_on      = gopt Opt_EnableRewriteRules           dflags+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags+    ww_on         = gopt Opt_WorkerWrapper                dflags+    static_ptrs   = xopt LangExt.StaticPointers           dflags++    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)++    maybe_strictness_before phase+      = runWhen (phase `elem` strictnessBefore dflags) CoreDoDemand++    base_mode = SimplMode { sm_phase      = panic "base_mode"+                          , sm_names      = []+                          , sm_dflags     = dflags+                          , sm_rules      = rules_on+                          , sm_eta_expand = eta_expand_on+                          , sm_inline     = True+                          , sm_case_case  = True }++    simpl_phase phase names iter+      = CoreDoPasses+      $   [ maybe_strictness_before phase+          , CoreDoSimplify iter+                (base_mode { sm_phase = Phase phase+                           , sm_names = names })++          , maybe_rule_check (Phase phase) ]++    simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter+                                | phase <- [phases, phases-1 .. 1] ]+++        -- initial simplify: mk specialiser happy: minimum effort please+    simpl_gently = CoreDoSimplify max_iter+                       (base_mode { sm_phase = InitialPhase+                                  , sm_names = ["Gentle"]+                                  , sm_rules = rules_on   -- Note [RULEs enabled in InitialPhase]+                                  , sm_inline = True+                                              -- See Note [Inline in InitialPhase]+                                  , sm_case_case = False })+                          -- Don't do case-of-case transformations.+                          -- This makes full laziness work better++    dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper]+                          else [CoreDoDemand,CoreDoCpr]+++    demand_analyser = (CoreDoPasses (+                           dmd_cpr_ww +++                           [simpl_phase 0 ["post-worker-wrapper"] max_iter]+                           ))++    -- Static forms are moved to the top level with the FloatOut pass.+    -- See Note [Grand plan for static forms] in StaticPtrTable.+    static_ptrs_float_outwards =+      runWhen static_ptrs $ CoreDoPasses+        [ simpl_gently -- Float Out can't handle type lets (sometimes created+                       -- by simpleOptPgm via mkParallelBindings)+        , CoreDoFloatOutwards FloatOutSwitches+          { floatOutLambdas   = Just 0+          , floatOutConstants = True+          , floatOutOverSatApps = False+          , floatToTopLevelOnly = True+          }+        ]++    core_todo =+     if opt_level == 0 then+       [ static_ptrs_float_outwards,+         CoreDoSimplify max_iter+             (base_mode { sm_phase = Phase 0+                        , sm_names = ["Non-opt simplification"] })+       ]++     else {- opt_level >= 1 -} [++    -- We want to do the static argument transform before full laziness as it+    -- may expose extra opportunities to float things outwards. However, to fix+    -- up the output of the transformation we need at do at least one simplify+    -- after this before anything else+        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),++        -- initial simplify: mk specialiser happy: minimum effort please+        simpl_gently,++        -- Specialisation is best done before full laziness+        -- so that overloaded functions have all their dictionary lambdas manifest+        runWhen do_specialise CoreDoSpecialising,++        if full_laziness then+           CoreDoFloatOutwards FloatOutSwitches {+                                 floatOutLambdas   = Just 0,+                                 floatOutConstants = True,+                                 floatOutOverSatApps = False,+                                 floatToTopLevelOnly = False }+                -- Was: gentleFloatOutSwitches+                --+                -- I have no idea why, but not floating constants to+                -- top level is very bad in some cases.+                --+                -- Notably: p_ident in spectral/rewrite+                --          Changing from "gentle" to "constantsOnly"+                --          improved rewrite's allocation by 19%, and+                --          made 0.0% difference to any other nofib+                --          benchmark+                --+                -- Not doing floatOutOverSatApps yet, we'll do+                -- that later on when we've had a chance to get more+                -- accurate arity information.  In fact it makes no+                -- difference at all to performance if we do it here,+                -- but maybe we save some unnecessary to-and-fro in+                -- the simplifier.+        else+           -- Even with full laziness turned off, we still need to float static+           -- forms to the top level. See Note [Grand plan for static forms] in+           -- StaticPtrTable.+           static_ptrs_float_outwards,++        simpl_phases,++                -- Phase 0: allow all Ids to be inlined now+                -- This gets foldr inlined before strictness analysis++                -- At least 3 iterations because otherwise we land up with+                -- huge dead expressions because of an infelicity in the+                -- simplifier.+                --      let k = BIG in foldr k z xs+                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs+                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs+                -- Don't stop now!+        simpl_phase 0 ["main"] (max max_iter 3),++        runWhen do_float_in CoreDoFloatInwards,+            -- Run float-inwards immediately before the strictness analyser+            -- Doing so pushes bindings nearer their use site and hence makes+            -- them more likely to be strict. These bindings might only show+            -- up after the inlining from simplification.  Example in fulsom,+            -- Csg.calc, where an arg of timesDouble thereby becomes strict.++        runWhen call_arity $ CoreDoPasses+            [ CoreDoCallArity+            , simpl_phase 0 ["post-call-arity"] max_iter+            ],++        runWhen strictness demand_analyser,++        runWhen exitification CoreDoExitify,+            -- See note [Placement of the exitification pass]++        runWhen full_laziness $+           CoreDoFloatOutwards FloatOutSwitches {+                                 floatOutLambdas     = floatLamArgs dflags,+                                 floatOutConstants   = True,+                                 floatOutOverSatApps = True,+                                 floatToTopLevelOnly = False },+                -- nofib/spectral/hartel/wang doubles in speed if you+                -- do full laziness late in the day.  It only happens+                -- after fusion and other stuff, so the early pass doesn't+                -- catch it.  For the record, the redex is+                --        f_el22 (f_el21 r_midblock)+++        runWhen cse CoreCSE,+                -- We want CSE to follow the final full-laziness pass, because it may+                -- succeed in commoning up things floated out by full laziness.+                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more++        runWhen do_float_in CoreDoFloatInwards,++        maybe_rule_check (Phase 0),++                -- Case-liberation for -O2.  This should be after+                -- strictness analysis and the simplification which follows it.+        runWhen liberate_case (CoreDoPasses [+            CoreLiberateCase,+            simpl_phase 0 ["post-liberate-case"] max_iter+            ]),         -- Run the simplifier after LiberateCase to vastly+                        -- reduce the possibility of shadowing+                        -- Reason: see Note [Shadowing] in GHC.Core.Op.SpecConstr++        runWhen spec_constr CoreDoSpecConstr,++        maybe_rule_check (Phase 0),++        runWhen late_specialise+          (CoreDoPasses [ CoreDoSpecialising+                        , simpl_phase 0 ["post-late-spec"] max_iter]),++        -- LiberateCase can yield new CSE opportunities because it peels+        -- off one layer of a recursive function (concretely, I saw this+        -- in wheel-sieve1), and I'm guessing that SpecConstr can too+        -- And CSE is a very cheap pass. So it seems worth doing here.+        runWhen ((liberate_case || spec_constr) && cse) CoreCSE,++        -- Final clean-up simplification:+        simpl_phase 0 ["final"] max_iter,++        runWhen late_dmd_anal $ CoreDoPasses (+            dmd_cpr_ww +++            [simpl_phase 0 ["post-late-ww"] max_iter]+          ),++        -- Final run of the demand_analyser, ensures that one-shot thunks are+        -- really really one-shot thunks. Only needed if the demand analyser+        -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Op.DmdAnal+        -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution+        -- can become /exponentially/ more expensive. See #11731, #12996.+        runWhen (strictness || late_dmd_anal) CoreDoDemand,++        maybe_rule_check (Phase 0)+     ]++    -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.+    flatten_todos [] = []+    flatten_todos (CoreDoNothing : rest) = flatten_todos rest+    flatten_todos (CoreDoPasses passes : rest) =+      flatten_todos passes ++ flatten_todos rest+    flatten_todos (todo : rest) = todo : flatten_todos rest++{- Note [Inline in InitialPhase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is+confusing for users because when they say INLINE they expect the function to inline+right away.++So now we do inlining immediately, even in the InitialPhase, assuming that the+Id's Activation allows it.++This is a surprisingly big deal. Compiler performance improved a lot+when I made this change:++   perf/compiler/T5837.run            T5837 [stat too good] (normal)+   perf/compiler/parsing001.run       parsing001 [stat too good] (normal)+   perf/compiler/T12234.run           T12234 [stat too good] (optasm)+   perf/compiler/T9020.run            T9020 [stat too good] (optasm)+   perf/compiler/T3064.run            T3064 [stat too good] (normal)+   perf/compiler/T9961.run            T9961 [stat too good] (normal)+   perf/compiler/T13056.run           T13056 [stat too good] (optasm)+   perf/compiler/T9872d.run           T9872d [stat too good] (normal)+   perf/compiler/T783.run             T783 [stat too good] (normal)+   perf/compiler/T12227.run           T12227 [stat too good] (normal)+   perf/should_run/lazy-bs-alloc.run  lazy-bs-alloc [stat too good] (normal)+   perf/compiler/T1969.run            T1969 [stat too good] (normal)+   perf/compiler/T9872a.run           T9872a [stat too good] (normal)+   perf/compiler/T9872c.run           T9872c [stat too good] (normal)+   perf/compiler/T9872b.run           T9872b [stat too good] (normal)+   perf/compiler/T9872d.run           T9872d [stat too good] (normal)++Note [RULEs enabled in InitialPhase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+RULES are enabled when doing "gentle" simplification in InitialPhase,+or with -O0.  Two reasons:++  * We really want the class-op cancellation to happen:+        op (df d1 d2) --> $cop3 d1 d2+    because this breaks the mutual recursion between 'op' and 'df'++  * I wanted the RULE+        lift String ===> ...+    to work in Template Haskell when simplifying+    splices, so we get simpler code for literal strings++But watch out: list fusion can prevent floating.  So use phase control+to switch off those rules until after floating.++************************************************************************+*                                                                      *+                  The CoreToDo interpreter+*                                                                      *+************************************************************************+-}++runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts+runCorePasses passes guts+  = foldM do_pass guts passes+  where+    do_pass guts CoreDoNothing = return guts+    do_pass guts (CoreDoPasses ps) = runCorePasses ps guts+    do_pass guts pass = do+       withTimingD (ppr pass <+> brackets (ppr mod))+                   (const ()) $ do+            { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts+            ; endPass pass (mg_binds guts') (mg_rules guts')+            ; return guts' }++    mod = mg_module guts++doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts+doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}+                                       simplifyPgm pass++doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}+                                       doPass cseProgram++doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}+                                       doPassD liberateCase++doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}+                                       floatInwards++doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}+                                       doPassDUM (floatOutwards f)++doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}+                                       doPassU doStaticArgs++doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}+                                       doPassD callArityAnalProgram++doCorePass CoreDoExitify             = {-# SCC "Exitify" #-}+                                       doPass exitifyProgram++doCorePass CoreDoDemand              = {-# SCC "DmdAnal" #-}+                                       doPassDFM dmdAnalProgram++doCorePass CoreDoCpr                 = {-# SCC "CprAnal" #-}+                                       doPassDFM cprAnalProgram++doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}+                                       doPassDFU wwTopBinds++doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}+                                       specProgram++doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}+                                       specConstrProgram++doCorePass CoreDoPrintCore              = observe   printCore+doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat+doCorePass CoreDoNothing                = return+doCorePass (CoreDoPasses passes)        = runCorePasses passes++doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass++doCorePass pass@CoreDesugar          = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CoreDesugarOpt       = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CoreTidy             = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CorePrep             = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CoreOccurAnal        = pprPanic "doCorePass" (ppr pass)++{-+************************************************************************+*                                                                      *+\subsection{Core pass combinators}+*                                                                      *+************************************************************************+-}++printCore :: DynFlags -> CoreProgram -> IO ()+printCore dflags binds+    = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)++ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts+ruleCheckPass current_phase pat guts =+    withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts))+                (const ()) $ do+    { rb <- getRuleBase+    ; dflags <- getDynFlags+    ; vis_orphs <- getVisibleOrphanMods+    ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn+                        ++ (mg_rules guts)+    ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan+                   (defaultDumpStyle dflags)+                   (ruleCheckProgram current_phase pat+                      rule_fn (mg_binds guts))+    ; return guts }++doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDUM do_pass = doPassM $ \binds -> do+    dflags <- getDynFlags+    us     <- getUniqueSupplyM+    liftIO $ do_pass dflags us binds++doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))++doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)++doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)++doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassU do_pass = doPassDU (const do_pass)++doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDFM do_pass guts = do+    dflags <- getDynFlags+    p_fam_env <- getPackageFamInstEnv+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)+    doPassM (liftIO . do_pass dflags fam_envs) guts++doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDFU do_pass guts = do+    dflags <- getDynFlags+    us     <- getUniqueSupplyM+    p_fam_env <- getPackageFamInstEnv+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)+    doPass (do_pass dflags fam_envs us) guts++-- Most passes return no stats and don't change rules: these combinators+-- let us lift them to the full blown ModGuts+CoreM world+doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts+doPassM bind_f guts = do+    binds' <- bind_f (mg_binds guts)+    return (guts { mg_binds = binds' })++doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }++-- Observer passes just peek; don't modify the bindings at all+observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts+observe do_pass = doPassM $ \binds -> do+    dflags <- getDynFlags+    _ <- liftIO $ do_pass dflags binds+    return binds++{-+************************************************************************+*                                                                      *+        Gentle simplification+*                                                                      *+************************************************************************+-}++simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do+             -> CoreExpr+             -> IO CoreExpr+-- simplifyExpr is called by the driver to simplify an+-- expression typed in at the interactive prompt+simplifyExpr hsc_env expr+  = withTiming dflags (text "Simplify [expr]") (const ()) $+    do  { eps <- hscEPS hsc_env ;+        ; let rule_env  = mkRuleEnv (eps_rule_base eps) []+              fi_env    = ( eps_fam_inst_env eps+                          , extendFamInstEnvList emptyFamInstEnv $+                            snd $ ic_instances $ hsc_IC hsc_env )+              simpl_env = simplEnvForGHCi dflags++        ; us <-  mkSplitUniqSupply 's'+        ; let sz = exprSize expr++        ; (expr', counts) <- initSmpl dflags rule_env fi_env us sz $+                             simplExprGently simpl_env expr++        ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)+                  "Simplifier statistics" (pprSimplCount counts)++        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"+                        FormatCore+                        (pprCoreExpr expr')++        ; return expr'+        }+  where+    dflags = hsc_dflags hsc_env++simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr+-- Simplifies an expression+--      does occurrence analysis, then simplification+--      and repeats (twice currently) because one pass+--      alone leaves tons of crud.+-- Used (a) for user expressions typed in at the interactive prompt+--      (b) the LHS and RHS of a RULE+--      (c) Template Haskell splices+--+-- The name 'Gently' suggests that the SimplMode is InitialPhase,+-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't+-- 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+-- simplifier does indeed do eta reduction (it's in GHC.Core.Op.Simplify.completeLam)+-- but only if -O is on.++simplExprGently env expr = do+    expr1 <- simplExpr env (occurAnalyseExpr expr)+    simplExpr env (occurAnalyseExpr expr1)++{-+************************************************************************+*                                                                      *+\subsection{The driver for the simplifier}+*                                                                      *+************************************************************************+-}++simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts+simplifyPgm pass guts+  = do { hsc_env <- getHscEnv+       ; us <- getUniqueSupplyM+       ; rb <- getRuleBase+       ; liftIOWithCount $+         simplifyPgmIO pass hsc_env us rb guts }++simplifyPgmIO :: CoreToDo+              -> HscEnv+              -> UniqSupply+              -> RuleBase+              -> ModGuts+              -> IO (SimplCount, ModGuts)  -- New bindings++simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)+              hsc_env us hpt_rule_base+              guts@(ModGuts { mg_module = this_mod+                            , mg_rdr_env = rdr_env+                            , mg_deps = deps+                            , mg_binds = binds, mg_rules = rules+                            , mg_fam_inst_env = fam_inst_env })+  = do { (termination_msg, it_count, counts_out, guts')+           <- do_iteration us 1 [] binds rules++        ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&+                                dopt Opt_D_dump_simpl_stats  dflags)+                  "Simplifier statistics for following pass"+                  (vcat [text termination_msg <+> text "after" <+> ppr it_count+                                              <+> text "iterations",+                         blankLine,+                         pprSimplCount counts_out])++        ; return (counts_out, guts')+    }+  where+    dflags       = hsc_dflags hsc_env+    print_unqual = mkPrintUnqualified dflags rdr_env+    simpl_env    = mkSimplEnv mode+    active_rule  = activeRule mode+    active_unf   = activeUnfolding mode++    do_iteration :: UniqSupply+                 -> Int          -- Counts iterations+                 -> [SimplCount] -- Counts from earlier iterations, reversed+                 -> CoreProgram  -- Bindings in+                 -> [CoreRule]   -- and orphan rules+                 -> IO (String, Int, SimplCount, ModGuts)++    do_iteration us iteration_no counts_so_far binds rules+        -- iteration_no is the number of the iteration we are+        -- about to begin, with '1' for the first+      | iteration_no > max_iterations   -- Stop if we've run out of iterations+      = WARN( debugIsOn && (max_iterations > 2)+            , hang (text "Simplifier bailing out after" <+> int max_iterations+                    <+> text "iterations"+                    <+> (brackets $ hsep $ punctuate comma $+                         map (int . simplCountN) (reverse counts_so_far)))+                 2 (text "Size =" <+> ppr (coreBindsStats binds)))++                -- Subtract 1 from iteration_no to get the+                -- number of iterations we actually completed+        return ( "Simplifier baled out", iteration_no - 1+               , totalise counts_so_far+               , guts { mg_binds = binds, mg_rules = rules } )++      -- Try and force thunks off the binds; significantly reduces+      -- space usage, especially with -O.  JRS, 000620.+      | let sz = coreBindsSize binds+      , () <- sz `seq` ()     -- Force it+      = do {+                -- Occurrence analysis+           let { tagged_binds = {-# SCC "OccAnal" #-}+                     occurAnalysePgm this_mod active_unf active_rule rules+                                     binds+               } ;+           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"+                     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+                -- 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+           eps <- hscEPS hsc_env ;+           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)+                ; rule_base2 = extendRuleBaseList rule_base1 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 dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $+               do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}+                                      simplTopBinds simpl_env tagged_binds++                      -- Apply the substitution to rules defined in this module+                      -- for imported Ids.  Eg  RULE map my_f = blah+                      -- If we have a substitution my_f :-> other_f, we'd better+                      -- apply it to the rule to, or it'll never match+                  ; rules1 <- simplRules env1 Nothing rules Nothing++                  ; return (getTopFloatBinds floats, rules1) } ;++                -- Stop if nothing happened; don't dump output+                -- See Note [Which transformations are innocuous] in GHC.Core.Op.Monad+           if isZeroSimplCount counts1 then+                return ( "Simplifier reached fixed point", iteration_no+                       , totalise (counts1 : counts_so_far)  -- Include "free" ticks+                       , guts { mg_binds = binds1, mg_rules = rules1 } )+           else do {+                -- Short out indirections+                -- We do this *after* at least one run of the simplifier+                -- because indirection-shorting uses the export flag on *occurrences*+                -- and that isn't guaranteed to be ok until after the first run propagates+                -- stuff from the binding site to its occurrences+                --+                -- ToDo: alas, this means that indirection-shorting does not happen at all+                --       if the simplifier does nothing (not common, I know, but unsavoury)+           let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;++                -- Dump the result of this iteration+           dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;+           lintPassResult hsc_env pass binds2 ;++                -- Loop+           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1+           } }+#if __GLASGOW_HASKELL__ <= 810+      | otherwise = panic "do_iteration"+#endif+      where+        (us1, us2) = splitUniqSupply us++        -- Remember the counts_so_far are reversed+        totalise :: [SimplCount] -> SimplCount+        totalise = foldr (\c acc -> acc `plusSimplCount` c)+                         (zeroSimplCount dflags)++simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"++-------------------+dump_end_iteration :: DynFlags -> PrintUnqualified -> Int+                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()+dump_end_iteration dflags print_unqual iteration_no counts binds rules+  = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules+  where+    mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations+            | otherwise                               = Nothing+            -- Show details if Opt_D_dump_simpl_iterations is on++    hdr = text "Simplifier iteration=" <> int iteration_no+    pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr+                     , pprSimplCount counts+                     , text "---- End of simplifier counts for" <+> hdr ]++{-+************************************************************************+*                                                                      *+                Shorting out indirections+*                                                                      *+************************************************************************++If we have this:++        x_local = <expression>+        ...bindings...+        x_exported = x_local++where x_exported is exported, and x_local is not, then we replace it with this:++        x_exported = <expression>+        x_local = x_exported+        ...bindings...++Without this we never get rid of the x_exported = x_local thing.  This+save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and+makes strictness information propagate better.  This used to happen in+the final phase, but it's tidier to do it here.++Note [Messing up the exported Id's RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must be careful about discarding (obviously) or even merging the+RULES on the exported Id. The example that went bad on me at one stage+was this one:++    iterate :: (a -> a) -> a -> [a]+        [Exported]+    iterate = iterateList++    iterateFB c f x = x `c` iterateFB c f (f x)+    iterateList f x =  x : iterateList f (f x)+        [Not exported]++    {-# RULES+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)+    "iterateFB"                 iterateFB (:) = iterateList+     #-}++This got shorted out to:++    iterateList :: (a -> a) -> a -> [a]+    iterateList = iterate++    iterateFB c f x = x `c` iterateFB c f (f x)+    iterate f x =  x : iterate f (f x)++    {-# RULES+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)+    "iterateFB"                 iterateFB (:) = iterate+     #-}++And now we get an infinite loop in the rule system+        iterate f x -> build (\cn -> iterateFB c f x)+                    -> iterateFB (:) f x+                    -> iterate f x++Old "solution":+        use rule switching-off pragmas to get rid+        of iterateList in the first place++But in principle the user *might* want rules that only apply to the Id+he says.  And inline pragmas are similar+   {-# NOINLINE f #-}+   f = local+   local = <stuff>+Then we do not want to get rid of the NOINLINE.++Hence hasShortableIdinfo.+++Note [Rules and indirection-zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Problem: what if x_exported has a RULE that mentions something in ...bindings...?+Then the things mentioned can be out of scope!  Solution+ a) Make sure that in this pass the usage-info from x_exported is+        available for ...bindings...+ b) If there are any such RULES, rec-ify the entire top-level.+    It'll get sorted out next time round++Other remarks+~~~~~~~~~~~~~+If more than one exported thing is equal to a local thing (i.e., the+local thing really is shared), then we do one only:+\begin{verbatim}+        x_local = ....+        x_exported1 = x_local+        x_exported2 = x_local+==>+        x_exported1 = ....++        x_exported2 = x_exported1+\end{verbatim}++We rely on prior eta reduction to simplify things like+\begin{verbatim}+        x_exported = /\ tyvars -> x_local tyvars+==>+        x_exported = x_local+\end{verbatim}+Hence,there's a possibility of leaving unchanged something like this:+\begin{verbatim}+        x_local = ....+        x_exported1 = x_local Int+\end{verbatim}+By the time we've thrown away the types in STG land this+could be eliminated.  But I don't think it's very common+and it's dangerous to do this fiddling in STG land+because we might eliminate a binding that's mentioned in the+unfolding for something.++Note [Indirection zapping and ticks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unfortunately this is another place where we need a special case for+ticks. The following happens quite regularly:++        x_local = <expression>+        x_exported = tick<x> x_local++Which we want to become:++        x_exported =  tick<x> <expression>++As it makes no sense to keep the tick and the expression on separate+bindings. Note however that that this might increase the ticks scoping+over the execution of x_local, so we can only do this for floatable+ticks. More often than not, other references will be unfoldings of+x_exported, and therefore carry the tick anyway.+-}++type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks++shortOutIndirections :: CoreProgram -> CoreProgram+shortOutIndirections binds+  | isEmptyVarEnv ind_env = binds+  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]+  | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff+  where+    ind_env            = makeIndEnv binds+    -- These exported Ids are the subjects  of the indirection-elimination+    exp_ids            = map fst $ nonDetEltsUFM ind_env+      -- It's OK to use nonDetEltsUFM here because we forget the ordering+      -- by immediately converting to a set or check if all the elements+      -- satisfy a predicate.+    exp_id_set         = mkVarSet exp_ids+    no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids+    binds'             = concatMap zap binds++    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]+    zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]++    zapPair (bndr, rhs)+        | bndr `elemVarSet` exp_id_set+        = []   -- Kill the exported-id binding++        | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr+        , (exp_id', lcl_id') <- transferIdInfo exp_id bndr+        =      -- Turn a local-id binding into two bindings+               --    exp_id = rhs; lcl_id = exp_id+          [ (exp_id', mkTicks ticks rhs),+            (lcl_id', Var exp_id') ]++        | otherwise+        = [(bndr,rhs)]++makeIndEnv :: [CoreBind] -> IndEnv+makeIndEnv binds+  = foldl' add_bind emptyVarEnv binds+  where+    add_bind :: IndEnv -> CoreBind -> IndEnv+    add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)+    add_bind env (Rec pairs)              = foldl' add_pair env pairs++    add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv+    add_pair env (exported_id, exported)+        | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported+        , shortMeOut env exported_id local_id+        = extendVarEnv env local_id (exported_id, ticks)+    add_pair env _ = env++-----------------+shortMeOut :: IndEnv -> Id -> Id -> Bool+shortMeOut ind_env exported_id local_id+-- The if-then-else stuff is just so I can get a pprTrace to see+-- how often I don't get shorting out because of IdInfo stuff+  = if isExportedId exported_id &&              -- Only if this is exported++       isLocalId local_id &&                    -- Only if this one is defined in this+                                                --      module, so that we *can* change its+                                                --      binding to be the exported thing!++       not (isExportedId local_id) &&           -- Only if this one is not itself exported,+                                                --      since the transformation will nuke it++       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]+        else WARN( True, text "Not shorting out:" <+> ppr exported_id )+             False+    else+        False++-----------------+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]+hasShortableIdInfo id+  =  isEmptyRuleInfo (ruleInfo info)+  && isDefaultInlinePragma (inlinePragInfo info)+  && not (isStableUnfolding (unfoldingInfo info))+  where+     info = idInfo id++-----------------+{- Note [Transferring IdInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+     lcl_id = e; exp_id = lcl_id++and lcl_id has useful IdInfo, we don't want to discard it by going+     gbl_id = e; lcl_id = gbl_id++Instead, transfer IdInfo from lcl_id to exp_id, specifically+* (Stable) unfolding+* Strictness+* Rules+* Inline pragma++Overwriting, rather than merging, seems to work ok.++We also zap the InlinePragma on the lcl_id. It might originally+have had a NOINLINE, which we have now transferred; and we really+want the lcl_id to inline now that its RHS is trivial!+-}++transferIdInfo :: Id -> Id -> (Id, Id)+-- See Note [Transferring IdInfo]+transferIdInfo exported_id local_id+  = ( modifyIdInfo transfer exported_id+    , local_id `setInlinePragma` defaultInlinePragma )+  where+    local_info = idInfo local_id+    transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info+                                 `setCprInfo`           cprInfo local_info+                                 `setUnfoldingInfo`     unfoldingInfo local_info+                                 `setInlinePragInfo`    inlinePragInfo local_info+                                 `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info+    new_info = setRuleInfoHead (idName exported_id)+                               (ruleInfo local_info)+        -- Remember to set the function-name field of the+        -- rules as we transfer them from one function to another
+ compiler/GHC/Core/Op/Simplify/Env.hs view
@@ -0,0 +1,938 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[GHC.Core.Op.Simplify.Monad]{The simplifier Monad}+-}++{-# LANGUAGE CPP #-}++module GHC.Core.Op.Simplify.Env (+        -- * The simplifier mode+        setMode, getMode, updMode, seDynFlags,++        -- * Environments+        SimplEnv(..), pprSimplEnv,   -- Temp not abstract+        mkSimplEnv, extendIdSubst,+        extendTvSubst, extendCvSubst,+        zapSubstEnv, setSubstEnv,+        getInScope, setInScopeFromE, setInScopeFromF,+        setInScopeSet, modifyInScope, addNewInScopeIds,+        getSimplRules,++        -- * Substitution results+        SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,++        -- * Simplifying 'Id' binders+        simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,+        simplBinder, simplBinders,+        substTy, substTyVar, getTCvSubst,+        substCo, substCoVar,++        -- * Floats+        SimplFloats(..), emptyFloats, mkRecFloats,+        mkFloatBind, addLetFloats, addJoinFloats, addFloats,+        extendFloats, wrapFloats,+        doFloatFromRhs, getTopFloatBinds,++        -- * LetFloats+        LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,+        addLetFlts,  mapLetFloats,++        -- * JoinFloats+        JoinFloat, JoinFloats, emptyJoinFloats,+        wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core.Op.Simplify.Monad+import GHC.Core.Op.Monad        ( SimplMode(..) )+import GHC.Core+import GHC.Core.Utils+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import OrdList+import GHC.Types.Id as Id+import GHC.Core.Make            ( mkWildValBinder )+import GHC.Driver.Session       ( DynFlags )+import TysWiredIn+import qualified GHC.Core.Type as Type+import GHC.Core.Type hiding     ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst )+import qualified GHC.Core.Coercion as Coercion+import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr )+import GHC.Types.Basic+import MonadUtils+import Outputable+import Util+import GHC.Types.Unique.FM      ( pprUniqFM )++import Data.List (mapAccumL)++{-+************************************************************************+*                                                                      *+\subsubsection{The @SimplEnv@ type}+*                                                                      *+************************************************************************+-}++data SimplEnv+  = SimplEnv {+     ----------- Static part of the environment -----------+     -- Static in the sense of lexically scoped,+     -- wrt the original expression++        seMode      :: SimplMode++        -- The current substitution+      , seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType+      , seCvSubst   :: CvSubstEnv      -- InCoVar |--> OutCoercion+      , seIdSubst   :: SimplIdSubst    -- InId    |--> OutExpr++     ----------- Dynamic part of the environment -----------+     -- Dynamic in the sense of describing the setup where+     -- the expression finally ends up++        -- The current set of in-scope variables+        -- They are all OutVars, and all bound in this module+      , seInScope   :: InScopeSet       -- OutVars only+    }++data SimplFloats+  = SimplFloats+      { -- Ordinary let bindings+        sfLetFloats  :: LetFloats+                -- See Note [LetFloats]++        -- Join points+      , sfJoinFloats :: JoinFloats+                -- Handled separately; they don't go very far+                -- We consider these to be /inside/ sfLetFloats+                -- because join points can refer to ordinary bindings,+                -- but not vice versa++        -- Includes all variables bound by sfLetFloats and+        -- sfJoinFloats, plus at least whatever is in scope where+        -- these bindings land up.+      , sfInScope :: InScopeSet  -- All OutVars+      }++instance Outputable SimplFloats where+  ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })+    = text "SimplFloats"+      <+> braces (vcat [ text "lets: " <+> ppr lf+                       , text "joins:" <+> ppr jf+                       , text "in_scope:" <+> ppr is ])++emptyFloats :: SimplEnv -> SimplFloats+emptyFloats env+  = SimplFloats { sfLetFloats  = emptyLetFloats+                , sfJoinFloats = emptyJoinFloats+                , sfInScope    = seInScope env }++pprSimplEnv :: SimplEnv -> SDoc+-- Used for debugging; selective+pprSimplEnv env+  = vcat [text "TvSubst:" <+> ppr (seTvSubst env),+          text "CvSubst:" <+> ppr (seCvSubst env),+          text "IdSubst:" <+> id_subst_doc,+          text "InScope:" <+> in_scope_vars_doc+    ]+  where+   id_subst_doc = pprUniqFM ppr (seIdSubst env)+   in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))+                                 (vcat . map ppr_one)+   ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)+             | otherwise = ppr v++type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr+        -- See Note [Extending the Subst] in GHC.Core.Subst++-- | A substitution result.+data SimplSR+  = DoneEx OutExpr (Maybe JoinArity)+       -- If  x :-> DoneEx e ja   is in the SimplIdSubst+       -- then replace occurrences of x by e+       -- and  ja = Just a <=> x is a join-point of arity a+       -- See Note [Join arity in SimplIdSubst]+++  | DoneId OutId+       -- If  x :-> DoneId v   is in the SimplIdSubst+       -- then replace occurrences of x by v+       -- and  v is a join-point of arity a+       --      <=> x is a join-point of arity a++  | ContEx TvSubstEnv                 -- A suspended substitution+           CvSubstEnv+           SimplIdSubst+           InExpr+      -- If   x :-> ContEx tv cv id e   is in the SimplISubst+      -- then replace occurrences of x by (subst (tv,cv,id) e)++instance Outputable SimplSR where+  ppr (DoneId v)    = text "DoneId" <+> ppr v+  ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e+    where+      pp_mj = case mj of+                Nothing -> empty+                Just n  -> parens (int n)++  ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,+                                ppr (filter_env tv), ppr (filter_env id) -}]+        -- where+        -- fvs = exprFreeVars e+        -- filter_env env = filterVarEnv_Directly keep env+        -- keep uniq _ = uniq `elemUFM_Directly` fvs++{-+Note [SimplEnv invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~+seInScope:+        The in-scope part of Subst includes *all* in-scope TyVars and Ids+        The elements of the set may have better IdInfo than the+        occurrences of in-scope Ids, and (more important) they will+        have a correctly-substituted type.  So we use a lookup in this+        set to replace occurrences++        The Ids in the InScopeSet are replete with their Rules,+        and as we gather info about the unfolding of an Id, we replace+        it in the in-scope set.++        The in-scope set is actually a mapping OutVar -> OutVar, and+        in case expressions we sometimes bind++seIdSubst:+        The substitution is *apply-once* only, because InIds and OutIds+        can overlap.+        For example, we generally omit mappings+                a77 -> a77+        from the substitution, when we decide not to clone a77, but it's quite+        legitimate to put the mapping in the substitution anyway.++        Furthermore, consider+                let x = case k of I# x77 -> ... in+                let y = case k of I# x77 -> ... in ...+        and suppose the body is strict in both x and y.  Then the simplifier+        will pull the first (case k) to the top; so the second (case k) will+        cancel out, mapping x77 to, well, x77!  But one is an in-Id and the+        other is an out-Id.++        Of course, the substitution *must* applied! Things in its domain+        simply aren't necessarily bound in the result.++* substId adds a binding (DoneId new_id) to the substitution if+        the Id's unique has changed++  Note, though that the substitution isn't necessarily extended+  if the type of the Id changes.  Why not?  Because of the next point:++* We *always, always* finish by looking up in the in-scope set+  any variable that doesn't get a DoneEx or DoneVar hit in the substitution.+  Reason: so that we never finish up with a "old" Id in the result.+  An old Id might point to an old unfolding and so on... which gives a space+  leak.++  [The DoneEx and DoneVar hits map to "new" stuff.]++* It follows that substExpr must not do a no-op if the substitution is empty.+  substType is free to do so, however.++* When we come to a let-binding (say) we generate new IdInfo, including an+  unfolding, attach it to the binder, and add this newly adorned binder to+  the in-scope set.  So all subsequent occurrences of the binder will get+  mapped to the full-adorned binder, which is also the one put in the+  binding site.++* The in-scope "set" usually maps x->x; we use it simply for its domain.+  But sometimes we have two in-scope Ids that are synomyms, and should+  map to the same target:  x->x, y->x.  Notably:+        case y of x { ... }+  That's why the "set" is actually a VarEnv Var++Note [Join arity in SimplIdSubst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have to remember which incoming variables are join points: the occurrences+may not be marked correctly yet, and we're in change of propagating the change if+OccurAnal makes something a join point).++Normally the in-scope set is where we keep the latest information, but+the in-scope set tracks only OutVars; if a binding is unconditionally+inlined (via DoneEx), it never makes it into the in-scope set, and we+need to know at the occurrence site that the variable is a join point+so that we know to drop the context. Thus we remember which join+points we're substituting. -}++mkSimplEnv :: SimplMode -> SimplEnv+mkSimplEnv mode+  = SimplEnv { seMode = mode+             , seInScope = init_in_scope+             , seTvSubst = emptyVarEnv+             , seCvSubst = emptyVarEnv+             , seIdSubst = emptyVarEnv }+        -- The top level "enclosing CC" is "SUBSUMED".++init_in_scope :: InScopeSet+init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))+              -- See Note [WildCard binders]++{-+Note [WildCard binders]+~~~~~~~~~~~~~~~~~~~~~~~+The program to be simplified may have wild binders+    case e of wild { p -> ... }+We want to *rename* them away, so that there are no+occurrences of 'wild-id' (with wildCardKey).  The easy+way to do that is to start of with a representative+Id in the in-scope set++There can be *occurrences* of wild-id.  For example,+GHC.Core.Make.mkCoreApp transforms+   e (a /# b)   -->   case (a /# b) of wild { DEFAULT -> e wild }+This is ok provided 'wild' isn't free in 'e', and that's the delicate+thing. Generally, you want to run the simplifier to get rid of the+wild-ids before doing much else.++It's a very dark corner of GHC.  Maybe it should be cleaned up.+-}++getMode :: SimplEnv -> SimplMode+getMode env = seMode env++seDynFlags :: SimplEnv -> DynFlags+seDynFlags env = sm_dflags (seMode env)++setMode :: SimplMode -> SimplEnv -> SimplEnv+setMode mode env = env { seMode = mode }++updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv+updMode upd env = env { seMode = upd (seMode env) }++---------------------+extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv+extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res+  = ASSERT2( isId var && not (isCoVar var), ppr var )+    env { seIdSubst = extendVarEnv subst var res }++extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv+extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res+  = ASSERT2( isTyVar var, ppr var $$ ppr res )+    env {seTvSubst = extendVarEnv tsubst var res}++extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv+extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co+  = ASSERT( isCoVar var )+    env {seCvSubst = extendVarEnv csubst var co}++---------------------+getInScope :: SimplEnv -> InScopeSet+getInScope env = seInScope env++setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv+setInScopeSet env in_scope = env {seInScope = in_scope}++setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv+-- See Note [Setting the right in-scope set]+setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env }++setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv+setInScopeFromF env floats = env { seInScope = sfInScope floats }++addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv+        -- The new Ids are guaranteed to be freshly allocated+addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs+  = env { seInScope = in_scope `extendInScopeSetList` vs,+          seIdSubst = id_subst `delVarEnvList` vs }+        -- Why delete?  Consider+        --      let x = a*b in (x, \x -> x+3)+        -- We add [x |-> a*b] to the substitution, but we must+        -- _delete_ it from the substitution when going inside+        -- the (\x -> ...)!++modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv+-- The variable should already be in scope, but+-- replace the existing version with this new one+-- which has more information+modifyInScope env@(SimplEnv {seInScope = in_scope}) v+  = env {seInScope = extendInScopeSet in_scope v}++{- Note [Setting the right in-scope set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  \x. (let x = e in b) arg[x]+where the let shadows the lambda.  Really this means something like+  \x1. (let x2 = e in b) arg[x1]++- When we capture the 'arg' in an ApplyToVal continuation, we capture+  the environment, which says what 'x' is bound to, namely x1++- Then that continuation gets pushed under the let++- Finally we simplify 'arg'.  We want+     - the static, lexical environment binding x :-> x1+     - the in-scopeset from "here", under the 'let' which includes+       both x1 and x2++It's important to have the right in-scope set, else we may rename a+variable to one that is already in scope.  So we must pick up the+in-scope set from "here", but otherwise use the environment we+captured along with 'arg'.  This transfer of in-scope set is done by+setInScopeFromE.+-}++---------------------+zapSubstEnv :: SimplEnv -> SimplEnv+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}++setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv+setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }++mkContEx :: SimplEnv -> InExpr -> SimplSR+mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e++{-+************************************************************************+*                                                                      *+\subsection{LetFloats}+*                                                                      *+************************************************************************++Note [LetFloats]+~~~~~~~~~~~~~~~~+The LetFloats is a bunch of bindings, classified by a FloatFlag.++* All of them satisfy the let/app invariant++Examples++  NonRec x (y:ys)       FltLifted+  Rec [(x,rhs)]         FltLifted++  NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?+  NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n++  NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge++Can't happen:+  NonRec x# (a /# b)    -- Might fail; does not satisfy let/app+  NonRec x# (f y)       -- Might diverge; does not satisfy let/app+-}++data LetFloats = LetFloats (OrdList OutBind) FloatFlag+                 -- See Note [LetFloats]++type JoinFloat  = OutBind+type JoinFloats = OrdList JoinFloat++data FloatFlag+  = FltLifted   -- All bindings are lifted and lazy *or*+                --     consist of a single primitive string literal+                --  Hence ok to float to top level, or recursive++  | FltOkSpec   -- All bindings are FltLifted *or*+                --      strict (perhaps because unlifted,+                --      perhaps because of a strict binder),+                --        *and* ok-for-speculation+                --  Hence ok to float out of the RHS+                --  of a lazy non-recursive let binding+                --  (but not to top level, or into a rec group)++  | FltCareful  -- At least one binding is strict (or unlifted)+                --      and not guaranteed cheap+                --      Do not float these bindings out of a lazy let++instance Outputable LetFloats where+  ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds)++instance Outputable FloatFlag where+  ppr FltLifted  = text "FltLifted"+  ppr FltOkSpec  = text "FltOkSpec"+  ppr FltCareful = text "FltCareful"++andFF :: FloatFlag -> FloatFlag -> FloatFlag+andFF FltCareful _          = FltCareful+andFF FltOkSpec  FltCareful = FltCareful+andFF FltOkSpec  _          = FltOkSpec+andFF FltLifted  flt        = flt++doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool+-- If you change this function look also at FloatIn.noFloatFromRhs+doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs+  =  not (isNilOL fs) && want_to_float && can_float+  where+     want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs+                     -- See Note [Float when cheap or expandable]+     can_float = case ff of+                   FltLifted  -> True+                   FltOkSpec  -> isNotTopLevel lvl && isNonRec rec+                   FltCareful -> isNotTopLevel lvl && isNonRec rec && str++{-+Note [Float when cheap or expandable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to float a let from a let if the residual RHS is+   a) cheap, such as (\x. blah)+   b) expandable, such as (f b) if f is CONLIKE+But there are+  - cheap things that are not expandable (eg \x. expensive)+  - expandable things that are not cheap (eg (f b) where b is CONLIKE)+so we must take the 'or' of the two.+-}++emptyLetFloats :: LetFloats+emptyLetFloats = LetFloats nilOL FltLifted++emptyJoinFloats :: JoinFloats+emptyJoinFloats = nilOL++unitLetFloat :: OutBind -> LetFloats+-- This key function constructs a singleton float with the right form+unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))+                    LetFloats (unitOL bind) (flag bind)+  where+    flag (Rec {})                = FltLifted+    flag (NonRec bndr rhs)+      | not (isStrictId bndr)    = FltLifted+      | exprIsTickedString rhs   = FltLifted+          -- String literals can be floated freely.+          -- See Note [Core top-level string literals] in GHC.Core.+      | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)+      | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )+                                   FltCareful+      -- Unlifted binders can only be let-bound if exprOkForSpeculation holds++unitJoinFloat :: OutBind -> JoinFloats+unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))+                     unitOL bind++mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)+-- Make a singleton SimplFloats, and+-- extend the incoming SimplEnv's in-scope set with its binders+-- These binders may already be in the in-scope set,+-- but may have by now been augmented with more IdInfo+mkFloatBind env bind+  = (floats, env { seInScope = in_scope' })+  where+    floats+      | isJoinBind bind+      = SimplFloats { sfLetFloats  = emptyLetFloats+                    , sfJoinFloats = unitJoinFloat bind+                    , sfInScope    = in_scope' }+      | otherwise+      = SimplFloats { sfLetFloats  = unitLetFloat bind+                    , sfJoinFloats = emptyJoinFloats+                    , sfInScope    = in_scope' }++    in_scope' = seInScope env `extendInScopeSetBind` bind++extendFloats :: SimplFloats -> OutBind -> SimplFloats+-- Add this binding to the floats, and extend the in-scope env too+extendFloats (SimplFloats { sfLetFloats  = floats+                          , sfJoinFloats = jfloats+                          , sfInScope    = in_scope })+             bind+  | isJoinBind bind+  = SimplFloats { sfInScope    = in_scope'+                , sfLetFloats  = floats+                , sfJoinFloats = jfloats' }+  | otherwise+  = SimplFloats { sfInScope    = in_scope'+                , sfLetFloats  = floats'+                , sfJoinFloats = jfloats }+  where+    in_scope' = in_scope `extendInScopeSetBind` bind+    floats'   = floats  `addLetFlts`  unitLetFloat bind+    jfloats'  = jfloats `addJoinFlts` unitJoinFloat bind++addLetFloats :: SimplFloats -> LetFloats -> SimplFloats+-- Add the let-floats for env2 to env1;+-- *plus* the in-scope set for env2, which is bigger+-- than that for env1+addLetFloats floats let_floats@(LetFloats binds _)+  = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats+           , sfInScope   = foldlOL extendInScopeSetBind+                                   (sfInScope floats) binds }++addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats+addJoinFloats floats join_floats+  = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats+           , sfInScope    = foldlOL extendInScopeSetBind+                                    (sfInScope floats) join_floats }++extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet+extendInScopeSetBind in_scope bind+  = extendInScopeSetList in_scope (bindersOf bind)++addFloats :: SimplFloats -> SimplFloats -> SimplFloats+-- Add both let-floats and join-floats for env2 to env1;+-- *plus* the in-scope set for env2, which is bigger+-- than that for env1+addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 })+          (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope })+  = SimplFloats { sfLetFloats  = lf1 `addLetFlts` lf2+                , sfJoinFloats = jf1 `addJoinFlts` jf2+                , sfInScope    = in_scope }++addLetFlts :: LetFloats -> LetFloats -> LetFloats+addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2)+  = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2)++letFloatBinds :: LetFloats -> [CoreBind]+letFloatBinds (LetFloats bs _) = fromOL bs++addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats+addJoinFlts = appOL++mkRecFloats :: SimplFloats -> SimplFloats+-- Flattens the floats from env2 into a single Rec group,+-- They must either all be lifted LetFloats or all JoinFloats+mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs ff+                                , sfJoinFloats = jbs+                                , sfInScope    = in_scope })+  = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )+    ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )+    SimplFloats { sfLetFloats  = floats'+                , sfJoinFloats = jfloats'+                , sfInScope    = in_scope }+  where+    floats'  | isNilOL bs  = emptyLetFloats+             | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))+    jfloats' | isNilOL jbs = emptyJoinFloats+             | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))++wrapFloats :: SimplFloats -> OutExpr -> OutExpr+-- Wrap the floats around the expression; they should all+-- satisfy the let/app invariant, so mkLets should do the job just fine+wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs _+                        , sfJoinFloats = jbs }) body+  = foldrOL Let (wrapJoinFloats jbs body) bs+     -- Note: Always safe to put the joins on the inside+     -- since the values can't refer to them++wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr)+-- Wrap the sfJoinFloats of the env around the expression,+-- and take them out of the SimplEnv+wrapJoinFloatsX floats body+  = ( floats { sfJoinFloats = emptyJoinFloats }+    , wrapJoinFloats (sfJoinFloats floats) body )++wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr+-- Wrap the sfJoinFloats of the env around the expression,+-- and take them out of the SimplEnv+wrapJoinFloats join_floats body+  = foldrOL Let body join_floats++getTopFloatBinds :: SimplFloats -> [CoreBind]+getTopFloatBinds (SimplFloats { sfLetFloats  = lbs+                              , sfJoinFloats = jbs})+  = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings+    letFloatBinds lbs++mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats+mapLetFloats (LetFloats fs ff) fun+   = LetFloats (mapOL app fs) ff+   where+    app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'+    app (Rec bs)     = Rec (map fun bs)++{-+************************************************************************+*                                                                      *+                Substitution of Vars+*                                                                      *+************************************************************************++Note [Global Ids in the substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We look up even a global (eg imported) Id in the substitution. Consider+   case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }+The binder-swap in the occurrence analyser will add a binding+for a LocalId version of g (with the same unique though):+   case X.g_34 of b { (a,b) ->  let g_34 = b in+                                ... case X.g_34 of { (p,q) -> ...} ... }+So we want to look up the inner X.g_34 in the substitution, where we'll+find that it has been substituted by b.  (Or conceivably cloned.)+-}++substId :: SimplEnv -> InId -> SimplSR+-- Returns DoneEx only on a non-Var expression+substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v+  = case lookupVarEnv ids v of  -- Note [Global Ids in the substitution]+        Nothing               -> DoneId (refineFromInScope in_scope v)+        Just (DoneId v)       -> DoneId (refineFromInScope in_scope v)+        Just res              -> res    -- DoneEx non-var, or ContEx++        -- Get the most up-to-date thing from the in-scope set+        -- Even though it isn't in the substitution, it may be in+        -- the in-scope set with better IdInfo.+        --+        -- See also Note [In-scope set as a substitution] in GHC.Core.Op.Simplify.++refineFromInScope :: InScopeSet -> Var -> Var+refineFromInScope in_scope v+  | isLocalId v = case lookupInScope in_scope v of+                  Just v' -> v'+                  Nothing -> WARN( True, ppr v ) v  -- This is an error!+  | otherwise = v++lookupRecBndr :: SimplEnv -> InId -> OutId+-- Look up an Id which has been put into the envt by simplRecBndrs,+-- but where we have not yet done its RHS+lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v+  = case lookupVarEnv ids v of+        Just (DoneId v) -> v+        Just _ -> pprPanic "lookupRecBndr" (ppr v)+        Nothing -> refineFromInScope in_scope v++{-+************************************************************************+*                                                                      *+\section{Substituting an Id binder}+*                                                                      *+************************************************************************+++These functions are in the monad only so that they can be made strict via seq.++Note [Return type for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++   (join j :: Char -> Int -> Int) 77+   (     j x = \y. y + ord x    )+   (in case v of                )+   (     A -> j 'x'             )+   (     B -> j 'y'             )+   (     C -> <blah>            )++The simplifier pushes the "apply to 77" continuation inwards to give++   join j :: Char -> Int+        j x = (\y. y + ord x) 77+   in case v of+        A -> j 'x'+        B -> j 'y'+        C -> <blah> 77++Notice that the "apply to 77" continuation went into the RHS of the+join point.  And that meant that the return type of the join point+changed!!++That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr+takes a (Just res_ty) argument so that it knows to do the type-changing+thing.+-}++simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])+simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs++-------------+simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- Used for lambda and case-bound variables+-- Clone Id if necessary, substitute type+-- Return with IdInfo already substituted, but (fragile) occurrence info zapped+-- The substitution is extended only if the variable is cloned, because+-- we *don't* need to use it to track occurrence info.+simplBinder env bndr+  | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr+                        ; seqTyVar tv `seq` return (env', tv) }+  | otherwise     = do  { let (env', id) = substIdBndr Nothing env bndr+                        ; seqId id `seq` return (env', id) }++---------------+simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- A non-recursive let binder+simplNonRecBndr env id+  = do  { let (env1, id1) = substIdBndr Nothing env id+        ; seqId id1 `seq` return (env1, id1) }++---------------+simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr+                    -> SimplM (SimplEnv, OutBndr)+-- A non-recursive let binder for a join point;+-- context being pushed inward may change the type+-- See Note [Return type for join points]+simplNonRecJoinBndr env res_ty id+  = do  { let (env1, id1) = substIdBndr (Just res_ty) env id+        ; seqId id1 `seq` return (env1, id1) }++---------------+simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv+-- Recursive let binders+simplRecBndrs env@(SimplEnv {}) ids+  = ASSERT(all (not . isJoinId) ids)+    do  { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids+        ; seqIds ids1 `seq` return env1 }++---------------+simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv+-- Recursive let binders for join points;+-- context being pushed inward may change types+-- See Note [Return type for join points]+simplRecJoinBndrs env@(SimplEnv {}) res_ty ids+  = ASSERT(all isJoinId ids)+    do  { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids+        ; seqIds ids1 `seq` return env1 }++---------------+substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr)+-- Might be a coercion variable+substIdBndr new_res_ty env bndr+  | isCoVar bndr  = substCoVarBndr env bndr+  | otherwise     = substNonCoVarIdBndr new_res_ty env bndr++---------------+substNonCoVarIdBndr+   :: Maybe OutType -- New result type, if a join binder+                    -- See Note [Return type for join points]+   -> SimplEnv+   -> InBndr    -- Env and binder to transform+   -> (SimplEnv, OutBndr)+-- Clone Id if necessary, substitute its type+-- Return an Id with its+--      * Type substituted+--      * UnfoldingInfo, Rules, WorkerInfo zapped+--      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]+--      * Robust info, retained especially arity and demand info,+--         so that they are available to occurrences that occur in an+--         earlier binding of a letrec+--+-- For the robust info, see Note [Arity robustness]+--+-- Augment the substitution  if the unique changed+-- Extend the in-scope set with the new Id+--+-- Similar to GHC.Core.Subst.substIdBndr, except that+--      the type of id_subst differs+--      all fragile info is zapped+substNonCoVarIdBndr new_res_ty+                    env@(SimplEnv { seInScope = in_scope+                                  , seIdSubst = id_subst })+                    old_id+  = ASSERT2( not (isCoVar old_id), ppr old_id )+    (env { seInScope = in_scope `extendInScopeSet` new_id,+           seIdSubst = new_subst }, new_id)+  where+    id1    = uniqAway in_scope old_id+    id2    = substIdType env id1++    id3    | Just res_ty <- new_res_ty+           = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2)+                             -- See Note [Return type for join points]+           | otherwise+           = id2++    new_id = zapFragileIdInfo id3       -- Zaps rules, worker-info, unfolding+                                        -- and fragile OccInfo++        -- Extend the substitution if the unique has changed,+        -- or there's some useful occurrence information+        -- See the notes with substTyVarBndr for the delSubstEnv+    new_subst | new_id /= old_id+              = extendVarEnv id_subst old_id (DoneId new_id)+              | otherwise+              = delVarEnv id_subst old_id++------------------------------------+seqTyVar :: TyVar -> ()+seqTyVar b = b `seq` ()++seqId :: Id -> ()+seqId id = seqType (idType id)  `seq`+           idInfo id            `seq`+           ()++seqIds :: [Id] -> ()+seqIds []       = ()+seqIds (id:ids) = seqId id `seq` seqIds ids++{-+Note [Arity robustness]+~~~~~~~~~~~~~~~~~~~~~~~+We *do* transfer the arity from from the in_id of a let binding to the+out_id.  This is important, so that the arity of an Id is visible in+its own RHS.  For example:+        f = \x. ....g (\y. f y)....+We can eta-reduce the arg to g, because f is a value.  But that+needs to be visible.++This interacts with the 'state hack' too:+        f :: Bool -> IO Int+        f = \x. case x of+                  True  -> f y+                  False -> \s -> ...+Can we eta-expand f?  Only if we see that f has arity 1, and then we+take advantage of the 'state hack' on the result of+(f y) :: State# -> (State#, Int) to expand the arity one more.++There is a disadvantage though.  Making the arity visible in the RHS+allows us to eta-reduce+        f = \x -> f x+to+        f = f+which technically is not sound.   This is very much a corner case, so+I'm not worried about it.  Another idea is to ensure that f's arity+never decreases; its arity started as 1, and we should never eta-reduce+below that.+++Note [Robust OccInfo]+~~~~~~~~~~~~~~~~~~~~~+It's important that we *do* retain the loop-breaker OccInfo, because+that's what stops the Id getting inlined infinitely, in the body of+the letrec.+-}+++{-+************************************************************************+*                                                                      *+                Impedance matching to type substitution+*                                                                      *+************************************************************************+-}++getTCvSubst :: SimplEnv -> TCvSubst+getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env+                      , seCvSubst = cv_env })+  = mkTCvSubst in_scope (tv_env, cv_env)++substTy :: SimplEnv -> Type -> Type+substTy env ty = Type.substTy (getTCvSubst env) ty++substTyVar :: SimplEnv -> TyVar -> Type+substTyVar env tv = Type.substTyVar (getTCvSubst env) tv++substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)+substTyVarBndr env tv+  = case Type.substTyVarBndr (getTCvSubst env) tv of+        (TCvSubst in_scope' tv_env' cv_env', tv')+           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')++substCoVar :: SimplEnv -> CoVar -> Coercion+substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv++substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)+substCoVarBndr env cv+  = case Coercion.substCoVarBndr (getTCvSubst env) cv of+        (TCvSubst in_scope' tv_env' cv_env', cv')+           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')++substCo :: SimplEnv -> Coercion -> Coercion+substCo env co = Coercion.substCo (getTCvSubst env) co++------------------+substIdType :: SimplEnv -> Id -> Id+substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id+  |  (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)+  || noFreeVarsOfType old_ty+  = id+  | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)+                -- The tyCoVarsOfType is cheaper than it looks+                -- because we cache the free tyvars of the type+                -- in a Note in the id's type itself+  where+    old_ty = idType id
+ compiler/GHC/Core/Op/Simplify/Monad.hs view
@@ -0,0 +1,252 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[GHC.Core.Op.Simplify.Monad]{The simplifier Monad}+-}++{-# LANGUAGE DeriveFunctor #-}+module GHC.Core.Op.Simplify.Monad (+        -- The monad+        SimplM,+        initSmpl, traceSmpl,+        getSimplRules, getFamEnvs,++        -- Unique supply+        MonadUnique(..), newId, newJoinId,++        -- Counting+        SimplCount, tick, freeTick, checkedTick,+        getSimplCount, zeroSimplCount, pprSimplCount,+        plusSimplCount, isZeroSimplCount+    ) where++import GhcPrelude++import GHC.Types.Var       ( Var, isId, mkLocalVar )+import GHC.Types.Name      ( mkSystemVarName )+import GHC.Types.Id        ( Id, mkSysLocalOrCoVar )+import GHC.Types.Id.Info   ( IdDetails(..), vanillaIdInfo, setArityInfo )+import GHC.Core.Type       ( Type, mkLamTypes )+import GHC.Core.FamInstEnv ( FamInstEnv )+import GHC.Core            ( RuleEnv(..) )+import GHC.Types.Unique.Supply+import GHC.Driver.Session+import GHC.Core.Op.Monad+import Outputable+import FastString+import MonadUtils+import ErrUtils as Err+import Util                ( count )+import Panic               (throwGhcExceptionIO, GhcException (..))+import GHC.Types.Basic     ( IntWithInf, treatZeroAsInf, mkIntWithInf )+import Control.Monad       ( ap )++{-+************************************************************************+*                                                                      *+\subsection{Monad plumbing}+*                                                                      *+************************************************************************++For the simplifier monad, we want to {\em thread} a unique supply and a counter.+(Command-line switches move around through the explicitly-passed SimplEnv.)+-}++newtype SimplM result+  =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much+                -> UniqSupply   -- We thread the unique supply because+                                -- constantly splitting it is rather expensive+                -> SimplCount+                -> IO (result, UniqSupply, SimplCount)}+  -- we only need IO here for dump output+    deriving (Functor)++data SimplTopEnv+  = STE { st_flags     :: DynFlags+        , st_max_ticks :: IntWithInf  -- Max #ticks in this simplifier run+        , st_rules     :: RuleEnv+        , st_fams      :: (FamInstEnv, FamInstEnv) }++initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)+         -> UniqSupply          -- No init count; set to 0+         -> Int                 -- Size of the bindings, used to limit+                                -- the number of ticks we allow+         -> SimplM a+         -> IO (a, SimplCount)++initSmpl dflags rules fam_envs us size m+  = do (result, _, count) <- unSM m env us (zeroSimplCount dflags)+       return (result, count)+  where+    env = STE { st_flags = dflags, st_rules = rules+              , st_max_ticks = computeMaxTicks dflags size+              , st_fams = fam_envs }++computeMaxTicks :: DynFlags -> Int -> IntWithInf+-- Compute the max simplifier ticks as+--     (base-size + pgm-size) * magic-multiplier * tick-factor/100+-- where+--    magic-multiplier is a constant that gives reasonable results+--    base-size is a constant to deal with size-zero programs+computeMaxTicks dflags size+  = treatZeroAsInf $+    fromInteger ((toInteger (size + base_size)+                  * toInteger (tick_factor * magic_multiplier))+          `div` 100)+  where+    tick_factor      = simplTickFactor dflags+    base_size        = 100+    magic_multiplier = 40+        -- MAGIC NUMBER, multiplies the simplTickFactor+        -- We can afford to be generous; this is really+        -- just checking for loops, and shouldn't usually fire+        -- A figure of 20 was too small: see #5539.++{-# INLINE thenSmpl #-}+{-# INLINE thenSmpl_ #-}+{-# INLINE returnSmpl #-}+++instance Applicative SimplM where+    pure  = returnSmpl+    (<*>) = ap+    (*>)  = thenSmpl_++instance Monad SimplM where+   (>>)   = (*>)+   (>>=)  = thenSmpl++returnSmpl :: a -> SimplM a+returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))++thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b++thenSmpl m k+  = SM $ \st_env us0 sc0 -> do+      (m_result, us1, sc1) <- unSM m st_env us0 sc0+      unSM (k m_result) st_env us1 sc1++thenSmpl_ m k+  = SM $ \st_env us0 sc0 -> do+      (_, us1, sc1) <- unSM m st_env us0 sc0+      unSM k st_env us1 sc1++-- TODO: this specializing is not allowed+-- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}+-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}+-- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}++traceSmpl :: String -> SDoc -> SimplM ()+traceSmpl herald doc+  = do { dflags <- getDynFlags+       ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"+           FormatText+           (hang (text herald) 2 doc) }++{-+************************************************************************+*                                                                      *+\subsection{The unique supply}+*                                                                      *+************************************************************************+-}++instance MonadUnique SimplM where+    getUniqueSupplyM+       = SM (\_st_env us sc -> case splitUniqSupply us of+                                (us1, us2) -> return (us1, us2, sc))++    getUniqueM+       = SM (\_st_env us sc -> case takeUniqFromSupply us of+                                (u, us') -> return (u, us', sc))++    getUniquesM+        = SM (\_st_env us sc -> case splitUniqSupply us of+                                (us1, us2) -> return (uniqsFromSupply us1, us2, sc))++instance HasDynFlags SimplM where+    getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))++instance MonadIO SimplM where+    liftIO m = SM $ \_ us sc -> do+      x <- m+      return (x, us, sc)++getSimplRules :: SimplM RuleEnv+getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))++getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)+getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))++newId :: FastString -> Type -> SimplM Id+newId fs ty = do uniq <- getUniqueM+                 return (mkSysLocalOrCoVar fs uniq ty)++newJoinId :: [Var] -> Type -> SimplM Id+newJoinId bndrs body_ty+  = do { uniq <- getUniqueM+       ; let name       = mkSystemVarName uniq (fsLit "$j")+             join_id_ty = mkLamTypes bndrs body_ty  -- Note [Funky mkLamTypes]+             arity      = count isId bndrs+             -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core+             join_arity = length bndrs+             details    = JoinId join_arity+             id_info    = vanillaIdInfo `setArityInfo` arity+--                                        `setOccInfo` strongLoopBreaker++       ; return (mkLocalVar details name join_id_ty id_info) }++{-+************************************************************************+*                                                                      *+\subsection{Counting up what we've done}+*                                                                      *+************************************************************************+-}++getSimplCount :: SimplM SimplCount+getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))++tick :: Tick -> SimplM ()+tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc+                              in sc' `seq` return ((), us, sc'))++checkedTick :: Tick -> SimplM ()+-- Try to take a tick, but fail if too many+checkedTick t+  = SM (\st_env us sc ->+           if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)+           then throwGhcExceptionIO $+                  PprProgramError "Simplifier ticks exhausted" (msg sc)+           else let sc' = doSimplTick (st_flags st_env) t sc+                in sc' `seq` return ((), us, sc'))+  where+    msg sc = vcat+      [ text "When trying" <+> ppr t+      , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."+      , space+      , text "If you need to increase the limit substantially, please file a"+      , text "bug report and indicate the factor you needed."+      , space+      , text "If GHC was unable to complete compilation even"+               <+> text "with a very large factor"+      , text "(a thousand or more), please consult the"+                <+> doubleQuotes (text "Known bugs or infelicities")+      , text "section in the Users Guide before filing a report. There are a"+      , text "few situations unlikely to occur in practical programs for which"+      , text "simplifier non-termination has been judged acceptable."+      , space+      , pp_details sc+      , pprSimplCount sc ]+    pp_details sc+      | hasDetailedCounts sc = empty+      | otherwise = text "To see detailed counts use -ddump-simpl-stats"+++freeTick :: Tick -> SimplM ()+-- Record a tick, but don't add to the total tick count, which is+-- used to decide when nothing further has happened+freeTick t+   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc+                           in sc' `seq` return ((), us, sc'))
+ compiler/GHC/Core/Op/Simplify/Utils.hs view
@@ -0,0 +1,2329 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++The simplifier utilities+-}++{-# LANGUAGE CPP #-}++module GHC.Core.Op.Simplify.Utils (+        -- Rebuilding+        mkLam, mkCase, prepareAlts, tryEtaExpandRhs,++        -- Inlining,+        preInlineUnconditionally, postInlineUnconditionally,+        activeUnfolding, activeRule,+        getUnfoldingInRuleMatch,+        simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,++        -- The continuation type+        SimplCont(..), DupFlag(..), StaticEnv,+        isSimplified, contIsStop,+        contIsDupable, contResultType, contHoleType,+        contIsTrivial, contArgs,+        countArgs,+        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,+        interestingCallContext,++        -- ArgInfo+        ArgInfo(..), ArgSpec(..), mkArgInfo,+        addValArgTo, addCastTo, addTyArgTo,+        argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,++        abstractFloats,++        -- Utilities+        isExitJoinId+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core.Op.Simplify.Env+import GHC.Core.Op.Monad        ( SimplMode(..), Tick(..) )+import GHC.Driver.Session+import GHC.Core+import qualified GHC.Core.Subst+import GHC.Core.Ppr+import GHC.Core.TyCo.Ppr ( pprParendType )+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.Arity+import GHC.Core.Unfold+import GHC.Types.Name+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Var+import GHC.Types.Demand+import GHC.Core.Op.Simplify.Monad+import GHC.Core.Type     hiding( substTy )+import GHC.Core.Coercion hiding( substCo )+import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )+import GHC.Types.Var.Set+import GHC.Types.Basic+import Util+import OrdList          ( isNilOL )+import MonadUtils+import Outputable+import GHC.Core.Op.ConstantFold+import FastString       ( fsLit )++import Control.Monad    ( when )+import Data.List        ( sortBy )++{-+************************************************************************+*                                                                      *+                The SimplCont and DupFlag types+*                                                                      *+************************************************************************++A SimplCont allows the simplifier to traverse the expression in a+zipper-like fashion.  The SimplCont represents the rest of the expression,+"above" the point of interest.++You can also think of a SimplCont as an "evaluation context", using+that term in the way it is used for operational semantics. This is the+way I usually think of it, For example you'll often see a syntax for+evaluation context looking like+        C ::= []  |  C e   |  case C of alts  |  C `cast` co+That's the kind of thing we are doing here, and I use that syntax in+the comments.+++Key points:+  * A SimplCont describes a *strict* context (just like+    evaluation contexts do).  E.g. Just [] is not a SimplCont++  * A SimplCont describes a context that *does not* bind+    any variables.  E.g. \x. [] is not a SimplCont+-}++data SimplCont+  = Stop                -- Stop[e] = e+        OutType         -- Type of the <hole>+        CallCtxt        -- Tells if there is something interesting about+                        --          the context, and hence the inliner+                        --          should be a bit keener (see interestingCallContext)+                        -- Specifically:+                        --     This is an argument of a function that has RULES+                        --     Inlining the call might allow the rule to fire+                        -- Never ValAppCxt (use ApplyToVal instead)+                        -- or CaseCtxt (use Select instead)++  | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]+        OutCoercion             -- The coercion simplified+                                -- Invariant: never an identity coercion+        SimplCont++  | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]+      { sc_dup  :: DupFlag      -- See Note [DupFlag invariants]+      , sc_arg  :: InExpr       -- The argument,+      , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]+      , sc_cont :: SimplCont }++  | 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]+      , sc_cont    :: SimplCont }++  | Select             -- (Select alts K)[e] = K[ case e of alts ]+      { sc_dup  :: DupFlag        -- See Note [DupFlag invariants]+      , sc_bndr :: InId           -- case binder+      , sc_alts :: [InAlt]        -- Alternatives+      , sc_env  :: StaticEnv      -- See Note [StaticEnv invariant]+      , sc_cont :: SimplCont }++  -- The two strict forms have no DupFlag, because we never duplicate them+  | StrictBind          -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b]+                        --       or, equivalently,  = K[ (\x xs.b) e ]+      { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]+      , sc_bndr  :: InId+      , sc_bndrs :: [InBndr]+      , sc_body  :: InExpr+      , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]+      , sc_cont  :: SimplCont }++  | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]+      { sc_dup  :: DupFlag     -- Always Simplified or OkToDup+      , sc_fun  :: ArgInfo     -- Specifies f, e1..en, Whether f has rules, etc+                               --     plus strictness flags for *further* args+      , sc_cci  :: CallCtxt    -- Whether *this* argument position is interesting+      , sc_cont :: SimplCont }++  | TickIt              -- (TickIt t K)[e] = K[ tick t e ]+        (Tickish Id)    -- Tick tickish <hole>+        SimplCont++type StaticEnv = SimplEnv       -- Just the static part is relevant++data DupFlag = NoDup       -- Unsimplified, might be big+             | Simplified  -- Simplified+             | OkToDup     -- Simplified and small++isSimplified :: DupFlag -> Bool+isSimplified NoDup = False+isSimplified _     = True       -- Invariant: the subst-env is empty++perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type+perhapsSubstTy dup env ty+  | isSimplified dup = ty+  | otherwise        = substTy env ty++{- Note [StaticEnv invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pair up an InExpr or InAlts with a StaticEnv, which establishes the+lexical scope for that InExpr.  When we simplify that InExpr/InAlts, we+use+  - Its captured StaticEnv+  - Overriding its InScopeSet with the larger one at the+    simplification point.++Why override the InScopeSet?  Example:+      (let y = ey in f) ex+By the time we simplify ex, 'y' will be in scope.++However the InScopeSet in the StaticEnv is not irrelevant: it should+include all the free vars of applying the substitution to the InExpr.+Reason: contHoleType uses perhapsSubstTy to apply the substitution to+the expression, and that (rightly) gives ASSERT failures if the InScopeSet+isn't big enough.++Note [DupFlag invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~+In both (ApplyToVal dup _ env k)+   and  (Select dup _ _ env k)+the following invariants hold++  (a) if dup = OkToDup, then continuation k is also ok-to-dup+  (b) if dup = OkToDup or Simplified, the subst-env is empty+      (and and hence no need to re-simplify)+-}++instance Outputable DupFlag where+  ppr OkToDup    = text "ok"+  ppr NoDup      = text "nodup"+  ppr Simplified = text "simpl"++instance Outputable SimplCont where+  ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty+  ppr (CastIt co cont  )    = (text "CastIt" <+> pprOptCo co) $$ ppr cont+  ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont+  ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })+    = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont+  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })+    = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)+                                        $$ ppr cont+  ppr (StrictBind { sc_bndr = b, sc_cont = cont })+    = (text "StrictBind" <+> ppr b) $$ ppr cont+  ppr (StrictArg { sc_fun = ai, sc_cont = cont })+    = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont+  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })+    = (text "Select" <+> ppr dup <+> ppr bndr) $$+       whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont+++{- Note [The hole type in ApplyToTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_hole_ty field of ApplyToTy records the type of the "hole" in the+continuation.  It is absolutely necessary to compute contHoleType, but it is+not used for anything else (and hence may not be evaluated).++Why is it necessary for contHoleType?  Consider the continuation+     ApplyToType Int (Stop Int)+corresponding to+     (<hole> @Int) :: Int+What is the type of <hole>?  It could be (forall a. Int) or (forall a. a),+and there is no way to know which, so we must record it.++In a chain of applications  (f @t1 @t2 @t3) we'll lazily compute exprType+for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably+doesn't matter because we'll never compute them all.++************************************************************************+*                                                                      *+                ArgInfo and ArgSpec+*                                                                      *+************************************************************************+-}++data ArgInfo+  = ArgInfo {+        ai_fun   :: OutId,      -- The function+        ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)++        ai_type  :: OutType,    -- Type of (f a1 ... an)++        ai_rules :: FunRules,   -- Rules for this function++        ai_encl :: Bool,        -- Flag saying whether this function+                                -- or an enclosing one has rules (recursively)+                                --      True => be keener to inline in all args++        ai_strs :: [Bool],      -- Strictness of remaining arguments+                                --   Usually infinite, but if it is finite it guarantees+                                --   that the function diverges after being given+                                --   that number of args+        ai_discs :: [Int]       -- Discounts for remaining arguments; non-zero => be keener to inline+                                --   Always infinite+    }++data ArgSpec+  = ValArg OutExpr                    -- Apply to this (coercion or value); c.f. ApplyToVal+  | TyArg { as_arg_ty  :: OutType     -- Apply to this type; c.f. ApplyToTy+          , as_hole_ty :: OutType }   -- Type of the function (presumably forall a. blah)+  | CastBy OutCoercion                -- Cast by this; c.f. CastIt++instance Outputable ArgSpec where+  ppr (ValArg e)                 = text "ValArg" <+> ppr e+  ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty+  ppr (CastBy c)                 = text "CastBy" <+> ppr c++addValArgTo :: ArgInfo -> OutExpr -> ArgInfo+addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai+                        , ai_type = applyTypeToArg (ai_type ai) arg+                        , ai_rules = decRules (ai_rules ai) }++addTyArgTo :: ArgInfo -> OutType -> ArgInfo+addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai+                          , ai_type = piResultTy poly_fun_ty arg_ty+                          , ai_rules = decRules (ai_rules ai) }+  where+    poly_fun_ty = ai_type ai+    arg_spec    = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty }++addCastTo :: ArgInfo -> OutCoercion -> ArgInfo+addCastTo ai co = ai { ai_args = CastBy co : ai_args ai+                     , ai_type = coercionRKind co }++argInfoAppArgs :: [ArgSpec] -> [OutExpr]+argInfoAppArgs []                              = []+argInfoAppArgs (CastBy {}                : _)  = []  -- Stop at a cast+argInfoAppArgs (ValArg e                 : as) = e       : argInfoAppArgs as+argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as++pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont+pushSimplifiedArgs _env []           k = k+pushSimplifiedArgs env  (arg : args) k+  = case arg of+      TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }+               -> ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }+      ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest }+      CastBy c -> CastIt c rest+  where+    rest = pushSimplifiedArgs env args k+           -- The env has an empty SubstEnv++argInfoExpr :: OutId -> [ArgSpec] -> OutExpr+-- NB: the [ArgSpec] is reversed so that the first arg+-- in the list is the last one in the application+argInfoExpr fun rev_args+  = go rev_args+  where+    go []                              = Var fun+    go (ValArg a                 : as) = go as `App` a+    go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty+    go (CastBy co                : as) = mkCast (go as) co+++type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function+     -- Nothing => No rules+     -- Just (n, rules) => some rules, requiring at least n more type/value args++decRules :: FunRules -> FunRules+decRules (Just (n, rules)) = Just (n-1, rules)+decRules Nothing           = Nothing++mkFunRules :: [CoreRule] -> FunRules+mkFunRules [] = Nothing+mkFunRules rs = Just (n_required, rs)+  where+    n_required = maximum (map ruleArity rs)++{-+************************************************************************+*                                                                      *+                Functions on SimplCont+*                                                                      *+************************************************************************+-}++mkBoringStop :: OutType -> SimplCont+mkBoringStop ty = Stop ty BoringCtxt++mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in GHC.Core.Unfold+mkRhsStop ty = Stop ty RhsCtxt++mkLazyArgStop :: OutType -> CallCtxt -> SimplCont+mkLazyArgStop ty cci = Stop ty cci++-------------------+contIsRhsOrArg :: SimplCont -> Bool+contIsRhsOrArg (Stop {})       = True+contIsRhsOrArg (StrictBind {}) = True+contIsRhsOrArg (StrictArg {})  = True+contIsRhsOrArg _               = False++contIsRhs :: SimplCont -> Bool+contIsRhs (Stop _ RhsCtxt) = True+contIsRhs _                = False++-------------------+contIsStop :: SimplCont -> Bool+contIsStop (Stop {}) = True+contIsStop _         = False++contIsDupable :: SimplCont -> Bool+contIsDupable (Stop {})                         = True+contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k+contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]+contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto...+contIsDupable (StrictArg { sc_dup = OkToDup })  = True -- ...ditto...+contIsDupable (CastIt _ k)                      = contIsDupable k+contIsDupable _                                 = False++-------------------+contIsTrivial :: SimplCont -> Bool+contIsTrivial (Stop {})                                         = True+contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k+contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k+contIsTrivial (CastIt _ k)                                      = contIsTrivial k+contIsTrivial _                                                 = False++-------------------+contResultType :: SimplCont -> OutType+contResultType (Stop ty _)                  = ty+contResultType (CastIt _ k)                 = contResultType k+contResultType (StrictBind { sc_cont = k }) = contResultType k+contResultType (StrictArg { sc_cont = k })  = contResultType k+contResultType (Select { sc_cont = k })     = contResultType k+contResultType (ApplyToTy  { sc_cont = k }) = contResultType k+contResultType (ApplyToVal { sc_cont = k }) = contResultType k+contResultType (TickIt _ k)                 = contResultType k++contHoleType :: SimplCont -> OutType+contHoleType (Stop ty _)                      = ty+contHoleType (TickIt _ k)                     = contHoleType k+contHoleType (CastIt co _)                    = coercionLKind co+contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })+  = perhapsSubstTy dup se (idType b)+contHoleType (StrictArg { sc_fun = ai })      = funArgTy (ai_type ai)+contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]+contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k })+  = mkVisFunTy (perhapsSubstTy dup se (exprType e))+               (contHoleType k)+contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })+  = perhapsSubstTy d se (idType b)++-------------------+countArgs :: SimplCont -> Int+-- Count all arguments, including types, coercions, and other values+countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont+countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont+countArgs _                               = 0++contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)+-- Summarises value args, discards type args and coercions+-- The returned continuation of the call is only used to+-- answer questions like "are you interesting?"+contArgs cont+  | lone cont = (True, [], cont)+  | otherwise = go [] cont+  where+    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in GHC.Core.Unfold+    lone (ApplyToVal {}) = False+    lone (CastIt {})     = False+    lone _               = True++    go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })+                                        = go (is_interesting arg se : args) k+    go args (ApplyToTy { sc_cont = k }) = go args k+    go args (CastIt _ k)                = go args k+    go args k                           = (False, reverse args, k)++    is_interesting arg se = interestingArg se arg+                   -- Do *not* use short-cutting substitution here+                   -- because we want to get as much IdInfo as possible+++-------------------+mkArgInfo :: SimplEnv+          -> Id+          -> [CoreRule] -- Rules for function+          -> Int        -- Number of value args+          -> SimplCont  -- Context of the call+          -> ArgInfo++mkArgInfo env fun rules n_val_args call_cont+  | n_val_args < idArity fun            -- Note [Unsaturated functions]+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty+            , ai_rules = fun_rules+            , ai_encl = False+            , ai_strs = vanilla_stricts+            , ai_discs = vanilla_discounts }+  | otherwise+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty+            , ai_rules = fun_rules+            , ai_encl  = interestingArgContext rules call_cont+            , ai_strs  = arg_stricts+            , ai_discs = arg_discounts }+  where+    fun_ty = idType fun++    fun_rules = mkFunRules rules++    vanilla_discounts, arg_discounts :: [Int]+    vanilla_discounts = repeat 0+    arg_discounts = case idUnfolding fun of+                        CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}+                              -> discounts ++ vanilla_discounts+                        _     -> vanilla_discounts++    vanilla_stricts, arg_stricts :: [Bool]+    vanilla_stricts  = repeat False++    arg_stricts+      | not (sm_inline (seMode env))+      = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False]+      | otherwise+      = add_type_str fun_ty $+        case splitStrictSig (idStrictness fun) of+          (demands, result_info)+                | not (demands `lengthExceeds` n_val_args)+                ->      -- Enough args, use the strictness given.+                        -- For bottoming functions we used to pretend that the arg+                        -- is lazy, so that we don't treat the arg as an+                        -- interesting context.  This avoids substituting+                        -- top-level bindings for (say) strings into+                        -- calls to error.  But now we are more careful about+                        -- inlining lone variables, so it's ok+                        -- (see GHC.Core.Op.Simplify.Utils.analyseCont)+                   if isBotDiv result_info then+                        map isStrictDmd demands         -- Finite => result is bottom+                   else+                        map isStrictDmd demands ++ vanilla_stricts+               | otherwise+               -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)+                                <+> ppr n_val_args <+> ppr demands )+                   vanilla_stricts      -- Not enough args, or no strictness++    add_type_str :: Type -> [Bool] -> [Bool]+    -- If the function arg types are strict, record that in the 'strictness bits'+    -- No need to instantiate because unboxed types (which dominate the strict+    --   types) can't instantiate type variables.+    -- add_type_str is done repeatedly (for each call);+    --   might be better once-for-all in the function+    -- But beware primops/datacons with no strictness++    add_type_str _ [] = []+    add_type_str fun_ty all_strs@(str:strs)+      | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info+      = (str || Just False == isLiftedType_maybe arg_ty)+        : add_type_str fun_ty' strs+          -- If the type is levity-polymorphic, we can't know whether it's+          -- strict. isLiftedType_maybe will return Just False only when+          -- we're sure the type is unlifted.++      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty+      = add_type_str fun_ty' all_strs     -- Look through foralls++      | otherwise+      = all_strs++{- Note [Unsaturated functions]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (test eyeball/inline4)+        x = a:as+        y = f x+where f has arity 2.  Then we do not want to inline 'x', because+it'll just be floated out again.  Even if f has lots of discounts+on its first argument -- it must be saturated for these to kick in++Note [Do not expose strictness if sm_inline=False]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+#15163 showed a case in which we had++  {-# INLINE [1] zip #-}+  zip = undefined++  {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}++If we expose zip's bottoming nature when simplifying the LHS of the+RULE we get+  {-# RULES "foo" forall as bs.+                   stream (case zip of {}) = ..blah... #-}+discarding the arguments to zip.  Usually this is fine, but on the+LHS of a rule it's not, because 'as' and 'bs' are now not bound on+the LHS.++This is a pretty pathological example, so I'm not losing sleep over+it, but the simplest solution was to check sm_inline; if it is False,+which it is on the LHS of a rule (see updModeForRules), then don't+make use of the strictness info for the function.+-}+++{-+************************************************************************+*                                                                      *+        Interesting arguments+*                                                                      *+************************************************************************++Note [Interesting call context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to avoid inlining an expression where there can't possibly be+any gain, such as in an argument position.  Hence, if the continuation+is interesting (eg. a case scrutinee, application etc.) then we+inline, otherwise we don't.++Previously some_benefit used to return True only if the variable was+applied to some value arguments.  This didn't work:++        let x = _coerce_ (T Int) Int (I# 3) in+        case _coerce_ Int (T Int) x of+                I# y -> ....++we want to inline x, but can't see that it's a constructor in a case+scrutinee position, and some_benefit is False.++Another example:++dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)++....  case dMonadST _@_ x0 of (a,b,c) -> ....++we'd really like to inline dMonadST here, but we *don't* want to+inline if the case expression is just++        case x of y { DEFAULT -> ... }++since we can just eliminate this case instead (x is in WHNF).  Similar+applies when x is bound to a lambda expression.  Hence+contIsInteresting looks for case expressions with just a single+default case.++Note [No case of case is boring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see+   case f x of <alts>++we'd usually treat the context as interesting, to encourage 'f' to+inline.  But if case-of-case is off, it's really not so interesting+after all, because we are unlikely to be able to push the case+expression into the branches of any case in f's unfolding.  So, to+reduce unnecessary code expansion, we just make the context look boring.+This made a small compile-time perf improvement in perf/compiler/T6048,+and it looks plausible to me.+-}++interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt+-- See Note [Interesting call context]+interestingCallContext env cont+  = interesting cont+  where+    interesting (Select {})+       | sm_case_case (getMode env) = CaseCtxt+       | otherwise                  = BoringCtxt+       -- See Note [No case of case is boring]++    interesting (ApplyToVal {}) = ValAppCtxt+        -- Can happen if we have (f Int |> co) y+        -- If f has an INLINE prag we need to give it some+        -- motivation to inline. See Note [Cast then apply]+        -- in GHC.Core.Unfold++    interesting (StrictArg { sc_cci = cci }) = cci+    interesting (StrictBind {})              = BoringCtxt+    interesting (Stop _ cci)                 = cci+    interesting (TickIt _ k)                 = interesting k+    interesting (ApplyToTy { sc_cont = k })  = interesting k+    interesting (CastIt _ k)                 = interesting k+        -- If this call is the arg of a strict function, the context+        -- is a bit interesting.  If we inline here, we may get useful+        -- evaluation information to avoid repeated evals: e.g.+        --      x + (y * z)+        -- Here the contIsInteresting makes the '*' keener to inline,+        -- which in turn exposes a constructor which makes the '+' inline.+        -- Assuming that +,* aren't small enough to inline regardless.+        --+        -- It's also very important to inline in a strict context for things+        -- like+        --              foldr k z (f x)+        -- Here, the context of (f x) is strict, and if f's unfolding is+        -- a build it's *great* to inline it here.  So we must ensure that+        -- the context for (f x) is not totally uninteresting.++interestingArgContext :: [CoreRule] -> SimplCont -> Bool+-- If the argument has form (f x y), where x,y are boring,+-- and f is marked INLINE, then we don't want to inline f.+-- But if the context of the argument is+--      g (f x y)+-- where g has rules, then we *do* want to inline f, in case it+-- exposes a rule that might fire.  Similarly, if the context is+--      h (g (f x x))+-- where h has rules, then we do want to inline f; hence the+-- call_cont argument to interestingArgContext+--+-- The ai-rules flag makes this happen; if it's+-- set, the inliner gets just enough keener to inline f+-- regardless of how boring f's arguments are, if it's marked INLINE+--+-- The alternative would be to *always* inline an INLINE function,+-- regardless of how boring its context is; but that seems overkill+-- For example, it'd mean that wrapper functions were always inlined+--+-- The call_cont passed to interestingArgContext is the context of+-- the call itself, e.g. g <hole> in the example above+interestingArgContext rules call_cont+  = notNull rules || enclosing_fn_has_rules+  where+    enclosing_fn_has_rules = go call_cont++    go (Select {})                  = False+    go (ApplyToVal {})              = False  -- Shouldn't really happen+    go (ApplyToTy  {})              = False  -- Ditto+    go (StrictArg { sc_cci = cci }) = interesting cci+    go (StrictBind {})              = False      -- ??+    go (CastIt _ c)                 = go c+    go (Stop _ cci)                 = interesting cci+    go (TickIt _ c)                 = go c++    interesting RuleArgCtxt = True+    interesting _           = False+++{- Note [Interesting arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An argument is interesting if it deserves a discount for unfoldings+with a discount in that argument position.  The idea is to avoid+unfolding a function that is applied only to variables that have no+unfolding (i.e. they are probably lambda bound): f x y z There is+little point in inlining f here.++Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But+we must look through lets, eg (let x = e in C a b), because the let will+float, exposing the value, if we inline.  That makes it different to+exprIsHNF.++Before 2009 we said it was interesting if the argument had *any* structure+at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see #3016.++But we don't regard (f x y) as interesting, unless f is unsaturated.+If it's saturated and f hasn't inlined, then it's probably not going+to now!++Note [Conlike is interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        f d = ...((*) d x y)...+        ... f (df d')...+where df is con-like. Then we'd really like to inline 'f' so that the+rule for (*) (df d) can fire.  To do this+  a) we give a discount for being an argument of a class-op (eg (*) d)+  b) we say that a con-like argument (eg (df d)) is interesting+-}++interestingArg :: SimplEnv -> CoreExpr -> ArgSummary+-- See Note [Interesting arguments]+interestingArg env e = go env 0 e+  where+    -- n is # value args to which the expression is applied+    go env n (Var v)+       = case substId env v of+           DoneId v'            -> go_var n v'+           DoneEx e _           -> go (zapSubstEnv env)             n e+           ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e++    go _   _ (Lit {})          = ValueArg+    go _   _ (Type _)          = TrivArg+    go _   _ (Coercion _)      = TrivArg+    go env n (App fn (Type _)) = go env n fn+    go env n (App fn _)        = go env (n+1) fn+    go env n (Tick _ a)        = go env n a+    go env n (Cast e _)        = go env n e+    go env n (Lam v e)+       | isTyVar v             = go env n e+       | n>0                   = NonTrivArg     -- (\x.b) e   is NonTriv+       | otherwise             = ValueArg+    go _ _ (Case {})           = NonTrivArg+    go env n (Let b e)         = case go env' n e of+                                   ValueArg -> ValueArg+                                   _        -> NonTrivArg+                               where+                                 env' = env `addNewInScopeIds` bindersOf b++    go_var n v+       | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that+                                        --    data constructors here+       | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding+       | n > 0             = NonTrivArg -- Saturated or unknown call+       | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding+                                        -- See Note [Conlike is interesting]+       | otherwise         = TrivArg    -- n==0, no useful unfolding+       where+         conlike_unfolding = isConLikeUnfolding (idUnfolding v)++{-+************************************************************************+*                                                                      *+                  SimplMode+*                                                                      *+************************************************************************++The SimplMode controls several switches; see its definition in+GHC.Core.Op.Monad+        sm_rules      :: Bool     -- Whether RULES are enabled+        sm_inline     :: Bool     -- Whether inlining is enabled+        sm_case_case  :: Bool     -- Whether case-of-case is enabled+        sm_eta_expand :: Bool     -- Whether eta-expansion is enabled+-}++simplEnvForGHCi :: DynFlags -> SimplEnv+simplEnvForGHCi dflags+  = mkSimplEnv $ SimplMode { sm_names  = ["GHCi"]+                           , sm_phase  = InitialPhase+                           , sm_dflags = dflags+                           , sm_rules  = rules_on+                           , sm_inline = False+                           , sm_eta_expand = eta_expand_on+                           , sm_case_case  = True }+  where+    rules_on      = gopt Opt_EnableRewriteRules   dflags+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags+   -- Do not do any inlining, in case we expose some unboxed+   -- tuple stuff that confuses the bytecode interpreter++updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode+-- See Note [Simplifying inside stable unfoldings]+updModeForStableUnfoldings inline_rule_act current_mode+  = current_mode { sm_phase      = phaseFromActivation inline_rule_act+                 , sm_inline     = True+                 , sm_eta_expand = False }+                     -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]+       -- For sm_rules, just inherit; sm_rules might be "off"+       -- because of -fno-enable-rewrite-rules+  where+    phaseFromActivation (ActiveAfter _ n) = Phase n+    phaseFromActivation _                 = InitialPhase++updModeForRules :: SimplMode -> SimplMode+-- See Note [Simplifying rules]+updModeForRules current_mode+  = current_mode { sm_phase      = InitialPhase+                 , sm_inline     = False  -- See Note [Do not expose strictness if sm_inline=False]+                 , sm_rules      = False+                 , sm_eta_expand = False }++{- Note [Simplifying rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When simplifying a rule LHS, refrain from /any/ inlining or applying+of other RULES.++Doing anything to the LHS is plain confusing, because it means that what the+rule matches is not what the user wrote. c.f. #10595, and #10528.+Moreover, inlining (or applying rules) on rule LHSs risks introducing+Ticks into the LHS, which makes matching trickier. #10665, #10745.++Doing this to either side confounds tools like HERMIT, which seek to reason+about and apply the RULES as originally written. See #10829.++Note [No eta expansion in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a stable unfolding++  f :: Ord a => a -> IO ()+  -- Unfolding template+  --    = /\a \(d:Ord a) (x:a). bla++we do not want to eta-expand to++  f :: Ord a => a -> IO ()+  -- Unfolding template+  --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co++because not specialisation of the overloading doesn't work properly+(see Note [Specialisation shape] in GHC.Core.Op.Specialise), #9509.++So we disable eta-expansion in stable unfoldings.++Note [Inlining in gentle mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Something is inlined if+   (i)   the sm_inline flag is on, AND+   (ii)  the thing has an INLINE pragma, AND+   (iii) the thing is inlinable in the earliest phase.++Example of why (iii) is important:+  {-# INLINE [~1] g #-}+  g = ...++  {-# INLINE f #-}+  f x = g (g x)++If we were to inline g into f's inlining, then an importing module would+never be able to do+        f e --> g (g e) ---> RULE fires+because the stable unfolding for f has had g inlined into it.++On the other hand, it is bad not to do ANY inlining into an+stable unfolding, because then recursive knots in instance declarations+don't get unravelled.++However, *sometimes* SimplGently must do no call-site inlining at all+(hence sm_inline = False).  Before full laziness we must be careful+not to inline wrappers, because doing so inhibits floating+    e.g. ...(case f x of ...)...+    ==> ...(case (case x of I# x# -> fw x#) of ...)...+    ==> ...(case x of I# x# -> case fw x# of ...)...+and now the redex (f x) isn't floatable any more.++The no-inlining thing is also important for Template Haskell.  You might be+compiling in one-shot mode with -O2; but when TH compiles a splice before+running it, we don't want to use -O2.  Indeed, we don't want to inline+anything, because the byte-code interpreter might get confused about+unboxed tuples and suchlike.++Note [Simplifying inside stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must take care with simplification inside stable unfoldings (which come from+INLINE pragmas).++First, consider the following example+        let f = \pq -> BIG+        in+        let g = \y -> f y y+            {-# INLINE g #-}+        in ...g...g...g...g...g...+Now, if that's the ONLY occurrence of f, it might be inlined inside g,+and thence copied multiple times when g is inlined. HENCE we treat+any occurrence in a stable unfolding as a multiple occurrence, not a single+one; see OccurAnal.addRuleUsage.++Second, we do want *do* to some modest rules/inlining stuff in stable+unfoldings, partly to eliminate senseless crap, and partly to break+the recursive knots generated by instance declarations.++However, suppose we have+        {-# INLINE <act> f #-}+        f = <rhs>+meaning "inline f in phases p where activation <act>(p) holds".+Then what inlinings/rules can we apply to the copy of <rhs> captured in+f's stable unfolding?  Our model is that literally <rhs> is substituted for+f when it is inlined.  So our conservative plan (implemented by+updModeForStableUnfoldings) is this:++  -------------------------------------------------------------+  When simplifying the RHS of a stable unfolding, set the phase+  to the phase in which the stable unfolding first becomes active+  -------------------------------------------------------------++That ensures that++  a) Rules/inlinings that *cease* being active before p will+     not apply to the stable unfolding, consistent with it being+     inlined in its *original* form in phase p.++  b) Rules/inlinings that only become active *after* p will+     not apply to the stable unfolding, again to be consistent with+     inlining the *original* rhs in phase p.++For example,+        {-# INLINE f #-}+        f x = ...g...++        {-# NOINLINE [1] g #-}+        g y = ...++        {-# RULE h g = ... #-}+Here we must not inline g into f's RHS, even when we get to phase 0,+because when f is later inlined into some other module we want the+rule for h to fire.++Similarly, consider+        {-# INLINE f #-}+        f x = ...g...++        g y = ...+and suppose that there are auto-generated specialisations and a strictness+wrapper for g.  The specialisations get activation AlwaysActive, and the+strictness wrapper get activation (ActiveAfter 0).  So the strictness+wrepper fails the test and won't be inlined into f's stable unfolding. That+means f can inline, expose the specialised call to g, so the specialisation+rules can fire.++A note about wrappers+~~~~~~~~~~~~~~~~~~~~~+It's also important not to inline a worker back into a wrapper.+A wrapper looks like+        wraper = inline_me (\x -> ...worker... )+Normally, the inline_me prevents the worker getting inlined into+the wrapper (initially, the worker's only call site!).  But,+if the wrapper is sure to be called, the strictness analyser will+mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf+continuation.+-}++activeUnfolding :: SimplMode -> Id -> Bool+activeUnfolding mode id+  | isCompulsoryUnfolding (realIdUnfolding id)+  = True   -- Even sm_inline can't override compulsory unfoldings+  | otherwise+  = isActive (sm_phase mode) (idInlineActivation id)+  && sm_inline mode+      -- `or` isStableUnfolding (realIdUnfolding id)+      -- Inline things when+      --  (a) they are active+      --  (b) sm_inline says so, except that for stable unfoldings+      --                         (ie pragmas) we inline anyway++getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv+-- When matching in RULE, we want to "look through" an unfolding+-- (to see a constructor) if *rules* are on, even if *inlinings*+-- are not.  A notable example is DFuns, which really we want to+-- match in rules like (op dfun) in gentle mode. Another example+-- is 'otherwise' which we want exprIsConApp_maybe to be able to+-- see very early on+getUnfoldingInRuleMatch env+  = (in_scope, id_unf)+  where+    in_scope = seInScope env+    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)++----------------------+activeRule :: SimplMode -> Activation -> Bool+-- Nothing => No rules at all+activeRule mode+  | not (sm_rules mode) = \_ -> False     -- Rewriting is off+  | otherwise           = isActive (sm_phase mode)++{-+************************************************************************+*                                                                      *+                  preInlineUnconditionally+*                                                                      *+************************************************************************++preInlineUnconditionally+~~~~~~~~~~~~~~~~~~~~~~~~+@preInlineUnconditionally@ examines a bndr to see if it is used just+once in a completely safe way, so that it is safe to discard the+binding inline its RHS at the (unique) usage site, REGARDLESS of how+big the RHS might be.  If this is the case we don't simplify the RHS+first, but just inline it un-simplified.++This is much better than first simplifying a perhaps-huge RHS and then+inlining and re-simplifying it.  Indeed, it can be at least quadratically+better.  Consider++        x1 = e1+        x2 = e2[x1]+        x3 = e3[x2]+        ...etc...+        xN = eN[xN-1]++We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.+This can happen with cascades of functions too:++        f1 = \x1.e1+        f2 = \xs.e2[f1]+        f3 = \xs.e3[f3]+        ...etc...++THE MAIN INVARIANT is this:++        ----  preInlineUnconditionally invariant -----+   IF preInlineUnconditionally chooses to inline x = <rhs>+   THEN doing the inlining should not change the occurrence+        info for the free vars of <rhs>+        ----------------------------------------------++For example, it's tempting to look at trivial binding like+        x = y+and inline it unconditionally.  But suppose x is used many times,+but this is the unique occurrence of y.  Then inlining x would change+y's occurrence info, which breaks the invariant.  It matters: y+might have a BIG rhs, which will now be dup'd at every occurrence of x.+++Even RHSs labelled InlineMe aren't caught here, because there might be+no benefit from inlining at the call site.++[Sept 01] Don't unconditionally inline a top-level thing, because that+can simply make a static thing into something built dynamically.  E.g.+        x = (a,b)+        main = \s -> h x++[Remember that we treat \s as a one-shot lambda.]  No point in+inlining x unless there is something interesting about the call site.++But watch out: if you aren't careful, some useful foldr/build fusion+can be lost (most notably in spectral/hartel/parstof) because the+foldr didn't see the build.  Doing the dynamic allocation isn't a big+deal, in fact, but losing the fusion can be.  But the right thing here+seems to be to do a callSiteInline based on the fact that there is+something interesting about the call site (it's strict).  Hmm.  That+seems a bit fragile.++Conclusion: inline top level things gaily until Phase 0 (the last+phase), at which point don't.++Note [pre/postInlineUnconditionally in gentle mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even in gentle mode we want to do preInlineUnconditionally.  The+reason is that too little clean-up happens if you don't inline+use-once things.  Also a bit of inlining is *good* for full laziness;+it can expose constant sub-expressions.  Example in+spectral/mandel/Mandel.hs, where the mandelset function gets a useful+let-float if you inline windowToViewport++However, as usual for Gentle mode, do not inline things that are+inactive in the initial stages.  See Note [Gentle mode].++Note [Stable unfoldings and preInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!+Example++   {-# INLINE f #-}+   f :: Eq a => a -> a+   f x = ...++   fInt :: Int -> Int+   fInt = f Int dEqInt++   ...fInt...fInt...fInt...++Here f occurs just once, in the RHS of fInt. But if we inline it there+it might make fInt look big, and we'll lose the opportunity to inline f+at each of fInt's call sites.  The INLINE pragma will only inline when+the application is saturated for exactly this reason; and we don't+want PreInlineUnconditionally to second-guess it.  A live example is+#3736.+    c.f. Note [Stable unfoldings and postInlineUnconditionally]++NB: if the pragma is INLINEABLE, then we don't want to behave in+this special way -- an INLINEABLE pragma just says to GHC "inline this+if you like".  But if there is a unique occurrence, we want to inline+the stable unfolding, not the RHS.++Note [Top-level bottoming Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don't inline top-level Ids that are bottoming, even if they are used just+once, because FloatOut has gone to some trouble to extract them out.+Inlining them won't make the program run faster!++Note [Do not inline CoVars unconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Coercion variables appear inside coercions, and the RHS of a let-binding+is a term (not a coercion) so we can't necessarily inline the latter in+the former.+-}++preInlineUnconditionally+    :: SimplEnv -> TopLevelFlag -> InId+    -> InExpr -> StaticEnv  -- These two go together+    -> Maybe SimplEnv       -- Returned env has extended substitution+-- Precondition: rhs satisfies the let/app invariant+-- See Note [Core let/app invariant] in GHC.Core+-- Reason: we don't want to inline single uses, or discard dead bindings,+--         for unlifted, side-effect-ful bindings+preInlineUnconditionally env top_lvl bndr rhs rhs_env+  | not pre_inline_unconditionally           = Nothing+  | not active                               = Nothing+  | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids]+  | isCoVar bndr                             = Nothing -- Note [Do not inline CoVars unconditionally]+  | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]+                                                       -- in module Exitify+  | not (one_occ (idOccInfo bndr))           = Nothing+  | not (isStableUnfolding unf)              = Just (extend_subst_with rhs)++  -- Note [Stable unfoldings and preInlineUnconditionally]+  | isInlinablePragma inline_prag+  , Just inl <- maybeUnfoldingTemplate unf   = Just (extend_subst_with inl)+  | otherwise                                = Nothing+  where+    unf = idUnfolding bndr+    extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)++    one_occ IAmDead = True -- Happens in ((\x.1) v)+    one_occ OneOcc{ occ_one_br = InOneBranch+                  , occ_in_lam = NotInsideLam }   = isNotTopLevel top_lvl || early_phase+    one_occ OneOcc{ occ_one_br = InOneBranch+                  , occ_in_lam = IsInsideLam+                  , occ_int_cxt = IsInteresting } = canInlineInLam rhs+    one_occ _                                     = False++    pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env)+    mode   = getMode env+    active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag)+             -- See Note [pre/postInlineUnconditionally in gentle mode]+    inline_prag = idInlinePragma bndr++-- Be very careful before inlining inside a lambda, because (a) we must not+-- invalidate occurrence information, and (b) we want to avoid pushing a+-- single allocation (here) into multiple allocations (inside lambda).+-- Inlining a *function* with a single *saturated* call would be ok, mind you.+--      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)+--      where+--              is_cheap = exprIsCheap rhs+--              ok = is_cheap && int_cxt++        --      int_cxt         The context isn't totally boring+        -- E.g. let f = \ab.BIG in \y. map f xs+        --      Don't want to substitute for f, because then we allocate+        --      its closure every time the \y is called+        -- But: let f = \ab.BIG in \y. map (f y) xs+        --      Now we do want to substitute for f, even though it's not+        --      saturated, because we're going to allocate a closure for+        --      (f y) every time round the loop anyhow.++        -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,+        -- so substituting rhs inside a lambda doesn't change the occ info.+        -- Sadly, not quite the same as exprIsHNF.+    canInlineInLam (Lit _)    = True+    canInlineInLam (Lam b e)  = isRuntimeVar b || canInlineInLam e+    canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e+    canInlineInLam _          = False+      -- not ticks.  Counting ticks cannot be duplicated, and non-counting+      -- ticks around a Lam will disappear anyway.++    early_phase = case sm_phase mode of+                    Phase 0 -> False+                    _       -> True+-- If we don't have this early_phase test, consider+--      x = length [1,2,3]+-- The full laziness pass carefully floats all the cons cells to+-- top level, and preInlineUnconditionally floats them all back in.+-- Result is (a) static allocation replaced by dynamic allocation+--           (b) many simplifier iterations because this tickles+--               a related problem; only one inlining per pass+--+-- On the other hand, I have seen cases where top-level fusion is+-- lost if we don't inline top level thing (e.g. string constants)+-- Hence the test for phase zero (which is the phase for all the final+-- simplifications).  Until phase zero we take no special notice of+-- top level things, but then we become more leery about inlining+-- them.++{-+************************************************************************+*                                                                      *+                  postInlineUnconditionally+*                                                                      *+************************************************************************++postInlineUnconditionally+~~~~~~~~~~~~~~~~~~~~~~~~~+@postInlineUnconditionally@ decides whether to unconditionally inline+a thing based on the form of its RHS; in particular if it has a+trivial RHS.  If so, we can inline and discard the binding altogether.++NB: a loop breaker has must_keep_binding = True and non-loop-breakers+only have *forward* references. Hence, it's safe to discard the binding++NOTE: This isn't our last opportunity to inline.  We're at the binding+site right now, and we'll get another opportunity when we get to the+occurrence(s)++Note that we do this unconditional inlining only for trivial RHSs.+Don't inline even WHNFs inside lambdas; doing so may simply increase+allocation when the function is called. This isn't the last chance; see+NOTE above.++NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?+Because we don't even want to inline them into the RHS of constructor+arguments. See NOTE above++NB: At one time even NOINLINE was ignored here: if the rhs is trivial+it's best to inline it anyway.  We often get a=E; b=a from desugaring,+with both a and b marked NOINLINE.  But that seems incompatible with+our new view that inlining is like a RULE, so I'm sticking to the 'active'+story for now.+-}++postInlineUnconditionally+    :: SimplEnv -> TopLevelFlag+    -> OutId            -- The binder (*not* a CoVar), including its unfolding+    -> OccInfo          -- From the InId+    -> OutExpr+    -> Bool+-- Precondition: rhs satisfies the let/app invariant+-- See Note [Core let/app invariant] in GHC.Core+-- Reason: we don't want to inline single uses, or discard dead bindings,+--         for unlifted, side-effect-ful bindings+postInlineUnconditionally env top_lvl bndr occ_info rhs+  | not active                  = False+  | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline+                                        -- because it might be referred to "earlier"+  | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]+  | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]+  | exprIsTrivial rhs           = True+  | otherwise+  = case occ_info of+        -- The point of examining occ_info here is that for *non-values*+        -- that occur outside a lambda, the call-site inliner won't have+        -- a chance (because it doesn't know that the thing+        -- only occurs once).   The pre-inliner won't have gotten+        -- it either, if the thing occurs in more than one branch+        -- So the main target is things like+        --      let x = f y in+        --      case v of+        --         True  -> case x of ...+        --         False -> case x of ...+        -- This is very important in practice; e.g. wheel-seive1 doubles+        -- in allocation if you miss this out+      OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt }+               -- OneOcc => no code-duplication issue+        ->     smallEnoughToInline dflags unfolding     -- Small enough to dup+                        -- ToDo: consider discount on smallEnoughToInline if int_cxt is true+                        --+                        -- NB: Do NOT inline arbitrarily big things, even if one_br is True+                        -- Reason: doing so risks exponential behaviour.  We simplify a big+                        --         expression, inline it, and simplify it again.  But if the+                        --         very same thing happens in the big expression, we get+                        --         exponential cost!+                        -- PRINCIPLE: when we've already simplified an expression once,+                        -- make sure that we only inline it if it's reasonably small.++           && (in_lam == NotInsideLam ||+                        -- Outside a lambda, we want to be reasonably aggressive+                        -- about inlining into multiple branches of case+                        -- e.g. let x = <non-value>+                        --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }+                        -- Inlining can be a big win if C3 is the hot-spot, even if+                        -- the uses in C1, C2 are not 'interesting'+                        -- An example that gets worse if you add int_cxt here is 'clausify'++                (isCheapUnfolding unfolding && int_cxt == IsInteresting))+                        -- isCheap => acceptable work duplication; in_lam may be true+                        -- int_cxt to prevent us inlining inside a lambda without some+                        -- good reason.  See the notes on int_cxt in preInlineUnconditionally++      IAmDead -> True   -- This happens; for example, the case_bndr during case of+                        -- known constructor:  case (a,b) of x { (p,q) -> ... }+                        -- Here x isn't mentioned in the RHS, so we don't want to+                        -- create the (dead) let-binding  let x = (a,b) in ...++      _ -> False++-- Here's an example that we don't handle well:+--      let f = if b then Left (\x.BIG) else Right (\y.BIG)+--      in \y. ....case f of {...} ....+-- Here f is used just once, and duplicating the case work is fine (exprIsCheap).+-- But+--  - We can't preInlineUnconditionally because that would invalidate+--    the occ info for b.+--  - We can't postInlineUnconditionally because the RHS is big, and+--    that risks exponential behaviour+--  - We can't call-site inline, because the rhs is big+-- Alas!++  where+    unfolding = idUnfolding bndr+    dflags    = seDynFlags env+    active    = isActive (sm_phase (getMode env)) (idInlineActivation bndr)+        -- See Note [pre/postInlineUnconditionally in gentle mode]++{-+Note [Top level and postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't do postInlineUnconditionally for top-level things (even for+ones that are trivial):++  * Doing so will inline top-level error expressions that have been+    carefully floated out by FloatOut.  More generally, it might+    replace static allocation with dynamic.++  * Even for trivial expressions there's a problem.  Consider+      {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-}+      blah xs = reverse xs+      ruggle = sort+    In one simplifier pass we might fire the rule, getting+      blah xs = ruggle xs+    but in *that* simplifier pass we must not do postInlineUnconditionally+    on 'ruggle' because then we'll have an unbound occurrence of 'ruggle'++    If the rhs is trivial it'll be inlined by callSiteInline, and then+    the binding will be dead and discarded by the next use of OccurAnal++  * There is less point, because the main goal is to get rid of local+    bindings used in multiple case branches.++  * The inliner should inline trivial things at call sites anyway.++  * The Id might be exported.  We could check for that separately,+    but since we aren't going to postInlineUnconditionally /any/+    top-level bindings, we don't need to test.++Note [Stable unfoldings and postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do not do postInlineUnconditionally if the Id has a stable unfolding,+otherwise we lose the unfolding.  Example++     -- f has stable unfolding with rhs (e |> co)+     --   where 'e' is big+     f = e |> co++Then there's a danger we'll optimise to++     f' = e+     f = f' |> co++and now postInlineUnconditionally, losing the stable unfolding on f.  Now f'+won't inline because 'e' is too big.++    c.f. Note [Stable unfoldings and preInlineUnconditionally]+++************************************************************************+*                                                                      *+        Rebuilding a lambda+*                                                                      *+************************************************************************+-}++mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr+-- mkLam tries three things+--      a) eta reduction, if that gives a trivial expression+--      b) eta expansion [only if there are some value lambdas]++mkLam _env [] body _cont+  = return body+mkLam env bndrs body cont+  = do { dflags <- getDynFlags+       ; mkLam' dflags bndrs body }+  where+    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr+    mkLam' dflags bndrs (Cast body co)+      | not (any bad bndrs)+        -- Note [Casts and lambdas]+      = do { lam <- mkLam' dflags bndrs body+           ; return (mkCast lam (mkPiCos Representational bndrs co)) }+      where+        co_vars  = tyCoVarsOfCo co+        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars++    mkLam' dflags bndrs body@(Lam {})+      = mkLam' dflags (bndrs ++ bndrs1) body1+      where+        (bndrs1, body1) = collectBinders body++    mkLam' dflags bndrs (Tick t expr)+      | tickishFloatable t+      = mkTick t <$> mkLam' dflags bndrs expr++    mkLam' dflags bndrs body+      | gopt Opt_DoEtaReduction dflags+      , Just etad_lam <- tryEtaReduce bndrs body+      = do { tick (EtaReduction (head bndrs))+           ; return etad_lam }++      | not (contIsRhs cont)   -- See Note [Eta-expanding lambdas]+      , sm_eta_expand (getMode env)+      , any isRuntimeVar bndrs+      , let body_arity = exprEtaExpandArity dflags body+      , body_arity > 0+      = do { tick (EtaExpansion (head bndrs))+           ; let res = mkLams bndrs (etaExpand body_arity body)+           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)+                                          , text "after" <+> ppr res])+           ; return res }++      | otherwise+      = return (mkLams bndrs body)++{-+Note [Eta expanding lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we *do* want to eta-expand lambdas. Consider+   f (\x -> case x of (a,b) -> \s -> blah)+where 's' is a state token, and hence can be eta expanded.  This+showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather+important function!++The eta-expansion will never happen unless we do it now.  (Well, it's+possible that CorePrep will do it, but CorePrep only has a half-baked+eta-expander that can't deal with casts.  So it's much better to do it+here.)++However, when the lambda is let-bound, as the RHS of a let, we have a+better eta-expander (in the form of tryEtaExpandRhs), so we don't+bother to try expansion in mkLam in that case; hence the contIsRhs+guard.++NB: We check the SimplEnv (sm_eta_expand), not DynFlags.+    See Note [No eta expansion in stable unfoldings]++Note [Casts and lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        (\x. (\y. e) `cast` g1) `cast` g2+There is a danger here that the two lambdas look separated, and the+full laziness pass might float an expression to between the two.++So this equation in mkLam' floats the g1 out, thus:+        (\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)+where x:tx.++In general, this floats casts outside lambdas, where (I hope) they+might meet and cancel with some other cast:+        \x. e `cast` co   ===>   (\x. e) `cast` (tx -> co)+        /\a. e `cast` co  ===>   (/\a. e) `cast` (/\a. co)+        /\g. e `cast` co  ===>   (/\g. e) `cast` (/\g. co)+                          (if not (g `in` co))++Notice that it works regardless of 'e'.  Originally it worked only+if 'e' was itself a lambda, but in some cases that resulted in+fruitless iteration in the simplifier.  A good example was when+compiling Text.ParserCombinators.ReadPrec, where we had a definition+like    (\x. Get `cast` g)+where Get is a constructor with nonzero arity.  Then mkLam eta-expanded+the Get, and the next iteration eta-reduced it, and then eta-expanded+it again.++Note also the side condition for the case of coercion binders.+It does not make sense to transform+        /\g. e `cast` g  ==>  (/\g.e) `cast` (/\g.g)+because the latter is not well-kinded.++************************************************************************+*                                                                      *+              Eta expansion+*                                                                      *+************************************************************************+-}++tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr+                -> SimplM (Arity, Bool, OutExpr)+-- See Note [Eta-expanding at let bindings]+-- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then+--   (a) rhs' has manifest arity n+--   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom+tryEtaExpandRhs mode bndr rhs+  | Just join_arity <- isJoinId_maybe bndr+  = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs+       ; return (count isId join_bndrs, exprIsBottom join_body, rhs) }+         -- Note [Do not eta-expand join points]+         -- But do return the correct arity and bottom-ness, because+         -- these are used to set the bndr's IdInfo (#15517)+         -- Note [Invariants on join points] invariant 2b, in GHC.Core++  | otherwise+  = do { (new_arity, is_bot, new_rhs) <- try_expand++       ; WARN( new_arity < old_id_arity,+               (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity+                <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )+                        -- Note [Arity decrease] in GHC.Core.Op.Simplify+         return (new_arity, is_bot, new_rhs) }+  where+    try_expand+      | exprIsTrivial rhs+      = return (exprArity rhs, False, rhs)++      | sm_eta_expand mode      -- Provided eta-expansion is on+      , new_arity > old_arity   -- And the current manifest arity isn't enough+      = do { tick (EtaExpansion bndr)+           ; return (new_arity, is_bot, etaExpand new_arity rhs) }++      | otherwise+      = return (old_arity, is_bot && new_arity == old_arity, rhs)++    dflags       = sm_dflags mode+    old_arity    = exprArity rhs -- See Note [Do not expand eta-expand PAPs]+    old_id_arity = idArity bndr++    (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity+    new_arity2 = idCallArity bndr+    new_arity  = max new_arity1 new_arity2++{-+Note [Eta-expanding at let bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We now eta expand at let-bindings, which is where the payoff comes.+The most significant thing is that we can do a simple arity analysis+(in GHC.Core.Arity.findRhsArity), which we can't do for free-floating lambdas++One useful consequence of not eta-expanding lambdas is this example:+   genMap :: C a => ...+   {-# INLINE genMap #-}+   genMap f xs = ...++   myMap :: D a => ...+   {-# INLINE myMap #-}+   myMap = genMap++Notice that 'genMap' should only inline if applied to two arguments.+In the stable unfolding for myMap we'll have the unfolding+    (\d -> genMap Int (..d..))+We do not want to eta-expand to+    (\d f xs -> genMap Int (..d..) f xs)+because then 'genMap' will inline, and it really shouldn't: at least+as far as the programmer is concerned, it's not applied to two+arguments!++Note [Do not eta-expand join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Similarly to CPR (see Note [Don't w/w join points for CPR] in+GHC.Core.Op.WorkWrap), a join point stands well to gain from its outer binding's+eta-expansion, and eta-expanding a join point is fraught with issues like how to+deal with a cast:++    let join $j1 :: IO ()+             $j1 = ...+             $j2 :: Int -> IO ()+             $j2 n = if n > 0 then $j1+                              else ...++    =>++    let join $j1 :: IO ()+             $j1 = (\eta -> ...)+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())+                                 ~  IO ()+             $j2 :: Int -> IO ()+             $j2 n = (\eta -> if n > 0 then $j1+                                       else ...)+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())+                                 ~  IO ()++The cast here can't be pushed inside the lambda (since it's not casting to a+function type), so the lambda has to stay, but it can't because it contains a+reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather+than try and detect this situation (and whatever other situations crop up!), we+don't bother; again, any surrounding eta-expansion will improve these join+points anyway, since an outer cast can *always* be pushed inside. By the time+CorePrep comes around, the code is very likely to look more like this:++    let join $j1 :: State# RealWorld -> (# State# RealWorld, ())+             $j1 = (...) eta+             $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())+             $j2 = if n > 0 then $j1+                            else (...) eta++Note [Do not eta-expand PAPs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have old_arity = manifestArity rhs, which meant that we+would eta-expand even PAPs.  But this gives no particular advantage,+and can lead to a massive blow-up in code size, exhibited by #9020.+Suppose we have a PAP+    foo :: IO ()+    foo = returnIO ()+Then we can eta-expand do+    foo = (\eta. (returnIO () |> sym g) eta) |> g+where+    g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)++But there is really no point in doing this, and it generates masses of+coercions and whatnot that eventually disappear again. For T9020, GHC+allocated 6.6G before, and 0.8G afterwards; and residency dropped from+1.8G to 45M.++But note that this won't eta-expand, say+  f = \g -> map g+Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps+strictness analysis will have less to bite on?+++************************************************************************+*                                                                      *+\subsection{Floating lets out of big lambdas}+*                                                                      *+************************************************************************++Note [Floating and type abstraction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+        x = /\a. C e1 e2+We'd like to float this to+        y1 = /\a. e1+        y2 = /\a. e2+        x  = /\a. C (y1 a) (y2 a)+for the usual reasons: we want to inline x rather vigorously.++You may think that this kind of thing is rare.  But in some programs it is+common.  For example, if you do closure conversion you might get:++        data a :-> b = forall e. (e -> a -> b) :$ e++        f_cc :: forall a. a :-> a+        f_cc = /\a. (\e. id a) :$ ()++Now we really want to inline that f_cc thing so that the+construction of the closure goes away.++So I have elaborated simplLazyBind to understand right-hand sides that look+like+        /\ a1..an. body++and treat them specially. The real work is done in+GHC.Core.Op.Simplify.Utils.abstractFloats, but there is quite a bit of plumbing+in simplLazyBind as well.++The same transformation is good when there are lets in the body:++        /\abc -> let(rec) x = e in b+   ==>+        let(rec) x' = /\abc -> let x = x' a b c in e+        in+        /\abc -> let x = x' a b c in b++This is good because it can turn things like:++        let f = /\a -> letrec g = ... g ... in g+into+        letrec g' = /\a -> ... g' a ...+        in+        let f = /\ a -> g' a++which is better.  In effect, it means that big lambdas don't impede+let-floating.++This optimisation is CRUCIAL in eliminating the junk introduced by+desugaring mutually recursive definitions.  Don't eliminate it lightly!++[May 1999]  If we do this transformation *regardless* then we can+end up with some pretty silly stuff.  For example,++        let+            st = /\ s -> let { x1=r1 ; x2=r2 } in ...+        in ..+becomes+        let y1 = /\s -> r1+            y2 = /\s -> r2+            st = /\s -> ...[y1 s/x1, y2 s/x2]+        in ..++Unless the "..." is a WHNF there is really no point in doing this.+Indeed it can make things worse.  Suppose x1 is used strictly,+and is of the form++        x1* = case f y of { (a,b) -> e }++If we abstract this wrt the tyvar we then can't do the case inline+as we would normally do.++That's why the whole transformation is part of the same process that+floats let-bindings and constructor arguments out of RHSs.  In particular,+it is guarded by the doFloatFromRhs call in simplLazyBind.++Note [Which type variables to abstract over]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Abstract only over the type variables free in the rhs wrt which the+new binding is abstracted.  Note that++  * The naive approach of abstracting wrt the+    tyvars free in the Id's /type/ fails. Consider:+        /\ a b -> let t :: (a,b) = (e1, e2)+                      x :: a     = fst t+                  in ...+    Here, b isn't free in x's type, but we must nevertheless+    abstract wrt b as well, because t's type mentions b.+    Since t is floated too, we'd end up with the bogus:+         poly_t = /\ a b -> (e1, e2)+         poly_x = /\ a   -> fst (poly_t a *b*)++  * We must do closeOverKinds.  Example (#10934):+       f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...+    Here we want to float 't', but we must remember to abstract over+    'k' as well, even though it is not explicitly mentioned in the RHS,+    otherwise we get+       t = /\ (f:k->*) (a:k). AccFailure @ (f a)+    which is obviously bogus.+-}++abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats+              -> OutExpr -> SimplM ([OutBind], OutExpr)+abstractFloats dflags top_lvl main_tvs floats body+  = ASSERT( notNull body_floats )+    ASSERT( isNilOL (sfJoinFloats floats) )+    do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats+        ; return (float_binds, GHC.Core.Subst.substExpr (text "abstract_floats1") subst body) }+  where+    is_top_lvl  = isTopLevel top_lvl+    main_tv_set = mkVarSet main_tvs+    body_floats = letFloatBinds (sfLetFloats floats)+    empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats)++    abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)+    abstract subst (NonRec id rhs)+      = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id+           ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'+                 subst' = GHC.Core.Subst.extendIdSubst subst id poly_app+           ; return (subst', NonRec poly_id2 poly_rhs) }+      where+        rhs' = GHC.Core.Subst.substExpr (text "abstract_floats2") subst rhs++        -- tvs_here: see Note [Which type variables to abstract over]+        tvs_here = scopedSort $+                   filter (`elemVarSet` main_tv_set) $+                   closeOverKindsList $+                   exprSomeFreeVarsList isTyVar rhs'++    abstract subst (Rec prs)+       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids+            ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)+                  poly_pairs = [ mk_poly2 poly_id tvs_here rhs'+                               | (poly_id, rhs) <- poly_ids `zip` rhss+                               , let rhs' = GHC.Core.Subst.substExpr (text "abstract_floats")+                                                                subst' rhs ]+            ; return (subst', Rec poly_pairs) }+       where+         (ids,rhss) = unzip prs+                -- For a recursive group, it's a bit of a pain to work out the minimal+                -- set of tyvars over which to abstract:+                --      /\ a b c.  let x = ...a... in+                --                 letrec { p = ...x...q...+                --                          q = .....p...b... } in+                --                 ...+                -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted+                -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.+                -- Since it's a pain, we just use the whole set, which is always safe+                --+                -- If you ever want to be more selective, remember this bizarre case too:+                --      x::a = x+                -- Here, we must abstract 'x' over 'a'.+         tvs_here = scopedSort main_tvs++    mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)+    mk_poly1 tvs_here var+      = do { uniq <- getUniqueM+           ; let  poly_name = setNameUnique (idName var) uniq      -- Keep same name+                  poly_ty   = mkInvForAllTys tvs_here (idType var) -- But new type of course+                  poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id+                              mkLocalId poly_name poly_ty+           ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }+                -- In the olden days, it was crucial to copy the occInfo of the original var,+                -- because we were looking at occurrence-analysed but as yet unsimplified code!+                -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking+                -- at already simplified code, so it doesn't matter+                --+                -- It's even right to retain single-occurrence or dead-var info:+                -- Suppose we started with  /\a -> let x = E in B+                -- where x occurs once in B. Then we transform to:+                --      let x' = /\a -> E in /\a -> let x* = x' a in B+                -- where x* has an INLINE prag on it.  Now, once x* is inlined,+                -- the occurrences of x' will be just the occurrences originally+                -- pinned on x.++    mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)+    mk_poly2 poly_id tvs_here rhs+      = (poly_id `setIdUnfolding` unf, poly_rhs)+      where+        poly_rhs = mkLams tvs_here rhs+        unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs++        -- We want the unfolding.  Consider+        --      let+        --            x = /\a. let y = ... in Just y+        --      in body+        -- Then we float the y-binding out (via abstractFloats and addPolyBind)+        -- but 'x' may well then be inlined in 'body' in which case we'd like the+        -- opportunity to inline 'y' too.++{-+Note [Abstract over coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the+type variable a.  Rather than sort this mess out, we simply bale out and abstract+wrt all the type variables if any of them are coercion variables.+++Historical note: if you use let-bindings instead of a substitution, beware of this:++                -- Suppose we start with:+                --+                --      x = /\ a -> let g = G in E+                --+                -- Then we'll float to get+                --+                --      x = let poly_g = /\ a -> G+                --          in /\ a -> let g = poly_g a in E+                --+                -- But now the occurrence analyser will see just one occurrence+                -- of poly_g, not inside a lambda, so the simplifier will+                -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!+                -- (I used to think that the "don't inline lone occurrences" stuff+                --  would stop this happening, but since it's the *only* occurrence,+                --  PreInlineUnconditionally kicks in first!)+                --+                -- Solution: put an INLINE note on g's RHS, so that poly_g seems+                --           to appear many times.  (NB: mkInlineMe eliminates+                --           such notes on trivial RHSs, so do it manually.)++************************************************************************+*                                                                      *+                prepareAlts+*                                                                      *+************************************************************************++prepareAlts tries these things:++1.  Eliminate alternatives that cannot match, including the+    DEFAULT alternative.++2.  If the DEFAULT alternative can match only one possible constructor,+    then make that constructor explicit.+    e.g.+        case e of x { DEFAULT -> rhs }+     ===>+        case e of x { (a,b) -> rhs }+    where the type is a single constructor type.  This gives better code+    when rhs also scrutinises x or e.++3. Returns a list of the constructors that cannot holds in the+   DEFAULT alternative (if there is one)++Here "cannot match" includes knowledge from GADTs++It's a good idea to do this stuff before simplifying the alternatives, to+avoid simplifying alternatives we know can't happen, and to come up with+the list of constructors that are handled, to put into the IdInfo of the+case binder, for use when simplifying the alternatives.++Eliminating the default alternative in (1) isn't so obvious, but it can+happen:++data Colour = Red | Green | Blue++f x = case x of+        Red -> ..+        Green -> ..+        DEFAULT -> h x++h y = case y of+        Blue -> ..+        DEFAULT -> [ case y of ... ]++If we inline h into f, the default case of the inlined h can't happen.+If we don't notice this, we may end up filtering out *all* the cases+of the inner case y, which give us nowhere to go!+-}++prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])+-- The returned alternatives can be empty, none are possible+prepareAlts scrut case_bndr' alts+  | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr')+           -- Case binder is needed just for its type. Note that as an+           --   OutId, it has maximum information; this is important.+           --   Test simpl013 is an example+  = do { us <- getUniquesM+       ; let (idcs1, alts1)       = filterAlts tc tys imposs_cons alts+             (yes2,  alts2)       = refineDefaultAlt us tc tys idcs1 alts1+             (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2+             -- "idcs" stands for "impossible default data constructors"+             -- i.e. the constructors that can't match the default case+       ; when yes2 $ tick (FillInCaseDefault case_bndr')+       ; when yes3 $ tick (AltMerge case_bndr')+       ; return (idcs3, alts3) }++  | otherwise  -- Not a data type, so nothing interesting happens+  = return ([], alts)+  where+    imposs_cons = case scrut of+                    Var v -> otherCons (idUnfolding v)+                    _     -> []+++{-+************************************************************************+*                                                                      *+                mkCase+*                                                                      *+************************************************************************++mkCase tries these things++* Note [Nerge nested cases]+* Note [Eliminate identity case]+* Note [Scrutinee constant folding]++Note [Merge Nested Cases]+~~~~~~~~~~~~~~~~~~~~~~~~~+       case e of b {             ==>   case e of b {+         p1 -> rhs1                      p1 -> rhs1+         ...                             ...+         pm -> rhsm                      pm -> rhsm+         _  -> case b of b' {            pn -> let b'=b in rhsn+                     pn -> rhsn          ...+                     ...                 po -> let b'=b in rhso+                     po -> rhso          _  -> let b'=b in rhsd+                     _  -> rhsd+       }++which merges two cases in one case when -- the default alternative of+the outer case scrutises the same variable as the outer case. This+transformation is called Case Merging.  It avoids that the same+variable is scrutinised multiple times.++Note [Eliminate Identity Case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        case e of               ===> e+                True  -> True;+                False -> False++and similar friends.++Note [Scrutinee Constant Folding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+     case x op# k# of _ {  ===> case x of _ {+        a1# -> e1                  (a1# inv_op# k#) -> e1+        a2# -> e2                  (a2# inv_op# k#) -> e2+        ...                        ...+        DEFAULT -> ed              DEFAULT -> ed++     where (x op# k#) inv_op# k# == x++And similarly for commuted arguments and for some unary operations.++The purpose of this transformation is not only to avoid an arithmetic+operation at runtime but to allow other transformations to apply in cascade.++Example with the "Merge Nested Cases" optimization (from #12877):++      main = case t of t0+         0##     -> ...+         DEFAULT -> case t0 `minusWord#` 1## of t1+            0##     -> ...+            DEFAULT -> case t1 `minusWord#` 1## of t2+               0##     -> ...+               DEFAULT -> case t2 `minusWord#` 1## of _+                  0##     -> ...+                  DEFAULT -> ...++  becomes:++      main = case t of _+      0##     -> ...+      1##     -> ...+      2##     -> ...+      3##     -> ...+      DEFAULT -> ...++There are some wrinkles++* Do not apply caseRules if there is just a single DEFAULT alternative+     case e +# 3# of b { DEFAULT -> rhs }+  If we applied the transformation here we would (stupidly) get+     case a of b' { DEFAULT -> let b = e +# 3# in rhs }+  and now the process may repeat, because that let will really+  be a case.++* The type of the scrutinee might change.  E.g.+        case tagToEnum (x :: Int#) of (b::Bool)+          False -> e1+          True -> e2+  ==>+        case x of (b'::Int#)+          DEFAULT -> e1+          1#      -> e2++* The case binder may be used in the right hand sides, so we need+  to make a local binding for it, if it is alive.  e.g.+         case e +# 10# of b+           DEFAULT -> blah...b...+           44#     -> blah2...b...+  ===>+         case e of b'+           DEFAULT -> let b = b' +# 10# in blah...b...+           34#     -> let b = 44# in blah2...b...++  Note that in the non-DEFAULT cases we know what to bind 'b' to,+  whereas in the DEFAULT case we must reconstruct the original value.+  But NB: we use b'; we do not duplicate 'e'.++* In dataToTag we might need to make up some fake binders;+  see Note [caseRules for dataToTag] in GHC.Core.Op.ConstantFold+-}++mkCase, mkCase1, mkCase2, mkCase3+   :: DynFlags+   -> OutExpr -> OutId+   -> OutType -> [OutAlt]               -- Alternatives in standard (increasing) order+   -> SimplM OutExpr++--------------------------------------------------+--      1. Merge Nested Cases+--------------------------------------------------++mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)+  | gopt Opt_CaseMerge dflags+  , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)+       <- stripTicksTop tickishFloatable deflt_rhs+  , inner_scrut_var == outer_bndr+  = do  { tick (CaseMerge outer_bndr)++        ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args )+                                          (con, args, wrap_rhs rhs)+                -- Simplifier's no-shadowing invariant should ensure+                -- that outer_bndr is not shadowed by the inner patterns+              wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs+                -- The let is OK even for unboxed binders,++              wrapped_alts | isDeadBinder inner_bndr = inner_alts+                           | otherwise               = map wrap_alt inner_alts++              merged_alts = mergeAlts outer_alts wrapped_alts+                -- NB: mergeAlts gives priority to the left+                --      case x of+                --        A -> e1+                --        DEFAULT -> case x of+                --                      A -> e2+                --                      B -> e3+                -- When we merge, we must ensure that e1 takes+                -- precedence over e2 as the value for A!++        ; fmap (mkTicks ticks) $+          mkCase1 dflags scrut outer_bndr alts_ty merged_alts+        }+        -- Warning: don't call mkCase recursively!+        -- Firstly, there's no point, because inner alts have already had+        -- mkCase applied to them, so they won't have a case in their default+        -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr+        -- in munge_rhs may put a case into the DEFAULT branch!++mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts++--------------------------------------------------+--      2. Eliminate Identity Case+--------------------------------------------------++mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case+  | all identity_alt alts+  = do { tick (CaseIdentity case_bndr)+       ; return (mkTicks ticks $ re_cast scrut rhs1) }+  where+    ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts)+    identity_alt (con, args, rhs) = check_eq rhs con args++    check_eq (Cast rhs co) con args        -- See Note [RHS casts]+      = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args+    check_eq (Tick t e) alt args+      = tickishFloatable t && check_eq e alt args++    check_eq (Lit lit) (LitAlt lit') _     = lit == lit'+    check_eq (Var v) _ _  | v == case_bndr = True+    check_eq (Var v)   (DataAlt con) args+      | null arg_tys, null args            = v == dataConWorkId con+                                             -- Optimisation only+    check_eq rhs        (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $+                                             mkConApp2 con arg_tys args+    check_eq _          _             _    = False++    arg_tys = tyConAppArgs (idType case_bndr)++        -- Note [RHS casts]+        -- ~~~~~~~~~~~~~~~~+        -- We've seen this:+        --      case e of x { _ -> x `cast` c }+        -- And we definitely want to eliminate this case, to give+        --      e `cast` c+        -- So we throw away the cast from the RHS, and reconstruct+        -- it at the other end.  All the RHS casts must be the same+        -- if (all identity_alt alts) holds.+        --+        -- Don't worry about nested casts, because the simplifier combines them++    re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co+    re_cast scrut _             = scrut++mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts++--------------------------------------------------+--      2. Scrutinee Constant Folding+--------------------------------------------------++mkCase2 dflags scrut bndr alts_ty alts+  | -- See Note [Scrutinee Constant Folding]+    case alts of  -- Not if there is just a DEFAULT alternative+      [(DEFAULT,_,_)] -> False+      _               -> True+  , gopt Opt_CaseFolding dflags+  , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut+  = do { bndr' <- newId (fsLit "lwild") (exprType scrut')++       ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts+                  -- mapMaybeM: discard unreachable alternatives+                  -- See Note [Unreachable caseRules alternatives]+                  -- in GHC.Core.Op.ConstantFold++       ; mkCase3 dflags scrut' bndr' alts_ty $+         add_default (re_sort alts')+       }++  | otherwise+  = mkCase3 dflags scrut bndr alts_ty alts+  where+    -- We need to keep the correct association between the scrutinee and its+    -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with+    -- "let bndr = ... in":+    --+    --     case v + 10 of y        =====> case v of y+    --        20      -> e1                 10      -> let y = 20     in e1+    --        DEFAULT -> e2                 DEFAULT -> let y = v + 10 in e2+    --+    -- Other transformations give: =====> case v of y'+    --                                      10      -> let y = 20      in e1+    --                                      DEFAULT -> let y = y' + 10 in e2+    --+    -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules,+    -- to construct an expression equivalent to the original one, for use+    -- in the DEFAULT case++    tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id+           -> CoreAlt -> SimplM (Maybe CoreAlt)+    tx_alt tx_con mk_orig new_bndr (con, bs, rhs)+      = case tx_con con of+          Nothing   -> return Nothing+          Just con' -> do { bs' <- mk_new_bndrs new_bndr con'+                          ; return (Just (con', bs', rhs')) }+      where+        rhs' | isDeadBinder bndr = rhs+             | otherwise         = bindNonRec bndr orig_val rhs++        orig_val = case con of+                      DEFAULT    -> mk_orig new_bndr+                      LitAlt l   -> Lit l+                      DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs++    mk_new_bndrs new_bndr (DataAlt dc)+      | not (isNullaryRepDataCon dc)+      = -- For non-nullary data cons we must invent some fake binders+        -- See Note [caseRules for dataToTag] in GHC.Core.Op.ConstantFold+        do { us <- getUniquesM+           ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc+                                        (tyConAppArgs (idType new_bndr))+           ; return (ex_tvs ++ arg_ids) }+    mk_new_bndrs _ _ = return []++    re_sort :: [CoreAlt] -> [CoreAlt]+    -- Sort the alternatives to re-establish+    -- GHC.Core Note [Case expression invariants]+    re_sort alts = sortBy cmpAlt alts++    add_default :: [CoreAlt] -> [CoreAlt]+    -- See Note [Literal cases]+    add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts+    add_default alts                          = alts++{- Note [Literal cases]+~~~~~~~~~~~~~~~~~~~~~~~+If we have+  case tagToEnum (a ># b) of+     False -> e1+     True  -> e2++then caseRules for TagToEnum will turn it into+  case tagToEnum (a ># b) of+     0# -> e1+     1# -> e2++Since the case is exhaustive (all cases are) we can convert it to+  case tagToEnum (a ># b) of+     DEFAULT -> e1+     1#      -> e2++This may generate sligthtly better code (although it should not, since+all cases are exhaustive) and/or optimise better.  I'm not certain that+it's necessary, but currently we do make this change.  We do it here,+NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]+in GHC.Core.Op.ConstantFold)+-}++--------------------------------------------------+--      Catch-all+--------------------------------------------------+mkCase3 _dflags scrut bndr alts_ty alts+  = return (Case scrut bndr alts_ty alts)++-- See Note [Exitification] and Note [Do not inline exit join points] in+-- GHC.Core.Op.Exitify+-- This lives here (and not in Id) because occurrence info is only valid on+-- InIds, so it's crucial that isExitJoinId is only called on freshly+-- occ-analysed code. It's not a generic function you can call anywhere.+isExitJoinId :: Var -> Bool+isExitJoinId id+  = isJoinId id+  && isOneOcc (idOccInfo id)+  && occ_in_lam (idOccInfo id) == IsInsideLam++{-+Note [Dead binders]+~~~~~~~~~~~~~~~~~~~~+Note that dead-ness is maintained by the simplifier, so that it is+accurate after simplification as well as before.+++Note [Cascading case merge]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case merging should cascade in one sweep, because it+happens bottom-up++      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> case b of c {+                                     DEFAULT -> e+                                     A -> ea+                      B -> eb+        C -> ec+==>+      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> let c = b in e+                      A -> let c = b in ea+                      B -> eb+        C -> ec+==>+      case e of a {+        DEFAULT -> let b = a in let c = b in e+        A -> let b = a in let c = b in ea+        B -> let b = a in eb+        C -> ec+++However here's a tricky case that we still don't catch, and I don't+see how to catch it in one pass:++  case x of c1 { I# a1 ->+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case x of c3 { I# a2 ->+               case a2 of ...++After occurrence analysis (and its binder-swap) we get this++  case x of c1 { I# a1 ->+  let x = c1 in         -- Binder-swap addition+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case x of c3 { I# a2 ->+               case a2 of ...++When we simplify the inner case x, we'll see that+x=c1=I# a1.  So we'll bind a2 to a1, and get++  case x of c1 { I# a1 ->+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case a1 of ...++This is correct, but we can't do a case merge in this sweep+because c2 /= a1.  Reason: the binding c1=I# a1 went inwards+without getting changed to c1=I# c2.++I don't think this is worth fixing, even if I knew how. It'll+all come out in the next pass anyway.+-}
+ compiler/GHC/Core/Op/SpecConstr.hs view
@@ -0,0 +1,2360 @@+{-+ToDo [Oct 2013]+~~~~~~~~~~~~~~~+1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim)+2. Nuke NoSpecConstr+++(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[SpecConstr]{Specialise over constructors}+-}++{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Core.Op.SpecConstr(+        specConstrProgram,+        SpecConstrAnnotation(..)+    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core+import GHC.Core.Subst+import GHC.Core.Utils+import GHC.Core.Unfold  ( couldBeSmallEnoughToInline )+import GHC.Core.FVs     ( exprsFreeVarsList )+import GHC.Core.Op.Monad+import GHC.Types.Literal ( litIsLifted )+import GHC.Driver.Types ( ModGuts(..) )+import GHC.Core.Op.WorkWrap.Lib ( isWorkerSmallEnough, mkWorkerArgs )+import GHC.Core.DataCon+import GHC.Core.Coercion hiding( substCo )+import GHC.Core.Rules+import GHC.Core.Type     hiding ( substTy )+import GHC.Core.TyCon   ( tyConName )+import GHC.Types.Id+import GHC.Core.Ppr     ( pprParendExpr )+import GHC.Core.Make    ( mkImpossibleExpr )+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Basic+import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )+                          , gopt, hasPprDebug )+import Maybes           ( orElse, catMaybes, isJust, isNothing )+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Serialized   ( deserializeWithData )+import Util+import Pair+import GHC.Types.Unique.Supply+import Outputable+import FastString+import GHC.Types.Unique.FM+import MonadUtils+import Control.Monad    ( zipWithM )+import Data.List+import PrelNames        ( specTyConName )+import GHC.Types.Module+import GHC.Core.TyCon ( TyCon )+import GHC.Exts( SpecConstrAnnotation(..) )+import Data.Ord( comparing )++{-+-----------------------------------------------------+                        Game plan+-----------------------------------------------------++Consider+        drop n []     = []+        drop 0 xs     = []+        drop n (x:xs) = drop (n-1) xs++After the first time round, we could pass n unboxed.  This happens in+numerical code too.  Here's what it looks like in Core:++        drop n xs = case xs of+                      []     -> []+                      (y:ys) -> case n of+                                  I# n# -> case n# of+                                             0 -> []+                                             _ -> drop (I# (n# -# 1#)) xs++Notice that the recursive call has an explicit constructor as argument.+Noticing this, we can make a specialised version of drop++        RULE: drop (I# n#) xs ==> drop' n# xs++        drop' n# xs = let n = I# n# in ...orig RHS...++Now the simplifier will apply the specialisation in the rhs of drop', giving++        drop' n# xs = case xs of+                      []     -> []+                      (y:ys) -> case n# of+                                  0 -> []+                                  _ -> drop' (n# -# 1#) xs++Much better!++We'd also like to catch cases where a parameter is carried along unchanged,+but evaluated each time round the loop:++        f i n = if i>0 || i>n then i else f (i*2) n++Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.+In Core, by the time we've w/wd (f is strict in i) we get++        f i# n = case i# ># 0 of+                   False -> I# i#+                   True  -> case n of { I# n# ->+                            case i# ># n# of+                                False -> I# i#+                                True  -> f (i# *# 2#) n++At the call to f, we see that the argument, n is known to be (I# n#),+and n is evaluated elsewhere in the body of f, so we can play the same+trick as above.+++Note [Reboxing]+~~~~~~~~~~~~~~~+We must be careful not to allocate the same constructor twice.  Consider+        f p = (...(case p of (a,b) -> e)...p...,+               ...let t = (r,s) in ...t...(f t)...)+At the recursive call to f, we can see that t is a pair.  But we do NOT want+to make a specialised copy:+        f' a b = let p = (a,b) in (..., ...)+because now t is allocated by the caller, then r and s are passed to the+recursive call, which allocates the (r,s) pair again.++This happens if+  (a) the argument p is used in other than a case-scrutinisation way.+  (b) the argument to the call is not a 'fresh' tuple; you have to+        look into its unfolding to see that it's a tuple++Hence the "OR" part of Note [Good arguments] below.++ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves+allocation, but does perhaps save evals. In the RULE we'd have+something like++  f (I# x#) = f' (I# x#) x#++If at the call site the (I# x) was an unfolding, then we'd have to+rely on CSE to eliminate the duplicate allocation.... This alternative+doesn't look attractive enough to pursue.++ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that+the conservative reboxing story prevents many useful functions from being+specialised.  Example:+        foo :: Maybe Int -> Int -> Int+        foo   (Just m) 0 = 0+        foo x@(Just m) n = foo x (n-m)+Here the use of 'x' will clearly not require boxing in the specialised function.++The strictness analyser has the same problem, in fact.  Example:+        f p@(a,b) = ...+If we pass just 'a' and 'b' to the worker, it might need to rebox the+pair to create (a,b).  A more sophisticated analysis might figure out+precisely the cases in which this could happen, but the strictness+analyser does no such analysis; it just passes 'a' and 'b', and hopes+for the best.++So my current choice is to make SpecConstr similarly aggressive, and+ignore the bad potential of reboxing.+++Note [Good arguments]+~~~~~~~~~~~~~~~~~~~~~+So we look for++* A self-recursive function.  Ignore mutual recursion for now,+  because it's less common, and the code is simpler for self-recursion.++* EITHER++   a) At a recursive call, one or more parameters is an explicit+      constructor application+        AND+      That same parameter is scrutinised by a case somewhere in+      the RHS of the function++  OR++    b) At a recursive call, one or more parameters has an unfolding+       that is an explicit constructor application+        AND+      That same parameter is scrutinised by a case somewhere in+      the RHS of the function+        AND+      Those are the only uses of the parameter (see Note [Reboxing])+++What to abstract over+~~~~~~~~~~~~~~~~~~~~~+There's a bit of a complication with type arguments.  If the call+site looks like++        f p = ...f ((:) [a] x xs)...++then our specialised function look like++        f_spec x xs = let p = (:) [a] x xs in ....as before....++This only makes sense if either+  a) the type variable 'a' is in scope at the top of f, or+  b) the type variable 'a' is an argument to f (and hence fs)++Actually, (a) may hold for value arguments too, in which case+we may not want to pass them.  Suppose 'x' is in scope at f's+defn, but xs is not.  Then we'd like++        f_spec xs = let p = (:) [a] x xs in ....as before....++Similarly (b) may hold too.  If x is already an argument at the+call, no need to pass it again.++Finally, if 'a' is not in scope at the call site, we could abstract+it as we do the term variables:++        f_spec a x xs = let p = (:) [a] x xs in ...as before...++So the grand plan is:++        * abstract the call site to a constructor-only pattern+          e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)++        * Find the free variables of the abstracted pattern++        * Pass these variables, less any that are in scope at+          the fn defn.  But see Note [Shadowing] below.+++NOTICE that we only abstract over variables that are not in scope,+so we're in no danger of shadowing variables used in "higher up"+in f_spec's RHS.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+In this pass we gather up usage information that may mention variables+that are bound between the usage site and the definition site; or (more+seriously) may be bound to something different at the definition site.+For example:++        f x = letrec g y v = let x = ...+                             in ...(g (a,b) x)...++Since 'x' is in scope at the call site, we may make a rewrite rule that+looks like+        RULE forall a,b. g (a,b) x = ...+But this rule will never match, because it's really a different 'x' at+the call site -- and that difference will be manifest by the time the+simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*+no-shadowing, so perhaps it may not be distinct?]++Anyway, the rule isn't actually wrong, it's just not useful.  One possibility+is to run deShadowBinds before running SpecConstr, but instead we run the+simplifier.  That gives the simplest possible program for SpecConstr to+chew on; and it virtually guarantees no shadowing.++Note [Specialising for constant parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This one is about specialising on a *constant* (but not necessarily+constructor) argument++    foo :: Int -> (Int -> Int) -> Int+    foo 0 f = 0+    foo m f = foo (f m) (+1)++It produces++    lvl_rmV :: GHC.Base.Int -> GHC.Base.Int+    lvl_rmV =+      \ (ds_dlk :: GHC.Base.Int) ->+        case ds_dlk of wild_alH { GHC.Base.I# x_alG ->+        GHC.Base.I# (GHC.Prim.+# x_alG 1)++    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->+    GHC.Prim.Int#+    T.$wfoo =+      \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->+        case ww_sme of ds_Xlw {+          __DEFAULT ->+        case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->+        T.$wfoo ww1_Xmz lvl_rmV+        };+          0 -> 0+        }++The recursive call has lvl_rmV as its argument, so we could create a specialised copy+with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.++When is this worth it?  Call the constant 'lvl'+- If 'lvl' has an unfolding that is a constructor, see if the corresponding+  parameter is scrutinised anywhere in the body.++- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding+  parameter is applied (...to enough arguments...?)++  Also do this is if the function has RULES?++Also++Note [Specialising for lambda parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    foo :: Int -> (Int -> Int) -> Int+    foo 0 f = 0+    foo m f = foo (f m) (\n -> n-m)++This is subtly different from the previous one in that we get an+explicit lambda as the argument:++    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->+    GHC.Prim.Int#+    T.$wfoo =+      \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->+        case ww_sm8 of ds_Xlr {+          __DEFAULT ->+        case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->+        T.$wfoo+          ww1_Xmq+          (\ (n_ad3 :: GHC.Base.Int) ->+             case n_ad3 of wild_alB { GHC.Base.I# x_alA ->+             GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)+             })+        };+          0 -> 0+        }++I wonder if SpecConstr couldn't be extended to handle this? After all,+lambda is a sort of constructor for functions and perhaps it already+has most of the necessary machinery?++Furthermore, there's an immediate win, because you don't need to allocate the lambda+at the call site; and if perchance it's called in the recursive call, then you+may avoid allocating it altogether.  Just like for constructors.++Looks cool, but probably rare...but it might be easy to implement.+++Note [SpecConstr for casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    data family T a :: *+    data instance T Int = T Int++    foo n = ...+       where+         go (T 0) = 0+         go (T n) = go (T (n-1))++The recursive call ends up looking like+        go (T (I# ...) `cast` g)+So we want to spot the constructor application inside the cast.+That's why we have the Cast case in argToPat++Note [Local recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a *local* recursive group, we can see all the calls to the+function, so we seed the specialisation loop from the calls in the+body, not from the calls in the RHS.  Consider:++  bar m n = foo n (n,n) (n,n) (n,n) (n,n)+   where+     foo n p q r s+       | n == 0    = m+       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }+       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }+       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }+       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }++If we start with the RHSs of 'foo', we get lots and lots of specialisations,+most of which are not needed.  But if we start with the (single) call+in the rhs of 'bar' we get exactly one fully-specialised copy, and all+the recursive calls go to this fully-specialised copy. Indeed, the original+function is later collected as dead code.  This is very important in+specialising the loops arising from stream fusion, for example in NDP where+we were getting literally hundreds of (mostly unused) specialisations of+a local function.++In a case like the above we end up never calling the original un-specialised+function.  (Although we still leave its code around just in case.)++However, if we find any boring calls in the body, including *unsaturated*+ones, such as+      letrec foo x y = ....foo...+      in map foo xs+then we will end up calling the un-specialised function, so then we *should*+use the calls in the un-specialised RHS as seeds.  We call these+"boring call patterns", and callsToPats reports if it finds any of these.++Note [Seeding top-level recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This seeding is done in the binding for seed_calls in specRec.++1. If all the bindings in a top-level recursive group are local (not+   exported), then all the calls are in the rest of the top-level+   bindings.  This means we can specialise with those call patterns+   ONLY, and NOT with the RHSs of the recursive group (exactly like+   Note [Local recursive groups])++2. But if any of the bindings are exported, the function may be called+   with any old arguments, so (for lack of anything better) we specialise+   based on+     (a) the call patterns in the RHS+     (b) the call patterns in the rest of the top-level bindings+   NB: before Apr 15 we used (a) only, but Dimitrios had an example+       where (b) was crucial, so I added that.+       Adding (b) also improved nofib allocation results:+                  multiplier: 4%   better+                  minimax:    2.8% better++Actually in case (2), instead of using the calls from the RHS, it+would be better to specialise in the importing module.  We'd need to+add an INLINABLE pragma to the function, and then it can be+specialised in the importing scope, just as is done for type classes+in GHC.Core.Op.Specialise.specImports. This remains to be done (#10346).++Note [Top-level recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To get the call usage information from "the rest of the top level+bindings" (c.f. Note [Seeding top-level recursive groups]), we work+backwards through the top-level bindings so we see the usage before we+get to the binding of the function.  Before we can collect the usage+though, we go through all the bindings and add them to the+environment. This is necessary because usage is only tracked for+functions in the environment.  These two passes are called+   'go' and 'goEnv'+in specConstrProgram.  (Looks a bit revolting to me.)++Note [Do not specialise diverging functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Specialising a function that just diverges is a waste of code.+Furthermore, it broke GHC (simpl014) thus:+   {-# STR Sb #-}+   f = \x. case x of (a,b) -> f x+If we specialise f we get+   f = \x. case x of (a,b) -> fspec a b+But fspec doesn't have decent strictness info.  As it happened,+(f x) :: IO t, so the state hack applied and we eta expanded fspec,+and hence f.  But now f's strictness is less than its arity, which+breaks an invariant.+++Note [Forcing specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With stream fusion and in other similar cases, we want to fully+specialise some (but not necessarily all!) loops regardless of their+size and the number of specialisations.++We allow a library to do this, in one of two ways (one which is+deprecated):++  1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body.++  2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts,+     and then add *that* type as a parameter to the loop body++The reason #2 is deprecated is because it requires GHCi, which isn't+available for things like a cross compiler using stage1.++Here's a (simplified) example from the `vector` package. You may bring+the special 'force specialization' type into scope by saying:++  import GHC.Types (SPEC(..))++or by defining your own type (again, deprecated):++  data SPEC = SPEC | SPEC2+  {-# ANN type SPEC ForceSpecConstr #-}++(Note this is the exact same definition of GHC.Types.SPEC, just+without the annotation.)++After that, you say:++  foldl :: (a -> b -> a) -> a -> Stream b -> a+  {-# INLINE foldl #-}+  foldl f z (Stream step s _) = foldl_loop SPEC z s+    where+      foldl_loop !sPEC z s = case step s of+                              Yield x s' -> foldl_loop sPEC (f z x) s'+                              Skip       -> foldl_loop sPEC z s'+                              Done       -> z++SpecConstr will spot the SPEC parameter and always fully specialise+foldl_loop. Note that++  * We have to prevent the SPEC argument from being removed by+    w/w which is why (a) SPEC is a sum type, and (b) we have to seq on+    the SPEC argument.++  * And lastly, the SPEC argument is ultimately eliminated by+    SpecConstr itself so there is no runtime overhead.++This is all quite ugly; we ought to come up with a better design.++ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set+sc_force to True when calling specLoop. This flag does four things:++  * Ignore specConstrThreshold, to specialise functions of arbitrary size+        (see scTopBind)+  * Ignore specConstrCount, to make arbitrary numbers of specialisations+        (see specialise)+  * Specialise even for arguments that are not scrutinised in the loop+        (see argToPat; #4448)+  * Only specialise on recursive types a finite number of times+        (see is_too_recursive; #5550; Note [Limit recursive specialisation])++The flag holds only for specialising a single binding group, and NOT+for nested bindings.  (So really it should be passed around explicitly+and not stored in ScEnv.)  #14379 turned out to be caused by+   f SPEC x = let g1 x = ...+              in ...+We force-specialise f (because of the SPEC), but that generates a specialised+copy of g1 (as well as the original).  Alas g1 has a nested binding g2; and+in each copy of g1 we get an unspecialised and specialised copy of g2; and so+on. Result, exponential.  So the force-spec flag now only applies to one+level of bindings at a time.++Mechanism for this one-level-only thing:++ - Switch it on at the call to specRec, in scExpr and scTopBinds+ - Switch it off when doing the RHSs;+   this can be done very conveniently in decreaseSpecCount++What alternatives did I consider?++* Annotating the loop itself doesn't work because (a) it is local and+  (b) it will be w/w'ed and having w/w propagating annotations somehow+  doesn't seem like a good idea. The types of the loop arguments+  really seem to be the most persistent thing.++* Annotating the types that make up the loop state doesn't work,+  either, because (a) it would prevent us from using types like Either+  or tuples here, (b) we don't want to restrict the set of types that+  can be used in Stream states and (c) some types are fixed by the+  user (e.g., the accumulator here) but we still want to specialise as+  much as possible.++Alternatives to ForceSpecConstr+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of giving the loop an extra argument of type SPEC, we+also considered *wrapping* arguments in SPEC, thus+  data SPEC a = SPEC a | SPEC2++  loop = \arg -> case arg of+                     SPEC state ->+                        case state of (x,y) -> ... loop (SPEC (x',y')) ...+                        S2 -> error ...+The idea is that a SPEC argument says "specialise this argument+regardless of whether the function case-analyses it".  But this+doesn't work well:+  * SPEC must still be a sum type, else the strictness analyser+    eliminates it+  * But that means that 'loop' won't be strict in its real payload+This loss of strictness in turn screws up specialisation, because+we may end up with calls like+   loop (SPEC (case z of (p,q) -> (q,p)))+Without the SPEC, if 'loop' were strict, the case would move out+and we'd see loop applied to a pair. But if 'loop' isn't strict+this doesn't look like a specialisable call.++Note [Limit recursive specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is possible for ForceSpecConstr to cause an infinite loop of specialisation.+Because there is no limit on the number of specialisations, a recursive call with+a recursive constructor as an argument (for example, list cons) will generate+a specialisation for that constructor. If the resulting specialisation also+contains a recursive call with the constructor, this could proceed indefinitely.++For example, if ForceSpecConstr is on:+  loop :: [Int] -> [Int] -> [Int]+  loop z []         = z+  loop z (x:xs)     = loop (x:z) xs+this example will create a specialisation for the pattern+  loop (a:b) c      = loop' a b c++  loop' a b []      = (a:b)+  loop' a b (x:xs)  = loop (x:(a:b)) xs+and a new pattern is found:+  loop (a:(b:c)) d  = loop'' a b c d+which can continue indefinitely.++Roman's suggestion to fix this was to stop after a couple of times on recursive types,+but still specialising on non-recursive types as much as possible.++To implement this, we count the number of times we have gone round the+"specialise recursively" loop ('go' in 'specRec').  Once have gone round+more than N times (controlled by -fspec-constr-recursive=N) we check++  - If sc_force is off, and sc_count is (Just max) then we don't+    need to do anything: trim_pats will limit the number of specs++  - Otherwise check if any function has now got more than (sc_count env)+    specialisations.  If sc_count is "no limit" then we arbitrarily+    choose 10 as the limit (ugh).++See #5550.   Also #13623, where this test had become over-aggressive,+and we lost a wonderful specialisation that we really wanted!++Note [NoSpecConstr]+~~~~~~~~~~~~~~~~~~~+The ignoreDataCon stuff allows you to say+    {-# ANN type T NoSpecConstr #-}+to mean "don't specialise on arguments of this type".  It was added+before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised+regardless of size; and then we needed a way to turn that *off*.  Now+that we have ForceSpecConstr, this NoSpecConstr is probably redundant.+(Used only for PArray, TODO: remove?)++-----------------------------------------------------+                Stuff not yet handled+-----------------------------------------------------++Here are notes arising from Roman's work that I don't want to lose.++Example 1+~~~~~~~~~+    data T a = T !a++    foo :: Int -> T Int -> Int+    foo 0 t = 0+    foo x t | even x    = case t of { T n -> foo (x-n) t }+            | otherwise = foo (x-1) t++SpecConstr does no specialisation, because the second recursive call+looks like a boxed use of the argument.  A pity.++    $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#+    $wfoo_sFw =+      \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->+         case ww_sFo of ds_Xw6 [Just L] {+           __DEFAULT ->+                case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {+                  __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;+                  0 ->+                    case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->+                    case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->+                    $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy+                    } } };+           0 -> 0++Example 2+~~~~~~~~~+    data a :*: b = !a :*: !b+    data T a = T !a++    foo :: (Int :*: T Int) -> Int+    foo (0 :*: t) = 0+    foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }+                  | otherwise = foo ((x-1) :*: t)++Very similar to the previous one, except that the parameters are now in+a strict tuple. Before SpecConstr, we have++    $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#+    $wfoo_sG3 =+      \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T+    GHC.Base.Int) ->+        case ww_sFU of ds_Xws [Just L] {+          __DEFAULT ->+        case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {+          __DEFAULT ->+            case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->+            $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1+            };+          0 ->+            case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->+            case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->+            $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2+            } } };+          0 -> 0 }++We get two specialisations:+"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)+                  = Foo.$s$wfoo1 a_sFB sc_sGC ;+"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))+                  = Foo.$s$wfoo y_aFp sc_sGC ;++But perhaps the first one isn't good.  After all, we know that tpl_B2 is+a T (I# x) really, because T is strict and Int has one constructor.  (We can't+unbox the strict fields, because T is polymorphic!)++************************************************************************+*                                                                      *+\subsection{Top level wrapper stuff}+*                                                                      *+************************************************************************+-}++specConstrProgram :: ModGuts -> CoreM ModGuts+specConstrProgram guts+  = do+      dflags <- getDynFlags+      us     <- getUniqueSupplyM+      (_, annos) <- getFirstAnnotations deserializeWithData guts+      this_mod <- getModule+      let binds' = reverse $ fst $ initUs us $ do+                    -- Note [Top-level recursive groups]+                    (env, binds) <- goEnv (initScEnv dflags this_mod annos)+                                          (mg_binds guts)+                        -- binds is identical to (mg_binds guts), except that the+                        -- binders on the LHS have been replaced by extendBndr+                        --   (SPJ this seems like overkill; I don't think the binders+                        --    will change at all; and we don't substitute in the RHSs anyway!!)+                    go env nullUsage (reverse binds)++      return (guts { mg_binds = binds' })+  where+    -- See Note [Top-level recursive groups]+    goEnv env []            = return (env, [])+    goEnv env (bind:binds)  = do (env', bind')   <- scTopBindEnv env bind+                                 (env'', binds') <- goEnv env' binds+                                 return (env'', bind' : binds')++    -- Arg list of bindings is in reverse order+    go _   _   []           = return []+    go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind+                                 binds' <- go env usg' binds+                                 return (bind' : binds')++{-+************************************************************************+*                                                                      *+\subsection{Environment: goes downwards}+*                                                                      *+************************************************************************++Note [Work-free values only in environment]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_vals field keeps track of in-scope value bindings, so+that if we come across (case x of Just y ->...) we can reduce the+case from knowing that x is bound to a pair.++But only *work-free* values are ok here. For example if the envt had+    x -> Just (expensive v)+then we do NOT want to expand to+     let y = expensive v in ...+because the x-binding still exists and we've now duplicated (expensive v).++This seldom happens because let-bound constructor applications are+ANF-ised, but it can happen as a result of on-the-fly transformations in+SpecConstr itself.  Here is #7865:++        let {+          a'_shr =+            case xs_af8 of _ {+              [] -> acc_af6;+              : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] ->+                (expensive x_af7, x_af7+            } } in+        let {+          ds_sht =+            case a'_shr of _ { (p'_afd, q'_afe) ->+            TSpecConstr_DoubleInline.recursive+              (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd)+            } } in++When processed knowing that xs_af8 was bound to a cons, we simplify to+   a'_shr = (expensive x_af7, x_af7)+and we do NOT want to inline that at the occurrence of a'_shr in ds_sht.+(There are other occurrences of a'_shr.)  No no no.++It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned+into a work-free value again, thus+   a1 = expensive x_af7+   a'_shr = (a1, x_af7)+but that's more work, so until its shown to be important I'm going to+leave it for now.++Note [Making SpecConstr keener]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this, in (perf/should_run/T9339)+   last (filter odd [1..1000])++After optimisation, including SpecConstr, we get:+   f :: Int# -> Int -> Int+   f x y = case case remInt# x 2# of+             __DEFAULT -> case x of+                            __DEFAULT -> f (+# wild_Xp 1#) (I# x)+                            1000000# -> ...+             0# -> case x of+                     __DEFAULT -> f (+# wild_Xp 1#) y+                    1000000#   -> y++Not good!  We build an (I# x) box every time around the loop.+SpecConstr (as described in the paper) does not specialise f, despite+the call (f ... (I# x)) because 'y' is not scrutinised in the body.+But it is much better to specialise f for the case where the argument+is of form (I# x); then we build the box only when returning y, which+is on the cold path.++Another example:++   f x = ...(g x)....++Here 'x' is not scrutinised in f's body; but if we did specialise 'f'+then the call (g x) might allow 'g' to be specialised in turn.++So sc_keen controls whether or not we take account of whether argument is+scrutinised in the body.  True <=> ignore that, and specialise whenever+the function is applied to a data constructor.+-}++data ScEnv = SCE { sc_dflags    :: DynFlags,+                   sc_module    :: !Module,+                   sc_size      :: Maybe Int,   -- Size threshold+                                                -- Nothing => no limit++                   sc_count     :: Maybe Int,   -- Max # of specialisations for any one fn+                                                -- Nothing => no limit+                                                -- See Note [Avoiding exponential blowup]++                   sc_recursive :: Int,         -- Max # of specialisations over recursive type.+                                                -- Stops ForceSpecConstr from diverging.++                   sc_keen     :: Bool,         -- Specialise on arguments that are known+                                                -- constructors, even if they are not+                                                -- scrutinised in the body.  See+                                                -- Note [Making SpecConstr keener]++                   sc_force     :: Bool,        -- Force specialisation?+                                                -- See Note [Forcing specialisation]++                   sc_subst     :: Subst,       -- Current substitution+                                                -- Maps InIds to OutExprs++                   sc_how_bound :: HowBoundEnv,+                        -- Binds interesting non-top-level variables+                        -- Domain is OutVars (*after* applying the substitution)++                   sc_vals      :: ValueEnv,+                        -- Domain is OutIds (*after* applying the substitution)+                        -- Used even for top-level bindings (but not imported ones)+                        -- The range of the ValueEnv is *work-free* values+                        -- such as (\x. blah), or (Just v)+                        -- but NOT (Just (expensive v))+                        -- See Note [Work-free values only in environment]++                   sc_annotations :: UniqFM SpecConstrAnnotation+             }++---------------------+type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars++---------------------+type ValueEnv = IdEnv Value             -- Domain is OutIds+data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors+                                        --   The AltCon is never DEFAULT+              | LambdaVal               -- Inlinable lambdas or PAPs++instance Outputable Value where+   ppr (ConVal con args) = ppr con <+> interpp'SP args+   ppr LambdaVal         = text "<Lambda>"++---------------------+initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv+initScEnv dflags this_mod anns+  = SCE { sc_dflags      = dflags,+          sc_module      = this_mod,+          sc_size        = specConstrThreshold dflags,+          sc_count       = specConstrCount     dflags,+          sc_recursive   = specConstrRecursive dflags,+          sc_keen        = gopt Opt_SpecConstrKeen dflags,+          sc_force       = False,+          sc_subst       = emptySubst,+          sc_how_bound   = emptyVarEnv,+          sc_vals        = emptyVarEnv,+          sc_annotations = anns }++data HowBound = RecFun  -- These are the recursive functions for which+                        -- we seek interesting call patterns++              | RecArg  -- These are those functions' arguments, or their sub-components;+                        -- we gather occurrence information for these++instance Outputable HowBound where+  ppr RecFun = text "RecFun"+  ppr RecArg = text "RecArg"++scForce :: ScEnv -> Bool -> ScEnv+scForce env b = env { sc_force = b }++lookupHowBound :: ScEnv -> Id -> Maybe HowBound+lookupHowBound env id = lookupVarEnv (sc_how_bound env) id++scSubstId :: ScEnv -> Id -> CoreExpr+scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v++scSubstTy :: ScEnv -> Type -> Type+scSubstTy env ty = substTy (sc_subst env) ty++scSubstCo :: ScEnv -> Coercion -> Coercion+scSubstCo env co = substCo (sc_subst env) co++zapScSubst :: ScEnv -> ScEnv+zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }++extendScInScope :: ScEnv -> [Var] -> ScEnv+        -- Bring the quantified variables into scope+extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }++        -- Extend the substitution+extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv+extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }++extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv+extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }++extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv+extendHowBound env bndrs how_bound+  = env { sc_how_bound = extendVarEnvList (sc_how_bound env)+                            [(bndr,how_bound) | bndr <- bndrs] }++extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])+extendBndrsWith how_bound env bndrs+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')+  where+    (subst', bndrs') = substBndrs (sc_subst env) bndrs+    hb_env' = sc_how_bound env `extendVarEnvList`+                    [(bndr,how_bound) | bndr <- bndrs']++extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)+extendBndrWith how_bound env bndr+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')+  where+    (subst', bndr') = substBndr (sc_subst env) bndr+    hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound++extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])+extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')+                      where+                        (subst', bndrs') = substRecBndrs (sc_subst env) bndrs++extendBndr :: ScEnv -> Var -> (ScEnv, Var)+extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')+                      where+                        (subst', bndr') = substBndr (sc_subst env) bndr++extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv+extendValEnv env _  Nothing   = env+extendValEnv env id (Just cv)+ | valueIsWorkFree cv      -- Don't duplicate work!!  #7865+ = env { sc_vals = extendVarEnv (sc_vals env) id cv }+extendValEnv env _ _ = env++extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])+-- When we encounter+--      case scrut of b+--          C x y -> ...+-- we want to bind b, to (C x y)+-- NB1: Extends only the sc_vals part of the envt+-- NB2: Kill the dead-ness info on the pattern binders x,y, since+--      they are potentially made alive by the [b -> C x y] binding+extendCaseBndrs env scrut case_bndr con alt_bndrs+   = (env2, alt_bndrs')+ where+   live_case_bndr = not (isDeadBinder case_bndr)+   env1 | Var v <- stripTicksTopE (const True) scrut+                         = extendValEnv env v cval+        | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]+   env2 | live_case_bndr = extendValEnv env1 case_bndr cval+        | otherwise      = env1++   alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }+              = map zap alt_bndrs+              | otherwise+              = alt_bndrs++   cval = case con of+                DEFAULT    -> Nothing+                LitAlt {}  -> Just (ConVal con [])+                DataAlt {} -> Just (ConVal con vanilla_args)+                      where+                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) +++                                       varsToCoreExprs alt_bndrs++   zap v | isTyVar v = v                -- See NB2 above+         | otherwise = zapIdOccInfo v+++decreaseSpecCount :: ScEnv -> Int -> ScEnv+-- See Note [Avoiding exponential blowup]+decreaseSpecCount env n_specs+  = env { sc_force = False   -- See Note [Forcing specialisation]+        , sc_count = case sc_count env of+                       Nothing -> Nothing+                       Just n  -> Just (n `div` (n_specs + 1)) }+        -- The "+1" takes account of the original function;+        -- See Note [Avoiding exponential blowup]++---------------------------------------------------+-- See Note [Forcing specialisation]+ignoreType    :: ScEnv -> Type   -> Bool+ignoreDataCon  :: ScEnv -> DataCon -> Bool+forceSpecBndr :: ScEnv -> Var    -> Bool++ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)++ignoreType env ty+  = case tyConAppTyCon_maybe ty of+      Just tycon -> ignoreTyCon env tycon+      _          -> False++ignoreTyCon :: ScEnv -> TyCon -> Bool+ignoreTyCon env tycon+  = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr++forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var++forceSpecFunTy :: ScEnv -> Type -> Bool+forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys++forceSpecArgTy :: ScEnv -> Type -> Bool+forceSpecArgTy env ty+  | Just ty' <- coreView ty = forceSpecArgTy env ty'++forceSpecArgTy env ty+  | Just (tycon, tys) <- splitTyConApp_maybe ty+  , tycon /= funTyCon+      = tyConName tycon == specTyConName+        || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr+        || any (forceSpecArgTy env) tys++forceSpecArgTy _ _ = False++{-+Note [Add scrutinee to ValueEnv too]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+   case x of y+     (a,b) -> case b of c+                I# v -> ...(f y)...+By the time we get to the call (f y), the ValueEnv+will have a binding for y, and for c+    y -> (a,b)+    c -> I# v+BUT that's not enough!  Looking at the call (f y) we+see that y is pair (a,b), but we also need to know what 'b' is.+So in extendCaseBndrs we must *also* add the binding+   b -> I# v+else we lose a useful specialisation for f.  This is necessary even+though the simplifier has systematically replaced uses of 'x' with 'y'+and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came+from outside the case.  See #4908 for the live example.++Note [Avoiding exponential blowup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_count field of the ScEnv says how many times we are prepared to+duplicate a single function.  But we must take care with recursive+specialisations.  Consider++        let $j1 = let $j2 = let $j3 = ...+                            in+                            ...$j3...+                  in+                  ...$j2...+        in+        ...$j1...++If we specialise $j1 then in each specialisation (as well as the original)+we can specialise $j2, and similarly $j3.  Even if we make just *one*+specialisation of each, because we also have the original we'll get 2^n+copies of $j3, which is not good.++So when recursively specialising we divide the sc_count by the number of+copies we are making at this level, including the original.+++************************************************************************+*                                                                      *+\subsection{Usage information: flows upwards}+*                                                                      *+************************************************************************+-}++data ScUsage+   = SCU {+        scu_calls :: CallEnv,           -- Calls+                                        -- The functions are a subset of the+                                        --      RecFuns in the ScEnv++        scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences+     }                                  -- The domain is OutIds++type CallEnv = IdEnv [Call]+data Call = Call Id [CoreArg] ValueEnv+        -- The arguments of the call, together with the+        -- env giving the constructor bindings at the call site+        -- We keep the function mainly for debug output++instance Outputable ScUsage where+  ppr (SCU { scu_calls = calls, scu_occs = occs })+    = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls+                                         , text "occs =" <+> ppr occs ])++instance Outputable Call where+  ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)++nullUsage :: ScUsage+nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }++combineCalls :: CallEnv -> CallEnv -> CallEnv+combineCalls = plusVarEnv_C (++)+  where+--    plus cs ds | length res > 1+--               = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs+--                                               , text "ds:" <+> ppr ds])+--                 res+--               | otherwise = res+--       where+--          res = cs ++ ds++combineUsage :: ScUsage -> ScUsage -> ScUsage+combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),+                           scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }++combineUsages :: [ScUsage] -> ScUsage+combineUsages [] = nullUsage+combineUsages us = foldr1 combineUsage us++lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])+lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs+  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},+     [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])++data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument+            | UnkOcc    -- Used in some unknown way++            | ScrutOcc  -- See Note [ScrutOcc]+                 (DataConEnv [ArgOcc])   -- How the sub-components are used++type DataConEnv a = UniqFM a     -- Keyed by DataCon++{- Note  [ScrutOcc]+~~~~~~~~~~~~~~~~~~~+An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,+is *only* taken apart or applied.++  Functions, literal: ScrutOcc emptyUFM+  Data constructors:  ScrutOcc subs,++where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,+The domain of the UniqFM is the Unique of the data constructor++The [ArgOcc] is the occurrences of the *pattern-bound* components+of the data structure.  E.g.+        data T a = forall b. MkT a b (b->a)+A pattern binds b, x::a, y::b, z::b->a, but not 'a'!++-}++instance Outputable ArgOcc where+  ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs+  ppr UnkOcc        = text "unk-occ"+  ppr NoOcc         = text "no-occ"++evalScrutOcc :: ArgOcc+evalScrutOcc = ScrutOcc emptyUFM++-- Experimentally, this version of combineOcc makes ScrutOcc "win", so+-- that if the thing is scrutinised anywhere then we get to see that+-- in the overall result, even if it's also used in a boxed way+-- This might be too aggressive; see Note [Reboxing] Alternative 3+combineOcc :: ArgOcc -> ArgOcc -> ArgOcc+combineOcc NoOcc         occ           = occ+combineOcc occ           NoOcc         = occ+combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)+combineOcc UnkOcc        (ScrutOcc ys) = ScrutOcc ys+combineOcc (ScrutOcc xs) UnkOcc        = ScrutOcc xs+combineOcc UnkOcc        UnkOcc        = UnkOcc++combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]+combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys++setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage+-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee+-- is a variable, and an interesting variable+setScrutOcc env usg (Cast e _) occ      = setScrutOcc env usg e occ+setScrutOcc env usg (Tick _ e) occ      = setScrutOcc env usg e occ+setScrutOcc env usg (Var v)    occ+  | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }+  | otherwise                           = usg+setScrutOcc _env usg _other _occ        -- Catch-all+  = usg++{-+************************************************************************+*                                                                      *+\subsection{The main recursive function}+*                                                                      *+************************************************************************++The main recursive function gathers up usage information, and+creates specialised versions of functions.+-}++scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)+        -- The unique supply is needed when we invent+        -- a new name for the specialised function and its args++scExpr env e = scExpr' env e++scExpr' env (Var v)      = case scSubstId env v of+                            Var v' -> return (mkVarUsage env v' [], Var v')+                            e'     -> scExpr (zapScSubst env) e'++scExpr' env (Type t)     = return (nullUsage, Type (scSubstTy env t))+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))+scExpr' _   e@(Lit {})   = return (nullUsage, e)+scExpr' env (Tick t e)   = do (usg, e') <- scExpr env e+                              return (usg, Tick t e')+scExpr' env (Cast e co)  = do (usg, e') <- scExpr env e+                              return (usg, mkCast e' (scSubstCo env co))+                              -- Important to use mkCast here+                              -- See Note [SpecConstr call patterns]+scExpr' env e@(App _ _)  = scApp env (collectArgs e)+scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b+                              (usg, e') <- scExpr env' e+                              return (usg, Lam b' e')++scExpr' env (Case scrut b ty alts)+  = do  { (scrut_usg, scrut') <- scExpr env scrut+        ; case isValue (sc_vals env) scrut' of+                Just (ConVal con args) -> sc_con_app con args scrut'+                _other                 -> sc_vanilla scrut_usg scrut'+        }+  where+    sc_con_app con args scrut'  -- Known constructor; simplify+     = do { let (_, bs, rhs) = findAlt con alts+                                  `orElse` (DEFAULT, [], mkImpossibleExpr ty)+                alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)+          ; scExpr alt_env' rhs }++    sc_vanilla scrut_usg scrut' -- Normal case+     = do { let (alt_env,b') = extendBndrWith RecArg env b+                        -- Record RecArg for the components++          ; (alt_usgs, alt_occs, alts')+                <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts++          ; let scrut_occ  = foldr combineOcc NoOcc alt_occs+                scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ+                -- The combined usage of the scrutinee is given+                -- by scrut_occ, which is passed to scScrut, which+                -- in turn treats a bare-variable scrutinee specially++          ; return (foldr combineUsage scrut_usg' alt_usgs,+                    Case scrut' b' (scSubstTy env ty) alts') }++    sc_alt env scrut' b' (con,bs,rhs)+     = do { let (env1, bs1) = extendBndrsWith RecArg env bs+                (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1+          ; (usg, rhs') <- scExpr env2 rhs+          ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)+                scrut_occ = case con of+                               DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)+                               _          -> ScrutOcc emptyUFM+          ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }++scExpr' env (Let (NonRec bndr rhs) body)+  | isTyVar bndr        -- Type-lets may be created by doBeta+  = scExpr' (extendScSubst env bndr rhs) body++  | otherwise+  = do  { let (body_env, bndr') = extendBndr env bndr+        ; rhs_info  <- scRecRhs env (bndr',rhs)++        ; let body_env2 = extendHowBound body_env [bndr'] RecFun+                           -- Note [Local let bindings]+              rhs'      = ri_new_rhs rhs_info+              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')++        ; (body_usg, body') <- scExpr body_env3 body++          -- NB: For non-recursive bindings we inherit sc_force flag from+          -- the parent function (see Note [Forcing specialisation])+        ; (spec_usg, specs) <- specNonRec env body_usg rhs_info++        ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }+                    `combineUsage` spec_usg,  -- Note [spec_usg includes rhs_usg]+                  mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body')+        }+++-- A *local* recursive group: see Note [Local recursive groups]+scExpr' env (Let (Rec prs) body)+  = do  { let (bndrs,rhss)      = unzip prs+              (rhs_env1,bndrs') = extendRecBndrs env bndrs+              rhs_env2          = extendHowBound rhs_env1 bndrs' RecFun+              force_spec        = any (forceSpecBndr env) bndrs'+                -- Note [Forcing specialisation]++        ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)+        ; (body_usg, body')     <- scExpr rhs_env2 body++        -- NB: start specLoop from body_usg+        ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec)+                                       body_usg rhs_infos+                -- Do not unconditionally generate specialisations from rhs_usgs+                -- Instead use them only if we find an unspecialised call+                -- See Note [Local recursive groups]++        ; let all_usg = spec_usg `combineUsage` body_usg  -- Note [spec_usg includes rhs_usg]+              bind'   = Rec (concat (zipWith ruleInfoBinds rhs_infos specs))++        ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },+                  Let bind' body') }++{-+Note [Local let bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~+It is not uncommon to find this++   let $j = \x. <blah> in ...$j True...$j True...++Here $j is an arbitrary let-bound function, but it often comes up for+join points.  We might like to specialise $j for its call patterns.+Notice the difference from a letrec, where we look for call patterns+in the *RHS* of the function.  Here we look for call patterns in the+*body* of the let.++At one point I predicated this on the RHS mentioning the outer+recursive function, but that's not essential and might even be+harmful.  I'm not sure.+-}++scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)++scApp env (Var fn, args)        -- Function is a variable+  = ASSERT( not (null args) )+    do  { args_w_usgs <- mapM (scExpr env) args+        ; let (arg_usgs, args') = unzip args_w_usgs+              arg_usg = combineUsages arg_usgs+        ; case scSubstId env fn of+            fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')+                        -- Do beta-reduction and try again++            Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',+                               mkApps (Var fn') args')++            other_fn' -> return (arg_usg, mkApps other_fn' args') }+                -- NB: doing this ignores any usage info from the substituted+                --     function, but I don't think that matters.  If it does+                --     we can fix it.+  where+    doBeta :: OutExpr -> [OutExpr] -> OutExpr+    -- ToDo: adjust for System IF+    doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)+    doBeta fn              args         = mkApps fn args++-- The function is almost always a variable, but not always.+-- In particular, if this pass follows float-in,+-- which it may, we can get+--      (let f = ...f... in f) arg1 arg2+scApp env (other_fn, args)+  = do  { (fn_usg,   fn')   <- scExpr env other_fn+        ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args+        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }++----------------------+mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage+mkVarUsage env fn args+  = case lookupHowBound env fn of+        Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)]+                           , scu_occs  = emptyVarEnv }+        Just RecArg -> SCU { scu_calls = emptyVarEnv+                           , scu_occs  = unitVarEnv fn arg_occ }+        Nothing     -> nullUsage+  where+    -- I rather think we could use UnkOcc all the time+    arg_occ | null args = UnkOcc+            | otherwise = evalScrutOcc++----------------------+scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)+scTopBindEnv env (Rec prs)+  = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs+              rhs_env2          = extendHowBound rhs_env1 bndrs RecFun++              prs'              = zip bndrs' rhss+        ; return (rhs_env2, Rec prs') }+  where+    (bndrs,rhss) = unzip prs++scTopBindEnv env (NonRec bndr rhs)+  = do  { let (env1, bndr') = extendBndr env bndr+              env2          = extendValEnv env1 bndr' (isValue (sc_vals env) rhs)+        ; return (env2, NonRec bndr' rhs) }++----------------------+scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)++{-+scTopBind _ usage _+  | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False+  = error "false"+-}++scTopBind env body_usage (Rec prs)+  | Just threshold <- sc_size env+  , not force_spec+  , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss)+                -- No specialisation+  = -- pprTrace "scTopBind: nospec" (ppr bndrs) $+    do  { (rhs_usgs, rhss')   <- mapAndUnzipM (scExpr env) rhss+        ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) }++  | otherwise   -- Do specialisation+  = do  { rhs_infos <- mapM (scRecRhs env) prs++        ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec)+                                         body_usage rhs_infos++        ; return (body_usage `combineUsage` spec_usage,+                  Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) }+  where+    (bndrs,rhss) = unzip prs+    force_spec   = any (forceSpecBndr env) bndrs+      -- Note [Forcing specialisation]++scTopBind env usage (NonRec bndr rhs)   -- Oddly, we don't seem to specialise top-level non-rec functions+  = do  { (rhs_usg', rhs') <- scExpr env rhs+        ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') }++----------------------+scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo+scRecRhs env (bndr,rhs)+  = do  { let (arg_bndrs,body)       = collectBinders rhs+              (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs+        ; (body_usg, body')         <- scExpr body_env body+        ; let (rhs_usg, arg_occs)    = lookupOccs body_usg arg_bndrs'+        ; return (RI { ri_rhs_usg = rhs_usg+                     , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body'+                     , ri_lam_bndrs = arg_bndrs, ri_lam_body = body+                     , ri_arg_occs = arg_occs }) }+                -- The arg_occs says how the visible,+                -- lambda-bound binders of the RHS are used+                -- (including the TyVar binders)+                -- Two pats are the same if they match both ways++----------------------+ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]+ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs })+              (SI { si_specs = specs })+  = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] +++              -- First the specialised bindings++    [(fn `addIdSpecialisations` rules, new_rhs)]+              -- And now the original binding+  where+    rules = [r | OS { os_rule = r } <- specs]++{-+************************************************************************+*                                                                      *+                The specialiser itself+*                                                                      *+************************************************************************+-}++data RhsInfo+  = RI { ri_fn :: OutId                 -- The binder+       , ri_new_rhs :: OutExpr          -- The specialised RHS (in current envt)+       , ri_rhs_usg :: ScUsage          -- Usage info from specialising RHS++       , ri_lam_bndrs :: [InVar]       -- The *original* RHS (\xs.body)+       , ri_lam_body  :: InExpr        --   Note [Specialise original body]+       , ri_arg_occs  :: [ArgOcc]      -- Info on how the xs occur in body+    }++data SpecInfo       -- Info about specialisations for a particular Id+  = SI { si_specs :: [OneSpec]          -- The specialisations we have generated++       , si_n_specs :: Int              -- Length of si_specs; used for numbering them++       , si_mb_unspec :: Maybe ScUsage  -- Just cs  => we have not yet used calls in the+       }                                --             from calls in the *original* RHS as+                                        --             seeds for new specialisations;+                                        --             if you decide to do so, here is the+                                        --             RHS usage (which has not yet been+                                        --             unleashed)+                                        -- Nothing => we have+                                        -- See Note [Local recursive groups]+                                        -- See Note [spec_usg includes rhs_usg]++        -- One specialisation: Rule plus definition+data OneSpec =+  OS { os_pat  :: CallPat    -- Call pattern that generated this specialisation+     , os_rule :: CoreRule   -- Rule connecting original id with the specialisation+     , os_id   :: OutId      -- Spec id+     , os_rhs  :: OutExpr }  -- Spec rhs++noSpecInfo :: SpecInfo+noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing }++----------------------+specNonRec :: ScEnv+           -> ScUsage         -- Body usage+           -> RhsInfo         -- Structure info usage info for un-specialised RHS+           -> UniqSM (ScUsage, SpecInfo)       -- Usage from RHSs (specialised and not)+                                               --     plus details of specialisations++specNonRec env body_usg rhs_info+  = specialise env (scu_calls body_usg) rhs_info+               (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) })++----------------------+specRec :: TopLevelFlag -> ScEnv+        -> ScUsage                         -- Body usage+        -> [RhsInfo]                       -- Structure info and usage info for un-specialised RHSs+        -> UniqSM (ScUsage, [SpecInfo])    -- Usage from all RHSs (specialised and not)+                                           --     plus details of specialisations++specRec top_lvl env body_usg rhs_infos+  = go 1 seed_calls nullUsage init_spec_infos+  where+    (seed_calls, init_spec_infos)    -- Note [Seeding top-level recursive groups]+       | isTopLevel top_lvl+       , any (isExportedId . ri_fn) rhs_infos   -- Seed from body and RHSs+       = (all_calls,     [noSpecInfo | _ <- rhs_infos])+       | otherwise                              -- Seed from body only+       = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) }+                         | ri <- rhs_infos])++    calls_in_body = scu_calls body_usg+    calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos+    all_calls = calls_in_rhss `combineCalls` calls_in_body++    -- Loop, specialising, until you get no new specialisations+    go :: Int   -- Which iteration of the "until no new specialisations"+                -- loop we are on; first iteration is 1+       -> CallEnv   -- Seed calls+                    -- Two accumulating parameters:+       -> ScUsage      -- Usage from earlier specialisations+       -> [SpecInfo]   -- Details of specialisations so far+       -> UniqSM (ScUsage, [SpecInfo])+    go n_iter seed_calls usg_so_far spec_infos+      | isEmptyVarEnv seed_calls+      = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos)+        --                           , ppr seed_calls+        --                           , ppr body_usg ]) $+        return (usg_so_far, spec_infos)++      -- Limit recursive specialisation+      -- See Note [Limit recursive specialisation]+      | n_iter > sc_recursive env  -- Too many iterations of the 'go' loop+      , sc_force env || isNothing (sc_count env)+           -- If both of these are false, the sc_count+           -- threshold will prevent non-termination+      , any ((> the_limit) . si_n_specs) spec_infos+      = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $+        return (usg_so_far, spec_infos)++      | otherwise+      = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)+        --                           , text "iteration" <+> int n_iter+        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)+        --                    ]) $+        do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos+            ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg+                  extra_usg = combineUsages extra_usg_s+                  all_usg   = usg_so_far `combineUsage` extra_usg+            ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos }++    -- See Note [Limit recursive specialisation]+    the_limit = case sc_count env of+                  Nothing  -> 10    -- Ugh!+                  Just max -> max+++----------------------+specialise+   :: ScEnv+   -> CallEnv                     -- Info on newly-discovered calls to this function+   -> RhsInfo+   -> SpecInfo                    -- Original RHS plus patterns dealt with+   -> UniqSM (ScUsage, SpecInfo)  -- New specialised versions and their usage++-- See Note [spec_usg includes rhs_usg]++-- Note: this only generates *specialised* bindings+-- The original binding is added by ruleInfoBinds+--+-- Note: the rhs here is the optimised version of the original rhs+-- So when we make a specialised copy of the RHS, we're starting+-- from an RHS whose nested functions have been optimised already.++specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs+                              , ri_lam_body = body, ri_arg_occs = arg_occs })+               spec_info@(SI { si_specs = specs, si_n_specs = spec_count+                             , si_mb_unspec = mb_unspec })+  | isBottomingId fn      -- Note [Do not specialise diverging functions]+                          -- and do not generate specialisation seeds from its RHS+  = -- pprTrace "specialise bot" (ppr fn) $+    return (nullUsage, spec_info)++  | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation]+    || null arg_bndrs                     -- Only specialise functions+  = -- pprTrace "specialise inactive" (ppr fn) $+    case mb_unspec of    -- Behave as if there was a single, boring call+      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })+                         -- See Note [spec_usg includes rhs_usg]+      Nothing      -> return (nullUsage, spec_info)++  | Just all_calls <- lookupVarEnv bind_calls fn+  = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $+    do  { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls++        ; let n_pats = length new_pats+--        ; if (not (null new_pats) || isJust mb_unspec) then+--            pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"+--                                        , text "mb_unspec" <+> ppr (isJust mb_unspec)+--                                        , text "arg_occs" <+> ppr arg_occs+--                                        , text "good pats" <+> ppr new_pats])  $+--               return ()+--          else return ()++        ; let spec_env = decreaseSpecCount env n_pats+        ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)+                                                 (new_pats `zip` [spec_count..])+                -- See Note [Specialise original body]++        ; let spec_usg = combineUsages spec_usgs++              -- If there were any boring calls among the seeds (= all_calls), then those+              -- calls will call the un-specialised function.  So we should use the seeds+              -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning+              -- then in new_usg.+              (new_usg, mb_unspec')+                  = case mb_unspec of+                      Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)+                      _                          -> (spec_usg,                      mb_unspec)++--        ; pprTrace "specialise return }"+--             (vcat [ ppr fn+--                   , text "boring_call:" <+> ppr boring_call+--                   , text "new calls:" <+> ppr (scu_calls new_usg)]) $+--          return ()++          ; return (new_usg, SI { si_specs = new_specs ++ specs+                                , si_n_specs = spec_count + n_pats+                                , si_mb_unspec = mb_unspec' }) }++  | otherwise  -- No new seeds, so return nullUsage+  = return (nullUsage, spec_info)+++++---------------------+spec_one :: ScEnv+         -> OutId       -- Function+         -> [InVar]     -- Lambda-binders of RHS; should match patterns+         -> InExpr      -- Body of the original function+         -> (CallPat, Int)+         -> UniqSM (ScUsage, OneSpec)   -- Rule and binding++-- spec_one creates a specialised copy of the function, together+-- with a rule for using it.  I'm very proud of how short this+-- function is, considering what it does :-).++{-+  Example++     In-scope: a, x::a+     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...+          [c::*, v::(b,c) are presumably bound by the (...) part]+  ==>+     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->+                  (...entire body of f...) [b -> (b,c),+                                            y -> ((:) (a,(b,c)) (x,v) hw)]++     RULE:  forall b::* c::*,           -- Note, *not* forall a, x+                   v::(b,c),+                   hw::[(a,(b,c))] .++            f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw+-}++spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)+  = do  { spec_uniq <- getUniqueM+        ; let spec_env   = extendScSubstList (extendScInScope env qvars)+                                             (arg_bndrs `zip` pats)+              fn_name    = idName fn+              fn_loc     = nameSrcSpan fn_name+              fn_occ     = nameOccName fn_name+              spec_occ   = mkSpecOcc fn_occ+              -- We use fn_occ rather than fn in the rule_name string+              -- as we don't want the uniq to end up in the rule, and+              -- hence in the ABI, as that can cause spurious ABI+              -- changes (#4012).+              rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)+              spec_name  = mkInternalName spec_uniq spec_occ fn_loc+--      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn+--                              <+> ppr pats <+> text "-->" <+> ppr spec_name) $+--        return ()++        -- Specialise the body+        ; (spec_usg, spec_body) <- scExpr spec_env body++--      ; pprTrace "done spec_one}" (ppr fn) $+--        return ()++                -- And build the results+        ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env)+                                                             qvars body_ty+                -- Usual w/w hack to avoid generating+                -- a spec_rhs of unlifted type and no args++              spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args+                -- Annotate the variables with the strictness information from+                -- the function (see Note [Strictness information in worker binders])++              spec_join_arity | isJoinId fn = Just (length spec_lam_args)+                              | otherwise   = Nothing+              spec_id    = mkLocalId spec_name+                                     (mkLamTypes spec_lam_args body_ty)+                             -- See Note [Transfer strictness]+                             `setIdStrictness` spec_str+                             `setIdCprInfo` topCprSig+                             `setIdArity` count isId spec_lam_args+                             `asJoinId_maybe` spec_join_arity+              spec_str   = calcSpecStrictness fn spec_lam_args pats+++                -- Conditionally use result of new worker-wrapper transform+              spec_rhs   = mkLams spec_lam_args_str spec_body+              body_ty    = exprType spec_body+              rule_rhs   = mkVarApps (Var spec_id) spec_call_args+              inline_act = idInlineActivation fn+              this_mod   = sc_module spec_env+              rule       = mkRule this_mod True {- Auto -} True {- Local -}+                                  rule_name inline_act fn_name qvars pats rule_rhs+                           -- See Note [Transfer activation]+        ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule+                               , os_id = spec_id+                               , os_rhs = spec_rhs }) }+++-- See Note [Strictness information in worker binders]+handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]+handOutStrictnessInformation = go+  where+    go _ [] = []+    go [] vs = vs+    go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs+    go dmds (v:vs) = v : go dmds vs++calcSpecStrictness :: Id                     -- The original function+                   -> [Var] -> [CoreExpr]    -- Call pattern+                   -> StrictSig              -- Strictness of specialised thing+-- See Note [Transfer strictness]+calcSpecStrictness fn qvars pats+  = mkClosedStrictSig spec_dmds topDiv+  where+    spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]+    StrictSig (DmdType _ dmds _) = idStrictness fn++    dmd_env = go emptyVarEnv dmds pats++    go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv+    go env ds (Type {} : pats)     = go env ds pats+    go env ds (Coercion {} : pats) = go env ds pats+    go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats+    go env _      _                = env++    go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv+    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d+    go_one env d e+           | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict+           , (Var _, args) <- collectArgs e = go env ds args+    go_one env _         _ = env++{-+Note [spec_usg includes rhs_usg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In calls to 'specialise', the returned ScUsage must include the rhs_usg in+the passed-in SpecInfo, unless there are no calls at all to the function.++The caller can, indeed must, assume this.  He should not combine in rhs_usg+himself, or he'll get rhs_usg twice -- and that can lead to an exponential+blowup of duplicates in the CallEnv.  This is what gave rise to the massive+performance loss in #8852.++Note [Specialise original body]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RhsInfo for a binding keeps the *original* body of the binding.  We+must specialise that, *not* the result of applying specExpr to the RHS+(which is also kept in RhsInfo). Otherwise we end up specialising a+specialised RHS, and that can lead directly to exponential behaviour.++Note [Transfer activation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+  This note is for SpecConstr, but exactly the same thing+  happens in the overloading specialiser; see+  Note [Auto-specialisation and RULES] in GHC.Core.Op.Specialise.++In which phase should the specialise-constructor rules be active?+Originally I made them always-active, but Manuel found that this+defeated some clever user-written rules.  Then I made them active only+in Phase 0; after all, currently, the specConstr transformation is+only run after the simplifier has reached Phase 0, but that meant+that specialisations didn't fire inside wrappers; see test+simplCore/should_compile/spec-inline.++So now I just use the inline-activation of the parent Id, as the+activation for the specialisation RULE, just like the main specialiser;++This in turn means there is no point in specialising NOINLINE things,+so we test for that.++Note [Transfer strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We must transfer strictness information from the original function to+the specialised one.  Suppose, for example++  f has strictness     SS+        and a RULE     f (a:as) b = f_spec a as b++Now we want f_spec to have strictness  LLS, otherwise we'll use call-by-need+when calling f_spec instead of call-by-value.  And that can result in+unbounded worsening in space (cf the classic foldl vs foldl')++See #3437 for a good example.++The function calcSpecStrictness performs the calculation.++Note [Strictness information in worker binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++After having calculated the strictness annotation for the worker (see Note+[Transfer strictness] above), we also want to have this information attached to+the worker’s arguments, for the benefit of later passes. The function+handOutStrictnessInformation decomposes the strictness annotation calculated by+calcSpecStrictness and attaches them to the variables.++************************************************************************+*                                                                      *+\subsection{Argument analysis}+*                                                                      *+************************************************************************++This code deals with analysing call-site arguments to see whether+they are constructor applications.++Note [Free type variables of the qvar types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a call (f @a x True), that we want to specialise, what variables should+we quantify over.  Clearly over 'a' and 'x', but what about any type variables+free in x's type?  In fact we don't need to worry about them because (f @a)+can only be a well-typed application if its type is compatible with x, so any+variables free in x's type must be free in (f @a), and hence either be gathered+via 'a' itself, or be in scope at f's defn.  Hence we just take+  (exprsFreeVars pats).++BUT phantom type synonyms can mess this reasoning up,+  eg   x::T b   with  type T b = Int+So we apply expandTypeSynonyms to the bound Ids.+See # 5458.  Yuk.++Note [SpecConstr call patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "call patterns" that we collect is going to become the LHS of a RULE.+It's important that it doesn't have+     e |> Refl+or+    e |> g1 |> g2+because both of these will be optimised by Simplify.simplRule. In the+former case such optimisation benign, because the rule will match more+terms; but in the latter we may lose a binding of 'g1' or 'g2', and+end up with a rule LHS that doesn't bind the template variables+(#10602).++The simplifier eliminates such things, but SpecConstr itself constructs+new terms by substituting.  So the 'mkCast' in the Cast case of scExpr+is very important!++Note [Choosing patterns]+~~~~~~~~~~~~~~~~~~~~~~~~+If we get lots of patterns we may not want to make a specialisation+for each of them (code bloat), so we choose as follows, implemented+by trim_pats.++* The flag -fspec-constr-count-N sets the sc_count field+  of the ScEnv to (Just n).  This limits the total number+  of specialisations for a given function to N.++* -fno-spec-constr-count sets the sc_count field to Nothing,+  which switches of the limit.++* The ghastly ForceSpecConstr trick also switches of the limit+  for a particular function++* Otherwise we sort the patterns to choose the most general+  ones first; more general => more widely applicable.++Note [SpecConstr and casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#14270) a call like++    let f = e+    in ... f (K @(a |> co)) ...++where 'co' is a coercion variable not in scope at f's definition site.+If we aren't caereful we'll get++    let $sf a co = e (K @(a |> co))+        RULE "SC:f" forall a co.  f (K @(a |> co)) = $sf a co+        f = e+    in ...++But alas, when we match the call we won't bind 'co', because type-matching+(for good reasons) discards casts).++I don't know how to solve this, so for now I'm just discarding any+call patterns that+  * Mentions a coercion variable in a type argument+  * That is not in scope at the binding of the function++I think this is very rare.++It is important (e.g. #14936) that this /only/ applies to+coercions mentioned in casts.  We don't want to be discombobulated+by casts in terms!  For example, consider+   f ((e1,e2) |> sym co)+where, say,+   f  :: Foo -> blah+   co :: Foo ~R (Int,Int)++Here we definitely do want to specialise for that pair!  We do not+match on the structure of the coercion; instead we just match on a+coercion variable, so the RULE looks like++   forall (x::Int, y::Int, co :: (Int,Int) ~R Foo)+     f ((x,y) |> co) = $sf x y co++Often the body of f looks like+   f arg = ...(case arg |> co' of+                (x,y) -> blah)...++so that the specialised f will turn into+   $sf x y co = let arg = (x,y) |> co+                in ...(case arg>| co' of+                         (x,y) -> blah)....++which will simplify to not use 'co' at all.  But we can't guarantee+that co will end up unused, so we still pass it.  Absence analysis+may remove it later.++Note that this /also/ discards the call pattern if we have a cast in a+/term/, although in fact Rules.match does make a very flaky and+fragile attempt to match coercions.  e.g. a call like+    f (Maybe Age) (Nothing |> co) blah+    where co :: Maybe Int ~ Maybe Age+will be discarded.  It's extremely fragile to match on the form of a+coercion, so I think it's better just not to try.  A more complicated+alternative would be to discard calls that mention coercion variables+only in kind-casts, but I'm doing the simple thing for now.+-}++type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments+                                        -- See Note [SpecConstr call patterns]++callsToNewPats :: ScEnv -> Id+               -> SpecInfo+               -> [ArgOcc] -> [Call]+               -> UniqSM (Bool, [CallPat])+        -- Result has no duplicate patterns,+        -- nor ones mentioned in done_pats+        -- Bool indicates that there was at least one boring pattern+callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls+  = do  { mb_pats <- mapM (callToPats env bndr_occs) calls++        ; let have_boring_call = any isNothing mb_pats++              good_pats :: [CallPat]+              good_pats = catMaybes mb_pats++              -- Remove patterns we have already done+              new_pats = filterOut is_done good_pats+              is_done p = any (samePat p . os_pat) done_specs++              -- Remove duplicates+              non_dups = nubBy samePat new_pats++              -- Remove ones that have too many worker variables+              small_pats = filterOut too_big non_dups+              too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars)+                  -- We are about to construct w/w pair in 'spec_one'.+                  -- Omit specialisation leading to high arity workers.+                  -- See Note [Limit w/w arity] in GHC.Core.Op.WorkWrap.Lib++                -- Discard specialisations if there are too many of them+              trimmed_pats = trim_pats env fn spec_info small_pats++--        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls+--                                       , text "done_specs:" <+> ppr (map os_pat done_specs)+--                                       , text "good_pats:" <+> ppr good_pats ]) $+--          return ()++        ; return (have_boring_call, trimmed_pats) }+++trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]+-- See Note [Choosing patterns]+trim_pats env fn (SI { si_n_specs = done_spec_count }) pats+  | sc_force env+    || isNothing mb_scc+    || n_remaining >= n_pats+  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)+    pats          -- No need to trim++  | otherwise+  = emit_trace $  -- Need to trim, so keep the best ones+    take n_remaining sorted_pats++  where+    n_pats         = length pats+    spec_count'    = n_pats + done_spec_count+    n_remaining    = max_specs - done_spec_count+    mb_scc         = sc_count env+    Just max_specs = mb_scc++    sorted_pats = map fst $+                  sortBy (comparing snd) $+                  [(pat, pat_cons pat) | pat <- pats]+     -- Sort in order of increasing number of constructors+     -- (i.e. decreasing generality) and pick the initial+     -- segment of this list++    pat_cons :: CallPat -> Int+    -- How many data constructors of literals are in+    -- the pattern.  More data-cons => less general+    pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps+       where+          q_set = mkVarSet qs+          n_cons (Var v) | v `elemVarSet` q_set = 0+                         | otherwise            = 1+          n_cons (Cast e _)  = n_cons e+          n_cons (App e1 e2) = n_cons e1 + n_cons e2+          n_cons (Lit {})    = 1+          n_cons _           = 0++    emit_trace result+       | debugIsOn || hasPprDebug (sc_dflags env)+         -- Suppress this scary message for ordinary users!  #5125+       = pprTrace "SpecConstr" msg result+       | otherwise+       = result+    msg = vcat [ sep [ text "Function" <+> quotes (ppr fn)+                     , nest 2 (text "has" <+>+                               speakNOf spec_count' (text "call pattern") <> comma <+>+                               text "but the limit is" <+> int max_specs) ]+               , text "Use -fspec-constr-count=n to set the bound"+               , text "done_spec_count =" <+> int done_spec_count+               , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats+               , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]+++callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)+        -- The [Var] is the variables to quantify over in the rule+        --      Type variables come first, since they may scope+        --      over the following term variables+        -- The [CoreExpr] are the argument patterns for the rule+callToPats env bndr_occs call@(Call _ args con_env)+  | args `ltLength` bndr_occs      -- Check saturated+  = return Nothing+  | otherwise+  = do  { let in_scope = substInScope (sc_subst env)+        ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs+        ; let pat_fvs = exprsFreeVarsList pats+                -- To get determinism we need the list of free variables in+                -- deterministic order. Otherwise we end up creating+                -- lambdas with different argument orders. See+                -- determinism/simplCore/should_compile/spec-inline-determ.hs+                -- for an example. For explanation of determinism+                -- considerations See Note [Unique Determinism] in GHC.Types.Unique.++              in_scope_vars = getInScopeVars in_scope+              is_in_scope v = v `elemVarSet` in_scope_vars+              qvars         = filterOut is_in_scope pat_fvs+                -- Quantify over variables that are not in scope+                -- at the call site+                -- See Note [Free type variables of the qvar types]+                -- See Note [Shadowing] at the top++              (ktvs, ids)   = partition isTyVar qvars+              qvars'        = scopedSort ktvs ++ map sanitise ids+                -- Order into kind variables, type variables, term variables+                -- The kind of a type variable may mention a kind variable+                -- and the type of a term variable may mention a type variable++              sanitise id   = id `setIdType` expandTypeSynonyms (idType id)+                -- See Note [Free type variables of the qvar types]++              -- Bad coercion variables: see Note [SpecConstr and casts]+              bad_covars :: CoVarSet+              bad_covars = mapUnionVarSet get_bad_covars pats+              get_bad_covars :: CoreArg -> CoVarSet+              get_bad_covars (Type ty)+                = filterVarSet (\v -> isId v && not (is_in_scope v)) $+                  tyCoVarsOfType ty+              get_bad_covars _+                = emptyVarSet++        ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $+          WARN( not (isEmptyVarSet bad_covars)+              , text "SpecConstr: bad covars:" <+> ppr bad_covars+                $$ ppr call )+          if interesting && isEmptyVarSet bad_covars+          then return (Just (qvars', pats))+          else return Nothing }++    -- argToPat takes an actual argument, and returns an abstracted+    -- version, consisting of just the "constructor skeleton" of the+    -- argument, with non-constructor sub-expression replaced by new+    -- placeholder variables.  For example:+    --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)++argToPat :: ScEnv+         -> InScopeSet                  -- What's in scope at the fn defn site+         -> ValueEnv                    -- ValueEnv at the call site+         -> CoreArg                     -- A call arg (or component thereof)+         -> ArgOcc+         -> UniqSM (Bool, CoreArg)++-- Returns (interesting, pat),+-- where pat is the pattern derived from the argument+--            interesting=True if the pattern is non-trivial (not a variable or type)+-- E.g.         x:xs         --> (True, x:xs)+--              f xs         --> (False, w)        where w is a fresh wildcard+--              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard+--              \x. x+y      --> (True, \x. x+y)+--              lvl7         --> (True, lvl7)      if lvl7 is bound+--                                                 somewhere further out++argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ+  = return (False, arg)++argToPat env in_scope val_env (Tick _ arg) arg_occ+  = argToPat env in_scope val_env arg arg_occ+        -- Note [Notes in call patterns]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- Ignore Notes.  In particular, we want to ignore any InlineMe notes+        -- Perhaps we should not ignore profiling notes, but I'm going to+        -- ride roughshod over them all for now.+        --- See Note [Notes in RULE matching] in GHC.Core.Rules++argToPat env in_scope val_env (Let _ arg) arg_occ+  = argToPat env in_scope val_env arg arg_occ+        -- See Note [Matching lets] in Rule.hs+        -- Look through let expressions+        -- e.g.         f (let v = rhs in (v,w))+        -- Here we can specialise for f (v,w)+        -- because the rule-matcher will look through the let.++{- Disabled; see Note [Matching cases] in Rule.hs+argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ+  | exprOkForSpeculation scrut  -- See Note [Matching cases] in Rule.hhs+  = argToPat env in_scope val_env rhs arg_occ+-}++argToPat env in_scope val_env (Cast arg co) arg_occ+  | not (ignoreType env ty2)+  = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ+        ; if not interesting then+                wildCardPat ty2+          else do+        { -- Make a wild-card pattern for the coercion+          uniq <- getUniqueM+        ; let co_name = mkSysTvName uniq (fsLit "sg")+              co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)+        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }+  where+    Pair ty1 ty2 = coercionKind co++++{-      Disabling lambda specialisation for now+        It's fragile, and the spec_loop can be infinite+argToPat in_scope val_env arg arg_occ+  | is_value_lam arg+  = return (True, arg)+  where+    is_value_lam (Lam v e)         -- Spot a value lambda, even if+        | isId v       = True      -- it is inside a type lambda+        | otherwise    = is_value_lam e+    is_value_lam other = False+-}++  -- Check for a constructor application+  -- NB: this *precedes* the Var case, so that we catch nullary constrs+argToPat env in_scope val_env arg arg_occ+  | Just (ConVal (DataAlt dc) args) <- isValue val_env arg+  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]+  , Just arg_occs <- mb_scrut dc+  = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args+        ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs+        ; return (True,+                  mkConApp dc (ty_args ++ args')) }+  where+    mb_scrut dc = case arg_occ of+                    ScrutOcc bs | Just occs <- lookupUFM bs dc+                                -> Just (occs)  -- See Note [Reboxing]+                    _other      | sc_force env || sc_keen env+                                -> Just (repeat UnkOcc)+                                | otherwise+                                -> Nothing++  -- Check if the argument is a variable that+  --    (a) is used in an interesting way in the function body+  --    (b) we know what its value is+  -- In that case it counts as "interesting"+argToPat env in_scope val_env (Var v) arg_occ+  | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)+    is_value,                                                            -- (b)+       -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]+       -- So sc_keen focused just on f (I# x), where we have freshly-allocated+       -- box that we can eliminate in the caller+    not (ignoreType env (varType v))+  = return (True, Var v)+  where+    is_value+        | isLocalId v = v `elemInScopeSet` in_scope+                        && isJust (lookupVarEnv val_env v)+                -- Local variables have values in val_env+        | otherwise   = isValueUnfolding (idUnfolding v)+                -- Imports have unfoldings++--      I'm really not sure what this comment means+--      And by not wild-carding we tend to get forall'd+--      variables that are in scope, which in turn can+--      expose the weakness in let-matching+--      See Note [Matching lets] in GHC.Core.Rules++  -- Check for a variable bound inside the function.+  -- Don't make a wild-card, because we may usefully share+  --    e.g.  f a = let x = ... in f (x,x)+  -- NB: this case follows the lambda and con-app cases!!+-- argToPat _in_scope _val_env (Var v) _arg_occ+--   = return (False, Var v)+        -- SLPJ : disabling this to avoid proliferation of versions+        -- also works badly when thinking about seeding the loop+        -- from the body of the let+        --       f x y = letrec g z = ... in g (x,y)+        -- We don't want to specialise for that *particular* x,y++  -- The default case: make a wild-card+  -- We use this for coercions too+argToPat _env _in_scope _val_env arg _arg_occ+  = wildCardPat (exprType arg)++wildCardPat :: Type -> UniqSM (Bool, CoreArg)+wildCardPat ty+  = do { uniq <- getUniqueM+       ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty+       ; return (False, varToCoreExpr id) }++argsToPats :: ScEnv -> InScopeSet -> ValueEnv+           -> [CoreArg] -> [ArgOcc]  -- Should be same length+           -> UniqSM (Bool, [CoreArg])+argsToPats env in_scope val_env args occs+  = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs+       ; let (interesting_s, args') = unzip stuff+       ; return (or interesting_s, args') }++isValue :: ValueEnv -> CoreExpr -> Maybe Value+isValue _env (Lit lit)+  | litIsLifted lit = Nothing+  | otherwise       = Just (ConVal (LitAlt lit) [])++isValue env (Var v)+  | Just cval <- lookupVarEnv env v+  = Just cval  -- You might think we could look in the idUnfolding here+               -- but that doesn't take account of which branch of a+               -- case we are in, which is the whole point++  | not (isLocalId v) && isCheapUnfolding unf+  = isValue env (unfoldingTemplate unf)+  where+    unf = idUnfolding v+        -- However we do want to consult the unfolding+        -- as well, for let-bound constructors!++isValue env (Lam b e)+  | isTyVar b = case isValue env e of+                  Just _  -> Just LambdaVal+                  Nothing -> Nothing+  | otherwise = Just LambdaVal++isValue env (Tick t e)+  | not (tickishIsCode t)+  = isValue env e++isValue _env expr       -- Maybe it's a constructor application+  | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr+  = case isDataConWorkId_maybe fun of++        Just con | args `lengthAtLeast` dataConRepArity con+                -- Check saturated; might be > because the+                --                  arity excludes type args+                -> Just (ConVal (DataAlt con) args)++        _other | valArgCount args < idArity fun+                -- Under-applied function+               -> Just LambdaVal        -- Partial application++        _other -> Nothing++isValue _env _expr = Nothing++valueIsWorkFree :: Value -> Bool+valueIsWorkFree LambdaVal       = True+valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args++samePat :: CallPat -> CallPat -> Bool+samePat (vs1, as1) (vs2, as2)+  = all2 same as1 as2+  where+    same (Var v1) (Var v2)+        | v1 `elem` vs1 = v2 `elem` vs2+        | v2 `elem` vs2 = False+        | otherwise     = v1 == v2++    same (Lit l1)    (Lit l2)    = l1==l2+    same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2++    same (Type {}) (Type {}) = True     -- Note [Ignore type differences]+    same (Coercion {}) (Coercion {}) = True+    same (Tick _ e1) e2 = same e1 e2  -- Ignore casts and notes+    same (Cast e1 _) e2 = same e1 e2+    same e1 (Tick _ e2) = same e1 e2+    same e1 (Cast e2 _) = same e1 e2++    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)+                 False  -- Let, lambda, case should not occur+    bad (Case {}) = True+    bad (Let {})  = True+    bad (Lam {})  = True+    bad _other    = False++{-+Note [Ignore type differences]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not want to generate specialisations where the call patterns+differ only in their type arguments!  Not only is it utterly useless,+but it also means that (with polymorphic recursion) we can generate+an infinite number of specialisations. Example is Data.Sequence.adjustTree,+I think.+-}
+ compiler/GHC/Core/Op/Specialise.hs view
@@ -0,0 +1,2716 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+module GHC.Core.Op.Specialise ( specProgram, specUnfolding ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Types.Id+import TcType hiding( substTy )+import GHC.Core.Type  hiding( substTy, extendTvSubstList )+import GHC.Core.Predicate+import GHC.Types.Module( Module, HasModule(..) )+import GHC.Core.Coercion( Coercion )+import GHC.Core.Op.Monad+import qualified GHC.Core.Subst+import GHC.Core.Unfold+import GHC.Types.Var      ( isLocalVar )+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Core+import GHC.Core.Rules+import GHC.Core.SimpleOpt ( collectBindersPushingCo )+import GHC.Core.Utils     ( exprIsTrivial, mkCast, exprType )+import GHC.Core.FVs+import GHC.Core.Arity     ( etaExpandToJoinPointRule )+import GHC.Types.Unique.Supply+import GHC.Types.Name+import GHC.Types.Id.Make  ( voidArgId, voidPrimId )+import Maybes           ( mapMaybe, isJust )+import MonadUtils       ( foldlM )+import GHC.Types.Basic+import GHC.Driver.Types+import Bag+import GHC.Driver.Session+import Util+import Outputable+import FastString+import State+import GHC.Types.Unique.DFM+import GHC.Core.TyCo.Rep (TyCoBinder (..))++import Control.Monad++{-+************************************************************************+*                                                                      *+\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}+*                                                                      *+************************************************************************++These notes describe how we implement specialisation to eliminate+overloading.++The specialisation pass works on Core+syntax, complete with all the explicit dictionary application,+abstraction and construction as added by the type checker.  The+existing type checker remains largely as it is.++One important thought: the {\em types} passed to an overloaded+function, and the {\em dictionaries} passed are mutually redundant.+If the same function is applied to the same type(s) then it is sure to+be applied to the same dictionary(s)---or rather to the same {\em+values}.  (The arguments might look different but they will evaluate+to the same value.)++Second important thought: we know that we can make progress by+treating dictionary arguments as static and worth specialising on.  So+we can do without binding-time analysis, and instead specialise on+dictionary arguments and no others.++The basic idea+~~~~~~~~~~~~~~+Suppose we have++        let f = <f_rhs>+        in <body>++and suppose f is overloaded.++STEP 1: CALL-INSTANCE COLLECTION++We traverse <body>, accumulating all applications of f to types and+dictionaries.++(Might there be partial applications, to just some of its types and+dictionaries?  In principle yes, but in practice the type checker only+builds applications of f to all its types and dictionaries, so partial+applications could only arise as a result of transformation, and even+then I think it's unlikely.  In any case, we simply don't accumulate such+partial applications.)+++STEP 2: EQUIVALENCES++So now we have a collection of calls to f:+        f t1 t2 d1 d2+        f t3 t4 d3 d4+        ...+Notice that f may take several type arguments.  To avoid ambiguity, we+say that f is called at type t1/t2 and t3/t4.++We take equivalence classes using equality of the *types* (ignoring+the dictionary args, which as mentioned previously are redundant).++STEP 3: SPECIALISATION++For each equivalence class, choose a representative (f t1 t2 d1 d2),+and create a local instance of f, defined thus:++        f@t1/t2 = <f_rhs> t1 t2 d1 d2++f_rhs presumably has some big lambdas and dictionary lambdas, so lots+of simplification will now result.  However we don't actually *do* that+simplification.  Rather, we leave it for the simplifier to do.  If we+*did* do it, though, we'd get more call instances from the specialised+RHS.  We can work out what they are by instantiating the call-instance+set from f's RHS with the types t1, t2.++Add this new id to f's IdInfo, to record that f has a specialised version.++Before doing any of this, check that f's IdInfo doesn't already+tell us about an existing instance of f at the required type/s.+(This might happen if specialisation was applied more than once, or+it might arise from user SPECIALIZE pragmas.)++Recursion+~~~~~~~~~+Wait a minute!  What if f is recursive?  Then we can't just plug in+its right-hand side, can we?++But it's ok.  The type checker *always* creates non-recursive definitions+for overloaded recursive functions.  For example:++        f x = f (x+x)           -- Yes I know its silly++becomes++        f a (d::Num a) = let p = +.sel a d+                         in+                         letrec fl (y::a) = fl (p y y)+                         in+                         fl++We still have recursion for non-overloaded functions which we+specialise, but the recursive call should get specialised to the+same recursive version.+++Polymorphism 1+~~~~~~~~~~~~~~++All this is crystal clear when the function is applied to *constant+types*; that is, types which have no type variables inside.  But what if+it is applied to non-constant types?  Suppose we find a call of f at type+t1/t2.  There are two possibilities:++(a) The free type variables of t1, t2 are in scope at the definition point+of f.  In this case there's no problem, we proceed just as before.  A common+example is as follows.  Here's the Haskell:++        g y = let f x = x+x+              in f y + f y++After typechecking we have++        g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x+                                in +.sel a d (f a d y) (f a d y)++Notice that the call to f is at type type "a"; a non-constant type.+Both calls to f are at the same type, so we can specialise to give:++        g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x+                                in +.sel a d (f@a y) (f@a y)+++(b) The other case is when the type variables in the instance types+are *not* in scope at the definition point of f.  The example we are+working with above is a good case.  There are two instances of (+.sel a d),+but "a" is not in scope at the definition of +.sel.  Can we do anything?+Yes, we can "common them up", a sort of limited common sub-expression deal.+This would give:++        g a (d::Num a) (y::a) = let +.sel@a = +.sel a d+                                    f@a (x::a) = +.sel@a x x+                                in +.sel@a (f@a y) (f@a y)++This can save work, and can't be spotted by the type checker, because+the two instances of +.sel weren't originally at the same type.++Further notes on (b)++* There are quite a few variations here.  For example, the defn of+  +.sel could be floated outside the \y, to attempt to gain laziness.+  It certainly mustn't be floated outside the \d because the d has to+  be in scope too.++* We don't want to inline f_rhs in this case, because+that will duplicate code.  Just commoning up the call is the point.++* Nothing gets added to +.sel's IdInfo.++* Don't bother unless the equivalence class has more than one item!++Not clear whether this is all worth it.  It is of course OK to+simply discard call-instances when passing a big lambda.++Polymorphism 2 -- Overloading+~~~~~~~~~~~~~~+Consider a function whose most general type is++        f :: forall a b. Ord a => [a] -> b -> b++There is really no point in making a version of g at Int/Int and another+at Int/Bool, because it's only instantiating the type variable "a" which+buys us any efficiency. Since g is completely polymorphic in b there+ain't much point in making separate versions of g for the different+b types.++That suggests that we should identify which of g's type variables+are constrained (like "a") and which are unconstrained (like "b").+Then when taking equivalence classes in STEP 2, we ignore the type args+corresponding to unconstrained type variable.  In STEP 3 we make+polymorphic versions.  Thus:++        f@t1/ = /\b -> <f_rhs> t1 b d1 d2++We do this.+++Dictionary floating+~~~~~~~~~~~~~~~~~~~+Consider this++        f a (d::Num a) = let g = ...+                         in+                         ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...++Here, g is only called at one type, but the dictionary isn't in scope at the+definition point for g.  Usually the type checker would build a+definition for d1 which enclosed g, but the transformation system+might have moved d1's defn inward.  Solution: float dictionary bindings+outwards along with call instances.++Consider++        f x = let g p q = p==q+                  h r s = (r+s, g r s)+              in+              h x x+++Before specialisation, leaving out type abstractions we have++        f df x = let g :: Eq a => a -> a -> Bool+                     g dg p q = == dg p q+                     h :: Num a => a -> a -> (a, Bool)+                     h dh r s = let deq = eqFromNum dh+                                in (+ dh r s, g deq r s)+              in+              h df x x++After specialising h we get a specialised version of h, like this:++                    h' r s = let deq = eqFromNum df+                             in (+ df r s, g deq r s)++But we can't naively make an instance for g from this, because deq is not in scope+at the defn of g.  Instead, we have to float out the (new) defn of deq+to widen its scope.  Notice that this floating can't be done in advance -- it only+shows up when specialisation is done.++User SPECIALIZE pragmas+~~~~~~~~~~~~~~~~~~~~~~~+Specialisation pragmas can be digested by the type checker, and implemented+by adding extra definitions along with that of f, in the same way as before++        f@t1/t2 = <f_rhs> t1 t2 d1 d2++Indeed the pragmas *have* to be dealt with by the type checker, because+only it knows how to build the dictionaries d1 and d2!  For example++        g :: Ord a => [a] -> [a]+        {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}++Here, the specialised version of g is an application of g's rhs to the+Ord dictionary for (Tree Int), which only the type checker can conjure+up.  There might not even *be* one, if (Tree Int) is not an instance of+Ord!  (All the other specialision has suitable dictionaries to hand+from actual calls.)++Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because+it is buried in a complex (as-yet-un-desugared) binding group.+Maybe we should say++        f@t1/t2 = f* t1 t2 d1 d2++where f* is the Id f with an IdInfo which says "inline me regardless!".+Indeed all the specialisation could be done in this way.+That in turn means that the simplifier has to be prepared to inline absolutely+any in-scope let-bound thing.+++Again, the pragma should permit polymorphism in unconstrained variables:++        h :: Ord a => [a] -> b -> b+        {-# SPECIALIZE h :: [Int] -> b -> b #-}++We *insist* that all overloaded type variables are specialised to ground types,+(and hence there can be no context inside a SPECIALIZE pragma).+We *permit* unconstrained type variables to be specialised to+        - a ground type+        - or left as a polymorphic type variable+but nothing in between.  So++        {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}++is *illegal*.  (It can be handled, but it adds complication, and gains the+programmer nothing.)+++SPECIALISING INSTANCE DECLARATIONS+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++        instance Foo a => Foo [a] where+                ...+        {-# SPECIALIZE instance Foo [Int] #-}++The original instance decl creates a dictionary-function+definition:++        dfun.Foo.List :: forall a. Foo a -> Foo [a]++The SPECIALIZE pragma just makes a specialised copy, just as for+ordinary function definitions:++        dfun.Foo.List@Int :: Foo [Int]+        dfun.Foo.List@Int = dfun.Foo.List Int dFooInt++The information about what instance of the dfun exist gets added to+the dfun's IdInfo in the same way as a user-defined function too.+++Automatic instance decl specialisation?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Can instance decls be specialised automatically?  It's tricky.+We could collect call-instance information for each dfun, but+then when we specialised their bodies we'd get new call-instances+for ordinary functions; and when we specialised their bodies, we might get+new call-instances of the dfuns, and so on.  This all arises because of+the unrestricted mutual recursion between instance decls and value decls.++Still, there's no actual problem; it just means that we may not do all+the specialisation we could theoretically do.++Furthermore, instance decls are usually exported and used non-locally,+so we'll want to compile enough to get those specialisations done.++Lastly, there's no such thing as a local instance decl, so we can+survive solely by spitting out *usage* information, and then reading that+back in as a pragma when next compiling the file.  So for now,+we only specialise instance decls in response to pragmas.+++SPITTING OUT USAGE INFORMATION+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++To spit out usage information we need to traverse the code collecting+call-instance information for all imported (non-prelude?) functions+and data types. Then we equivalence-class it and spit it out.++This is done at the top-level when all the call instances which escape+must be for imported functions and data types.++*** Not currently done ***+++Partial specialisation by pragmas+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What about partial specialisation:++        k :: (Ord a, Eq b) => [a] -> b -> b -> [a]+        {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}++or even++        {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}++Seems quite reasonable.  Similar things could be done with instance decls:++        instance (Foo a, Foo b) => Foo (a,b) where+                ...+        {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}+        {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}++Ho hum.  Things are complex enough without this.  I pass.+++Requirements for the simplifier+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The simplifier has to be able to take advantage of the specialisation.++* When the simplifier finds an application of a polymorphic f, it looks in+f's IdInfo in case there is a suitable instance to call instead.  This converts++        f t1 t2 d1 d2   ===>   f_t1_t2++Note that the dictionaries get eaten up too!++* Dictionary selection operations on constant dictionaries must be+  short-circuited:++        +.sel Int d     ===>  +Int++The obvious way to do this is in the same way as other specialised+calls: +.sel has inside it some IdInfo which tells that if it's applied+to the type Int then it should eat a dictionary and transform to +Int.++In short, dictionary selectors need IdInfo inside them for constant+methods.++* Exactly the same applies if a superclass dictionary is being+  extracted:++        Eq.sel Int d   ===>   dEqInt++* Something similar applies to dictionary construction too.  Suppose+dfun.Eq.List is the function taking a dictionary for (Eq a) to+one for (Eq [a]).  Then we want++        dfun.Eq.List Int d      ===> dEq.List_Int++Where does the Eq [Int] dictionary come from?  It is built in+response to a SPECIALIZE pragma on the Eq [a] instance decl.++In short, dfun Ids need IdInfo with a specialisation for each+constant instance of their instance declaration.++All this uses a single mechanism: the SpecEnv inside an Id+++What does the specialisation IdInfo look like?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The SpecEnv of an Id maps a list of types (the template) to an expression++        [Type]  |->  Expr++For example, if f has this RuleInfo:++        [Int, a]  ->  \d:Ord Int. f' a++it means that we can replace the call++        f Int t  ===>  (\d. f' t)++This chucks one dictionary away and proceeds with the+specialised version of f, namely f'.+++What can't be done this way?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is no way, post-typechecker, to get a dictionary for (say)+Eq a from a dictionary for Eq [a].  So if we find++        ==.sel [t] d++we can't transform to++        eqList (==.sel t d')++where+        eqList :: (a->a->Bool) -> [a] -> [a] -> Bool++Of course, we currently have no way to automatically derive+eqList, nor to connect it to the Eq [a] instance decl, but you+can imagine that it might somehow be possible.  Taking advantage+of this is permanently ruled out.++Still, this is no great hardship, because we intend to eliminate+overloading altogether anyway!++A note about non-tyvar dictionaries+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some Ids have types like++        forall a,b,c. Eq a -> Ord [a] -> tau++This seems curious at first, because we usually only have dictionary+args whose types are of the form (C a) where a is a type variable.+But this doesn't hold for the functions arising from instance decls,+which sometimes get arguments with types of form (C (T a)) for some+type constructor T.++Should we specialise wrt this compound-type dictionary?  We used to say+"no", saying:+        "This is a heuristic judgement, as indeed is the fact that we+        specialise wrt only dictionaries.  We choose *not* to specialise+        wrt compound dictionaries because at the moment the only place+        they show up is in instance decls, where they are simply plugged+        into a returned dictionary.  So nothing is gained by specialising+        wrt them."++But it is simpler and more uniform to specialise wrt these dicts too;+and in future GHC is likely to support full fledged type signatures+like+        f :: Eq [(a,b)] => ...+++************************************************************************+*                                                                      *+\subsubsection{The new specialiser}+*                                                                      *+************************************************************************++Our basic game plan is this.  For let(rec) bound function+        f :: (C a, D c) => (a,b,c,d) -> Bool++* Find any specialised calls of f, (f ts ds), where+  ts are the type arguments t1 .. t4, and+  ds are the dictionary arguments d1 .. d2.++* Add a new definition for f1 (say):++        f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2++  Note that we abstract over the unconstrained type arguments.++* Add the mapping++        [t1,b,t3,d]  |->  \d1 d2 -> f1 b d++  to the specialisations of f.  This will be used by the+  simplifier to replace calls+                (f t1 t2 t3 t4) da db+  by+                (\d1 d1 -> f1 t2 t4) da db++  All the stuff about how many dictionaries to discard, and what types+  to apply the specialised function to, are handled by the fact that the+  SpecEnv contains a template for the result of the specialisation.++We don't build *partial* specialisations for f.  For example:++  f :: Eq a => a -> a -> Bool+  {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}++Here, little is gained by making a specialised copy of f.+There's a distinct danger that the specialised version would+first build a dictionary for (Eq b, Eq c), and then select the (==)+method from it!  Even if it didn't, not a great deal is saved.++We do, however, generate polymorphic, but not overloaded, specialisations:++  f :: Eq a => [a] -> b -> b -> b+  ... SPECIALISE f :: [Int] -> b -> b -> b ...++Hence, the invariant is this:++        *** no specialised version is overloaded ***+++************************************************************************+*                                                                      *+\subsubsection{The exported function}+*                                                                      *+************************************************************************+-}++-- | Specialise calls to type-class overloaded functions occurring in a program.+specProgram :: ModGuts -> CoreM ModGuts+specProgram guts@(ModGuts { mg_module = this_mod+                          , mg_rules = local_rules+                          , mg_binds = binds })+  = do { dflags <- getDynFlags++             -- Specialise the bindings of this module+       ; (binds', uds) <- runSpecM dflags this_mod (go binds)++             -- Specialise imported functions+       ; hpt_rules <- getRuleBase+       ; let rule_base = extendRuleBaseList hpt_rules local_rules+       ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet+                                                [] rule_base uds++       ; let final_binds+               | null spec_binds = binds'+               | otherwise       = Rec (flattenBinds spec_binds) : binds'+                   -- Note [Glom the bindings if imported functions are specialised]++       ; return (guts { mg_binds = final_binds+                      , mg_rules = new_rules ++ local_rules }) }+  where+        -- We need to start with a Subst that knows all the things+        -- that are in scope, so that the substitution engine doesn't+        -- accidentally re-use a unique that's already in use+        -- Easiest thing is to do it all at once, as if all the top-level+        -- decls were mutually recursive+    top_env = SE { se_subst = GHC.Core.Subst.mkEmptySubst $ mkInScopeSet $ mkVarSet $+                              bindersOfBinds binds+                 , se_interesting = emptyVarSet }++    go []           = return ([], emptyUDs)+    go (bind:binds) = do (binds', uds) <- go binds+                         (bind', uds') <- specBind top_env bind uds+                         return (bind' ++ binds', uds')++{-+Note [Wrap bindings returned by specImports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'specImports' returns a set of specialized bindings. However, these are lacking+necessary floated dictionary bindings, which are returned by+UsageDetails(ud_binds). These dictionaries need to be brought into scope with+'wrapDictBinds' before the bindings returned by 'specImports' can be used. See,+for instance, the 'specImports' call in 'specProgram'.+++Note [Disabling cross-module specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since GHC 7.10 we have performed specialisation of INLINABLE bindings living+in modules outside of the current module. This can sometimes uncover user code+which explodes in size when aggressively optimized. The+-fno-cross-module-specialise option was introduced to allow users to being+bitten by such instances to revert to the pre-7.10 behavior.++See #10491+-}++-- | An argument that we might want to specialise.+-- See Note [Specialising Calls] for the nitty gritty details.+data SpecArg+  =+    -- | Type arguments that should be specialised, due to appearing+    -- free in the type of a 'SpecDict'.+    SpecType Type+    -- | Type arguments that should remain polymorphic.+  | UnspecType+    -- | Dictionaries that should be specialised.+  | SpecDict DictExpr+    -- | Value arguments that should not be specialised.+  | UnspecArg++instance Outputable SpecArg where+  ppr (SpecType t) = text "SpecType" <+> ppr t+  ppr UnspecType   = text "UnspecType"+  ppr (SpecDict d) = text "SpecDict" <+> ppr d+  ppr UnspecArg    = text "UnspecArg"++getSpecDicts :: [SpecArg] -> [DictExpr]+getSpecDicts = mapMaybe go+  where+    go (SpecDict d) = Just d+    go _            = Nothing++getSpecTypes :: [SpecArg] -> [Type]+getSpecTypes = mapMaybe go+  where+    go (SpecType t) = Just t+    go _            = Nothing++isUnspecArg :: SpecArg -> Bool+isUnspecArg UnspecArg  = True+isUnspecArg UnspecType = True+isUnspecArg _          = False++isValueArg :: SpecArg -> Bool+isValueArg UnspecArg    = True+isValueArg (SpecDict _) = True+isValueArg _            = False++-- | Given binders from an original function 'f', and the 'SpecArg's+-- corresponding to its usage, compute everything necessary to build+-- a specialisation.+--+-- We will use a running example. Consider the function+--+--    foo :: forall a b. Eq a => Int -> blah+--    foo @a @b dEqA i = blah+--+-- which is called with the 'CallInfo'+--+--    [SpecType T1, UnspecType, SpecDict dEqT1, UnspecArg]+--+-- We'd eventually like to build the RULE+--+--    RULE "SPEC foo @T1 _"+--      forall @a @b (dEqA' :: Eq a).+--        foo @T1 @b dEqA' = $sfoo @b+--+-- and the specialisation '$sfoo'+--+--    $sfoo :: forall b. Int -> blah+--    $sfoo @b = \i -> SUBST[a->T1, dEqA->dEqA'] blah+--+-- The cases for 'specHeader' below are presented in the same order as this+-- running example. The result of 'specHeader' for this example is as follows:+--+--    ( -- Returned arguments+--      env + [a -> T1, deqA -> dEqA']+--    , []+--+--      -- RULE helpers+--    , [b, dx', i]+--    , [T1, b, dx', i]+--+--      -- Specialised function helpers+--    , [b, i]+--    , [dx]+--    , [T1, b, dx_spec, i]+--    )+specHeader+     :: SpecEnv+     -> [CoreBndr]  -- The binders from the original function 'f'+     -> [SpecArg]   -- From the CallInfo+     -> SpecM ( -- Returned arguments+                SpecEnv      -- Substitution to apply to the body of 'f'+              , [CoreBndr]   -- All the remaining unspecialised args from the original function 'f'++                -- RULE helpers+              , [CoreBndr]   -- Binders for the RULE+              , [CoreArg]    -- Args for the LHS of the rule++                -- Specialised function helpers+              , [CoreBndr]   -- Binders for $sf+              , [DictBind]   -- Auxiliary dictionary bindings+              , [CoreExpr]   -- Specialised arguments for unfolding+              )++-- We want to specialise on type 'T1', and so we must construct a substitution+-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding+-- details.+specHeader env (bndr : bndrs) (SpecType t : args)+  = do { let env' = extendTvSubstList env [(bndr, t)]+       ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)+            <- specHeader env' bndrs args+       ; pure ( env''+              , unused_bndrs+              , rule_bs+              , Type t : rule_es+              , bs'+              , dx+              , Type t : spec_args+              )+       }++-- Next we have a type that we don't want to specialise. We need to perform+-- a substitution on it (in case the type refers to 'a'). Additionally, we need+-- to produce a binder, LHS argument and RHS argument for the resulting rule,+-- /and/ a binder for the specialised body.+specHeader env (bndr : bndrs) (UnspecType : args)+  = do { let (env', bndr') = substBndr env bndr+       ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)+            <- specHeader env' bndrs args+       ; pure ( env''+              , unused_bndrs+              , bndr' : rule_bs+              , varToCoreExpr bndr' : rule_es+              , bndr' : bs'+              , dx+              , varToCoreExpr bndr' : spec_args+              )+       }++-- Next we want to specialise the 'Eq a' dict away. We need to construct+-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for+-- the nitty-gritty), as a LHS rule and unfolding details.+specHeader env (bndr : bndrs) (SpecDict d : args)+  = do { inst_dict_id <- newDictBndr env bndr+       ; let (rhs_env2, dx_binds, spec_dict_args')+                = bindAuxiliaryDicts env [bndr] [d] [inst_dict_id]+       ; (env', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)+             <- specHeader rhs_env2 bndrs args+       ; pure ( env'+              , unused_bndrs+              -- See Note [Evidence foralls]+              , exprFreeIdsList (varToCoreExpr inst_dict_id) ++ rule_bs+              , varToCoreExpr inst_dict_id : rule_es+              , bs'+              , dx_binds ++ dx+              , spec_dict_args' ++ spec_args+              )+       }++-- Finally, we have the unspecialised argument 'i'. We need to produce+-- a binder, LHS and RHS argument for the RULE, and a binder for the+-- specialised body.+--+-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is+-- why 'i' doesn't appear in our RULE above. But we have no guarantee that+-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so+-- this case must be here.+specHeader env (bndr : bndrs) (UnspecArg : args)+  = do { let (env', bndr') = substBndr env bndr+       ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)+             <- specHeader env' bndrs args+       ; pure ( env''+              , unused_bndrs+              , bndr' : rule_bs+              , varToCoreExpr bndr' : rule_es+              , bndr' : bs'+              , dx+              , varToCoreExpr bndr' : spec_args+              )+       }++-- Return all remaining binders from the original function. These have the+-- invariant that they should all correspond to unspecialised arguments, so+-- it's safe to stop processing at this point.+specHeader env bndrs [] = pure (env, bndrs, [], [], [], [], [])+specHeader env [] _     = pure (env, [], [], [], [], [], [])+++-- | Specialise a set of calls to imported bindings+specImports :: DynFlags+            -> Module+            -> SpecEnv          -- Passed in so that all top-level Ids are in scope+            -> VarSet           -- Don't specialise these ones+                                -- See Note [Avoiding recursive specialisation]+            -> [Id]             -- Stack of imported functions being specialised+            -> RuleBase         -- Rules from this module and the home package+                                -- (but not external packages, which can change)+            -> UsageDetails     -- Calls for imported things, and floating bindings+            -> CoreM ( [CoreRule]   -- New rules+                     , [CoreBind] ) -- Specialised bindings+                                    -- See Note [Wrapping bindings returned by specImports]+specImports dflags this_mod top_env done callers rule_base+            (MkUD { ud_binds = dict_binds, ud_calls = calls })+  -- See Note [Disabling cross-module specialisation]+  | not $ gopt Opt_CrossModuleSpecialise dflags+  = return ([], [])++  | otherwise+  = do { let import_calls = dVarEnvElts calls+       ; (rules, spec_binds) <- go rule_base import_calls++             -- Don't forget to wrap the specialized bindings with+             -- bindings for the needed dictionaries.+             -- See Note [Wrap bindings returned by specImports]+       ; let spec_binds' = wrapDictBinds dict_binds spec_binds++       ; return (rules, spec_binds') }+  where+    go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])+    go _ [] = return ([], [])+    go rb (cis@(CIS fn _) : other_calls)+      = do { let ok_calls = filterCalls cis dict_binds+                     -- Drop calls that (directly or indirectly) refer to fn+                     -- See Note [Avoiding loops]+--           ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn+--                                                       , text "calls" <+> ppr cis+--                                                       , text "ud_binds =" <+> ppr dict_binds+--                                                       , text "dump set =" <+> ppr dump_set+--                                                       , text "filtered calls =" <+> ppr ok_calls ])+           ; (rules1, spec_binds1) <- specImport dflags this_mod top_env+                                                 done callers rb fn ok_calls++           ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls+           ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }++specImport :: DynFlags+           -> Module+           -> SpecEnv               -- Passed in so that all top-level Ids are in scope+           -> VarSet                -- Don't specialise these+                                    -- See Note [Avoiding recursive specialisation]+           -> [Id]                  -- Stack of imported functions being specialised+           -> RuleBase              -- Rules from this module+           -> Id -> [CallInfo]      -- Imported function and calls for it+           -> CoreM ( [CoreRule]    -- New rules+                    , [CoreBind] )  -- Specialised bindings+specImport dflags this_mod top_env done callers rb fn calls_for_fn+  | fn `elemVarSet` done+  = return ([], [])     -- No warning.  This actually happens all the time+                        -- when specialising a recursive function, because+                        -- the RHS of the specialised function contains a recursive+                        -- call to the original function++  | null calls_for_fn   -- We filtered out all the calls in deleteCallsMentioning+  = return ([], [])++  | wantSpecImport dflags unfolding+  , Just rhs <- maybeUnfoldingTemplate unfolding+  = do {     -- Get rules from the external package state+             -- We keep doing this in case we "page-fault in"+             -- more rules as we go along+       ; 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++       ; (rules1, spec_pairs, uds)+             <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $+                runSpecM dflags this_mod $+                specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs+       ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]+             -- After the rules kick in we may get recursion, but+             -- we rely on a global GlomBinds to sort that out later+             -- See Note [Glom the bindings if imported functions are specialised]++              -- Now specialise any cascaded calls+       ; (rules2, spec_binds2) <- -- pprTrace "specImport 2" (ppr fn $$ ppr rules1 $$ ppr spec_binds1) $+                                  specImports dflags this_mod top_env+                                              (extendVarSet done fn)+                                              (fn:callers)+                                              (extendRuleBaseList rb rules1)+                                              uds++       ; let final_binds = spec_binds2 ++ spec_binds1++       ; return (rules2 ++ rules1, final_binds) }++  | otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn+                   ; return ([], [])}++  where+    unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers++-- | Returns whether or not to show a missed-spec warning.+-- If -Wall-missed-specializations is on, show the warning.+-- Otherwise, if -Wmissed-specializations is on, only show a warning+-- if there is at least one imported function being specialized,+-- and if all imported functions are marked with an inline pragma+-- Use the most specific warning as the reason.+tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()+-- See Note [Warning about missed specialisations]+tryWarnMissingSpecs dflags callers fn calls_for_fn+  | wopt Opt_WarnMissedSpecs dflags+    && not (null callers)+    && allCallersInlined                  = doWarn $ Reason Opt_WarnMissedSpecs+  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ Reason Opt_WarnAllMissedSpecs+  | otherwise                             = return ()+  where+    allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers+    doWarn reason =+      warnMsg reason+        (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))+                2 (vcat [ text "when specialising" <+> quotes (ppr caller)+                        | caller <- callers])+          , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))+          , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])++wantSpecImport :: DynFlags -> Unfolding -> Bool+-- See Note [Specialise imported INLINABLE things]+wantSpecImport dflags unf+ = case unf of+     NoUnfolding      -> False+     BootUnfolding    -> False+     OtherCon {}      -> False+     DFunUnfolding {} -> True+     CoreUnfolding { uf_src = src, uf_guidance = _guidance }+       | gopt Opt_SpecialiseAggressively dflags -> True+       | isStableSource src -> True+               -- Specialise even INLINE things; it hasn't inlined yet,+               -- so perhaps it never will.  Moreover it may have calls+               -- inside it that we want to specialise+       | otherwise -> False    -- Stable, not INLINE, hence INLINABLE++{- Note [Warning about missed specialisations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose+ * In module Lib, you carefully mark a function 'foo' INLINABLE+ * Import Lib(foo) into another module M+ * Call 'foo' at some specialised type in M+Then you jolly well expect it to be specialised in M.  But what if+'foo' calls another function 'Lib.bar'.  Then you'd like 'bar' to be+specialised too.  But if 'bar' is not marked INLINABLE it may well+not be specialised.  The warning Opt_WarnMissedSpecs warns about this.++It's more noisy to warning about a missed specialisation opportunity+for /every/ overloaded imported function, but sometimes useful. That+is what Opt_WarnAllMissedSpecs does.++ToDo: warn about missed opportunities for local functions.++Note [Specialise imported INLINABLE things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What imported functions do we specialise?  The basic set is+ * DFuns and things with INLINABLE pragmas.+but with -fspecialise-aggressively we add+ * Anything with an unfolding template++#8874 has a good example of why we want to auto-specialise DFuns.++We have the -fspecialise-aggressively flag (usually off), because we+risk lots of orphan modules from over-vigorous specialisation.+However it's not a big deal: anything non-recursive with an+unfolding-template will probably have been inlined already.++Note [Glom the bindings if imported functions are specialised]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an imported, *recursive*, INLINABLE function+   f :: Eq a => a -> a+   f = /\a \d x. ...(f a d)...+In the module being compiled we have+   g x = f (x::Int)+Now we'll make a specialised function+   f_spec :: Int -> Int+   f_spec = \x -> ...(f Int dInt)...+   {-# RULE  f Int _ = f_spec #-}+   g = \x. f Int dInt x+Note that f_spec doesn't look recursive+After rewriting with the RULE, we get+   f_spec = \x -> ...(f_spec)...+BUT since f_spec was non-recursive before it'll *stay* non-recursive.+The occurrence analyser never turns a NonRec into a Rec.  So we must+make sure that f_spec is recursive.  Easiest thing is to make all+the specialisations for imported bindings recursive.+++Note [Avoiding recursive specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we specialise 'f' we may find new overloaded calls to 'g', 'h' in+'f's RHS.  So we want to specialise g,h.  But we don't want to+specialise f any more!  It's possible that f's RHS might have a+recursive yet-more-specialised call, so we'd diverge in that case.+And if the call is to the same type, one specialisation is enough.+Avoiding this recursive specialisation loop is the reason for the+'done' VarSet passed to specImports and specImport.++************************************************************************+*                                                                      *+\subsubsection{@specExpr@: the main function}+*                                                                      *+************************************************************************+-}++data SpecEnv+  = SE { se_subst :: GHC.Core.Subst.Subst+             -- We carry a substitution down:+             -- a) we must clone any binding that might float outwards,+             --    to avoid name clashes+             -- b) we carry a type substitution to use when analysing+             --    the RHS of specialised bindings (no type-let!)+++       , se_interesting :: VarSet+             -- Dict Ids that we know something about+             -- and hence may be worth specialising against+             -- See Note [Interesting dictionary arguments]+     }++specVar :: SpecEnv -> Id -> CoreExpr+specVar env v = GHC.Core.Subst.lookupIdSubst (text "specVar") (se_subst env) v++specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)++---------------- First the easy cases --------------------+specExpr env (Type ty)     = return (Type     (substTy env ty), emptyUDs)+specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)+specExpr env (Var v)       = return (specVar env v, emptyUDs)+specExpr _   (Lit lit)     = return (Lit lit,       emptyUDs)+specExpr env (Cast e co)+  = do { (e', uds) <- specExpr env e+       ; return ((mkCast e' (substCo env co)), uds) }+specExpr env (Tick tickish body)+  = do { (body', uds) <- specExpr env body+       ; return (Tick (specTickish env tickish) body', uds) }++---------------- Applications might generate a call instance --------------------+specExpr env expr@(App {})+  = go expr []+  where+    go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg+                               (fun', uds_app) <- go fun (arg':args)+                               return (App fun' arg', uds_arg `plusUDs` uds_app)++    go (Var f)       args = case specVar env f of+                                Var f' -> return (Var f', mkCallUDs env f' args)+                                e'     -> return (e', emptyUDs) -- I don't expect this!+    go other         _    = specExpr env other++---------------- Lambda/case require dumping of usage details --------------------+specExpr env e@(Lam _ _) = do+    (body', uds) <- specExpr env' body+    let (free_uds, dumped_dbs) = dumpUDs bndrs' uds+    return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds)+  where+    (bndrs, body) = collectBinders e+    (env', bndrs') = substBndrs env bndrs+        -- More efficient to collect a group of binders together all at once+        -- and we don't want to split a lambda group with dumped bindings++specExpr env (Case scrut case_bndr ty alts)+  = do { (scrut', scrut_uds) <- specExpr env scrut+       ; (scrut'', case_bndr', alts', alts_uds)+             <- specCase env scrut' case_bndr alts+       ; return (Case scrut'' case_bndr' (substTy env ty) alts'+                , scrut_uds `plusUDs` alts_uds) }++---------------- Finally, let is the interesting case --------------------+specExpr env (Let bind body)+  = do { -- Clone binders+         (rhs_env, body_env, bind') <- cloneBindSM env bind++         -- Deal with the body+       ; (body', body_uds) <- specExpr body_env body++        -- Deal with the bindings+      ; (binds', uds) <- specBind rhs_env bind' body_uds++        -- All done+      ; return (foldr Let body' binds', uds) }++specTickish :: SpecEnv -> Tickish Id -> Tickish Id+specTickish env (Breakpoint ix ids)+  = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]+  -- drop vars from the list if they have a non-variable substitution.+  -- should never happen, but it's harmless to drop them anyway.+specTickish _ other_tickish = other_tickish++specCase :: SpecEnv+         -> CoreExpr            -- Scrutinee, already done+         -> Id -> [CoreAlt]+         -> SpecM ( CoreExpr    -- New scrutinee+                  , Id+                  , [CoreAlt]+                  , UsageDetails)+specCase env scrut' case_bndr [(con, args, rhs)]+  | isDictId case_bndr           -- See Note [Floating dictionaries out of cases]+  , interestingDict env scrut'+  , not (isDeadBinder case_bndr && null sc_args')+  = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')++       ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')+                              [(con, args', Var sc_arg')]+                       | sc_arg' <- sc_args' ]++             -- Extend the substitution for RHS to map the *original* binders+             -- to their floated versions.+             mb_sc_flts :: [Maybe DictId]+             mb_sc_flts = map (lookupVarEnv clone_env) args'+             clone_env  = zipVarEnv sc_args' sc_args_flt+             subst_prs  = (case_bndr, Var case_bndr_flt)+                        : [ (arg, Var sc_flt)+                          | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]+             env_rhs' = env_rhs { se_subst = GHC.Core.Subst.extendIdSubstList (se_subst env_rhs) subst_prs+                                , se_interesting = se_interesting env_rhs `extendVarSetList`+                                                   (case_bndr_flt : sc_args_flt) }++       ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs+       ; let scrut_bind    = mkDB (NonRec case_bndr_flt scrut')+             case_bndr_set = unitVarSet case_bndr_flt+             sc_binds      = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)+                             | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]+             flt_binds     = scrut_bind : sc_binds+             (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds+             all_uds = flt_binds `addDictBinds` free_uds+             alt'    = (con, args', wrapDictBindsE dumped_dbs rhs')+       ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }+  where+    (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)+    sc_args' = filter is_flt_sc_arg args'++    clone_me bndr = do { uniq <- getUniqueM+                       ; return (mkUserLocalOrCoVar occ uniq ty loc) }+       where+         name = idName bndr+         ty   = idType bndr+         occ  = nameOccName name+         loc  = getSrcSpan name++    arg_set = mkVarSet args'+    is_flt_sc_arg var =  isId var+                      && not (isDeadBinder var)+                      && isDictTy var_ty+                      && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set)+       where+         var_ty = idType var+++specCase env scrut case_bndr alts+  = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts+       ; return (scrut, case_bndr', alts', uds_alts) }+  where+    (env_alt, case_bndr') = substBndr env case_bndr+    spec_alt (con, args, rhs) = do+          (rhs', uds) <- specExpr env_rhs rhs+          let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds+          return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)+        where+          (env_rhs, args') = substBndrs env_alt args++{-+Note [Floating dictionaries out of cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   g = \d. case d of { MkD sc ... -> ...(f sc)... }+Naively we can't float d2's binding out of the case expression,+because 'sc' is bound by the case, and that in turn means we can't+specialise f, which seems a pity.++So we invert the case, by floating out a binding+for 'sc_flt' thus:+    sc_flt = case d of { MkD sc ... -> sc }+Now we can float the call instance for 'f'.  Indeed this is just+what'll happen if 'sc' was originally bound with a let binding,+but case is more efficient, and necessary with equalities. So it's+good to work with both.++You might think that this won't make any difference, because the+call instance will only get nuked by the \d.  BUT if 'g' itself is+specialised, then transitively we should be able to specialise f.++In general, given+   case e of cb { MkD sc ... -> ...(f sc)... }+we transform to+   let cb_flt = e+       sc_flt = case cb_flt of { MkD sc ... -> sc }+   in+   case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }++The "_flt" things are the floated binds; we use the current substitution+to substitute sc -> sc_flt in the RHS++************************************************************************+*                                                                      *+                     Dealing with a binding+*                                                                      *+************************************************************************+-}++specBind :: SpecEnv                     -- Use this for RHSs+         -> CoreBind                    -- Binders are already cloned by cloneBindSM,+                                        -- but RHSs are un-processed+         -> UsageDetails                -- Info on how the scope of the binding+         -> SpecM ([CoreBind],          -- New bindings+                   UsageDetails)        -- And info to pass upstream++-- Returned UsageDetails:+--    No calls for binders of this bind+specBind rhs_env (NonRec fn rhs) body_uds+  = do { (rhs', rhs_uds) <- specExpr rhs_env rhs+       ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs++       ; let pairs = spec_defns ++ [(fn', rhs')]+                        -- fn' mentions the spec_defns in its rules,+                        -- so put the latter first++             combined_uds = body_uds1 `plusUDs` rhs_uds++             (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds++             final_binds :: [DictBind]+             -- See Note [From non-recursive to recursive]+             final_binds+               | not (isEmptyBag dump_dbs)+               , not (null spec_defns)+               = [recWithDumpedDicts pairs dump_dbs]+               | otherwise+               = [mkDB $ NonRec b r | (b,r) <- pairs]+                 ++ bagToList dump_dbs++       ; if float_all then+             -- Rather than discard the calls mentioning the bound variables+             -- we float this (dictionary) binding along with the others+              return ([], free_uds `snocDictBinds` final_binds)+         else+             -- No call in final_uds mentions bound variables,+             -- so we can just leave the binding here+              return (map fst final_binds, free_uds) }+++specBind rhs_env (Rec pairs) body_uds+       -- Note [Specialising a recursive group]+  = do { let (bndrs,rhss) = unzip pairs+       ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss+       ; let scope_uds = body_uds `plusUDs` rhs_uds+                       -- Includes binds and calls arising from rhss++       ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs++       ; (bndrs3, spec_defns3, uds3)+             <- if null spec_defns1  -- Common case: no specialisation+                then return (bndrs1, [], uds1)+                else do {            -- Specialisation occurred; do it again+                          (bndrs2, spec_defns2, uds2)+                              <- specDefns rhs_env uds1 (bndrs1 `zip` rhss)+                        ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }++       ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3+             final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')+                                             dumped_dbs++       ; if float_all then+              return ([], final_uds `snocDictBind` final_bind)+         else+              return ([fst final_bind], final_uds) }+++---------------------------+specDefns :: SpecEnv+          -> UsageDetails               -- Info on how it is used in its scope+          -> [(OutId,InExpr)]           -- The things being bound and their un-processed RHS+          -> SpecM ([OutId],            -- Original Ids with RULES added+                    [(OutId,OutExpr)],  -- Extra, specialised bindings+                    UsageDetails)       -- Stuff to fling upwards from the specialised versions++-- Specialise a list of bindings (the contents of a Rec), but flowing usages+-- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }+-- Then if the input CallDetails has a specialised call for 'g', whose specialisation+-- in turn generates a specialised call for 'f', we catch that in this one sweep.+-- But not vice versa (it's a fixpoint problem).++specDefns _env uds []+  = return ([], [], uds)+specDefns env uds ((bndr,rhs):pairs)+  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs+       ; (bndr1, spec_defns2, uds2)  <- specDefn env uds1 bndr rhs+       ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }++---------------------------+specDefn :: SpecEnv+         -> UsageDetails                -- Info on how it is used in its scope+         -> OutId -> InExpr             -- The thing being bound and its un-processed RHS+         -> SpecM (Id,                  -- Original Id with added RULES+                   [(Id,CoreExpr)],     -- Extra, specialised bindings+                   UsageDetails)        -- Stuff to fling upwards from the specialised versions++specDefn env body_uds fn rhs+  = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds+             rules_for_me = idCoreRules fn+       ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me+                                                    calls_for_me fn rhs+       ; return ( fn `addIdSpecialisations` rules+                , spec_defns+                , body_uds_without_me `plusUDs` spec_uds) }+                -- It's important that the `plusUDs` is this way+                -- round, because body_uds_without_me may bind+                -- dictionaries that are used in calls_for_me passed+                -- to specDefn.  So the dictionary bindings in+                -- spec_uds may mention dictionaries bound in+                -- body_uds_without_me++---------------------------+specCalls :: Maybe Module      -- Just this_mod  =>  specialising imported fn+                               -- Nothing        =>  specialising local fn+          -> SpecEnv+          -> [CoreRule]        -- Existing RULES for the fn+          -> [CallInfo]+          -> OutId -> InExpr+          -> SpecM SpecInfo    -- New rules, specialised bindings, and usage details++-- This function checks existing rules, and does not create+-- duplicate ones. So the caller does not need to do this filtering.+-- See 'already_covered'++type SpecInfo = ( [CoreRule]       -- Specialisation rules+                , [(Id,CoreExpr)]  -- Specialised definition+                , UsageDetails )   -- Usage details from specialised RHSs++specCalls mb_mod env existing_rules calls_for_me fn rhs+        -- The first case is the interesting one+  |  callSpecArity pis <= fn_arity      -- See Note [Specialisation Must Preserve Sharing]+  && notNull calls_for_me               -- And there are some calls to specialise+  && not (isNeverActive (idInlineActivation fn))+        -- Don't specialise NOINLINE things+        -- See Note [Auto-specialisation and RULES]++--   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small+--      See Note [Inline specialisation] for why we do not+--      switch off specialisation for inline functions++  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $+    foldlM spec_call ([], [], emptyUDs) calls_for_me++  | otherwise   -- No calls or RHS doesn't fit our preconceptions+  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,+          text "Missed specialisation opportunity for"+                                 <+> ppr fn $$ _trace_doc )+          -- Note [Specialisation shape]+    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $+    return ([], [], emptyUDs)+  where+    _trace_doc = sep [ ppr rhs_tyvars, ppr rhs_bndrs+                     , ppr (idInlineActivation fn) ]++    fn_type                 = idType fn+    fn_arity                = idArity fn+    fn_unf                  = realIdUnfolding fn  -- Ignore loop-breaker-ness here+    pis                     = fst $ splitPiTys fn_type+    theta                   = getTheta pis+    n_dicts                 = length theta+    inl_prag                = idInlinePragma fn+    inl_act                 = inlinePragmaActivation inl_prag+    is_local                = isLocalId fn++        -- Figure out whether the function has an INLINE pragma+        -- See Note [Inline specialisations]++    (rhs_bndrs, rhs_body)      = collectBindersPushingCo rhs+                                 -- See Note [Account for casts in binding]+    rhs_tyvars = filter isTyVar rhs_bndrs++    in_scope = GHC.Core.Subst.substInScope (se_subst env)++    already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool+    already_covered dflags new_rules args      -- Note [Specialisations already covered]+       = isJust (lookupRule dflags (in_scope, realIdUnfolding)+                            (const True) fn args+                            (new_rules ++ existing_rules))+         -- NB: we look both in the new_rules (generated by this invocation+         --     of specCalls), and in existing_rules (passed in to specCalls)++    ----------------------------------------------------------+        -- Specialise to one particular call pattern+    spec_call :: SpecInfo                         -- Accumulating parameter+              -> CallInfo                         -- Call instance+              -> SpecM SpecInfo+    spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)+              (CI { ci_key = call_args, ci_arity = call_arity })+      = ASSERT(call_arity <= fn_arity)++        -- See Note [Specialising Calls]+        do { (rhs_env2, unused_bndrs, rule_bndrs, rule_args, unspec_bndrs, dx_binds, spec_args)+               <- specHeader env rhs_bndrs $ dropWhileEndLE isUnspecArg call_args+           ; let rhs_body' = mkLams unused_bndrs rhs_body+           ; dflags <- getDynFlags+           ; if already_covered dflags rules_acc rule_args+             then return spec_acc+             else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids+                  --                           , text "rhs_env2" <+> ppr (se_subst rhs_env2)+                  --                           , ppr dx_binds ]) $+                  do+           {    -- Figure out the type of the specialised function+             let body = mkLams unspec_bndrs rhs_body'+                 body_ty = substTy rhs_env2 $ exprType body+                 (lam_extra_args, app_args)     -- See Note [Specialisations Must Be Lifted]+                   | isUnliftedType body_ty     -- C.f. GHC.Core.Op.WorkWrap.Lib.mkWorkerArgs+                   , not (isJoinId fn)+                   = ([voidArgId], voidPrimId : unspec_bndrs)+                   | otherwise = ([], unspec_bndrs)+                 join_arity_change = length app_args - length rule_args+                 spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn+                                 = Just (orig_join_arity + join_arity_change)+                                 | otherwise+                                 = Nothing++           ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_extra_args body)+           ; let spec_id_ty = exprType spec_rhs+           ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity+           ; this_mod <- getModule+           ; let+                -- The rule to put in the function's specialisation is:+                --      forall x @b d1' d2'.+                --          f x @T1 @b @T2 d1' d2' = f1 x @b+                -- See Note [Specialising Calls]+                herald = case mb_mod of+                           Nothing        -- Specialising local fn+                               -> text "SPEC"+                           Just this_mod  -- Specialising imported fn+                               -> text "SPEC/" <> ppr this_mod++                rule_name = mkFastString $ showSDoc dflags $+                            herald <+> ftext (occNameFS (getOccName fn))+                                   <+> hsep (mapMaybe ppr_call_key_ty call_args)+                            -- This name ends up in interface files, so use occNameString.+                            -- Otherwise uniques end up there, making builds+                            -- less deterministic (See #4012 comment:61 ff)++                rule_wout_eta = mkRule+                                  this_mod+                                  True {- Auto generated -}+                                  is_local+                                  rule_name+                                  inl_act       -- Note [Auto-specialisation and RULES]+                                  (idName fn)+                                  rule_bndrs+                                  rule_args+                                  (mkVarApps (Var spec_f) app_args)++                spec_rule+                  = case isJoinId_maybe fn of+                      Just join_arity -> etaExpandToJoinPointRule join_arity+                                                                  rule_wout_eta+                      Nothing -> rule_wout_eta++                -- Add the { d1' = dx1; d2' = dx2 } usage stuff+                -- See Note [Specialising Calls]+                spec_uds = foldr consDictBind rhs_uds dx_binds++                --------------------------------------+                -- Add a suitable unfolding if the spec_inl_prag says so+                -- See Note [Inline specialisations]+                (spec_inl_prag, spec_unf)+                  | not is_local && isStrongLoopBreaker (idOccInfo fn)+                  = (neverInlinePragma, noUnfolding)+                        -- See Note [Specialising imported functions] in OccurAnal++                  | InlinePragma { inl_inline = Inlinable } <- inl_prag+                  = (inl_prag { inl_inline = NoUserInline }, noUnfolding)++                  | otherwise+                  = (inl_prag, specUnfolding dflags unspec_bndrs spec_app n_dicts fn_unf)++                spec_app e = e `mkApps` spec_args++                --------------------------------------+                -- Adding arity information just propagates it a bit faster+                --      See Note [Arity decrease] in GHC.Core.Op.Simplify+                -- Copy InlinePragma information from the parent Id.+                -- So if f has INLINE[1] so does spec_f+                spec_f_w_arity = spec_f `setIdArity`      max 0 (fn_arity - n_dicts)+                                        `setInlinePragma` spec_inl_prag+                                        `setIdUnfolding`  spec_unf+                                        `asJoinId_maybe`  spec_join_arity++                _rule_trace_doc = vcat [ ppr spec_f, ppr fn_type, ppr spec_id_ty+                                       , ppr rhs_bndrs, ppr call_args+                                       , ppr spec_rule+                                       ]++           ; -- pprTrace "spec_call: rule" _rule_trace_doc+             return ( spec_rule                  : rules_acc+                    , (spec_f_w_arity, spec_rhs) : pairs_acc+                    , spec_uds           `plusUDs` uds_acc+                    ) } }++{- Note [Specialisation Must Preserve Sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function:++    f :: forall a. Eq a => a -> blah+    f =+      if expensive+         then f1+         else f2++As written, all calls to 'f' will share 'expensive'. But if we specialise 'f'+at 'Int', eg:++    $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2)++    RULE "SPEC f"+      forall (d :: Eq Int).+        f Int _ = $sfIntf++We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes!++To avoid this, we only generate specialisations for functions whose arity is+enough to bind all of the arguments we need to specialise.  This ensures our+specialised functions don't do any work before receiving all of their dicts,+and thus avoids the 'f' case above.++Note [Specialisations Must Be Lifted]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function 'f':++    f = forall a. Eq a => Array# a++used like++    case x of+      True -> ...f @Int dEqInt...+      False -> 0++Naively, we might generate an (expensive) specialisation++    $sfInt :: Array# Int++even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to+the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to+preserve laziness.++Note [Specialising Calls]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have a function:++    f :: Int -> forall a b c. (Foo a, Foo c) => Bar -> Qux+    f = \x -> /\ a b c -> \d1 d2 bar -> rhs++and suppose it is called at:++    f 7 @T1 @T2 @T3 dFooT1 dFooT3 bar++This call is described as a 'CallInfo' whose 'ci_key' is++    [ UnspecArg, SpecType T1, UnspecType, SpecType T3, SpecDict dFooT1+    , SpecDict dFooT3, UnspecArg ]++Why are 'a' and 'c' identified as 'SpecType', while 'b' is 'UnspecType'?+Because we must specialise the function on type variables that appear+free in its *dictionary* arguments; but not on type variables that do not+appear in any dictionaries, i.e. are fully polymorphic.++Because this call has dictionaries applied, we'd like to specialise+the call on any type argument that appears free in those dictionaries.+In this case, those are (a ~ T1, c ~ T3).++As a result, we'd like to generate a function:++    $sf :: Int -> forall b. Bar -> Qux+    $sf = SUBST[a->T1, c->T3, d1->d1', d2->d2'] (\x -> /\ b -> \bar -> rhs)++Note that the substitution is applied to the whole thing.  This is+convenient, but just slightly fragile.  Notably:+  * There had better be no name clashes in a/b/c++We must construct a rewrite rule:++    RULE "SPEC f @T1 _ @T3"+      forall (x :: Int) (@b :: Type) (d1' :: Foo T1) (d2' :: Foo T3).+        f x @T1 @b @T3 d1' d2' = $sf x @b++In the rule, d1' and d2' are just wildcards, not used in the RHS.  Note+additionally that 'bar' isn't captured by this rule --- we bind only+enough etas in order to capture all of the *specialised* arguments.++Finally, we must also construct the usage-details++     { d1' = dx1; d2' = dx2 }++where d1', d2' are cloned versions of d1,d2, with the type substitution+applied.  These auxiliary bindings just avoid duplication of dx1, dx2.++Note [Account for casts in binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: Eq a => a -> IO ()+   {-# INLINABLE f+       StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g+     #-}+   f = ...++In f's stable unfolding we have done some modest simplification which+has pushed the cast to the outside.  (I wonder if this is the Right+Thing, but it's what happens now; see GHC.Core.Op.Simplify.Utils Note [Casts and+lambdas].)  Now that stable unfolding must be specialised, so we want+to push the cast back inside. It would be terrible if the cast+defeated specialisation!  Hence the use of collectBindersPushingCo.++Note [Evidence foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose (#12212) that we are specialising+   f :: forall a b. (Num a, F a ~ F b) => blah+with a=b=Int. Then the RULE will be something like+   RULE forall (d:Num Int) (g :: F Int ~ F Int).+        f Int Int d g = f_spec+But both varToCoreExpr (when constructing the LHS args), and the+simplifier (when simplifying the LHS args), will transform to+   RULE forall (d:Num Int) (g :: F Int ~ F Int).+        f Int Int d <F Int> = f_spec+by replacing g with Refl.  So now 'g' is unbound, which results in a later+crash. So we use Refl right off the bat, and do not forall-quantify 'g':+ * varToCoreExpr generates a Refl+ * exprsFreeIdsList returns the Ids bound by the args,+   which won't include g++You might wonder if this will match as often, but the simplifier replaces+complicated Refl coercions with Refl pretty aggressively.++Note [Orphans and auto-generated rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we specialise an INLINABLE function, or when we have+-fspecialise-aggressively, we auto-generate RULES that are orphans.+We don't want to warn about these, or we'd generate a lot of warnings.+Thus, we only warn about user-specified orphan rules.++Indeed, we don't even treat the module as an orphan module if it has+auto-generated *rule* orphans.  Orphan modules are read every time we+compile, so they are pretty obtrusive and slow down every compilation,+even non-optimised ones.  (Reason: for type class instances it's a+type correctness issue.)  But specialisation rules are strictly for+*optimisation* only so it's fine not to read the interface.++What this means is that a SPEC rules from auto-specialisation in+module M will be used in other modules only if M.hi has been read for+some other reason, which is actually pretty likely.+-}++bindAuxiliaryDicts+        :: SpecEnv+        -> [DictId] -> [CoreExpr]   -- Original dict bndrs, and the witnessing expressions+        -> [DictId]                 -- A cloned dict-id for each dict arg+        -> (SpecEnv,                -- Substitute for all orig_dicts+            [DictBind],             -- Auxiliary dict bindings+            [CoreExpr])             -- Witnessing expressions (all trivial)+-- Bind any dictionary arguments to fresh names, to preserve sharing+bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })+                   orig_dict_ids call_ds inst_dict_ids+  = (env', dx_binds, spec_dict_args)+  where+    (dx_binds, spec_dict_args) = go call_ds inst_dict_ids+    env' = env { se_subst = subst `GHC.Core.Subst.extendSubstList`+                                     (orig_dict_ids `zip` spec_dict_args)+                                  `GHC.Core.Subst.extendInScopeList` dx_ids+               , se_interesting = interesting `unionVarSet` interesting_dicts }++    dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds]+    interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds+                                 , interestingDict env dx ]+                  -- See Note [Make the new dictionaries interesting]++    go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr])+    go [] _  = ([], [])+    go (dx:dxs) (dx_id:dx_ids)+      | exprIsTrivial dx = (dx_binds,                          dx        : args)+      | otherwise        = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args)+      where+        (dx_binds, args) = go dxs dx_ids+             -- In the first case extend the substitution but not bindings;+             -- in the latter extend the bindings but not the substitution.+             -- For the former, note that we bind the *original* dict in the substitution,+             -- overriding any d->dx_id binding put there by substBndrs+    go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids)++{-+Note [Make the new dictionaries interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Important!  We're going to substitute dx_id1 for d+and we want it to look "interesting", else we won't gather *any*+consequential calls. E.g.+    f d = ...g d....+If we specialise f for a call (f (dfun dNumInt)), we'll get+a consequent call (g d') with an auxiliary definition+    d' = df dNumInt+We want that consequent call to look interesting+++Note [From non-recursive to recursive]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even in the non-recursive case, if any dict-binds depend on 'fn' we might+have built a recursive knot++      f a d x = <blah>+      MkUD { ud_binds = NonRec d7  (MkD ..f..)+           , ud_calls = ...(f T d7)... }++The we generate++     Rec { fs x = <blah>[T/a, d7/d]+           f a d x = <blah>+               RULE f T _ = fs+           d7 = ...f... }++Here the recursion is only through the RULE.++However we definitely should /not/ make the Rec in this wildly common+case:+      d = ...+      MkUD { ud_binds = NonRec d7 (...d...)+           , ud_calls = ...(f T d7)... }++Here we want simply to add d to the floats, giving+      MkUD { ud_binds = NonRec d (...)+                        NonRec d7 (...d...)+           , ud_calls = ...(f T d7)... }++In general, we need only make this Rec if+  - there are some specialisations (spec_binds non-empty)+  - there are some dict_binds that depend on f (dump_dbs non-empty)++Note [Avoiding loops]+~~~~~~~~~~~~~~~~~~~~~+When specialising /dictionary functions/ we must be very careful to+avoid building loops. Here is an example that bit us badly: #3591++     class Eq a => C a+     instance Eq [a] => C [a]++This translates to+     dfun :: Eq [a] -> C [a]+     dfun a d = MkD a d (meth d)++     d4 :: Eq [T] = <blah>+     d2 ::  C [T] = dfun T d4+     d1 :: Eq [T] = $p1 d2+     d3 ::  C [T] = dfun T d1++None of these definitions is recursive. What happened was that we+generated a specialisation:++     RULE forall d. dfun T d = dT  :: C [T]+     dT = (MkD a d (meth d)) [T/a, d1/d]+        = MkD T d1 (meth d1)++But now we use the RULE on the RHS of d2, to get++    d2 = dT = MkD d1 (meth d1)+    d1 = $p1 d2++and now d1 is bottom!  The problem is that when specialising 'dfun' we+should first dump "below" the binding all floated dictionary bindings+that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be+placed below 'dfun', and thus unavailable to it when specialising+'dfun'.  That in turn means that the call (dfun T d1) must be+discarded.  On the other hand, the call (dfun T d4) is fine, assuming+d4 doesn't mention dfun.++Solution:+  Discard all calls that mention dictionaries that depend+  (directly or indirectly) on the dfun we are specialising.+  This is done by 'filterCalls'++--------------+Here's another example, this time for an imported dfun, so the call+to filterCalls is in specImports (#13429). Suppose we have+  class Monoid v => C v a where ...++We start with a call+   f @ [Integer] @ Integer $fC[]Integer++Specialising call to 'f' gives dict bindings+   $dMonoid_1 :: Monoid [Integer]+   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer++   $dC_1 :: C [Integer] (Node [Integer] Integer)+   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1++...plus a recursive call to+   f @ [Integer] @ (Node [Integer] Integer) $dC_1++Specialising that call gives+   $dMonoid_2  :: Monoid [Integer]+   $dMonoid_2  = M.$p1C @ [Integer] $dC_1++   $dC_2 :: C [Integer] (Node [Integer] Integer)+   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2++Now we have two calls to the imported function+  M.$fCvNode :: Monoid v => C v a+  M.$fCvNode @v @a m = C m some_fun++But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)+for specialisation, else we get:++  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1+  $dMonoid_2 = M.$p1C @ [Integer] $dC_1+  $s$fCvNode = C $dMonoid_2 ...+    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode++Now use the rule to rewrite the call in the RHS of $dC_1+and we get a loop!++--------------+Here's yet another example++  class C a where { foo,bar :: [a] -> [a] }++  instance C Int where+     foo x = r_bar x+     bar xs = reverse xs++  r_bar :: C a => [a] -> [a]+  r_bar xs = bar (xs ++ xs)++That translates to:++    r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)++    Rec { $fCInt :: C Int = MkC foo_help reverse+          foo_help (xs::[Int]) = r_bar Int $fCInt xs }++The call (r_bar $fCInt) mentions $fCInt,+                        which mentions foo_help,+                        which mentions r_bar+But we DO want to specialise r_bar at Int:++    Rec { $fCInt :: C Int = MkC foo_help reverse+          foo_help (xs::[Int]) = r_bar Int $fCInt xs++          r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)+            RULE r_bar Int _ = r_bar_Int++          r_bar_Int xs = bar Int $fCInt (xs ++ xs)+           }++Note that, because of its RULE, r_bar joins the recursive+group.  (In this case it'll unravel a short moment later.)+++Note [Specialising a recursive group]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    let rec { f x = ...g x'...+            ; g y = ...f y'.... }+    in f 'a'+Here we specialise 'f' at Char; but that is very likely to lead to+a specialisation of 'g' at Char.  We must do the latter, else the+whole point of specialisation is lost.++But we do not want to keep iterating to a fixpoint, because in the+presence of polymorphic recursion we might generate an infinite number+of specialisations.++So we use the following heuristic:+  * Arrange the rec block in dependency order, so far as possible+    (the occurrence analyser already does this)++  * Specialise it much like a sequence of lets++  * Then go through the block a second time, feeding call-info from+    the RHSs back in the bottom, as it were++In effect, the ordering maxmimises the effectiveness of each sweep,+and we do just two sweeps.   This should catch almost every case of+monomorphic recursion -- the exception could be a very knotted-up+recursion with multiple cycles tied up together.++This plan is implemented in the Rec case of specBindItself.++Note [Specialisations already covered]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We obviously don't want to generate two specialisations for the same+argument pattern.  There are two wrinkles++1. We do the already-covered test in specDefn, not when we generate+the CallInfo in mkCallUDs.  We used to test in the latter place, but+we now iterate the specialiser somewhat, and the Id at the call site+might therefore not have all the RULES that we can see in specDefn++2. What about two specialisations where the second is an *instance*+of the first?  If the more specific one shows up first, we'll generate+specialisations for both.  If the *less* specific one shows up first,+we *don't* currently generate a specialisation for the more specific+one.  (See the call to lookupRule in already_covered.)  Reasons:+  (a) lookupRule doesn't say which matches are exact (bad reason)+  (b) if the earlier specialisation is user-provided, it's+      far from clear that we should auto-specialise further++Note [Auto-specialisation and RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   g :: Num a => a -> a+   g = ...++   f :: (Int -> Int) -> Int+   f w = ...+   {-# RULE f g = 0 #-}++Suppose that auto-specialisation makes a specialised version of+g::Int->Int That version won't appear in the LHS of the RULE for f.+So if the specialisation rule fires too early, the rule for f may+never fire.++It might be possible to add new rules, to "complete" the rewrite system.+Thus when adding+        RULE forall d. g Int d = g_spec+also add+        RULE f g_spec = 0++But that's a bit complicated.  For now we ask the programmer's help,+by *copying the INLINE activation pragma* to the auto-specialised+rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule+will also not be active until phase 2.  And that's what programmers+should jolly well do anyway, even aside from specialisation, to ensure+that g doesn't inline too early.++This in turn means that the RULE would never fire for a NOINLINE+thing so not much point in generating a specialisation at all.++Note [Specialisation shape]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only specialise a function if it has visible top-level lambdas+corresponding to its overloading.  E.g. if+        f :: forall a. Eq a => ....+then its body must look like+        f = /\a. \d. ...++Reason: when specialising the body for a call (f ty dexp), we want to+substitute dexp for d, and pick up specialised calls in the body of f.++This doesn't always work.  One example I came across was this:+        newtype Gen a = MkGen{ unGen :: Int -> a }++        choose :: Eq a => a -> Gen a+        choose n = MkGen (\r -> n)++        oneof = choose (1::Int)++It's a silly example, but we get+        choose = /\a. g `cast` co+where choose doesn't have any dict arguments.  Thus far I have not+tried to fix this (wait till there's a real example).++Mind you, then 'choose' will be inlined (since RHS is trivial) so+it doesn't matter.  This comes up with single-method classes++   class C a where { op :: a -> a }+   instance C a => C [a] where ....+==>+   $fCList :: C a => C [a]+   $fCList = $copList |> (...coercion>...)+   ....(uses of $fCList at particular types)...++So we suppress the WARN if the rhs is trivial.++Note [Inline specialisations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is what we do with the InlinePragma of the original function+  * Activation/RuleMatchInfo: both transferred to the+                              specialised function+  * InlineSpec:+       (a) An INLINE pragma is transferred+       (b) An INLINABLE pragma is *not* transferred++Why (a): transfer INLINE pragmas? The point of INLINE was precisely to+specialise the function at its call site, and arguably that's not so+important for the specialised copies.  BUT *pragma-directed*+specialisation now takes place in the typechecker/desugarer, with+manually specified INLINEs.  The specialisation here is automatic.+It'd be very odd if a function marked INLINE was specialised (because+of some local use), and then forever after (including importing+modules) the specialised version wasn't INLINEd.  After all, the+programmer said INLINE!++You might wonder why we specialise INLINE functions at all.  After+all they should be inlined, right?  Two reasons:++ * Even INLINE functions are sometimes not inlined, when they aren't+   applied to interesting arguments.  But perhaps the type arguments+   alone are enough to specialise (even though the args are too boring+   to trigger inlining), and it's certainly better to call the+   specialised version.++ * The RHS of an INLINE function might call another overloaded function,+   and we'd like to generate a specialised version of that function too.+   This actually happens a lot. Consider+      replicateM_ :: (Monad m) => Int -> m a -> m ()+      {-# INLINABLE replicateM_ #-}+      replicateM_ d x ma = ...+   The strictness analyser may transform to+      replicateM_ :: (Monad m) => Int -> m a -> m ()+      {-# INLINE replicateM_ #-}+      replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma++      $wreplicateM_ :: (Monad m) => Int# -> m a -> m ()+      {-# INLINABLE $wreplicateM_ #-}+      $wreplicateM_ = ...+   Now an importing module has a specialised call to replicateM_, say+   (replicateM_ dMonadIO).  We certainly want to specialise $wreplicateM_!+   This particular example had a huge effect on the call to replicateM_+   in nofib/shootout/n-body.++Why (b): discard INLINABLE pragmas? See #4874 for persuasive examples.+Suppose we have+    {-# INLINABLE f #-}+    f :: Ord a => [a] -> Int+    f xs = letrec f' = ...f'... in f'+Then, when f is specialised and optimised we might get+    wgo :: [Int] -> Int#+    wgo = ...wgo...+    f_spec :: [Int] -> Int+    f_spec xs = case wgo xs of { r -> I# r }+and we clearly want to inline f_spec at call sites.  But if we still+have the big, un-optimised of f (albeit specialised) captured in an+INLINABLE pragma for f_spec, we won't get that optimisation.++So we simply drop INLINABLE pragmas when specialising. It's not really+a complete solution; ignoring specialisation for now, INLINABLE functions+don't get properly strictness analysed, for example. But it works well+for examples involving specialisation, which is the dominant use of+INLINABLE.  See #4874.+++************************************************************************+*                                                                      *+\subsubsection{UsageDetails and suchlike}+*                                                                      *+************************************************************************+-}++data UsageDetails+  = MkUD {+      ud_binds :: !(Bag DictBind),+               -- See Note [Floated dictionary bindings]+               -- The order is important;+               -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1+               -- (Remember, Bags preserve order in GHC.)++      ud_calls :: !CallDetails++      -- INVARIANT: suppose bs = bindersOf ud_binds+      -- Then 'calls' may *mention* 'bs',+      -- but there should be no calls *for* bs+    }++-- | A 'DictBind' is a binding along with a cached set containing its free+-- variables (both type variables and dictionaries)+type DictBind = (CoreBind, VarSet)++{- Note [Floated dictionary bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We float out dictionary bindings for the reasons described under+"Dictionary floating" above.  But not /just/ dictionary bindings.+Consider++   f :: Eq a => blah+   f a d = rhs++   $c== :: T -> T -> Bool+   $c== x y = ...++   $df :: Eq T+   $df = Eq $c== ...++   gurgle = ...(f @T $df)...++We gather the call info for (f @T $df), and we don't want to drop it+when we come across the binding for $df.  So we add $df to the floats+and continue.  But then we have to add $c== to the floats, and so on.+These all float above the binding for 'f', and now we can+successfully specialise 'f'.++So the DictBinds in (ud_binds :: Bag DictBind) may contain+non-dictionary bindings too.+-}++instance Outputable UsageDetails where+  ppr (MkUD { ud_binds = dbs, ud_calls = calls })+        = text "MkUD" <+> braces (sep (punctuate comma+                [text "binds" <+> equals <+> ppr dbs,+                 text "calls" <+> equals <+> ppr calls]))++emptyUDs :: UsageDetails+emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }++------------------------------------------------------------+type CallDetails  = DIdEnv CallInfoSet+  -- The order of specialized binds and rules depends on how we linearize+  -- CallDetails, so to get determinism we must use a deterministic set here.+  -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM++data CallInfoSet = CIS Id (Bag CallInfo)+  -- The list of types and dictionaries is guaranteed to+  -- match the type of f+  -- The Bag may contain duplicate calls (i.e. f @T and another f @T)+  -- These dups are eliminated by already_covered in specCalls++data CallInfo+  = CI { ci_key  :: [SpecArg]   -- All arguments+       , ci_arity :: Int        -- The number of variables necessary to bind+                                -- all of the specialised arguments+       , ci_fvs  :: VarSet      -- Free vars of the ci_key+                                -- call (including tyvars)+                                -- [*not* include the main id itself, of course]+    }++type DictExpr = CoreExpr++ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet+ciSetFilter p (CIS id a) = CIS id (filterBag p a)++instance Outputable CallInfoSet where+  ppr (CIS fn map) = hang (text "CIS" <+> ppr fn)+                        2 (ppr map)++pprCallInfo :: Id -> CallInfo -> SDoc+pprCallInfo fn (CI { ci_key = key })+  = ppr fn <+> ppr key++ppr_call_key_ty :: SpecArg -> Maybe SDoc+ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty+ppr_call_key_ty UnspecType    = Just $ char '_'+ppr_call_key_ty (SpecDict _)  = Nothing+ppr_call_key_ty UnspecArg     = Nothing++instance Outputable CallInfo where+  ppr (CI { ci_key = key, ci_fvs = fvs })+    = text "CI" <> braces (hsep [ fsep (mapMaybe ppr_call_key_ty key), ppr fvs ])++unionCalls :: CallDetails -> CallDetails -> CallDetails+unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2++unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet+unionCallInfoSet (CIS f calls1) (CIS _ calls2) =+  CIS f (calls1 `unionBags` calls2)++callDetailsFVs :: CallDetails -> VarSet+callDetailsFVs calls =+  nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls+  -- It's OK to use nonDetFoldUDFM here because we forget the ordering+  -- immediately by converting to a nondeterministic set.++callInfoFVs :: CallInfoSet -> VarSet+callInfoFVs (CIS _ call_info) =+  foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info++computeArity :: [SpecArg] -> Int+computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg++callSpecArity :: [TyCoBinder] -> Int+callSpecArity = length . filter (not . isNamedBinder) . dropWhileEndLE isVisibleBinder++getTheta :: [TyCoBinder] -> [PredType]+getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder)+++------------------------------------------------------------+singleCall :: Id -> [SpecArg] -> UsageDetails+singleCall id args+  = MkUD {ud_binds = emptyBag,+          ud_calls = unitDVarEnv id $ CIS id $+                     unitBag (CI { ci_key  = args -- used to be tys+                                 , ci_arity = computeArity args+                                 , ci_fvs  = call_fvs }) }+  where+    tys      = getSpecTypes args+    dicts    = getSpecDicts args+    call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs+    tys_fvs  = tyCoVarsOfTypes tys+        -- The type args (tys) are guaranteed to be part of the dictionary+        -- types, because they are just the constrained types,+        -- and the dictionary is therefore sure to be bound+        -- inside the binding for any type variables free in the type;+        -- hence it's safe to neglect tyvars free in tys when making+        -- the free-var set for this call+        -- BUT I don't trust this reasoning; play safe and include tys_fvs+        --+        -- We don't include the 'id' itself.++mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails+mkCallUDs env f args+  = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ])+    res+  where+    res = mkCallUDs' env f args++mkCallUDs' env f args+  | not (want_calls_for f)  -- Imported from elsewhere+  || null theta             -- Not overloaded+  = emptyUDs++  |  not (all type_determines_value theta)+  || not (computeArity ci_key <= idArity f)+  || not (length dicts == length theta)+  || not (any (interestingDict env) dicts)    -- Note [Interesting dictionary arguments]+  -- See also Note [Specialisations already covered]+  = -- pprTrace "mkCallUDs: discarding" _trace_doc+    emptyUDs    -- Not overloaded, or no specialisation wanted++  | otherwise+  = -- pprTrace "mkCallUDs: keeping" _trace_doc+    singleCall f ci_key+  where+    _trace_doc = vcat [ppr f, ppr args, ppr (map (interestingDict env) dicts)]+    pis                = fst $ splitPiTys $ idType f+    theta              = getTheta pis+    constrained_tyvars = tyCoVarsOfTypes theta++    ci_key :: [SpecArg]+    ci_key = fmap (\(t, a) ->+      case t of+        Named (binderVar -> tyVar)+          |  tyVar `elemVarSet` constrained_tyvars+          -> case a of+              Type ty -> SpecType ty+              _ -> pprPanic "ci_key" $ ppr a+          |  otherwise+          -> UnspecType+        Anon InvisArg _ -> SpecDict a+        Anon VisArg _ -> UnspecArg+                ) $ zip pis args++    dicts = getSpecDicts ci_key++    want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))+         -- For imported things, we gather call instances if+         -- there is an unfolding that we could in principle specialise+         -- We might still decide not to use it (consulting dflags)+         -- in specImports+         -- Use 'realIdUnfolding' to ignore the loop-breaker flag!++    type_determines_value pred    -- See Note [Type determines value]+        = case classifyPredType pred of+            ClassPred cls _ -> not (isIPClass cls)  -- Superclasses can't be IPs+            EqPred {}       -> True+            IrredPred {}    -> True   -- Things like (D []) where D is a+                                      -- Constraint-ranged family; #7785+            ForAllPred {}   -> True++{-+Note [Type determines value]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Only specialise if all overloading is on non-IP *class* params,+because these are the ones whose *type* determines their *value*.  In+parrticular, with implicit params, the type args *don't* say what the+value of the implicit param is!  See #7101++However, consider+         type family D (v::*->*) :: Constraint+         type instance D [] = ()+         f :: D v => v Char -> Int+If we see a call (f "foo"), we'll pass a "dictionary"+  () |> (g :: () ~ D [])+and it's good to specialise f at this dictionary.++So the question is: can an implicit parameter "hide inside" a+type-family constraint like (D a).  Well, no.  We don't allow+        type instance D Maybe = ?x:Int+Hence the IrredPred case in type_determines_value.+See #7785.++Note [Interesting dictionary arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+         \a.\d:Eq a.  let f = ... in ...(f d)...+There really is not much point in specialising f wrt the dictionary d,+because the code for the specialised f is not improved at all, because+d is lambda-bound.  We simply get junk specialisations.++What is "interesting"?  Just that it has *some* structure.  But what about+variables?++ * A variable might be imported, in which case its unfolding+   will tell us whether it has useful structure++ * Local variables are cloned on the way down (to avoid clashes when+   we float dictionaries), and cloning drops the unfolding+   (cloneIdBndr).  Moreover, we make up some new bindings, and it's a+   nuisance to give them unfoldings.  So we keep track of the+   "interesting" dictionaries as a VarSet in SpecEnv.+   We have to take care to put any new interesting dictionary+   bindings in the set.++We accidentally lost accurate tracking of local variables for a long+time, because cloned variables don't have unfoldings. But makes a+massive difference in a few cases, eg #5113. For nofib as a+whole it's only a small win: 2.2% improvement in allocation for ansi,+1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.+-}++interestingDict :: SpecEnv -> CoreExpr -> Bool+-- A dictionary argument is interesting if it has *some* structure+-- NB: "dictionary" arguments include constraints of all sorts,+--     including equality constraints; hence the Coercion case+interestingDict env (Var v) =  hasSomeUnfolding (idUnfolding v)+                            || isDataConWorkId v+                            || v `elemVarSet` se_interesting env+interestingDict _ (Type _)                = False+interestingDict _ (Coercion _)            = False+interestingDict env (App fn (Type _))     = interestingDict env fn+interestingDict env (App fn (Coercion _)) = interestingDict env fn+interestingDict env (Tick _ a)            = interestingDict env a+interestingDict env (Cast e _)            = interestingDict env e+interestingDict _ _                       = True++plusUDs :: UsageDetails -> UsageDetails -> UsageDetails+plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})+        (MkUD {ud_binds = db2, ud_calls = calls2})+  = MkUD { ud_binds = db1    `unionBags`   db2+         , ud_calls = calls1 `unionCalls`  calls2 }++-----------------------------+_dictBindBndrs :: Bag DictBind -> [Id]+_dictBindBndrs dbs = foldr ((++) . bindersOf . fst) [] dbs++-- | Construct a 'DictBind' from a 'CoreBind'+mkDB :: CoreBind -> DictBind+mkDB bind = (bind, bind_fvs bind)++-- | Identify the free variables of a 'CoreBind'+bind_fvs :: CoreBind -> VarSet+bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)+bind_fvs (Rec prs)         = foldl' delVarSet rhs_fvs bndrs+                           where+                             bndrs = map fst prs+                             rhs_fvs = unionVarSets (map pair_fvs prs)++pair_fvs :: (Id, CoreExpr) -> VarSet+pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs+                       `unionVarSet` idFreeVars bndr+        -- idFreeVars: don't forget variables mentioned in+        -- the rules of the bndr.  C.f. OccAnal.addRuleUsage+        -- Also tyvars mentioned in its type; they may not appear+        -- in the RHS+        --      type T a = Int+        --      x :: T a = 3+  where+    interesting :: InterestingVarFun+    interesting v = isLocalVar v || (isId v && isDFunId v)+        -- Very important: include DFunIds /even/ if it is imported+        -- Reason: See Note [Avoiding loops], the second example+        --         involving an imported dfun.  We must know whether+        --         a dictionary binding depends on an imported dfun,+        --         in case we try to specialise that imported dfun+        --         #13429 illustrates++-- | Flatten a set of "dumped" 'DictBind's, and some other binding+-- pairs, into a single recursive binding.+recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind+recWithDumpedDicts pairs dbs+  = (Rec bindings, fvs)+  where+    (bindings, fvs) = foldr add+                               ([], emptyVarSet)+                               (dbs `snocBag` mkDB (Rec pairs))+    add (NonRec b r, fvs') (pairs, fvs) =+      ((b,r) : pairs, fvs `unionVarSet` fvs')+    add (Rec prs1,   fvs') (pairs, fvs) =+      (prs1 ++ pairs, fvs `unionVarSet` fvs')++snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails+-- Add ud_binds to the tail end of the bindings in uds+snocDictBinds uds dbs+  = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs }++consDictBind :: DictBind -> UsageDetails -> UsageDetails+consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds }++addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails+addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }++snocDictBind :: UsageDetails -> DictBind -> UsageDetails+snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }++wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]+wrapDictBinds dbs binds+  = foldr add binds dbs+  where+    add (bind,_) binds = bind : binds++wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr+wrapDictBindsE dbs expr+  = foldr add expr dbs+  where+    add (bind,_) expr = Let bind expr++----------------------+dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)+-- Used at a lambda or case binder; just dump anything mentioning the binder+dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  | null bndrs = (uds, emptyBag)  -- Common in case alternatives+  | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $+                 (free_uds, dump_dbs)+  where+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }+    bndr_set = mkVarSet bndrs+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set+    free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor+                 deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be+                                                    -- no calls for any of the dicts in dump_dbs++dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)+-- Used at a let(rec) binding.+-- We return a boolean indicating whether the binding itself is mentioned,+-- directly or indirectly, by any of the ud_calls; in that case we want to+-- float the binding itself;+-- See Note [Floated dictionary bindings]+dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $+    (free_uds, dump_dbs, float_all)+  where+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }+    bndr_set = mkVarSet bndrs+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set+    free_calls = deleteCallsFor bndrs orig_calls+    float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls++callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])+callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  = -- pprTrace ("callsForMe")+    --          (vcat [ppr fn,+    --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),+    --                 text "Orig calls ="   <+> ppr orig_calls,+    --                 text "Dep set ="      <+> ppr dep_set,+    --                 text "Calls for me =" <+> ppr calls_for_me]) $+    (uds_without_me, calls_for_me)+  where+    uds_without_me = MkUD { ud_binds = orig_dbs+                          , ud_calls = delDVarEnv orig_calls fn }+    calls_for_me = case lookupDVarEnv orig_calls fn of+                        Nothing -> []+                        Just cis -> filterCalls cis orig_dbs+         -- filterCalls: drop calls that (directly or indirectly)+         -- refer to fn.  See Note [Avoiding loops]++----------------------+filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]+-- See Note [Avoiding loops]+filterCalls (CIS fn call_bag) dbs+  = filter ok_call (bagToList call_bag)+  where+    dump_set = foldl' go (unitVarSet fn) dbs+      -- This dump-set could also be computed by splitDictBinds+      --   (_,_,dump_set) = splitDictBinds dbs {fn}+      -- But this variant is shorter++    go so_far (db,fvs) | fvs `intersectsVarSet` so_far+                       = extendVarSetList so_far (bindersOf db)+                       | otherwise = so_far++    ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set)++----------------------+splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)+-- splitDictBinds dbs bndrs returns+--   (free_dbs, dump_dbs, dump_set)+-- where+--   * dump_dbs depends, transitively on bndrs+--   * free_dbs does not depend on bndrs+--   * dump_set = bndrs `union` bndrs(dump_dbs)+splitDictBinds dbs bndr_set+   = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs+                -- Important that it's foldl' not foldr;+                -- we're accumulating the set of dumped ids in dump_set+   where+    split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)+        | dump_idset `intersectsVarSet` fvs     -- Dump it+        = (free_dbs, dump_dbs `snocBag` db,+           extendVarSetList dump_idset (bindersOf bind))++        | otherwise     -- Don't dump it+        = (free_dbs `snocBag` db, dump_dbs, dump_idset)+++----------------------+deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails+-- Remove calls *mentioning* bs in any way+deleteCallsMentioning bs calls+  = mapDVarEnv (ciSetFilter keep_call) calls+  where+    keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs)++deleteCallsFor :: [Id] -> CallDetails -> CallDetails+-- Remove calls *for* bs+deleteCallsFor bs calls = delDVarEnvList calls bs++{-+************************************************************************+*                                                                      *+\subsubsection{Boring helper functions}+*                                                                      *+************************************************************************+-}++newtype SpecM a = SpecM (State SpecState a) deriving (Functor)++data SpecState = SpecState {+                     spec_uniq_supply :: UniqSupply,+                     spec_module :: Module,+                     spec_dflags :: DynFlags+                 }++instance Applicative SpecM where+    pure x = SpecM $ return x+    (<*>) = ap++instance Monad SpecM where+    SpecM x >>= f = SpecM $ do y <- x+                               case f y of+                                   SpecM z ->+                                       z++instance MonadFail SpecM where+   fail str = SpecM $ error str++instance MonadUnique SpecM where+    getUniqueSupplyM+        = SpecM $ do st <- get+                     let (us1, us2) = splitUniqSupply $ spec_uniq_supply st+                     put $ st { spec_uniq_supply = us2 }+                     return us1++    getUniqueM+        = SpecM $ do st <- get+                     let (u,us') = takeUniqFromSupply $ spec_uniq_supply st+                     put $ st { spec_uniq_supply = us' }+                     return u++instance HasDynFlags SpecM where+    getDynFlags = SpecM $ liftM spec_dflags get++instance HasModule SpecM where+    getModule = SpecM $ liftM spec_module get++runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a+runSpecM dflags this_mod (SpecM spec)+    = do us <- getUniqueSupplyM+         let initialState = SpecState {+                                spec_uniq_supply = us,+                                spec_module = this_mod,+                                spec_dflags = dflags+                            }+         return $ evalState spec initialState++mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)+mapAndCombineSM _ []     = return ([], emptyUDs)+mapAndCombineSM f (x:xs) = do (y, uds1) <- f x+                              (ys, uds2) <- mapAndCombineSM f xs+                              return (y:ys, uds1 `plusUDs` uds2)++extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv+extendTvSubstList env tv_binds+  = env { se_subst = GHC.Core.Subst.extendTvSubstList (se_subst env) tv_binds }++substTy :: SpecEnv -> Type -> Type+substTy env ty = GHC.Core.Subst.substTy (se_subst env) ty++substCo :: SpecEnv -> Coercion -> Coercion+substCo env co = GHC.Core.Subst.substCo (se_subst env) co++substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)+substBndr env bs = case GHC.Core.Subst.substBndr (se_subst env) bs of+                      (subst', bs') -> (env { se_subst = subst' }, bs')++substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])+substBndrs env bs = case GHC.Core.Subst.substBndrs (se_subst env) bs of+                      (subst', bs') -> (env { se_subst = subst' }, bs')++cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)+-- Clone the binders of the bind; return new bind with the cloned binders+-- Return the substitution to use for RHSs, and the one to use for the body+cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs)+  = do { us <- getUniqueSupplyM+       ; let (subst', bndr') = GHC.Core.Subst.cloneIdBndr subst us bndr+             interesting' | interestingDict env rhs+                          = interesting `extendVarSet` bndr'+                          | otherwise = interesting+       ; return (env, env { se_subst = subst', se_interesting = interesting' }+                , NonRec bndr' rhs) }++cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs)+  = do { us <- getUniqueSupplyM+       ; let (subst', bndrs') = GHC.Core.Subst.cloneRecIdBndrs subst us (map fst pairs)+             env' = env { se_subst = subst'+                        , se_interesting = interesting `extendVarSetList`+                                           [ v | (v,r) <- pairs, interestingDict env r ] }+       ; return (env', env', Rec (bndrs' `zip` map snd pairs)) }++newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr+-- Make up completely fresh binders for the dictionaries+-- Their bindings are going to float outwards+newDictBndr env b = do { uniq <- getUniqueM+                       ; let n   = idName b+                             ty' = substTy env (idType b)+                       ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }++newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id+    -- Give the new Id a similar occurrence name to the old one+newSpecIdSM old_id new_ty join_arity_maybe+  = do  { uniq <- getUniqueM+        ; let name    = idName old_id+              new_occ = mkSpecOcc (nameOccName name)+              new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)+                          `asJoinId_maybe` join_arity_maybe+        ; return new_id }++{-+                Old (but interesting) stuff about unboxed bindings+                ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++What should we do when a value is specialised to a *strict* unboxed value?++        map_*_* f (x:xs) = let h = f x+                               t = map f xs+                           in h:t++Could convert let to case:++        map_*_Int# f (x:xs) = case f x of h# ->+                              let t = map f xs+                              in h#:t++This may be undesirable since it forces evaluation here, but the value+may not be used in all branches of the body. In the general case this+transformation is impossible since the mutual recursion in a letrec+cannot be expressed as a case.++There is also a problem with top-level unboxed values, since our+implementation cannot handle unboxed values at the top level.++Solution: Lift the binding of the unboxed value and extract it when it+is used:++        map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#+                                  t = map f xs+                              in case h of+                                 _Lift h# -> h#:t++Now give it to the simplifier and the _Lifting will be optimised away.++The benefit is that we have given the specialised "unboxed" values a+very simple lifted semantics and then leave it up to the simplifier to+optimise it --- knowing that the overheads will be removed in nearly+all cases.++In particular, the value will only be evaluated in the branches of the+program which use it, rather than being forced at the point where the+value is bound. For example:++        filtermap_*_* p f (x:xs)+          = let h = f x+                t = ...+            in case p x of+                True  -> h:t+                False -> t+   ==>+        filtermap_*_Int# p f (x:xs)+          = let h = case (f x) of h# -> _Lift h#+                t = ...+            in case p x of+                True  -> case h of _Lift h#+                           -> h#:t+                False -> t++The binding for h can still be inlined in the one branch and the+_Lifting eliminated.+++Question: When won't the _Lifting be eliminated?++Answer: When they at the top-level (where it is necessary) or when+inlining would duplicate work (or possibly code depending on+options). However, the _Lifting will still be eliminated if the+strictness analyser deems the lifted binding strict.+-}
+ compiler/GHC/Core/Op/StaticArgs.hs view
@@ -0,0 +1,433 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++************************************************************************++               Static Argument Transformation pass++************************************************************************++May be seen as removing invariants from loops:+Arguments of recursive functions that do not change in recursive+calls are removed from the recursion, which is done locally+and only passes the arguments which effectively change.++Example:+map = /\ ab -> \f -> \xs -> case xs of+                 []       -> []+                 (a:b) -> f a : map f b++as map is recursively called with the same argument f (unmodified)+we transform it to++map = /\ ab -> \f -> \xs -> let map' ys = case ys of+                       []     -> []+                       (a:b) -> f a : map' b+                in map' xs++Notice that for a compiler that uses lambda lifting this is+useless as map' will be transformed back to what map was.++We could possibly do the same for big lambdas, but we don't as+they will eventually be removed in later stages of the compiler,+therefore there is no penalty in keeping them.++We only apply the SAT when the number of static args is > 2. This+produces few bad cases.  See+                should_transform+in saTransform.++Here are the headline nofib results:+                  Size    Allocs   Runtime+Min             +0.0%    -13.7%    -21.4%+Max             +0.1%     +0.0%     +5.4%+Geometric Mean  +0.0%     -0.2%     -6.9%++The previous patch, to fix polymorphic floatout demand signatures, is+essential to make this work well!+-}++{-# LANGUAGE CPP #-}+module GHC.Core.Op.StaticArgs ( doStaticArgs ) where++import GhcPrelude++import GHC.Types.Var+import GHC.Core+import GHC.Core.Utils+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Var.Env+import GHC.Types.Unique.Supply+import Util+import GHC.Types.Unique.FM+import GHC.Types.Var.Set+import GHC.Types.Unique+import GHC.Types.Unique.Set+import Outputable++import Data.List (mapAccumL)+import FastString++#include "HsVersions.h"++doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram+doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds+  where+    sat_bind_threaded_us us bind =+        let (us1, us2) = splitUniqSupply us+        in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet))++-- We don't bother to SAT recursive groups since it can lead+-- to massive code expansion: see Andre Santos' thesis for details.+-- This means we only apply the actual SAT to Rec groups of one element,+-- but we want to recurse into the others anyway to discover other binds+satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)+satBind (NonRec binder expr) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (NonRec binder expr', finalizeApp expr_app sat_info_expr)+satBind (Rec [(binder, rhs)]) interesting_ids = do+    let interesting_ids' = interesting_ids `addOneToUniqSet` binder+        (rhs_binders, rhs_body) = collectBinders rhs+    (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids'+    let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders)+        sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body++        shadowing = binder `elementOfUniqSet` interesting_ids+        sat_info_rhs'' = if shadowing+                        then sat_info_rhs' `delFromUFM` binder -- For safety+                        else sat_info_rhs'++    bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder)+                              rhs_binders rhs_body'+    return (bind', sat_info_rhs'')+satBind (Rec pairs) interesting_ids = do+    let (binders, rhss) = unzip pairs+    rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss+    let (rhss', sat_info_rhss') = unzip rhss_SATed+    return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')++data App = VarApp Id | TypeApp Type | CoApp Coercion+data Staticness a = Static a | NotStatic++type IdAppInfo = (Id, SATInfo)++type SATInfo = [Staticness App]+type IdSATInfo = IdEnv SATInfo+emptyIdSATInfo :: IdSATInfo+emptyIdSATInfo = emptyUFM++{-+pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info))+  where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info)+-}++pprSATInfo :: SATInfo -> SDoc+pprSATInfo staticness = hcat $ map pprStaticness staticness++pprStaticness :: Staticness App -> SDoc+pprStaticness (Static (VarApp _))  = text "SV"+pprStaticness (Static (TypeApp _)) = text "ST"+pprStaticness (Static (CoApp _))   = text "SC"+pprStaticness NotStatic            = text "NS"+++mergeSATInfo :: SATInfo -> SATInfo -> SATInfo+mergeSATInfo l r = zipWith mergeSA l r+  where+    mergeSA NotStatic _ = NotStatic+    mergeSA _ NotStatic = NotStatic+    mergeSA (Static (VarApp v)) (Static (VarApp v'))+      | v == v'   = Static (VarApp v)+      | otherwise = NotStatic+    mergeSA (Static (TypeApp t)) (Static (TypeApp t'))+      | t `eqType` t' = Static (TypeApp t)+      | otherwise     = NotStatic+    mergeSA (Static (CoApp c)) (Static (CoApp c'))+      | c `eqCoercion` c' = Static (CoApp c)+      | otherwise             = NotStatic+    mergeSA _ _  = pprPanic "mergeSATInfo" $+                          text "Left:"+                       <> pprSATInfo l <> text ", "+                       <> text "Right:"+                       <> pprSATInfo r++mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo+mergeIdSATInfo = plusUFM_C mergeSATInfo++mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo+mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo++bindersToSATInfo :: [Id] -> SATInfo+bindersToSATInfo vs = map (Static . binderToApp) vs+    where binderToApp v | isId v    = VarApp v+                        | isTyVar v = TypeApp $ mkTyVarTy v+                        | otherwise = CoApp $ mkCoVarCo v++finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo+finalizeApp Nothing id_sat_info = id_sat_info+finalizeApp (Just (v, sat_info')) id_sat_info =+    let sat_info'' = case lookupUFM id_sat_info v of+                        Nothing -> sat_info'+                        Just sat_info -> mergeSATInfo sat_info sat_info'+    in extendVarEnv id_sat_info v sat_info''++satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)+satTopLevelExpr expr interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (expr', finalizeApp expr_app sat_info_expr)++satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)+satExpr var@(Var v) interesting_ids = do+    let app_info = if v `elementOfUniqSet` interesting_ids+                   then Just (v, [])+                   else Nothing+    return (var, emptyIdSATInfo, app_info)++satExpr lit@(Lit _) _ = do+    return (lit, emptyIdSATInfo, Nothing)++satExpr (Lam binders body) interesting_ids = do+    (body', sat_info, this_app) <- satExpr body interesting_ids+    return (Lam binders body', finalizeApp this_app sat_info, Nothing)++satExpr (App fn arg) interesting_ids = do+    (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids+    let satRemainder = boring fn' sat_info_fn+    case fn_app of+        Nothing -> satRemainder Nothing+        Just (fn_id, fn_app_info) ->+            -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)+            let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])+            in case arg of+                Type t     -> satRemainderWithStaticness $ Static (TypeApp t)+                Coercion c -> satRemainderWithStaticness $ Static (CoApp c)+                Var v      -> satRemainderWithStaticness $ Static (VarApp v)+                _          -> satRemainderWithStaticness $ NotStatic+  where+    boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)+    boring fn' sat_info_fn app_info =+        do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids+           let sat_info_arg' = finalizeApp arg_app sat_info_arg+               sat_info = mergeIdSATInfo sat_info_fn sat_info_arg'+           return (App fn' arg', sat_info, app_info)++satExpr (Case expr bndr ty alts) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    let sat_info_expr' = finalizeApp expr_app sat_info_expr++    zipped_alts' <- mapM satAlt alts+    let (alts', sat_infos_alts) = unzip zipped_alts'+    return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing)+  where+    satAlt (con, bndrs, expr) = do+        (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids+        return ((con, bndrs, expr'), sat_info_expr)++satExpr (Let bind body) interesting_ids = do+    (body', sat_info_body, body_app) <- satExpr body interesting_ids+    (bind', sat_info_bind) <- satBind bind interesting_ids+    return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app)++satExpr (Tick tickish expr) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (Tick tickish expr', sat_info_expr, expr_app)++satExpr ty@(Type _) _ = do+    return (ty, emptyIdSATInfo, Nothing)++satExpr co@(Coercion _) _ = do+    return (co, emptyIdSATInfo, Nothing)++satExpr (Cast expr coercion) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (Cast expr' coercion, sat_info_expr, expr_app)++{-+************************************************************************++                Static Argument Transformation Monad++************************************************************************+-}++type SatM result = UniqSM result++runSAT :: UniqSupply -> SatM a -> a+runSAT = initUs_++newUnique :: SatM Unique+newUnique = getUniqueM++{-+************************************************************************++                Static Argument Transformation Monad++************************************************************************++To do the transformation, the game plan is to:++1. Create a small nonrecursive RHS that takes the+   original arguments to the function but discards+   the ones that are static and makes a call to the+   SATed version with the remainder. We intend that+   this will be inlined later, removing the overhead++2. Bind this nonrecursive RHS over the original body+   WITH THE SAME UNIQUE as the original body so that+   any recursive calls to the original now go via+   the small wrapper++3. Rebind the original function to a new one which contains+   our SATed function and just makes a call to it:+   we call the thing making this call the local body++Example: transform this++    map :: forall a b. (a->b) -> [a] -> [b]+    map = /\ab. \(f:a->b) (as:[a]) -> body[map]+to+    map :: forall a b. (a->b) -> [a] -> [b]+    map = /\ab. \(f:a->b) (as:[a]) ->+         letrec map' :: [a] -> [b]+                    -- The "worker function+                map' = \(as:[a]) ->+                         let map :: forall a' b'. (a -> b) -> [a] -> [b]+                                -- The "shadow function+                             map = /\a'b'. \(f':(a->b) (as:[a]).+                                   map' as+                         in body[map]+         in map' as++Note [Shadow binding]+~~~~~~~~~~~~~~~~~~~~~+The calls to the inner map inside body[map] should get inlined+by the local re-binding of 'map'.  We call this the "shadow binding".++But we can't use the original binder 'map' unchanged, because+it might be exported, in which case the shadow binding won't be+discarded as dead code after it is inlined.++So we use a hack: we make a new SysLocal binder with the *same* unique+as binder.  (Another alternative would be to reset the export flag.)++Note [Binder type capture]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Notice that in the inner map (the "shadow function"), the static arguments+are discarded -- it's as if they were underscores.  Instead, mentions+of these arguments (notably in the types of dynamic arguments) are bound+by the *outer* lambdas of the main function.  So we must make up fresh+names for the static arguments so that they do not capture variables+mentioned in the types of dynamic args.++In the map example, the shadow function must clone the static type+argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a'+is bound by the outer forall.  We clone f' too for consistency, but+that doesn't matter either way because static Id arguments aren't+mentioned in the shadow binding at all.++If we don't we get something like this:++[Exported]+[Arity 3]+GHC.Base.until =+  \ (@ a_aiK)+    (p_a6T :: a_aiK -> GHC.Types.Bool)+    (f_a6V :: a_aiK -> a_aiK)+    (x_a6X :: a_aiK) ->+    letrec {+      sat_worker_s1aU :: a_aiK -> a_aiK+      []+      sat_worker_s1aU =+        \ (x_a6X :: a_aiK) ->+          let {+            sat_shadow_r17 :: forall a_a3O.+                              (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O+            []+            sat_shadow_r17 =+              \ (@ a_aiK)+                (p_a6T :: a_aiK -> GHC.Types.Bool)+                (f_a6V :: a_aiK -> a_aiK)+                (x_a6X :: a_aiK) ->+                sat_worker_s1aU x_a6X } in+          case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] {+            GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X);+            GHC.Types.True -> x_a6X+          }; } in+    sat_worker_s1aU x_a6X++Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK+type argument. This is bad because it means the application sat_worker_s1aU x_a6X+is not well typed.+-}++saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind+saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body+  | Just arg_staticness <- maybe_arg_staticness+  , should_transform arg_staticness+  = saTransform binder arg_staticness rhs_binders rhs_body+  | otherwise+  = return (Rec [(binder, mkLams rhs_binders rhs_body)])+  where+    should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT+      where+        n_static_args = count isStaticValue staticness++saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind+saTransform binder arg_staticness rhs_binders rhs_body+  = do  { shadow_lam_bndrs <- mapM clone binders_w_staticness+        ; uniq             <- newUnique+        ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) }+  where+    -- Running example: foldr+    -- foldr \alpha \beta c n xs = e, for some e+    -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic]+    -- rhs_binders = [\alpha, \beta, c, n, xs]+    -- rhs_body = e++    binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic)+                                        -- Any extra args are assumed NotStatic++    non_static_args :: [Var]+            -- non_static_args = [xs]+            -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs]+    non_static_args = [v | (v, NotStatic) <- binders_w_staticness]++    clone (bndr, NotStatic) = return bndr+    clone (bndr, _        ) = do { uniq <- newUnique+                                 ; return (setVarUnique bndr uniq) }++    -- new_rhs = \alpha beta c n xs ->+    --           let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs ->+    --                                       sat_worker xs+    --                                   in e+    --           in sat_worker xs+    mk_new_rhs uniq shadow_lam_bndrs+        = mkLams rhs_binders $+          Let (Rec [(rec_body_bndr, rec_body)])+          local_body+        where+          local_body = mkVarApps (Var rec_body_bndr) non_static_args++          rec_body = mkLams non_static_args $+                     Let (NonRec shadow_bndr shadow_rhs) rhs_body++            -- See Note [Binder type capture]+          shadow_rhs = mkLams shadow_lam_bndrs local_body+            -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs++          rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body)+            -- rec_body_bndr = sat_worker++            -- See Note [Shadow binding]; make a SysLocal+          shadow_bndr = mkSysLocal (occNameFS (getOccName binder))+                                   (idUnique binder)+                                   (exprType shadow_rhs)++isStaticValue :: Staticness App -> Bool+isStaticValue (Static (VarApp _)) = True+isStaticValue _                   = False
+ compiler/GHC/Core/Op/WorkWrap.hs view
@@ -0,0 +1,776 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}+-}++{-# LANGUAGE CPP #-}+module GHC.Core.Op.WorkWrap ( wwTopBinds ) where++import GhcPrelude++import GHC.Core.Arity  ( manifestArity )+import GHC.Core+import GHC.Core.Unfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )+import GHC.Core.Utils  ( exprType, exprIsHNF )+import GHC.Core.FVs    ( exprFreeVars )+import GHC.Types.Var+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core.Type+import GHC.Types.Unique.Supply+import GHC.Types.Basic+import GHC.Driver.Session+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Core.Op.WorkWrap.Lib+import Util+import Outputable+import GHC.Core.FamInstEnv+import MonadUtils++#include "HsVersions.h"++{-+We take Core bindings whose binders have:++\begin{enumerate}++\item Strictness attached (by the front-end of the strictness+analyser), and / or++\item Constructed Product Result information attached by the CPR+analysis pass.++\end{enumerate}++and we return some ``plain'' bindings which have been+worker/wrapper-ified, meaning:++\begin{enumerate}++\item Functions have been split into workers and wrappers where+appropriate.  If a function has both strictness and CPR properties+then only one worker/wrapper doing both transformations is produced;++\item Binders' @IdInfos@ have been updated to reflect the existence of+these workers/wrappers (this is where we get STRICTNESS and CPR pragma+info for exported values).+\end{enumerate}+-}++wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram++wwTopBinds dflags fam_envs us top_binds+  = initUs_ us $ do+    top_binds' <- mapM (wwBind dflags fam_envs) top_binds+    return (concat top_binds')++{-+************************************************************************+*                                                                      *+\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}+*                                                                      *+************************************************************************++@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in+turn.  Non-recursive case first, then recursive...+-}++wwBind  :: DynFlags+        -> FamInstEnvs+        -> CoreBind+        -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;+                                -- the caller will convert to Expr/Binding,+                                -- as appropriate.++wwBind dflags fam_envs (NonRec binder rhs) = do+    new_rhs <- wwExpr dflags fam_envs rhs+    new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs+    return [NonRec b e | (b,e) <- new_pairs]+      -- Generated bindings must be non-recursive+      -- because the original binding was.++wwBind dflags fam_envs (Rec pairs)+  = return . Rec <$> concatMapM do_one pairs+  where+    do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs+                              tryWW dflags fam_envs Recursive binder new_rhs++{-+@wwExpr@ basically just walks the tree, looking for appropriate+annotations that can be used. Remember it is @wwBind@ that does the+matching by looking for strict arguments of the correct type.+@wwExpr@ is a version that just returns the ``Plain'' Tree.+-}++wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr++wwExpr _      _ e@(Type {}) = return e+wwExpr _      _ e@(Coercion {}) = return e+wwExpr _      _ e@(Lit  {}) = return e+wwExpr _      _ e@(Var  {}) = return e++wwExpr dflags fam_envs (Lam binder expr)+  = Lam new_binder <$> wwExpr dflags fam_envs expr+  where new_binder | isId binder = zapIdUsedOnceInfo binder+                   | otherwise   = binder+  -- See Note [Zapping Used Once info in WorkWrap]++wwExpr dflags fam_envs (App f a)+  = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a++wwExpr dflags fam_envs (Tick note expr)+  = Tick note <$> wwExpr dflags fam_envs expr++wwExpr dflags fam_envs (Cast expr co) = do+    new_expr <- wwExpr dflags fam_envs expr+    return (Cast new_expr co)++wwExpr dflags fam_envs (Let bind expr)+  = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr++wwExpr dflags fam_envs (Case expr binder ty alts) = do+    new_expr <- wwExpr dflags fam_envs expr+    new_alts <- mapM ww_alt alts+    let new_binder = zapIdUsedOnceInfo binder+      -- See Note [Zapping Used Once info in WorkWrap]+    return (Case new_expr new_binder ty new_alts)+  where+    ww_alt (con, binders, rhs) = do+        new_rhs <- wwExpr dflags fam_envs rhs+        let new_binders = [ if isId b then zapIdUsedOnceInfo b else b+                          | b <- binders ]+           -- See Note [Zapping Used Once info in WorkWrap]+        return (con, new_binders, new_rhs)++{-+************************************************************************+*                                                                      *+\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}+*                                                                      *+************************************************************************++@tryWW@ just accumulates arguments, converts strictness info from the+front-end into the proper form, then calls @mkWwBodies@ to do+the business.++The only reason this is monadised is for the unique supply.++Note [Don't w/w INLINE things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very important to refrain from w/w-ing an INLINE function (ie one+with a stable unfolding) because the wrapper will then overwrite the+old stable unfolding with the wrapper code.++Furthermore, if the programmer has marked something as INLINE,+we may lose by w/w'ing it.++If the strictness analyser is run twice, this test also prevents+wrappers (which are INLINEd) from being re-done.  (You can end up with+several liked-named Ids bouncing around at the same time---absolute+mischief.)++Notice that we refrain from w/w'ing an INLINE function even if it is+in a recursive group.  It might not be the loop breaker.  (We could+test for loop-breaker-hood, but I'm not sure that ever matters.)++Note [Worker-wrapper for INLINABLE functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+  {-# INLINABLE f #-}+  f :: Ord a => [a] -> Int -> a+  f x y = ....f....++where f is strict in y, we might get a more efficient loop by w/w'ing+f.  But that would make a new unfolding which would overwrite the old+one! So the function would no longer be INLNABLE, and in particular+will not be specialised at call sites in other modules.++This comes in practice (#6056).++Solution: do the w/w for strictness analysis, but transfer the Stable+unfolding to the *worker*.  So we will get something like this:++  {-# INLINE[0] f #-}+  f :: Ord a => [a] -> Int -> a+  f d x y = case y of I# y' -> fw d x y'++  {-# INLINABLE[0] fw #-}+  fw :: Ord a => [a] -> Int# -> a+  fw d x y' = let y = I# y' in ...f...++How do we "transfer the unfolding"? Easy: by using the old one, wrapped+in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding.++Note [Worker-wrapper for NOINLINE functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to disable worker/wrapper for NOINLINE things, but it turns out+this can cause unnecessary reboxing of values. Consider++  {-# NOINLINE f #-}+  f :: Int -> a+  f x = error (show x)++  g :: Bool -> Bool -> Int -> Int+  g True  True  p = f p+  g False True  p = p + 1+  g b     False p = g b True p++the strictness analysis will discover f and g are strict, but because f+has no wrapper, the worker for g will rebox p. So we get++  $wg x y p# =+    let p = I# p# in  -- Yikes! Reboxing!+    case x of+      False ->+        case y of+          False -> $wg False True p#+          True -> +# p# 1#+      True ->+        case y of+          False -> $wg True True p#+          True -> case f p of { }++  g x y p = case p of (I# p#) -> $wg x y p#++Now, in this case the reboxing will float into the True branch, and so+the allocation will only happen on the error path. But it won't float+inwards if there are multiple branches that call (f p), so the reboxing+will happen on every call of g. Disaster.++Solution: do worker/wrapper even on NOINLINE things; but move the+NOINLINE pragma to the worker.++(See #13143 for a real-world example.)++It is crucial that we do this for *all* NOINLINE functions. #10069+demonstrates what happens when we promise to w/w a (NOINLINE) leaf function, but+fail to deliver:++  data C = C Int# Int#++  {-# NOINLINE c1 #-}+  c1 :: C -> Int#+  c1 (C _ n) = n++  {-# NOINLINE fc #-}+  fc :: C -> Int#+  fc c = 2 *# c1 c++Failing to w/w `c1`, but still w/wing `fc` leads to the following code:++  c1 :: C -> Int#+  c1 (C _ n) = n++  $wfc :: Int# -> Int#+  $wfc n = let c = C 0# n in 2 #* c1 c++  fc :: C -> Int#+  fc (C _ n) = $wfc n++Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place.+This generalises to any function that derives its strictness signature from+its callees, so we have to make sure that when a function announces particular+strictness properties, we have to w/w them accordingly, even if it means+splitting a NOINLINE function.++Note [Worker activation]+~~~~~~~~~~~~~~~~~~~~~~~~+Follows on from Note [Worker-wrapper for INLINABLE functions]++It is *vital* that if the worker gets an INLINABLE pragma (from the+original function), then the worker has the same phase activation as+the wrapper (or later).  That is necessary to allow the wrapper to+inline into the worker's unfolding: see GHC.Core.Op.Simplify.Utils+Note [Simplifying inside stable unfoldings].++If the original is NOINLINE, it's important that the work inherit the+original activation. Consider++  {-# NOINLINE expensive #-}+  expensive x = x + 1++  f y = let z = expensive y in ...++If expensive's worker inherits the wrapper's activation,+we'll get this (because of the compromise in point (2) of+Note [Wrapper activation])++  {-# NOINLINE[0] $wexpensive #-}+  $wexpensive x = x + 1+  {-# INLINE[0] expensive #-}+  expensive x = $wexpensive x++  f y = let z = expensive y in ...++and $wexpensive will be immediately inlined into expensive, followed by+expensive into f. This effectively removes the original NOINLINE!++Otherwise, nothing is lost by giving the worker the same activation as the+wrapper, because the worker won't have any chance of inlining until the+wrapper does; there's no point in giving it an earlier activation.++Note [Don't w/w inline small non-loop-breaker things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we refrain from w/w-ing *small* functions, which are not+loop breakers, because they'll inline anyway.  But we must take care:+it may look small now, but get to be big later after other inlining+has happened.  So we take the precaution of adding an INLINE pragma to+any such functions.++I made this change when I observed a big function at the end of+compilation with a useful strictness signature but no w-w.  (It was+small during demand analysis, we refrained from w/w, and then got big+when something was inlined in its rhs.) When I measured it on nofib,+it didn't make much difference; just a few percent improved allocation+on one benchmark (bspt/Euclid.space).  But nothing got worse.++There is an infelicity though.  We may get something like+      f = g val+==>+      g x = case gw x of r -> I# r++      f {- InlineStable, Template = g val -}+      f = case gw x of r -> I# r++The code for f duplicates that for g, without any real benefit. It+won't really be executed, because calls to f will go via the inlining.++Note [Don't w/w join points for CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's no point in exploiting CPR info on a join point. If the whole function+is getting CPR'd, then the case expression around the worker function will get+pushed into the join point by the simplifier, which will have the same effect+that w/w'ing for CPR would have - the result will be returned in an unboxed+tuple.++  f z = let join j x y = (x+1, y+1)+        in case z of A -> j 1 2+                     B -> j 2 3++  =>++  f z = case $wf z of (# a, b #) -> (a, b)+  $wf z = case (let join j x y = (x+1, y+1)+                in case z of A -> j 1 2+                             B -> j 2 3) of (a, b) -> (# a, b #)++  =>++  f z = case $wf z of (# a, b #) -> (a, b)+  $wf z = let join j x y = (# x+1, y+1 #)+          in case z of A -> j 1 2+                       B -> j 2 3++Note that we still want to give @j@ the CPR property, so that @f@ has it. So+CPR *analyse* join points as regular functions, but don't *transform* them.++Doing W/W for returned products on a join point would be tricky anyway, as the+worker could not be a join point because it would not be tail-called. However,+doing the *argument* part of W/W still works for join points, since the wrapper+body will make a tail call:++  f z = let join j x y = x + y+        in ...++  =>++  f z = let join $wj x# y# = x# +# y#+                 j x y = case x of I# x# ->+                         case y of I# y# ->+                         $wj x# y#+        in ...++Note [Wrapper activation]+~~~~~~~~~~~~~~~~~~~~~~~~~+When should the wrapper inlining be active?++1. It must not be active earlier than the current Activation of the+   Id++2. It should be active at some point, despite (1) because of+   Note [Worker-wrapper for NOINLINE functions]++3. For ordinary functions with no pragmas we want to inline the+   wrapper as early as possible (#15056).  Suppose another module+   defines    f x = g x x+   and suppose there is some RULE for (g True True).  Then if we have+   a call (f True), we'd expect to inline 'f' and the RULE will fire.+   But if f is w/w'd (which it might be), we want the inlining to+   occur just as if it hadn't been.++   (This only matters if f's RHS is big enough to w/w, but small+   enough to inline given the call site, but that can happen.)++4. We do not want to inline the wrapper before specialisation.+         module Foo where+           f :: Num a => a -> Int -> a+           f n 0 = n              -- Strict in the Int, hence wrapper+           f n x = f (n+n) (x-1)++           g :: Int -> Int+           g x = f x x            -- Provokes a specialisation for f++         module Bar where+           import Foo++           h :: Int -> Int+           h x = f 3 x++   In module Bar we want to give specialisations a chance to fire+   before inlining f's wrapper.++Reminder: Note [Don't w/w INLINE things], so we don't need to worry+          about INLINE things here.++Conclusion:+  - If the user said NOINLINE[n], respect that+  - If the user said NOINLINE, inline the wrapper as late as+    poss (phase 0). This is a compromise driven by (2) above+  - Otherwise inline wrapper in phase 2.  That allows the+    'gentle' simplification pass to apply specialisation rules++Historical note: At one stage I tried making the wrapper inlining+always-active, and that had a very bad effect on nofib/imaginary/x2n1;+a wrapper was inlined before the specialisation fired.++Note [Wrapper NoUserInline]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The use an inl_inline of NoUserInline on the wrapper distinguishes+this pragma from one that was given by the user. In particular, CSE+will not happen if there is a user-specified pragma, but should happen+for w/w’ed things (#14186).+-}++tryWW   :: DynFlags+        -> FamInstEnvs+        -> RecFlag+        -> Id                           -- The fn binder+        -> CoreExpr                     -- The bound rhs; its innards+                                        --   are already ww'd+        -> UniqSM [(Id, CoreExpr)]      -- either *one* or *two* pairs;+                                        -- if one, then no worker (only+                                        -- the orig "wrapper" lives on);+                                        -- if two, then a worker and a+                                        -- wrapper.+tryWW dflags fam_envs is_rec fn_id rhs+  -- See Note [Worker-wrapper for NOINLINE functions]++  | Just stable_unf <- certainlyWillInline dflags fn_info+  = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]+        -- See Note [Don't w/w INLINE things]+        -- See Note [Don't w/w inline small non-loop-breaker things]++  | is_fun && is_eta_exp+  = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs++  | is_thunk                                   -- See Note [Thunk splitting]+  = splitThunk dflags fam_envs is_rec new_fn_id rhs++  | otherwise+  = return [ (new_fn_id, rhs) ]++  where+    fn_info      = idInfo fn_id+    (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info)++    cpr_ty       = getCprSig (cprInfo fn_info)+    -- Arity of the CPR sig should match idArity when it's not a join point.+    -- See Note [Arity trimming for CPR signatures] in GHC.Core.Op.CprAnal+    cpr          = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info+                          , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info))+                   ct_cpr cpr_ty++    new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)+        -- See Note [Zapping DmdEnv after Demand Analyzer] and+        -- See Note [Zapping Used Once info WorkWrap]++    is_fun     = notNull wrap_dmds || isJoinId fn_id+    -- See Note [Don't eta expand in w/w]+    is_eta_exp = length wrap_dmds == manifestArity rhs+    is_thunk   = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)+                            && not (isUnliftedType (idType fn_id))++{-+Note [Zapping DmdEnv after Demand Analyzer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the worker-wrapper pass we zap the DmdEnv.  Why?+ (a) it is never used again+ (b) it wastes space+ (c) it becomes incorrect as things are cloned, because+     we don't push the substitution into it++Why here?+ * Because we don’t want to do it in the Demand Analyzer, as we never know+   there when we are doing the last pass.+ * We want them to be still there at the end of DmdAnal, so that+   -ddump-str-anal contains them.+ * We don’t want a second pass just for that.+ * WorkWrap looks at all bindings anyway.++We also need to do it in TidyCore.tidyLetBndr to clean up after the+final, worker/wrapper-less run of the demand analyser (see+Note [Final Demand Analyser run] in GHC.Core.Op.DmdAnal).++Note [Zapping Used Once info in WorkWrap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the worker-wrapper pass we zap the used once info in demands and in+strictness signatures.++Why?+ * The simplifier may happen to transform code in a way that invalidates the+   data (see #11731 for an example).+ * It is not used in later passes, up to code generation.++So as the data is useless and possibly wrong, we want to remove it. The most+convenient place to do that is the worker wrapper phase, as it runs after every+run of the demand analyser besides the very last one (which is the one where we+want to _keep_ the info for the code generator).++We do not do it in the demand analyser for the same reasons outlined in+Note [Zapping DmdEnv after Demand Analyzer] above.++Note [Don't eta expand in w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A binding where the manifestArity of the RHS is less than idArity of the binder+means GHC.Core.Arity didn't eta expand that binding. When this happens, it does so+for a reason (see Note [exprArity invariant] in GHC.Core.Arity) and we probably have+a PAP, cast or trivial expression as RHS.++Performing the worker/wrapper split will implicitly eta-expand the binding to+idArity, overriding GHC.Core.Arity's decision. Other than playing fast and loose with+divergence, it's also broken for newtypes:++  f = (\xy.blah) |> co+    where+      co :: (Int -> Int -> Char) ~ T++Then idArity is 2 (despite the type T), and it can have a StrictSig based on a+threshold of 2. But we can't w/w it without a type error.++The situation is less grave for PAPs, but the implicit eta expansion caused a+compiler allocation regression in T15164, where huge recursive instance method+groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the+simplifier, when simply waiting for the PAPs to inline arrived at the same+output program.++Note there is the worry here that such PAPs and trivial RHSs might not *always*+be inlined. That would lead to reboxing, because the analysis tacitly assumes+that we W/W'd for idArity and will propagate analysis information under that+assumption. So far, this doesn't seem to matter in practice.+See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.+-}+++---------------------+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr+         -> UniqSM [(Id, CoreExpr)]+splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs+  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) do+    -- The arity should match the signature+    stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info+    case stuff of+      Just (work_demands, join_arity, wrap_fn, work_fn) -> do+        work_uniq <- getUniqueM+        let work_rhs = work_fn rhs+            work_act = case fn_inline_spec of  -- See Note [Worker activation]+                          NoInline -> fn_act+                          _        -> wrap_act++            work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"+                                     , inl_inline = fn_inline_spec+                                     , inl_sat    = Nothing+                                     , inl_act    = work_act+                                     , inl_rule   = FunLike }+              -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]+              -- inl_act:    see Note [Worker activation]+              -- inl_rule:   it does not make sense for workers to be constructorlike.++            work_join_arity | isJoinId fn_id = Just join_arity+                            | otherwise      = Nothing+              -- worker is join point iff wrapper is join point+              -- (see Note [Don't w/w join points for CPR])++            work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)+                        `setIdOccInfo` occInfo fn_info+                                -- Copy over occurrence info from parent+                                -- Notably whether it's a loop breaker+                                -- Doesn't matter much, since we will simplify next, but+                                -- seems right-er to do so++                        `setInlinePragma` work_prag++                        `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding+                                -- See Note [Worker-wrapper for INLINABLE functions]++                        `setIdStrictness` mkClosedStrictSig work_demands div+                                -- Even though we may not be at top level,+                                -- it's ok to give it an empty DmdEnv++                        `setIdCprInfo` mkCprSig work_arity work_cpr_info++                        `setIdDemandInfo` worker_demand++                        `setIdArity` work_arity+                                -- Set the arity so that the Core Lint check that the+                                -- arity is consistent with the demand type goes+                                -- through+                        `asJoinId_maybe` work_join_arity++            work_arity = length work_demands++            -- See Note [Demand on the Worker]+            single_call = saturatedByOneShots arity (demandInfo fn_info)+            worker_demand | single_call = mkWorkerDemand work_arity+                          | otherwise   = topDmd++            wrap_rhs  = wrap_fn work_id+            wrap_act  = case fn_act of  -- See Note [Wrapper activation]+                           ActiveAfter {} -> fn_act+                           NeverActive    -> activeDuringFinal+                           _              -> activeAfterInitial+            wrap_prag = InlinePragma { inl_src    = SourceText "{-# INLINE"+                                     , inl_inline = NoUserInline+                                     , inl_sat    = Nothing+                                     , inl_act    = wrap_act+                                     , inl_rule   = rule_match_info }+                -- inl_act:    see Note [Wrapper activation]+                -- inl_inline: see Note [Wrapper NoUserInline]+                -- inl_rule:   RuleMatchInfo is (and must be) unaffected++            wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule dflags wrap_rhs arity+                              `setInlinePragma` wrap_prag+                              `setIdOccInfo`    noOccInfo+                                -- Zap any loop-breaker-ness, to avoid bleating from Lint+                                -- about a loop breaker with an INLINE rule++++        return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)]+            -- Worker first, because wrapper mentions it++      Nothing -> return [(fn_id, rhs)]+  where+    rhs_fvs         = exprFreeVars rhs+    fn_inl_prag     = inlinePragInfo fn_info+    fn_inline_spec  = inl_inline fn_inl_prag+    fn_act          = inl_act fn_inl_prag+    rule_match_info = inlinePragmaRuleMatchInfo fn_inl_prag+    fn_unfolding    = unfoldingInfo fn_info+    arity           = arityInfo fn_info+                    -- The arity is set by the simplifier using exprEtaExpandArity+                    -- So it may be more than the number of top-level-visible lambdas++    -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points,+    -- see Note [Don't w/w join points for CPR].+    use_cpr_info  | isJoinId fn_id = topCpr+                  | otherwise      = cpr+    -- Even if we don't w/w join points for CPR, we might still do so for+    -- strictness. In which case a join point worker keeps its original CPR+    -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker+    -- doesn't have the CPR property anymore.+    work_cpr_info | isJoinId fn_id = cpr+                  | otherwise      = topCpr+++{-+Note [Demand on the worker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++If the original function is called once, according to its demand info, then+so is the worker. This is important so that the occurrence analyser can+attach OneShot annotations to the worker’s lambda binders.+++Example:++  -- Original function+  f [Demand=<L,1*C1(U)>] :: (a,a) -> a+  f = \p -> ...++  -- Wrapper+  f [Demand=<L,1*C1(U)>] :: a -> a -> a+  f = \p -> case p of (a,b) -> $wf a b++  -- Worker+  $wf [Demand=<L,1*C1(C1(U))>] :: Int -> Int+  $wf = \a b -> ...++We need to check whether the original function is called once, with+sufficiently many arguments. This is done using saturatedByOneShots, which+takes the arity of the original function (resp. the wrapper) and the demand on+the original function.++The demand on the worker is then calculated using mkWorkerDemand, and always of+the form [Demand=<L,1*(C1(...(C1(U))))>]+++Note [Do not split void functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this rather common form of binding:+        $j = \x:Void# -> ...no use of x...++Since x is not used it'll be marked as absent.  But there is no point+in w/w-ing because we'll simply add (\y:Void#), see GHC.Core.Op.WorkWrap.Lib.mkWorerArgs.++If x has a more interesting type (eg Int, or Int#), there *is* a point+in w/w so that we don't pass the argument at all.++Note [Thunk splitting]+~~~~~~~~~~~~~~~~~~~~~~+Suppose x is used strictly (never mind whether it has the CPR+property).++      let+        x* = x-rhs+      in body++splitThunk transforms like this:++      let+        x* = case x-rhs of { I# a -> I# a }+      in body++Now simplifier will transform 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 }++The join point will abstract over a, rather than over (which is+what would have happened before) which is fine.++Notice that x certainly has the CPR property now!++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.+-}++-- See Note [Thunk splitting]+-- splitThunk converts the *non-recursive* binding+--      x = e+-- into+--      x = let x = e+--          in case x of+--               I# y -> let x = I# y in x }+-- See comments above. Is it not beautifully short?+-- Moreover, it works just as well when there are+-- several binders, and if the binders are lifted+-- E.g.     x = e+--     -->  x = let x = e in+--              case x of (a,b) -> let x = (a,b)  in x++splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]+splitThunk dflags fam_envs is_rec fn_id rhs+  = ASSERT(not (isJoinId fn_id))+    do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id]+       ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]+       ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive+                   return res+                   else return [(fn_id, rhs)] }
+ compiler/GHC/Core/Op/WorkWrap/Lib.hs view
@@ -0,0 +1,1247 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++A library for the ``worker\/wrapper'' back-end to the strictness analyser+-}++{-# LANGUAGE CPP #-}++module GHC.Core.Op.WorkWrap.Lib+   ( mkWwBodies, mkWWstr, mkWorkerArgs+   , DataConAppContext(..), deepSplitProductType_maybe, wantToUnbox+   , findTypeShape+   , isWorkerSmallEnough+   )+where++#include "HsVersions.h"++import GhcPrelude++import GHC.Core+import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase )+import GHC.Types.Id+import GHC.Types.Id.Info ( JoinArity )+import GHC.Core.DataCon+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Core.Make    ( mkAbsentErrorApp, mkCoreUbxTup+                        , mkCoreApp, mkCoreLet )+import GHC.Types.Id.Make ( voidArgId, voidPrimId )+import TysWiredIn       ( tupleDataCon )+import TysPrim          ( voidPrimTy )+import GHC.Types.Literal ( absentLiteralOf, rubbishLit )+import GHC.Types.Var.Env ( mkInScopeSet )+import GHC.Types.Var.Set ( VarSet )+import GHC.Core.Type+import GHC.Core.Predicate ( isClassPred )+import GHC.Types.RepType  ( isVoidTy, typePrimRep )+import GHC.Core.Coercion+import GHC.Core.FamInstEnv+import GHC.Types.Basic       ( Boxity(..) )+import GHC.Core.TyCon+import GHC.Types.Unique.Supply+import GHC.Types.Unique+import Maybes+import Util+import Outputable+import GHC.Driver.Session+import FastString+import ListSetOps++{-+************************************************************************+*                                                                      *+\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}+*                                                                      *+************************************************************************++Here's an example.  The original function is:++\begin{verbatim}+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+        case x of+          0 -> head ys+          _ -> head (tail ys)+\end{verbatim}++From this, we want to produce:+\begin{verbatim}+-- wrapper (an unfolding)+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+        case x of+          I# x# -> $wg a x# ys+            -- call the worker; don't forget the type args!++-- worker+$wg :: forall a . Int# -> [a] -> a++$wg = \/\ a -> \ x# ys ->+        let+            x = I# x#+        in+            case x of               -- note: body of g moved intact+              0 -> head ys+              _ -> head (tail ys)+\end{verbatim}++Something we have to be careful about:  Here's an example:++\begin{verbatim}+-- "f" strictness: U(P)U(P)+f (I# a) (I# b) = a +# b++g = f   -- "g" strictness same as "f"+\end{verbatim}++\tr{f} will get a worker all nice and friendly-like; that's good.+{\em But we don't want a worker for \tr{g}}, even though it has the+same strictness as \tr{f}.  Doing so could break laziness, at best.++Consequently, we insist that the number of strictness-info items is+exactly the same as the number of lambda-bound arguments.  (This is+probably slightly paranoid, but OK in practice.)  If it isn't the+same, we ``revise'' the strictness info, so that we won't propagate+the unusable strictness-info into the interfaces.+++************************************************************************+*                                                                      *+\subsection{The worker wrapper core}+*                                                                      *+************************************************************************++@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.+-}++type WwResult+  = ([Demand],              -- Demands 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++mkWwBodies :: DynFlags+           -> FamInstEnvs+           -> VarSet         -- Free vars of RHS+                             -- See Note [Freshen WW arguments]+           -> Id             -- The original function+           -> [Demand]       -- Strictness of original function+           -> CprResult      -- Info about function result+           -> UniqSM (Maybe WwResult)++-- wrap_fn_args E       = \x y -> E+-- work_fn_args E       = E x y++-- wrap_fn_str E        = case x of { (a,b) ->+--                        case a of { (a1,a2) ->+--                        E a1 a2 b y }}+-- work_fn_str E        = \a1 a2 b y ->+--                        let a = (a1,a2) in+--                        let x = (a,b) in+--                        E++mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info+  = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)+                -- See Note [Freshen WW arguments]++        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+             <- mkWWargs empty_subst fun_ty demands+        ; (useful1, work_args, wrap_fn_str, work_fn_str)+             <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args++        -- Do CPR w/w.  See Note [Always do CPR w/w]+        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)+              <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info++        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty+              worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]+              wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var+              worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args++        ; if isWorkerSmallEnough dflags work_args+             && not (too_many_args_for_join_point wrap_args)+             && ((useful1 && not only_one_void_argument) || useful2)+          then return (Just (worker_args_dmds, length work_call_args,+                       wrapper_body, worker_body))+          else return Nothing+        }+        -- We use an INLINE unconditionally, even if the wrapper turns out to be+        -- something trivial like+        --      fw = ...+        --      f = __inline__ (coerce T fw)+        -- The point is to propagate the coerce to f's call sites, so even though+        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent+        -- fw from being inlined into f's RHS+  where+    fun_ty        = idType fun_id+    mb_join_arity = isJoinId_maybe fun_id+    has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)+                          -- See Note [Do not unpack class dictionaries]++    -- Note [Do not split void functions]+    only_one_void_argument+      | [d] <- demands+      , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty+      , isAbsDmd d && isVoidTy arg_ty1+      = True+      | 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+      = WARN(True, text "Unable to worker/wrapper join point with arity " <+>+                     int join_arity <+> text "but" <+>+                     int (length wrap_args) <+> text "args")+        True+      | otherwise+      = False++-- See Note [Limit w/w arity]+isWorkerSmallEnough :: DynFlags -> [Var] -> Bool+isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags+    -- We count only Free variables (isId) to skip Type, Kind+    -- variables which have no runtime representation.++{-+Note [Always do CPR w/w]+~~~~~~~~~~~~~~~~~~~~~~~~+At one time we refrained from doing CPR w/w for thunks, on the grounds that+we might duplicate work.  But that is already handled by the demand analyser,+which doesn't give the CPR property if w/w might waste work: see+Note [CPR for thunks] in GHC.Core.Op.DmdAnal.++And if something *has* been given the CPR property and we don't w/w, it's+a disaster, because then the enclosing function might say it has the CPR+property, but now doesn't and there a cascade of disaster.  A good example+is #5920.++Note [Limit w/w arity]+~~~~~~~~~~~~~~~~~~~~~~~~+Guard against high worker arity as it generates a lot of stack traffic.+A simplified example is #11565#comment:6++Current strategy is very simple: don't perform w/w transformation at all+if the result produces a wrapper with arity higher than -fmax-worker-args=.++It is a bit all or nothing, consider++        f (x,y) (a,b,c,d,e ... , z) = rhs++Currently we will remove all w/w ness entirely. But actually we could+w/w on the (x,y) pair... it's the huge product that is the problem.++Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd+solve f. But we can get a lot of args from deeply-nested products:++        g (a, (b, (c, (d, ...)))) = rhs++This is harder to spot on an arg-by-arg basis. Previously mkWwStr was+given some "fuel" saying how many arguments it could add; when we ran+out of fuel it would stop w/wing.+Still not very clever because it had a left-right bias.++************************************************************************+*                                                                      *+\subsection{Making wrapper args}+*                                                                      *+************************************************************************++During worker-wrapper stuff we may end up with an unlifted thing+which we want to let-bind without losing laziness.  So we+add a void argument.  E.g.++        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z+==>+        fw = /\ a -> \void -> E+        f  = /\ a -> \x y z -> fw realworld++We use the state-token type which generates no code.+-}++mkWorkerArgs :: DynFlags -> [Var]+             -> Type    -- Type of body+             -> ([Var], -- Lambda bound args+                 [Var]) -- Args at call site+mkWorkerArgs dflags args res_ty+    | any isId args || not needsAValueLambda+    = (args, args)+    | otherwise+    = (args ++ [voidArgId], args ++ [voidPrimId])+    where+      -- See "Making wrapper args" section above+      needsAValueLambda =+        lifted+        -- We may encounter a levity-polymorphic result, in which case we+        -- conservatively assume that we have laziness that needs preservation.+        -- See #15186.+        || not (gopt Opt_FunToThunk dflags)+           -- see Note [Protecting the last value argument]++      -- Might the result be lifted?+      lifted =+        case isLiftedType_maybe res_ty of+          Just lifted -> lifted+          Nothing     -> True++{-+Note [Protecting the last value argument]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the user writes (\_ -> E), they might be intentionally disallowing+the sharing of E. Since absence analysis and worker-wrapper are keen+to remove such unused arguments, we add in a void argument to prevent+the function from becoming a thunk.++The user can avoid adding the void argument with the -ffun-to-thunk+flag. However, this can create sharing, which may be bad in two ways. 1) It can+create a space leak. 2) It can prevent inlining *under a lambda*. If w/w+removes the last argument from a function f, then f now looks like a thunk, and+so f can't be inlined *under a lambda*.++Note [Join points and beta-redexes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Originally, the worker would invoke the original function by calling it with+arguments, thus producing a beta-redex for the simplifier to munch away:++  \x y z -> e => (\x y z -> e) wx wy wz++Now that we have special rules about join points, however, this is Not Good if+the original function is itself a join point, as then it may contain invocations+of other join points:++  join j1 x = ...+  join j2 y = if y == 0 then 0 else j1 y++  =>++  join j1 x = ...+  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy+  join j2 y = case y of I# y# -> jump $wj2 y#++There can't be an intervening lambda between a join point's declaration and its+occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:++  ...+  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y+  ...++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 GraphOps.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.++************************************************************************+*                                                                      *+\subsection{Coercion stuff}+*                                                                      *+************************************************************************++We really want to "look through" coerces.+Reason: I've seen this situation:++        let f = coerce T (\s -> E)+        in \x -> case x of+                    p -> coerce T' f+                    q -> \s -> E2+                    r -> coerce T' f++If only we w/w'd f, we'd get+        let f = coerce T (\s -> fw s)+            fw = \s -> E+        in ...++Now we'll inline f to get++        let fw = \s -> E+        in \x -> case x of+                    p -> fw+                    q -> \s -> E2+                    r -> fw++Now we'll see that fw has arity 1, and will arity expand+the \x to get what we want.+-}++-- mkWWargs just does eta expansion+-- is driven off the function type and arity.+-- It chomps bites off foralls, arrows, newtypes+-- and keeps repeating that until it's satisfied the supplied arity++mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type+                                --   See Note [Freshen WW arguments]+         -> Type                -- The type of the function+         -> [Demand]     -- Demands and one-shot info for value arguments+         -> UniqSM  ([Var],            -- Wrapper args+                     CoreExpr -> CoreExpr,      -- Wrapper fn+                     CoreExpr -> CoreExpr,      -- Worker fn+                     Type)                      -- Type of wrapper body++mkWWargs subst fun_ty demands+  | null demands+  = return ([], id, id, substTy subst fun_ty)++  | (dmd:demands') <- demands+  , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty+  = do  { uniq <- getUniqueM+        ; let arg_ty' = substTy subst arg_ty+              id = mk_wrap_arg uniq arg_ty' dmd+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+              <- mkWWargs subst fun_ty' demands'+        ; return (id : wrap_args,+                  Lam id . wrap_fn_args,+                  apply_or_bind_then work_fn_args (varToCoreExpr id),+                  res_ty) }++  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty+  = do  { uniq <- getUniqueM+        ; let (subst', tv') = cloneTyVarBndr subst tv uniq+                -- See Note [Freshen WW arguments]+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+             <- mkWWargs subst' fun_ty' demands+        ; return (tv' : wrap_args,+                  Lam tv' . wrap_fn_args,+                  apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),+                  res_ty) }++  | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty+        -- The newtype case is for when the function has+        -- a newtype after the arrow (rare)+        --+        -- It's also important when we have a function returning (say) a pair+        -- wrapped in a  newtype, at least if CPR analysis can look+        -- through such newtypes, which it probably can since they are+        -- simply coerces.++  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)+            <-  mkWWargs subst rep_ty demands+       ; let co' = substCo subst co+       ; return (wrap_args,+                  \e -> Cast (wrap_fn_args e) (mkSymCo co'),+                  \e -> work_fn_args (Cast e co'),+                  res_ty) }++  | otherwise+  = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand+    return ([], id, id, substTy subst fun_ty)   -- then there should be a function arrow+  where+    -- See Note [Join points and beta-redexes]+    apply_or_bind_then k arg (Lam bndr body)+      = mkCoreLet (NonRec bndr arg) (k body)    -- Important that arg is fresh!+    apply_or_bind_then k arg fun+      = k $ mkCoreApp (text "mkWWargs") fun arg+applyToVars :: [Var] -> CoreExpr -> CoreExpr+applyToVars vars fn = mkVarApps fn vars++mk_wrap_arg :: Unique -> Type -> Demand -> Id+mk_wrap_arg uniq ty dmd+  = mkSysLocalOrCoVar (fsLit "w") uniq ty+       `setIdDemandInfo` dmd++{- Note [Freshen WW arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Wen we do a worker/wrapper split, we must not in-scope names as the arguments+of the worker, else we'll get name capture.  E.g.++   -- y1 is in scope from further out+   f x = ..y1..++If we accidentally choose y1 as a worker argument disaster results:++   fww y1 y2 = let x = (y1,y2) in ...y1...++To avoid this:++  * We use a fresh unique for both type-variable and term-variable binders+    Originally we lacked this freshness for type variables, and that led+    to the very obscure #12562.  (A type variable in the worker shadowed+    an outer term-variable binding.)++  * Because of this cloning we have to substitute in the type/kind of the+    new binders.  That's why we carry the TCvSubst through mkWWargs.++    So we need a decent in-scope set, just in case that type/kind+    itself has foralls.  We get this from the free vars of the RHS of the+    function since those are the only variables that might be captured.+    It's a lazy thunk, which will only be poked if the type/kind has a forall.++    Another tricky case was when f :: forall a. a -> forall a. a->a+    (i.e. with shadowing), and then the worker used the same 'a' twice.++************************************************************************+*                                                                      *+\subsection{Strictness stuff}+*                                                                      *+************************************************************************+-}++mkWWstr :: DynFlags+        -> FamInstEnvs+        -> Bool    -- True <=> INLINEABLE pragma on this function defn+                   -- See Note [Do not unpack class dictionaries]+        -> [Var]                                -- Wrapper args; have their demand info on them+                                                --  *Includes type variables*+        -> UniqSM (Bool,                        -- Is this useful+                   [Var],                       -- Worker args+                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call+                                                -- and without its lambdas+                                                -- This fn adds the unboxing++                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,+                                                -- and lacking its lambdas.+                                                -- This fn does the reboxing+mkWWstr dflags fam_envs has_inlineable_prag args+  = go args+  where+    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg++    go []           = return (False, [], nop_fn, nop_fn)+    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg+                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args+                         ; return ( useful1 || useful2+                                  , args1 ++ args2+                                  , wrap_fn1 . wrap_fn2+                                  , work_fn1 . work_fn2) }++{-+Note [Unpacking arguments with product and polymorphic demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The argument is unpacked in a case if it has a product type and has a+strict *and* used demand put on it. I.e., arguments, with demands such+as the following ones:++   <S,U(U, L)>+   <S(L,S),U>++will be unpacked, but++   <S,U> or <B,U>++will not, because the pieces aren't used. This is quite important otherwise+we end up unpacking massive tuples passed to the bottoming function. Example:++        f :: ((Int,Int) -> String) -> (Int,Int) -> a+        f g pr = error (g pr)++        main = print (f fst (1, error "no"))++Does 'main' print "error 1" or "error no"?  We don't really want 'f'+to unbox its second argument.  This actually happened in GHC's onwn+source code, in Packages.applyPackageFlag, which ended up un-boxing+the enormous DynFlags tuple, and being strict in the+as-yet-un-filled-in pkgState files.+-}++----------------------+-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)+--   *  wrap_fn assumes wrap_arg is in scope,+--        brings into scope work_args (via cases)+--   * work_fn assumes work_args are in scope, a+--        brings into scope wrap_arg (via lets)+-- See Note [How to do the worker/wrapper split]+mkWWstr_one :: DynFlags -> FamInstEnvs+            -> Bool    -- True <=> INLINEABLE pragma on this function defn+                       -- See Note [Do not unpack class dictionaries]+            -> Var+            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+mkWWstr_one dflags fam_envs has_inlineable_prag arg+  | isTyVar arg+  = return (False, [arg],  nop_fn, nop_fn)++  | isAbsDmd dmd+  , Just work_fn <- mk_absent_let dflags fam_envs arg+     -- Absent case.  We can't always handle absence for arbitrary+     -- unlifted types, so we need to choose just the cases we can+     -- (that's what mk_absent_let does)+  = return (True, [], nop_fn, work_fn)++  | Just (cs, acdc) <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd+  = unbox_one dflags fam_envs arg cs acdc++  | otherwise   -- Other cases+  = return (False, [arg], nop_fn, nop_fn)++  where+    arg_ty = idType arg+    dmd    = idDemandInfo arg++wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext)+wantToUnbox fam_envs has_inlineable_prag ty dmd =+  case deepSplitProductType_maybe fam_envs ty of+    Just dcac@DataConAppContext{ dcac_arg_tys = con_arg_tys }+      | isStrictDmd dmd+      -- See Note [Unpacking arguments with product and polymorphic demands]+      , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys)+      -- See Note [Do not unpack class dictionaries]+      , not (has_inlineable_prag && isClassPred ty)+      -- See Note [mkWWstr and unsafeCoerce]+      , cs `equalLength` con_arg_tys+      -> Just (cs, dcac)+    _ -> Nothing+  where+    split_prod_dmd_arity dmd arty+      -- For seqDmd, splitProdDmd_maybe will return Nothing (because how would+      -- it know the arity?), but it should behave like <S, U(AAAA)>, for some+      -- suitable arity+      | isSeqDmd dmd = Just (replicate arty absDmd)+      -- Otherwise splitProdDmd_maybe does the job+      | otherwise    = splitProdDmd_maybe dmd++unbox_one :: DynFlags -> FamInstEnvs -> Var+          -> [Demand]+          -> DataConAppContext+          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+unbox_one dflags fam_envs arg cs+          DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys+                            , dcac_arg_tys = inst_con_arg_tys+                            , dcac_co = co }+  = do { (uniq1:uniqs) <- getUniquesM+        ; let   -- See Note [Add demands for strict constructors]+                cs'       = addDataConStrictness data_con cs+                unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs'+                unbox_fn  = mkUnpackCase (Var arg) co uniq1+                                         data_con unpk_args+                arg_no_unf = zapStableUnfolding arg+                             -- See Note [Zap unfolding when beta-reducing]+                             -- in GHC.Core.Op.Simplify; and see #13890+                rebox_fn   = Let (NonRec arg_no_unf con_app)+                con_app    = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co+         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args+         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }+                           -- Don't pass the arg, rebox instead+  where+    mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd++----------------------+nop_fn :: CoreExpr -> CoreExpr+nop_fn body = body++addDataConStrictness :: DataCon -> [Demand] -> [Demand]+-- See Note [Add demands for strict constructors]+addDataConStrictness con ds+  = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds )+    zipWith add ds strs+  where+    strs = dataConRepStrictness con+    add dmd str | isMarkedStrict str = strictifyDmd dmd+                | otherwise          = dmd++{- Note [How to do the worker/wrapper split]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The worker-wrapper transformation, mkWWstr_one, takes into account+several possibilities to decide if the function is worthy for+splitting:++1. If an argument is absent, it would be silly to pass it to+   the worker.  Hence the isAbsDmd case.  This case must come+   first because a demand like <S,A> or <B,A> is possible.+   E.g. <B,A> comes from a function like+       f x = error "urk"+   and <S,A> can come from Note [Add demands for strict constructors]++2. If the argument is evaluated strictly, and we can split the+   product demand (splitProdDmd_maybe), then unbox it and w/w its+   pieces.  For example++    f :: (Int, Int) -> Int+    f p = (case p of (a,b) -> a) + 1+  is split to+    f :: (Int, Int) -> Int+    f p = case p of (a,b) -> $wf a++    $wf :: Int -> Int+    $wf a = a + 1++  and+    g :: Bool -> (Int, Int) -> Int+    g c p = case p of (a,b) ->+               if c then a else b+  is split to+   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 the components are not used; that is, the+   usage is just 'Used' rather than 'UProd'. In this case+   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing+   a massive tuple which is barely used.  Example:++        f :: ((Int,Int) -> String) -> (Int,Int) -> a+        f g pr = error (g pr)++        main = print (f fst (1, error "no"))++   Here, f does not take 'pr' apart, and it's stupid to do so.+   Imagine that it had millions of fields. This actually happened+   in GHC itself where the tuple was DynFlags++3. A plain 'seqDmd', which is head-strict with usage UHead, can't+   be split by splitProdDmd_maybe.  But we want it to behave just+   like U(AAAA) for suitable number of absent demands. So we have+   a special case for it, with arity coming from the data constructor.++Note [Worker-wrapper for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used not to split if the result is bottom.+[Justification:  there's no efficiency to be gained.]++But it's sometimes bad not to make a wrapper.  Consider+        fw = \x# -> let x = I# x# in case e of+                                        p1 -> error_fn x+                                        p2 -> error_fn x+                                        p3 -> the real stuff+The re-boxing code won't go away unless error_fn gets a wrapper too.+[We don't do reboxing now, but in general it's better to pass an+unboxed thing to f, and have it reboxed in the error cases....]++Note [Add demands for strict constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this program (due to Roman):++    data X a = X !a++    foo :: X Int -> Int -> Int+    foo (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, 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++* We leave the demand-analysis alone.  The demand on 'a' in the+  definition of 'foo' is <L, U(U)>; the strictness info is Lazy+  because foo's body may or may not evaluate 'a'; but the usage info+  says that 'a' is unpacked and its content is used.++* During worker/wrapper, if we unpack a strict constructor (as we do+  for 'foo'), we use 'addDataConStrictness' to bump up the strictness on+  the strict arguments of the data constructor.++* That in turn means that, if the usage info supports doing so+  (i.e. splitProdDmd_maybe returns Just), we will unpack that argument+  -- even though the original demand (e.g. on 'a') was lazy.++* What does "bump up the strictness" mean?  Just add a head-strict+  demand to the strictness!  Even for a demand like <L,A> we can+  safely turn it into <S,A>; remember case (1) of+  Note [How to do the worker/wrapper split].++The net effect is that the w/w transformation is more aggressive about+unpacking the strict arguments of a data constructor, when that+eagerness is supported by the usage info.++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++    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 [mkWWstr and unsafeCoerce]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+By using unsafeCoerce, it is possible to make the number of demands fail to+match the number of constructor arguments; this happened in #8037.+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 [Record evaluated-ness in worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   data T = MkT !Int Int++   f :: T -> T+   f x = e++and f's is strict, and has the CPR property.  The we are going to generate+this w/w split++   f x = case x of+           MkT x1 x2 -> case $wf x1 x2 of+                           (# r1, r2 #) -> MkT r1 r2++   $wfw x1 x2 = let x = MkT x1 x2 in+                case e of+                  MkT r1 r2 -> (# r1, r2 #)++Note that++* In the worker $wf, inside 'e' we can be sure that x1 will be+  evaluated (it came from unpacking the argument MkT.  But that's no+  immediately apparent in $wf++* In the wrapper 'f', which we'll inline at call sites, we can be sure+  that 'r1' has been evaluated (because it came from unpacking the result+  MkT.  But that is not immediately apparent from the wrapper code.++Missing these facts isn't unsound, but it loses possible future+opportunities for optimisation.++Solution: use setCaseBndrEvald when creating+ (A) The arg binders x1,x2 in mkWstr_one+         See #13077, test T13077+ (B) The result binders r1,r2 in mkWWcpr_help+         See Trace #13077, test T13077a+         And #13027 comment:20, item (4)+to record that the relevant binder is evaluated.+++************************************************************************+*                                                                      *+         Type scrutiny that is specific to demand analysis+*                                                                      *+************************************************************************++Note [Do not unpack 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.Op.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 switch+off the unpacking in mkWWstr_one (see the isClassPred test).++Historical note: #14955 describes how I got this fix wrong+the first time.+-}++-- | Context for a 'DataCon' application with a hole for every field, including+-- surrounding coercions.+-- The result of 'deepSplitProductType_maybe' and 'deepSplitCprType_maybe'.+--+-- Example:+--+-- > DataConAppContext Just [Int] [(Lazy, Int)] (co :: Maybe Int ~ First Int)+--+-- represents+--+-- > Just @Int (_1 :: Int) |> co :: First Int+--+-- where _1 is a hole for the first argument. The number of arguments is+-- determined by the length of @arg_tys@.+data DataConAppContext+  = DataConAppContext+  { dcac_dc      :: !DataCon+  , dcac_tys     :: ![Type]+  , dcac_arg_tys :: ![(Type, StrictnessMark)]+  , dcac_co      :: !Coercion+  }++deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext+-- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)+-- then  dc @ tys (args::arg_tys) :: rep_ty+--       co :: ty ~ rep_ty+-- Why do we return the strictness of the data-con arguments?+-- Answer: see Note [Record evaluated-ness in worker/wrapper]+deepSplitProductType_maybe fam_envs ty+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty+                    `orElse` (mkRepReflCo ty, ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , Just con <- isDataProductTyCon_maybe tc+  , let arg_tys = dataConInstArgTys con tc_args+        strict_marks = dataConRepStrictness con+  = Just DataConAppContext { dcac_dc = con+                           , dcac_tys = tc_args+                           , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks+                           , dcac_co = co }+deepSplitProductType_maybe _ _ = Nothing++deepSplitCprType_maybe+  :: FamInstEnvs -> ConTag -> Type -> Maybe DataConAppContext+-- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)+-- then  dc @ tys (args::arg_tys) :: rep_ty+--       co :: ty ~ rep_ty+-- Why do we return the strictness of the data-con arguments?+-- Answer: see Note [Record evaluated-ness in worker/wrapper]+deepSplitCprType_maybe fam_envs con_tag ty+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty+                    `orElse` (mkRepReflCo ty, ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , isDataTyCon tc+  , let cons = tyConDataCons tc+  , cons `lengthAtLeast` con_tag -- This might not be true if we import the+                                 -- type constructor via a .hs-bool file (#8743)+  , let con = cons `getNth` (con_tag - fIRST_TAG)+        arg_tys = dataConInstArgTys con tc_args+        strict_marks = dataConRepStrictness con+  = Just DataConAppContext { dcac_dc = con+                           , dcac_tys = tc_args+                           , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks+                           , dcac_co = co }+deepSplitCprType_maybe _ _ _ = Nothing++findTypeShape :: FamInstEnvs -> Type -> TypeShape+-- Uncover the arrow and product shape of a type+-- The data type TypeShape is defined in GHC.Types.Demand+-- See Note [Trimming a demand to a type] in GHC.Types.Demand+findTypeShape fam_envs ty+  | Just (tc, tc_args)  <- splitTyConApp_maybe ty+  , Just con <- isDataProductTyCon_maybe tc+  = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)++  | Just (_, res) <- splitFunTy_maybe ty+  = TsFun (findTypeShape fam_envs res)++  | Just (_, ty') <- splitForAllTy_maybe ty+  = findTypeShape fam_envs ty'++  | Just (_, ty') <- topNormaliseType_maybe fam_envs ty+  = findTypeShape fam_envs ty'++  | otherwise+  = TsUnk++{-+************************************************************************+*                                                                      *+\subsection{CPR stuff}+*                                                                      *+************************************************************************+++@mkWWcpr@ takes the worker/wrapper pair produced from the strictness+info and adds in the CPR transformation.  The worker returns an+unboxed tuple containing non-CPR components.  The wrapper takes this+tuple and re-produces the correct structured output.++The non-CPR results appear ordered in the unboxed tuple as if by a+left-to-right traversal of the result structure.+-}++mkWWcpr :: Bool+        -> FamInstEnvs+        -> Type                              -- function body type+        -> CprResult                         -- CPR analysis results+        -> UniqSM (Bool,                     -- Is w/w'ing useful?+                   CoreExpr -> CoreExpr,     -- New wrapper+                   CoreExpr -> CoreExpr,     -- New worker+                   Type)                     -- Type of worker's body++mkWWcpr opt_CprAnal fam_envs body_ty cpr+    -- CPR explicitly turned off (or in -O0)+  | not opt_CprAnal = return (False, id, id, body_ty)+    -- CPR is turned on by default for -O and O2+  | otherwise+  = case asConCpr cpr of+       Nothing      -> return (False, id, id, body_ty)  -- No CPR info+       Just con_tag | Just dcac <- deepSplitCprType_maybe fam_envs con_tag body_ty+                    -> mkWWcpr_help dcac+                    |  otherwise+                       -- See Note [non-algebraic or open body type warning]+                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )+                       return (False, id, id, body_ty)++mkWWcpr_help :: DataConAppContext+             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)++mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys+                                , dcac_arg_tys = arg_tys, dcac_co = co })+  | [arg1@(arg_ty1, _)] <- arg_tys+  , isUnliftedType arg_ty1+        -- Special case when there is a single result of unlifted type+        --+        -- Wrapper:     case (..call worker..) of x -> C x+        -- Worker:      case (   ..body..    ) of C x -> x+  = do { (work_uniq : arg_uniq : _) <- getUniquesM+       ; let arg       = mk_ww_local arg_uniq arg1+             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co++       ; return ( True+                , \ wkr_call -> mkDefaultCase wkr_call arg con_app+                , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)+                                -- varToCoreExpr important here: arg can be a coercion+                                -- Lacking this caused #10658+                , arg_ty1 ) }++  | otherwise   -- The general case+        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b+        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)+  = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM+       ; let wrap_wild   = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict)+             args        = zipWith mk_ww_local uniqs arg_tys+             ubx_tup_ty  = exprType ubx_tup_app+             ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)+             con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co+             tup_con     = tupleDataCon Unboxed (length arg_tys)++       ; return (True+                , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild+                                                (DataAlt tup_con) args con_app+                , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app+                , ubx_tup_ty ) }++mkUnpackCase ::  CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr+-- (mkUnpackCase e co uniq Con args body)+--      returns+-- case e |> co of bndr { Con args -> body }++mkUnpackCase (Tick tickish e) co uniq con args body   -- See Note [Profiling and unpacking]+  = Tick tickish (mkUnpackCase e co uniq con args body)+mkUnpackCase scrut co uniq boxing_con unpk_args body+  = mkSingleAltCase casted_scrut bndr+                    (DataAlt boxing_con) unpk_args body+  where+    casted_scrut = scrut `mkCast` co+    bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)++{-+Note [non-algebraic or open body type warning]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are a few cases where the W/W transformation is told that something+returns a constructor, but the type at hand doesn't really match this. One+real-world example involves unsafeCoerce:+  foo = IO a+  foo = unsafeCoerce c_exit+  foreign import ccall "c_exit" c_exit :: IO ()+Here CPR will tell you that `foo` returns a () constructor for sure, but trying+to create a worker/wrapper for type `a` obviously fails.+(This was a real example until ee8e792  in libraries/base.)++It does not seem feasible to avoid all such cases already in the analyser (and+after all, the analysis is not really wrong), so we simply do nothing here in+mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch+other cases where something went avoidably wrong.++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 [Profiling and unpacking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the original function looked like+        f = \ x -> {-# SCC "foo" #-} E++then we want the CPR'd worker to look like+        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)+and definitely not+        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)++This transform doesn't move work or allocation+from one cost centre to another.++Later [SDM]: presumably this is because we want the simplifier to+eliminate the case, and the scc would get in the way?  I'm ok with+including the case itself in the cost centre, since it is morally+part of the function (post transformation) anyway.+++************************************************************************+*                                                                      *+\subsection{Utilities}+*                                                                      *+************************************************************************++Note [Absent errors]+~~~~~~~~~~~~~~~~~~~~+We make a new binding for Ids that are marked absent, thus+   let x = absentError "x :: Int"+The idea is that this binding will never be used; but if it+buggily is used we'll get a runtime error message.++Coping with absence for *unlifted* types is important; see, for+example, #4306 and #15627.  In the UnliftedRep case, we can+use LitRubbish, which we need to apply to the required type.+For the unlifted types of singleton kind like Float#, Addr#, etc. we+also find a suitable literal, using Literal.absentLiteralOf.  We don't+have literals for every primitive type, so the function is partial.++Note: I did try the experiment of using an error thunk for unlifted+things too, relying on the simplifier to drop it as dead code.+But this is fragile++ - It fails when profiling is on, which disables various optimisations++ - It fails when reboxing happens. E.g.+      data T = MkT Int Int#+      f p@(MkT a _) = ...g p....+   where g is /lazy/ in 'p', but only uses the first component.  Then+   'f' is /strict/ in 'p', and only uses the first component.  So we only+   pass that component to the worker for 'f', which reconstructs 'p' to+   pass it to 'g'.  Alas we can't say+       ...f (MkT a (absentError Int# "blah"))...+   bacause `MkT` is strict in its Int# argument, so we get an absentError+   exception when we shouldn't.  Very annoying!++So absentError is only used for lifted types.+-}++-- | Tries to find a suitable dummy RHS to bind the given absent identifier to.+--+-- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding+-- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be+-- found (currently only happens for bindings of 'VecRep' representation).+mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Maybe (CoreExpr -> CoreExpr)+mk_absent_let dflags fam_envs arg+  -- The lifted case: Bind 'absentError'+  -- See Note [Absent errors]+  | not (isUnliftedType arg_ty)+  = Just (Let (NonRec lifted_arg abs_rhs))+  -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@+  -- See Note [Absent errors]+  | [UnliftedRep] <- typePrimRep arg_ty+  = Just (Let (NonRec arg unlifted_rhs))+  -- The monomorphic unlifted cases: Bind to some literal, if possible+  -- See Note [Absent errors]+  | Just tc <- tyConAppTyCon_maybe nty+  , Just lit <- absentLiteralOf tc+  = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co)))+  | nty `eqType` voidPrimTy+  = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co)))+  | otherwise+  = WARN( True, text "No absent value for" <+> ppr arg_ty )+    Nothing -- Can happen for 'State#' and things of 'VecRep'+  where+    lifted_arg   = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr+              -- Note in strictness signature that this is bottoming+              -- (for the sake of the "empty case scrutinee not known to+              -- diverge for sure lint" warning)+    arg_ty       = idType arg++    -- Normalise the type to have best chance of finding an absent literal+    -- e.g. (#17852)   data unlifted N = MkN Int#+    --                 f :: N -> a -> a+    --                 f _ x = x+    (co, nty)    = topNormaliseType_maybe fam_envs arg_ty+                   `orElse` (mkRepReflCo arg_ty, arg_ty)++    abs_rhs      = mkAbsentErrorApp arg_ty msg+    msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)+                          (ppr arg <+> ppr (idType arg))+              -- We need to suppress uniques here because otherwise they'd+              -- end up in the generated code as strings. This is bad for+              -- determinism, because with different uniques the strings+              -- will have different lengths and hence different costs for+              -- the inliner leading to different inlining.+              -- See also Note [Unique Determinism] in GHC.Types.Unique+    unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty]++mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id+-- The StrictnessMark comes form the data constructor and says+-- whether this field is strict+-- See Note [Record evaluated-ness in worker/wrapper]+mk_ww_local uniq (ty,str)+  = setCaseBndrEvald str $+    mkSysLocalOrCoVar (fsLit "ww") uniq ty
compiler/GHC/Core/Ppr/TyThing.hs view
@@ -21,16 +21,16 @@  import GhcPrelude -import Type    ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType )+import GHC.Core.Type    ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)   , showToHeader, pprIfaceDecl )-import CoAxiom ( coAxiomTyCon )+import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) import GHC.Driver.Types( tyThingParent_maybe )-import GHC.Iface.Utils ( tyThingToIfaceDecl )-import FamInstEnv( FamInst(..), FamFlavor(..) )-import TyCoPpr ( pprUserForAll, pprTypeApp, pprSigmaType )-import Name-import VarEnv( emptyTidyEnv )+import GHC.Iface.Make ( tyThingToIfaceDecl )+import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )+import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType )+import GHC.Types.Name+import GHC.Types.Var.Env( emptyTidyEnv ) import Outputable  -- -----------------------------------------------------------------------------@@ -72,7 +72,7 @@  * Interface files contains fast-strings, not uniques, so the very same   tidying must take place when we convert to IfaceDecl. E.g.-  GHC.Iface.Utils.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,+  GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,   Class etc) to an IfaceDecl.    Bottom line: IfaceDecls are already 'tidy', so it's straightforward
compiler/GHC/CoreToByteCode.hs view
@@ -19,44 +19,43 @@ import GHC.ByteCode.Types  import GHC.Runtime.Interpreter-import GHC.Runtime.Interpreter.Types import GHCi.FFI import GHCi.RemoteTypes-import BasicTypes+import GHC.Types.Basic import GHC.Driver.Session import Outputable import GHC.Platform-import Name-import MkId-import Id-import Var             ( updateVarType )-import ForeignCall+import GHC.Types.Name+import GHC.Types.Id.Make+import GHC.Types.Id+import GHC.Types.Var ( updateVarType )+import GHC.Types.ForeignCall import GHC.Driver.Types import GHC.Core.Utils import GHC.Core import GHC.Core.Ppr-import Literal+import GHC.Types.Literal import PrimOp import GHC.Core.FVs-import Type+import GHC.Core.Type import GHC.Types.RepType-import DataCon-import TyCon+import GHC.Core.DataCon+import GHC.Core.TyCon import Util-import VarSet+import GHC.Types.Var.Set import TysPrim-import TyCoPpr         ( pprType )+import GHC.Core.TyCo.Ppr ( pprType ) import ErrUtils-import Unique+import GHC.Types.Unique import FastString import Panic-import GHC.StgToCmm.Closure    ( NonVoid(..), fromNonVoid, nonVoidIds )+import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) import GHC.Data.Bitmap import OrdList import Maybes-import VarEnv+import GHC.Types.Var.Env import PrelNames ( unsafeEqualityProofName )  import Data.List@@ -64,8 +63,8 @@ import Control.Monad import Data.Char -import UniqSupply-import Module+import GHC.Types.Unique.Supply+import GHC.Types.Module  import Control.Exception import Data.Array@@ -205,19 +204,19 @@ newtype WordOff = WordOff Int     deriving (Enum, Eq, Integral, Num, Ord, Real) -wordsToBytes :: DynFlags -> WordOff -> ByteOff-wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral+wordsToBytes :: Platform -> WordOff -> ByteOff+wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral  -- Used when we know we have a whole number of words-bytesToWords :: DynFlags -> ByteOff -> WordOff-bytesToWords dflags (ByteOff bytes) =-    let (q, r) = bytes `quotRem` (wORD_SIZE dflags)+bytesToWords :: Platform -> ByteOff -> WordOff+bytesToWords platform (ByteOff bytes) =+    let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)     in if r == 0            then fromIntegral q            else panic $ "GHC.CoreToByteCode.bytesToWords: bytes=" ++ show bytes -wordSize :: DynFlags -> ByteOff-wordSize dflags = ByteOff (wORD_SIZE dflags)+wordSize :: Platform -> ByteOff+wordSize platform = ByteOff (platformWordSizeInBytes platform)  type Sequel = ByteOff -- back off to this depth before ENTER @@ -297,11 +296,11 @@         peep []            = [] -argBits :: DynFlags -> [ArgRep] -> [Bool]-argBits _      [] = []-argBits dflags (rep : args)-  | isFollowableArg rep  = False : argBits dflags args-  | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args+argBits :: Platform -> [ArgRep] -> [Bool]+argBits _        [] = []+argBits platform (rep : args)+  | isFollowableArg rep  = False : argBits platform args+  | otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args  -- ----------------------------------------------------------------------------- -- schemeTopBind@@ -382,6 +381,7 @@    = do      dflags <- getDynFlags      let+         platform  = targetPlatform dflags          all_args  = reverse args ++ fvs          arity     = length all_args          -- all_args are the args in reverse order.  We're compiling a function@@ -390,14 +390,14 @@           -- Stack arguments always take a whole number of words, we never pack          -- them unlike constructor fields.-         szsb_args = map (wordsToBytes dflags . idSizeW dflags) all_args+         szsb_args = map (wordsToBytes platform . idSizeW platform) all_args          sum_szsb_args  = sum szsb_args          p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))           -- make the arg bitmap-         bits = argBits dflags (reverse (map bcIdArgRep all_args))+         bits = argBits platform (reverse (map bcIdArgRep all_args))          bitmap_size = genericLength bits-         bitmap = mkBitmap dflags bits+         bitmap = mkBitmap platform bits      body_code <- schemeER_wrk sum_szsb_args p_init body       emitBc (mkProtoBCO dflags nm body_code (Right original_body)@@ -411,21 +411,24 @@         cc_arr <- getCCArray         this_mod <- moduleName <$> getCurrentModule         dflags <- getDynFlags-        let idOffSets = getVarOffSets dflags d p fvs+        let platform = targetPlatform dflags+        let idOffSets = getVarOffSets platform d p fvs         let breakInfo = CgBreakInfo                         { cgb_vars = idOffSets                         , cgb_resty = exprType (deAnnotate' newRhs)                         }         newBreakInfo tick_no breakInfo-        dflags <- getDynFlags-        let cc | interpreterProfiled dflags = cc_arr ! tick_no+        hsc_env <- getHscEnv+        let cc | Just interp <- hsc_interp hsc_env+               , interpreterProfiled interp+               = cc_arr ! tick_no                | otherwise = toRemotePtr nullPtr         let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc         return $ breakInstr `consOL` code    | otherwise = schemeE d 0 p rhs -getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]-getVarOffSets dflags depth env = map getOffSet+getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]+getVarOffSets platform depth env = map getOffSet   where     getOffSet id = case lookupBCEnv_maybe id env of         Nothing     -> Nothing@@ -438,7 +441,7 @@             -- BRK_FUN in Interpreter.c In any case, this is used only when             -- we trigger a breakpoint.             let !var_depth_ws =-                    trunc16W $ bytesToWords dflags (depth - offset) + 2+                    trunc16W $ bytesToWords platform (depth - offset) + 2             in Just (id, var_depth_ws)  truncIntegral16 :: Integral a => a -> Word16@@ -481,10 +484,11 @@ -- Heave it on the stack, SLIDE, and RETURN. returnUnboxedAtom d s p e e_rep = do     dflags <- getDynFlags+    let platform = targetPlatform dflags     (push, szb) <- pushAtom d p e-    return (push                                 -- value onto stack-           `appOL`  mkSlideB dflags szb (d - s)  -- clear to sequel-           `snocOL` RETURN_UBX e_rep)            -- go+    return (push                                  -- value onto stack+           `appOL`  mkSlideB platform szb (d - s) -- clear to sequel+           `snocOL` RETURN_UBX e_rep)             -- go  -- Compile code to apply the given expression to the remaining args -- on the stack, returning a HNF.@@ -514,15 +518,15 @@         -- saturated constructor application.         -- Just allocate the constructor and carry on         alloc_code <- mkConAppCode d s p data_con args_r_to_l-        dflags <- getDynFlags-        let !d2 = d + wordSize dflags+        platform <- targetPlatform <$> getDynFlags+        let !d2 = d + wordSize platform         body_code <- schemeE d2 s (Map.insert x d2 p) body         return (alloc_code `appOL` body_code)  -- General case for let.  Generates correct, if inefficient, code in -- all situations. schemeE d s p (AnnLet binds (_,body)) = do-     dflags <- getDynFlags+     platform <- targetPlatform <$> getDynFlags      let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])                                    AnnRec xs_n_rhss -> unzip xs_n_rhss          n_binds = genericLength xs@@ -533,7 +537,7 @@          (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss           -- Sizes of free vars-         size_w = trunc16W . idSizeW dflags+         size_w = trunc16W . idSizeW platform          sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss           -- the arity of each rhs@@ -543,9 +547,9 @@          -- are ptrs, so all have size 1 word.  d' and p' reflect the stack          -- after the closures have been allocated in the heap (but not          -- filled in), and pointers to them parked on the stack.-         offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))+         offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform))          p' = Map.insertList (zipE xs' offsets) p-         d' = d + wordsToBytes dflags n_binds+         d' = d + wordsToBytes platform n_binds          zipE = zipEqual "schemeE"           -- ToDo: don't build thunks for things with no free variables@@ -830,8 +834,9 @@    | Just con <- maybe_saturated_dcon    = do alloc_con <- mkConAppCode d s p con args_r_to_l         dflags <- getDynFlags+        let platform = targetPlatform dflags         return (alloc_con         `appOL`-                mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL`+                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`                 ENTER)     -- Case 4: Tail call of function@@ -874,6 +879,7 @@   where     app_code = do         dflags <- getDynFlags+        let platform = targetPlatform dflags          -- The args are initially in reverse order, but mkVirtHeapOffsets         -- expects them to be left-to-right.@@ -893,7 +899,7 @@                 more_push_code <- do_pushery (d + arg_bytes) args                 return (push `appOL` more_push_code)             do_pushery !d [] = do-                let !n_arg_words = trunc16W $ bytesToWords dflags (d - orig_d)+                let !n_arg_words = trunc16W $ bytesToWords platform (d - orig_d)                 return (unitOL (PACK con n_arg_words))          -- Push on the stack in the reverse order.@@ -927,15 +933,17 @@         ASSERT( null reps ) return ()         (push_fn, sz) <- pushAtom d p (AnnVar fn)         dflags <- getDynFlags-        ASSERT( sz == wordSize dflags ) return ()-        let slide = mkSlideB dflags (d - init_d + wordSize dflags) (init_d - s)+        let platform = targetPlatform dflags+        ASSERT( sz == wordSize platform ) return ()+        let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)         return (push_fn `appOL` (slide `appOL` unitOL ENTER))   do_pushes !d args reps = do       let (push_apply, n, rest_of_reps) = findPushSeq reps           (these_args, rest_of_args) = splitAt n args       (next_d, push_code) <- push_seq d these_args       dflags <- getDynFlags-      instrs <- do_pushes (next_d + wordSize dflags) rest_of_args rest_of_reps+      let platform = targetPlatform dflags+      instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps       --                          ^^^ for the PUSH_APPLY_ instruction       return (push_code `appOL` (push_apply `consOL` instrs)) @@ -994,30 +1002,32 @@      dflags <- getDynFlags      hsc_env <- getHscEnv      let+        platform = targetPlatform dflags         profiling-          | Just (ExternalInterp _) <- hsc_interp hsc_env = gopt Opt_SccProfilingOn dflags-          | otherwise = rtsIsProfiled+          | Just interp <- hsc_interp hsc_env+          = interpreterProfiled interp+          | otherwise = False          -- Top of stack is the return itbl, as usual.         -- underneath it is the pointer to the alt_code BCO.         -- When an alt is entered, it assumes the returned value is         -- on top of the itbl.         ret_frame_size_b :: StackDepth-        ret_frame_size_b = 2 * wordSize dflags+        ret_frame_size_b = 2 * wordSize platform          -- The extra frame we push to save/restore the CCCS when profiling-        save_ccs_size_b | profiling = 2 * wordSize dflags+        save_ccs_size_b | profiling = 2 * wordSize platform                         | otherwise = 0          -- An unlifted value gets an extra info table pushed on top         -- when it is returned.         unlifted_itbl_size_b :: StackDepth         unlifted_itbl_size_b | isAlgCase = 0-                            | otherwise = wordSize dflags+                             | otherwise = wordSize platform          -- depth of stack after the return value has been pushed         d_bndr =-            d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)+            d + ret_frame_size_b + wordsToBytes platform (idSizeW platform bndr)          -- depth of stack after the extra info table for an unboxed return         -- has been pushed, if any.  This is the stack depth at the@@ -1059,7 +1069,7 @@                          ]                  size = WordOff tot_wds -                 stack_bot = d_alts + wordsToBytes dflags size+                 stack_bot = d_alts + wordsToBytes platform size                   -- convert offsets from Sp into offsets into the virtual stack                  p' = Map.insertList@@ -1109,10 +1119,10 @@         -- really want a bitmap up to depth (d-s).  This affects compilation of         -- case-of-case expressions, which is the only time we can be compiling a         -- case expression with s /= 0.-        bitmap_size = trunc16W $ bytesToWords dflags (d - s)+        bitmap_size = trunc16W $ bytesToWords platform (d - s)         bitmap_size' :: Int         bitmap_size' = fromIntegral bitmap_size-        bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}+        bitmap = intsToReverseBitmap platform bitmap_size'{-size-}                         (sort (filter (< bitmap_size') rel_slots))           where           binds = Map.toList p@@ -1121,7 +1131,7 @@           rel_slots = nub $ map fromIntegral $ concatMap spread binds           spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]                               | otherwise                      = []-                where rel_offset = trunc16W $ bytesToWords dflags (d - offset)+                where rel_offset = trunc16W $ bytesToWords platform (d - offset)       alt_stuff <- mapM codeAlt alts      alt_final <- mkMultiBranch maybe_ncons alt_stuff@@ -1165,9 +1175,10 @@      dflags <- getDynFlags       let+         platform = targetPlatform dflags          -- useful constants          addr_size_b :: ByteOff-         addr_size_b = wordSize dflags+         addr_size_b = wordSize platform           -- Get the args on the stack, with tags and suitably          -- dereferenced for the CCall.  For each arg, return the@@ -1223,10 +1234,10 @@      code_n_reps <- pargs d0 args_r_to_l      let          (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps-         a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l)+         a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l)           push_args    = concatOL pushs_arg-         !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW+         !d_after_args = d0 + wordsToBytes platform a_reps_sizeW          a_reps_pushed_RAW             | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))             = panic "GHC.CoreToByteCode.generateCCall: missing or invalid World token?"@@ -1288,9 +1299,9 @@                    Just (LitLabel target mb_size IsFunction)                    where                       mb_size-                          | OSMinGW32 <- platformOS (targetPlatform dflags)+                          | OSMinGW32 <- platformOS platform                           , StdCallConv <- cconv-                          = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)+                          = Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform)                           | otherwise                           = Nothing @@ -1313,12 +1324,12 @@           -- Push the return placeholder.  For a call returning nothing,          -- this is a V (tag).-         r_sizeW   = repSizeWords dflags r_rep-         d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW+         r_sizeW   = repSizeWords platform r_rep+         d_after_r = d_after_Addr + wordsToBytes platform r_sizeW          push_r =              if returns_void                 then nilOL-                else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW))+                else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (trunc16W r_sizeW))           -- generate the marshalling code we're going to call @@ -1326,7 +1337,7 @@          -- instruction needs to describe the chunk of stack containing          -- the ccall args to the GC, so it needs to know how large it          -- is.  See comment in Interpreter.c with the CCALL instruction.-         stk_offset   = trunc16W $ bytesToWords dflags (d_after_r - s)+         stk_offset   = trunc16W $ bytesToWords platform (d_after_r - s)           conv = case cconv of            CCallConv -> FFICCall@@ -1338,8 +1349,8 @@      -- address of this to the CCALL instruction.  -     let ffires = primRepToFFIType dflags r_rep-         ffiargs = map (primRepToFFIType dflags) a_reps+     let ffires = primRepToFFIType platform r_rep+         ffiargs = map (primRepToFFIType platform) a_reps      hsc_env <- getHscEnv      token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)      recordFFIBc token@@ -1353,7 +1364,7 @@                            PlayRisky         -> 0x2           -- slide and return-         d_after_r_min_s = bytesToWords dflags (d_after_r - s)+         d_after_r_min_s = bytesToWords platform (d_after_r - s)          wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)                         `snocOL` RETURN_UBX (toArgRep r_rep)          --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $@@ -1362,8 +1373,8 @@          push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup          ) -primRepToFFIType :: DynFlags -> PrimRep -> FFIType-primRepToFFIType dflags r+primRepToFFIType :: Platform -> PrimRep -> FFIType+primRepToFFIType platform r   = case r of      VoidRep     -> FFIVoid      IntRep      -> signed_word@@ -1375,18 +1386,17 @@      DoubleRep   -> FFIDouble      _           -> panic "primRepToFFIType"   where-    (signed_word, unsigned_word)-       | wORD_SIZE dflags == 4  = (FFISInt32, FFIUInt32)-       | wORD_SIZE dflags == 8  = (FFISInt64, FFIUInt64)-       | otherwise              = panic "primTyDescChar"+    (signed_word, unsigned_word) = case platformWordSize platform of+       PW4 -> (FFISInt32, FFIUInt32)+       PW8 -> (FFISInt64, FFIUInt64)  -- Make a dummy literal, to be used as a placeholder for FFI return -- values on the stack.-mkDummyLiteral :: DynFlags -> PrimRep -> Literal-mkDummyLiteral dflags pr+mkDummyLiteral :: Platform -> PrimRep -> Literal+mkDummyLiteral platform pr    = case pr of-        IntRep    -> mkLitInt dflags 0-        WordRep   -> mkLitWord dflags 0+        IntRep    -> mkLitInt  platform 0+        WordRep   -> mkLitWord platform 0         Int64Rep  -> mkLitInt64 0         Word64Rep -> mkLitWord64 0         AddrRep   -> LitNullAddr@@ -1504,8 +1514,9 @@        dflags <- getDynFlags        let infos = zip4 labels (tail labels ++ [label_fail])                                [0 ..] names+           platform = targetPlatform dflags            steps = map (mkStep label_exit) infos-           slide_ws = bytesToWords dflags (d - s + arg_bytes)+           slide_ws = bytesToWords platform (d - s + arg_bytes)         return (push_arg                `appOL` unitOL (PUSH_UBX LitNullAddr 1)@@ -1562,24 +1573,24 @@     | Just primop <- isPrimOpId_maybe var    = do-       dflags <-getDynFlags-       return (unitOL (PUSH_PRIMOP primop), wordSize dflags)+       platform <- targetPlatform <$> getDynFlags+       return (unitOL (PUSH_PRIMOP primop), wordSize platform)     | Just d_v <- lookupBCEnv_maybe var p  -- var is a local variable-   = do dflags <- getDynFlags+   = do platform <- targetPlatform <$> getDynFlags -        let !szb = idSizeCon dflags var+        let !szb = idSizeCon platform var             with_instr instr = do                 let !off_b = trunc16B $ d - d_v-                return (unitOL (instr off_b), wordSize dflags)+                return (unitOL (instr off_b), wordSize platform)          case szb of             1 -> with_instr PUSH8_W             2 -> with_instr PUSH16_W             4 -> with_instr PUSH32_W             _ -> do-                let !szw = bytesToWords dflags szb-                    !off_w = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1+                let !szw = bytesToWords platform szb+                    !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1                 return (toOL (genericReplicate szw (PUSH_L off_w)), szb)         -- d - d_v           offset from TOS to the first slot of the object         --@@ -1590,22 +1601,22 @@     | otherwise  -- var must be a global variable    = do topStrings <- getTopStrings-        dflags <- getDynFlags+        platform <- targetPlatform <$> getDynFlags         case lookupVarEnv topStrings var of-            Just ptr -> pushAtom d p $ AnnLit $ mkLitWord dflags $+            Just ptr -> pushAtom d p $ AnnLit $ mkLitWord platform $               fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr             Nothing -> do-                let sz = idSizeCon dflags var-                MASSERT( sz == wordSize dflags )+                let sz = idSizeCon platform var+                MASSERT( sz == wordSize platform )                 return (unitOL (PUSH_G (getName var)), sz)   pushAtom _ _ (AnnLit lit) = do-     dflags <- getDynFlags+     platform <- targetPlatform <$> getDynFlags      let code rep-             = let size_words = WordOff (argRepSizeW dflags rep)+             = let size_words = WordOff (argRepSizeW platform rep)                in  return (unitOL (PUSH_UBX lit (trunc16W size_words)),-                           wordsToBytes dflags size_words)+                           wordsToBytes platform size_words)       case lit of         LitLabel _ _ _   -> code N@@ -1642,8 +1653,8 @@  pushConstrAtom d p (AnnVar v)     | Just d_v <- lookupBCEnv_maybe v p = do  -- v is a local variable-        dflags <- getDynFlags-        let !szb = idSizeCon dflags v+        platform <- targetPlatform <$> getDynFlags+        let !szb = idSizeCon platform v             done instr = do                 let !off = trunc16B $ d - d_v                 return (unitOL (instr off), szb)@@ -1807,11 +1818,11 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff lookupBCEnv_maybe = Map.lookup -idSizeW :: DynFlags -> Id -> WordOff-idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep+idSizeW :: Platform -> Id -> WordOff+idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep -idSizeCon :: DynFlags -> Id -> ByteOff-idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep+idSizeCon :: Platform -> Id -> ByteOff+idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep  bcIdArgRep :: Id -> ArgRep bcIdArgRep = toArgRep . bcIdPrimRep@@ -1823,8 +1834,8 @@   | otherwise   = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) -repSizeWords :: DynFlags -> PrimRep -> WordOff-repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)+repSizeWords :: Platform -> PrimRep -> WordOff+repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep rep)  isFollowableArg :: ArgRep -> Bool isFollowableArg P = True@@ -1856,11 +1867,11 @@   ("Error: bytecode compiler can't handle some foreign calling conventions\n"++    "  Workaround: use -fobject-code, or compile this module to .o separately.")) -mkSlideB :: DynFlags -> ByteOff -> ByteOff -> OrdList BCInstr-mkSlideB dflags !nb !db = mkSlideW n d+mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr+mkSlideB platform !nb !db = mkSlideW n d   where-    !n = trunc16W $ bytesToWords dflags nb-    !d = bytesToWords dflags db+    !n = trunc16W $ bytesToWords platform nb+    !d = bytesToWords platform db  mkSlideW :: Word16 -> WordOff -> OrdList BCInstr mkSlideW !n !ws
compiler/GHC/CoreToStg.hs view
@@ -23,34 +23,36 @@ import GHC.Core.Arity   ( manifestArity ) import GHC.Stg.Syntax -import Type+import GHC.Core.Type import GHC.Types.RepType-import TyCon-import MkId             ( coercionTokenId )-import Id-import IdInfo-import DataCon-import CostCentre-import VarEnv-import Module-import Name             ( isExternalName, nameModule_maybe )-import BasicTypes       ( Arity )+import GHC.Core.TyCon+import GHC.Types.Id.Make ( coercionTokenId )+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core.DataCon+import GHC.Types.CostCentre+import GHC.Types.Var.Env+import GHC.Types.Module+import GHC.Types.Name   ( isExternalName, nameModule_maybe )+import GHC.Types.Basic  ( Arity ) import TysWiredIn       ( unboxedUnitDataCon, unitDataConId )-import Literal+import GHC.Types.Literal import Outputable import MonadUtils import FastString import Util import GHC.Driver.Session-import ForeignCall-import Demand           ( isUsedOnce )+import GHC.Driver.Ways+import GHC.Types.ForeignCall+import GHC.Types.Demand ( isUsedOnce ) import PrimOp           ( PrimCall(..), primOpWrapperId )-import SrcLoc           ( mkGeneralSrcSpan )+import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) import PrelNames        ( unsafeEqualityProofName )  import Data.List.NonEmpty (nonEmpty, toList) import Data.Maybe    (fromMaybe) import Control.Monad (ap)+import qualified Data.Set as Set  -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~@@ -230,7 +232,7 @@     (_, (local_ccs, local_cc_stacks), pgm')       = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm -    prof = WayProf `elem` ways dflags+    prof = WayProf `Set.member` ways dflags      final_ccs       | prof && gopt Opt_AutoSccsOnIndividualCafs dflags@@ -447,7 +449,7 @@     vars_alt (con, binders, rhs)       | DataAlt c <- con, c == unboxedUnitDataCon       = -- This case is a bit smelly.-        -- See Note [Nullary unboxed tuple] in Type.hs+        -- See Note [Nullary unboxed tuple] in GHC.Core.Type         -- where a nullary tuple is mapped to (State# World#)         ASSERT( null binders )         do { rhs2 <- coreToStgExpr rhs@@ -606,11 +608,11 @@         -- or foreign call.         -- Wanted: a better solution than this hacky warning -    dflags <- getDynFlags+    platform <- targetPlatform <$> getDynFlags     let         arg_rep = typePrimRep (exprType arg)         stg_arg_rep = typePrimRep (stgArgType stg_arg)-        bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep)+        bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)      WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )      return (stg_arg : stg_args, ticks ++ aticks)
compiler/GHC/CoreToStg/Prep.hs view
@@ -18,48 +18,50 @@ #include "HsVersions.h"  import GhcPrelude+import GHC.Platform -import OccurAnal+import GHC.Core.Op.OccurAnal  import GHC.Driver.Types import PrelNames-import MkId             ( realWorldPrimId )+import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Core.Utils import GHC.Core.Arity import GHC.Core.FVs-import CoreMonad        ( CoreToDo(..) )+import GHC.Core.Op.Monad ( CoreToDo(..) ) import GHC.Core.Lint    ( endPassIO ) import GHC.Core import GHC.Core.Make hiding( FloatBind(..) )   -- We use our own FloatBind here-import Type-import Literal-import Coercion+import GHC.Core.Type+import GHC.Types.Literal+import GHC.Core.Coercion import TcEnv-import TyCon-import Demand-import Var-import VarSet-import VarEnv-import Id-import IdInfo+import GHC.Core.TyCon+import GHC.Types.Demand+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Id+import GHC.Types.Id.Info import TysWiredIn-import DataCon-import BasicTypes-import Module-import UniqSupply+import GHC.Core.DataCon+import GHC.Types.Basic+import GHC.Types.Module+import GHC.Types.Unique.Supply import Maybes import OrdList import ErrUtils import GHC.Driver.Session+import GHC.Driver.Ways import Util import Outputable import FastString-import Name             ( NamedThing(..), nameSrcSpan, isInternalName )-import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )+import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )+import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits import MonadUtils       ( mapAccumLM ) import Control.Monad-import CostCentre       ( CostCentre, ccFromThisModule )+import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S  {-@@ -110,7 +112,7 @@     We want curried definitions for all of these in case they     aren't inlined by some caller. -9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.hs+9.  Replace (lazy e) by e.  See Note [lazyId magic] in GHC.Types.Id.Make     Also replace (noinline e) by e.  10. Convert (LitInteger i t) into the core representation@@ -183,7 +185,7 @@     initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env      let cost_centres-          | WayProf `elem` ways dflags+          | WayProf `S.member` ways dflags           = collectCostCentres this_mod binds           | otherwise           = S.empty@@ -522,7 +524,7 @@ cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr             -> UniqSM (JoinId, CpeRhs) -- Used for all join bindings--- No eta-expansion: see Note [Do not eta-expand join points] in SimplUtils+-- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Op.Simplify.Utils cpeJoinPair env bndr rhs   = ASSERT(isJoinId bndr)     do { let Just join_arity = isJoinId_maybe bndr@@ -573,10 +575,10 @@ cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr) cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr) cpeRhsE env (Lit (LitNumber LitNumInteger i _))-    = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)+    = cpeRhsE env (cvtLitInteger (targetPlatform (cpe_dynFlags env)) (getMkIntegerId env)                    (cpe_integerSDataCon env) i) cpeRhsE env (Lit (LitNumber LitNumNatural i _))-    = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)+    = cpeRhsE env (cvtLitNatural (targetPlatform (cpe_dynFlags env)) (getMkNaturalId env)                    (cpe_naturalSDataCon env) i) cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {})  = cpeApp env expr@@ -651,17 +653,17 @@             ; rhs' <- cpeBodyNF env2 rhs             ; return (con, bs', rhs') } -cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr+cvtLitInteger :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr -- Here we convert a literal Integer to the low-level -- representation. Exactly how we do this depends on the -- library that implements Integer.  If it's GMP we -- use the S# data constructor for small literals.--- See Note [Integer literals] in Literal-cvtLitInteger dflags _ (Just sdatacon) i-  | inIntRange dflags i -- Special case for small integers-    = mkConApp sdatacon [Lit (mkLitInt dflags i)]+-- See Note [Integer literals] in GHC.Types.Literal+cvtLitInteger platform _ (Just sdatacon) i+  | platformInIntRange platform i -- Special case for small integers+    = mkConApp sdatacon [Lit (mkLitInt platform i)] -cvtLitInteger dflags mk_integer _ i+cvtLitInteger platform mk_integer _ i     = mkApps (Var mk_integer) [isNonNegative, ints]   where isNonNegative = if i < 0 then mkConApp falseDataCon []                                  else mkConApp trueDataCon  []@@ -669,25 +671,25 @@         f 0 = []         f x = let low  = x .&. mask                   high = x `shiftR` bits-              in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high+              in mkConApp intDataCon [Lit (mkLitInt platform low)] : f high         bits = 31         mask = 2 ^ bits - 1 -cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr+cvtLitNatural :: Platform -> Id -> Maybe DataCon -> Integer -> CoreExpr -- Here we convert a literal Natural to the low-level -- representation.--- See Note [Natural literals] in Literal-cvtLitNatural dflags _ (Just sdatacon) i-  | inWordRange dflags i -- Special case for small naturals-    = mkConApp sdatacon [Lit (mkLitWord dflags i)]+-- See Note [Natural literals] in GHC.Types.Literal+cvtLitNatural platform _ (Just sdatacon) i+  | platformInWordRange platform i -- Special case for small naturals+    = mkConApp sdatacon [Lit (mkLitWord platform i)] -cvtLitNatural dflags mk_natural _ i+cvtLitNatural platform mk_natural _ i     = mkApps (Var mk_natural) [words]   where words = mkListExpr wordTy (f i)         f 0 = []         f x = let low  = x .&. mask                   high = x `shiftR` bits-              in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high+              in mkConApp wordDataCon [Lit (mkLitWord platform low)] : f high         bits = 32         mask = 2 ^ bits - 1 @@ -769,7 +771,7 @@    (case bot of {}) realWorldPrimId# because that gives a panic in CoreToStg.myCollectArgs, which expects only variables in function position.  But if we are sure to make-runRW# strict (which we do in MkId), this can't happen+runRW# strict (which we do in GHC.Types.Id.Make), this can't happen -}  cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)@@ -897,7 +899,7 @@       CpeApp arg@(Coercion {}) ->         rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss       CpeApp arg -> do-        let (ss1, ss_rest)  -- See Note [lazyId magic] in MkId+        let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make                = case (ss, isLazyExpr arg) of                    (_   : ss_rest, True)  -> (topDmd, ss_rest)                    (ss1 : ss_rest, False) -> (ss1,    ss_rest)@@ -916,7 +918,7 @@         rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss  isLazyExpr :: CoreExpr -> Bool--- See Note [lazyId magic] in MkId+-- See Note [lazyId magic] in GHC.Types.Id.Make isLazyExpr (Cast e _)              = isLazyExpr e isLazyExpr (Tick _ e)              = isLazyExpr e isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey@@ -1409,7 +1411,7 @@ with cases like this.  We can then drop the let-binding altogether.  Why does the removal of 'lazy' have to occur in CorePrep?-The gory details are in Note [lazyId magic] in MkId, but the+The gory details are in Note [lazyId magic] in GHC.Types.Id.Make, but the main reason is that lazy must appear in unfoldings (optimizer output) and it must prevent call-by-value for catch# (which is implemented by CorePrep.)
compiler/GHC/Data/Bitmap.hs view
@@ -18,7 +18,6 @@  import GHC.Platform import GHC.Runtime.Heap.Layout-import GHC.Driver.Session  import Data.Bits @@ -30,32 +29,32 @@ type Bitmap = [StgWord]  -- | Make a bitmap from a sequence of bits-mkBitmap :: DynFlags -> [Bool] -> Bitmap+mkBitmap :: Platform -> [Bool] -> Bitmap mkBitmap _ [] = []-mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest-  where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff+mkBitmap platform stuff = chunkToBitmap platform chunk : mkBitmap platform rest+  where (chunk, rest) = splitAt (platformWordSizeInBits platform) stuff -chunkToBitmap :: DynFlags -> [Bool] -> StgWord-chunkToBitmap dflags chunk =-  foldl' (.|.) (toStgWord dflags 0) [ oneAt n | (True,n) <- zip chunk [0..] ]+chunkToBitmap :: Platform -> [Bool] -> StgWord+chunkToBitmap platform chunk =+  foldl' (.|.) (toStgWord platform 0) [ oneAt n | (True,n) <- zip chunk [0..] ]   where     oneAt :: Int -> StgWord-    oneAt i = toStgWord dflags 1 `shiftL` i+    oneAt i = toStgWord platform 1 `shiftL` i  -- | Make a bitmap where the slots specified are the /zeros/ in the bitmap. -- eg. @[0,1,3], size 4 ==> 0x4@  (we leave any bits outside the size as zero, -- just to make the bitmap easier to read). -- -- The list of @Int@s /must/ be already sorted and duplicate-free.-intsToReverseBitmap :: DynFlags+intsToReverseBitmap :: Platform                     -> Int      -- ^ size in bits                     -> [Int]    -- ^ sorted indices of zeros free of duplicates                     -> Bitmap-intsToReverseBitmap dflags size = go 0+intsToReverseBitmap platform size = go 0   where-    word_sz = wORD_SIZE_IN_BITS dflags+    word_sz = platformWordSizeInBits platform     oneAt :: Int -> StgWord-    oneAt i = toStgWord dflags 1 `shiftL` i+    oneAt i = toStgWord platform 1 `shiftL` i      -- It is important that we maintain strictness here.     -- See Note [Strictness when building Bitmaps].@@ -63,7 +62,7 @@     go !pos slots       | size <= pos = []       | otherwise =-        (foldl' xor (toStgWord dflags init) (map (\i->oneAt (i - pos)) these)) :+        (foldl' xor (toStgWord platform init) (map (\i->oneAt (i - pos)) these)) :           go (pos + word_sz) rest       where         (these,rest) = span (< (pos + word_sz)) slots@@ -98,8 +97,8 @@ large.  This value represents the largest size of bitmap that can be packed into a single word. -}-mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int-mAX_SMALL_BITMAP_SIZE dflags =-    case platformWordSize (targetPlatform dflags) of+mAX_SMALL_BITMAP_SIZE :: Platform -> Int+mAX_SMALL_BITMAP_SIZE platform =+    case platformWordSize platform of       PW4 -> 27 -- On 32-bit: 5 bits for size, 27 bits for bitmap       PW8 -> 58 -- On 64-bit: 6 bits for size, 58 bits for bitmap
compiler/GHC/Driver/Backpack.hs view
@@ -32,23 +32,23 @@ import GHC.Driver.Session import TcRnMonad import TcRnDriver-import Module+import GHC.Types.Module import GHC.Driver.Types import StringBuffer import FastString import ErrUtils-import SrcLoc+import GHC.Types.SrcLoc import GHC.Driver.Main-import UniqFM-import UniqDFM+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM import Outputable import Maybes import HeaderInfo-import GHC.Iface.Utils+import GHC.Iface.Recomp import GHC.Driver.Make-import UniqDSet+import GHC.Types.Unique.DSet import PrelNames-import BasicTypes hiding (SuccessFlag(..))+import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Driver.Finder import Util @@ -87,7 +87,8 @@         POk _ pkgname_bkp -> do             -- OK, so we have an LHsUnit PackageName, but we want an             -- LHsUnit HsComponentId.  So let's rename it.-            let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp+            let pkgstate = pkgState dflags+            let bkp = renameHsUnits pkgstate (packageNameMap pkgstate pkgname_bkp) pkgname_bkp             initBkpM src_filename bkp $                 forM_ (zip [1..] bkp) $ \(i, lunit) -> do                     let comp_name = unLoc (hsunitName (unLoc lunit))@@ -95,7 +96,7 @@                     innerBkpM $ do                         let (cid, insts) = computeUnitId lunit                         if null insts-                            then if cid == ComponentId (fsLit "main")+                            then if cid == ComponentId (fsLit "main") Nothing                                     then compileExe lunit                                     else compileUnit cid []                             else typecheckUnit cid insts@@ -136,7 +137,7 @@                -> BkpM a withBkpSession cid insts deps session_type do_this = do     dflags <- getDynFlags-    let (ComponentId cid_fs) = cid+    let (ComponentId cid_fs _) = cid         is_primary = False         uid_str = unpackFS (hashUnitId cid insts)         cid_str = unpackFS cid_fs@@ -205,7 +206,7 @@  withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a withBkpExeSession deps do_this = do-    withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this+    withBkpSession (ComponentId (fsLit "main") Nothing) [] deps ExeSession do_this  getSource :: ComponentId -> BkpM (LHsUnit HsComponentId) getSource cid = do@@ -303,7 +304,7 @@             getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)             obj_files = concatMap getOfiles linkables -        let compat_fs = (case cid of ComponentId fs -> fs)+        let compat_fs = (case cid of ComponentId fs _ -> fs)             compat_pn = PackageName compat_fs          return InstalledPackageInfo {@@ -560,22 +561,22 @@  -- For now, something really simple, since we're not actually going -- to use this for anything-unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)-unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })-    = (pn, HsComponentId pn (ComponentId fs))+unitDefines :: PackageState -> LHsUnit PackageName -> (PackageName, HsComponentId)+unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })+    = (pn, HsComponentId pn (mkComponentId pkgstate fs)) -packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId-packageNameMap units = Map.fromList (map unitDefines units)+packageNameMap :: PackageState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId+packageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units) -renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]-renameHsUnits dflags m units = map (fmap renameHsUnit) units+renameHsUnits :: PackageState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]+renameHsUnits pkgstate m units = map (fmap renameHsUnit) units   where      renamePackageName :: PackageName -> HsComponentId     renamePackageName pn =         case Map.lookup pn m of             Nothing ->-                case lookupPackageName dflags pn of+                case lookupPackageName pkgstate pn of                     Nothing -> error "no package name"                     Just cid -> HsComponentId pn cid             Just hscid -> hscid@@ -824,7 +825,7 @@ -- | Create a new, externally provided hashed unit id from -- a hash. newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId-newInstalledUnitId (ComponentId cid_fs) (Just fs)+newInstalledUnitId (ComponentId cid_fs _) (Just fs)     = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)-newInstalledUnitId (ComponentId cid_fs) Nothing+newInstalledUnitId (ComponentId cid_fs _) Nothing     = InstalledUnitId cid_fs
compiler/GHC/Driver/CodeOutput.hs view
@@ -6,7 +6,12 @@  {-# LANGUAGE CPP #-} -module GHC.Driver.CodeOutput ( codeOutput, outputForeignStubs ) where+module GHC.Driver.CodeOutput+   ( codeOutput+   , outputForeignStubs+   , profilingInitCode+   )+where  #include "HsVersions.h" @@ -15,13 +20,14 @@ import GHC.CmmToAsm     ( nativeCodeGen ) import GHC.CmmToLlvm    ( llvmCodeGen ) -import UniqSupply       ( mkSplitUniqSupply )+import GHC.Types.Unique.Supply ( mkSplitUniqSupply )  import GHC.Driver.Finder    ( mkStubPaths ) import GHC.CmmToC           ( writeC ) import GHC.Cmm.Lint         ( cmmLint ) import GHC.Driver.Packages import GHC.Cmm              ( RawCmmGroup )+import GHC.Cmm.CLabel import GHC.Driver.Types import GHC.Driver.Session import Stream           ( Stream )@@ -30,8 +36,9 @@  import ErrUtils import Outputable-import Module-import SrcLoc+import GHC.Types.Module+import GHC.Types.SrcLoc+import GHC.Types.CostCentre  import Control.Exception import System.Directory@@ -262,3 +269,51 @@ outputForeignStubs_help fname doc_str header footer    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")         return True++-- -----------------------------------------------------------------------------+-- Initialising cost centres++-- We must produce declarations for the cost-centres defined in this+-- module;++-- | Generate code to initialise cost centres+profilingInitCode :: Module -> CollectedCCs -> SDoc+profilingInitCode this_mod (local_CCs, singleton_CCSs)+ = sdocWithDynFlags $ \dflags ->+   if not (gopt Opt_SccProfilingOn dflags)+   then empty+   else vcat+    $  map emit_cc_decl local_CCs+    ++ map emit_ccs_decl singleton_CCSs+    ++ [emit_cc_list local_CCs]+    ++ [emit_ccs_list singleton_CCSs]+    ++ [ text "static void prof_init_" <> ppr this_mod+            <> text "(void) __attribute__((constructor));"+       , text "static void prof_init_" <> ppr this_mod <> text "(void)"+       , braces (vcat+                 [ text "registerCcList" <> parens local_cc_list_label <> semi+                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi+                 ])+       ]+ where+   emit_cc_decl cc =+       text "extern CostCentre" <+> cc_lbl <> text "[];"+     where cc_lbl = ppr (mkCCLabel cc)+   local_cc_list_label = text "local_cc_" <> ppr this_mod+   emit_cc_list ccs =+      text "static CostCentre *" <> local_cc_list_label <> text "[] ="+      <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma+                         | cc <- ccs+                         ] ++ [text "NULL"])+      <> semi++   emit_ccs_decl ccs =+       text "extern CostCentreStack" <+> ccs_lbl <> text "[];"+     where ccs_lbl = ppr (mkCCSLabel ccs)+   singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod+   emit_ccs_list ccs =+      text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="+      <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma+                         | cc <- ccs+                         ] ++ [text "NULL"])+      <> semi
compiler/GHC/Driver/Finder.hs view
@@ -35,7 +35,7 @@  import GhcPrelude -import Module+import GHC.Types.Module import GHC.Driver.Types import GHC.Driver.Packages import FastString@@ -340,8 +340,9 @@   let         dflags = hsc_dflags hsc_env         pkg_id = installedModuleUnitId mod+        pkgstate = pkgState dflags   ---  case lookupInstalledPackage dflags pkg_id of+  case lookupInstalledPackage pkgstate pkg_id of      Nothing -> return (InstalledNoPackage pkg_id)      Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf @@ -805,12 +806,13 @@             _ -> panic "cantFindInstalledErr"      build_tag = buildTag dflags+    pkgstate = pkgState dflags      looks_like_srcpkgid :: InstalledUnitId -> SDoc     looks_like_srcpkgid pk      -- Unsafely coerce a unit id FastString into a source package ID      -- FastString and see if it means anything.-     | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk))+     | (pkg:pkgs) <- searchPackageId pkgstate (SourcePackageId (installedUnitIdFS pk))      = parens (text "This unit ID looks like the source package ID;" $$        text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$        (if null pkgs then Outputable.empty
compiler/GHC/Driver/Main.hs view
@@ -88,39 +88,40 @@  import Data.Data hiding (Fixity, TyCon) import Data.Maybe       ( fromJust )-import Id+import GHC.Types.Id import GHC.Runtime.Interpreter ( addSptEntry ) import GHCi.RemoteTypes        ( ForeignHValue ) import GHC.CoreToByteCode      ( byteCodeGen, coreExprToBCOs ) import GHC.Runtime.Linker import GHC.Core.Op.Tidy        ( tidyExpr )-import Type                    ( Type, Kind )+import GHC.Core.Type           ( Type, Kind ) import GHC.Core.Lint           ( lintInteractiveExpr )-import VarEnv                  ( emptyTidyEnv )+import GHC.Types.Var.Env       ( emptyTidyEnv ) import Panic-import ConLike+import GHC.Core.ConLike  import ApiAnnotation-import Module+import GHC.Types.Module import GHC.Driver.Packages-import RdrName+import GHC.Types.Name.Reader import GHC.Hs import GHC.Hs.Dump import GHC.Core import StringBuffer import Parser import Lexer-import SrcLoc+import GHC.Types.SrcLoc import TcRnDriver import GHC.IfaceToCore  ( typecheckIface ) import TcRnMonad import TcHsSyn          ( ZonkFlexi (DefaultFlexi) )-import NameCache        ( initNameCache )-import GHC.Iface.Load   ( ifaceStats, initExternalPackageState )+import GHC.Types.Name.Cache ( initNameCache ) import PrelInfo-import GHC.Iface.Utils+import GHC.Core.Op.Simplify.Driver import GHC.HsToCore-import SimplCore+import GHC.Iface.Load   ( ifaceStats, initExternalPackageState, writeIface )+import GHC.Iface.Make+import GHC.Iface.Recomp import GHC.Iface.Tidy import GHC.CoreToStg.Prep import GHC.CoreToStg    ( coreToStg )@@ -128,19 +129,18 @@ import GHC.Stg.FVs      ( annTopBindingsFreeVars ) import GHC.Stg.Pipeline ( stg2stg ) import qualified GHC.StgToCmm as StgToCmm ( codeGen )-import CostCentre-import ProfInit-import TyCon-import Name-import NameSet+import GHC.Types.CostCentre+import GHC.Core.TyCon+import GHC.Types.Name+import GHC.Types.Name.Set import GHC.Cmm import GHC.Cmm.Parser         ( parseCmmFile ) import GHC.Cmm.Info.Build import GHC.Cmm.Pipeline import GHC.Cmm.Info import GHC.Driver.CodeOutput-import InstEnv-import FamInstEnv+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv import Fingerprint      ( Fingerprint ) import GHC.Driver.Hooks import TcEnv@@ -152,11 +152,11 @@ import ErrUtils  import Outputable-import NameEnv+import GHC.Types.Name.Env import HscStats         ( ppSourceStats ) import GHC.Driver.Types import FastString-import UniqSupply+import GHC.Types.Unique.Supply import Bag import Exception import qualified Stream@@ -1227,7 +1227,7 @@     dflags <- getDynFlags     let errors = S.foldr go [] pkgs         go pkg acc-            | trusted $ getInstalledPackageDetails dflags pkg+            | trusted $ getInstalledPackageDetails (pkgState dflags) pkg             = acc             | otherwise             = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)@@ -1370,7 +1370,7 @@     unless no_change $         let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags)         in  {-# SCC "writeIface" #-}-            writeIfaceFile dflags ifaceFile iface+            writeIface dflags ifaceFile iface     whenGeneratingDynamicToo dflags $ do         -- TODO: We should do a no_change check for the dynamic         --       interface file too@@ -1379,7 +1379,7 @@             -- dynDflags will have set hiSuf correctly.             dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags) -        writeIfaceFile dynDflags dynIfaceFile iface+        writeIface dynDflags dynIfaceFile iface   where     buildIfName :: String -> String -> String     buildIfName baseName suffix
compiler/GHC/Driver/Make.hs view
@@ -45,31 +45,31 @@ import GHC.Driver.Monad import HeaderInfo import GHC.Driver.Types-import Module+import GHC.Types.Module import GHC.IfaceToCore  ( typecheckIface ) import TcRnMonad        ( initIfaceCheck ) import GHC.Driver.Main  import Bag              ( unitBag, listToBag, unionManyBags, isEmptyBag )-import BasicTypes+import GHC.Types.Basic import Digraph import Exception        ( tryIO, gbracket, gfinally ) import FastString import Maybes           ( expectJust )-import Name+import GHC.Types.Name import MonadUtils       ( allM ) import Outputable import Panic-import SrcLoc+import GHC.Types.SrcLoc import StringBuffer-import UniqFM-import UniqDSet+import GHC.Types.Unique.FM+import GHC.Types.Unique.DSet import TcBackpack import GHC.Driver.Packages-import UniqSet+import GHC.Types.Unique.Set import Util import qualified GHC.LanguageExtensions as LangExt-import NameEnv+import GHC.Types.Name.Env import FileCleanup  import Data.Either ( rights, partitionEithers )
compiler/GHC/Driver/MakeFile.hs view
@@ -20,15 +20,16 @@ import qualified GHC import GHC.Driver.Monad import GHC.Driver.Session+import GHC.Driver.Ways import Util import GHC.Driver.Types import qualified SysTools-import Module+import GHC.Types.Module import Digraph          ( SCC(..) ) import GHC.Driver.Finder import Outputable import Panic-import SrcLoc+import GHC.Types.SrcLoc import Data.List import FastString import FileCleanup@@ -43,6 +44,7 @@ import Control.Monad    ( when ) import Data.Maybe       ( isJust ) import Data.IORef+import qualified Data.Set as Set  ----------------------------------------------------------------- --@@ -62,8 +64,8 @@     -- way and .o/.hi extensions, regardless of any flags that might     -- be specified.     let dflags = dflags0 {-                     ways = [],-                     buildTag = mkBuildTag [],+                     ways = Set.empty,+                     buildTag = waysTag Set.empty,                      hiSuf = "hi",                      objectSuf = "o"                  }
compiler/GHC/Driver/Pipeline.hs view
@@ -40,6 +40,7 @@  import GHC.Driver.Pipeline.Monad import GHC.Driver.Packages+import GHC.Driver.Ways import HeaderInfo import GHC.Driver.Phases import SysTools@@ -48,15 +49,15 @@ import GHC.Driver.Finder import GHC.Driver.Types hiding ( Hsc ) import Outputable-import Module+import GHC.Types.Module import ErrUtils import GHC.Driver.Session import Panic import Util import StringBuffer     ( hGetStringBuffer, hPutStringBuffer )-import BasicTypes       ( SuccessFlag(..) )+import GHC.Types.Basic  ( SuccessFlag(..) ) import Maybes           ( expectJust )-import SrcLoc+import GHC.Types.SrcLoc import GHC.CmmToLlvm    ( llvmFixupAsm, llvmVersionList ) import MonadUtils import GHC.Platform@@ -68,7 +69,7 @@ import Ar import Bag              ( unitBag ) import FastString       ( mkFastString )-import GHC.Iface.Utils  ( mkFullIface )+import GHC.Iface.Make   ( mkFullIface ) import UpdateCafInfos   ( updateModDetailsCafInfos )  import Exception@@ -288,7 +289,7 @@        -- #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 dynamicGhc && internalInterpreter &&+       dflags1 = if hostIsDynamic && internalInterpreter &&                     not isDynWay && not isProfWay && needsLinker                   then gopt_set dflags0 Opt_BuildDynamicToo                   else dflags0@@ -510,8 +511,9 @@          -- next, check libraries. XXX this only checks Haskell libraries,         -- not extra_libraries or -l things from the command line.+        let pkgstate = pkgState dflags         let pkg_hslibs  = [ (collectLibraryPaths dflags [c], lib)-                          | Just c <- map (lookupInstalledPackage dflags) pkg_deps,+                          | Just c <- map (lookupInstalledPackage pkgstate) pkg_deps,                             lib <- packageHsLibs dflags c ]          pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs@@ -650,7 +652,7 @@          -- We want to catch cases of "you can't get there from here" before          -- we start the pipeline, because otherwise it will just run off the          -- end.-         let happensBefore' = happensBefore dflags+         let happensBefore' = happensBefore (targetPlatform dflags)          case start_phase of              RealPhase start_phase' ->                  -- See Note [Partial ordering on phases]@@ -722,7 +724,7 @@   env <- getPipeEnv   dflags <- getDynFlags   -- See Note [Partial ordering on phases]-  let happensBefore' = happensBefore dflags+  let happensBefore' = happensBefore (targetPlatform dflags)       stopPhase = stop_phase env   case phase of    RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done@@ -1196,7 +1198,7 @@                      final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just caf_infos))                     let final_mod_details = {-# SCC updateModDetailsCafInfos #-}-                                            updateModDetailsCafInfos caf_infos mod_details+                                            updateModDetailsCafInfos iface_dflags caf_infos mod_details                     setIface final_iface final_mod_details                      -- See Note [Writing interface files]@@ -2139,7 +2141,7 @@                        SysTools.Option "-nostdlib",                        SysTools.Option "-Wl,-r"                      ]-                        -- See Note [No PIE while linking] in DynFlags+                        -- See Note [No PIE while linking] in GHC.Driver.Session                      ++ (if toolSettings_ccSupportsNoPie toolSettings'                           then [SysTools.Option "-no-pie"]                           else [])
compiler/GHC/HsToCore.hs view
@@ -27,12 +27,12 @@ import TcRnTypes import TcRnMonad  ( finalSafeMode, fixSafeInstances ) import TcRnDriver ( runTcInteractive )-import Id-import IdInfo-import Name-import Type-import TyCon       ( tyConDataCons )-import Avail+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name+import GHC.Core.Type+import GHC.Core.TyCon     ( tyConDataCons )+import GHC.Types.Avail import GHC.Core import GHC.Core.FVs       ( exprsSomeFreeVarsList ) import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr )@@ -45,22 +45,22 @@ import GHC.HsToCore.Foreign.Decl import PrelNames import TysPrim-import Coercion+import GHC.Core.Coercion import TysWiredIn-import DataCon     ( dataConWrapId )+import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make-import Module-import NameSet-import NameEnv+import GHC.Types.Module+import GHC.Types.Name.Set+import GHC.Types.Name.Env import GHC.Core.Rules-import BasicTypes-import CoreMonad        ( CoreToDo(..) )-import GHC.Core.Lint    ( endPassIO )-import VarSet+import GHC.Types.Basic+import GHC.Core.Op.Monad ( CoreToDo(..) )+import GHC.Core.Lint     ( endPassIO )+import GHC.Types.Var.Set import FastString import ErrUtils import Outputable-import SrcLoc+import GHC.Types.SrcLoc import GHC.HsToCore.Coverage import Util import MonadUtils@@ -560,7 +560,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We sometimes need to have access to defined Ids in pure contexts. Usually, we simply "wire in" these entities, as we do for types in TysWiredIn and for Ids-in MkId. See Note [Wired-in Ids] in MkId.+in GHC.Types.Id.Make. See Note [Wired-in Ids] in GHC.Types.Id.Make.  However, it is sometimes *much* easier to define entities in Haskell, even if we need pure access; note that wiring-in an Id requires all@@ -639,18 +639,7 @@ simply look up the UnsafeEquality GADT in the environment, leaving us only to wire in unsafeCoerce# directly. -Wrinkle:----------We must make absolutely sure that unsafeCoerce# is inlined. You might-think that giving it a compulsory unfolding is enough. However,-unsafeCoerce# is put in an interface file like any other definition.-At optimization level 0, we enable -fignore-interface-pragmas, which-ignores pragmas in interface files. We thus must check to see whether-there is a compulsory unfolding, even with -fignore-interface-pragmas.-This is done in TcIface.tcIdInfo.--Test case: ghci/linker/dyn/T3372-+Wrinkle: see Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy -}
compiler/GHC/HsToCore/Arrows.hs view
@@ -37,7 +37,7 @@                                           dsSyntaxExpr )  import TcType-import Type ( splitPiTy )+import GHC.Core.Type( splitPiTy ) import TcEvidence import GHC.Core import GHC.Core.FVs@@ -45,18 +45,18 @@ import GHC.Core.Make import GHC.HsToCore.Binds (dsHsWrapper) -import Id-import ConLike+import GHC.Types.Id+import GHC.Core.ConLike import TysWiredIn-import BasicTypes+import GHC.Types.Basic import PrelNames import Outputable-import VarSet-import SrcLoc+import GHC.Types.Var.Set+import GHC.Types.SrcLoc import ListSetOps( assocMaybe ) import Data.List import Util-import UniqDSet+import GHC.Types.Unique.DSet  data DsCmdEnv = DsCmdEnv {         arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr@@ -1248,7 +1248,7 @@     go (CoPat _ _ pat _)          = collectl (noLoc pat) bndrs     go (ViewPat _ _ pat)          = collectl pat bndrs     go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)-    go p@(XPat {})                = pprPanic "collectl/go" (ppr p)+    go (XPat nec)                 = noExtCon nec  collectEvBinders :: TcEvBinds -> [Id] collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs
compiler/GHC/HsToCore/Binds.hs view
@@ -37,41 +37,41 @@  import GHC.Hs             -- lots of things import GHC.Core           -- lots of things-import GHC.Core.SimpleOpt ( simpleOptExpr )-import OccurAnal          ( occurAnalyseExpr )+import GHC.Core.SimpleOpt    ( simpleOptExpr )+import GHC.Core.Op.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Make import GHC.Core.Utils import GHC.Core.Arity     ( etaExpand ) import GHC.Core.Unfold import GHC.Core.FVs import Digraph-import Predicate+import GHC.Core.Predicate  import PrelNames-import TyCon+import GHC.Core.TyCon import TcEvidence import TcType-import Type-import Coercion+import GHC.Core.Type+import GHC.Core.Coercion import TysWiredIn ( typeNatKind, typeSymbolKind )-import Id-import MkId(proxyHashId)-import Name-import VarSet+import GHC.Types.Id+import GHC.Types.Id.Make(proxyHashId)+import GHC.Types.Name+import GHC.Types.Var.Set import GHC.Core.Rules-import VarEnv-import Var( EvVar )+import GHC.Types.Var.Env+import GHC.Types.Var( EvVar ) import Outputable-import Module-import SrcLoc+import GHC.Types.Module+import GHC.Types.SrcLoc import Maybes import OrdList import Bag-import BasicTypes+import GHC.Types.Basic import GHC.Driver.Session import FastString import Util-import UniqSet( nonDetEltsUniqSet )+import GHC.Types.Unique.Set( nonDetEltsUniqSet ) import MonadUtils import qualified GHC.LanguageExtensions as LangExt import Control.Monad@@ -135,14 +135,11 @@          -- bindings and their desugared right hand sides.  dsHsBind dflags (VarBind { var_id = var-                         , var_rhs = expr-                         , var_inline = inline_regardless })+                         , var_rhs = expr })   = do  { core_expr <- dsLExpr expr                 -- Dictionary bindings are always VarBinds,                 -- so we only need do this here-        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr-                   | otherwise         = var-        ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr+        ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr               force_var = if xopt LangExt.Strict dflags                           then [id]                           else []
compiler/GHC/HsToCore/Coverage.hs view
@@ -19,28 +19,28 @@ import Data.Array import GHC.ByteCode.Types import GHC.Stack.CCS-import Type+import GHC.Core.Type import GHC.Hs-import Module+import GHC.Types.Module as Module import Outputable import GHC.Driver.Session-import ConLike+import GHC.Core.ConLike import Control.Monad-import SrcLoc+import GHC.Types.SrcLoc import ErrUtils-import NameSet hiding (FreeVars)-import Name+import GHC.Types.Name.Set hiding (FreeVars)+import GHC.Types.Name import Bag-import CostCentre-import CostCentreState+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State import GHC.Core-import Id-import VarSet+import GHC.Types.Id+import GHC.Types.Var.Set import Data.List import FastString import GHC.Driver.Types-import TyCon-import BasicTypes+import GHC.Core.TyCon+import GHC.Types.Basic import MonadUtils import Maybes import GHC.Cmm.CLabel@@ -157,13 +157,13 @@   :: HscEnv -> Module -> Int -> [MixEntry_]   -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre)) mkCCSArray hsc_env modul count entries = do-  if interpreterProfiled dflags-    then do+  case hsc_interp hsc_env of+    Just interp | GHCi.interpreterProfiled interp -> do       let module_str = moduleNameString (moduleName modul)       costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)       return (listArray (0,count-1) costcentres)-    else do-      return (listArray (0,-1) [])++    _ -> return (listArray (0,-1) [])  where     dflags = hsc_dflags hsc_env     mk_one (srcspan, decl_path, _, _) = (name, src)
compiler/GHC/HsToCore/Docs.hs view
@@ -16,9 +16,9 @@ import GHC.Hs.Extension import GHC.Hs.Types import GHC.Hs.Utils-import Name-import NameSet-import SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.SrcLoc import TcRnTypes  import Control.Applicative
compiler/GHC/HsToCore/Expr.hs view
@@ -33,9 +33,9 @@ import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.PmCheck ( checkGuardMatches )-import Name-import NameEnv-import FamInstEnv( topNormaliseType )+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.HsToCore.Quote import GHC.Hs @@ -44,29 +44,29 @@ import TcType import TcEvidence import TcRnMonad-import Type+import GHC.Core.Type import GHC.Core import GHC.Core.Utils import GHC.Core.Make  import GHC.Driver.Session-import CostCentre-import Id-import MkId-import Module-import ConLike-import DataCon-import TyCoPpr( pprWithTYPE )+import GHC.Types.CostCentre+import GHC.Types.Id+import GHC.Types.Id.Make+import GHC.Types.Module+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.TyCo.Ppr( pprWithTYPE ) import TysWiredIn import PrelNames-import BasicTypes+import GHC.Types.Basic import Maybes-import VarEnv-import SrcLoc+import GHC.Types.Var.Env+import GHC.Types.SrcLoc import Util import Bag import Outputable-import PatSyn+import GHC.Core.PatSyn  import Control.Monad import Data.List.NonEmpty ( nonEmpty )@@ -488,6 +488,7 @@     makeStaticId <- dsLookupGlobalId makeStaticName      dflags <- getDynFlags+    let platform = targetPlatform dflags     let (line, col) = case loc of            RealSrcSpan r _ ->                             ( srcLocLine $ realSrcSpanStart r@@ -496,7 +497,7 @@            _             -> (0, 0)         srcLoc = mkCoreConApps (tupleDataCon Boxed 2)                      [ Type intTy              , Type intTy-                     , mkIntExprInt dflags line, mkIntExprInt dflags col+                     , mkIntExprInt platform line, mkIntExprInt platform col                      ]      putSrcSpanDs loc $ return $@@ -673,7 +674,7 @@                           -- Be sure to use user_tvs (which may be ordered                           -- differently than `univ_tvs ++ ex_tvs) above.                           -- See Note [DataCon user type variable binders]-                          -- in DataCon.+                          -- in GHC.Core.DataCon.                  rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args                          -- Tediously wrap the application in a cast@@ -890,7 +891,8 @@ dsExplicitList elt_ty (Just fln) xs   = do { list <- dsExplicitList elt_ty Nothing xs        ; dflags <- getDynFlags-       ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }+       ; let platform = targetPlatform dflags+       ; dsSyntaxExpr fln [mkIntExprInt platform (length xs), list] }  dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr dsArithSeq expr (From from)@@ -1044,10 +1046,13 @@  dsHsVar :: Id -> DsM CoreExpr dsHsVar var-               -- See Wrinkle in Note [Detecting forced eta expansion]-  = ASSERT2(null (badUseOfLevPolyPrimop var ty), ppr var $$ ppr ty)-    return (varToCoreExpr var)   -- See Note [Desugaring vars]+  | let bad_tys = badUseOfLevPolyPrimop var ty+  , not (null bad_tys)+  = do { levPolyPrimopErr (ppr var) ty bad_tys+       ; return unitExpr }  -- return something eminently safe +  | otherwise+  = return (varToCoreExpr var)   -- See Note [Desugaring vars]   where     ty = idType var @@ -1134,6 +1139,8 @@ With that representation invariant, we simply look inside every HsWrap to see if its body is an HsVar whose Id hasNoBinding. Then, we look at the wrapped type. If it has any levity polymorphic arguments, reject.+Because we might have an HsVar without a wrapper, we check in dsHsVar+as well. typecheck/should_fail/T17021 triggers this case.  Interestingly, this approach does not look to see whether the Id in question will be eta expanded. The logic is this:@@ -1144,20 +1151,6 @@     argument. If its wrapped type contains levity polymorphic arguments, reject. So, either way, we're good to reject. -Wrinkle-~~~~~~~-Currently, all levity-polymorphic Ids are wrapped in HsWrap.--However, this is not set in stone, in the future we might make-instantiation more lazy.  (See "Visible type application", ESOP '16.)-If we spot a levity-polymorphic hasNoBinding Id without a wrapper,-then that is surely a problem. In this case, we raise an assertion failure.-This failure can be changed to a call to `levPolyPrimopErr` in the future,-if we decide to change instantiation.--We can just check HsVar and HsConLikeOut for RealDataCon, since-we don't have levity-polymorphic pattern synonyms. (This might change-in the future.) -}  -- | Takes an expression and its instantiated type. If the expression is an
compiler/GHC/HsToCore/Foreign/Call.hs view
@@ -23,27 +23,28 @@   import GhcPrelude+import GHC.Platform  import GHC.Core  import GHC.HsToCore.Monad import GHC.Core.Utils import GHC.Core.Make-import MkId-import ForeignCall-import DataCon+import GHC.Types.Id.Make+import GHC.Types.ForeignCall+import GHC.Core.DataCon import GHC.HsToCore.Utils  import TcType-import Type-import Id   ( Id )-import Coercion+import GHC.Core.Type+import GHC.Types.Id   ( Id )+import GHC.Core.Coercion import PrimOp import TysPrim-import TyCon+import GHC.Core.TyCon import TysWiredIn-import BasicTypes-import Literal+import GHC.Types.Basic+import GHC.Types.Literal import PrelNames import GHC.Driver.Session import Outputable@@ -152,9 +153,10 @@   | Just tc <- tyConAppTyCon_maybe arg_ty,     tc `hasKey` boolTyConKey   = do dflags <- getDynFlags+       let platform = targetPlatform dflags        prim_arg <- newSysLocalDs intPrimTy        return (Var prim_arg,-              \ body -> Case (mkIfThenElse arg (mkIntLit dflags 1) (mkIntLit dflags 0))+              \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0))                              prim_arg                              (exprType body)                              [(DEFAULT,[],body)])@@ -326,10 +328,11 @@   | Just (tc,_) <- maybe_tc_app   , tc `hasKey` boolTyConKey   = do { dflags <- getDynFlags+       ; let platform = targetPlatform dflags        ; let marshal_bool e                = mkWildCase e intPrimTy boolTy-                   [ (DEFAULT                   ,[],Var trueDataConId )-                   , (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)]+                   [ (DEFAULT                     ,[],Var trueDataConId )+                   , (LitAlt (mkLitInt platform 0),[],Var falseDataConId)]        ; return (Just intPrimTy, marshal_bool) }    -- Newtypes@@ -349,8 +352,9 @@   , Just data_con <- isDataProductTyCon_maybe tycon  -- One constructor, no existentials   , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument   = do { dflags <- getDynFlags+       ; let platform = targetPlatform dflags        ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty-       ; let narrow_wrapper = maybeNarrow dflags tycon+       ; let narrow_wrapper = maybeNarrow platform tycon              marshal_con e  = Var (dataConWrapId data_con)                               `mkTyApps` tycon_arg_tys                               `App` wrapper (narrow_wrapper e)@@ -366,15 +370,17 @@ -- standard appears to say that this is the responsibility of the -- caller, not the callee. -maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)-maybeNarrow dflags tycon+maybeNarrow :: Platform -> TyCon -> (CoreExpr -> CoreExpr)+maybeNarrow platform tycon   | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e   | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e   | tycon `hasKey` int32TyConKey-         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e+  , platformWordSizeInBytes platform > 4+  = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e    | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e   | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e   | tycon `hasKey` word32TyConKey-         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e+  , platformWordSizeInBytes platform > 4+  = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e   | otherwise                     = id
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -26,28 +26,28 @@ import GHC.HsToCore.Monad  import GHC.Hs-import DataCon+import GHC.Core.DataCon import GHC.Core.Unfold-import Id-import Literal-import Module-import Name-import Type+import GHC.Types.Id+import GHC.Types.Literal+import GHC.Types.Module+import GHC.Types.Name+import GHC.Core.Type import GHC.Types.RepType-import TyCon-import Coercion+import GHC.Core.TyCon+import GHC.Core.Coercion import TcEnv import TcType  import GHC.Cmm.Expr import GHC.Cmm.Utils import GHC.Driver.Types-import ForeignCall+import GHC.Types.ForeignCall import TysWiredIn import TysPrim import PrelNames-import BasicTypes-import SrcLoc+import GHC.Types.Basic+import GHC.Types.SrcLoc import Outputable import FastString import GHC.Driver.Session@@ -158,6 +158,7 @@ dsCImport id co (CLabel cid) cconv _ _ = do    dflags <- getDynFlags    let ty  = coercionLKind co+       platform = targetPlatform dflags        fod = case tyConAppTyCon_maybe (dropForAlls ty) of              Just tycon               | tyConUnique tycon == funPtrTyConKey ->@@ -168,7 +169,7 @@     let         rhs = foRhs (Lit (LitLabel cid stdcall_info fod))         rhs' = Cast rhs co-        stdcall_info = fun_type_arg_stdcall_info dflags cconv ty+        stdcall_info = fun_type_arg_stdcall_info platform cconv ty     in     return ([(id, rhs')], empty, empty) @@ -182,14 +183,14 @@ -- For stdcall labels, if the type was a FunPtr or newtype thereof, -- then we need to calculate the size of the arguments in order to add -- the @n suffix to the label.-fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int-fun_type_arg_stdcall_info dflags StdCallConv ty+fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int+fun_type_arg_stdcall_info platform StdCallConv ty   | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,     tyConUnique tc == funPtrTyConKey   = let        (bndrs, _) = tcSplitPiTys arg_ty        fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs-    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)+    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys) fun_type_arg_stdcall_info _ _other_conv _   = Nothing @@ -422,6 +423,7 @@ dsFExportDynamic id co0 cconv = do     mod <- getModule     dflags <- getDynFlags+    let platform = targetPlatform dflags     let fe_nm = mkFastString $ zEncodeString             (moduleStableString mod ++ "$" ++ toCName dflags id)         -- Construct the label based on the passed id, don't use names@@ -443,7 +445,7 @@           to be entered using an external calling convention           (stdcall, ccall).          -}-        adj_args      = [ mkIntLitInt dflags (ccallConvToInt cconv)+        adj_args      = [ mkIntLitInt platform (ccallConvToInt cconv)                         , Var stbl_value                         , Lit (LitLabel fe_nm mb_sz_args IsFunction)                         , Lit (mkLitString typestring)@@ -524,6 +526,8 @@          -- use that instead.  I hope the two coincide --SDM     )  where+  platform = targetPlatform dflags+   -- list the arguments to the C function   arg_info :: [(SDoc,           -- arg name                 SDoc,           -- C type@@ -533,7 +537,7 @@                 (arg_cname n stg_type,                  stg_type,                  ty,-                 typeCmmType dflags (getPrimTyOf ty))+                 typeCmmType platform (getPrimTyOf ty))               | (ty,n) <- zip arg_htys [1::Int ..] ]    arg_cname n stg_ty@@ -546,21 +550,21 @@    type_string       -- libffi needs to know the result type too:-      | libffi    = primTyDescChar dflags res_hty : arg_type_string+      | libffi    = primTyDescChar platform res_hty : arg_type_string       | otherwise = arg_type_string -  arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]+  arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info]                 -- just the real args    -- add some auxiliary args; the stable ptr in the wrapper case, and   -- a slot for the dummy return address in the wrapper + ccall case   aug_arg_info-    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info+    | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info     | otherwise              = arg_info    stable_ptr_arg =         (text "the_stableptr", text "StgStablePtr", undefined,-         typeCmmType dflags (mkStablePtrPrimTy alphaTy))+         typeCmmType platform (mkStablePtrPrimTy alphaTy))    -- stuff to do with the return type of the C function   res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes@@ -741,10 +745,10 @@   | otherwise   = pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty) -insertRetAddr :: DynFlags -> CCallConv+insertRetAddr :: Platform -> CCallConv               -> [(SDoc, SDoc, Type, CmmType)]               -> [(SDoc, SDoc, Type, CmmType)]-insertRetAddr dflags CCallConv args+insertRetAddr platform CCallConv args     = case platformArch platform of       ArchX86_64        | platformOS platform == OSMinGW32 ->@@ -754,7 +758,7 @@           -- (See rts/Adjustor.c for details).           let go :: Int -> [(SDoc, SDoc, Type, CmmType)]                         -> [(SDoc, SDoc, Type, CmmType)]-              go 4 args = ret_addr_arg dflags : args+              go 4 args = ret_addr_arg platform : args               go n (arg:args) = arg : go (n+1) args               go _ [] = []           in go 0 args@@ -765,20 +769,19 @@           -- (See rts/Adjustor.c for details).           let go :: Int -> [(SDoc, SDoc, Type, CmmType)]                         -> [(SDoc, SDoc, Type, CmmType)]-              go 6 args = ret_addr_arg dflags : args+              go 6 args = ret_addr_arg platform : args               go n (arg@(_,_,_,rep):args)                | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args                | otherwise  = arg : go n     args               go _ [] = []           in go 0 args       _ ->-          ret_addr_arg dflags : args-    where platform = targetPlatform dflags+          ret_addr_arg platform : args insertRetAddr _ _ args = args -ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)-ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,-                       typeCmmType dflags addrPrimTy)+ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)+ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,+                         typeCmmType platform addrPrimTy)  -- This function returns the primitive type associated with the boxed -- type argument to a foreign export (eg. Int ==> Int#).@@ -800,8 +803,8 @@ -- represent a primitive type as a Char, for building a string that -- described the foreign function type.  The types are size-dependent, -- e.g. 'W' is a signed 32-bit integer.-primTyDescChar :: DynFlags -> Type -> Char-primTyDescChar dflags ty+primTyDescChar :: Platform -> Type -> Char+primTyDescChar platform ty  | ty `eqType` unitTy = 'v'  | otherwise  = case typePrimRep1 (getPrimTyOf ty) of@@ -814,7 +817,6 @@      DoubleRep   -> 'd'      _           -> pprPanic "primTyDescChar" (ppr ty)   where-    (signed_word, unsigned_word)-       | wORD_SIZE dflags == 4  = ('W','w')-       | wORD_SIZE dflags == 8  = ('L','l')-       | otherwise              = panic "primTyDescChar"+    (signed_word, unsigned_word) = case platformWordSize platform of+      PW4 -> ('W','w')+      PW8 -> ('L','l')
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -26,9 +26,9 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Utils import GHC.HsToCore.PmCheck.Types ( Deltas, initDeltas )-import Type   ( Type )+import GHC.Core.Type ( Type ) import Util-import SrcLoc+import GHC.Types.SrcLoc import Outputable import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList )
compiler/GHC/HsToCore/ListComp.hs view
@@ -28,12 +28,12 @@  import GHC.Driver.Session import GHC.Core.Utils-import Id-import Type+import GHC.Types.Id+import GHC.Core.Type import TysWiredIn import GHC.HsToCore.Match import PrelNames-import SrcLoc+import GHC.Types.SrcLoc import Outputable import TcType import ListSetOps( getNth )@@ -638,7 +638,7 @@                  -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op   = dsMcStmts (stmts ++-                 [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) False ret_op)])+                 [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) Nothing ret_op)])   -- The `unzip` function for `GroupStmt` in a monad comprehensions
compiler/GHC/HsToCore/Match.hs view
@@ -24,10 +24,11 @@ #include "HsVersions.h"  import GhcPrelude+import GHC.Platform  import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) -import BasicTypes ( Origin(..) )+import GHC.Types.Basic ( Origin(..) ) import GHC.Driver.Session import GHC.Hs import TcHsSyn@@ -35,32 +36,32 @@ import TcRnMonad import GHC.HsToCore.PmCheck import GHC.Core-import Literal+import GHC.Types.Literal import GHC.Core.Utils import GHC.Core.Make import GHC.HsToCore.Monad import GHC.HsToCore.Binds import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils-import Id-import ConLike-import DataCon-import PatSyn+import GHC.Types.Id+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.PatSyn import GHC.HsToCore.Match.Constructor import GHC.HsToCore.Match.Literal-import Type-import Coercion ( eqCoercion )-import TyCon( isNewTyCon )+import GHC.Core.Type+import GHC.Core.Coercion ( eqCoercion )+import GHC.Core.TyCon    ( isNewTyCon ) import TysWiredIn-import SrcLoc+import GHC.Types.SrcLoc import Maybes import Util-import Name+import GHC.Types.Name import Outputable-import BasicTypes ( isGenerated, il_value, fl_value )+import GHC.Types.Basic ( isGenerated, il_value, fl_value ) import FastString-import Unique-import UniqDFM+import GHC.Types.Unique+import GHC.Types.Unique.DFM  import Control.Monad( unless ) import Data.List.NonEmpty (NonEmpty(..))@@ -186,11 +187,12 @@ match (v:vs) ty eqns    -- Eqns *can* be empty   = ASSERT2( all (isInternalName . idName) vars, ppr vars )     do  { dflags <- getDynFlags+        ; let platform = targetPlatform dflags                 -- Tidy the first pattern, generating                 -- auxiliary bindings if necessary         ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns                 -- Group the equations and match each group in turn-        ; let grouped = groupEquations dflags tidy_eqns+        ; let grouped = groupEquations platform tidy_eqns           -- print the view patterns that are commoned up to help debug         ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)@@ -337,7 +339,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 Simplify.+See also Note [Case elimination: lifted case] in GHC.Core.Op.Simplify.   ************************************************************************@@ -910,13 +912,13 @@ for overloaded strings. -} -groupEquations :: DynFlags -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]+groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] -- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg -- (b) none of the gi are empty -- The ordering of equations is unchanged-groupEquations dflags eqns-  = NEL.groupBy same_gp $ [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]+groupEquations platform eqns+  = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]   -- comprehension on NonEmpty   where     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool@@ -1117,7 +1119,7 @@     eq_list _  (_:_)  []     = False     eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys -patGroup :: DynFlags -> Pat GhcTc -> PatGroup+patGroup :: Platform -> Pat GhcTc -> PatGroup patGroup _ (ConPatOut { pat_con = L _ con                       , pat_arg_tys = tys })  | RealDataCon dcon <- con              = PgCon dcon@@ -1140,7 +1142,7 @@                                                     -- Type of innelexp pattern patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p)) patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList-patGroup dflags (LitPat _ lit)          = PgLit (hsLitKey dflags lit)+patGroup platform (LitPat _ lit)        = PgLit (hsLitKey platform lit) patGroup _ pat                          = pprPanic "patGroup" (ppr pat)  {-
compiler/GHC/HsToCore/Match.hs-boot view
@@ -1,10 +1,10 @@ module GHC.HsToCore.Match where  import GhcPrelude-import Var      ( Id )+import GHC.Types.Var ( Id ) import TcType   ( Type )-import GHC.HsToCore.Monad  ( DsM, EquationInfo, MatchResult )-import GHC.Core  ( CoreExpr )+import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult )+import GHC.Core ( CoreExpr ) import GHC.Hs   ( LPat, HsMatchContext, MatchGroup, LHsExpr ) import GHC.Hs.Extension ( GhcRn, GhcTc )
compiler/GHC/HsToCore/Match/Constructor.hs view
@@ -22,17 +22,17 @@  import GHC.Hs import GHC.HsToCore.Binds-import ConLike-import BasicTypes ( Origin(..) )+import GHC.Core.ConLike+import GHC.Types.Basic ( Origin(..) ) import TcType import GHC.HsToCore.Monad import GHC.HsToCore.Utils import GHC.Core.Make ( mkCoreLets ) import Util-import Id-import NameEnv-import FieldLabel ( flSelector )-import SrcLoc+import GHC.Types.Id+import GHC.Types.Name.Env+import GHC.Types.FieldLabel ( flSelector )+import GHC.Types.SrcLoc import Outputable import Control.Monad(liftM) import Data.List (groupBy)@@ -260,37 +260,5 @@ positional patterns (T a b) and (a `T` b) all match the arguments in order.  Also T {} is special because it's equivalent to (T _ _). Hence the (null rpats) checks here and there.---Note [Existentials in shift_con_pat]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-        data T = forall a. Ord a => T a (a->Int)--        f (T x f) True  = ...expr1...-        f (T y g) False = ...expr2..--When we put in the tyvars etc we get--        f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...-        f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...--After desugaring etc we'll get a single case:--        f = \t::T b::Bool ->-            case t of-               T a (d::Ord a) (x::a) (f::a->Int)) ->-            case b of-                True  -> ...expr1...-                False -> ...expr2...--*** We have to substitute [a/b, d/e] in expr2! **-Hence-                False -> ....((/\b\(e:Ord b).expr2) a d)....--Originally I tried to use-        (\b -> let e = d in expr2) a-to do this substitution.  While this is "correct" in a way, it fails-Lint, because e::Ord b but d::Ord a.  -}
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -24,6 +24,7 @@ #include "HsVersions.h"  import GhcPrelude+import GHC.Platform  import {-# SOURCE #-} GHC.HsToCore.Match ( match ) import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsExpr, dsSyntaxExpr )@@ -33,23 +34,23 @@  import GHC.Hs -import Id+import GHC.Types.Id import GHC.Core import GHC.Core.Make-import TyCon-import DataCon+import GHC.Core.TyCon+import GHC.Core.DataCon import TcHsSyn ( shortCutLit ) import TcType-import Name-import Type+import GHC.Types.Name+import GHC.Core.Type import PrelNames import TysWiredIn import TysPrim-import Literal-import SrcLoc+import GHC.Types.Literal+import GHC.Types.SrcLoc import Data.Ratio import Outputable-import BasicTypes+import GHC.Types.Basic import GHC.Driver.Session import Util import FastString@@ -88,19 +89,20 @@ dsLit :: HsLit GhcRn -> DsM CoreExpr dsLit l = do   dflags <- getDynFlags+  let platform = targetPlatform dflags   case l of     HsStringPrim _ s -> return (Lit (LitString s))     HsCharPrim   _ c -> return (Lit (LitChar c))-    HsIntPrim    _ i -> return (Lit (mkLitIntWrap dflags i))-    HsWordPrim   _ w -> return (Lit (mkLitWordWrap dflags w))-    HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap dflags i))-    HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w))+    HsIntPrim    _ i -> return (Lit (mkLitIntWrap platform i))+    HsWordPrim   _ w -> return (Lit (mkLitWordWrap platform w))+    HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap platform i))+    HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap platform w))     HsFloatPrim  _ f -> return (Lit (LitFloat (fl_value f)))     HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))     HsChar _ c       -> return (mkCharExpr c)     HsString _ str   -> mkStringExprFS str     HsInteger _ i _  -> mkIntegerExpr i-    HsInt _ i        -> return (mkIntExpr dflags (il_value i))+    HsInt _ i        -> return (mkIntExpr platform (il_value i))     XLit nec         -> noExtCon nec     HsRat _ (FL _ _ val) ty -> do       num   <- mkIntegerExpr (numerator val)@@ -119,7 +121,8 @@ dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty                    , ol_witness = witness }) = do   dflags <- getDynFlags-  case shortCutLit dflags val ty of+  let platform = targetPlatform dflags+  case shortCutLit platform val ty of     Just expr | not rebindable -> dsExpr expr        -- Note [Literal short cut]     _                          -> dsExpr witness dsOverLit (XOverLit nec) = noExtCon nec@@ -369,7 +372,7 @@      -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3      -- If we do convert to the constructor form, we'll generate a case      -- expression on a Float# or Double# and that's not allowed in Core; see-     -- #9238 and Note [Rules for floating-point comparisons] in PrelRules+     -- #9238 and Note [Rules for floating-point comparisons] in GHC.Core.Op.ConstantFold   where     -- Sometimes (like in test case     -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include@@ -426,9 +429,10 @@     match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult)     match_group eqns@(firstEqn :| _)         = do { dflags <- getDynFlags+             ; let platform = targetPlatform dflags              ; let LitPat _ hs_lit = firstPat firstEqn              ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)-             ; return (hsLitKey dflags hs_lit, match_result) }+             ; return (hsLitKey platform hs_lit, match_result) }      wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult         -- Equality check for string literals@@ -443,7 +447,7 @@   ----------------------------hsLitKey :: DynFlags -> HsLit GhcTc -> Literal+hsLitKey :: Platform -> HsLit GhcTc -> Literal -- Get the Core literal corresponding to a HsLit. -- It only works for primitive types and strings; -- others have been removed by tidy@@ -453,15 +457,15 @@ -- In the case of the fixed-width numeric types, we need to wrap here -- because Literal has an invariant that the literal is in range, while -- HsLit does not.-hsLitKey dflags (HsIntPrim    _ i) = mkLitIntWrap  dflags i-hsLitKey dflags (HsWordPrim   _ w) = mkLitWordWrap dflags w-hsLitKey dflags (HsInt64Prim  _ i) = mkLitInt64Wrap  dflags i-hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w-hsLitKey _      (HsCharPrim   _ c) = mkLitChar            c-hsLitKey _      (HsFloatPrim  _ f) = mkLitFloat           (fl_value f)-hsLitKey _      (HsDoublePrim _ d) = mkLitDouble          (fl_value d)-hsLitKey _      (HsString _ s)     = LitString (bytesFS s)-hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)+hsLitKey platform (HsIntPrim    _ i) = mkLitIntWrap  platform i+hsLitKey platform (HsWordPrim   _ w) = mkLitWordWrap platform w+hsLitKey platform (HsInt64Prim  _ i) = mkLitInt64Wrap  platform i+hsLitKey platform (HsWord64Prim _ w) = mkLitWord64Wrap platform w+hsLitKey _        (HsCharPrim   _ c) = mkLitChar            c+hsLitKey _        (HsFloatPrim  _ f) = mkLitFloat           (fl_value f)+hsLitKey _        (HsDoublePrim _ d) = mkLitDouble          (fl_value d)+hsLitKey _        (HsString _ s)     = LitString (bytesFS s)+hsLitKey _        l                  = pprPanic "hsLitKey" (ppr l)  {- ************************************************************************
compiler/GHC/HsToCore/Monad.hs view
@@ -55,7 +55,7 @@ import GhcPrelude  import TcRnMonad-import FamInstEnv+import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Make  ( unitExpr ) import GHC.Core.Utils ( exprType, isExprLevPoly )@@ -63,28 +63,28 @@ import GHC.IfaceToCore import TcMType ( checkForLevPolyX, formatLevPolyErr ) import PrelNames-import RdrName+import GHC.Types.Name.Reader import GHC.Driver.Types import Bag-import BasicTypes ( Origin )-import DataCon-import ConLike-import TyCon+import GHC.Types.Basic ( Origin )+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.TyCon import GHC.HsToCore.PmCheck.Types-import Id-import Module+import GHC.Types.Id+import GHC.Types.Module import Outputable-import SrcLoc-import Type-import UniqSupply-import Name-import NameEnv+import GHC.Types.SrcLoc+import GHC.Core.Type+import GHC.Types.Unique.Supply+import GHC.Types.Name+import GHC.Types.Name.Env import GHC.Driver.Session import ErrUtils import FastString-import UniqFM ( lookupWithDefaultUFM )-import Literal ( mkLitString )-import CostCentreState+import GHC.Types.Unique.FM ( lookupWithDefaultUFM )+import GHC.Types.Literal ( mkLitString )+import GHC.Types.CostCentre.State  import Data.IORef
compiler/GHC/HsToCore/PmCheck.hs view
@@ -27,25 +27,25 @@ import GHC.HsToCore.PmCheck.Types import GHC.HsToCore.PmCheck.Oracle import GHC.HsToCore.PmCheck.Ppr-import BasicTypes (Origin, isGenerated)+import GHC.Types.Basic (Origin, isGenerated) import GHC.Core (CoreExpr, Expr(Var,App)) import FastString (unpackFS, lengthFS) import GHC.Driver.Session import GHC.Hs-import TcHsSyn-import Id-import ConLike-import Name+import TcHsSyn   ( shortCutLit )+import GHC.Types.Id+import GHC.Core.ConLike+import GHC.Types.Name import FamInst import TysWiredIn-import SrcLoc+import GHC.Types.SrcLoc import Util import Outputable-import DataCon-import TyCon-import Var (EvVar)-import Coercion-import TcEvidence+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Types.Var (EvVar)+import GHC.Core.Coercion+import TcEvidence ( HsWrapper(..), isIdHsWrapper ) import TcType (evVarPred) import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)@@ -54,8 +54,8 @@ import GHC.HsToCore.Monad import Bag import OrdList-import TyCoRep-import Type+import GHC.Core.TyCo.Rep+import GHC.Core.Type import GHC.HsToCore.Utils       (isTrueLHsExpr) import Maybes import qualified GHC.LanguageExtensions as LangExt@@ -514,10 +514,11 @@     -- type of the scrutinee, so info on both pattern and scrutinee (for which     -- short cutting in dsOverLit works properly) is overloaded iff either is.     dflags <- getDynFlags+    let platform = targetPlatform dflags     core_expr <- case olit of       OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }         | not rebindable-        , Just expr <- shortCutLit dflags val ty+        , Just expr <- shortCutLit platform val ty         -> dsExpr expr       _ -> dsOverLit olit     let lit  = expectJust "failed to detect OverLit" (coreExprAsPmLit core_expr)@@ -539,7 +540,7 @@   SumPat _ty p alt arity -> do     (y, grds) <- translateLPatV fam_insts p     let sum_con = sumDataCon alt arity-    -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon     pure $ vanillaConGrd x sum_con [y] : grds    -- --------------------------------------------------------------------------@@ -641,7 +642,7 @@   grhss' <- mapM (translateLGRHS fam_insts match_loc pats) (grhssGRHSs grhss)   -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr grhss, ppr grhss'])   return (mkGrdTreeMany pats' grhss')-translateMatch _ _ (L _ (XMatch _)) = panic "translateMatch"+translateMatch _ _ (L _ (XMatch nec)) = noExtCon nec  -- ----------------------------------------------------------------------- -- * Transform source guards (GuardStmt Id) to simpler PmGrds@@ -656,7 +657,7 @@         | null gs   = L match_loc (sep (map ppr pats))         | otherwise = L grd_loc   (sep (map ppr pats) <+> vbar <+> interpp'SP gs)       L grd_loc _ = head gs-translateLGRHS _ _ _ (L _ (XGRHS _)) = panic "translateLGRHS"+translateLGRHS _ _ _ (L _ (XGRHS nec)) = noExtCon nec  -- | Translate a guard statement to a 'GrdVec' translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM GrdVec@@ -999,7 +1000,7 @@   tracePm "checkGrdTree {" $ vcat [ ppr guards                                   , ppr deltas ]   res <- checkGrdTree' guards deltas-  tracePm "}:" (ppr res) -- braces are easier to match by tooling+  tracePm "checkGrdTree }:" (ppr res) -- braces are easier to match by tooling   return res  -- ----------------------------------------------------------------------------
compiler/GHC/HsToCore/PmCheck/Oracle.hs view
@@ -34,41 +34,40 @@ import ErrUtils import Util import Bag-import UniqSet-import UniqDSet-import Unique-import Id-import VarEnv-import UniqDFM-import Var           (EvVar)-import Name+import GHC.Types.Unique.Set+import GHC.Types.Unique.DSet+import GHC.Types.Unique+import GHC.Types.Id+import GHC.Types.Var.Env+import GHC.Types.Unique.DFM+import GHC.Types.Var      (EvVar)+import GHC.Types.Name import GHC.Core import GHC.Core.FVs       (exprFreeVars) import GHC.Core.Map import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils     (exprType) import GHC.Core.Make      (mkListExpr, mkCharExpr)-import UniqSupply+import GHC.Types.Unique.Supply import FastString-import SrcLoc-import ListSetOps (unionLists)+import GHC.Types.SrcLoc import Maybes-import ConLike-import DataCon-import PatSyn-import TyCon+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.PatSyn+import GHC.Core.TyCon import TysWiredIn import TysPrim (tYPETyCon)-import TyCoRep-import Type-import TcSimplify    (tcNormalise, tcCheckSatisfiability)-import Unify         (tcMatchTy)-import TcRnTypes     (completeMatchConLikes)-import Coercion+import GHC.Core.TyCo.Rep+import GHC.Core.Type+import TcSimplify     (tcNormalise, tcCheckSatisfiability)+import GHC.Core.Unify (tcMatchTy)+import TcRnTypes      (completeMatchConLikes)+import GHC.Core.Coercion import MonadUtils hiding (foldlM) import GHC.HsToCore.Monad hiding (foldlM) import FamInst-import FamInstEnv+import GHC.Core.FamInstEnv  import Control.Monad (guard, mzero, when) import Control.Monad.Trans.Class (lift)@@ -613,9 +612,6 @@   - (Refine) If we had @x /~ K zs@, unify each y with each z in turn. * Adding negative information. Example: Add the fact @x /~ Nothing@ (see 'addNotConCt')   - (Refut) If we have @x ~ K ys@, refute.-  - (Redundant) If we have @x ~ K2@ and @eqPmAltCon K K2 == Disjoint@-    (ex. Just and Nothing), the info is redundant and can be-    discarded.   - (COMPLETE) If K=Nothing and we had @x /~ Just@, then we get     @x /~ [Just,Nothing]@. This is vacuous by matter of comparing to the built-in     COMPLETE set, so should refute.@@ -655,7 +651,7 @@ -- * Looking up VarInfo  emptyVarInfo :: Id -> VarInfo-emptyVarInfo x = VI (idType x) [] [] NoPM+emptyVarInfo x = VI (idType x) [] emptyPmAltConSet NoPM  lookupVarInfo :: TmState -> Id -> VarInfo -- (lookupVarInfo tms x) tells what we know about 'x'@@ -754,7 +750,7 @@ canDiverge :: Delta -> Id -> Bool canDiverge delta@MkDelta{ delta_tm_st = ts } x   | VI _ pos neg _ <- lookupVarInfo ts x-  = null neg && all pos_can_diverge pos+  = isEmptyPmAltConSet neg && all pos_can_diverge pos   where     pos_can_diverge (PmAltConLike (RealDataCon dc), _, [y])       -- See Note [Divergence of Newtype matches]@@ -793,8 +789,8 @@ lookupRefuts MkDelta{ delta_tm_st = ts@(TmSt (SDIE env) _) } k =   case lookupUDFM env k of     Nothing -> []-    Just (Indirect y) -> vi_neg (lookupVarInfo ts y)-    Just (Entry vi)   -> vi_neg vi+    Just (Indirect y) -> pmAltConSetElems (vi_neg (lookupVarInfo ts y))+    Just (Entry vi)   -> pmAltConSetElems (vi_neg vi)  isDataConSolution :: (PmAltCon, [TyVar], [Id]) -> Bool isDataConSolution (PmAltConLike (RealDataCon _), _, _) = True@@ -937,7 +933,7 @@         | any (implies nalt) pos = neg         -- See Note [Completeness checking with required Thetas]         | hasRequiredTheta nalt  = neg-        | otherwise              = unionLists neg [nalt]+        | otherwise              = extendPmAltConSet neg nalt   let vi_ext = vi{ vi_neg = neg' }   -- 3. Make sure there's at least one other possible constructor   vi' <- case nalt of@@ -985,7 +981,7 @@  -- | Guess the universal argument types of a ConLike from an instantiation of -- its result type. Rather easy for DataCons, but not so much for PatSynCons.--- See Note [Pattern synonym result type] in PatSyn.hs.+-- See Note [Pattern synonym result type] in GHC.Core.PatSyn. guessConLikeUnivTyArgsFromResTy :: FamInstEnvs -> Type -> ConLike -> Maybe [Type] guessConLikeUnivTyArgsFromResTy env res_ty (RealDataCon _) = do   (tc, tc_args) <- splitTyConApp_maybe res_ty@@ -997,7 +993,7 @@ guessConLikeUnivTyArgsFromResTy _   res_ty (PatSynCon ps)  = do   -- We are successful if we managed to instantiate *every* univ_tv of con.   -- This is difficult and bound to fail in some cases, see-  -- Note [Pattern synonym result type] in PatSyn.hs. So we just try our best+  -- Note [Pattern synonym result type] in GHC.Core.PatSyn. So we just try our best   -- here and be sure to return an instantiation when we can substitute every   -- universally quantified type variable.   -- We *could* instantiate all the other univ_tvs just to fresh variables, I@@ -1129,7 +1125,7 @@         delta_pos <- foldlM add_fact delta_refs (vi_pos vi_x)         -- Do the same for negative info         let add_refut delta nalt = addNotConCt delta y nalt-        delta_neg <- foldlM add_refut delta_pos (vi_neg vi_x)+        delta_neg <- foldlM add_refut delta_pos (pmAltConSetElems (vi_neg vi_x))         -- vi_cache will be updated in addNotConCt, so we are good to         -- go!         pure delta_neg@@ -1144,7 +1140,7 @@ addConCt delta@MkDelta{ delta_tm_st = TmSt env reps } x alt tvs args = do   VI ty pos neg cache <- lift (initLookupVarInfo delta x)   -- First try to refute with a negative fact-  guard (all ((/= Equal) . eqPmAltCon alt) neg)+  guard (not (elemPmAltConSet alt neg))   -- Then see if any of the other solutions (remember: each of them is an   -- additional refinement of the possible values x could take) indicate a   -- contradiction@@ -1160,11 +1156,8 @@       let tm_cts = zipWithEqual "addConCt" PmVarCt args other_args       MaybeT $ addPmCts delta (listToBag ty_cts `unionBags` listToBag tm_cts)     Nothing -> do-      -- Filter out redundant negative facts (those that compare Just False to-      -- the new solution)-      let neg' = filter ((== PossiblyOverlap) . eqPmAltCon alt) neg       let pos' = (alt, tvs, args):pos-      pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg' cache)) reps}+      pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg cache)) reps}  equateTys :: [Type] -> [Type] -> [PmCt] equateTys ts us =@@ -1553,7 +1546,7 @@         []           -- When there are literals involved, just print negative info           -- instead of listing missed constructors-          | notNull [ l | PmAltLit l <- neg ]+          | notNull [ l | PmAltLit l <- pmAltConSetElems neg ]           -> go xs n delta         [] -> try_instantiate x xs n delta
compiler/GHC/HsToCore/PmCheck/Ppr.hs view
@@ -12,12 +12,12 @@  import GhcPrelude -import BasicTypes-import Id-import VarEnv-import UniqDFM-import ConLike-import DataCon+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Var.Env+import GHC.Types.Unique.DFM+import GHC.Core.ConLike+import GHC.Core.DataCon import TysWiredIn import Outputable import Control.Monad.Trans.RWS.CPS
compiler/GHC/HsToCore/Quote.hs view
@@ -27,6 +27,7 @@ #include "HsVersions.h"  import GhcPrelude+import GHC.Platform  import {-# SOURCE #-}   GHC.HsToCore.Expr ( dsExpr ) @@ -37,41 +38,36 @@  import GHC.Hs import PrelNames--- To avoid clashes with GHC.HsToCore.Quote.varName we must make a local alias--- for OccName.varName. We do this by removing varName from the import of OccName--- above, making a qualified instance of OccName and using OccNameAlias.varName--- where varName ws previously used in this file.-import qualified OccName( isDataOcc, isVarOcc, isTcOcc ) -import Module-import Id-import Name hiding( isVarOcc, isTcOcc, varName, tcName )+import GHC.Types.Module+import GHC.Types.Id+import GHC.Types.Name hiding( varName, tcName ) import THNames-import NameEnv+import GHC.Types.Name.Env import TcType-import TyCon+import GHC.Core.TyCon import TysWiredIn import GHC.Core import GHC.Core.Make import GHC.Core.Utils-import SrcLoc-import Unique-import BasicTypes+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Unique+import GHC.Types.Basic import Outputable import Bag import GHC.Driver.Session import FastString-import ForeignCall+import GHC.Types.ForeignCall import Util import Maybes import MonadUtils import TcEvidence import Control.Monad.Trans.Reader import Control.Monad.Trans.Class-import Class+import GHC.Core.Class import GHC.Driver.Types ( MonadThings )-import DataCon-import Var+import GHC.Core.DataCon+import GHC.Types.Var import GHC.HsToCore.Binds  import GHC.TypeLits@@ -138,6 +134,9 @@ -- wrapper type MetaM a = ReaderT MetaWrappers DsM a +getPlatform :: MetaM Platform+getPlatform = targetPlatform <$> getDynFlags+ ----------------------------------------------------------------------------- dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr           -> HsBracket GhcRn@@ -2101,10 +2100,10 @@       name_mod = moduleNameString (moduleName mod)       name_pkg = unitIdString (moduleUnitId mod)       name_occ = nameOccName name-      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName-              | OccName.isVarOcc  name_occ = mkNameG_vName-              | OccName.isTcOcc   name_occ = mkNameG_tcName-              | otherwise                  = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name)+      mk_varg | isDataOcc name_occ = mkNameG_dName+              | isVarOcc  name_occ = mkNameG_vName+              | isTcOcc   name_occ = mkNameG_tcName+              | otherwise          = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name)  lookupType :: Name      -- Name of type constructor (e.g. (M TH.Exp))            -> MetaM Type  -- The type@@ -2212,10 +2211,10 @@ repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat)) -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here repPunboxedSum (MkC p) alt arity- = do { dflags <- getDynFlags+ = do { platform <- getPlatform       ; rep2 unboxedSumPName [ p-                             , mkIntExprInt dflags alt-                             , mkIntExprInt dflags arity ] }+                             , mkIntExprInt platform alt+                             , mkIntExprInt platform arity ] }  repPcon   :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat)) repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]@@ -2282,10 +2281,10 @@ repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp)) -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here repUnboxedSum (MkC e) alt arity- = do { dflags <- getDynFlags+ = do { platform <- getPlatform       ; rep2 unboxedSumEName [ e-                             , mkIntExprInt dflags alt-                             , mkIntExprInt dflags arity ] }+                             , mkIntExprInt platform alt+                             , mkIntExprInt platform arity ] }  repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp)) repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]@@ -2689,18 +2688,18 @@  repTupleTyCon :: Int -> MetaM (Core (M TH.Type)) -- Note: not Core Int; it's easier to be direct here-repTupleTyCon i = do dflags <- getDynFlags-                     rep2 tupleTName [mkIntExprInt dflags i]+repTupleTyCon i = do platform <- getPlatform+                     rep2 tupleTName [mkIntExprInt platform i]  repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type)) -- Note: not Core Int; it's easier to be direct here-repUnboxedTupleTyCon i = do dflags <- getDynFlags-                            rep2 unboxedTupleTName [mkIntExprInt dflags i]+repUnboxedTupleTyCon i = do platform <- getPlatform+                            rep2 unboxedTupleTName [mkIntExprInt platform i]  repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type)) -- Note: not Core TH.SumArity; it's easier to be direct here-repUnboxedSumTyCon arity = do dflags <- getDynFlags-                              rep2 unboxedSumTName [mkIntExprInt dflags arity]+repUnboxedSumTyCon arity = do platform <- getPlatform+                              rep2 unboxedSumTName [mkIntExprInt platform arity]  repArrowTyCon :: MetaM (Core (M TH.Type)) repArrowTyCon = rep2 arrowTName []@@ -2712,8 +2711,8 @@ repPromotedDataCon (MkC s) = rep2 promotedTName [s]  repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type))-repPromotedTupleTyCon i = do dflags <- getDynFlags-                             rep2 promotedTupleTName [mkIntExprInt dflags i]+repPromotedTupleTyCon i = do platform <- getPlatform+                             rep2 promotedTupleTName [mkIntExprInt platform i]  repPromotedNilTyCon :: MetaM (Core (M TH.Type)) repPromotedNilTyCon = rep2 promotedNilTName []@@ -2746,11 +2745,11 @@  repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit) repLiteral (HsStringPrim _ bs)-  = do dflags   <- getDynFlags+  = do platform <- getPlatform        word8_ty <- lookupType word8TyConName        let w8s = unpack bs            w8s_expr = map (\w8 -> mkCoreConApps word8DataCon-                                  [mkWordLit dflags (toInteger w8)]) w8s+                                  [mkWordLit platform (toInteger w8)]) w8s        rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr] repLiteral lit   = do lit' <- case lit of@@ -2935,8 +2934,8 @@ ------------ Literals & Variables -------------------  coreIntLit :: Int -> MetaM (Core Int)-coreIntLit i = do dflags <- getDynFlags-                  return (MkC (mkIntExprInt dflags i))+coreIntLit i = do platform <- getPlatform+                  return (MkC (mkIntExprInt platform i))  coreIntegerLit :: MonadThings m => Integer -> m (Core Integer) coreIntegerLit i = fmap MkC (mkIntegerExpr i)
compiler/GHC/HsToCore/Usage.hs view
@@ -5,7 +5,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.HsToCore.Usage (-    -- * Dependency/fingerprinting code (used by GHC.Iface.Utils)+    -- * Dependency/fingerprinting code (used by GHC.Iface.Make)     mkUsageInfo, mkUsedNames, mkDependencies     ) where @@ -14,15 +14,16 @@ import GhcPrelude  import GHC.Driver.Session+import GHC.Driver.Ways import GHC.Driver.Types import TcRnTypes-import Name-import NameSet-import Module+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Module import Outputable import Util-import UniqSet-import UniqFM+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM import Fingerprint import Maybes import GHC.Driver.Packages
compiler/GHC/HsToCore/Utils.hs view
@@ -38,7 +38,7 @@         mkSelectorBinds,          selectSimpleMatchVarL, selectMatchVars, selectMatchVar,-        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,+        mkOptTickBox, mkBinaryTickBox, decideBangHood,         isTrueLHsExpr     ) where @@ -57,25 +57,25 @@  import GHC.Core.Utils import GHC.Core.Make-import MkId-import Id-import Literal-import TyCon-import DataCon-import PatSyn-import Type-import Coercion+import GHC.Types.Id.Make+import GHC.Types.Id+import GHC.Types.Literal+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Core.PatSyn+import GHC.Core.Type+import GHC.Core.Coercion import TysPrim import TysWiredIn-import BasicTypes-import ConLike-import UniqSet-import UniqSupply-import Module+import GHC.Types.Basic+import GHC.Core.ConLike+import GHC.Types.Unique.Set+import GHC.Types.Unique.Supply+import GHC.Types.Module import PrelNames-import Name( isInternalName )+import GHC.Types.Name( isInternalName ) import Outputable-import SrcLoc+import GHC.Types.SrcLoc import Util import GHC.Driver.Session import FastString@@ -331,7 +331,7 @@                alt_result = match_result} = alt     (matcher, needs_void_lam) = patSynMatcher psyn -    -- See Note [Matchers and builders for pattern synonyms] in PatSyns+    -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn     -- on these extra Void# arguments     ensure_unstrict cont | needs_void_lam = Lam voidArgId cont                          | otherwise      = cont@@ -863,7 +863,7 @@ (This note predates join points as formal entities (hence the quotation marks). We can't use actual join points here (see above); if we did, this would also solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR-join points] in WorkWrap.)+join points] in GHC.Core.Op.WorkWrap.)  When we make a failure point we ensure that it does not look like a thunk. Example:@@ -954,19 +954,6 @@       = case p of            ParPat x p    -> L l (ParPat x (go p))            LazyPat _ lp' -> lp'-           BangPat _ _   -> lp-           _             -> L l (BangPat noExtField lp)---- | Unconditionally make a 'Pat' strict.-addBang :: LPat GhcTc -- ^ Original pattern-        -> LPat GhcTc -- ^ Banged pattern-addBang = go-  where-    go lp@(L l p)-      = case p of-           ParPat x p    -> L l (ParPat x (go p))-           LazyPat _ lp' -> L l (BangPat noExtField lp')-                                  -- Should we bring the extension value over?            BangPat _ _   -> lp            _             -> L l (BangPat noExtField lp)
compiler/GHC/Iface/Binary.hs view
@@ -39,19 +39,19 @@ import PrelInfo   ( isKnownKeyName, lookupKnownKeyName ) import GHC.Iface.Env import GHC.Driver.Types-import Module-import Name+import GHC.Types.Module+import GHC.Types.Name import GHC.Driver.Session-import UniqFM-import UniqSupply+import GHC.Types.Unique.FM+import GHC.Types.Unique.Supply import Panic import Binary-import SrcLoc+import GHC.Types.SrcLoc import ErrUtils import FastMutInt-import Unique+import GHC.Types.Unique import Outputable-import NameCache+import GHC.Types.Name.Cache import GHC.Platform import FastString import Constants@@ -133,9 +133,9 @@     -- should be).  Also, the serialisation of value of type "Bin     -- a" used to depend on the word size of the machine, now they     -- are always 32 bits.-    if wORD_SIZE dflags == 4-        then do _ <- Binary.get bh :: IO Word32; return ()-        else do _ <- Binary.get bh :: IO Word64; return ()+    case platformWordSize (targetPlatform dflags) of+      PW4 -> do _ <- Binary.get bh :: IO Word32; return ()+      PW8 -> do _ <- Binary.get bh :: IO Word64; return ()      -- Check the interface file version and ways.     check_ver  <- get bh@@ -191,9 +191,9 @@    -- dummy 32/64-bit field before the version/way for    -- compatibility with older interface file formats.    -- See Note [dummy iface field] above.-    if wORD_SIZE dflags == 4-        then Binary.put_ bh (0 :: Word32)-        else Binary.put_ bh (0 :: Word64)+    case platformWordSize (targetPlatform dflags) of+      PW4 -> Binary.put_ bh (0 :: Word32)+      PW8 -> Binary.put_ bh (0 :: Word64)      -- The version and way descriptor go next     put_ bh (show hiVersion)
compiler/GHC/Iface/Env.hs view
@@ -26,17 +26,17 @@  import TcRnMonad import GHC.Driver.Types-import Type-import Var-import Name-import Avail-import Module+import GHC.Core.Type+import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Avail+import GHC.Types.Module import FastString import FastStringEnv import GHC.Iface.Type-import NameCache-import UniqSupply-import SrcLoc+import GHC.Types.Name.Cache+import GHC.Types.Unique.Supply+import GHC.Types.SrcLoc  import Outputable import Data.List     ( partition )@@ -48,7 +48,7 @@ *                                                      * ********************************************************* -See Also: Note [The Name Cache] in NameCache+See Also: Note [The Name Cache] in GHC.Types.Name.Cache -}  newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
compiler/GHC/Iface/Env.hs-boot view
@@ -1,9 +1,9 @@ module GHC.Iface.Env where -import Module-import OccName+import GHC.Types.Module+import GHC.Types.Name.Occurrence import TcRnMonad-import Name-import SrcLoc+import GHC.Types.Name+import GHC.Types.SrcLoc  newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
compiler/GHC/Iface/Ext/Ast.hs view
@@ -18,28 +18,28 @@  import GhcPrelude -import Avail                      ( Avails )+import GHC.Types.Avail            ( Avails ) import Bag                        ( Bag, bagToList )-import BasicTypes+import GHC.Types.Basic import BooleanFormula-import Class                      ( FunDep )+import GHC.Core.Class             ( FunDep ) import GHC.Core.Utils             ( exprType )-import ConLike                    ( conLikeName )+import GHC.Core.ConLike           ( conLikeName ) import GHC.HsToCore               ( deSugarExpr )-import FieldLabel+import GHC.Types.FieldLabel import GHC.Hs import GHC.Driver.Types-import Module                     ( ModuleName, ml_hs_file )+import GHC.Types.Module           ( ModuleName, ml_hs_file ) import MonadUtils                 ( concatMapM, liftIO )-import Name                       ( Name, nameSrcSpan, setNameLoc )-import NameEnv                    ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )-import SrcLoc+import GHC.Types.Name             ( Name, nameSrcSpan, setNameLoc )+import GHC.Types.Name.Env         ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )+import GHC.Types.SrcLoc import TcHsSyn                    ( hsLitType, hsPatType )-import Type                       ( mkVisFunTys, Type )+import GHC.Core.Type              ( mkVisFunTys, Type ) import TysWiredIn                 ( mkListTy, mkSumTy )-import Var                        ( Id, Var, setVarName, varName, varType )+import GHC.Types.Var              ( Id, Var, setVarName, varName, varType ) import TcRnTypes-import GHC.Iface.Utils            ( mkIfaceExports )+import GHC.Iface.Make             ( mkIfaceExports ) import Panic import Maybes @@ -753,7 +753,7 @@           in toHie $ patScopes Nothing rhsScope NoScope pats       , toHie grhss       ]-    XMatch _ -> []+    XMatch nec -> noExtCon nec  instance ( ToHie (Context (Located (IdP a)))          ) => ToHie (HsMatchContext a) where@@ -842,7 +842,7 @@         ]       CoPat _ _ _ _ ->         []-      XPat _ -> []+      XPat nec -> noExtCon nec     where       contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args       contextify (InfixCon a b) = InfixCon a' b'@@ -1039,7 +1039,7 @@       [ toHie expr       ]     Missing _ -> []-    XTupArg _ -> []+    XTupArg nec -> noExtCon nec  instance ( a ~ GhcPass p          , ToHie (PScoped (LPat a))@@ -1081,7 +1081,7 @@       RecStmt {recS_stmts = stmts} ->         [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts         ]-      XStmtLR _ -> []+      XStmtLR nec -> noExtCon nec  instance ( ToHie (LHsExpr a)          , ToHie (PScoped (LPat a))@@ -1145,7 +1145,7 @@     FieldOcc name _ ->       [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)       ]-    XFieldOcc _ -> []+    XFieldOcc nec -> noExtCon nec  instance ToHie (RFContext (LFieldOcc GhcTc)) where   toHie (RFC c rhs (L nspan f)) = concatM $ case f of@@ -1153,7 +1153,7 @@       let var' = setVarName var (removeDefSrcSpan $ varName var)       in [ toHie $ C (RecField c rhs) (L nspan var')          ]-    XFieldOcc _ -> []+    XFieldOcc nec -> noExtCon nec  instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where   toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of@@ -1162,7 +1162,7 @@       ]     Ambiguous _name _ ->       [ ]-    XAmbiguousFieldOcc _ -> []+    XAmbiguousFieldOcc nec -> noExtCon nec  instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where   toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of@@ -1174,7 +1174,7 @@       let var' = setVarName var (removeDefSrcSpan $ varName var)       in [ toHie $ C (RecField c rhs) (L nspan var')          ]-    XAmbiguousFieldOcc _ -> []+    XAmbiguousFieldOcc nec -> noExtCon nec  instance ( a ~ GhcPass p          , ToHie (PScoped (LPat a))@@ -1193,7 +1193,7 @@     [ toHie $ listScopes NoScope stmts     , toHie $ PS Nothing sc NoScope pat     ]-  toHie (RS _ (XApplicativeArg _)) = pure []+  toHie (RS _ (XApplicativeArg nec)) = noExtCon nec  instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where   toHie (PrefixCon args) = toHie args@@ -1271,7 +1271,7 @@     , toHie roles     , toHie instances     ]-  toHie (XTyClGroup _) = pure []+  toHie (XTyClGroup nec) = noExtCon nec  instance ToHie (LTyClDecl GhcRn) where   toHie (L span decl) = concatM $ makeNode decl span : case decl of@@ -1317,7 +1317,7 @@           context_scope = mkLScope context           rhs_scope = foldl1' combineScopes $ map mkScope             [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]-      XTyClDecl _ -> []+      XTyClDecl nec -> noExtCon nec  instance ToHie (LFamilyDecl GhcRn) where   toHie (L span decl) = concatM $ makeNode decl span : case decl of@@ -1332,7 +1332,7 @@           rhsSpan = sigSpan `combineScopes` injSpan           sigSpan = mkScope $ getLoc sig           injSpan = maybe NoScope (mkScope . getLoc) inj-      XFamilyDecl _ -> []+      XFamilyDecl nec -> noExtCon nec  instance ToHie (FamilyInfo GhcRn) where   toHie (ClosedTypeFamily (Just eqns)) = concatM $@@ -1353,7 +1353,7 @@       TyVarSig _ bndr ->         [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr         ]-      XFamilyResultSig _ -> []+      XFamilyResultSig nec -> noExtCon nec  instance ToHie (Located (FunDep (Located Name))) where   toHie (L span fd@(lhs, rhs)) = concatM $@@ -1377,7 +1377,7 @@     where scope = combineScopes patsScope rhsScope           patsScope = mkScope (loc pats)           rhsScope = mkScope (loc rhs)-  toHie (XFamEqn _) = pure []+  toHie (XFamEqn nec) = noExtCon nec  instance ToHie (LInjectivityAnn GhcRn) where   toHie (L span ann) = concatM $ makeNode ann span : case ann of@@ -1393,7 +1393,7 @@     , toHie cons     , toHie derivs     ]-  toHie (XHsDataDefn _) = pure []+  toHie (XHsDataDefn nec) = noExtCon nec  instance ToHie (HsDeriving GhcRn) where   toHie (L span clauses) = concatM@@ -1408,7 +1408,7 @@         , pure $ locOnly ispan         , toHie $ map (TS (ResolvedScopes [])) tys         ]-      XHsDerivingClause _ -> []+      XHsDerivingClause nec -> noExtCon nec  instance ToHie (Located (DerivStrategy GhcRn)) where   toHie (L span strat) = concatM $ makeNode strat span : case strat of@@ -1446,7 +1446,7 @@           rhsScope = combineScopes ctxScope argsScope           ctxScope = maybe NoScope mkLScope ctx           argsScope = condecl_scope dets-      XConDecl _ -> []+      XConDecl nec -> noExtCon nec     where condecl_scope args = case args of             PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs             InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)@@ -1466,7 +1466,7 @@       , toHie $ TS sc a       ]     where span = loc a-  toHie (TS _ (XHsImplicitBndrs _)) = pure []+  toHie (TS _ (XHsImplicitBndrs nec)) = noExtCon nec  instance ( HasLoc thing          , ToHie (TScoped thing)@@ -1476,7 +1476,7 @@       , toHie $ TS sc a       ]     where span = loc a-  toHie (TS _ (XHsWildCardBndrs _)) = pure []+  toHie (TS _ (XHsWildCardBndrs nec)) = noExtCon nec  instance ToHie (LStandaloneKindSig GhcRn) where   toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]@@ -1487,7 +1487,7 @@       [ toHie $ C TyDecl name       , toHie $ TS (ResolvedScopes []) typ       ]-    XStandaloneKindSig _ -> []+    XStandaloneKindSig nec -> noExtCon nec  instance ToHie (SigContext (LSig GhcRn)) where   toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of@@ -1531,7 +1531,7 @@         , toHie $ map (C Use) names         , toHie $ fmap (C Use) typ         ]-      XSig _ -> []+      XSig nec -> noExtCon nec  instance ToHie (LHsType GhcRn) where   toHie x = toHie $ TS (ResolvedScopes []) x@@ -1623,7 +1623,7 @@         [ toHie $ C (TyVarBind sc tsc) var         , toHie kind         ]-      XTyVarBndr _ -> []+      XTyVarBndr nec -> noExtCon nec  instance ToHie (TScoped (LHsQTyVars GhcRn)) where   toHie (TS sc (HsQTvs implicits vars)) = concatM $@@ -1633,7 +1633,7 @@     where       varLoc = loc vars       bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits-  toHie (TS _ (XLHsQTyVars _)) = pure []+  toHie (TS _ (XLHsQTyVars nec)) = noExtCon nec  instance ToHie (LHsContext GhcRn) where   toHie (L span tys) = concatM $@@ -1647,7 +1647,7 @@         [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields         , toHie typ         ]-      XConDeclField _ -> []+      XConDeclField nec -> noExtCon nec  instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where   toHie (From expr) = toHie expr@@ -1670,7 +1670,7 @@       SpliceDecl _ splice _ ->         [ toHie splice         ]-      XSpliceDecl _ -> []+      XSpliceDecl nec -> noExtCon nec  instance ToHie (HsBracket a) where   toHie _ = pure []@@ -1728,7 +1728,7 @@         [ toHie $ C Use var         , concatMapM (pure . locOnly . getLoc) roles         ]-      XRoleAnnotDecl _ -> []+      XRoleAnnotDecl nec -> noExtCon nec  instance ToHie (LInstDecl GhcRn) where   toHie (L span decl) = concatM $ makeNode decl span : case decl of@@ -1741,7 +1741,7 @@       TyFamInstD _ d ->         [ toHie $ L span d         ]-      XInstDecl _ -> []+      XInstDecl nec -> noExtCon nec  instance ToHie (LClsInstDecl GhcRn) where   toHie (L span decl) = concatM@@ -1775,21 +1775,21 @@         , toHie strat         , toHie overlap         ]-      XDerivDecl _ -> []+      XDerivDecl nec -> noExtCon nec  instance ToHie (LFixitySig GhcRn) where   toHie (L span sig) = concatM $ makeNode sig span : case sig of       FixitySig _ vars _ ->         [ toHie $ map (C Use) vars         ]-      XFixitySig _ -> []+      XFixitySig nec -> noExtCon nec  instance ToHie (LDefaultDecl GhcRn) where   toHie (L span decl) = concatM $ makeNode decl span : case decl of       DefaultDecl _ typs ->         [ toHie typs         ]-      XDefaultDecl _ -> []+      XDefaultDecl nec -> noExtCon nec  instance ToHie (LForeignDecl GhcRn) where   toHie (L span decl) = concatM $ makeNode decl span : case decl of@@ -1803,7 +1803,7 @@         , toHie $ TS (ResolvedScopes []) sig         , toHie fe         ]-      XForeignDecl _ -> []+      XForeignDecl nec -> noExtCon nec  instance ToHie ForeignImport where   toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $@@ -1823,14 +1823,14 @@       Warnings _ _ warnings ->         [ toHie warnings         ]-      XWarnDecls _ -> []+      XWarnDecls nec -> noExtCon nec  instance ToHie (LWarnDecl GhcRn) where   toHie (L span decl) = concatM $ makeNode decl span : case decl of       Warning _ vars _ ->         [ toHie $ map (C Use) vars         ]-      XWarnDecl _ -> []+      XWarnDecl nec  -> noExtCon nec  instance ToHie (LAnnDecl GhcRn) where   toHie (L span decl) = concatM $ makeNode decl span : case decl of@@ -1838,7 +1838,7 @@         [ toHie prov         , toHie expr         ]-      XAnnDecl _ -> []+      XAnnDecl nec -> noExtCon nec  instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where   toHie (ValueAnnProvenance a) = toHie $ C Use a@@ -1850,10 +1850,10 @@       HsRules _ _ rules ->         [ toHie rules         ]-      XRuleDecls _ -> []+      XRuleDecls nec -> noExtCon nec  instance ToHie (LRuleDecl GhcRn) where-  toHie (L _ (XRuleDecl _)) = pure []+  toHie (L _ (XRuleDecl nec)) = noExtCon nec   toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM         [ makeNode r span         , pure $ locOnly $ getLoc rname@@ -1876,7 +1876,7 @@         [ toHie $ C (ValBind RegularBind sc Nothing) var         , toHie $ TS (ResolvedScopes [sc]) typ         ]-      XRuleBndr _ -> []+      XRuleBndr nec -> noExtCon nec  instance ToHie (LImportDecl GhcRn) where   toHie (L span decl) = concatM $ makeNode decl span : case decl of@@ -1885,7 +1885,7 @@         , toHie $ fmap (IEC ImportAs) as         , maybe (pure []) goIE hidden         ]-      XImportDecl _ -> []+      XImportDecl nec -> noExtCon nec     where       goIE (hiding, (L sp liens)) = concatM $         [ pure $ locOnly sp@@ -1916,7 +1916,7 @@       IEGroup _ _ _ -> []       IEDoc _ _ -> []       IEDocNamed _ _ -> []-      XIE _ -> []+      XIE nec -> noExtCon nec  instance ToHie (IEContext (LIEWrappedName Name)) where   toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
compiler/GHC/Iface/Ext/Binary.hs view
@@ -23,15 +23,15 @@ import GHC.Iface.Binary           ( getDictFastString ) import FastMutInt import FastString                 ( FastString )-import Module                     ( Module )-import Name-import NameCache+import GHC.Types.Module           ( Module )+import GHC.Types.Name+import GHC.Types.Name.Cache import Outputable import PrelInfo-import SrcLoc-import UniqSupply                 ( takeUniqFromSupply )-import Unique-import UniqFM+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Unique.Supply    ( takeUniqFromSupply )+import GHC.Types.Unique+import GHC.Types.Unique.FM import Util  import qualified Data.Array as A
compiler/GHC/Iface/Ext/Debug.hs view
@@ -9,15 +9,15 @@  import GhcPrelude -import SrcLoc-import Module+import GHC.Types.SrcLoc+import GHC.Types.Module import FastString import Outputable  import GHC.Iface.Ext.Types import GHC.Iface.Ext.Binary import GHC.Iface.Ext.Utils-import Name+import GHC.Types.Name  import qualified Data.Map as M import qualified Data.Set as S
compiler/GHC/Iface/Ext/Types.hs view
@@ -16,11 +16,11 @@ import Binary import FastString                 ( FastString ) import GHC.Iface.Type-import Module                     ( ModuleName, Module )-import Name                       ( Name )+import GHC.Types.Module           ( ModuleName, Module )+import GHC.Types.Name             ( Name ) import Outputable hiding ( (<>) )-import SrcLoc                     ( RealSrcSpan )-import Avail+import GHC.Types.SrcLoc           ( RealSrcSpan )+import GHC.Types.Avail  import qualified Data.Array as A import qualified Data.Map as M
compiler/GHC/Iface/Ext/Utils.hs view
@@ -10,15 +10,15 @@ import GHC.Driver.Session         ( DynFlags ) import FastString                 ( FastString, mkFastString ) import GHC.Iface.Type-import Name hiding (varName)+import GHC.Types.Name hiding (varName) import Outputable                 ( renderWithStyle, ppr, defaultUserStyle, initSDocContext )-import SrcLoc+import GHC.Types.SrcLoc import GHC.CoreToIface-import TyCon-import TyCoRep-import Type-import Var-import VarEnv+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.Type+import GHC.Types.Var+import GHC.Types.Var.Env  import GHC.Iface.Ext.Types
compiler/GHC/Iface/Load.hs view
@@ -22,7 +22,7 @@         -- IfM functions         loadInterface,         loadSysInterface, loadUserInterface, loadPluginInterface,-        findAndReadIface, readIface,    -- Used when reading the module's old interface+        findAndReadIface, readIface, writeIface,         loadDecls,      -- Should move to GHC.IfaceToCore and be renamed         initExternalPackageState,         moduleFreeHolesPrecise,@@ -45,29 +45,29 @@ import GHC.Iface.Env import GHC.Driver.Types -import BasicTypes hiding (SuccessFlag(..))+import GHC.Types.Basic hiding (SuccessFlag(..)) import TcRnMonad  import Constants import PrelNames import PrelInfo import PrimOp   ( allThePrimOps, primOpFixity, primOpOcc )-import MkId     ( seqId )+import GHC.Types.Id.Make ( seqId ) import TysPrim  ( funTyConName ) import GHC.Core.Rules-import TyCon-import Annotations-import InstEnv-import FamInstEnv-import Name-import NameEnv-import Avail-import Module+import GHC.Core.TyCon+import GHC.Types.Annotations+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Avail+import GHC.Types.Module import Maybes import ErrUtils import GHC.Driver.Finder-import UniqFM-import SrcLoc+import GHC.Types.Unique.FM+import GHC.Types.SrcLoc import Outputable import GHC.Iface.Binary import Panic@@ -75,15 +75,16 @@ import FastString import Fingerprint import GHC.Driver.Hooks-import FieldLabel+import GHC.Types.FieldLabel import GHC.Iface.Rename-import UniqDSet+import GHC.Types.Unique.DSet import GHC.Driver.Plugins  import Control.Monad import Control.Exception import Data.IORef import System.FilePath+import System.Directory  {- ************************************************************************@@ -486,7 +487,6 @@                             -- Warn warn against an EPS-updating import                             -- of one's own boot file! (one-shot only)                             -- See Note [Loading your own hi-boot file]-                            -- in GHC.Iface.Utils.          ; WARN( bad_boot, ppr mod )           updateEps_  $ \ eps ->@@ -536,7 +536,7 @@ Generally speaking, when compiling module M, we should not load M.hi boot into the EPS.  After all, we are very shortly going to have full information about M.  Moreover, see-Note [Do not update EPS with your own hi-boot] in GHC.Iface.Utils.+Note [Do not update EPS with your own hi-boot] in GHC.Iface.Recomp.  But there is a HORRIBLE HACK here. @@ -974,8 +974,13 @@                              liftIO $ writeIORef ref False           checkBuildDynamicToo _ = return () --- @readIface@ tries just the one file.+-- | Write interface file+writeIface :: DynFlags -> FilePath -> ModIface -> IO ()+writeIface dflags hi_file_path new_iface+    = do createDirectoryIfMissing True (takeDirectory hi_file_path)+         writeBinIface dflags hi_file_path new_iface +-- @readIface@ tries just the one file. readIface :: Module -> FilePath           -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)         -- Failed err    <=> file not found, or unreadable, or illegible
compiler/GHC/Iface/Load.hs-boot view
@@ -1,6 +1,6 @@ module GHC.Iface.Load where -import Module (Module)+import GHC.Types.Module (Module) import TcRnMonad (IfM) import GHC.Driver.Types (ModIface) import Outputable (SDoc)
+ compiler/GHC/Iface/Make.hs view
@@ -0,0 +1,723 @@+{-+(c) The University of Glasgow 2006-2008+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+-}++{-# LANGUAGE CPP, NondecreasingIndentation #-}+{-# LANGUAGE MultiWayIf #-}++-- | Module for constructing @ModIface@ values (interface files),+-- writing them to disk and comparing two versions to see if+-- recompilation is required.+module GHC.Iface.Make+   ( mkPartialIface+   , mkFullIface+   , mkIfaceTc+   , mkIfaceExports+   , coAxiomToIfaceDecl+   , tyThingToIfaceDecl -- Converting things to their Iface equivalents+   )+where++#include "HsVersions.h"++import GhcPrelude++import GHC.Iface.Syntax+import GHC.Iface.Recomp+import GHC.Iface.Load+import GHC.CoreToIface++import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )+import GHC.Types.Id+import GHC.Types.Annotations+import GHC.Core+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.Type+import TcType+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv+import TcRnMonad+import GHC.Hs+import GHC.Driver.Types+import GHC.Driver.Session+import GHC.Types.Var.Env+import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Avail+import GHC.Types.Name.Reader+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Module+import ErrUtils+import Outputable+import GHC.Types.Basic  hiding ( SuccessFlag(..) )+import Util             hiding ( eqListBy )+import FastString+import Maybes+import GHC.HsToCore.Docs++import Data.Function+import Data.List ( findIndex, mapAccumL, sortBy )+import Data.Ord+import Data.IORef+import GHC.Driver.Plugins (LoadedPlugin(..))++{-+************************************************************************+*                                                                      *+\subsection{Completing an interface}+*                                                                      *+************************************************************************+-}++mkPartialIface :: HscEnv+               -> ModDetails+               -> ModGuts+               -> PartialModIface+mkPartialIface hsc_env mod_details+  ModGuts{ mg_module       = this_mod+         , mg_hsc_src      = hsc_src+         , mg_usages       = usages+         , mg_used_th      = used_th+         , mg_deps         = deps+         , mg_rdr_env      = rdr_env+         , mg_fix_env      = fix_env+         , mg_warns        = warns+         , mg_hpc_info     = hpc_info+         , mg_safe_haskell = safe_mode+         , mg_trust_pkg    = self_trust+         , mg_doc_hdr      = doc_hdr+         , mg_decl_docs    = decl_docs+         , mg_arg_docs     = arg_docs+         }+  = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust+             safe_mode usages doc_hdr decl_docs arg_docs mod_details++-- | Fully instantiate a interface+-- Adds fingerprints and potentially code generator produced information.+mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface+mkFullIface hsc_env partial_iface mb_non_cafs = do+    let decls+          | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)+          = mi_decls partial_iface+          | otherwise+          = updateDeclCafInfos (mi_decls partial_iface) mb_non_cafs++    full_iface <-+      {-# SCC "addFingerprints" #-}+      addFingerprints hsc_env partial_iface{ mi_decls = decls }++    -- Debug printing+    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)++    return full_iface++updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl]+updateDeclCafInfos decls Nothing = decls+updateDeclCafInfos decls (Just non_cafs) = map update_decl decls+  where+    update_decl decl+      | IfaceId nm ty details infos <- decl+      , elemNameSet nm non_cafs+      = IfaceId nm ty details (HsNoCafRefs : infos)+      | otherwise+      = decl++-- | Make an interface from the results of typechecking only.  Useful+-- for non-optimising compilation, or where we aren't generating any+-- object code at all ('HscNothing').+mkIfaceTc :: HscEnv+          -> SafeHaskellMode    -- The safe haskell mode+          -> ModDetails         -- gotten from mkBootModDetails, probably+          -> TcGblEnv           -- Usages, deprecations, etc+          -> IO ModIface+mkIfaceTc hsc_env safe_mode mod_details+  tc_result@TcGblEnv{ tcg_mod = this_mod,+                      tcg_src = hsc_src,+                      tcg_imports = imports,+                      tcg_rdr_env = rdr_env,+                      tcg_fix_env = fix_env,+                      tcg_merged = merged,+                      tcg_warns = warns,+                      tcg_hpc = other_hpc_info,+                      tcg_th_splice_used = tc_splice_used,+                      tcg_dependent_files = dependent_files+                    }+  = do+          let used_names = mkUsedNames tc_result+          let pluginModules =+                map lpModule (cachedPlugins (hsc_dflags hsc_env))+          deps <- mkDependencies+                    (thisInstalledUnitId (hsc_dflags hsc_env))+                    (map mi_module pluginModules) tc_result+          let hpc_info = emptyHpcInfo other_hpc_info+          used_th <- readIORef tc_splice_used+          dep_files <- (readIORef dependent_files)+          -- 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+          -- module is something we want to record dependencies for,+          -- 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 (imp_mods imports) used_names+                      dep_files merged pluginModules++          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result++          let partial_iface = mkIface_ hsc_env+                   this_mod hsc_src+                   used_th deps rdr_env+                   fix_env warns hpc_info+                   (imp_trust_own_pkg imports) safe_mode usages+                   doc_hdr' doc_map arg_map+                   mod_details++          mkFullIface hsc_env partial_iface Nothing++mkIface_ :: HscEnv -> Module -> HscSource+         -> Bool -> Dependencies -> GlobalRdrEnv+         -> NameEnv FixItem -> Warnings -> HpcInfo+         -> Bool+         -> SafeHaskellMode+         -> [Usage]+         -> Maybe HsDocString+         -> DeclDocMap+         -> ArgDocMap+         -> ModDetails+         -> PartialModIface+mkIface_ hsc_env+         this_mod hsc_src used_th deps rdr_env fix_env src_warns+         hpc_info pkg_trust_req safe_mode usages+         doc_hdr decl_docs arg_docs+         ModDetails{  md_insts     = insts,+                      md_fam_insts = fam_insts,+                      md_rules     = rules,+                      md_anns      = anns,+                      md_types     = type_env,+                      md_exports   = exports,+                      md_complete_sigs = complete_sigs }+-- NB:  notice that mkIface does not look at the bindings+--      only at the TypeEnv.  The previous Tidy phase has+--      put exactly the info into the TypeEnv that we want+--      to expose in the interface++  = do+    let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)+        entities = typeEnvElts type_env+        decls  = [ tyThingToIfaceDecl entity+                 | entity <- entities,+                   let name = getName entity,+                   not (isImplicitTyThing entity),+                      -- No implicit Ids and class tycons in the interface file+                   not (isWiredInName name),+                      -- Nor wired-in things; the compiler knows about them anyhow+                   nameIsLocalOrFrom semantic_mod name  ]+                      -- Sigh: see Note [Root-main Id] in TcRnDriver+                      -- NB: ABSOLUTELY need to check against semantic_mod,+                      -- because all of the names in an hsig p[H=<H>]:H+                      -- are going to be for <H>, not the former id!+                      -- See Note [Identity versus semantic module]++        fixities    = sortBy (comparing fst)+          [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]+          -- The order of fixities returned from nameEnvElts is not+          -- deterministic, so we sort by OccName to canonicalize it.+          -- 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_fam_insts = map famInstToIfaceFamInst fam_insts+        trust_info  = setSafeMode safe_mode+        annotations = map mkIfaceAnnotation anns+        icomplete_sigs = map mkIfaceCompleteSig complete_sigs++    ModIface {+          mi_module      = this_mod,+          -- Need to record this because it depends on the -instantiated-with flag+          -- which could change+          mi_sig_of      = if semantic_mod == this_mod+                            then Nothing+                            else Just semantic_mod,+          mi_hsc_src     = hsc_src,+          mi_deps        = deps,+          mi_usages      = usages,+          mi_exports     = mkIfaceExports exports,++          -- Sort these lexicographically, so that+          -- the result is stable across compilations+          mi_insts       = sortBy cmp_inst     iface_insts,+          mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,+          mi_rules       = sortBy cmp_rule     iface_rules,++          mi_fixities    = fixities,+          mi_warns       = warns,+          mi_anns        = annotations,+          mi_globals     = maybeGlobalRdrEnv rdr_env,+          mi_used_th     = used_th,+          mi_decls       = decls,+          mi_hpc         = isHpcUsed hpc_info,+          mi_trust       = trust_info,+          mi_trust_pkg   = pkg_trust_req,+          mi_complete_sigs = icomplete_sigs,+          mi_doc_hdr     = doc_hdr,+          mi_decl_docs   = decl_docs,+          mi_arg_docs    = arg_docs,+          mi_final_exts  = () }+  where+     cmp_rule     = comparing ifRuleName+     -- Compare these lexicographically by OccName, *not* by unique,+     -- because the latter is not stable across compilations:+     cmp_inst     = comparing (nameOccName . ifDFun)+     cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)++     dflags = hsc_dflags hsc_env++     -- We only fill in mi_globals if the module was compiled to byte+     -- code.  Otherwise, the compiler may not have retained all the+     -- top-level bindings and they won't be in the TypeEnv (see+     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used+     -- by GHCi to decide whether the module has its full top-level+     -- scope available. (#5534)+     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv+     maybeGlobalRdrEnv rdr_env+         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env+         | otherwise                                   = Nothing++     ifFamInstTcName = ifFamInstFam+++{-+************************************************************************+*                                                                      *+       COMPLETE Pragmas+*                                                                      *+************************************************************************+-}++mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch+mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc+++{-+************************************************************************+*                                                                      *+       Keeping track of what we've slurped, and fingerprints+*                                                                      *+************************************************************************+-}+++mkIfaceAnnotation :: Annotation -> IfaceAnnotation+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })+  = IfaceAnnotation {+        ifAnnotatedTarget = fmap nameOccName target,+        ifAnnotatedValue = payload+    }++mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical+mkIfaceExports exports+  = sortBy stableAvailCmp (map sort_subs exports)+  where+    sort_subs :: AvailInfo -> AvailInfo+    sort_subs (Avail n) = Avail n+    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)+    sort_subs (AvailTC n (m:ms) fs)+       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)+       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)+       -- Maintain the AvailTC Invariant++    sort_flds = sortBy (stableNameCmp `on` flSelector)++{-+Note [Original module]+~~~~~~~~~~~~~~~~~~~~~+Consider this:+        module X where { data family T }+        module Y( T(..) ) where { import X; data instance T Int = MkT Int }+The exported Avail from Y will look like+        X.T{X.T, Y.MkT}+That is, in Y,+  - only MkT is brought into scope by the data instance;+  - but the parent (used for grouping and naming in T(..) exports) is X.T+  - and in this case we export X.T too++In the result of mkIfaceExports, the names are grouped by defining module,+so we may need to split up a single Avail into multiple ones.++Note [Internal used_names]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Most of the used_names are External Names, but we can have Internal+Names too: see Note [Binders in Template Haskell] in Convert, and+#5362 for an example.  Such Names are always+  - Such Names are always for locally-defined things, for which we+    don't gather usage info, so we can just ignore them in ent_map+  - They are always System Names, hence the assert, just as a double check.++-}+++{-+************************************************************************+*                                                                      *+                Converting things to their Iface equivalents+*                                                                      *+************************************************************************+-}++tyThingToIfaceDecl :: TyThing -> IfaceDecl+tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id+tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)+tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax+tyThingToIfaceDecl (AConLike cl)  = case cl of+    RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only+    PatSynCon ps   -> patSynToIfaceDecl ps++--------------------------+idToIfaceDecl :: Id -> IfaceDecl+-- The Id is already tidied, so that locally-bound names+-- (lambdas, for-alls) already have non-clashing OccNames+-- We can't tidy it here, locally, because it may have+-- free variables in its type or IdInfo+idToIfaceDecl id+  = IfaceId { ifName      = getName id,+              ifType      = toIfaceType (idType id),+              ifIdDetails = toIfaceIdDetails (idDetails id),+              ifIdInfo    = toIfaceIdInfo (idInfo id) }++--------------------------+dataConToIfaceDecl :: DataCon -> IfaceDecl+dataConToIfaceDecl dataCon+  = IfaceId { ifName      = getName dataCon,+              ifType      = toIfaceType (dataConUserType dataCon),+              ifIdDetails = IfVanillaId,+              ifIdInfo    = [] }++--------------------------+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl+-- We *do* tidy Axioms, because they are not (and cannot+-- conveniently be) built in tidy form+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches+                               , co_ax_role = role })+ = IfaceAxiom { ifName       = getName ax+              , ifTyCon      = toIfaceTyCon tycon+              , ifRole       = role+              , ifAxBranches = map (coAxBranchToIfaceBranch tycon+                                     (map coAxBranchLHS branch_list))+                                   branch_list }+ where+   branch_list = fromBranches branches++-- 2nd parameter is the list of branch LHSs, in case of a closed type family,+-- for conversion from incompatible branches to incompatible indices.+-- For an open type family the list should be empty.+-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom+coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch+coAxBranchToIfaceBranch tc lhs_s+                        (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                                    , cab_eta_tvs = eta_tvs+                                    , cab_lhs = lhs, cab_roles = roles+                                    , cab_rhs = rhs, cab_incomps = incomps })++  = IfaceAxBranch { ifaxbTyVars  = toIfaceTvBndrs tvs+                  , ifaxbCoVars  = map toIfaceIdBndr cvs+                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs+                  , ifaxbLHS     = toIfaceTcArgs tc lhs+                  , ifaxbRoles   = roles+                  , ifaxbRHS     = toIfaceType rhs+                  , ifaxbIncomps = iface_incomps }+  where+    iface_incomps = map (expectJust "iface_incomps"+                        . flip findIndex lhs_s+                        . eqTypes+                        . coAxBranchLHS) incomps++-----------------+tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)+-- We *do* tidy TyCons, because they are not (and cannot+-- conveniently be) built in tidy form+-- The returned TidyEnv is the one after tidying the tyConTyVars+tyConToIfaceDecl env tycon+  | Just clas <- tyConClass_maybe tycon+  = classToIfaceDecl env clas++  | Just syn_rhs <- synTyConRhs_maybe tycon+  = ( tc_env1+    , IfaceSynonym { ifName    = getName tycon,+                     ifRoles   = tyConRoles tycon,+                     ifSynRhs  = if_syn_type syn_rhs,+                     ifBinders = if_binders,+                     ifResKind = if_res_kind+                   })++  | Just fam_flav <- famTyConFlav_maybe tycon+  = ( tc_env1+    , IfaceFamily { ifName    = getName tycon,+                    ifResVar  = if_res_var,+                    ifFamFlav = to_if_fam_flav fam_flav,+                    ifBinders = if_binders,+                    ifResKind = if_res_kind,+                    ifFamInj  = tyConInjectivityInfo tycon+                  })++  | isAlgTyCon tycon+  = ( tc_env1+    , IfaceData { ifName    = getName tycon,+                  ifBinders = if_binders,+                  ifResKind = if_res_kind,+                  ifCType   = tyConCType tycon,+                  ifRoles   = tyConRoles tycon,+                  ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),+                  ifCons    = ifaceConDecls (algTyConRhs tycon),+                  ifGadtSyntax = isGadtSyntaxTyCon tycon,+                  ifParent  = parent })++  | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon+  -- We only convert these TyCons to IfaceTyCons when we are+  -- just about to pretty-print them, not because we are going+  -- to put them into interface files+  = ( env+    , IfaceData { ifName       = getName tycon,+                  ifBinders    = if_binders,+                  ifResKind    = if_res_kind,+                  ifCType      = Nothing,+                  ifRoles      = tyConRoles tycon,+                  ifCtxt       = [],+                  ifCons       = IfDataTyCon [],+                  ifGadtSyntax = False,+                  ifParent     = IfNoParent })+  where+    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`+    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause+    -- an error.+    (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)+    tc_tyvars      = binderVars tc_binders+    if_binders     = toIfaceTyCoVarBinders tc_binders+                     -- No tidying of the binders; they are already tidy+    if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)+    if_syn_type ty = tidyToIfaceType tc_env1 ty+    if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon++    parent = case tyConFamInstSig_maybe tycon of+               Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)+                                                   (toIfaceTyCon tc)+                                                   (tidyToIfaceTcArgs tc_env1 tc ty)+               Nothing           -> IfNoParent++    to_if_fam_flav OpenSynFamilyTyCon             = IfaceOpenSynFamilyTyCon+    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceAbstractClosedSynFamilyTyCon+    to_if_fam_flav (DataFamilyTyCon {})           = IfaceDataFamilyTyCon+    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceBuiltInSynFamTyCon+    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing+    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))+      = IfaceClosedSynFamilyTyCon (Just (axn, ibr))+      where defs = fromBranches $ coAxiomBranches ax+            lhss = map coAxBranchLHS defs+            ibr  = map (coAxBranchToIfaceBranch tycon lhss) defs+            axn  = coAxiomName ax++    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)+    ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)+    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon [ifaceConDecl con]+    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)+    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon+        -- The AbstractTyCon case happens when a TyCon has been trimmed+        -- during tidying.+        -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver+        -- for GHCi, when browsing a module, in which case the+        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.+        -- (Tuple declarations are not serialised into interface files.)++    ifaceConDecl data_con+        = IfCon   { ifConName    = dataConName data_con,+                    ifConInfix   = dataConIsInfix data_con,+                    ifConWrapper = isJust (dataConWrapId_maybe data_con),+                    ifConExTCvs  = map toIfaceBndr ex_tvs',+                    ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',+                    ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,+                    ifConCtxt    = tidyToIfaceContext con_env2 theta,+                    ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,+                    ifConFields  = dataConFieldLabels data_con,+                    ifConStricts = map (toIfaceBang con_env2)+                                       (dataConImplBangs data_con),+                    ifConSrcStricts = map toIfaceSrcBang+                                          (dataConSrcBangs data_con)}+        where+          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)+            = dataConFullSig data_con+          user_bndrs = dataConUserTyVarBinders data_con++          -- Tidy the univ_tvs of the data constructor to be identical+          -- to the tyConTyVars of the type constructor.  This means+          -- (a) we don't need to redundantly put them into the interface file+          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,+          --     we know that the type variables will line up+          -- The latter (b) is important because we pretty-print type constructors+          -- by converting to Iface syntax and pretty-printing that+          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))+                     -- A bit grimy, perhaps, but it's simple!++          (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs+          user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs+          to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)++          -- By this point, we have tidied every universal and existential+          -- tyvar. Because of the dcUserTyCoVarBinders invariant+          -- (see Note [DataCon user type variable binders]), *every*+          -- user-written tyvar must be contained in the substitution that+          -- tidying produced. Therefore, tidying the user-written tyvars is a+          -- simple matter of looking up each variable in the substitution,+          -- which tidyTyCoVarOcc accomplishes.+          tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder+          tidyUserTyCoVarBinder env (Bndr tv vis) =+            Bndr (tidyTyCoVarOcc env tv) vis++classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)+classToIfaceDecl env clas+  = ( env1+    , IfaceClass { ifName   = getName tycon,+                   ifRoles  = tyConRoles (classTyCon clas),+                   ifBinders = toIfaceTyCoVarBinders tc_binders,+                   ifBody   = body,+                   ifFDs    = map toIfaceFD clas_fds })+  where+    (_, clas_fds, sc_theta, _, clas_ats, op_stuff)+      = classExtraBigSig clas+    tycon = classTyCon clas++    body | isAbstractTyCon tycon = IfAbstractClass+         | otherwise+         = IfConcreteClass {+                ifClassCtxt   = tidyToIfaceContext env1 sc_theta,+                ifATs    = map toIfaceAT clas_ats,+                ifSigs   = map toIfaceClassOp op_stuff,+                ifMinDef = fmap getOccFS (classMinimalDef clas)+            }++    (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)++    toIfaceAT :: ClassATItem -> IfaceAT+    toIfaceAT (ATI tc def)+      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)+      where+        (env2, if_decl) = tyConToIfaceDecl env1 tc++    toIfaceClassOp (sel_id, def_meth)+        = ASSERT( sel_tyvars == binderVars tc_binders )+          IfaceClassOp (getName sel_id)+                       (tidyToIfaceType env1 op_ty)+                       (fmap toDmSpec def_meth)+        where+                -- Be careful when splitting the type, because of things+                -- like         class Foo a where+                --                op :: (?x :: String) => a -> a+                -- and          class Baz a where+                --                op :: (Ord a) => a -> a+          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)+          op_ty                = funResultTy rho_ty++    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType+    toDmSpec (_, VanillaDM)       = VanillaDM+    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)++    toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1+                             ,map (tidyTyVar env1) tvs2)++--------------------------++tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)+-- If the type variable "binder" is in scope, don't re-bind it+-- In a class decl, for example, the ATD binders mention+-- (amd must mention) the class tyvars+tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)+ = case lookupVarEnv subst tv of+     Just tv' -> (env,  Bndr tv' vis)+     Nothing  -> tidyTyCoVarBinder env tvb++tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])+tidyTyConBinders = mapAccumL tidyTyConBinder++tidyTyVar :: TidyEnv -> TyVar -> FastString+tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)++--------------------------+instanceToIfaceInst :: ClsInst -> IfaceClsInst+instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag+                             , is_cls_nm = cls_name, is_cls = cls+                             , is_tcs = mb_tcs+                             , is_orphan = orph })+  = ASSERT( cls_name == className cls )+    IfaceClsInst { ifDFun    = dfun_name,+                ifOFlag   = oflag,+                ifInstCls = cls_name,+                ifInstTys = map do_rough mb_tcs,+                ifInstOrph = orph }+  where+    do_rough Nothing  = Nothing+    do_rough (Just n) = Just (toIfaceTyCon_name n)++    dfun_name = idName dfun_id+++--------------------------+famInstToIfaceFamInst :: FamInst -> IfaceFamInst+famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,+                                 fi_fam      = fam,+                                 fi_tcs      = roughs })+  = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom+                 , ifFamInstFam      = fam+                 , ifFamInstTys      = map do_rough roughs+                 , ifFamInstOrph     = orph }+  where+    do_rough Nothing  = Nothing+    do_rough (Just n) = Just (toIfaceTyCon_name n)++    fam_decl = tyConName $ coAxiomTyCon axiom+    mod = ASSERT( isExternalName (coAxiomName axiom) )+          nameModule (coAxiomName axiom)+    is_local name = nameIsLocalOrFrom mod name++    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)++    orph | is_local fam_decl+         = NotOrphan (nameOccName fam_decl)+         | otherwise+         = chooseOrphanAnchor lhs_names++--------------------------+coreRuleToIfaceRule :: CoreRule -> IfaceRule+coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})+  = pprTrace "toHsRule: builtin" (ppr fn) $+    bogusIfaceRule fn++coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,+                            ru_act = act, ru_bndrs = bndrs,+                            ru_args = args, ru_rhs = rhs,+                            ru_orphan = orph, ru_auto = auto })+  = IfaceRule { ifRuleName  = name, ifActivation = act,+                ifRuleBndrs = map toIfaceBndr bndrs,+                ifRuleHead  = fn,+                ifRuleArgs  = map do_arg args,+                ifRuleRhs   = toIfaceExpr rhs,+                ifRuleAuto  = auto,+                ifRuleOrph  = orph }+  where+        -- For type args we must remove synonyms from the outermost+        -- level.  Reason: so that when we read it back in we'll+        -- construct the same ru_rough field as we have right now;+        -- see tcIfaceRule+    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
@@ -0,0 +1,1386 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}++-- | Module for detecting if recompilation is required+module GHC.Iface.Recomp+   ( checkOldIface+   , RecompileRequired(..)+   , recompileRequired+   , addFingerprints+   )+where++#include "HsVersions.h"++import GhcPrelude++import GHC.Iface.Syntax+import BinFingerprint+import GHC.Iface.Load+import FlagChecker++import GHC.Types.Annotations+import GHC.Core+import TcRnMonad+import GHC.Hs+import GHC.Driver.Types+import GHC.Driver.Finder+import GHC.Driver.Session+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Module+import ErrUtils+import Digraph+import GHC.Types.SrcLoc+import Outputable+import GHC.Types.Unique+import Util             hiding ( eqListBy )+import Maybes+import Binary+import Fingerprint+import Exception+import GHC.Types.Unique.Set+import GHC.Driver.Packages++import Control.Monad+import Data.Function+import Data.List (find, sortBy, sort)+import qualified Data.Map as Map+import qualified Data.Set as Set+import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )++--Qualified import so we can define a Semigroup instance+-- but it doesn't clash with Outputable.<>+import qualified Data.Semigroup++{-+  -----------------------------------------------+          Recompilation checking+  -----------------------------------------------++A complete description of how recompilation checking works can be+found in the wiki commentary:++ https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance++Please read the above page for a top-down description of how this all+works.  Notes below cover specific issues related to the implementation.++Basic idea:++  * In the mi_usages information in an interface, we record the+    fingerprint of each free variable of the module++  * In mkIface, we compute the fingerprint of each exported thing A.f.+    For each external thing that A.f refers to, we include the fingerprint+    of the external reference when computing the fingerprint of A.f.  So+    if anything that A.f depends on changes, then A.f's fingerprint will+    change.+    Also record any dependent files added with+      * addDependentFile+      * #include+      * -optP-include++  * In checkOldIface we compare the mi_usages for the module with+    the actual fingerprint for all each thing recorded in mi_usages+-}++data RecompileRequired+  = UpToDate+       -- ^ everything is up to date, recompilation is not required+  | MustCompile+       -- ^ The .hs file has been touched, or the .o/.hi file does not exist+  | RecompBecause String+       -- ^ 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 Semigroup RecompileRequired where+  UpToDate <> r = r+  mc <> _       = mc++instance Monoid RecompileRequired where+  mempty = UpToDate++recompileRequired :: RecompileRequired -> Bool+recompileRequired UpToDate = False+recompileRequired _ = True++-- | 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.+checkOldIface+  :: HscEnv+  -> ModSummary+  -> SourceModified+  -> Maybe ModIface         -- Old interface from compilation manager, if any+  -> IO (RecompileRequired, Maybe ModIface)++checkOldIface hsc_env mod_summary source_modified maybe_iface+  = do  let dflags = hsc_dflags hsc_env+        showPass dflags $+            "Checking old interface for " +++              (showPpr dflags $ ms_mod mod_summary) +++              " (use -ddump-hi-diffs for more details)"+        initIfaceCheck (text "checkOldIface") hsc_env $+            check_old_iface hsc_env mod_summary source_modified maybe_iface++check_old_iface+  :: HscEnv+  -> ModSummary+  -> SourceModified+  -> Maybe ModIface+  -> IfG (RecompileRequired, Maybe ModIface)++check_old_iface hsc_env mod_summary src_modified maybe_iface+  = let dflags = hsc_dflags hsc_env+        getIface =+            case maybe_iface of+                Just _  -> do+                    traceIf (text "We already have the old interface for" <+>+                      ppr (ms_mod mod_summary))+                    return maybe_iface+                Nothing -> loadIface++        loadIface = do+             let iface_path = msHiFilePath mod_summary+             read_result <- readIface (ms_mod mod_summary) iface_path+             case read_result of+                 Failed err -> do+                     traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)+                     traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)+                     return Nothing+                 Succeeded iface -> do+                     traceIf (text "Read the interface file" <+> text iface_path)+                     return $ Just iface++        src_changed+            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True+            | SourceModified <- src_modified = True+            | otherwise = False+    in do+        when src_changed $+            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")++        case src_changed of+            -- If the source has changed and we're in interactive mode,+            -- avoid reading an interface; just return the one we might+            -- have been supplied with.+            True | not (isObjectTarget $ hscTarget dflags) ->+                return (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' <- getIface+                return (MustCompile, maybe_iface')++            False -> do+                maybe_iface' <- getIface+                case maybe_iface' of+                    -- We can't retrieve the iface+                    Nothing    -> return (MustCompile, Nothing)++                    -- We have got the old iface; check its versions+                    -- even in the SourceUnmodifiedAndStable case we+                    -- should check versions because some packages+                    -- might have changed or gone away.+                    Just iface -> checkVersions hsc_env mod_summary iface++-- | Check if a module is still the same 'version'.+--+-- This function is called in the recompilation checker after we have+-- determined that the module M being checked hasn't had any changes+-- to its source file since we last compiled M. So at this point in general+-- two things may have changed that mean we should recompile M:+--   * The interface export by a dependency of M has changed.+--   * The compiler flags specified this time for M have changed+--     in a manner that is significant for recompilation.+-- We return not just if we should recompile the object file but also+-- if we should rebuild the interface file.+checkVersions :: HscEnv+              -> ModSummary+              -> ModIface       -- Old interface+              -> IfG (RecompileRequired, Maybe ModIface)+checkVersions hsc_env mod_summary iface+  = do { traceHiDiffs (text "Considering whether compilation is required for" <+>+                        ppr (mi_module iface) <> colon)++       -- readIface will have verified that the InstalledUnitId matches,+       -- but we ALSO must make sure the instantiation matches up.  See+       -- test case bkpcabal04!+       ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)+            then return (RecompBecause "-this-unit-id changed", Nothing) else do {+       ; recomp <- checkFlagHash hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkOptimHash hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkHpcHash hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkMergedSignatures mod_summary iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkHsig mod_summary iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkHie mod_summary+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkDependencies hsc_env mod_summary iface+       ; if recompileRequired recomp then return (recomp, Just iface) else do {+       ; recomp <- checkPlugins hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+++       -- Source code unchanged and no errors yet... carry on+       --+       -- First put the dependent-module info, read from the old+       -- interface, into the envt, so that when we look for+       -- interfaces we look for the right one (.hi or .hi-boot)+       --+       -- It's just temporary because either the usage check will succeed+       -- (in which case we are done with this module) or it'll fail (in which+       -- case we'll compile the module from scratch anyhow).+       --+       -- We do this regardless of compilation mode, although in --make mode+       -- all the dependent modules should be in the HPT already, so it's+       -- quite redundant+       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }+       ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]+       ; return (recomp, Just iface)+    }}}}}}}}}}+  where+    this_pkg = thisPackage (hsc_dflags hsc_env)+    -- This is a bit of a hack really+    mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)+    mod_deps = mkModDeps (dep_mods (mi_deps iface))++-- | Check if any plugins are requesting recompilation+checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired+checkPlugins hsc iface = liftIO $ do+  new_fingerprint <- fingerprintPlugins hsc+  let old_fingerprint = mi_plugin_hash (mi_final_exts iface)+  pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))+  return $+    pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr++fingerprintPlugins :: HscEnv -> IO Fingerprint+fingerprintPlugins hsc_env = do+  fingerprintPlugins' $ plugins (hsc_dflags hsc_env)++fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint+fingerprintPlugins' plugins = do+  res <- mconcat <$> mapM pluginRecompile' plugins+  return $ case res of+      NoForceRecompile -> fingerprintString "NoForceRecompile"+      ForceRecompile   -> fingerprintString "ForceRecompile"+      -- is the chance of collision worth worrying about?+      -- An alternative is to fingerprintFingerprints [fingerprintString+      -- "maybeRecompile", fp]+      (MaybeRecompile fp) -> fp+++pluginRecompileToRecompileRequired+    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired+pluginRecompileToRecompileRequired old_fp new_fp pr+  | old_fp == new_fp =+    case pr of+      NoForceRecompile  -> UpToDate++      -- we already checked the fingerprint above so a mismatch is not possible+      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.+      MaybeRecompile _  -> UpToDate++      -- 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 "Impure plugin forced recompilation"++  | old_fp `elem` magic_fingerprints ||+    new_fp `elem` magic_fingerprints+    -- The fingerprints do not match either the old or new one is a magic+    -- fingerprint. This happens when non-pure plugins are added for the first+    -- time or when we go from one recompilation strategy to another: (force ->+    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)+    --+    -- For example when we go from 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 "Plugins changed"++  | otherwise =+    let reason = "Plugin fingerprint changed" in+    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 reason++      _                -> RecompBecause reason++ where+   magic_fingerprints =+       [ fingerprintString "NoForceRecompile"+       , fingerprintString "ForceRecompile"+       ]+++-- | Check if an hsig file needs recompilation because its+-- implementing module has changed.+checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired+checkHsig mod_summary iface = do+    dflags <- getDynFlags+    let outer_mod = ms_mod mod_summary+        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )+    case inner_mod == mi_semantic_module iface of+        True -> up_to_date (text "implementing module unchanged")+        False -> return (RecompBecause "implementing module changed")++-- | Check if @.hie@ file is out of date or missing.+checkHie :: ModSummary -> IfG RecompileRequired+checkHie mod_summary = do+    dflags <- getDynFlags+    let hie_date_opt = ms_hie_date mod_summary+        hs_date = ms_hs_date mod_summary+    pure $ case gopt Opt_WriteHie dflags of+               False -> UpToDate+               True -> case hie_date_opt of+                           Nothing -> RecompBecause "HIE file is missing"+                           Just hie_date+                               | hie_date < hs_date+                               -> RecompBecause "HIE file is out of date"+                               | otherwise+                               -> UpToDate++-- | Check the flags haven't changed+checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkFlagHash hsc_env iface = do+    let old_hash = mi_flag_hash (mi_final_exts iface)+    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)+                                             (mi_module iface)+                                             putNameLiterally+    case old_hash == new_hash of+        True  -> up_to_date (text "Module flags unchanged")+        False -> out_of_date_hash "flags changed"+                     (text "  Module flags have changed")+                     old_hash new_hash++-- | Check the optimisation flags haven't changed+checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkOptimHash hsc_env iface = do+    let old_hash = mi_opt_hash (mi_final_exts iface)+    new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)+                                               putNameLiterally+    if | old_hash == new_hash+         -> up_to_date (text "Optimisation flags unchanged")+       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)+         -> up_to_date (text "Optimisation flags changed; ignoring")+       | otherwise+         -> out_of_date_hash "Optimisation flags changed"+                     (text "  Optimisation flags have changed")+                     old_hash new_hash++-- | Check the HPC flags haven't changed+checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkHpcHash hsc_env iface = do+    let old_hash = mi_hpc_hash (mi_final_exts iface)+    new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)+                                               putNameLiterally+    if | old_hash == new_hash+         -> up_to_date (text "HPC flags unchanged")+       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)+         -> up_to_date (text "HPC flags changed; ignoring")+       | otherwise+         -> out_of_date_hash "HPC flags changed"+                     (text "  HPC flags have changed")+                     old_hash new_hash++-- Check that the set of signatures we are merging in match.+-- If the -unit-id flags change, this can change too.+checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired+checkMergedSignatures mod_summary iface = do+    dflags <- getDynFlags+    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]+        new_merged = case Map.lookup (ms_mod_name mod_summary)+                                     (requirementContext (pkgState dflags)) of+                        Nothing -> []+                        Just r -> sort $ map (indefModuleToModule dflags) r+    if old_merged == new_merged+        then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)+        else return (RecompBecause "signatures to merge in changed")++-- If the direct imports of this module are resolved to targets that+-- are not among the dependencies of the previous interface file,+-- then we definitely need to recompile.  This catches cases like+--   - an exposed package has been upgraded+--   - we are compiling with different package flags+--   - a home module that was shadowing a package module has been removed+--   - a new home module has been added that shadows a package module+-- See bug #1372.+--+-- In addition, we also check if the union of dependencies of the imported+-- modules has any difference to the previous set of dependencies. We would need+-- to recompile in that case also since the `mi_deps` field of ModIface needs+-- to be updated to match that information. This is one of the invariants+-- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).+-- See bug #16511.+--+-- Returns (RecompBecause <textual reason>) if recompilation is required.+checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired+checkDependencies hsc_env summary iface+ = do+   checkList $+     [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))+     , do+         (recomp, mnames_seen) <- runUntilRecompRequired $ map+           checkForNewHomeDependency+           (ms_home_imps summary)+         case recomp of+           UpToDate -> do+             let+               seen_home_deps = Set.unions $ map Set.fromList mnames_seen+             checkIfAllOldHomeDependenciesAreSeen seen_home_deps+           _ -> return recomp]+ where+   prev_dep_mods = dep_mods (mi_deps iface)+   prev_dep_plgn = dep_plgins (mi_deps iface)+   prev_dep_pkgs = dep_pkgs (mi_deps iface)++   this_pkg = thisPackage (hsc_dflags hsc_env)++   dep_missing (mb_pkg, L _ mod) = do+     find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)+     let reason = moduleNameString mod ++ " changed"+     case find_res of+        Found _ mod+          | pkg == this_pkg+           -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn+                 then do traceHiDiffs $+                           text "imported module " <> quotes (ppr mod) <>+                           text " not among previous dependencies"+                         return (RecompBecause reason)+                 else+                         return UpToDate+          | otherwise+           -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)+                 then do traceHiDiffs $+                           text "imported module " <> quotes (ppr mod) <>+                           text " is from package " <> quotes (ppr pkg) <>+                           text ", which is not among previous dependencies"+                         return (RecompBecause reason)+                 else+                         return UpToDate+           where pkg = moduleUnitId mod+        _otherwise  -> return (RecompBecause reason)++   old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods+   isOldHomeDeps = flip Set.member old_deps+   checkForNewHomeDependency (L _ mname) = do+     let+       mod = mkModule this_pkg mname+       str_mname = moduleNameString mname+       reason = str_mname ++ " changed"+     -- We only want to look at home modules to check if any new home dependency+     -- pops in and thus here, skip modules that are not home. Checking+     -- membership in old home dependencies suffice because the `dep_missing`+     -- check already verified that all imported home modules are present there.+     if not (isOldHomeDeps mname)+       then return (UpToDate, [])+       else do+         mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do+           let mnames = mname:(map fst $ filter (not . snd) $+                 dep_mods $ mi_deps imported_iface)+           case find (not . isOldHomeDeps) mnames of+             Nothing -> return (UpToDate, mnames)+             Just new_dep_mname -> do+               traceHiDiffs $+                 text "imported home module " <> quotes (ppr mod) <>+                 text " has a new dependency " <> quotes (ppr new_dep_mname)+               return (RecompBecause reason, [])+         return $ fromMaybe (MustCompile, []) mb_result++   -- Performs all recompilation checks in the list until a check that yields+   -- recompile required is encountered. Returns the list of the results of+   -- all UpToDate checks.+   runUntilRecompRequired []             = return (UpToDate, [])+   runUntilRecompRequired (check:checks) = do+     (recompile, value) <- check+     if recompileRequired recompile+       then return (recompile, [])+       else do+         (recomp, values) <- runUntilRecompRequired checks+         return (recomp, value:values)++   checkIfAllOldHomeDependenciesAreSeen seen_deps = do+     let unseen_old_deps = Set.difference+          old_deps+          seen_deps+     if not (null unseen_old_deps)+       then do+         let missing_dep = Set.elemAt 0 unseen_old_deps+         traceHiDiffs $+           text "missing old home dependency " <> quotes (ppr missing_dep)+         return $ RecompBecause "missing old dependency"+       else return UpToDate++needInterface :: Module -> (ModIface -> IfG RecompileRequired)+             -> IfG RecompileRequired+needInterface mod continue+  = do+      mb_recomp <- getFromModIface+        "need version info for"+        mod+        continue+      case mb_recomp of+        Nothing -> return MustCompile+        Just recomp -> return recomp++getFromModIface :: String -> Module -> (ModIface -> IfG a)+              -> IfG (Maybe a)+getFromModIface doc_msg mod getter+  = do  -- Load the imported interface if possible+    let doc_str = sep [text doc_msg, ppr mod]+    traceHiDiffs (text "Checking innterface for module" <+> ppr mod)++    mb_iface <- loadInterface doc_str mod ImportBySystem+        -- Load the interface, but don't complain on failure;+        -- Instead, get an Either back which we can test++    case mb_iface of+      Failed _ -> do+        traceHiDiffs (sep [text "Couldn't load interface for module",+                           ppr mod])+        return Nothing+                  -- Couldn't find or parse a module mentioned in the+                  -- 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 <$> getter iface++-- | Given the usage information extracted from the old+-- M.hi file for the module being compiled, figure out+-- whether M needs to be recompiled.+checkModUsage :: UnitId -> Usage -> IfG RecompileRequired+checkModUsage _this_pkg UsagePackageModule{+                                usg_mod = mod,+                                usg_mod_hash = old_mod_hash }+  = needInterface mod $ \iface -> do+    let reason = moduleNameString (moduleName mod) ++ " changed"+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))+        -- We only track the ABI hash of package modules, rather than+        -- individual entity usages, so if the ABI hash changes we must+        -- recompile.  This is safe but may entail more recompilation when+        -- a dependent package has changed.++checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }+  = needInterface mod $ \iface -> do+    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))++checkModUsage this_pkg UsageHomeModule{+                                usg_mod_name = mod_name,+                                usg_mod_hash = old_mod_hash,+                                usg_exports = maybe_old_export_hash,+                                usg_entities = old_decl_hash }+  = do+    let mod = mkModule this_pkg mod_name+    needInterface mod $ \iface -> do++       let+           new_mod_hash    = mi_mod_hash (mi_final_exts iface)+           new_decl_hash   = mi_hash_fn  (mi_final_exts iface)+           new_export_hash = mi_exp_hash (mi_final_exts iface)++           reason = moduleNameString mod_name ++ " changed"++           -- CHECK MODULE+       recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash+       if not (recompileRequired recompile)+         then return UpToDate+         else do++           -- CHECK EXPORT LIST+           checkMaybeHash reason maybe_old_export_hash new_export_hash+               (text "  Export list changed") $ do++                 -- CHECK ITEMS ONE BY ONE+                 recompile <- checkList [ checkEntityUsage 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 (text "  Great!  The bits I use are up to date")+++checkModUsage _this_pkg UsageFile{ usg_file_path = file,+                                   usg_file_hash = old_hash } =+  liftIO $+    handleIO handle $ do+      new_hash <- getFileHash file+      if (old_hash /= new_hash)+         then return recomp+         else return UpToDate+ where+   recomp = RecompBecause (file ++ " changed")+   handle =+#if defined(DEBUG)+       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp+#else+       \_ -> return recomp -- if we can't find the file, just recompile, don't fail+#endif++------------------------+checkModuleFingerprint :: String -> Fingerprint -> Fingerprint+                       -> IfG RecompileRequired+checkModuleFingerprint reason old_mod_hash new_mod_hash+  | new_mod_hash == old_mod_hash+  = up_to_date (text "Module fingerprint unchanged")++  | otherwise+  = out_of_date_hash reason (text "  Module fingerprint has changed")+                     old_mod_hash new_mod_hash++------------------------+checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc+               -> IfG RecompileRequired -> IfG RecompileRequired+checkMaybeHash reason maybe_old_hash new_hash doc continue+  | Just hash <- maybe_old_hash, hash /= new_hash+  = out_of_date_hash reason doc hash new_hash+  | otherwise+  = continue++------------------------+checkEntityUsage :: String+                 -> (OccName -> Maybe (OccName, Fingerprint))+                 -> (OccName, Fingerprint)+                 -> IfG RecompileRequired+checkEntityUsage reason new_hash (name,old_hash)+  = case new_hash name of++        Nothing       ->        -- We used it before, but it ain't there now+                          out_of_date reason (sep [text "No longer exported:", ppr name])++        Just (_, new_hash)      -- It's there, but is it up to date?+          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))+                                       return UpToDate+          | otherwise            -> out_of_date_hash reason (text "  Out of date:" <+> ppr name)+                                                     old_hash new_hash++up_to_date :: SDoc -> IfG RecompileRequired+up_to_date  msg = traceHiDiffs msg >> return UpToDate++out_of_date :: String -> SDoc -> IfG RecompileRequired+out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)++out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired+out_of_date_hash reason msg old_hash new_hash+  = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])++----------------------+checkList :: [IfG RecompileRequired] -> IfG 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++{-+Note [Fingerprinting IfaceDecls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The general idea here is that we first examine the 'IfaceDecl's and determine+the recursive groups of them. We then walk these groups in dependency order,+serializing each contained 'IfaceDecl' to a "Binary" buffer which we then+hash using MD5 to produce a fingerprint for the group.++However, the serialization that we use is a bit funny: we override the @putName@+operation with our own which serializes the hash of a 'Name' instead of the+'Name' itself. This ensures that the fingerprint of a decl changes if anything+in its transitive closure changes. This trick is why we must be careful about+traversing in dependency order: we need to ensure that we have hashes for+everything referenced by the decl which we are fingerprinting.++Moreover, we need to be careful to distinguish between serialization of binding+Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls+field of a IfaceClsInst): only in the non-binding case should we include the+fingerprint; in the binding case we shouldn't since it is merely the name of the+thing that we are currently fingerprinting.+-}++-- | Add fingerprints for top-level declarations to a 'ModIface'.+--+-- See Note [Fingerprinting IfaceDecls]+addFingerprints+        :: HscEnv+        -> PartialModIface+        -> IO ModIface+addFingerprints hsc_env iface0+ = do+   eps <- hscEPS hsc_env+   let+       decls = mi_decls iface0+       warn_fn = mkIfaceWarnCache (mi_warns iface0)+       fix_fn = mkIfaceFixCache (mi_fixities iface0)++        -- The ABI of a declaration represents everything that is made+        -- visible about the declaration that a client can depend on.+        -- see IfaceDeclABI below.+       declABI :: IfaceDecl -> IfaceDeclABI+       -- TODO: I'm not sure if this should be semantic_mod or this_mod.+       -- See also Note [Identity versus semantic module]+       declABI decl = (this_mod, decl, extras)+        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts+                                  non_orph_fis top_lvl_name_env decl++       -- This is used for looking up the Name of a default method+       -- from its OccName. See Note [default method Name]+       top_lvl_name_env =+         mkOccEnv [ (nameOccName nm, nm)+                  | IfaceId { ifName = nm } <- decls ]++       -- Dependency edges between declarations in the current module.+       -- This is computed by finding the free external names of each+       -- declaration, including IfaceDeclExtras (things that a+       -- declaration implicitly depends on).+       edges :: [ Node Unique IfaceDeclABI ]+       edges = [ DigraphNode abi (getUnique (getOccName decl)) out+               | decl <- decls+               , let abi = declABI decl+               , let out = localOccs $ freeNamesDeclABI abi+               ]++       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n+       localOccs =+         map (getUnique . getParent . getOccName)+                        -- NB: names always use semantic module, so+                        -- filtering must be on the semantic module!+                        -- See Note [Identity versus semantic module]+                        . filter ((== semantic_mod) . name_module)+                        . nonDetEltsUniqSet+                   -- It's OK to use nonDetEltsUFM as localOccs is only+                   -- used to construct the edges and+                   -- stronglyConnCompFromEdgedVertices is deterministic+                   -- even with non-deterministic order of edges as+                   -- explained in Note [Deterministic SCC] in Digraph.+          where getParent :: OccName -> OccName+                getParent occ = lookupOccEnv parent_map occ `orElse` occ++        -- maps OccNames to their parents in the current module.+        -- e.g. a reference to a constructor must be turned into a reference+        -- to the TyCon for the purposes of calculating dependencies.+       parent_map :: OccEnv OccName+       parent_map = foldl' extend emptyOccEnv decls+          where extend env d =+                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]+                  where n = getOccName d++        -- Strongly-connected groups of declarations, in dependency order+       groups :: [SCC IfaceDeclABI]+       groups = stronglyConnCompFromEdgedVerticesUniq edges++       global_hash_fn = mkHashFun hsc_env eps++        -- How to output Names when generating the data to fingerprint.+        -- Here we want to output the fingerprint for each top-level+        -- Name, whether it comes from the current module or another+        -- module.  In this way, the fingerprint for a declaration will+        -- change if the fingerprint for anything it refers to (transitively)+        -- changes.+       mk_put_name :: OccEnv (OccName,Fingerprint)+                   -> BinHandle -> Name -> IO  ()+       mk_put_name local_env bh name+          | isWiredInName name  =  putNameLiterally bh name+           -- wired-in names don't have fingerprints+          | otherwise+          = ASSERT2( isExternalName name, ppr name )+            let hash | nameModule name /= semantic_mod =  global_hash_fn name+                     -- Get it from the REAL interface!!+                     -- This will trigger when we compile an hsig file+                     -- and we know a backing impl for it.+                     -- See Note [Identity versus semantic module]+                     | semantic_mod /= this_mod+                     , not (isHoleModule semantic_mod) = global_hash_fn name+                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)+                           `orElse` pprPanic "urk! lookup local fingerprint"+                                       (ppr name $$ ppr local_env)))+                -- This panic indicates that we got the dependency+                -- analysis wrong, because we needed a fingerprint for+                -- an entity that wasn't in the environment.  To debug+                -- it, turn the panic into a trace, uncomment the+                -- pprTraces below, run the compile again, and inspect+                -- the output and the generated .hi file with+                -- --show-iface.+            in hash >>= put_ bh++        -- take a strongly-connected group of declarations and compute+        -- its fingerprint.++       fingerprint_group :: (OccEnv (OccName,Fingerprint),+                             [(Fingerprint,IfaceDecl)])+                         -> SCC IfaceDeclABI+                         -> IO (OccEnv (OccName,Fingerprint),+                                [(Fingerprint,IfaceDecl)])++       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)+          = do let hash_fn = mk_put_name local_env+                   decl = abiDecl abi+               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do+               hash <- computeFingerprint hash_fn abi+               env' <- extend_hash_env local_env (hash,decl)+               return (env', (hash,decl) : decls_w_hashes)++       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)+          = do let decls = map abiDecl abis+               local_env1 <- foldM extend_hash_env local_env+                                   (zip (repeat fingerprint0) decls)+               let hash_fn = mk_put_name local_env1+               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do+               let stable_abis = sortBy cmp_abiNames abis+                -- put the cycle in a canonical order+               hash <- computeFingerprint hash_fn stable_abis+               let pairs = zip (repeat hash) decls+               local_env2 <- foldM extend_hash_env local_env pairs+               return (local_env2, pairs ++ decls_w_hashes)++       -- we have fingerprinted the whole declaration, but we now need+       -- to assign fingerprints to all the OccNames that it binds, to+       -- use when referencing those OccNames in later declarations.+       --+       extend_hash_env :: OccEnv (OccName,Fingerprint)+                       -> (Fingerprint,IfaceDecl)+                       -> IO (OccEnv (OccName,Fingerprint))+       extend_hash_env env0 (hash,d) = do+          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0+                 (ifaceDeclFingerprints hash d))++   --+   (local_env, decls_w_hashes) <-+       foldM fingerprint_group (emptyOccEnv, []) groups++   -- when calculating fingerprints, we always need to use canonical+   -- ordering for lists of things.  In particular, the mi_deps has various+   -- lists of modules and suchlike, so put these all in canonical order:+   let sorted_deps = sortDependencies (mi_deps iface0)++   -- The export hash of a module depends on the orphan hashes of the+   -- orphan modules below us in the dependency tree.  This is the way+   -- that changes in orphans get propagated all the way up the+   -- dependency tree.+   --+   -- Note [A bad dep_orphs optimization]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   -- In a previous version of this code, we filtered out orphan modules which+   -- were not from the home package, justifying it by saying that "we'd+   -- pick up the ABI hashes of the external module instead".  This is wrong.+   -- Suppose that we have:+   --+   --       module External where+   --           instance Show (a -> b)+   --+   --       module Home1 where+   --           import External+   --+   --       module Home2 where+   --           import Home1+   --+   -- The export hash of Home1 needs to reflect the orphan instances of+   -- External. It's true that Home1 will get rebuilt if the orphans+   -- of External, but we also need to make sure Home2 gets rebuilt+   -- as well.  See #12733 for more details.+   let orph_mods+        = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]+        $ dep_orphs sorted_deps+   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods++   -- Note [Do not update EPS with your own hi-boot]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   -- (See also #10182).  When your hs-boot file includes an orphan+   -- instance declaration, you may find that the dep_orphs of a module you+   -- import contains reference to yourself.  DO NOT actually load this module+   -- or add it to the orphan hashes: you're going to provide the orphan+   -- instances yourself, no need to consult hs-boot; if you do load the+   -- interface into EPS, you will see a duplicate orphan instance.++   orphan_hash <- computeFingerprint (mk_put_name local_env)+                                     (map ifDFun orph_insts, orph_rules, orph_fis)++   -- the export list hash doesn't depend on the fingerprints of+   -- the Names it mentions, only the Names themselves, hence putNameLiterally.+   export_hash <- computeFingerprint putNameLiterally+                      (mi_exports iface0,+                       orphan_hash,+                       dep_orphan_hashes,+                       dep_pkgs (mi_deps iface0),+                       -- See Note [Export hash depends on non-orphan family instances]+                       dep_finsts (mi_deps iface0),+                        -- dep_pkgs: see "Package Version Changes" on+                        -- wiki/commentary/compiler/recompilation-avoidance+                       mi_trust iface0)+                        -- Make sure change of Safe Haskell mode causes recomp.++   -- Note [Export hash depends on non-orphan family instances]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   --+   -- Suppose we have:+   --+   --   module A where+   --       type instance F Int = Bool+   --+   --   module B where+   --       import A+   --+   --   module C where+   --       import B+   --+   -- The family instance consistency check for C depends on the dep_finsts of+   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need+   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of+   -- the exports of B, because C always considers them when checking+   -- consistency.+   --+   -- A full discussion is in #12723.+   --+   -- We do NOT need to hash dep_orphs, because this is implied by+   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,+   -- because there is no eager consistency check as there is with type families+   -- (also we didn't store it anywhere!)+   --++   -- put the declarations in a canonical order, sorted by OccName+   let sorted_decls = Map.elems $ Map.fromList $+                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]++   -- the flag hash depends on:+   --   - (some of) dflags+   -- it returns two hashes, one that shouldn't change+   -- the abi hash and one that should+   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally++   opt_hash <- fingerprintOptFlags dflags putNameLiterally++   hpc_hash <- fingerprintHpcFlags dflags putNameLiterally++   plugin_hash <- fingerprintPlugins hsc_env++   -- the ABI hash depends on:+   --   - decls+   --   - export list+   --   - orphans+   --   - deprecations+   --   - flag abi hash+   mod_hash <- computeFingerprint putNameLiterally+                      (map fst sorted_decls,+                       export_hash,  -- includes orphan_hash+                       mi_warns iface0)++   -- The interface hash depends on:+   --   - the ABI hash, plus+   --   - the module level annotations,+   --   - usages+   --   - deps (home and external packages, dependent files)+   --   - hpc+   iface_hash <- computeFingerprint putNameLiterally+                      (mod_hash,+                       ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache+                       mi_usages iface0,+                       sorted_deps,+                       mi_hpc iface0)++   let+    final_iface_exts = ModIfaceBackend+      { mi_iface_hash  = iface_hash+      , mi_mod_hash    = mod_hash+      , mi_flag_hash   = flag_hash+      , mi_opt_hash    = opt_hash+      , mi_hpc_hash    = hpc_hash+      , mi_plugin_hash = plugin_hash+      , mi_orphan      = not (   all ifRuleAuto orph_rules+                                   -- See Note [Orphans and auto-generated rules]+                              && null orph_insts+                              && null orph_fis)+      , mi_finsts      = not (null (mi_fam_insts iface0))+      , mi_exp_hash    = export_hash+      , mi_orphan_hash = orphan_hash+      , mi_warn_fn     = warn_fn+      , mi_fix_fn      = fix_fn+      , mi_hash_fn     = lookupOccEnv local_env+      }+    final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts }+   --+   return final_iface++  where+    this_mod = mi_module iface0+    semantic_mod = mi_semantic_module iface0+    dflags = hsc_dflags hsc_env+    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)+    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)+    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)+    ann_fn = mkIfaceAnnCache (mi_anns iface0)++-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules+-- (in particular, the orphan modules which are transitively imported by the+-- current module).+--+-- Q: Why do we need the hash at all, doesn't the list of transitively+-- imported orphan modules suffice?+--+-- A: If one of our transitive imports adds a new orphan instance, our+-- export hash must change so that modules which import us rebuild.  If we just+-- hashed the [Module], the hash would not change even when a new instance was+-- added to a module that already had an orphan instance.+--+-- Q: Why don't we just hash the orphan hashes of our direct dependencies?+-- Why the full transitive closure?+--+-- A: Suppose we have these modules:+--+--      module A where+--          instance Show (a -> b) where+--      module B where+--          import A -- **+--      module C where+--          import A+--          import B+--+-- Whether or not we add or remove the import to A in B affects the+-- orphan hash of B.  But it shouldn't really affect the orphan hash+-- of C.  If we hashed only direct dependencies, there would be no+-- way to tell that the net effect was a wash, and we'd be forced+-- to recompile C and everything else.+getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]+getOrphanHashes hsc_env mods = do+  eps <- hscEPS hsc_env+  let+    hpt        = hsc_HPT hsc_env+    pit        = eps_PIT eps+    get_orph_hash mod =+          case lookupIfaceByModule hpt pit mod of+            Just iface -> return (mi_orphan_hash (mi_final_exts iface))+            Nothing    -> do -- similar to 'mkHashFun'+                iface <- initIfaceLoad hsc_env . withException+                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem+                return (mi_orphan_hash (mi_final_exts iface))++  --+  mapM get_orph_hash mods+++sortDependencies :: Dependencies -> Dependencies+sortDependencies d+ = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),+          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),+          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),+          dep_finsts = sortBy stableModuleCmp (dep_finsts d),+          dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }++{-+************************************************************************+*                                                                      *+          The ABI of an IfaceDecl+*                                                                      *+************************************************************************++Note [The ABI of an IfaceDecl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ABI of a declaration consists of:++   (a) the full name of the identifier (inc. module and package,+       because these are used to construct the symbol name by which+       the identifier is known externally).++   (b) the declaration itself, as exposed to clients.  That is, the+       definition of an Id is included in the fingerprint only if+       it is made available as an unfolding in the interface.++   (c) the fixity of the identifier (if it exists)+   (d) for Ids: rules+   (e) for classes: instances, fixity & rules for methods+   (f) for datatypes: instances, fixity & rules for constrs++Items (c)-(f) are not stored in the IfaceDecl, but instead appear+elsewhere in the interface file.  But they are *fingerprinted* with+the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,+and fingerprinting that as part of the declaration.+-}++type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)++data IfaceDeclExtras+  = IfaceIdExtras IfaceIdExtras++  | IfaceDataExtras+       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)+       [IfaceInstABI]           -- Local class and family instances of this tycon+                                -- See Note [Orphans] in GHC.Core.InstEnv+       [AnnPayload]             -- Annotations of the type itself+       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations++  | IfaceClassExtras+       (Maybe Fixity)           -- Fixity of the class itself (if it exists)+       [IfaceInstABI]           -- Local instances of this class *or*+                                --   of its associated data types+                                -- See Note [Orphans] in GHC.Core.InstEnv+       [AnnPayload]             -- Annotations of the type itself+       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations+       [IfExtName]              -- Default methods. If a module+                                -- mentions a class, then it can+                                -- instantiate the class and thereby+                                -- use the default methods, so we must+                                -- include these in the fingerprint of+                                -- a class.++  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]++  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]++  | IfaceOtherDeclExtras++data IfaceIdExtras+  = IdExtras+       (Maybe Fixity)           -- Fixity of the Id (if it exists)+       [IfaceRule]              -- Rules for the Id+       [AnnPayload]             -- Annotations for the Id++-- When hashing a class or family instance, we hash only the+-- DFunId or CoAxiom, because that depends on all the+-- information about the instance.+--+type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance++abiDecl :: IfaceDeclABI -> IfaceDecl+abiDecl (_, decl, _) = decl++cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering+cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`+                         getOccName (abiDecl abi2)++freeNamesDeclABI :: IfaceDeclABI -> NameSet+freeNamesDeclABI (_mod, decl, extras) =+  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras++freeNamesDeclExtras :: IfaceDeclExtras -> NameSet+freeNamesDeclExtras (IfaceIdExtras id_extras)+  = freeNamesIdExtras id_extras+freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)+  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)+freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)+  = unionNameSets $+      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs+freeNamesDeclExtras (IfaceSynonymExtras _ _)+  = emptyNameSet+freeNamesDeclExtras (IfaceFamilyExtras _ insts _)+  = mkNameSet insts+freeNamesDeclExtras IfaceOtherDeclExtras+  = emptyNameSet++freeNamesIdExtras :: IfaceIdExtras -> NameSet+freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)++instance Outputable IfaceDeclExtras where+  ppr IfaceOtherDeclExtras       = Outputable.empty+  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras+  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]+  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]+  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,+                                                ppr_id_extras_s stuff]+  ppr (IfaceClassExtras fix insts anns stuff defms) =+    vcat [ppr fix, ppr_insts insts, ppr anns,+          ppr_id_extras_s stuff, ppr defms]++ppr_insts :: [IfaceInstABI] -> SDoc+ppr_insts _ = text "<insts>"++ppr_id_extras_s :: [IfaceIdExtras] -> SDoc+ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)++ppr_id_extras :: IfaceIdExtras -> SDoc+ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)++-- This instance is used only to compute fingerprints+instance Binary IfaceDeclExtras where+  get _bh = panic "no get for IfaceDeclExtras"+  put_ bh (IfaceIdExtras extras) = do+   putByte bh 1; put_ bh extras+  put_ bh (IfaceDataExtras fix insts anns cons) = do+   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons+  put_ bh (IfaceClassExtras fix insts anns methods defms) = do+   putByte bh 3+   put_ bh fix+   put_ bh insts+   put_ bh anns+   put_ bh methods+   put_ bh defms+  put_ bh (IfaceSynonymExtras fix anns) = do+   putByte bh 4; put_ bh fix; put_ bh anns+  put_ bh (IfaceFamilyExtras fix finsts anns) = do+   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns+  put_ bh IfaceOtherDeclExtras = putByte bh 6++instance Binary IfaceIdExtras where+  get _bh = panic "no get for IfaceIdExtras"+  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }++declExtras :: (OccName -> Maybe Fixity)+           -> (OccName -> [AnnPayload])+           -> OccEnv [IfaceRule]+           -> OccEnv [IfaceClsInst]+           -> OccEnv [IfaceFamInst]+           -> OccEnv IfExtName          -- lookup default method names+           -> IfaceDecl+           -> IfaceDeclExtras++declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl+  = case decl of+      IfaceId{} -> IfaceIdExtras (id_extras n)+      IfaceData{ifCons=cons} ->+                     IfaceDataExtras (fix_fn n)+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) +++                         map ifDFun         (lookupOccEnvL inst_env n))+                        (ann_fn n)+                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))+      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->+                     IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms+          where+            insts = (map ifDFun $ (concatMap at_extras ats)+                                    ++ lookupOccEnvL inst_env n)+                           -- Include instances of the associated types+                           -- as well as instances of the class (#5147)+            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]+            -- Names of all the default methods (see Note [default method Name])+            defms = [ dmName+                    | IfaceClassOp bndr _ (Just _) <- sigs+                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)+                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]+      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)+                                           (ann_fn n)+      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))+                        (ann_fn n)+      _other -> IfaceOtherDeclExtras+  where+        n = getOccName decl+        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)+        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)+++{- Note [default method Name] (see also #15970)++The Names for the default methods aren't available in Iface syntax.++* We originally start with a DefMethInfo from the class, contain a+  Name for the default method++* We turn that into Iface syntax as a DefMethSpec which lacks a Name+  entirely. Why? Because the Name can be derived from the method name+  (in GHC.IfaceToCore), so doesn't need to be serialised into the interface+  file.++But now we have to get the Name back, because the class declaration's+fingerprint needs to depend on it (this was the bug in #15970).  This+is done in a slightly convoluted way:++* Then, in addFingerprints we build a map that maps OccNames to Names++* We pass that map to declExtras which laboriously looks up in the map+  (using the derived occurrence name) to recover the Name we have just+  thrown away.+-}++lookupOccEnvL :: OccEnv [v] -> OccName -> [v]+lookupOccEnvL env k = lookupOccEnv env k `orElse` []++{-+-- for testing: use the md5sum command to generate fingerprints and+-- compare the results against our built-in version.+  fp' <- oldMD5 dflags bh+  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')+               else return fp++oldMD5 dflags bh = do+  tmp <- newTempName dflags CurrentModule "bin"+  writeBinMem bh tmp+  tmp2 <- newTempName dflags CurrentModule "md5"+  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2+  r <- system cmd+  case r of+    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)+    ExitSuccess -> do+        hash_str <- readFile tmp2+        return $! readHexFingerprint hash_str+-}++----------------------+-- mkOrphMap partitions instance decls or rules into+--      (a) an OccEnv for ones that are not orphans,+--          mapping the local OccName to a list of its decls+--      (b) a list of orphan decls+mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl+          -> [decl]             -- Sorted into canonical order+          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;+                                --      each sublist in canonical order+              [decl])           -- Orphan decls; in canonical order+mkOrphMap get_key decls+  = foldl' go (emptyOccEnv, []) decls+  where+    go (non_orphs, orphs) d+        | NotOrphan occ <- get_key d+        = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)+        | otherwise = (non_orphs, d:orphs)++-- -----------------------------------------------------------------------------+-- Look up parents and versions of Names++-- This is like a global version of the mi_hash_fn field in each ModIface.+-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get+-- the parent and version info.++mkHashFun+        :: HscEnv                       -- needed to look up versions+        -> ExternalPackageState         -- ditto+        -> (Name -> IO Fingerprint)+mkHashFun hsc_env eps name+  | isHoleModule orig_mod+  = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))+  | otherwise+  = lookup orig_mod+  where+      dflags = hsc_dflags hsc_env+      hpt = hsc_HPT hsc_env+      pit = eps_PIT eps+      occ = nameOccName name+      orig_mod = nameModule name+      lookup mod = do+        MASSERT2( isExternalName name, ppr name )+        iface <- case lookupIfaceByModule hpt pit mod of+                  Just iface -> return iface+                  Nothing -> do+                      -- This can occur when we're writing out ifaces for+                      -- requirements; we didn't do any /real/ typechecking+                      -- so there's no guarantee everything is loaded.+                      -- Kind of a heinous hack.+                      iface <- initIfaceLoad hsc_env . withException+                            $ loadInterface (text "lookupVers2") mod ImportBySystem+                      return iface+        return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`+                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))+++-- | Creates cached lookup for the 'mi_anns' field of ModIface+-- Hackily, we use "module" as the OccName for any module-level annotations+mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]+mkIfaceAnnCache anns+  = \n -> lookupOccEnv env n `orElse` []+  where+    pair (IfaceAnnotation target value) =+      (case target of+          NamedTarget occn -> occn+          ModuleTarget _   -> mkVarOcc "module"+      , [value])+    -- flipping (++), so the first argument is always short+    env = mkOccEnv_C (flip (++)) (map pair anns)
compiler/GHC/Iface/Rename.hs view
@@ -19,22 +19,22 @@  import GhcPrelude -import SrcLoc+import GHC.Types.SrcLoc import Outputable import GHC.Driver.Types-import Module-import UniqFM-import Avail+import GHC.Types.Module+import GHC.Types.Unique.FM+import GHC.Types.Avail import GHC.Iface.Syntax-import FieldLabel-import Var+import GHC.Types.FieldLabel+import GHC.Types.Var import ErrUtils -import Name+import GHC.Types.Name import TcRnMonad import Util import Fingerprint-import BasicTypes+import GHC.Types.Basic  -- a bit vexing import {-# SOURCE #-} GHC.Iface.Load
compiler/GHC/Iface/Tidy.hs view
@@ -22,40 +22,40 @@ import GHC.Core.Unfold import GHC.Core.FVs import GHC.Core.Op.Tidy-import CoreMonad+import GHC.Core.Op.Monad import GHC.Core.Stats   (coreBindsStats, CoreStats(..)) import GHC.Core.Seq     (seqBinds) import GHC.Core.Lint import GHC.Core.Rules-import PatSyn-import ConLike+import GHC.Core.PatSyn+import GHC.Core.ConLike import GHC.Core.Arity   ( exprArity, exprBotStrictness_maybe ) import StaticPtrTable-import VarEnv-import VarSet-import Var-import Id-import MkId             ( mkDictSelRhs )-import IdInfo-import InstEnv-import Type             ( tidyTopType )-import Demand           ( appIsBottom, isTopSig, isBottomingSig )-import Cpr              ( mkCprSig, botCpr )-import BasicTypes-import Name hiding (varName)-import NameSet-import NameCache-import Avail+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Var+import GHC.Types.Id+import GHC.Types.Id.Make ( mkDictSelRhs )+import GHC.Types.Id.Info+import GHC.Core.InstEnv+import GHC.Core.Type     ( tidyTopType )+import GHC.Types.Demand  ( appIsBottom, isTopSig, isBottomingSig )+import GHC.Types.Cpr     ( mkCprSig, botCpr )+import GHC.Types.Basic+import GHC.Types.Name hiding (varName)+import GHC.Types.Name.Set+import GHC.Types.Name.Cache+import GHC.Types.Avail import GHC.Iface.Env import TcEnv import TcRnMonad-import DataCon-import TyCon-import Class-import Module+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Core.Class+import GHC.Types.Module import GHC.Driver.Types import Maybes-import UniqSupply+import GHC.Types.Unique.Supply import Outputable import Util( filterOut ) import qualified ErrUtils as Err@@ -317,6 +317,28 @@ Finally, substitute these new top-level binders consistently throughout, including in unfoldings.  We also tidy binders in RHSs, so that they print nicely in interfaces.++Note [Always expose compulsory unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must make absolutely sure that unsafeCoerce# is inlined. You might+think that giving it a compulsory unfolding is enough. However,+unsafeCoerce# is put in an interface file just like any other definition.+So, unless we take special precuations+- If we compiled Unsafe.Coerce with -O0, we might not put the unfolding+  into the interface file.+- If we compile a module M, that imports Unsafe.Coerce, with -O0 we might+  not read the unfolding out of the interface file.++So we need to take care, to ensure that Compulsory unfoldings are written+and read.  That makes sense: they are compulsory, after all. There are+three places this is actioned:++* GHC.Iface.Tidy.addExternal.  Export end: expose compulsory+  unfoldings, even with -O0.++* GHC.IfaceToCore.tcIdInfo.  Import end: when reading in from+  interface file, even with -O0 (fignore-interface-pragmas.)  we must+  load a compulsory unfolding -}  tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)@@ -379,7 +401,7 @@               -- exported Ids and things needed from them, which saves space               --               -- See Note [Don't attempt to trim data types]-              ; final_ids  = [ if omit_prags then trimId id else id+              ; final_ids  = [ trimId omit_prags id                              | id <- bindersOfBinds tidy_binds                              , isExternalName (idName id)                              , not (isWiredIn id)@@ -450,19 +472,21 @@     dflags = hsc_dflags hsc_env  ---------------------------trimId :: Id -> Id-trimId id-  | not (isImplicitId id)-  = id `setIdInfo` vanillaIdInfo-       `setIdUnfolding` unfolding-  | otherwise+trimId :: Bool -> Id -> Id+-- With -O0 we now trim off the arity, one-shot-ness, strictness+-- etc which tidyTopIdInfo retains for the benefit of the code generator+-- but which we don't want in the interface file or ModIface for+-- downstream compilations+trimId omit_prags id+  | omit_prags, not (isImplicitId id)+  = id `setIdInfo`      vanillaIdInfo+       `setIdUnfolding` idUnfolding id+       -- We respect the final unfolding chosen by tidyTopIdInfo.+       -- We have already trimmed it if we don't want it for -O0;+       -- see also Note [Always expose compulsory unfoldings]++  | otherwise   -- No trimming   = id-  where-    unfolding-      | isCompulsoryUnfolding (idUnfolding id)-      = idUnfolding id-      | otherwise-      = noUnfolding  {- Note [Drop wired-in things] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -557,7 +581,7 @@  getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc-  | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in MkId+  | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make   | otherwise     = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))  getClassImplicitBinds :: Class -> [CoreBind]@@ -663,9 +687,7 @@     | otherwise = do       (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc       let-          (new_ids, show_unfold)-                | omit_prags = ([], False)-                | otherwise  = addExternal expose_all refined_id+          (new_ids, show_unfold) = addExternal omit_prags expose_all refined_id                  -- 'idocc' is an *occurrence*, but we need to see the                 -- unfolding in the *definition*; so look up in binder_set@@ -687,12 +709,21 @@       let unfold_env' = extendVarEnv unfold_env id (name',False)       tidy_internal ids unfold_env' occ_env' -addExternal :: Bool -> Id -> ([Id], Bool)-addExternal expose_all id = (new_needed_ids, show_unfold)+addExternal :: Bool -> Bool -> Id -> ([Id], Bool)+addExternal omit_prags expose_all id+  | omit_prags+  , not (isCompulsoryUnfolding unfolding)+  = ([], False)  -- See Note [Always expose compulsory unfoldings]+                 -- in GHC.HsToCore++  | otherwise+  = (new_needed_ids, show_unfold)+   where     new_needed_ids = bndrFvsInOrder show_unfold id     idinfo         = idInfo id-    show_unfold    = show_unfolding (unfoldingInfo idinfo)+    unfolding      = unfoldingInfo idinfo+    show_unfold    = show_unfolding unfolding     never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))     loop_breaker   = isStrongLoopBreaker (occInfo idinfo)     bottoming_fn   = isBottomingSig (strictnessInfo idinfo)@@ -865,7 +896,7 @@ purely speculative, and meanwhile the code is taking up space and codegen time.  I found that binary sizes jumped by 6-10% when I started to specialise INLINE functions (again, Note [Inline-specialisations] in Specialise).+specialisations] in GHC.Core.Op.Specialise).  So it seems better to drop the binding for f_spec, and the rule itself, if the auto-generated rule is the *only* reason that it is@@ -873,8 +904,8 @@  (The RULE still might have been useful in the past; that is, it was the right thing to have generated it in the first place.  See Note-[Inline specialisations] in Specialise.  But now it has served its-purpose, and can be discarded.)+[Inline specialisations] in GHC.Core.Op.Specialise. But now it has+served its purpose, and can be discarded.)  So findExternalRules does this:   * Remove all bindings that are kept alive *only* by isAutoRule rules@@ -1222,7 +1253,8 @@     --    the function returns bottom     -- In this case, show_unfold will be false (we don't expose unfoldings     -- for bottoming functions), but we might still have a worker/wrapper-    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs+    -- split (see Note [Worker-wrapper for bottoming functions] in+    -- GHC.Core.Op.WorkWrap)       --------- Arity ------------@@ -1318,7 +1350,7 @@    | null data_cons              -- Ditto if there are no data constructors   = True                        -- (NB: empty data types do not count as enumerations-                                -- see Note [Enumeration types] in TyCon+                                -- see Note [Enumeration types] in GHC.Core.TyCon    | any exported_con data_cons  -- Expose rep if any datacon or field is exported   = True
− compiler/GHC/Iface/Utils.hs 
@@ -1,2095 +0,0 @@-{--(c) The University of Glasgow 2006-2008-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998--}--{-# LANGUAGE CPP, NondecreasingIndentation #-}-{-# LANGUAGE MultiWayIf #-}---- | Module for constructing @ModIface@ values (interface files),--- writing them to disk and comparing two versions to see if--- recompilation is required.-module GHC.Iface.Utils (-        mkPartialIface,-        mkFullIface,--        mkIfaceTc,--        writeIfaceFile, -- Write the interface file--        checkOldIface,  -- See if recompilation is required, by-                        -- comparing version information-        RecompileRequired(..), recompileRequired,-        mkIfaceExports,--        coAxiomToIfaceDecl,-        tyThingToIfaceDecl -- Converting things to their Iface equivalents- ) where--{--  ------------------------------------------------          Recompilation checking-  -------------------------------------------------A complete description of how recompilation checking works can be-found in the wiki commentary:-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance--Please read the above page for a top-down description of how this all-works.  Notes below cover specific issues related to the implementation.--Basic idea:--  * In the mi_usages information in an interface, we record the-    fingerprint of each free variable of the module--  * In mkIface, we compute the fingerprint of each exported thing A.f.-    For each external thing that A.f refers to, we include the fingerprint-    of the external reference when computing the fingerprint of A.f.  So-    if anything that A.f depends on changes, then A.f's fingerprint will-    change.-    Also record any dependent files added with-      * addDependentFile-      * #include-      * -optP-include--  * In checkOldIface we compare the mi_usages for the module with-    the actual fingerprint for all each thing recorded in mi_usages--}--#include "HsVersions.h"--import GhcPrelude--import GHC.Iface.Syntax-import BinFingerprint-import GHC.Iface.Load-import GHC.CoreToIface-import FlagChecker--import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )-import Id-import Annotations-import GHC.Core-import Class-import TyCon-import CoAxiom-import ConLike-import DataCon-import Type-import TcType-import InstEnv-import FamInstEnv-import TcRnMonad-import GHC.Hs-import GHC.Driver.Types-import GHC.Driver.Finder-import GHC.Driver.Session-import VarEnv-import Var-import Name-import Avail-import RdrName-import NameEnv-import NameSet-import Module-import GHC.Iface.Binary-import ErrUtils-import Digraph-import SrcLoc-import Outputable-import BasicTypes       hiding ( SuccessFlag(..) )-import Unique-import Util             hiding ( eqListBy )-import FastString-import Maybes-import Binary-import Fingerprint-import Exception-import UniqSet-import GHC.Driver.Packages-import GHC.HsToCore.Docs--import Control.Monad-import Data.Function-import Data.List (find, findIndex, mapAccumL, sortBy, sort)-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Ord-import Data.IORef-import System.Directory-import System.FilePath-import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..),-                 pluginRecompile', plugins )----Qualified import so we can define a Semigroup instance--- but it doesn't clash with Outputable.<>-import qualified Data.Semigroup--{--************************************************************************-*                                                                      *-\subsection{Completing an interface}-*                                                                      *-************************************************************************--}--mkPartialIface :: HscEnv-               -> ModDetails-               -> ModGuts-               -> PartialModIface-mkPartialIface hsc_env mod_details-  ModGuts{ mg_module       = this_mod-         , mg_hsc_src      = hsc_src-         , mg_usages       = usages-         , mg_used_th      = used_th-         , mg_deps         = deps-         , mg_rdr_env      = rdr_env-         , mg_fix_env      = fix_env-         , mg_warns        = warns-         , mg_hpc_info     = hpc_info-         , mg_safe_haskell = safe_mode-         , mg_trust_pkg    = self_trust-         , mg_doc_hdr      = doc_hdr-         , mg_decl_docs    = decl_docs-         , mg_arg_docs     = arg_docs-         }-  = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust-             safe_mode usages doc_hdr decl_docs arg_docs mod_details---- | Fully instantiate a interface--- Adds fingerprints and potentially code generator produced information.-mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface-mkFullIface hsc_env partial_iface mb_non_cafs = do-    let decls-          | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)-          = mi_decls partial_iface-          | otherwise-          = updateDeclCafInfos (mi_decls partial_iface) mb_non_cafs--    full_iface <--      {-# SCC "addFingerprints" #-}-      addFingerprints hsc_env partial_iface{ mi_decls = decls }--    -- Debug printing-    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)--    return full_iface--updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl]-updateDeclCafInfos decls Nothing = decls-updateDeclCafInfos decls (Just non_cafs) = map update_decl decls-  where-    update_decl decl-      | IfaceId nm ty details infos <- decl-      , elemNameSet nm non_cafs-      = IfaceId nm ty details (HsNoCafRefs : infos)-      | otherwise-      = decl---- | Make an interface from the results of typechecking only.  Useful--- for non-optimising compilation, or where we aren't generating any--- object code at all ('HscNothing').-mkIfaceTc :: HscEnv-          -> SafeHaskellMode    -- The safe haskell mode-          -> ModDetails         -- gotten from mkBootModDetails, probably-          -> TcGblEnv           -- Usages, deprecations, etc-          -> IO ModIface-mkIfaceTc hsc_env safe_mode mod_details-  tc_result@TcGblEnv{ tcg_mod = this_mod,-                      tcg_src = hsc_src,-                      tcg_imports = imports,-                      tcg_rdr_env = rdr_env,-                      tcg_fix_env = fix_env,-                      tcg_merged = merged,-                      tcg_warns = warns,-                      tcg_hpc = other_hpc_info,-                      tcg_th_splice_used = tc_splice_used,-                      tcg_dependent_files = dependent_files-                    }-  = do-          let used_names = mkUsedNames tc_result-          let pluginModules =-                map lpModule (cachedPlugins (hsc_dflags hsc_env))-          deps <- mkDependencies-                    (thisInstalledUnitId (hsc_dflags hsc_env))-                    (map mi_module pluginModules) tc_result-          let hpc_info = emptyHpcInfo other_hpc_info-          used_th <- readIORef tc_splice_used-          dep_files <- (readIORef dependent_files)-          -- 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-          -- module is something we want to record dependencies for,-          -- 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 (imp_mods imports) used_names-                      dep_files merged pluginModules--          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result--          let partial_iface = mkIface_ hsc_env-                   this_mod hsc_src-                   used_th deps rdr_env-                   fix_env warns hpc_info-                   (imp_trust_own_pkg imports) safe_mode usages-                   doc_hdr' doc_map arg_map-                   mod_details--          mkFullIface hsc_env partial_iface Nothing--mkIface_ :: HscEnv -> Module -> HscSource-         -> Bool -> Dependencies -> GlobalRdrEnv-         -> NameEnv FixItem -> Warnings -> HpcInfo-         -> Bool-         -> SafeHaskellMode-         -> [Usage]-         -> Maybe HsDocString-         -> DeclDocMap-         -> ArgDocMap-         -> ModDetails-         -> PartialModIface-mkIface_ hsc_env-         this_mod hsc_src used_th deps rdr_env fix_env src_warns-         hpc_info pkg_trust_req safe_mode usages-         doc_hdr decl_docs arg_docs-         ModDetails{  md_insts     = insts,-                      md_fam_insts = fam_insts,-                      md_rules     = rules,-                      md_anns      = anns,-                      md_types     = type_env,-                      md_exports   = exports,-                      md_complete_sigs = complete_sigs }--- NB:  notice that mkIface does not look at the bindings---      only at the TypeEnv.  The previous Tidy phase has---      put exactly the info into the TypeEnv that we want---      to expose in the interface--  = do-    let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)-        entities = typeEnvElts type_env-        decls  = [ tyThingToIfaceDecl entity-                 | entity <- entities,-                   let name = getName entity,-                   not (isImplicitTyThing entity),-                      -- No implicit Ids and class tycons in the interface file-                   not (isWiredInName name),-                      -- Nor wired-in things; the compiler knows about them anyhow-                   nameIsLocalOrFrom semantic_mod name  ]-                      -- Sigh: see Note [Root-main Id] in TcRnDriver-                      -- NB: ABSOLUTELY need to check against semantic_mod,-                      -- because all of the names in an hsig p[H=<H>]:H-                      -- are going to be for <H>, not the former id!-                      -- See Note [Identity versus semantic module]--        fixities    = sortBy (comparing fst)-          [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]-          -- The order of fixities returned from nameEnvElts is not-          -- deterministic, so we sort by OccName to canonicalize it.-          -- See Note [Deterministic UniqFM] in UniqDFM for more details.-        warns       = src_warns-        iface_rules = map coreRuleToIfaceRule rules-        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts-        iface_fam_insts = map famInstToIfaceFamInst fam_insts-        trust_info  = setSafeMode safe_mode-        annotations = map mkIfaceAnnotation anns-        icomplete_sigs = map mkIfaceCompleteSig complete_sigs--    ModIface {-          mi_module      = this_mod,-          -- Need to record this because it depends on the -instantiated-with flag-          -- which could change-          mi_sig_of      = if semantic_mod == this_mod-                            then Nothing-                            else Just semantic_mod,-          mi_hsc_src     = hsc_src,-          mi_deps        = deps,-          mi_usages      = usages,-          mi_exports     = mkIfaceExports exports,--          -- Sort these lexicographically, so that-          -- the result is stable across compilations-          mi_insts       = sortBy cmp_inst     iface_insts,-          mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,-          mi_rules       = sortBy cmp_rule     iface_rules,--          mi_fixities    = fixities,-          mi_warns       = warns,-          mi_anns        = annotations,-          mi_globals     = maybeGlobalRdrEnv rdr_env,-          mi_used_th     = used_th,-          mi_decls       = decls,-          mi_hpc         = isHpcUsed hpc_info,-          mi_trust       = trust_info,-          mi_trust_pkg   = pkg_trust_req,-          mi_complete_sigs = icomplete_sigs,-          mi_doc_hdr     = doc_hdr,-          mi_decl_docs   = decl_docs,-          mi_arg_docs    = arg_docs,-          mi_final_exts  = () }-  where-     cmp_rule     = comparing ifRuleName-     -- Compare these lexicographically by OccName, *not* by unique,-     -- because the latter is not stable across compilations:-     cmp_inst     = comparing (nameOccName . ifDFun)-     cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)--     dflags = hsc_dflags hsc_env--     -- We only fill in mi_globals if the module was compiled to byte-     -- code.  Otherwise, the compiler may not have retained all the-     -- top-level bindings and they won't be in the TypeEnv (see-     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used-     -- by GHCi to decide whether the module has its full top-level-     -- scope available. (#5534)-     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv-     maybeGlobalRdrEnv rdr_env-         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env-         | otherwise                                   = Nothing--     ifFamInstTcName = ifFamInstFam--------------------------------writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()-writeIfaceFile dflags hi_file_path new_iface-    = do createDirectoryIfMissing True (takeDirectory hi_file_path)-         writeBinIface dflags hi_file_path new_iface----- -------------------------------------------------------------------------------- Look up parents and versions of Names---- This is like a global version of the mi_hash_fn field in each ModIface.--- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get--- the parent and version info.--mkHashFun-        :: HscEnv                       -- needed to look up versions-        -> ExternalPackageState         -- ditto-        -> (Name -> IO Fingerprint)-mkHashFun hsc_env eps name-  | isHoleModule orig_mod-  = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))-  | otherwise-  = lookup orig_mod-  where-      dflags = hsc_dflags hsc_env-      hpt = hsc_HPT hsc_env-      pit = eps_PIT eps-      occ = nameOccName name-      orig_mod = nameModule name-      lookup mod = do-        MASSERT2( isExternalName name, ppr name )-        iface <- case lookupIfaceByModule hpt pit mod of-                  Just iface -> return iface-                  Nothing -> do-                      -- This can occur when we're writing out ifaces for-                      -- requirements; we didn't do any /real/ typechecking-                      -- so there's no guarantee everything is loaded.-                      -- Kind of a heinous hack.-                      iface <- initIfaceLoad hsc_env . withException-                            $ loadInterface (text "lookupVers2") mod ImportBySystem-                      return iface-        return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`-                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))---- ------------------------------------------------------------------------------ Compute fingerprints for the interface--{--Note [Fingerprinting IfaceDecls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The general idea here is that we first examine the 'IfaceDecl's and determine-the recursive groups of them. We then walk these groups in dependency order,-serializing each contained 'IfaceDecl' to a "Binary" buffer which we then-hash using MD5 to produce a fingerprint for the group.--However, the serialization that we use is a bit funny: we override the @putName@-operation with our own which serializes the hash of a 'Name' instead of the-'Name' itself. This ensures that the fingerprint of a decl changes if anything-in its transitive closure changes. This trick is why we must be careful about-traversing in dependency order: we need to ensure that we have hashes for-everything referenced by the decl which we are fingerprinting.--Moreover, we need to be careful to distinguish between serialization of binding-Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls-field of a IfaceClsInst): only in the non-binding case should we include the-fingerprint; in the binding case we shouldn't since it is merely the name of the-thing that we are currently fingerprinting.--}---- | Add fingerprints for top-level declarations to a 'ModIface'.------ See Note [Fingerprinting IfaceDecls]-addFingerprints-        :: HscEnv-        -> PartialModIface-        -> IO ModIface-addFingerprints hsc_env iface0- = do-   eps <- hscEPS hsc_env-   let-       decls = mi_decls iface0-       warn_fn = mkIfaceWarnCache (mi_warns iface0)-       fix_fn = mkIfaceFixCache (mi_fixities iface0)--        -- The ABI of a declaration represents everything that is made-        -- visible about the declaration that a client can depend on.-        -- see IfaceDeclABI below.-       declABI :: IfaceDecl -> IfaceDeclABI-       -- TODO: I'm not sure if this should be semantic_mod or this_mod.-       -- See also Note [Identity versus semantic module]-       declABI decl = (this_mod, decl, extras)-        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts-                                  non_orph_fis top_lvl_name_env decl--       -- This is used for looking up the Name of a default method-       -- from its OccName. See Note [default method Name]-       top_lvl_name_env =-         mkOccEnv [ (nameOccName nm, nm)-                  | IfaceId { ifName = nm } <- decls ]--       -- Dependency edges between declarations in the current module.-       -- This is computed by finding the free external names of each-       -- declaration, including IfaceDeclExtras (things that a-       -- declaration implicitly depends on).-       edges :: [ Node Unique IfaceDeclABI ]-       edges = [ DigraphNode abi (getUnique (getOccName decl)) out-               | decl <- decls-               , let abi = declABI decl-               , let out = localOccs $ freeNamesDeclABI abi-               ]--       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n-       localOccs =-         map (getUnique . getParent . getOccName)-                        -- NB: names always use semantic module, so-                        -- filtering must be on the semantic module!-                        -- See Note [Identity versus semantic module]-                        . filter ((== semantic_mod) . name_module)-                        . nonDetEltsUniqSet-                   -- It's OK to use nonDetEltsUFM as localOccs is only-                   -- used to construct the edges and-                   -- stronglyConnCompFromEdgedVertices is deterministic-                   -- even with non-deterministic order of edges as-                   -- explained in Note [Deterministic SCC] in Digraph.-          where getParent :: OccName -> OccName-                getParent occ = lookupOccEnv parent_map occ `orElse` occ--        -- maps OccNames to their parents in the current module.-        -- e.g. a reference to a constructor must be turned into a reference-        -- to the TyCon for the purposes of calculating dependencies.-       parent_map :: OccEnv OccName-       parent_map = foldl' extend emptyOccEnv decls-          where extend env d =-                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]-                  where n = getOccName d--        -- Strongly-connected groups of declarations, in dependency order-       groups :: [SCC IfaceDeclABI]-       groups = stronglyConnCompFromEdgedVerticesUniq edges--       global_hash_fn = mkHashFun hsc_env eps--        -- How to output Names when generating the data to fingerprint.-        -- Here we want to output the fingerprint for each top-level-        -- Name, whether it comes from the current module or another-        -- module.  In this way, the fingerprint for a declaration will-        -- change if the fingerprint for anything it refers to (transitively)-        -- changes.-       mk_put_name :: OccEnv (OccName,Fingerprint)-                   -> BinHandle -> Name -> IO  ()-       mk_put_name local_env bh name-          | isWiredInName name  =  putNameLiterally bh name-           -- wired-in names don't have fingerprints-          | otherwise-          = ASSERT2( isExternalName name, ppr name )-            let hash | nameModule name /= semantic_mod =  global_hash_fn name-                     -- Get it from the REAL interface!!-                     -- This will trigger when we compile an hsig file-                     -- and we know a backing impl for it.-                     -- See Note [Identity versus semantic module]-                     | semantic_mod /= this_mod-                     , not (isHoleModule semantic_mod) = global_hash_fn name-                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)-                           `orElse` pprPanic "urk! lookup local fingerprint"-                                       (ppr name $$ ppr local_env)))-                -- This panic indicates that we got the dependency-                -- analysis wrong, because we needed a fingerprint for-                -- an entity that wasn't in the environment.  To debug-                -- it, turn the panic into a trace, uncomment the-                -- pprTraces below, run the compile again, and inspect-                -- the output and the generated .hi file with-                -- --show-iface.-            in hash >>= put_ bh--        -- take a strongly-connected group of declarations and compute-        -- its fingerprint.--       fingerprint_group :: (OccEnv (OccName,Fingerprint),-                             [(Fingerprint,IfaceDecl)])-                         -> SCC IfaceDeclABI-                         -> IO (OccEnv (OccName,Fingerprint),-                                [(Fingerprint,IfaceDecl)])--       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)-          = do let hash_fn = mk_put_name local_env-                   decl = abiDecl abi-               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do-               hash <- computeFingerprint hash_fn abi-               env' <- extend_hash_env local_env (hash,decl)-               return (env', (hash,decl) : decls_w_hashes)--       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)-          = do let decls = map abiDecl abis-               local_env1 <- foldM extend_hash_env local_env-                                   (zip (repeat fingerprint0) decls)-               let hash_fn = mk_put_name local_env1-               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do-               let stable_abis = sortBy cmp_abiNames abis-                -- put the cycle in a canonical order-               hash <- computeFingerprint hash_fn stable_abis-               let pairs = zip (repeat hash) decls-               local_env2 <- foldM extend_hash_env local_env pairs-               return (local_env2, pairs ++ decls_w_hashes)--       -- we have fingerprinted the whole declaration, but we now need-       -- to assign fingerprints to all the OccNames that it binds, to-       -- use when referencing those OccNames in later declarations.-       ---       extend_hash_env :: OccEnv (OccName,Fingerprint)-                       -> (Fingerprint,IfaceDecl)-                       -> IO (OccEnv (OccName,Fingerprint))-       extend_hash_env env0 (hash,d) = do-          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0-                 (ifaceDeclFingerprints hash d))--   ---   (local_env, decls_w_hashes) <--       foldM fingerprint_group (emptyOccEnv, []) groups--   -- when calculating fingerprints, we always need to use canonical-   -- ordering for lists of things.  In particular, the mi_deps has various-   -- lists of modules and suchlike, so put these all in canonical order:-   let sorted_deps = sortDependencies (mi_deps iface0)--   -- The export hash of a module depends on the orphan hashes of the-   -- orphan modules below us in the dependency tree.  This is the way-   -- that changes in orphans get propagated all the way up the-   -- dependency tree.-   ---   -- Note [A bad dep_orphs optimization]-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   -- In a previous version of this code, we filtered out orphan modules which-   -- were not from the home package, justifying it by saying that "we'd-   -- pick up the ABI hashes of the external module instead".  This is wrong.-   -- Suppose that we have:-   ---   --       module External where-   --           instance Show (a -> b)-   ---   --       module Home1 where-   --           import External-   ---   --       module Home2 where-   --           import Home1-   ---   -- The export hash of Home1 needs to reflect the orphan instances of-   -- External. It's true that Home1 will get rebuilt if the orphans-   -- of External, but we also need to make sure Home2 gets rebuilt-   -- as well.  See #12733 for more details.-   let orph_mods-        = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]-        $ dep_orphs sorted_deps-   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods--   -- Note [Do not update EPS with your own hi-boot]-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   -- (See also #10182).  When your hs-boot file includes an orphan-   -- instance declaration, you may find that the dep_orphs of a module you-   -- import contains reference to yourself.  DO NOT actually load this module-   -- or add it to the orphan hashes: you're going to provide the orphan-   -- instances yourself, no need to consult hs-boot; if you do load the-   -- interface into EPS, you will see a duplicate orphan instance.--   orphan_hash <- computeFingerprint (mk_put_name local_env)-                                     (map ifDFun orph_insts, orph_rules, orph_fis)--   -- the export list hash doesn't depend on the fingerprints of-   -- the Names it mentions, only the Names themselves, hence putNameLiterally.-   export_hash <- computeFingerprint putNameLiterally-                      (mi_exports iface0,-                       orphan_hash,-                       dep_orphan_hashes,-                       dep_pkgs (mi_deps iface0),-                       -- See Note [Export hash depends on non-orphan family instances]-                       dep_finsts (mi_deps iface0),-                        -- dep_pkgs: see "Package Version Changes" on-                        -- wiki/commentary/compiler/recompilation-avoidance-                       mi_trust iface0)-                        -- Make sure change of Safe Haskell mode causes recomp.--   -- Note [Export hash depends on non-orphan family instances]-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   ---   -- Suppose we have:-   ---   --   module A where-   --       type instance F Int = Bool-   ---   --   module B where-   --       import A-   ---   --   module C where-   --       import B-   ---   -- The family instance consistency check for C depends on the dep_finsts of-   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need-   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of-   -- the exports of B, because C always considers them when checking-   -- consistency.-   ---   -- A full discussion is in #12723.-   ---   -- We do NOT need to hash dep_orphs, because this is implied by-   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,-   -- because there is no eager consistency check as there is with type families-   -- (also we didn't store it anywhere!)-   ----   -- put the declarations in a canonical order, sorted by OccName-   let sorted_decls = Map.elems $ Map.fromList $-                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]--   -- the flag hash depends on:-   --   - (some of) dflags-   -- it returns two hashes, one that shouldn't change-   -- the abi hash and one that should-   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally--   opt_hash <- fingerprintOptFlags dflags putNameLiterally--   hpc_hash <- fingerprintHpcFlags dflags putNameLiterally--   plugin_hash <- fingerprintPlugins hsc_env--   -- the ABI hash depends on:-   --   - decls-   --   - export list-   --   - orphans-   --   - deprecations-   --   - flag abi hash-   mod_hash <- computeFingerprint putNameLiterally-                      (map fst sorted_decls,-                       export_hash,  -- includes orphan_hash-                       mi_warns iface0)--   -- The interface hash depends on:-   --   - the ABI hash, plus-   --   - the module level annotations,-   --   - usages-   --   - deps (home and external packages, dependent files)-   --   - hpc-   iface_hash <- computeFingerprint putNameLiterally-                      (mod_hash,-                       ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache-                       mi_usages iface0,-                       sorted_deps,-                       mi_hpc iface0)--   let-    final_iface_exts = ModIfaceBackend-      { mi_iface_hash  = iface_hash-      , mi_mod_hash    = mod_hash-      , mi_flag_hash   = flag_hash-      , mi_opt_hash    = opt_hash-      , mi_hpc_hash    = hpc_hash-      , mi_plugin_hash = plugin_hash-      , mi_orphan      = not (   all ifRuleAuto orph_rules-                                   -- See Note [Orphans and auto-generated rules]-                              && null orph_insts-                              && null orph_fis)-      , mi_finsts      = not (null (mi_fam_insts iface0))-      , mi_exp_hash    = export_hash-      , mi_orphan_hash = orphan_hash-      , mi_warn_fn     = warn_fn-      , mi_fix_fn      = fix_fn-      , mi_hash_fn     = lookupOccEnv local_env-      }-    final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts }-   ---   return final_iface--  where-    this_mod = mi_module iface0-    semantic_mod = mi_semantic_module iface0-    dflags = hsc_dflags hsc_env-    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)-    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)-    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)-    ann_fn = mkIfaceAnnCache (mi_anns iface0)---- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules--- (in particular, the orphan modules which are transitively imported by the--- current module).------ Q: Why do we need the hash at all, doesn't the list of transitively--- imported orphan modules suffice?------ A: If one of our transitive imports adds a new orphan instance, our--- export hash must change so that modules which import us rebuild.  If we just--- hashed the [Module], the hash would not change even when a new instance was--- added to a module that already had an orphan instance.------ Q: Why don't we just hash the orphan hashes of our direct dependencies?--- Why the full transitive closure?------ A: Suppose we have these modules:------      module A where---          instance Show (a -> b) where---      module B where---          import A -- **---      module C where---          import A---          import B------ Whether or not we add or remove the import to A in B affects the--- orphan hash of B.  But it shouldn't really affect the orphan hash--- of C.  If we hashed only direct dependencies, there would be no--- way to tell that the net effect was a wash, and we'd be forced--- to recompile C and everything else.-getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]-getOrphanHashes hsc_env mods = do-  eps <- hscEPS hsc_env-  let-    hpt        = hsc_HPT hsc_env-    pit        = eps_PIT eps-    get_orph_hash mod =-          case lookupIfaceByModule hpt pit mod of-            Just iface -> return (mi_orphan_hash (mi_final_exts iface))-            Nothing    -> do -- similar to 'mkHashFun'-                iface <- initIfaceLoad hsc_env . withException-                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem-                return (mi_orphan_hash (mi_final_exts iface))--  ---  mapM get_orph_hash mods---sortDependencies :: Dependencies -> Dependencies-sortDependencies d- = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),-          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),-          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),-          dep_finsts = sortBy stableModuleCmp (dep_finsts d),-          dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }---- | Creates cached lookup for the 'mi_anns' field of ModIface--- Hackily, we use "module" as the OccName for any module-level annotations-mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]-mkIfaceAnnCache anns-  = \n -> lookupOccEnv env n `orElse` []-  where-    pair (IfaceAnnotation target value) =-      (case target of-          NamedTarget occn -> occn-          ModuleTarget _   -> mkVarOcc "module"-      , [value])-    -- flipping (++), so the first argument is always short-    env = mkOccEnv_C (flip (++)) (map pair anns)--{--************************************************************************-*                                                                      *-          The ABI of an IfaceDecl-*                                                                      *-************************************************************************--Note [The ABI of an IfaceDecl]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The ABI of a declaration consists of:--   (a) the full name of the identifier (inc. module and package,-       because these are used to construct the symbol name by which-       the identifier is known externally).--   (b) the declaration itself, as exposed to clients.  That is, the-       definition of an Id is included in the fingerprint only if-       it is made available as an unfolding in the interface.--   (c) the fixity of the identifier (if it exists)-   (d) for Ids: rules-   (e) for classes: instances, fixity & rules for methods-   (f) for datatypes: instances, fixity & rules for constrs--Items (c)-(f) are not stored in the IfaceDecl, but instead appear-elsewhere in the interface file.  But they are *fingerprinted* with-the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,-and fingerprinting that as part of the declaration.--}--type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)--data IfaceDeclExtras-  = IfaceIdExtras IfaceIdExtras--  | IfaceDataExtras-       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)-       [IfaceInstABI]           -- Local class and family instances of this tycon-                                -- See Note [Orphans] in InstEnv-       [AnnPayload]             -- Annotations of the type itself-       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations--  | IfaceClassExtras-       (Maybe Fixity)           -- Fixity of the class itself (if it exists)-       [IfaceInstABI]           -- Local instances of this class *or*-                                --   of its associated data types-                                -- See Note [Orphans] in InstEnv-       [AnnPayload]             -- Annotations of the type itself-       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations-       [IfExtName]              -- Default methods. If a module-                                -- mentions a class, then it can-                                -- instantiate the class and thereby-                                -- use the default methods, so we must-                                -- include these in the fingerprint of-                                -- a class.--  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]--  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]--  | IfaceOtherDeclExtras--data IfaceIdExtras-  = IdExtras-       (Maybe Fixity)           -- Fixity of the Id (if it exists)-       [IfaceRule]              -- Rules for the Id-       [AnnPayload]             -- Annotations for the Id---- When hashing a class or family instance, we hash only the--- DFunId or CoAxiom, because that depends on all the--- information about the instance.----type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance--abiDecl :: IfaceDeclABI -> IfaceDecl-abiDecl (_, decl, _) = decl--cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering-cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`-                         getOccName (abiDecl abi2)--freeNamesDeclABI :: IfaceDeclABI -> NameSet-freeNamesDeclABI (_mod, decl, extras) =-  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras--freeNamesDeclExtras :: IfaceDeclExtras -> NameSet-freeNamesDeclExtras (IfaceIdExtras id_extras)-  = freeNamesIdExtras id_extras-freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)-  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)-freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)-  = unionNameSets $-      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs-freeNamesDeclExtras (IfaceSynonymExtras _ _)-  = emptyNameSet-freeNamesDeclExtras (IfaceFamilyExtras _ insts _)-  = mkNameSet insts-freeNamesDeclExtras IfaceOtherDeclExtras-  = emptyNameSet--freeNamesIdExtras :: IfaceIdExtras -> NameSet-freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)--instance Outputable IfaceDeclExtras where-  ppr IfaceOtherDeclExtras       = Outputable.empty-  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras-  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]-  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]-  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,-                                                ppr_id_extras_s stuff]-  ppr (IfaceClassExtras fix insts anns stuff defms) =-    vcat [ppr fix, ppr_insts insts, ppr anns,-          ppr_id_extras_s stuff, ppr defms]--ppr_insts :: [IfaceInstABI] -> SDoc-ppr_insts _ = text "<insts>"--ppr_id_extras_s :: [IfaceIdExtras] -> SDoc-ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)--ppr_id_extras :: IfaceIdExtras -> SDoc-ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)---- This instance is used only to compute fingerprints-instance Binary IfaceDeclExtras where-  get _bh = panic "no get for IfaceDeclExtras"-  put_ bh (IfaceIdExtras extras) = do-   putByte bh 1; put_ bh extras-  put_ bh (IfaceDataExtras fix insts anns cons) = do-   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons-  put_ bh (IfaceClassExtras fix insts anns methods defms) = do-   putByte bh 3-   put_ bh fix-   put_ bh insts-   put_ bh anns-   put_ bh methods-   put_ bh defms-  put_ bh (IfaceSynonymExtras fix anns) = do-   putByte bh 4; put_ bh fix; put_ bh anns-  put_ bh (IfaceFamilyExtras fix finsts anns) = do-   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns-  put_ bh IfaceOtherDeclExtras = putByte bh 6--instance Binary IfaceIdExtras where-  get _bh = panic "no get for IfaceIdExtras"-  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }--declExtras :: (OccName -> Maybe Fixity)-           -> (OccName -> [AnnPayload])-           -> OccEnv [IfaceRule]-           -> OccEnv [IfaceClsInst]-           -> OccEnv [IfaceFamInst]-           -> OccEnv IfExtName          -- lookup default method names-           -> IfaceDecl-           -> IfaceDeclExtras--declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl-  = case decl of-      IfaceId{} -> IfaceIdExtras (id_extras n)-      IfaceData{ifCons=cons} ->-                     IfaceDataExtras (fix_fn n)-                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++-                         map ifDFun         (lookupOccEnvL inst_env n))-                        (ann_fn n)-                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))-      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->-                     IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms-          where-            insts = (map ifDFun $ (concatMap at_extras ats)-                                    ++ lookupOccEnvL inst_env n)-                           -- Include instances of the associated types-                           -- as well as instances of the class (#5147)-            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]-            -- Names of all the default methods (see Note [default method Name])-            defms = [ dmName-                    | IfaceClassOp bndr _ (Just _) <- sigs-                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)-                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]-      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)-                                           (ann_fn n)-      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)-                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))-                        (ann_fn n)-      _other -> IfaceOtherDeclExtras-  where-        n = getOccName decl-        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)-        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)---{- Note [default method Name] (see also #15970)--The Names for the default methods aren't available in Iface syntax.--* We originally start with a DefMethInfo from the class, contain a-  Name for the default method--* We turn that into Iface syntax as a DefMethSpec which lacks a Name-  entirely. Why? Because the Name can be derived from the method name-  (in GHC.IfaceToCore), so doesn't need to be serialised into the interface-  file.--But now we have to get the Name back, because the class declaration's-fingerprint needs to depend on it (this was the bug in #15970).  This-is done in a slightly convoluted way:--* Then, in addFingerprints we build a map that maps OccNames to Names--* We pass that map to declExtras which laboriously looks up in the map-  (using the derived occurrence name) to recover the Name we have just-  thrown away.--}--lookupOccEnvL :: OccEnv [v] -> OccName -> [v]-lookupOccEnvL env k = lookupOccEnv env k `orElse` []--{---- for testing: use the md5sum command to generate fingerprints and--- compare the results against our built-in version.-  fp' <- oldMD5 dflags bh-  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')-               else return fp--oldMD5 dflags bh = do-  tmp <- newTempName dflags CurrentModule "bin"-  writeBinMem bh tmp-  tmp2 <- newTempName dflags CurrentModule "md5"-  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2-  r <- system cmd-  case r of-    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)-    ExitSuccess -> do-        hash_str <- readFile tmp2-        return $! readHexFingerprint hash_str--}--------------------------- mkOrphMap partitions instance decls or rules into---      (a) an OccEnv for ones that are not orphans,---          mapping the local OccName to a list of its decls---      (b) a list of orphan decls-mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl-          -> [decl]             -- Sorted into canonical order-          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;-                                --      each sublist in canonical order-              [decl])           -- Orphan decls; in canonical order-mkOrphMap get_key decls-  = foldl' go (emptyOccEnv, []) decls-  where-    go (non_orphs, orphs) d-        | NotOrphan occ <- get_key d-        = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)-        | otherwise = (non_orphs, d:orphs)--{--************************************************************************-*                                                                      *-       COMPLETE Pragmas-*                                                                      *-************************************************************************--}--mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch-mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc---{--************************************************************************-*                                                                      *-       Keeping track of what we've slurped, and fingerprints-*                                                                      *-************************************************************************--}---mkIfaceAnnotation :: Annotation -> IfaceAnnotation-mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })-  = IfaceAnnotation {-        ifAnnotatedTarget = fmap nameOccName target,-        ifAnnotatedValue = payload-    }--mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical-mkIfaceExports exports-  = sortBy stableAvailCmp (map sort_subs exports)-  where-    sort_subs :: AvailInfo -> AvailInfo-    sort_subs (Avail n) = Avail n-    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)-    sort_subs (AvailTC n (m:ms) fs)-       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)-       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)-       -- Maintain the AvailTC Invariant--    sort_flds = sortBy (stableNameCmp `on` flSelector)--{--Note [Original module]-~~~~~~~~~~~~~~~~~~~~~-Consider this:-        module X where { data family T }-        module Y( T(..) ) where { import X; data instance T Int = MkT Int }-The exported Avail from Y will look like-        X.T{X.T, Y.MkT}-That is, in Y,-  - only MkT is brought into scope by the data instance;-  - but the parent (used for grouping and naming in T(..) exports) is X.T-  - and in this case we export X.T too--In the result of mkIfaceExports, the names are grouped by defining module,-so we may need to split up a single Avail into multiple ones.--Note [Internal used_names]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Most of the used_names are External Names, but we can have Internal-Names too: see Note [Binders in Template Haskell] in Convert, and-#5362 for an example.  Such Names are always-  - Such Names are always for locally-defined things, for which we-    don't gather usage info, so we can just ignore them in ent_map-  - They are always System Names, hence the assert, just as a double check.---************************************************************************-*                                                                      *-        Load the old interface file for this module (unless-        we have it already), and check whether it is up to date-*                                                                      *-************************************************************************--}--data RecompileRequired-  = UpToDate-       -- ^ everything is up to date, recompilation is not required-  | MustCompile-       -- ^ The .hs file has been touched, or the .o/.hi file does not exist-  | RecompBecause String-       -- ^ 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 Semigroup RecompileRequired where-  UpToDate <> r = r-  mc <> _       = mc--instance Monoid RecompileRequired where-  mempty = UpToDate--recompileRequired :: RecompileRequired -> Bool-recompileRequired UpToDate = False-recompileRequired _ = True------ | 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.-checkOldIface-  :: HscEnv-  -> ModSummary-  -> SourceModified-  -> Maybe ModIface         -- Old interface from compilation manager, if any-  -> IO (RecompileRequired, Maybe ModIface)--checkOldIface hsc_env mod_summary source_modified maybe_iface-  = do  let dflags = hsc_dflags hsc_env-        showPass dflags $-            "Checking old interface for " ++-              (showPpr dflags $ ms_mod mod_summary) ++-              " (use -ddump-hi-diffs for more details)"-        initIfaceCheck (text "checkOldIface") hsc_env $-            check_old_iface hsc_env mod_summary source_modified maybe_iface--check_old_iface-  :: HscEnv-  -> ModSummary-  -> SourceModified-  -> Maybe ModIface-  -> IfG (RecompileRequired, Maybe ModIface)--check_old_iface hsc_env mod_summary src_modified maybe_iface-  = let dflags = hsc_dflags hsc_env-        getIface =-            case maybe_iface of-                Just _  -> do-                    traceIf (text "We already have the old interface for" <+>-                      ppr (ms_mod mod_summary))-                    return maybe_iface-                Nothing -> loadIface--        loadIface = do-             let iface_path = msHiFilePath mod_summary-             read_result <- readIface (ms_mod mod_summary) iface_path-             case read_result of-                 Failed err -> do-                     traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)-                     traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)-                     return Nothing-                 Succeeded iface -> do-                     traceIf (text "Read the interface file" <+> text iface_path)-                     return $ Just iface--        src_changed-            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True-            | SourceModified <- src_modified = True-            | otherwise = False-    in do-        when src_changed $-            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")--        case src_changed of-            -- If the source has changed and we're in interactive mode,-            -- avoid reading an interface; just return the one we might-            -- have been supplied with.-            True | not (isObjectTarget $ hscTarget dflags) ->-                return (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' <- getIface-                return (MustCompile, maybe_iface')--            False -> do-                maybe_iface' <- getIface-                case maybe_iface' of-                    -- We can't retrieve the iface-                    Nothing    -> return (MustCompile, Nothing)--                    -- We have got the old iface; check its versions-                    -- even in the SourceUnmodifiedAndStable case we-                    -- should check versions because some packages-                    -- might have changed or gone away.-                    Just iface -> checkVersions hsc_env mod_summary iface---- | Check if a module is still the same 'version'.------ This function is called in the recompilation checker after we have--- determined that the module M being checked hasn't had any changes--- to its source file since we last compiled M. So at this point in general--- two things may have changed that mean we should recompile M:---   * The interface export by a dependency of M has changed.---   * The compiler flags specified this time for M have changed---     in a manner that is significant for recompilation.--- We return not just if we should recompile the object file but also--- if we should rebuild the interface file.-checkVersions :: HscEnv-              -> ModSummary-              -> ModIface       -- Old interface-              -> IfG (RecompileRequired, Maybe ModIface)-checkVersions hsc_env mod_summary iface-  = do { traceHiDiffs (text "Considering whether compilation is required for" <+>-                        ppr (mi_module iface) <> colon)--       -- readIface will have verified that the InstalledUnitId matches,-       -- but we ALSO must make sure the instantiation matches up.  See-       -- test case bkpcabal04!-       ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)-            then return (RecompBecause "-this-unit-id changed", Nothing) else do {-       ; recomp <- checkFlagHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkOptimHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHpcHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkMergedSignatures mod_summary iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHsig mod_summary iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHie mod_summary-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkDependencies hsc_env mod_summary iface-       ; if recompileRequired recomp then return (recomp, Just iface) else do {-       ; recomp <- checkPlugins hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {---       -- Source code unchanged and no errors yet... carry on-       ---       -- First put the dependent-module info, read from the old-       -- interface, into the envt, so that when we look for-       -- interfaces we look for the right one (.hi or .hi-boot)-       ---       -- It's just temporary because either the usage check will succeed-       -- (in which case we are done with this module) or it'll fail (in which-       -- case we'll compile the module from scratch anyhow).-       ---       -- We do this regardless of compilation mode, although in --make mode-       -- all the dependent modules should be in the HPT already, so it's-       -- quite redundant-       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }-       ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]-       ; return (recomp, Just iface)-    }}}}}}}}}}-  where-    this_pkg = thisPackage (hsc_dflags hsc_env)-    -- This is a bit of a hack really-    mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)-    mod_deps = mkModDeps (dep_mods (mi_deps iface))---- | Check if any plugins are requesting recompilation-checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired-checkPlugins hsc iface = liftIO $ do-  new_fingerprint <- fingerprintPlugins hsc-  let old_fingerprint = mi_plugin_hash (mi_final_exts iface)-  pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))-  return $-    pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr--fingerprintPlugins :: HscEnv -> IO Fingerprint-fingerprintPlugins hsc_env = do-  fingerprintPlugins' $ plugins (hsc_dflags hsc_env)--fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint-fingerprintPlugins' plugins = do-  res <- mconcat <$> mapM pluginRecompile' plugins-  return $ case res of-      NoForceRecompile ->  fingerprintString "NoForceRecompile"-      ForceRecompile   -> fingerprintString "ForceRecompile"-      -- is the chance of collision worth worrying about?-      -- An alternative is to fingerprintFingerprints [fingerprintString-      -- "maybeRecompile", fp]-      (MaybeRecompile fp) -> fp---pluginRecompileToRecompileRequired-    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired-pluginRecompileToRecompileRequired old_fp new_fp pr-  | old_fp == new_fp =-    case pr of-      NoForceRecompile  -> UpToDate--      -- we already checked the fingerprint above so a mismatch is not possible-      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.-      MaybeRecompile _  -> UpToDate--      -- 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 "Impure plugin forced recompilation"--  | old_fp `elem` magic_fingerprints ||-    new_fp `elem` magic_fingerprints-    -- The fingerprints do not match either the old or new one is a magic-    -- fingerprint. This happens when non-pure plugins are added for the first-    -- time or when we go from one recompilation strategy to another: (force ->-    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)-    ---    -- For example when we go from 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 "Plugins changed"--  | otherwise =-    let reason = "Plugin fingerprint changed" in-    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 reason--      _                -> RecompBecause reason-- where-   magic_fingerprints =-       [ fingerprintString "NoForceRecompile"-       , fingerprintString "ForceRecompile"-       ]----- | Check if an hsig file needs recompilation because its--- implementing module has changed.-checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired-checkHsig mod_summary iface = do-    dflags <- getDynFlags-    let outer_mod = ms_mod mod_summary-        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)-    MASSERT( moduleUnitId outer_mod == thisPackage dflags )-    case inner_mod == mi_semantic_module iface of-        True -> up_to_date (text "implementing module unchanged")-        False -> return (RecompBecause "implementing module changed")---- | Check if @.hie@ file is out of date or missing.-checkHie :: ModSummary -> IfG RecompileRequired-checkHie mod_summary = do-    dflags <- getDynFlags-    let hie_date_opt = ms_hie_date mod_summary-        hs_date = ms_hs_date mod_summary-    pure $ case gopt Opt_WriteHie dflags of-               False -> UpToDate-               True -> case hie_date_opt of-                           Nothing -> RecompBecause "HIE file is missing"-                           Just hie_date-                               | hie_date < hs_date-                               -> RecompBecause "HIE file is out of date"-                               | otherwise-                               -> UpToDate---- | Check the flags haven't changed-checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired-checkFlagHash hsc_env iface = do-    let old_hash = mi_flag_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)-                                             (mi_module iface)-                                             putNameLiterally-    case old_hash == new_hash of-        True  -> up_to_date (text "Module flags unchanged")-        False -> out_of_date_hash "flags changed"-                     (text "  Module flags have changed")-                     old_hash new_hash---- | Check the optimisation flags haven't changed-checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired-checkOptimHash hsc_env iface = do-    let old_hash = mi_opt_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)-                                               putNameLiterally-    if | old_hash == new_hash-         -> up_to_date (text "Optimisation flags unchanged")-       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)-         -> up_to_date (text "Optimisation flags changed; ignoring")-       | otherwise-         -> out_of_date_hash "Optimisation flags changed"-                     (text "  Optimisation flags have changed")-                     old_hash new_hash---- | Check the HPC flags haven't changed-checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired-checkHpcHash hsc_env iface = do-    let old_hash = mi_hpc_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)-                                               putNameLiterally-    if | old_hash == new_hash-         -> up_to_date (text "HPC flags unchanged")-       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)-         -> up_to_date (text "HPC flags changed; ignoring")-       | otherwise-         -> out_of_date_hash "HPC flags changed"-                     (text "  HPC flags have changed")-                     old_hash new_hash---- Check that the set of signatures we are merging in match.--- If the -unit-id flags change, this can change too.-checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired-checkMergedSignatures mod_summary iface = do-    dflags <- getDynFlags-    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]-        new_merged = case Map.lookup (ms_mod_name mod_summary)-                                     (requirementContext (pkgState dflags)) of-                        Nothing -> []-                        Just r -> sort $ map (indefModuleToModule dflags) r-    if old_merged == new_merged-        then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)-        else return (RecompBecause "signatures to merge in changed")---- If the direct imports of this module are resolved to targets that--- are not among the dependencies of the previous interface file,--- then we definitely need to recompile.  This catches cases like---   - an exposed package has been upgraded---   - we are compiling with different package flags---   - a home module that was shadowing a package module has been removed---   - a new home module has been added that shadows a package module--- See bug #1372.------ In addition, we also check if the union of dependencies of the imported--- modules has any difference to the previous set of dependencies. We would need--- to recompile in that case also since the `mi_deps` field of ModIface needs--- to be updated to match that information. This is one of the invariants--- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).--- See bug #16511.------ Returns (RecompBecause <textual reason>) if recompilation is required.-checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired-checkDependencies hsc_env summary iface- = do-   checkList $-     [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))-     , do-         (recomp, mnames_seen) <- runUntilRecompRequired $ map-           checkForNewHomeDependency-           (ms_home_imps summary)-         case recomp of-           UpToDate -> do-             let-               seen_home_deps = Set.unions $ map Set.fromList mnames_seen-             checkIfAllOldHomeDependenciesAreSeen seen_home_deps-           _ -> return recomp]- where-   prev_dep_mods = dep_mods (mi_deps iface)-   prev_dep_plgn = dep_plgins (mi_deps iface)-   prev_dep_pkgs = dep_pkgs (mi_deps iface)--   this_pkg = thisPackage (hsc_dflags hsc_env)--   dep_missing (mb_pkg, L _ mod) = do-     find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)-     let reason = moduleNameString mod ++ " changed"-     case find_res of-        Found _ mod-          | pkg == this_pkg-           -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn-                 then do traceHiDiffs $-                           text "imported module " <> quotes (ppr mod) <>-                           text " not among previous dependencies"-                         return (RecompBecause reason)-                 else-                         return UpToDate-          | otherwise-           -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)-                 then do traceHiDiffs $-                           text "imported module " <> quotes (ppr mod) <>-                           text " is from package " <> quotes (ppr pkg) <>-                           text ", which is not among previous dependencies"-                         return (RecompBecause reason)-                 else-                         return UpToDate-           where pkg = moduleUnitId mod-        _otherwise  -> return (RecompBecause reason)--   old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods-   isOldHomeDeps = flip Set.member old_deps-   checkForNewHomeDependency (L _ mname) = do-     let-       mod = mkModule this_pkg mname-       str_mname = moduleNameString mname-       reason = str_mname ++ " changed"-     -- We only want to look at home modules to check if any new home dependency-     -- pops in and thus here, skip modules that are not home. Checking-     -- membership in old home dependencies suffice because the `dep_missing`-     -- check already verified that all imported home modules are present there.-     if not (isOldHomeDeps mname)-       then return (UpToDate, [])-       else do-         mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do-           let mnames = mname:(map fst $ filter (not . snd) $-                 dep_mods $ mi_deps imported_iface)-           case find (not . isOldHomeDeps) mnames of-             Nothing -> return (UpToDate, mnames)-             Just new_dep_mname -> do-               traceHiDiffs $-                 text "imported home module " <> quotes (ppr mod) <>-                 text " has a new dependency " <> quotes (ppr new_dep_mname)-               return (RecompBecause reason, [])-         return $ fromMaybe (MustCompile, []) mb_result--   -- Performs all recompilation checks in the list until a check that yields-   -- recompile required is encountered. Returns the list of the results of-   -- all UpToDate checks.-   runUntilRecompRequired []             = return (UpToDate, [])-   runUntilRecompRequired (check:checks) = do-     (recompile, value) <- check-     if recompileRequired recompile-       then return (recompile, [])-       else do-         (recomp, values) <- runUntilRecompRequired checks-         return (recomp, value:values)--   checkIfAllOldHomeDependenciesAreSeen seen_deps = do-     let unseen_old_deps = Set.difference-          old_deps-          seen_deps-     if not (null unseen_old_deps)-       then do-         let missing_dep = Set.elemAt 0 unseen_old_deps-         traceHiDiffs $-           text "missing old home dependency " <> quotes (ppr missing_dep)-         return $ RecompBecause "missing old dependency"-       else return UpToDate--needInterface :: Module -> (ModIface -> IfG RecompileRequired)-             -> IfG RecompileRequired-needInterface mod continue-  = do-      mb_recomp <- getFromModIface-        "need version info for"-        mod-        continue-      case mb_recomp of-        Nothing -> return MustCompile-        Just recomp -> return recomp--getFromModIface :: String -> Module -> (ModIface -> IfG a)-              -> IfG (Maybe a)-getFromModIface doc_msg mod getter-  = do  -- Load the imported interface if possible-    let doc_str = sep [text doc_msg, ppr mod]-    traceHiDiffs (text "Checking innterface for module" <+> ppr mod)--    mb_iface <- loadInterface doc_str mod ImportBySystem-        -- Load the interface, but don't complain on failure;-        -- Instead, get an Either back which we can test--    case mb_iface of-      Failed _ -> do-        traceHiDiffs (sep [text "Couldn't load interface for module",-                           ppr mod])-        return Nothing-                  -- Couldn't find or parse a module mentioned in the-                  -- 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 <$> getter iface---- | Given the usage information extracted from the old--- M.hi file for the module being compiled, figure out--- whether M needs to be recompiled.-checkModUsage :: UnitId -> Usage -> IfG RecompileRequired-checkModUsage _this_pkg UsagePackageModule{-                                usg_mod = mod,-                                usg_mod_hash = old_mod_hash }-  = needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed"-    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))-        -- We only track the ABI hash of package modules, rather than-        -- individual entity usages, so if the ABI hash changes we must-        -- recompile.  This is safe but may entail more recompilation when-        -- a dependent package has changed.--checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }-  = needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"-    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))--checkModUsage this_pkg UsageHomeModule{-                                usg_mod_name = mod_name,-                                usg_mod_hash = old_mod_hash,-                                usg_exports = maybe_old_export_hash,-                                usg_entities = old_decl_hash }-  = do-    let mod = mkModule this_pkg mod_name-    needInterface mod $ \iface -> do--    let-        new_mod_hash    = mi_mod_hash (mi_final_exts iface)-        new_decl_hash   = mi_hash_fn  (mi_final_exts iface)-        new_export_hash = mi_exp_hash (mi_final_exts iface)--        reason = moduleNameString mod_name ++ " changed"--        -- CHECK MODULE-    recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash-    if not (recompileRequired recompile)-      then return UpToDate-      else do--        -- CHECK EXPORT LIST-        checkMaybeHash reason maybe_old_export_hash new_export_hash-            (text "  Export list changed") $ do--        -- CHECK ITEMS ONE BY ONE-        recompile <- checkList [ checkEntityUsage 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 (text "  Great!  The bits I use are up to date")---checkModUsage _this_pkg UsageFile{ usg_file_path = file,-                                   usg_file_hash = old_hash } =-  liftIO $-    handleIO handle $ do-      new_hash <- getFileHash file-      if (old_hash /= new_hash)-         then return recomp-         else return UpToDate- where-   recomp = RecompBecause (file ++ " changed")-   handle =-#if defined(DEBUG)-       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp-#else-       \_ -> return recomp -- if we can't find the file, just recompile, don't fail-#endif---------------------------checkModuleFingerprint :: String -> Fingerprint -> Fingerprint-                       -> IfG RecompileRequired-checkModuleFingerprint reason old_mod_hash new_mod_hash-  | new_mod_hash == old_mod_hash-  = up_to_date (text "Module fingerprint unchanged")--  | otherwise-  = out_of_date_hash reason (text "  Module fingerprint has changed")-                     old_mod_hash new_mod_hash---------------------------checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc-               -> IfG RecompileRequired -> IfG RecompileRequired-checkMaybeHash reason maybe_old_hash new_hash doc continue-  | Just hash <- maybe_old_hash, hash /= new_hash-  = out_of_date_hash reason doc hash new_hash-  | otherwise-  = continue---------------------------checkEntityUsage :: String-                 -> (OccName -> Maybe (OccName, Fingerprint))-                 -> (OccName, Fingerprint)-                 -> IfG RecompileRequired-checkEntityUsage reason new_hash (name,old_hash)-  = case new_hash name of--        Nothing       ->        -- We used it before, but it ain't there now-                          out_of_date reason (sep [text "No longer exported:", ppr name])--        Just (_, new_hash)      -- It's there, but is it up to date?-          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))-                                       return UpToDate-          | otherwise            -> out_of_date_hash reason (text "  Out of date:" <+> ppr name)-                                                     old_hash new_hash--up_to_date :: SDoc -> IfG RecompileRequired-up_to_date  msg = traceHiDiffs msg >> return UpToDate--out_of_date :: String -> SDoc -> IfG RecompileRequired-out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)--out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired-out_of_date_hash reason msg old_hash new_hash-  = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])-------------------------checkList :: [IfG RecompileRequired] -> IfG 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--{--************************************************************************-*                                                                      *-                Converting things to their Iface equivalents-*                                                                      *-************************************************************************--}--tyThingToIfaceDecl :: TyThing -> IfaceDecl-tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id-tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)-tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax-tyThingToIfaceDecl (AConLike cl)  = case cl of-    RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only-    PatSynCon ps   -> patSynToIfaceDecl ps-----------------------------idToIfaceDecl :: Id -> IfaceDecl--- The Id is already tidied, so that locally-bound names--- (lambdas, for-alls) already have non-clashing OccNames--- We can't tidy it here, locally, because it may have--- free variables in its type or IdInfo-idToIfaceDecl id-  = IfaceId { ifName      = getName id,-              ifType      = toIfaceType (idType id),-              ifIdDetails = toIfaceIdDetails (idDetails id),-              ifIdInfo    = toIfaceIdInfo (idInfo id) }-----------------------------dataConToIfaceDecl :: DataCon -> IfaceDecl-dataConToIfaceDecl dataCon-  = IfaceId { ifName      = getName dataCon,-              ifType      = toIfaceType (dataConUserType dataCon),-              ifIdDetails = IfVanillaId,-              ifIdInfo    = [] }-----------------------------coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl--- We *do* tidy Axioms, because they are not (and cannot--- conveniently be) built in tidy form-coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches-                               , co_ax_role = role })- = IfaceAxiom { ifName       = getName ax-              , ifTyCon      = toIfaceTyCon tycon-              , ifRole       = role-              , ifAxBranches = map (coAxBranchToIfaceBranch tycon-                                     (map coAxBranchLHS branch_list))-                                   branch_list }- where-   branch_list = fromBranches branches---- 2nd parameter is the list of branch LHSs, in case of a closed type family,--- for conversion from incompatible branches to incompatible indices.--- For an open type family the list should be empty.--- See Note [Storing compatibility] in CoAxiom-coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch-coAxBranchToIfaceBranch tc lhs_s-                        (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                                    , cab_eta_tvs = eta_tvs-                                    , cab_lhs = lhs, cab_roles = roles-                                    , cab_rhs = rhs, cab_incomps = incomps })--  = IfaceAxBranch { ifaxbTyVars  = toIfaceTvBndrs tvs-                  , ifaxbCoVars  = map toIfaceIdBndr cvs-                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs-                  , ifaxbLHS     = toIfaceTcArgs tc lhs-                  , ifaxbRoles   = roles-                  , ifaxbRHS     = toIfaceType rhs-                  , ifaxbIncomps = iface_incomps }-  where-    iface_incomps = map (expectJust "iface_incomps"-                        . flip findIndex lhs_s-                        . eqTypes-                        . coAxBranchLHS) incomps--------------------tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)--- We *do* tidy TyCons, because they are not (and cannot--- conveniently be) built in tidy form--- The returned TidyEnv is the one after tidying the tyConTyVars-tyConToIfaceDecl env tycon-  | Just clas <- tyConClass_maybe tycon-  = classToIfaceDecl env clas--  | Just syn_rhs <- synTyConRhs_maybe tycon-  = ( tc_env1-    , IfaceSynonym { ifName    = getName tycon,-                     ifRoles   = tyConRoles tycon,-                     ifSynRhs  = if_syn_type syn_rhs,-                     ifBinders = if_binders,-                     ifResKind = if_res_kind-                   })--  | Just fam_flav <- famTyConFlav_maybe tycon-  = ( tc_env1-    , IfaceFamily { ifName    = getName tycon,-                    ifResVar  = if_res_var,-                    ifFamFlav = to_if_fam_flav fam_flav,-                    ifBinders = if_binders,-                    ifResKind = if_res_kind,-                    ifFamInj  = tyConInjectivityInfo tycon-                  })--  | isAlgTyCon tycon-  = ( tc_env1-    , IfaceData { ifName    = getName tycon,-                  ifBinders = if_binders,-                  ifResKind = if_res_kind,-                  ifCType   = tyConCType tycon,-                  ifRoles   = tyConRoles tycon,-                  ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),-                  ifCons    = ifaceConDecls (algTyConRhs tycon),-                  ifGadtSyntax = isGadtSyntaxTyCon tycon,-                  ifParent  = parent })--  | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon-  -- We only convert these TyCons to IfaceTyCons when we are-  -- just about to pretty-print them, not because we are going-  -- to put them into interface files-  = ( env-    , IfaceData { ifName       = getName tycon,-                  ifBinders    = if_binders,-                  ifResKind    = if_res_kind,-                  ifCType      = Nothing,-                  ifRoles      = tyConRoles tycon,-                  ifCtxt       = [],-                  ifCons       = IfDataTyCon [],-                  ifGadtSyntax = False,-                  ifParent     = IfNoParent })-  where-    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`-    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause-    -- an error.-    (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)-    tc_tyvars      = binderVars tc_binders-    if_binders     = toIfaceTyCoVarBinders tc_binders-                     -- No tidying of the binders; they are already tidy-    if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)-    if_syn_type ty = tidyToIfaceType tc_env1 ty-    if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon--    parent = case tyConFamInstSig_maybe tycon of-               Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)-                                                   (toIfaceTyCon tc)-                                                   (tidyToIfaceTcArgs tc_env1 tc ty)-               Nothing           -> IfNoParent--    to_if_fam_flav OpenSynFamilyTyCon             = IfaceOpenSynFamilyTyCon-    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceAbstractClosedSynFamilyTyCon-    to_if_fam_flav (DataFamilyTyCon {})           = IfaceDataFamilyTyCon-    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceBuiltInSynFamTyCon-    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing-    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))-      = IfaceClosedSynFamilyTyCon (Just (axn, ibr))-      where defs = fromBranches $ coAxiomBranches ax-            lhss = map coAxBranchLHS defs-            ibr  = map (coAxBranchToIfaceBranch tycon lhss) defs-            axn  = coAxiomName ax--    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)-    ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)-    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon [ifaceConDecl con]-    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)-    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon-        -- The AbstractTyCon case happens when a TyCon has been trimmed-        -- during tidying.-        -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver-        -- for GHCi, when browsing a module, in which case the-        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.-        -- (Tuple declarations are not serialised into interface files.)--    ifaceConDecl data_con-        = IfCon   { ifConName    = dataConName data_con,-                    ifConInfix   = dataConIsInfix data_con,-                    ifConWrapper = isJust (dataConWrapId_maybe data_con),-                    ifConExTCvs  = map toIfaceBndr ex_tvs',-                    ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',-                    ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,-                    ifConCtxt    = tidyToIfaceContext con_env2 theta,-                    ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,-                    ifConFields  = dataConFieldLabels data_con,-                    ifConStricts = map (toIfaceBang con_env2)-                                       (dataConImplBangs data_con),-                    ifConSrcStricts = map toIfaceSrcBang-                                          (dataConSrcBangs data_con)}-        where-          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)-            = dataConFullSig data_con-          user_bndrs = dataConUserTyVarBinders data_con--          -- Tidy the univ_tvs of the data constructor to be identical-          -- to the tyConTyVars of the type constructor.  This means-          -- (a) we don't need to redundantly put them into the interface file-          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,-          --     we know that the type variables will line up-          -- The latter (b) is important because we pretty-print type constructors-          -- by converting to Iface syntax and pretty-printing that-          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))-                     -- A bit grimy, perhaps, but it's simple!--          (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs-          user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs-          to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)--          -- By this point, we have tidied every universal and existential-          -- tyvar. Because of the dcUserTyCoVarBinders invariant-          -- (see Note [DataCon user type variable binders]), *every*-          -- user-written tyvar must be contained in the substitution that-          -- tidying produced. Therefore, tidying the user-written tyvars is a-          -- simple matter of looking up each variable in the substitution,-          -- which tidyTyCoVarOcc accomplishes.-          tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder-          tidyUserTyCoVarBinder env (Bndr tv vis) =-            Bndr (tidyTyCoVarOcc env tv) vis--classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)-classToIfaceDecl env clas-  = ( env1-    , IfaceClass { ifName   = getName tycon,-                   ifRoles  = tyConRoles (classTyCon clas),-                   ifBinders = toIfaceTyCoVarBinders tc_binders,-                   ifBody   = body,-                   ifFDs    = map toIfaceFD clas_fds })-  where-    (_, clas_fds, sc_theta, _, clas_ats, op_stuff)-      = classExtraBigSig clas-    tycon = classTyCon clas--    body | isAbstractTyCon tycon = IfAbstractClass-         | otherwise-         = IfConcreteClass {-                ifClassCtxt   = tidyToIfaceContext env1 sc_theta,-                ifATs    = map toIfaceAT clas_ats,-                ifSigs   = map toIfaceClassOp op_stuff,-                ifMinDef = fmap getOccFS (classMinimalDef clas)-            }--    (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)--    toIfaceAT :: ClassATItem -> IfaceAT-    toIfaceAT (ATI tc def)-      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)-      where-        (env2, if_decl) = tyConToIfaceDecl env1 tc--    toIfaceClassOp (sel_id, def_meth)-        = ASSERT( sel_tyvars == binderVars tc_binders )-          IfaceClassOp (getName sel_id)-                       (tidyToIfaceType env1 op_ty)-                       (fmap toDmSpec def_meth)-        where-                -- Be careful when splitting the type, because of things-                -- like         class Foo a where-                --                op :: (?x :: String) => a -> a-                -- and          class Baz a where-                --                op :: (Ord a) => a -> a-          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)-          op_ty                = funResultTy rho_ty--    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType-    toDmSpec (_, VanillaDM)       = VanillaDM-    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)--    toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1-                             ,map (tidyTyVar env1) tvs2)------------------------------tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)--- If the type variable "binder" is in scope, don't re-bind it--- In a class decl, for example, the ATD binders mention--- (amd must mention) the class tyvars-tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)- = case lookupVarEnv subst tv of-     Just tv' -> (env,  Bndr tv' vis)-     Nothing  -> tidyTyCoVarBinder env tvb--tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])-tidyTyConBinders = mapAccumL tidyTyConBinder--tidyTyVar :: TidyEnv -> TyVar -> FastString-tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)-----------------------------instanceToIfaceInst :: ClsInst -> IfaceClsInst-instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag-                             , is_cls_nm = cls_name, is_cls = cls-                             , is_tcs = mb_tcs-                             , is_orphan = orph })-  = ASSERT( cls_name == className cls )-    IfaceClsInst { ifDFun    = dfun_name,-                ifOFlag   = oflag,-                ifInstCls = cls_name,-                ifInstTys = map do_rough mb_tcs,-                ifInstOrph = orph }-  where-    do_rough Nothing  = Nothing-    do_rough (Just n) = Just (toIfaceTyCon_name n)--    dfun_name = idName dfun_id------------------------------famInstToIfaceFamInst :: FamInst -> IfaceFamInst-famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,-                                 fi_fam      = fam,-                                 fi_tcs      = roughs })-  = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom-                 , ifFamInstFam      = fam-                 , ifFamInstTys      = map do_rough roughs-                 , ifFamInstOrph     = orph }-  where-    do_rough Nothing  = Nothing-    do_rough (Just n) = Just (toIfaceTyCon_name n)--    fam_decl = tyConName $ coAxiomTyCon axiom-    mod = ASSERT( isExternalName (coAxiomName axiom) )-          nameModule (coAxiomName axiom)-    is_local name = nameIsLocalOrFrom mod name--    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)--    orph | is_local fam_decl-         = NotOrphan (nameOccName fam_decl)-         | otherwise-         = chooseOrphanAnchor lhs_names-----------------------------coreRuleToIfaceRule :: CoreRule -> IfaceRule-coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})-  = pprTrace "toHsRule: builtin" (ppr fn) $-    bogusIfaceRule fn--coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,-                            ru_act = act, ru_bndrs = bndrs,-                            ru_args = args, ru_rhs = rhs,-                            ru_orphan = orph, ru_auto = auto })-  = IfaceRule { ifRuleName  = name, ifActivation = act,-                ifRuleBndrs = map toIfaceBndr bndrs,-                ifRuleHead  = fn,-                ifRuleArgs  = map do_arg args,-                ifRuleRhs   = toIfaceExpr rhs,-                ifRuleAuto  = auto,-                ifRuleOrph  = orph }-  where-        -- For type args we must remove synonyms from the outermost-        -- level.  Reason: so that when we read it back in we'll-        -- construct the same ru_rough field as we have right now;-        -- see tcIfaceRule-    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/IfaceToCore.hs view
@@ -33,47 +33,47 @@ import BuildTyCl import TcRnMonad import TcType-import Type-import Coercion-import CoAxiom-import TyCoRep    -- needs to build types & coercions in a knot-import TyCoSubst ( substTyCoVars )+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.Coercion.Axiom+import GHC.Core.TyCo.Rep    -- needs to build types & coercions in a knot+import GHC.Core.TyCo.Subst ( substTyCoVars ) import GHC.Driver.Types-import Annotations-import InstEnv-import FamInstEnv+import GHC.Types.Annotations+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Utils import GHC.Core.Unfold import GHC.Core.Lint import GHC.Core.Make-import Id-import MkId-import IdInfo-import Class-import TyCon-import ConLike-import DataCon+import GHC.Types.Id+import GHC.Types.Id.Make+import GHC.Types.Id.Info+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Core.ConLike+import GHC.Core.DataCon import PrelNames import TysWiredIn-import Literal-import Var-import VarSet-import Name-import NameEnv-import NameSet-import OccurAnal        ( occurAnalyseExpr )-import Demand-import Module-import UniqFM-import UniqSupply+import GHC.Types.Literal+import GHC.Types.Var as Var+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Core.Op.OccurAnal ( occurAnalyseExpr )+import GHC.Types.Demand+import GHC.Types.Module+import GHC.Types.Unique.FM+import GHC.Types.Unique.Supply import Outputable import Maybes-import SrcLoc+import GHC.Types.SrcLoc import GHC.Driver.Session import Util import FastString-import BasicTypes hiding ( SuccessFlag(..) )+import GHC.Types.Basic hiding ( SuccessFlag(..) ) import ListSetOps import GHC.Fingerprint import qualified BooleanFormula as BF@@ -867,7 +867,7 @@                             , ifaxbRoles = roles, ifaxbIncomps = incomps })   = bindIfaceTyConBinders_AT       (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->-         -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom+         -- The _AT variant is needed here; see Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom     bindIfaceIds cv_bndrs $ \ cvs -> do     { tc_lhs   <- tcIfaceAppArgs lhs     ; tc_rhs   <- tcIfaceType rhs@@ -963,7 +963,7 @@                        -- decisions) to buildDataCon; it'll use                        -- these to guide the construction of a                        -- worker.-                       -- See Note [Bangs on imported data constructors] in MkId+                       -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make                        lbl_names                        univ_tvs ex_tvs user_tv_bndrs                        eq_spec theta@@ -1176,7 +1176,7 @@                         kind_args = map typeKind args'                   ; return (mkTyConApp tc (kind_args ++ args')) } } --- See Note [Unboxed tuple RuntimeRep vars] in TyCon+-- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon tcTupleTyCon :: Bool    -- True <=> typechecking a *type* (vs. an expr)              -> TupleSort              -> Arity   -- the number of args. *not* the tuple arity.@@ -1384,13 +1384,13 @@ tcIfaceLit :: Literal -> IfL Literal -- Integer literals deserialise to (LitInteger i <error thunk>) -- so tcIfaceLit just fills in the type.--- See Note [Integer literals] in Literal+-- See Note [Integer literals] in GHC.Types.Literal tcIfaceLit (LitNumber LitNumInteger i _)   = do t <- tcIfaceTyConByName integerTyConName        return (mkLitInteger i (mkTyConTy t)) -- Natural literals deserialise to (LitNatural i <error thunk>) -- so tcIfaceLit just fills in the type.--- See Note [Natural literals] in Literal+-- See Note [Natural literals] in GHC.Types.Literal tcIfaceLit (LitNumber LitNumNatural i _)   = do t <- tcIfaceTyConByName naturalTyConName        return (mkLitNatural i (mkTyConTy t))@@ -1474,8 +1474,8 @@       | otherwise        = filter need_prag items      need_prag :: IfaceInfoItem -> Bool-      -- compulsory unfoldings are really compulsory.-      -- See wrinkle in Note [Wiring in unsafeCoerce#] in Desugar+      -- Always read in compulsory unfoldings+      -- See Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy     need_prag (HsUnfold _ (IfCompulsory {})) = True     need_prag _                              = False
compiler/GHC/IfaceToCore.hs-boot view
@@ -3,13 +3,13 @@ import GhcPrelude import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule                         , IfaceAnnotation, IfaceCompleteMatch )-import TyCoRep          ( TyThing )-import TcRnTypes        ( IfL )-import InstEnv          ( ClsInst )-import FamInstEnv       ( FamInst )+import GHC.Core.TyCo.Rep   ( TyThing )+import TcRnTypes           ( IfL )+import GHC.Core.InstEnv    ( ClsInst )+import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core         ( CoreRule ) import GHC.Driver.Types ( CompleteMatch )-import Annotations      ( Annotation )+import GHC.Types.Annotations ( Annotation )  tcIfaceDecl         :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules        :: Bool -> [IfaceRule] -> IfL [CoreRule]
compiler/GHC/Llvm/Ppr.hs view
@@ -30,10 +30,11 @@ import GHC.Llvm.Syntax import GHC.Llvm.MetaData import GHC.Llvm.Types+import GHC.Platform  import Data.List ( intersperse ) import Outputable-import Unique+import GHC.Types.Unique import FastString ( sLit )  --------------------------------------------------------------------------------@@ -41,14 +42,14 @@ --------------------------------------------------------------------------------  -- | Print out a whole LLVM module.-ppLlvmModule :: LlvmModule -> SDoc-ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)+ppLlvmModule :: Platform -> LlvmModule -> SDoc+ppLlvmModule platform (LlvmModule comments aliases meta globals decls funcs)   = ppLlvmComments comments $+$ newLine     $+$ ppLlvmAliases aliases $+$ newLine     $+$ ppLlvmMetas meta $+$ newLine     $+$ ppLlvmGlobals globals $+$ newLine     $+$ ppLlvmFunctionDecls decls $+$ newLine-    $+$ ppLlvmFunctions funcs+    $+$ ppLlvmFunctions platform funcs  -- | Print out a multi-line comment, can be inside a function or on its own ppLlvmComments :: [LMString] -> SDoc@@ -117,12 +118,12 @@   -- | Print out a list of function definitions.-ppLlvmFunctions :: LlvmFunctions -> SDoc-ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs+ppLlvmFunctions :: Platform -> LlvmFunctions -> SDoc+ppLlvmFunctions platform funcs = vcat $ map (ppLlvmFunction platform) funcs  -- | Print out a function definition.-ppLlvmFunction :: LlvmFunction -> SDoc-ppLlvmFunction fun =+ppLlvmFunction :: Platform -> LlvmFunction -> SDoc+ppLlvmFunction platform fun =     let attrDoc = ppSpaceJoin (funcAttrs fun)         secDoc = case funcSect fun of                       Just s' -> text "section" <+> (doubleQuotes $ ftext s')@@ -133,7 +134,7 @@     in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)         <+> attrDoc <+> secDoc <+> prefixDoc         $+$ lbrace-        $+$ ppLlvmBlocks (funcBody fun)+        $+$ ppLlvmBlocks platform (funcBody fun)         $+$ rbrace         $+$ newLine         $+$ newLine@@ -177,21 +178,21 @@   -- | Print out a list of LLVM blocks.-ppLlvmBlocks :: LlvmBlocks -> SDoc-ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks+ppLlvmBlocks :: Platform -> LlvmBlocks -> SDoc+ppLlvmBlocks platform blocks = vcat $ map (ppLlvmBlock platform) blocks  -- | Print out an LLVM block. -- It must be part of a function definition.-ppLlvmBlock :: LlvmBlock -> SDoc-ppLlvmBlock (LlvmBlock blockId stmts) =+ppLlvmBlock :: Platform -> LlvmBlock -> SDoc+ppLlvmBlock platform (LlvmBlock blockId stmts) =   let isLabel (MkLabel _) = True       isLabel _           = False       (block, rest)       = break isLabel stmts       ppRest = case rest of-        MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs)+        MkLabel id:xs -> ppLlvmBlock platform (LlvmBlock id xs)         _             -> empty   in ppLlvmBlockLabel blockId-           $+$ (vcat $ map ppLlvmStatement block)+           $+$ (vcat $ map (ppLlvmStatement platform) block)            $+$ newLine            $+$ ppRest @@ -201,11 +202,11 @@   -- | Print out an LLVM statement.-ppLlvmStatement :: LlvmStatement -> SDoc-ppLlvmStatement stmt =+ppLlvmStatement :: Platform -> LlvmStatement -> SDoc+ppLlvmStatement platform stmt =   let ind = (text "  " <>)   in case stmt of-        Assignment  dst expr      -> ind $ ppAssignment dst (ppLlvmExpression expr)+        Assignment  dst expr      -> ind $ ppAssignment dst (ppLlvmExpression platform expr)         Fence       st ord        -> ind $ ppFence st ord         Branch      target        -> ind $ ppBranch target         BranchIf    cond ifT ifF  -> ind $ ppBranchIf cond ifT ifF@@ -214,15 +215,15 @@         Store       value ptr     -> ind $ ppStore value ptr         Switch      scrut def tgs -> ind $ ppSwitch scrut def tgs         Return      result        -> ind $ ppReturn result-        Expr        expr          -> ind $ ppLlvmExpression expr+        Expr        expr          -> ind $ ppLlvmExpression platform expr         Unreachable               -> ind $ text "unreachable"         Nop                       -> empty-        MetaStmt    meta s        -> ppMetaStatement meta s+        MetaStmt    meta s        -> ppMetaStatement platform meta s   -- | Print out an LLVM expression.-ppLlvmExpression :: LlvmExpression -> SDoc-ppLlvmExpression expr+ppLlvmExpression :: Platform -> LlvmExpression -> SDoc+ppLlvmExpression platform expr   = case expr of         Alloca     tp amount        -> ppAlloca tp amount         LlvmOp     op left right    -> ppMachOp op left right@@ -235,13 +236,13 @@         Insert     vec elt idx      -> ppInsert vec elt idx         GetElemPtr inb ptr indexes  -> ppGetElementPtr inb ptr indexes         Load       ptr              -> ppLoad ptr-        ALoad      ord st ptr       -> ppALoad ord st ptr+        ALoad      ord st ptr       -> ppALoad platform ord st ptr         Malloc     tp amount        -> ppMalloc tp amount         AtomicRMW  aop tgt src ordering -> ppAtomicRMW aop tgt src ordering         CmpXChg    addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord         Phi        tp predecessors  -> ppPhi tp predecessors         Asm        asm c ty v se sk -> ppAsm asm c ty v se sk-        MExpr      meta expr        -> ppMetaExpr meta expr+        MExpr      meta expr        -> ppMetaExpr platform meta expr   --------------------------------------------------------------------------------@@ -360,9 +361,9 @@     align | isVector . pLower . getVarType $ var = text ", align 1"           | otherwise = empty -ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc-ppALoad ord st var = sdocWithDynFlags $ \dflags ->-  let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8+ppALoad :: Platform -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc+ppALoad platform ord st var =+  let alignment = (llvmWidthInBits platform $ getVarType var) `quot` 8       align     = text ", align" <+> ppr alignment       sThreaded | st        = text " singlethread"                 | otherwise = empty@@ -468,11 +469,13 @@     <+> ppr idx  -ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc-ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta+ppMetaStatement :: Platform -> [MetaAnnot] -> LlvmStatement -> SDoc+ppMetaStatement platform meta stmt =+   ppLlvmStatement platform stmt <> ppMetaAnnots meta -ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc-ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta+ppMetaExpr :: Platform -> [MetaAnnot] -> LlvmExpression -> SDoc+ppMetaExpr platform meta expr =+   ppLlvmExpression platform expr <> ppMetaAnnots meta  ppMetaAnnots :: [MetaAnnot] -> SDoc ppMetaAnnots meta = hcat $ map ppMeta meta
compiler/GHC/Llvm/Syntax.hs view
@@ -9,7 +9,7 @@ import GHC.Llvm.MetaData import GHC.Llvm.Types -import Unique+import GHC.Types.Unique  -- | Block labels type LlvmBlockId = Unique
compiler/GHC/Llvm/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}  -------------------------------------------------------------------------------- -- | The LLVM Type System.@@ -14,10 +15,11 @@ import Data.Int import Numeric +import GHC.Platform import GHC.Driver.Session import FastString import Outputable-import Unique+import GHC.Types.Unique  -- from NCG import GHC.CmmToAsm.Ppr@@ -351,23 +353,24 @@ isGlobal _                         = False  -- | Width in bits of an 'LlvmType', returns 0 if not applicable-llvmWidthInBits :: DynFlags -> LlvmType -> Int-llvmWidthInBits _      (LMInt n)       = n-llvmWidthInBits _      (LMFloat)       = 32-llvmWidthInBits _      (LMDouble)      = 64-llvmWidthInBits _      (LMFloat80)     = 80-llvmWidthInBits _      (LMFloat128)    = 128--- Could return either a pointer width here or the width of what--- it points to. We will go with the former for now.--- PMW: At least judging by the way LLVM outputs constants, pointers---      should use the former, but arrays the latter.-llvmWidthInBits dflags (LMPointer _)   = llvmWidthInBits dflags (llvmWord dflags)-llvmWidthInBits dflags (LMArray n t)   = n * llvmWidthInBits dflags t-llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty-llvmWidthInBits _      LMLabel         = 0-llvmWidthInBits _      LMVoid          = 0-llvmWidthInBits dflags (LMStruct tys)  = sum $ map (llvmWidthInBits dflags) tys-llvmWidthInBits _      (LMStructU _)   =+llvmWidthInBits :: Platform -> LlvmType -> Int+llvmWidthInBits platform = \case+   (LMInt n)       -> n+   (LMFloat)       -> 32+   (LMDouble)      -> 64+   (LMFloat80)     -> 80+   (LMFloat128)    -> 128+   -- Could return either a pointer width here or the width of what+   -- it points to. We will go with the former for now.+   -- PMW: At least judging by the way LLVM outputs constants, pointers+   --      should use the former, but arrays the latter.+   (LMPointer _)   -> llvmWidthInBits platform (llvmWord platform)+   (LMArray n t)   -> n * llvmWidthInBits platform t+   (LMVector n ty) -> n * llvmWidthInBits platform ty+   LMLabel         -> 0+   LMVoid          -> 0+   (LMStruct tys)  -> sum $ map (llvmWidthInBits platform) tys+   (LMStructU _)   ->     -- It's not trivial to calculate the bit width of the unpacked structs,     -- since they will be aligned depending on the specified datalayout (     -- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support@@ -377,9 +380,9 @@     -- llvm.sadd.with.overflow.*), so we don't actually need to compute their     -- bit width.     panic "llvmWidthInBits: not implemented for LMStructU"-llvmWidthInBits _      (LMFunction  _) = 0-llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t-llvmWidthInBits _      LMMetadata      = panic "llvmWidthInBits: Meta-data has no runtime representation!"+   (LMFunction  _) -> 0+   (LMAlias (_,t)) -> llvmWidthInBits platform t+   LMMetadata      -> panic "llvmWidthInBits: Meta-data has no runtime representation!"   -- -----------------------------------------------------------------------------@@ -396,9 +399,9 @@ i8Ptr = pLift i8  -- | The target architectures word size-llvmWord, llvmWordPtr :: DynFlags -> LlvmType-llvmWord    dflags = LMInt (wORD_SIZE dflags * 8)-llvmWordPtr dflags = pLift (llvmWord dflags)+llvmWord, llvmWordPtr :: Platform -> LlvmType+llvmWord    platform = LMInt (platformWordSizeInBytes platform * 8)+llvmWordPtr platform = pLift (llvmWord platform)  -- ----------------------------------------------------------------------------- -- * LLVM Function Types
compiler/GHC/Plugins.hs view
@@ -6,41 +6,69 @@ -- with saying "import GHC.Plugins". -- -- Particularly interesting modules for plugin writers include--- "GHC.Core" and "CoreMonad".-module GHC.Plugins(-        module GHC.Driver.Plugins,-        module RdrName, module OccName, module Name, module Var, module Id, module IdInfo,-        module CoreMonad, module GHC.Core, module Literal, module DataCon,-        module GHC.Core.Utils, module GHC.Core.Make, module GHC.Core.FVs,-        module GHC.Core.Subst, module GHC.Core.Rules, module Annotations,-        module GHC.Driver.Session, module GHC.Driver.Packages,-        module Module, module Type, module TyCon, module Coercion,-        module TysWiredIn, module GHC.Driver.Types, module BasicTypes,-        module VarSet, module VarEnv, module NameSet, module NameEnv,-        module UniqSet, module UniqFM, module FiniteMap,-        module Util, module GHC.Serialized, module SrcLoc, module Outputable,-        module UniqSupply, module Unique, module FastString,--        -- * Getting 'Name's-        thNameToGhcName-    ) where+-- "GHC.Core" and "GHC.Core.Op.Monad".+module GHC.Plugins+   ( module GHC.Driver.Plugins+   , module GHC.Types.Name.Reader+   , module GHC.Types.Name.Occurrence+   , module GHC.Types.Name+   , module GHC.Types.Var+   , module GHC.Types.Id+   , module GHC.Types.Id.Info+   , module GHC.Core.Op.Monad+   , module GHC.Core+   , module GHC.Types.Literal+   , module GHC.Core.DataCon+   , module GHC.Core.Utils+   , module GHC.Core.Make+   , module GHC.Core.FVs+   , module GHC.Core.Subst+   , module GHC.Core.Rules+   , module GHC.Types.Annotations+   , module GHC.Driver.Session+   , module GHC.Driver.Packages+   , module GHC.Types.Module+   , module GHC.Core.Type+   , module GHC.Core.TyCon+   , module GHC.Core.Coercion+   , module TysWiredIn+   , module GHC.Driver.Types+   , module GHC.Types.Basic+   , module GHC.Types.Var.Set+   , module GHC.Types.Var.Env+   , module GHC.Types.Name.Set+   , module GHC.Types.Name.Env+   , module GHC.Types.Unique+   , module GHC.Types.Unique.Set+   , module GHC.Types.Unique.FM+   , module FiniteMap+   , module Util+   , module GHC.Serialized+   , module GHC.Types.SrcLoc+   , module Outputable+   , module GHC.Types.Unique.Supply+   , module FastString+   , -- * Getting 'Name's+     thNameToGhcName+   )+where  -- Plugin stuff itself import GHC.Driver.Plugins  -- Variable naming-import RdrName-import OccName  hiding  ( varName {- conflicts with Var.varName -} )-import Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )-import Var-import Id       hiding  ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )-import IdInfo+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence  hiding  ( varName {- conflicts with Var.varName -} )+import GHC.Types.Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )+import GHC.Types.Var+import GHC.Types.Id       hiding  ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )+import GHC.Types.Id.Info  -- Core-import CoreMonad+import GHC.Core.Op.Monad import GHC.Core-import Literal-import DataCon+import GHC.Types.Literal+import GHC.Core.DataCon import GHC.Core.Utils import GHC.Core.Make import GHC.Core.FVs@@ -49,30 +77,30 @@  -- Core "extras" import GHC.Core.Rules-import Annotations+import GHC.Types.Annotations  -- Pipeline-related stuff import GHC.Driver.Session import GHC.Driver.Packages  -- Important GHC types-import Module-import Type     hiding {- conflict with GHC.Core.Subst -}+import GHC.Types.Module+import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -}                 ( substTy, extendTvSubst, extendTvSubstList, isInScope )-import Coercion hiding {- conflict with GHC.Core.Subst -}+import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -}                 ( substCo )-import TyCon+import GHC.Core.TyCon import TysWiredIn import GHC.Driver.Types-import BasicTypes hiding ( Version {- conflicts with Packages.Version -} )+import GHC.Types.Basic hiding ( Version {- conflicts with Packages.Version -} )  -- Collections and maps-import VarSet-import VarEnv-import NameSet-import NameEnv-import UniqSet-import UniqFM+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM -- Conflicts with UniqFM: --import LazyUniqFM import FiniteMap@@ -80,10 +108,10 @@ -- Common utilities import Util import GHC.Serialized-import SrcLoc+import GHC.Types.SrcLoc import Outputable-import UniqSupply-import Unique           ( Unique, Uniquable(..) )+import GHC.Types.Unique.Supply+import GHC.Types.Unique ( Unique, Uniquable(..) ) import FastString import Data.Maybe @@ -95,8 +123,8 @@  import qualified Language.Haskell.TH as TH -{- This instance is defined outside CoreMonad.hs so that-   CoreMonad does not depend on TcEnv -}+{- This instance is defined outside GHC.Core.Op.Monad.hs so that+   GHC.Core.Op.Monad does not depend on TcEnv -} instance MonadThings CoreM where     lookupThing name = do { hsc_env <- getHscEnv                           ; liftIO $ lookupGlobal hsc_env name }
compiler/GHC/Rename/Binds.hs view
@@ -45,19 +45,19 @@                         , checkUnusedRecordWildcard                         , checkDupAndShadowedNames, bindLocalNamesFV ) import GHC.Driver.Session-import Module-import Name-import NameEnv-import NameSet-import RdrName          ( RdrName, rdrNameOcc )-import SrcLoc+import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Name.Reader ( RdrName, rdrNameOcc )+import GHC.Types.SrcLoc as SrcLoc import ListSetOps       ( findDupsEq )-import BasicTypes       ( RecFlag(..), TypeOrKind(..) )+import GHC.Types.Basic  ( RecFlag(..), TypeOrKind(..) ) import Digraph          ( SCC(..) ) import Bag import Util import Outputable-import UniqSet+import GHC.Types.Unique.Set import Maybes           ( orElse ) import OrdList import qualified GHC.LanguageExtensions as LangExt@@ -577,7 +577,7 @@     sccs = depAnal (\(_, defs, _) -> defs)                    (\(_, _, uses) -> nonDetEltsUniqSet uses)                    -- It's OK to use nonDetEltsUniqSet here as explained in-                   -- Note [depAnal determinism] in NameEnv.+                   -- Note [depAnal determinism] in GHC.Types.Name.Env.                    (bagToList binds_w_dus)      get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
compiler/GHC/Rename/Doc.hs view
@@ -6,7 +6,7 @@  import TcRnTypes import GHC.Hs-import SrcLoc+import GHC.Types.SrcLoc   rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)
compiler/GHC/Rename/Env.hs view
@@ -49,26 +49,26 @@ import GHC.Iface.Load   ( loadInterfaceForName, loadSrcInterface_maybe ) import GHC.Iface.Env import GHC.Hs-import RdrName+import GHC.Types.Name.Reader import GHC.Driver.Types import TcEnv import TcRnMonad import RdrHsSyn         ( filterCTuple, setRdrNameSpace ) import TysWiredIn-import Name-import NameSet-import NameEnv-import Avail-import Module-import ConLike-import DataCon-import TyCon+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Avail+import GHC.Types.Module+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.TyCon import ErrUtils         ( MsgDoc ) import PrelNames        ( rOOT_MAIN )-import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) )-import SrcLoc+import GHC.Types.Basic  ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) )+import GHC.Types.SrcLoc as SrcLoc import Outputable-import UniqSet          ( uniqSetAny )+import GHC.Types.Unique.Set ( uniqSetAny ) import Util import Maybes import GHC.Driver.Session
compiler/GHC/Rename/Expr.hs view
@@ -32,7 +32,7 @@ import GHC.Hs import TcEnv            ( isBrackStage ) import TcRnMonad-import Module           ( getModule )+import GHC.Types.Module ( getModule ) import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames@@ -47,17 +47,17 @@ import GHC.Driver.Session import PrelNames -import BasicTypes-import Name-import NameSet-import RdrName-import UniqSet+import GHC.Types.Basic+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Reader+import GHC.Types.Unique.Set import Data.List import Util import ListSetOps       ( removeDups ) import ErrUtils import Outputable-import SrcLoc+import GHC.Types.SrcLoc import FastString import Control.Monad import TysWiredIn       ( nilDataConName )@@ -1498,7 +1498,7 @@   scheduled as outlined above and transformed into applicative   combinators.  However, the code is still represented as a do-block   with special forms of applicative statements. This allows us to-  recover the original do-block when e.g.  printing type errors, where+  recover the original do-block when e.g. printing type errors, where   we don't want to show any of the applicative combinators since they   don't exist in the source code.   See ApplicativeStmt and ApplicativeArg in HsExpr.@@ -1682,7 +1682,7 @@                             , is_body_stmt     = False                             , fail_operator    = fail_op}]                       False tail'-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_))+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))                 tail _tail_fvs   | (False,tail') <- needJoin monad_names tail   = mkApplicativeStmt ctxt@@ -1691,7 +1691,7 @@        , app_arg_pattern  = nlWildPatName        , arg_expr         = rhs        , is_body_stmt     = True-       , fail_operator    = fail_op}] False tail'+       , fail_operator    = noSyntaxExpr}] False tail'  stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =   return (s : tail, emptyNameSet)@@ -1706,7 +1706,8 @@    pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees    let (stmts', fvss) = unzip pairs    let (need_join, tail') =-         if any hasStrictPattern trees+     -- See Note [ApplicativeDo and refutable patterns]+         if any hasRefutablePattern stmts'          then (True, tail)          else needJoin monad_names tail @@ -1721,13 +1722,13 @@                , is_body_stmt     = False                , fail_operator    = fail_op                }, emptyFVs)-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) =+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =      return (ApplicativeArgOne              { xarg_app_arg_one = noExtField              , app_arg_pattern  = nlWildPatName              , arg_expr         = exp              , is_body_stmt     = True-             , fail_operator    = fail_op+             , fail_operator    = noSyntaxExpr              }, emptyFVs)    stmtTreeArg ctxt tail_fvs tree = do      let stmts = flattenStmtTree tree@@ -1852,15 +1853,23 @@     NPat{}          -> True     NPlusKPat{}     -> True     SplicePat{}     -> True-    _otherwise -> panic "isStrictPattern"+    CoPat{}         -> panic "isStrictPattern: CoPat"+    XPat nec        -> noExtCon nec -hasStrictPattern :: ExprStmtTree -> Bool-hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat-hasStrictPattern (StmtTreeOne _) = False-hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b-hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees+{-+Note [ApplicativeDo and refutable patterns] +Refutable patterns in do blocks are desugared to use the monadic 'fail' operation.+This means that sometimes an applicative block needs to be wrapped in 'join' simply because+of a refutable pattern, in order for the types to work out. +-}++hasRefutablePattern :: ApplicativeArg GhcRn -> Bool+hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat+                                       , is_body_stmt = False}) = not (isIrrefutableHsPat pat)+hasRefutablePattern _ = False+ isLetStmt :: LStmt a b -> Bool isLetStmt (L _ LetStmt{}) = True isLetStmt _ = False@@ -1956,19 +1965,20 @@          -> (Bool, [ExprLStmt GhcRn]) needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg needJoin monad_names  [L loc (LastStmt _ e _ t)]- | Just arg <- isReturnApp monad_names e =-       (False, [L loc (LastStmt noExtField arg True t)])+ | Just (arg, wasDollar) <- isReturnApp monad_names e =+       (False, [L loc (LastStmt noExtField arg (Just wasDollar) t)]) needJoin _monad_names stmts = (True, stmts) --- | @Just e@, if the expression is @return e@ or @return $ e@,--- otherwise @Nothing@+-- | @(Just e, False)@, if the expression is @return e@+--   @(Just e, True)@ if the expression is @return $ e@,+--   otherwise @Nothing@. isReturnApp :: MonadNames             -> LHsExpr GhcRn-            -> Maybe (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-  HsApp _ f arg  | is_return f               -> Just arg+  OpApp _ l op r | is_return l, is_dollar op -> Just (r, True)+  HsApp _ f arg  | is_return f               -> Just (arg, False)   _otherwise -> Nothing  where   is_var f (L _ (HsPar _ e)) = is_var f e
compiler/GHC/Rename/Expr.hs-boot view
@@ -1,9 +1,9 @@ module GHC.Rename.Expr where-import Name+import GHC.Types.Name import GHC.Hs-import NameSet     ( FreeVars )+import GHC.Types.Name.Set ( FreeVars ) import TcRnTypes-import SrcLoc      ( Located )+import GHC.Types.SrcLoc   ( Located ) import Outputable  ( Outputable )  rnLExpr :: LHsExpr GhcPs
compiler/GHC/Rename/Fixity.hs view
@@ -20,15 +20,15 @@  import GHC.Iface.Load import GHC.Hs-import RdrName+import GHC.Types.Name.Reader import GHC.Driver.Types import TcRnMonad-import Name-import NameEnv-import Module-import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence,+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Module+import GHC.Types.Basic  ( Fixity(..), FixityDirection(..), minPrecedence,                           defaultFixity, SourceText(..) )-import SrcLoc+import GHC.Types.SrcLoc import Outputable import Maybes import Data.List
compiler/GHC/Rename/Names.hs view
@@ -35,7 +35,7 @@ import GhcPrelude  import GHC.Driver.Session-import TyCoPpr+import GHC.Core.TyCo.Ppr import GHC.Hs import TcEnv import GHC.Rename.Env@@ -44,25 +44,25 @@ import GHC.Iface.Load   ( loadSrcInterface ) import TcRnMonad import PrelNames-import Module-import Name-import NameEnv-import NameSet-import Avail-import FieldLabel+import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Avail+import GHC.Types.FieldLabel import GHC.Driver.Types-import RdrName+import GHC.Types.Name.Reader import RdrHsSyn        ( setRdrNameSpace ) import Outputable import Maybes-import SrcLoc-import BasicTypes      ( TopLevelFlag(..), StringLiteral(..) )+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Basic  ( TopLevelFlag(..), StringLiteral(..) ) import Util import FastString import FastStringEnv-import Id-import Type-import PatSyn+import GHC.Types.Id+import GHC.Core.Type+import GHC.Core.PatSyn import qualified GHC.LanguageExtensions as LangExt  import Control.Monad@@ -1065,7 +1065,8 @@            -- Look up the children in the sub-names of the parent            let subnames = case ns of   -- The tc is first in ns,                             [] -> []   -- if it is there at all-                                       -- See the AvailTC Invariant in Avail.hs+                                       -- See the AvailTC Invariant in+                                       -- GHC.Types.Avail                             (n1:ns1) | n1 == name -> ns1                                      | otherwise  -> ns            case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of@@ -1350,7 +1351,7 @@ specification and implementation notes are here:   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports -See also Note [Choosing the best import declaration] in RdrName+See also Note [Choosing the best import declaration] in GHC.Types.Name.Reader -}  type ImportDeclUsage
compiler/GHC/Rename/Pat.hs view
@@ -63,17 +63,17 @@                            , checkTupSize , unknownSubordinateErr ) import GHC.Rename.Types import PrelNames-import Name-import NameSet-import RdrName-import BasicTypes+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Reader+import GHC.Types.Basic import Util import ListSetOps          ( removeDups ) import Outputable-import SrcLoc-import Literal             ( inCharRange )+import GHC.Types.SrcLoc+import GHC.Types.Literal   ( inCharRange ) import TysWiredIn          ( nilDataCon )-import DataCon+import GHC.Core.DataCon import qualified GHC.LanguageExtensions as LangExt  import Control.Monad       ( when, ap, guard )
compiler/GHC/Rename/Source.hs view
@@ -25,8 +25,8 @@ import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )  import GHC.Hs-import FieldLabel-import RdrName+import GHC.Types.FieldLabel+import GHC.Types.Name.Reader import GHC.Rename.Types import GHC.Rename.Binds import GHC.Rename.Env@@ -41,30 +41,30 @@ import TcAnnotations    ( annCtxt ) import TcRnMonad -import ForeignCall      ( CCallTarget(..) )-import Module-import GHC.Driver.Types         ( Warnings(..), plusWarns )+import GHC.Types.ForeignCall ( CCallTarget(..) )+import GHC.Types.Module+import GHC.Driver.Types ( Warnings(..), plusWarns ) import PrelNames        ( applicativeClassName, pureAName, thenAName                         , monadClassName, returnMName, thenMName                         , semigroupClassName, sappendName                         , monoidClassName, mappendName                         )-import Name-import NameSet-import NameEnv-import Avail+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Avail import Outputable import Bag-import BasicTypes       ( pprRuleName, TypeOrKind(..) )+import GHC.Types.Basic  ( pprRuleName, TypeOrKind(..) ) import FastString-import SrcLoc+import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )-import GHC.Driver.Types         ( HscEnv, hsc_dflags )+import GHC.Driver.Types ( HscEnv, hsc_dflags ) import ListSetOps       ( findDupsEq, removeDups, equivClasses ) import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)                         , stronglyConnCompFromEdgedVerticesUniq )-import UniqSet+import GHC.Types.Unique.Set import OrdList import qualified GHC.LanguageExtensions as LangExt
compiler/GHC/Rename/Splice.hs view
@@ -16,10 +16,10 @@  import GhcPrelude -import Name-import NameSet+import GHC.Types.Name+import GHC.Types.Name.Set import GHC.Hs-import RdrName+import GHC.Types.Name.Reader import TcRnMonad  import GHC.Rename.Env@@ -27,15 +27,15 @@ import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Source  ( rnSrcDecls, findSplice ) import GHC.Rename.Pat     ( rnPat )-import BasicTypes       ( TopLevelFlag, isTopLevel, SourceText(..) )+import GHC.Types.Basic    ( TopLevelFlag, isTopLevel, SourceText(..) ) import Outputable-import Module-import SrcLoc+import GHC.Types.Module+import GHC.Types.SrcLoc import GHC.Rename.Types ( rnLHsType )  import Control.Monad    ( unless, when ) -import {-# SOURCE #-} GHC.Rename.Expr   ( rnLExpr )+import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )  import TcEnv            ( checkWellStaged ) import THNames          ( liftName )
compiler/GHC/Rename/Splice.hs-boot view
@@ -3,7 +3,7 @@ import GhcPrelude import GHC.Hs import TcRnMonad-import NameSet+import GHC.Types.Name.Set   rnSpliceType :: HsSplice GhcPs   -> RnM (HsType GhcRn, FreeVars)
compiler/GHC/Rename/Types.hs view
@@ -46,17 +46,17 @@ import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn                          , lookupTyFixityRn ) import TcRnMonad-import RdrName+import GHC.Types.Name.Reader import PrelNames import TysPrim          ( funTyConName )-import Name-import SrcLoc-import NameSet-import FieldLabel+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Types.Name.Set+import GHC.Types.FieldLabel  import Util import ListSetOps       ( deleteBys )-import BasicTypes       ( compareFixity, funTyFixity, negateFixity+import GHC.Types.Basic  ( compareFixity, funTyFixity, negateFixity                         , Fixity(..), FixityDirection(..), LexicalFixity(..)                         , TypeOrKind(..) ) import Outputable@@ -1462,7 +1462,7 @@  The k comes first because a depends on k, even though the k appears later than the a in the code. Thus, GHC does ScopedSort on the variables.-See Note [ScopedSort] in Type.+See Note [ScopedSort] in GHC.Core.Type.  Implicitly bound variables are collected by any function which returns a FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably
compiler/GHC/Rename/Unbound.hs view
@@ -19,12 +19,12 @@  import GhcPrelude -import RdrName+import GHC.Types.Name.Reader import GHC.Driver.Types import TcRnMonad-import Name-import Module-import SrcLoc+import GHC.Types.Name+import GHC.Types.Module+import GHC.Types.SrcLoc as SrcLoc import Outputable import PrelNames ( mkUnboundName, isUnboundName, getUnique) import Util@@ -33,7 +33,7 @@ import FastString import Data.List import Data.Function ( on )-import UniqDFM (udfmToList)+import GHC.Types.Unique.DFM (udfmToList)  {- ************************************************************************
compiler/GHC/Rename/Utils.hs view
@@ -36,18 +36,18 @@ import GhcPrelude  import GHC.Hs-import RdrName+import GHC.Types.Name.Reader import GHC.Driver.Types import TcEnv import TcRnMonad-import Name-import NameSet-import NameEnv-import DataCon-import SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Core.DataCon+import GHC.Types.SrcLoc as SrcLoc import Outputable import Util-import BasicTypes       ( TopLevelFlag(..) )+import GHC.Types.Basic  ( TopLevelFlag(..) ) import ListSetOps       ( removeDups ) import GHC.Driver.Session import FastString
compiler/GHC/Runtime/Debugger.hs view
@@ -23,14 +23,14 @@ import GHCi.RemoteTypes import GHC.Driver.Monad import GHC.Driver.Types-import Id+import GHC.Types.Id import GHC.Iface.Syntax ( showToHeader ) import GHC.Iface.Env    ( newInteractiveBinder )-import Name-import Var hiding ( varName )-import VarSet-import UniqSet-import Type+import GHC.Types.Name+import GHC.Types.Var hiding ( varName )+import GHC.Types.Var.Set+import GHC.Types.Unique.Set+import GHC.Core.Type import GHC import Outputable import GHC.Core.Ppr.TyThing
compiler/GHC/Runtime/Eval.hs view
@@ -58,37 +58,38 @@ import GHC.Driver.Main import GHC.Hs import GHC.Driver.Types-import InstEnv-import GHC.Iface.Env   ( newInteractiveBinder )-import FamInstEnv      ( FamInst )-import GHC.Core.FVs    ( orphNamesOfFamInst )-import TyCon-import Type             hiding( typeKind )+import GHC.Core.InstEnv+import GHC.Iface.Env       ( newInteractiveBinder )+import GHC.Core.FamInstEnv ( FamInst )+import GHC.Core.FVs        ( orphNamesOfFamInst )+import GHC.Core.TyCon+import GHC.Core.Type       hiding( typeKind ) import GHC.Types.RepType import TcType import Constraint import TcOrigin-import Predicate-import Var-import Id-import Name             hiding ( varName )-import NameSet-import Avail-import RdrName-import VarEnv+import GHC.Core.Predicate+import GHC.Types.Var+import GHC.Types.Id as Id+import GHC.Types.Name      hiding ( varName )+import GHC.Types.Name.Set+import GHC.Types.Avail+import GHC.Types.Name.Reader+import GHC.Types.Var.Env import GHC.ByteCode.Types import GHC.Runtime.Linker as Linker import GHC.Driver.Session-import Unique-import UniqSupply+import GHC.LanguageExtensions+import GHC.Types.Unique+import GHC.Types.Unique.Supply import MonadUtils-import Module+import GHC.Types.Module import PrelNames  ( toDynName, pretendNameIsInScope ) import TysWiredIn ( isCTupleTyConName ) import Panic import Maybes import ErrUtils-import SrcLoc+import GHC.Types.SrcLoc import GHC.Runtime.Heap.Inspect import Outputable import FastString@@ -142,14 +143,6 @@     Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number     _ -> panic "getHistorySpan" -getModBreaks :: HomeModInfo -> ModBreaks-getModBreaks hmi-  | Just linkable <- hm_linkable hmi,-    [BCOs cbc _] <- linkableUnlinked linkable-  = fromMaybe emptyModBreaks (bc_breaks cbc)-  | otherwise-  = emptyModBreaks -- probably object code- {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings@@ -280,7 +273,7 @@     -- a virtual CWD is only necessary when we're running interpreted code in     -- the same process as the compiler.   case hsc_interp hsc_env of-    Just (ExternalInterp _) -> m+    Just (ExternalInterp {}) -> m     _ -> do       let ic = hsc_IC hsc_env       let set_cwd = do@@ -1254,17 +1247,20 @@ obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term #if defined(HAVE_INTERNAL_INTERPRETER) obtainTermFromVal hsc_env bound force ty x = withInterp hsc_env $ \case-  InternalInterp   -> cvObtainTerm hsc_env bound force ty (unsafeCoerce x)+  InternalInterp    -> cvObtainTerm hsc_env bound force ty (unsafeCoerce x) #else obtainTermFromVal hsc_env _bound _force _ty _x = withInterp hsc_env $ \case #endif-  ExternalInterp _ -> throwIO (InstallationError+  ExternalInterp {} -> throwIO (InstallationError                         "this operation requires -fno-external-interpreter")  obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id =  do   hv <- Linker.getHValue hsc_env (varName id)-  cvObtainTerm hsc_env bound force (idType id) hv+  cvObtainTerm (updEnv hsc_env) bound force (idType id) hv+ where updEnv env = env {hsc_dflags =                             -- #14828+            xopt_set (hsc_dflags env) ImpredicativeTypes}+         -- See Note [Setting ImpredicativeTypes for :print command]  -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)@@ -1274,3 +1270,39 @@  mkRuntimeUnkTyVar :: Name -> Kind -> TyVar mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk+++{-+Note [Setting ImpredicativeTypes for :print command]++If ImpredicativeTypes is not enabled, then `:print <term>` will fail if the+type of <term> has nested `forall`s or `=>`s.+This is because the GHCi debugger's internals will attempt to unify a+metavariable with the type of <term> and then display the result, but if the+type has nested `forall`s or `=>`s, then unification will fail.+As a result, `:print` will bail out and the unhelpful result will be+`<term> = (_t1::t1)` (where `t1` is a metavariable).++Beware: <term> can have nested `forall`s even if its definition doesn't use+RankNTypes! Here is an example from #14828:++  class Functor f where+    fmap :: (a -> b) -> f a -> f b++Somewhat surprisingly, `:print fmap` considers the type of fmap to have+nested foralls. This is because the GHCi debugger sees the type+`fmap :: forall f. Functor f => forall a b. (a -> b) -> f a -> f b`.+We could envision deeply instantiating this type to get the type+`forall f a b. Functor f => (a -> b) -> f a -> f b`,+but this trick wouldn't work for higher-rank types.++Instead, we adopt a simpler fix: enable `ImpredicativeTypes` when using+`:print` and friends in the GHCi debugger. This allows metavariables+to unify with types that have nested (or higher-rank) `forall`s/`=>`s,+which makes `:print fmap` display as+`fmap = (_t1::forall a b. Functor f => (a -> b) -> f a -> f b)`, as expected.++Although ImpredicativeTypes is a somewhat unpredictable from a type inference+perspective, there is no danger in using it in the GHCi debugger, since all+of the terms that the GHCi debugger deals with have already been typechecked.+-}
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -26,16 +26,18 @@ #include "HsVersions.h"  import GhcPrelude+import GHC.Platform  import GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes import GHC.Driver.Types+import GHCi.Message ( fromSerializableException ) -import DataCon-import Type+import GHC.Core.DataCon+import GHC.Core.Type import GHC.Types.RepType-import qualified Unify as U-import Var+import qualified GHC.Core.Unify as U+import GHC.Types.Var import TcRnMonad import TcType import TcMType@@ -43,14 +45,14 @@ import TcUnify import TcEnv -import TyCon-import Name-import OccName-import Module+import GHC.Core.TyCon+import GHC.Types.Name+import GHC.Types.Name.Occurrence as OccName+import GHC.Types.Module import GHC.Iface.Env import Util-import VarSet-import BasicTypes       ( Boxity(..) )+import GHC.Types.Var.Set+import GHC.Types.Basic ( Boxity(..) ) import TysPrim import PrelNames import TysWiredIn@@ -59,6 +61,7 @@ import GHC.Char import GHC.Exts.Heap import GHC.Runtime.Heap.Layout ( roundUpTo )+import GHC.IO (throwIO)  import Control.Monad import Data.Maybe@@ -378,7 +381,7 @@                 alloca $ \p -> poke p w >> peek (castPtr p)       return (Just (Ppr.double f))    -- let's assume that if we get two words, we're on a 32-bit-   -- machine. There's no good way to get a DynFlags to check the word+   -- machine. There's no good way to get a Platform to check the word    -- size here.    ppr_double  _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do       let f = unsafeDupablePerformIO $@@ -717,8 +720,13 @@ -- Thunks we may want to force       t | isThunk t && force -> do          traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))-         liftIO $ GHCi.seqHValue hsc_env a-         go (pred max_depth) my_ty old_ty a+         evalRslt <- liftIO $ GHCi.seqHValue hsc_env a+         case evalRslt of                                            -- #2950+           EvalSuccess _ -> go (pred max_depth) my_ty old_ty a+           EvalException ex -> do+              -- Report the exception to the UI+              traceTR $ text "Exception occured:" <+> text (show ex)+              liftIO $ throwIO $ fromSerializableException ex -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If -- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as -- the suspension so that entering it in GHCi will enter the BLACKHOLE instead@@ -826,7 +834,7 @@     go ptr_i arr_i (ty:tys)       | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty       , isUnboxedTupleTyCon tc-                -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+                -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon       = do (ptr_i, arr_i, terms0) <-                go ptr_i arr_i (dropRuntimeRepArgs elem_tys)            (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys@@ -858,9 +866,10 @@           -- within a single word. See also           -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding           dflags <- getDynFlags-          let word_size = wORD_SIZE dflags+          let platform = targetPlatform dflags+              word_size = platformWordSizeInBytes platform               big_endian = wORDS_BIGENDIAN dflags-              size_b = primRepSizeB dflags rep+              size_b = primRepSizeB platform rep               -- Align the start offset (eg, 2-byte value should be 2-byte               -- aligned). But not more than to a word. The offset calculation               -- should be the same with the offset calculation in
compiler/GHC/Runtime/Interpreter.hs view
@@ -2,8 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} ------ | Interacting with the interpreter, whether it is running on an+-- | Interacting with the iserv interpreter, whether it is running on an -- external process or in the current process. -- module GHC.Runtime.Interpreter@@ -24,7 +23,10 @@   , breakpointStatus   , getBreakpointVar   , getClosure+  , getModBreaks   , seqHValue+  , interpreterDynamic+  , interpreterProfiled    -- * The object-code linker   , initObjLinker@@ -41,7 +43,7 @@    -- * Lower-level API using messages   , iservCmd, Message(..), withIServ, withIServ_-  , withInterp, stopInterp+  , withInterp, hscInterp, stopInterp   , iservCall, readIServ, writeIServ   , purgeLookupSymbolCache   , freeHValueRefs@@ -55,22 +57,31 @@  import GHC.Runtime.Interpreter.Types import GHCi.Message-#if defined(HAVE_INTERNAL_INTERPRETER)-import GHCi.Run-#endif import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) import Fingerprint import GHC.Driver.Types-import UniqFM+import GHC.Types.Unique.FM import Panic import GHC.Driver.Session import Exception-import BasicTypes+import GHC.Types.Basic import FastString import Util+import GHC.Runtime.Eval.Types(BreakInfo(..))+import Outputable(brackets, ppr, showSDocUnqual)+import GHC.Types.SrcLoc+import Maybes+import GHC.Types.Module+import GHC.ByteCode.Types+import GHC.Types.Unique +#if defined(HAVE_INTERNAL_INTERPRETER)+import GHCi.Run+import GHC.Driver.Ways+#endif+ import Control.Concurrent import Control.Monad import Control.Monad.IO.Class@@ -78,12 +89,12 @@ import Data.Binary.Put import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB+import Data.Array ((!)) import Data.IORef import Foreign hiding (void) import GHC.Exts.Heap import GHC.Stack.CCS (CostCentre,CostCentreStack) import System.Exit-import Data.Maybe import GHC.IO.Handle.Types (Handle) #if defined(mingw32_HOST_OS) import Foreign.C@@ -169,7 +180,7 @@ #if defined(HAVE_INTERNAL_INTERPRETER)   InternalInterp     -> run msg -- Just run it directly #endif-  (ExternalInterp i) -> withIServ_ i $ \iserv ->+  (ExternalInterp c i) -> withIServ_ c i $ \iserv ->     uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]       iservCall iserv msg @@ -178,10 +189,16 @@ -- -- Fails if no target code interpreter is available withInterp :: HscEnv -> (Interp -> IO a) -> IO a-withInterp hsc_env action = case hsc_interp hsc_env of-   Nothing -> throwIO (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")-   Just i  -> action i+withInterp hsc_env action = action (hscInterp hsc_env) +-- | Retreive the targe code interpreter+--+-- Fails if no target code interpreter is available+hscInterp :: HscEnv -> Interp+hscInterp hsc_env = case hsc_interp hsc_env of+   Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")+   Just i  -> i+ -- Note [uninterruptibleMask_ and iservCmd] -- -- If we receive an async exception, such as ^C, while communicating@@ -195,14 +212,14 @@ -- Overloaded because this is used from TcM as well as IO. withIServ   :: (MonadIO m, ExceptionMonad m)-  => IServ -> (IServInstance -> m (IServInstance, a)) -> m a-withIServ (IServ mIServState) action = do+  => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a+withIServ conf (IServ mIServState) action = do   gmask $ \restore -> do     state <- liftIO $ takeMVar mIServState      iserv <- case state of       -- start the external iserv process if we haven't done so yet-      IServPending conf ->+      IServPending ->          liftIO (spawnIServ conf)            `gonException` (liftIO $ putMVar mIServState state) @@ -223,8 +240,8 @@  withIServ_   :: (MonadIO m, ExceptionMonad m)-  => IServ -> (IServInstance -> m a) -> m a-withIServ_ iserv action = withIServ iserv $ \inst ->+  => IServConfig -> IServ -> (IServInstance -> m a) -> m a+withIServ_ conf iserv action = withIServ conf iserv $ \inst ->    (inst,) <$> action inst  -- -----------------------------------------------------------------------------@@ -373,11 +390,46 @@     mb <- iservCmd hsc_env (GetClosure hval)     mapM (mkFinalizedHValue hsc_env) mb -seqHValue :: HscEnv -> ForeignHValue -> IO ()+-- | Send a Seq message to the iserv process to force a value      #2950+seqHValue :: HscEnv -> ForeignHValue -> IO (EvalResult ()) seqHValue hsc_env ref =   withForeignRef ref $ \hval ->-    iservCmd hsc_env (Seq hval) >>= fromEvalResult+    iservCmd hsc_env (Seq hval) >>= handleSeqHValueStatus hsc_env +-- | Process the result of a Seq or ResumeSeq message.             #2950+handleSeqHValueStatus :: HscEnv -> EvalStatus () -> IO (EvalResult ())+handleSeqHValueStatus hsc_env eval_status = do+  case eval_status of+    (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do+      -- A breakpoint was hit, inform the user and tell him+      -- which breakpoint was hit.+      resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt+      let hmi = expectJust "handleRunStatus" $+                  lookupHptDirectly (hsc_HPT hsc_env)+                    (mkUniqueGrimily mod_uniq)+          modl = mi_module (hm_iface hmi)+          bp | is_exception = Nothing+             | otherwise = Just (BreakInfo modl ix)+          sdocBpLoc = brackets . ppr . getSeqBpSpan+      putStrLn ("*** Ignoring breakpoint " +++            (showSDocUnqual (hsc_dflags hsc_env) $ sdocBpLoc bp))+      -- resume the seq (:force) processing in the iserv process+      withForeignRef resume_ctxt_fhv $ \hval ->+        iservCmd hsc_env (ResumeSeq hval) >>= handleSeqHValueStatus hsc_env+    (EvalComplete _ r) -> return r+  where+    getSeqBpSpan :: Maybe BreakInfo -> SrcSpan+    -- Just case: Stopped at a breakpoint, extract SrcSpan information+    -- from the breakpoint.+    getSeqBpSpan (Just BreakInfo{..}) =+      (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number+    -- Nothing case - should not occur!+    -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq+    getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "<unknown>")+    breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $+      lookupHpt (hsc_HPT hsc_env) (moduleName mod)++ -- ----------------------------------------------------------------------------- -- Interface to the object-code linker @@ -390,7 +442,7 @@   InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) #endif -  ExternalInterp i -> withIServ i $ \iserv -> do+  ExternalInterp c i -> withIServ c i $ \iserv -> do     -- Profiling of GHCi showed a lot of time and allocation spent     -- making cross-process LookupSymbol calls, so I added a GHC-side     -- cache which sped things up quite a lot.  We have to be careful@@ -419,9 +471,9 @@ #if defined(HAVE_INTERNAL_INTERPRETER)   Just InternalInterp -> pure () #endif-  Just (ExternalInterp (IServ mstate)) ->+  Just (ExternalInterp _ (IServ mstate)) ->     modifyMVar_ mstate $ \state -> pure $ case state of-      IServPending {}    -> state+      IServPending       -> state       IServRunning iserv -> IServRunning         (iserv { iservLookupSymbolCache = emptyUFM }) @@ -522,7 +574,6 @@     , iservProcess           = ph     , iservLookupSymbolCache = emptyUFM     , iservPendingFrees      = []-    , iservConfig            = conf     }  -- | Stop the interpreter@@ -532,16 +583,16 @@ #if defined(HAVE_INTERNAL_INTERPRETER)   Just InternalInterp -> pure () #endif-  Just (ExternalInterp (IServ mstate)) ->+  Just (ExternalInterp _ (IServ mstate)) ->     gmask $ \_restore -> modifyMVar_ mstate $ \state -> do       case state of-        IServPending {} -> pure state -- already stopped+        IServPending    -> pure state -- already stopped         IServRunning i  -> do           ex <- getProcessExitCode (iservProcess i)           if isJust ex              then pure ()              else iservCall i Shutdown-          pure (IServPending (iservConfig i))+          pure IServPending  runWithPipes :: (CreateProcess -> IO ProcessHandle)              -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)@@ -627,11 +678,11 @@    let hvref = toHValueRef rref     free <- case hsc_interp hsc_env of-     Nothing                         -> return (pure ())+     Nothing                           -> return (pure ()) #if defined(HAVE_INTERNAL_INTERPRETER)-     Just InternalInterp             -> return (freeRemoteRef hvref)+     Just InternalInterp               -> return (freeRemoteRef hvref) #endif-     Just (ExternalInterp (IServ i)) -> return $ modifyMVar_ i $ \state ->+     Just (ExternalInterp _ (IServ i)) -> return $ modifyMVar_ i $ \state ->        case state of          IServPending {}   -> pure state -- already shut down          IServRunning inst -> do@@ -656,9 +707,9 @@ -- the compiler, so it fails when @-fexternal-interpreter@ is on. wormholeRef :: Interp -> RemoteRef a -> IO a #if defined(HAVE_INTERNAL_INTERPRETER)-wormholeRef InternalInterp     _r = localRef _r+wormholeRef InternalInterp      _r = localRef _r #endif-wormholeRef (ExternalInterp _) _r+wormholeRef (ExternalInterp {}) _r   = throwIO (InstallationError       "this operation requires -fno-external-interpreter") @@ -676,3 +727,25 @@ fromEvalResult :: EvalResult a -> IO a fromEvalResult (EvalException e) = throwIO (fromSerializableException e) fromEvalResult (EvalSuccess a) = return a++getModBreaks :: HomeModInfo -> ModBreaks+getModBreaks hmi+  | Just linkable <- hm_linkable hmi,+    [BCOs cbc _] <- linkableUnlinked linkable+  = fromMaybe emptyModBreaks (bc_breaks cbc)+  | otherwise+  = emptyModBreaks -- probably object code++-- | Interpreter uses Profiling way+interpreterProfiled :: Interp -> Bool+#if defined(HAVE_INTERNAL_INTERPRETER)+interpreterProfiled InternalInterp       = hostIsProfiled+#endif+interpreterProfiled (ExternalInterp c _) = iservConfProfiled c++-- | Interpreter uses Dynamic way+interpreterDynamic :: Interp -> Bool+#if defined(HAVE_INTERNAL_INTERPRETER)+interpreterDynamic InternalInterp       = hostIsDynamic+#endif+interpreterDynamic (ExternalInterp c _) = iservConfDynamic c
compiler/GHC/Runtime/Linker.hs view
@@ -43,20 +43,21 @@ import GHC.Driver.Phases import GHC.Driver.Finder import GHC.Driver.Types-import Name-import NameEnv-import Module+import GHC.Driver.Ways+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Module import ListSetOps import GHC.Runtime.Linker.Types (DynLinker(..), LinkerUnitId, PersistentLinkerState(..)) import GHC.Driver.Session-import BasicTypes+import GHC.Types.Basic import Outputable import Panic import Util import ErrUtils-import SrcLoc+import GHC.Types.SrcLoc import qualified Maybes-import UniqDSet+import GHC.Types.Unique.DSet import FastString import GHC.Platform import SysTools@@ -65,6 +66,7 @@ -- Standard libraries import Control.Monad +import qualified Data.Set as Set import Data.Char (isSpace) import Data.IORef import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition)@@ -185,7 +187,7 @@               m <- lookupClosure hsc_env (unpackFS sym_to_find)               case m of                 Just hvref -> mkFinalizedHValue hsc_env hvref-                Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE"+                Nothing -> linkFail "GHC.Runtime.Linker.getHValue"                              (unpackFS sym_to_find)  linkDependencies :: HscEnv -> PersistentLinkerState@@ -470,7 +472,7 @@                  Nothing -> maybePutStrLn dflags "done"                  Just mm -> preloadFailed mm framework_paths lib_spec               return pls-      else panic "preloadLib Framework"+      else throwGhcExceptionIO (ProgramError "preloadLib Framework")    where     dflags = hsc_dflags hsc_env@@ -492,7 +494,7 @@     preload_statics _paths names        = do b <- or <$> mapM doesFileExist names             if not b then return (False, pls)-                     else if dynamicGhc+                     else if hostIsDynamic                              then  do pls1 <- dynLoadObjs hsc_env pls names                                       return (True, pls1)                              else  do mapM_ (loadObj hsc_env) names@@ -501,7 +503,7 @@     preload_static_archive _paths name        = do b <- doesFileExist name             if not b then return False-                     else do if dynamicGhc+                     else do if hostIsDynamic                                  then throwGhcExceptionIO $                                       CmdLineError dynamic_msg                                  else loadArchive hsc_env name@@ -577,22 +579,22 @@  checkNonStdWay :: HscEnv -> SrcSpan -> IO (Maybe FilePath) checkNonStdWay hsc_env srcspan-  | Just (ExternalInterp _) <- hsc_interp hsc_env = return Nothing+  | Just (ExternalInterp {}) <- hsc_interp hsc_env = return Nothing     -- with -fexternal-interpreter we load the .o files, whatever way     -- they were built.  If they were built for a non-std way, then     -- we will use the appropriate variant of the iserv binary to load them. -  | interpWays == haskellWays = return Nothing+  | hostFullWays == targetFullWays = return Nothing     -- Only if we are compiling with the same ways as GHC is built     -- with, can we dynamically load those object files. (see #3604) -  | objectSuf (hsc_dflags hsc_env) == normalObjectSuffix && not (null haskellWays)+  | objectSuf (hsc_dflags hsc_env) == normalObjectSuffix && not (null targetFullWays)   = failNonStd (hsc_dflags hsc_env) srcspan -  | otherwise = return (Just (interpTag ++ "o"))+  | otherwise = return (Just (hostWayTag ++ "o"))   where-    haskellWays = filter (not . wayRTSOnly) (ways (hsc_dflags hsc_env))-    interpTag = case mkBuildTag interpWays of+    targetFullWays = Set.filter (not . wayRTSOnly) (ways (hsc_dflags hsc_env))+    hostWayTag = case waysTag hostFullWays of                   "" -> ""                   tag -> tag ++ "_" @@ -614,8 +616,8 @@             | WayProf `elem` ways dflags = text "-prof"             | otherwise = text "normal"           ghciWay-            | dynamicGhc = text "with -dynamic"-            | rtsIsProfiled = text "with -prof"+            | hostIsDynamic = text "with -dynamic"+            | hostIsProfiled = text "with -prof"             | otherwise = text "the normal way"  getLinkDeps :: HscEnv -> HomePackageTable@@ -884,7 +886,7 @@             unlinkeds                = concatMap linkableUnlinked new_objs             wanted_objs              = map nameOfObject unlinkeds -        if interpreterDynamic (hsc_dflags hsc_env)+        if interpreterDynamic (hscInterp hsc_env)             then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs                     return (pls2, Succeeded)             else do mapM_ (loadObj hsc_env) wanted_objs@@ -948,8 +950,8 @@                       -- Even if we're e.g. profiling, we still want                       -- the vanilla dynamic libraries, so we set the                       -- ways / build tag to be just WayDyn.-                      ways = [WayDyn],-                      buildTag = mkBuildTag [WayDyn],+                      ways = Set.singleton WayDyn,+                      buildTag = waysTag (Set.singleton WayDyn),                       outputFile = Just soFile                   }     -- link all "loaded packages" so symbols in those can be resolved@@ -962,7 +964,9 @@     m <- loadDLL hsc_env soFile     case m of         Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }-        Just err -> panic ("Loading temp shared object failed: " ++ err)+        Just err -> linkFail msg err+  where+    msg = "GHC.Runtime.Linker.dynLoadObjs: Loading temp shared object failed"  rmDupLinkables :: [Linkable]    -- Already loaded                -> [Linkable]    -- New linkables@@ -1141,7 +1145,7 @@   where     unloadObjs :: Linkable -> IO ()     unloadObjs lnk-      | dynamicGhc = return ()+      | hostIsDynamic = return ()         -- We don't do any cleanup when linking objects with the         -- dynamic linker.  Doing so introduces extra complexity for         -- not much benefit.@@ -1244,6 +1248,7 @@     return $! pls { pkgs_loaded = pkgs' }   where      dflags = hsc_dflags hsc_env+     pkgstate = pkgState dflags       link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId]      link pkgs new_pkgs =@@ -1253,7 +1258,7 @@         | new_pkg `elem` pkgs   -- Already linked         = return pkgs -        | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg+        | Just pkg_cfg <- lookupInstalledPackage pkgstate new_pkg         = do {  -- Link dependents first                pkgs' <- link pkgs (depends pkg_cfg)                 -- Now link the package itself@@ -1269,7 +1274,7 @@    = do         let dflags    = hsc_dflags hsc_env             platform  = targetPlatform dflags-            is_dyn = interpreterDynamic dflags+            is_dyn    = interpreterDynamic (hscInterp hsc_env)             dirs | is_dyn    = Packages.libraryDynDirs pkg                  | otherwise = Packages.libraryDirs pkg @@ -1485,6 +1490,7 @@     where      dflags = hsc_dflags hsc_env+     interp = hscInterp hsc_env      dirs   = lib_dirs ++ gcc_dirs      gcc    = False      user   = True@@ -1499,8 +1505,8 @@                   ]      lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" -     loading_profiled_hs_libs = interpreterProfiled dflags-     loading_dynamic_hs_libs  = interpreterDynamic dflags+     loading_profiled_hs_libs = interpreterProfiled interp+     loading_dynamic_hs_libs  = interpreterDynamic  interp       import_libs  = [ lib <.> "lib"           , "lib" ++ lib <.> "lib"                     , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"@@ -1546,7 +1552,7 @@      assumeDll       | is_hs       , not loading_dynamic_hs_libs-      , interpreterProfiled dflags+      , interpreterProfiled interp       = do           warningMsg dflags             (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$
compiler/GHC/Runtime/Loader.hs view
@@ -26,26 +26,26 @@ import GHC.Runtime.Linker      ( linkModule, getHValue ) import GHC.Runtime.Interpreter ( wormhole, withInterp ) import GHC.Runtime.Interpreter.Types-import SrcLoc           ( noSrcSpan )-import GHC.Driver.Finder( findPluginModule, cannotFindModule )-import TcRnMonad        ( initTcInteractive, initIfaceTcRn )-import GHC.Iface.Load   ( loadPluginInterface )-import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)-                        , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName-                        , gre_name, mkRdrQual )-import OccName          ( OccName, mkVarOcc )+import GHC.Types.SrcLoc        ( noSrcSpan )+import GHC.Driver.Finder       ( findPluginModule, cannotFindModule )+import TcRnMonad               ( initTcInteractive, initIfaceTcRn )+import GHC.Iface.Load          ( loadPluginInterface )+import GHC.Types.Name.Reader  ( RdrName, ImportSpec(..), ImpDeclSpec(..)+                               , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName+                               , gre_name, mkRdrQual )+import GHC.Types.Name.Occurrence ( OccName, mkVarOcc ) import GHC.Rename.Names ( gresFromAvails ) import GHC.Driver.Plugins import PrelNames        ( pluginTyConName, frontendPluginTyConName )  import GHC.Driver.Types-import GHCi.RemoteTypes ( HValue )-import Type             ( Type, eqType, mkTyConTy )-import TyCoPpr          ( pprTyThingCategory )-import TyCon            ( TyCon )-import Name             ( Name, nameModule_maybe )-import Id               ( idType )-import Module           ( Module, ModuleName )+import GHCi.RemoteTypes  ( HValue )+import GHC.Core.Type     ( Type, eqType, mkTyConTy )+import GHC.Core.TyCo.Ppr ( pprTyThingCategory )+import GHC.Core.TyCon    ( TyCon )+import GHC.Types.Name    ( Name, nameModule_maybe )+import GHC.Types.Id      ( idType )+import GHC.Types.Module  ( Module, ModuleName ) import Panic import FastString import ErrUtils@@ -105,7 +105,7 @@ -- #14335 checkExternalInterpreter :: HscEnv -> IO () checkExternalInterpreter hsc_env-  | Just (ExternalInterp _) <- hsc_interp hsc_env+  | Just (ExternalInterp {}) <- hsc_interp hsc_env   = throwIO (InstallationError "Plugins require -fno-external-interpreter")   | otherwise   = pure ()
compiler/GHC/Stg/CSE.hs view
@@ -88,16 +88,16 @@  import GhcPrelude -import DataCon-import Id+import GHC.Core.DataCon+import GHC.Types.Id import GHC.Stg.Syntax import Outputable-import VarEnv+import GHC.Types.Var.Env import GHC.Core (AltCon(..)) import Data.List (mapAccumL) import Data.Maybe (fromMaybe) import GHC.Core.Map-import NameEnv+import GHC.Types.Name.Env import Control.Monad( (>=>) )  --------------
compiler/GHC/Stg/DepAnal.hs view
@@ -5,13 +5,13 @@ import GhcPrelude  import GHC.Stg.Syntax-import Id-import Name (Name, nameIsLocalOrFrom)-import NameEnv+import GHC.Types.Id+import GHC.Types.Name (Name, nameIsLocalOrFrom)+import GHC.Types.Name.Env import Outputable-import UniqSet (nonDetEltsUniqSet)-import VarSet-import Module (Module)+import GHC.Types.Unique.Set (nonDetEltsUniqSet)+import GHC.Types.Var.Set+import GHC.Types.Module (Module)  import Data.Graph (SCC (..))
compiler/GHC/Stg/FVs.hs view
@@ -45,8 +45,8 @@ import GhcPrelude  import GHC.Stg.Syntax-import Id-import VarSet+import GHC.Types.Id+import GHC.Types.Var.Set import GHC.Core    ( Tickish(Breakpoint) ) import Outputable import Util
compiler/GHC/Stg/Lift.hs view
@@ -19,17 +19,17 @@  import GhcPrelude -import BasicTypes+import GHC.Types.Basic import GHC.Driver.Session-import Id+import GHC.Types.Id import GHC.Stg.FVs ( annBindingFreeVars ) import GHC.Stg.Lift.Analysis import GHC.Stg.Lift.Monad import GHC.Stg.Syntax import Outputable-import UniqSupply+import GHC.Types.Unique.Supply import Util-import VarSet+import GHC.Types.Var.Set import Control.Monad ( when ) import Data.Maybe ( isNothing )
compiler/GHC/Stg/Lift/Analysis.hs view
@@ -21,11 +21,12 @@   ) where  import GhcPrelude+import GHC.Platform -import BasicTypes-import Demand+import GHC.Types.Basic+import GHC.Types.Demand import GHC.Driver.Session-import Id+import GHC.Types.Id import GHC.Runtime.Heap.Layout ( WordOff ) import GHC.Stg.Syntax import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep@@ -33,7 +34,7 @@ import qualified GHC.StgToCmm.Layout  as StgToCmm.Layout import Outputable import Util-import VarSet+import GHC.Types.Var.Set  import Data.Maybe ( mapMaybe ) @@ -374,6 +375,7 @@   , ("args spill on stack", args_spill_on_stack)   , ("increases allocation", inc_allocs)   ] where+      platform = targetPlatform dflags       decide deciders         | not (fancy_or deciders)         = llTrace "stgLiftLams:lifting"@@ -475,7 +477,7 @@         . expander         . flip dVarSetMinusVarSet bndrs_set         $ freeVarsOfRhs rhs-      clo_growth = closureGrowth expander (idClosureFootprint dflags) bndrs_set abs_ids scope+      clo_growth = closureGrowth expander (idClosureFootprint platform) bndrs_set abs_ids scope  rhsLambdaBndrs :: LlStgRhs -> [Id] rhsLambdaBndrs StgRhsCon{} = []@@ -499,9 +501,9 @@ -- Note that this can't handle unboxed tuples (which may still be present in -- let-no-escapes, even after Unarise), in which case -- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash.-idClosureFootprint:: DynFlags -> Id -> WordOff-idClosureFootprint dflags-  = StgToCmm.ArgRep.argRepSizeW dflags+idClosureFootprint:: Platform -> Id -> WordOff+idClosureFootprint platform+  = StgToCmm.ArgRep.argRepSizeW platform   . StgToCmm.ArgRep.idArgRep  -- | @closureGrowth expander sizer f fvs@ computes the closure growth in words
compiler/GHC/Stg/Lift/Monad.hs view
@@ -24,21 +24,21 @@  import GhcPrelude -import BasicTypes-import CostCentre ( isCurrentCCS, dontCareCCS )+import GHC.Types.Basic+import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS ) import GHC.Driver.Session import FastString-import Id-import Name+import GHC.Types.Id+import GHC.Types.Name import Outputable import OrdList import GHC.Stg.Subst import GHC.Stg.Syntax-import Type-import UniqSupply+import GHC.Core.Type+import GHC.Types.Unique.Supply import Util-import VarEnv-import VarSet+import GHC.Types.Var.Env+import GHC.Types.Var.Set  import Control.Arrow ( second ) import Control.Monad.Trans.Class@@ -271,7 +271,7 @@   let str = "$l" ++ occNameString (getOccName bndr)   let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)   let bndr'-        -- See Note [transferPolyIdInfo] in Id.hs. We need to do this at least+        -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least         -- for arity information.         = transferPolyIdInfo bndr (dVarSetElems abs_ids)         . mkSysLocal (mkFastString str) uniq
compiler/GHC/Stg/Lint.hs view
@@ -42,20 +42,20 @@ import GHC.Stg.Syntax  import GHC.Driver.Session-import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )-import BasicTypes       ( TopLevelFlag(..), isTopLevel )-import CostCentre       ( isCurrentCCS )-import Id               ( Id, idType, isJoinId, idName )-import VarSet-import DataCon-import GHC.Core         ( AltCon(..) )-import Name             ( getSrcLoc, nameIsLocalOrFrom )-import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )-import Type+import Bag                  ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )+import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel )+import GHC.Types.CostCentre ( isCurrentCCS )+import GHC.Types.Id         ( Id, idType, isJoinId, idName )+import GHC.Types.Var.Set+import GHC.Core.DataCon+import GHC.Core             ( AltCon(..) )+import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )+import ErrUtils             ( MsgDoc, Severity(..), mkLocMessage )+import GHC.Core.Type import GHC.Types.RepType-import SrcLoc+import GHC.Types.SrcLoc import Outputable-import Module           ( Module )+import GHC.Types.Module           ( Module ) import qualified ErrUtils as Err import Control.Applicative ((<|>)) import Control.Monad
compiler/GHC/Stg/Pipeline.hs view
@@ -23,11 +23,11 @@ import GHC.Stg.Unarise  ( unarise ) import GHC.Stg.CSE      ( stgCse ) import GHC.Stg.Lift     ( stgLiftLams )-import Module           ( Module )+import GHC.Types.Module ( Module )  import GHC.Driver.Session import ErrUtils-import UniqSupply+import GHC.Types.Unique.Supply import Outputable import Control.Monad import Control.Monad.IO.Class
compiler/GHC/Stg/Stats.hs view
@@ -31,7 +31,7 @@  import GHC.Stg.Syntax -import Id (Id)+import GHC.Types.Id (Id) import Panic  import Data.Map (Map)
compiler/GHC/Stg/Subst.hs view
@@ -6,8 +6,8 @@  import GhcPrelude -import Id-import VarEnv+import GHC.Types.Id+import GHC.Types.Var.Env import Control.Monad.Trans.State.Strict import Outputable import Util
compiler/GHC/Stg/Unarise.hs view
@@ -202,24 +202,24 @@  import GhcPrelude -import BasicTypes+import GHC.Types.Basic import GHC.Core-import DataCon+import GHC.Core.DataCon import FastString (FastString, mkFastString)-import Id-import Literal+import GHC.Types.Id+import GHC.Types.Literal import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID)-import MkId (voidPrimId, voidArgId)+import GHC.Types.Id.Make (voidPrimId, voidArgId) import MonadUtils (mapAccumLM) import Outputable import GHC.Types.RepType import GHC.Stg.Syntax-import Type+import GHC.Core.Type import TysPrim (intPrimTy,wordPrimTy,word64PrimTy) import TysWiredIn-import UniqSupply+import GHC.Types.Unique.Supply import Util-import VarEnv+import GHC.Types.Var.Env  import Data.Bifunctor (second) import Data.Maybe (mapMaybe)
compiler/GHC/StgToCmm.hs view
@@ -34,17 +34,17 @@ import ErrUtils  import GHC.Driver.Types-import CostCentre-import Id-import IdInfo+import GHC.Types.CostCentre+import GHC.Types.Id+import GHC.Types.Id.Info import GHC.Types.RepType-import DataCon-import TyCon-import Module+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Types.Module import Outputable import Stream-import BasicTypes-import VarSet ( isEmptyDVarSet )+import GHC.Types.Basic+import GHC.Types.Var.Set ( isEmptyDVarSet )  import OrdList import GHC.Cmm.Graph@@ -188,6 +188,7 @@ -- the static closure, for a constructor. cgDataCon data_con   = do  { dflags <- getDynFlags+        ; platform <- getPlatform         ; let             (tot_wds, --  #ptr_wds + #nonptr_wds              ptr_wds) --  #ptr_wds@@ -216,7 +217,7 @@             do { tickyEnterDynCon                ; ldvEnter (CmmReg nodeReg)                ; tickyReturnOldCon (length arg_reps)-               ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]+               ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon dflags data_con)]                }                     -- The case continuation code expects a tagged pointer         }
compiler/GHC/StgToCmm/ArgRep.hs view
@@ -6,6 +6,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE LambdaCase #-}+ module GHC.StgToCmm.ArgRep (         ArgRep(..), toArgRep, argRepSizeW, @@ -16,15 +18,14 @@         ) where  import GhcPrelude--import GHC.StgToCmm.Closure ( idPrimRep )+import GHC.Platform -import GHC.Runtime.Heap.Layout            ( WordOff )-import Id               ( Id )-import TyCon            ( PrimRep(..), primElemRepSizeB )-import BasicTypes       ( RepArity )-import Constants        ( wORD64_SIZE )-import GHC.Driver.Session+import GHC.StgToCmm.Closure    ( idPrimRep )+import GHC.Runtime.Heap.Layout ( WordOff )+import GHC.Types.Id            ( Id )+import GHC.Core.TyCon          ( PrimRep(..), primElemRepSizeB )+import GHC.Types.Basic         ( RepArity )+import Constants               ( wORD64_SIZE, dOUBLE_SIZE )  import Outputable import FastString@@ -91,16 +92,19 @@ isNonV V = False isNonV _ = True -argRepSizeW :: DynFlags -> ArgRep -> WordOff                -- Size in words-argRepSizeW _      N   = 1-argRepSizeW _      P   = 1-argRepSizeW _      F   = 1-argRepSizeW dflags L   = wORD64_SIZE        `quot` wORD_SIZE dflags-argRepSizeW dflags D   = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags-argRepSizeW _      V   = 0-argRepSizeW dflags V16 = 16                 `quot` wORD_SIZE dflags-argRepSizeW dflags V32 = 32                 `quot` wORD_SIZE dflags-argRepSizeW dflags V64 = 64                 `quot` wORD_SIZE dflags+argRepSizeW :: Platform -> ArgRep -> WordOff -- Size in words+argRepSizeW platform = \case+   N   -> 1+   P   -> 1+   F   -> 1+   L   -> wORD64_SIZE `quot` ws+   D   -> dOUBLE_SIZE `quot` ws+   V   -> 0+   V16 -> 16          `quot` ws+   V32 -> 32          `quot` ws+   V64 -> 64          `quot` ws+  where+   ws       = platformWordSizeInBytes platform  idArgRep :: Id -> ArgRep idArgRep = toArgRep . idPrimRep
compiler/GHC/StgToCmm/Bind.hs view
@@ -14,6 +14,7 @@   ) where  import GhcPrelude hiding ((<*>))+import GHC.Platform  import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad@@ -37,15 +38,15 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Stg.Syntax-import CostCentre-import Id-import IdInfo-import Name-import Module+import GHC.Types.CostCentre+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name+import GHC.Types.Module import ListSetOps import Util-import VarSet-import BasicTypes+import GHC.Types.Var.Set+import GHC.Types.Basic import Outputable import FastString import GHC.Driver.Session@@ -69,9 +70,10 @@                 -> (CgIdInfo, FCode ())  cgTopRhsClosure dflags rec id ccs upd_flag args body =-  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)+  let platform      = targetPlatform dflags+      closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)       cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)-      lf_info       = mkClosureLFInfo dflags id TopLevel [] upd_flag args+      lf_info       = mkClosureLFInfo platform id TopLevel [] upd_flag args   in (cg_id_info, gen_code dflags lf_info closure_label)   where   -- special case for a indirection (f = g).  We create an IND_STATIC@@ -274,7 +276,7 @@                                    -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise   , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee) -  , let offset_into_int = bytesToWordsRoundUp dflags the_offset+  , let offset_into_int = bytesToWordsRoundUp (targetPlatform dflags) the_offset                           - fixedHdrSizeW dflags   , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough   = -- NOT TRUE: ASSERT(is_single_constructor)@@ -323,10 +325,11 @@  ---------- Default case ------------------ mkRhsClosure dflags bndr cc fvs upd_flag args body-  = do  { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args+  = do  { let lf_info = mkClosureLFInfo platform bndr NotTopLevel fvs upd_flag args         ; (id_info, reg) <- rhsIdInfo bndr lf_info         ; return (id_info, gen_code lf_info reg) }  where+ platform = targetPlatform dflags  gen_code lf_info reg   = do  {       -- LAY OUT THE OBJECT         -- If the binder is itself a free variable, then don't store@@ -340,7 +343,6 @@          -- MAKE CLOSURE INFO FOR THIS CLOSURE         ; mod_name <- getModuleName-        ; dflags <- getDynFlags         ; let   name  = idName bndr                 descr = closureDescription dflags mod_name name                 fv_details :: [(NonVoid Id, ByteOff)]@@ -412,18 +414,18 @@   ; return (mkRhsInit dflags reg lf_info hp_plus_n) }  -mkClosureLFInfo :: DynFlags+mkClosureLFInfo :: Platform                 -> Id           -- The binder                 -> TopLevelFlag -- True of top level                 -> [NonVoid Id] -- Free vars                 -> UpdateFlag   -- Update flag                 -> [Id]         -- Args                 -> LambdaFormInfo-mkClosureLFInfo dflags bndr top fvs upd_flag args+mkClosureLFInfo platform bndr top fvs upd_flag args   | null args =         mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag   | otherwise =-        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args)+        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr platform args)   ------------------------------------------------------------------------@@ -479,6 +481,7 @@                 -- Emit slow-entry code (for entering a closure through a PAP)                 { mkSlowEntryCode bndr cl_info arg_regs                 ; dflags <- getDynFlags+                ; platform <- getPlatform                 ; let node_points = nodeMustPointToIt dflags lf_info                       node' = if node_points then Just node else Nothing                 ; loop_header_id <- newBlockId@@ -494,9 +497,9 @@                 -- ticky after heap check to avoid double counting                 ; tickyEnterFun cl_info                 ; enterCostCentreFun cc-                    (CmmMachOp (mo_wordSub dflags)+                    (CmmMachOp (mo_wordSub platform)                          [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]-                         , mkIntExpr dflags (funTag dflags cl_info) ])+                         , mkIntExpr platform (funTag dflags cl_info) ])                 ; fv_bindings <- mapM bind_fv fv_details                 -- Load free vars out of closure *after*                 -- heap check, to reduce live vars over check@@ -526,8 +529,9 @@ load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode () load_fvs node lf_info = mapM_ (\ (reg, off) ->    do dflags <- getDynFlags+      platform <- getPlatform       let tag = lfDynTag dflags lf_info-      emit $ mkTaggedObjectLoad dflags reg node off tag)+      emit $ mkTaggedObjectLoad platform reg node off tag)  ----------------------------------------- -- The "slow entry" code for a function.  This entry point takes its@@ -545,14 +549,15 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'   | Just (_, ArgGen _) <- closureFunInfo cl_info   = do dflags <- getDynFlags-       let node = idToReg dflags (NonVoid bndr)+       platform <- getPlatform+       let node = idToReg platform (NonVoid bndr)            slow_lbl = closureSlowEntryLabel  cl_info            fast_lbl = closureLocalEntryLabel dflags cl_info            -- mkDirectJump does not clobber `Node' containing function closure            jump = mkJump dflags NativeNodeCall                                 (mkLblExpr fast_lbl)                                 (map (CmmReg . CmmLocal) (node : arg_regs))-                                (initUpdFrameOff dflags)+                                (initUpdFrameOff platform)        tscope <- getTickScope        emitProcWithConvention Slow Nothing slow_lbl          (node : arg_regs) (jump, tscope)@@ -601,6 +606,7 @@ emitBlackHoleCode :: CmmExpr -> FCode () emitBlackHoleCode node = do   dflags <- getDynFlags+  let platform = targetPlatform dflags    -- Eager blackholing is normally disabled, but can be turned on with   -- -feager-blackholing.  When it is on, we replace the info pointer@@ -627,8 +633,8 @@              -- work with profiling.    when eager_blackholing $ do-    whenUpdRemSetEnabled dflags $ emitUpdRemSetPushThunk node-    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr+    whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node+    emitStore (cmmOffsetW platform node (fixedHdrSizeW dflags)) currentTSOExpr     -- See Note [Heap memory barriers] in SMP.h.     emitPrimCall [] MO_WriteBarrier []     emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))@@ -691,9 +697,10 @@   let            hdr         = fixedHdrSize dflags            off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags+           platform    = targetPlatform dflags   --   emitStore frame (mkLblExpr lbl)-  emitStore (cmmOffset dflags frame off_updatee) updatee+  emitStore (cmmOffset platform frame off_updatee) updatee   initUpdFrameProf frame  -----------------------------------------------------------------------------@@ -711,7 +718,8 @@         -- blackhole indirection closure   ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing                                     ForeignLabelInExternalPackage IsFunction-  ; bh <- newTemp (bWord dflags)+  ; let platform = targetPlatform dflags+  ; bh <- newTemp (bWord platform)   ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl       [ (baseExpr,  AddrHint),         (CmmReg (CmmLocal node), AddrHint) ]@@ -721,7 +729,7 @@   ; updfr  <- getUpdFrameOff   ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))   ; emit =<< mkCmmIfThen-      (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))+      (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform))         -- re-enter the CAF        (mkJump dflags NativeNodeCall target [] updfr)
compiler/GHC/StgToCmm/CgUtils.hs view
@@ -149,7 +149,7 @@           | reg == MachSp -> stmt           | otherwise ->             let baseAddr = get_GlobalReg_addr dflags reg-            in case reg `elem` activeStgRegs (targetPlatform dflags) of+            in case reg `elem` activeStgRegs platform of                 True  -> CmmAssign (CmmGlobal reg) src                 False -> CmmStore baseAddr src         other_stmt -> other_stmt@@ -170,7 +170,7 @@                     let baseAddr = get_GlobalReg_addr dflags reg                     in case reg of                         BaseReg -> baseAddr-                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)+                        _other  -> CmmLoad baseAddr (globalRegType platform reg)          CmmRegOff (CmmGlobal reg) offset ->             -- RegOf leaves are just a shorthand form. If the reg maps@@ -178,9 +178,9 @@             -- expand it and defer to the above code.             case reg `elem` activeStgRegs platform of                 True  -> expr-                False -> CmmMachOp (MO_Add (wordWidth dflags)) [+                False -> CmmMachOp (MO_Add (wordWidth platform)) [                                     fixExpr (CmmReg (CmmGlobal reg)),                                     CmmLit (CmmInt (fromIntegral offset)-                                                   (wordWidth dflags))]+                                                   (wordWidth platform))]          other_expr -> other_expr
compiler/GHC/StgToCmm/Closure.hs view
@@ -71,19 +71,19 @@ import GHC.Cmm import GHC.Cmm.Ppr.Expr() -- For Outputable instances -import CostCentre+import GHC.Types.CostCentre import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import Id-import IdInfo-import DataCon-import Name-import Type-import TyCoRep+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core.DataCon+import GHC.Types.Name+import GHC.Core.Type+import GHC.Core.TyCo.Rep import TcType-import TyCon+import GHC.Core.TyCon import GHC.Types.RepType-import BasicTypes+import GHC.Types.Basic import Outputable import GHC.Driver.Session import Util
compiler/GHC/StgToCmm/DataCon.hs view
@@ -34,14 +34,14 @@ import GHC.Cmm.CLabel import GHC.Cmm.Graph import GHC.Runtime.Heap.Layout-import CostCentre-import Module-import DataCon+import GHC.Types.CostCentre+import GHC.Types.Module+import GHC.Core.DataCon import GHC.Driver.Session import FastString-import Id+import GHC.Types.Id import GHC.Types.RepType (countConRepArgs)-import Literal+import GHC.Types.Literal import PrelInfo import Outputable import GHC.Platform@@ -198,7 +198,7 @@               val_int = fromIntegral val :: Int               offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)                 -- INTLIKE closures consist of a header and one word payload-              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW+              intlike_amode = cmmLabelOffW (targetPlatform dflags) intlike_lbl offsetW         ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode                  , return mkNop) } @@ -212,7 +212,7 @@   = do  { let charlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")               offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)                 -- CHARLIKE closures consist of a header and one word payload-              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW+              charlike_amode = cmmLabelOffW (targetPlatform dflags) charlike_lbl offsetW         ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode                  , return mkNop) } @@ -256,6 +256,7 @@ bindConArgs (DataAlt con) base args   = ASSERT(not (isUnboxedTupleCon con))     do dflags <- getDynFlags+       platform <- getPlatform        let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)            tag = tagForCon dflags con @@ -266,7 +267,7 @@              | isDeadBinder b  -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr              = return Nothing              | otherwise-             = do { emit $ mkTaggedObjectLoad dflags (idToReg dflags arg)+             = do { emit $ mkTaggedObjectLoad platform (idToReg platform arg)                                               base offset tag                   ; Just <$> bindArgToReg arg }
compiler/GHC/StgToCmm/Env.hs view
@@ -26,7 +26,8 @@  import GhcPrelude -import TyCon+import GHC.Core.TyCon+import GHC.Platform import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure@@ -37,16 +38,16 @@ import GHC.Cmm.Expr import GHC.Cmm.Utils import GHC.Driver.Session-import Id+import GHC.Types.Id import GHC.Cmm.Graph-import Name+import GHC.Types.Name import Outputable import GHC.Stg.Syntax-import Type+import GHC.Core.Type import TysPrim-import UniqFM+import GHC.Types.Unique.FM import Util-import VarEnv+import GHC.Types.Var.Env  ------------------------------------- --        Manipulating CgIdInfo@@ -60,14 +61,15 @@ litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo litIdInfo dflags id lf lit   = CgIdInfo { cg_id = id, cg_lf = lf-             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }+             , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) }   where     tag = lfDynTag dflags lf+    platform = targetPlatform dflags -lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo-lneIdInfo dflags id regs+lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo+lneIdInfo platform id regs   = CgIdInfo { cg_id = id, cg_lf = lf-             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }+             , cg_loc = LneLoc blk_id (map (idToReg platform) regs) }   where     lf     = mkLFLetNoEscape     blk_id = mkBlockId (idUnique id)@@ -75,13 +77,14 @@  rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) rhsIdInfo id lf_info-  = do dflags <- getDynFlags-       reg <- newTemp (gcWord dflags)+  = do platform <- getPlatform+       reg <- newTemp (gcWord platform)        return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)  mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph mkRhsInit dflags reg lf_info expr-  = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))+  = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag dflags lf_info))+  where platform = targetPlatform dflags  idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer@@ -89,9 +92,9 @@ idInfoToAmode cg_info   = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc -addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr--- A tag adds a byte offset to the pointer-addDynTag dflags expr tag = cmmOffsetB dflags expr tag+-- | A tag adds a byte offset to the pointer+addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr+addDynTag platform expr tag = cmmOffsetB platform expr tag  maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)@@ -177,8 +180,8 @@ bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg -- Bind an Id to a fresh LocalReg bindToReg nvid@(NonVoid id) lf_info-  = do dflags <- getDynFlags-       let reg = idToReg dflags nvid+  = do platform <- getPlatform+       let reg = idToReg platform nvid        addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))        return reg @@ -195,7 +198,7 @@ bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] bindArgsToRegs args = mapM bindArgToReg args -idToReg :: DynFlags -> NonVoid Id -> LocalReg+idToReg :: Platform -> NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument, -- free variable, or case binder --@@ -203,6 +206,6 @@ -- -- By now the Ids should be uniquely named; else one would worry -- about accidental collision-idToReg dflags (NonVoid id)+idToReg platform (NonVoid id)              = LocalReg (idUnique id)-                        (primRepCmmType dflags (idPrimRep id))+                        (primRepCmmType platform (idPrimRep id))
compiler/GHC/StgToCmm/Expr.hs view
@@ -37,15 +37,15 @@ import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Core-import DataCon-import GHC.Driver.Session         ( mAX_PTR_TAG )-import ForeignCall-import Id+import GHC.Core.DataCon+import GHC.Driver.Session ( mAX_PTR_TAG )+import GHC.Types.ForeignCall+import GHC.Types.Id import PrimOp-import TyCon-import Type             ( isUnliftedType )-import GHC.Types.RepType          ( isVoidTy, countConRepArgs )-import CostCentre       ( CostCentreStack, currentCCS )+import GHC.Core.TyCon+import GHC.Core.Type        ( isUnliftedType )+import GHC.Types.RepType    ( isVoidTy, countConRepArgs )+import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) import Maybes import Util import FastString@@ -64,7 +64,7 @@ cgExpr (StgApp fun args)     = cgIdApp fun args  -- seq# a s ==> a--- See Note [seq# magic] in PrelRules+-- See Note [seq# magic] in GHC.Core.Op.ConstantFold cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =   cgIdApp a [] @@ -72,8 +72,9 @@ -- See Note [dataToTag#] in primops.txt.pp cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do   dflags <- getDynFlags+  platform <- getPlatform   emitComment (mkFastString "dataToTag#")-  tmp <- newTemp (bWord dflags)+  tmp <- newTemp (bWord platform)   _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])   -- TODO: For small types look at the tag bits instead of reading info table   emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]@@ -175,8 +176,8 @@         -> FCode (CgIdInfo, FCode ())  cgLetNoEscapeClosure bndr cc_slot _unused_cc args body-  = do dflags <- getDynFlags-       return ( lneIdInfo dflags bndr args+  = do platform <- getPlatform+       return ( lneIdInfo platform bndr args               , code )   where    code = forkLneBody $ do {@@ -364,18 +365,18 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts   | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]   = -- assignment suffices for unlifted types-    do { dflags <- getDynFlags-       ; unless (reps_compatible dflags) $+    do { platform <- getPlatform+       ; unless (reps_compatible platform) $            pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"                     (pp_bndr v $$ pp_bndr bndr)        ; v_info <- getCgIdInfo v-       ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))+       ; emitAssign (CmmLocal (idToReg platform (NonVoid bndr)))                     (idInfoToAmode v_info)        -- Add bndr to the environment        ; _ <- bindArgToReg (NonVoid bndr)        ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }   where-    reps_compatible dflags = primRepCompatible dflags (idPrimRep v) (idPrimRep bndr)+    reps_compatible platform = primRepCompatible platform (idPrimRep v) (idPrimRep bndr)      pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) @@ -390,10 +391,10 @@ it would be better to invoke some kind of panic function here. -} cgCase scrut@(StgApp v []) _ (PrimAlt _) _-  = do { dflags <- getDynFlags+  = do { platform <- getPlatform        ; mb_cc <- maybeSaveCostCentre True        ; _ <- withSequel-                  (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)+                  (AssignTo [idToReg platform (NonVoid v)] False) (cgExpr scrut)        ; restoreCurrentCostCentre mb_cc        ; emitComment $ mkFastString "should be unreachable code"        ; l <- newBlockId@@ -404,7 +405,7 @@  {- Note [Handle seq#] ~~~~~~~~~~~~~~~~~~~~~-See Note [seq# magic] in PrelRules.+See Note [seq# magic] in GHC.Core.Op.ConstantFold. The special case for seq# in cgCase does this:    case seq# a s of v@@ -419,16 +420,16 @@  cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts   = -- Note [Handle seq#]-    -- And see Note [seq# magic] in PrelRules+    -- And see Note [seq# magic] in GHC.Core.Op.ConstantFold     -- Use the same return convention as vanilla 'a'.     cgCase (StgApp a []) bndr alt_type alts  cgCase scrut bndr alt_type alts   = -- the general case-    do { dflags <- getDynFlags+    do { platform <- getPlatform        ; up_hp_usg <- getVirtHp        -- Upstream heap usage        ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts-             alt_regs  = map (idToReg dflags) ret_bndrs+             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@@ -548,11 +549,11 @@         -- Here bndrs are *already* in scope, so don't rebind them  cgAlts gc_plan bndr (PrimAlt _) alts-  = do  { dflags <- getDynFlags+  = do  { platform <- getPlatform          ; tagged_cmms <- cgAltRhss gc_plan bndr alts -        ; let bndr_reg = CmmLocal (idToReg dflags bndr)+        ; let bndr_reg = CmmLocal (idToReg platform bndr)               (DEFAULT,deflt) = head tagged_cmms                 -- PrimAlts always have a DEFAULT case                 -- and it always comes first@@ -564,11 +565,12 @@  cgAlts gc_plan bndr (AlgAlt tycon) alts   = do  { dflags <- getDynFlags+        ; platform <- getPlatform          ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts          ; let !fam_sz   = tyConFamilySize tycon-              !bndr_reg = CmmLocal (idToReg dflags bndr)+              !bndr_reg = CmmLocal (idToReg platform bndr)               !ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)               !branches' = first succ <$> branches               !maxpt = mAX_PTR_TAG dflags@@ -807,9 +809,9 @@ cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]           -> FCode [(AltCon, CmmAGraphScoped)] cgAltRhss gc_plan bndr alts = do-  dflags <- getDynFlags+  platform <- getPlatform   let-    base_reg = idToReg dflags bndr+    base_reg = idToReg platform bndr     cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)     cg_alt (con, bndrs, rhs)       = getCodeScoped             $@@ -1083,10 +1085,10 @@ -- simply pass on the annotation as a @CmmTickish@. cgTick :: Tickish Id -> FCode () cgTick tick-  = do { dflags <- getDynFlags+  = do { platform <- getPlatform        ; case tick of            ProfNote   cc t p -> emitSetCCC cc t p-           HpcTick    m n    -> emit (mkTickBox dflags m n)+           HpcTick    m n    -> emit (mkTickBox platform m n)            SourceNote s n    -> emitTick $ SourceNote s n            _other            -> return () -- ignore        }
compiler/GHC/StgToCmm/ExtCode.hs view
@@ -49,10 +49,10 @@ import GHC.Cmm.BlockId import GHC.Driver.Session import FastString-import Module-import UniqFM-import Unique-import UniqSupply+import GHC.Types.Module+import GHC.Types.Unique.FM+import GHC.Types.Unique+import GHC.Types.Unique.Supply  import Control.Monad (ap)
compiler/GHC/StgToCmm/Foreign.hs view
@@ -32,18 +32,19 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Graph-import Type+import GHC.Core.Type import GHC.Types.RepType import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout-import ForeignCall+import GHC.Types.ForeignCall import GHC.Driver.Session+import GHC.Platform import Maybes import Outputable-import UniqSupply-import BasicTypes+import GHC.Types.Unique.Supply+import GHC.Types.Basic -import TyCoRep+import GHC.Core.TyCo.Rep import TysPrim import Util (zipEqual) @@ -63,7 +64,7 @@               -> FCode ReturnKind  cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty-  = do  { dflags <- getDynFlags+  = do  { platform <- getPlatform         ; let -- in the stdcall calling convention, the symbol needs @size appended               -- to it, where size is the total number of bytes of arguments.  We               -- attach this info to the CLabel here, and the CLabel pretty printer@@ -73,8 +74,8 @@               | otherwise            = Nothing                -- ToDo: this might not be correct for 64-bit API-            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)-                                     (wORD_SIZE dflags)+            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg)+                                     (platformWordSizeInBytes platform)         ; cmm_args <- getFCallArgs stg_args typ         ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty         ; let ((call_args, arg_hints), cmm_target)@@ -222,6 +223,7 @@    | otherwise = do     dflags <- getDynFlags+    platform <- getPlatform     updfr_off <- getUpdFrameOff     target' <- load_target_into_temp target     args' <- mapM maybe_assign_temp args@@ -230,7 +232,7 @@        -- see Note [safe foreign call convention]     tscope <- getTickScope     emit $-           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))+           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth platform)))                         (CmmLit (CmmBlock k))             <*> mkLast (CmmForeignCall { tgt  = target'                                        , res  = results@@ -264,8 +266,8 @@ -- maybe_assign_temp :: CmmExpr -> FCode CmmExpr maybe_assign_temp e = do-  dflags <- getDynFlags-  reg <- newTemp (cmmExprType dflags e)+  platform <- getPlatform+  reg <- newTemp (cmmExprType platform e)   emitAssign (CmmLocal reg) e   return (CmmReg (CmmLocal reg)) @@ -284,30 +286,32 @@ -- | Produce code to save the current thread state to @CurrentTSO@ saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph saveThreadState dflags = do-  tso <- newTemp (gcWord dflags)+  let platform = targetPlatform dflags+  tso <- newTemp (gcWord platform)   close_nursery <- closeNursery dflags tso   pure $ catAGraphs [     -- tso = CurrentTSO;     mkAssign (CmmLocal tso) currentTSOExpr,     -- tso->stackobj->sp = Sp;-    mkStore (cmmOffset dflags-                       (CmmLoad (cmmOffset dflags+    mkStore (cmmOffset platform+                       (CmmLoad (cmmOffset platform                                            (CmmReg (CmmLocal tso))                                            (tso_stackobj dflags))-                                (bWord dflags))+                                (bWord platform))                        (stack_SP dflags))             spExpr,     close_nursery,     -- and save the current cost centre stack in the TSO when profiling:     if gopt Opt_SccProfilingOn dflags then-        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr+        mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr       else mkNop     ]  emitCloseNursery :: FCode () emitCloseNursery = do   dflags <- getDynFlags-  tso <- newTemp (bWord dflags)+  platform <- getPlatform+  tso <- newTemp (bWord platform)   code <- closeNursery dflags tso   emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code @@ -335,26 +339,27 @@ closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph closeNursery df tso = do   let tsoreg  = CmmLocal tso-  cnreg      <- CmmLocal <$> newTemp (bWord df)+      platform = targetPlatform df+  cnreg      <- CmmLocal <$> newTemp (bWord platform)   pure $ catAGraphs [     mkAssign cnreg currentNurseryExpr,      -- CurrentNursery->free = Hp+1;-    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),+    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW platform hpExpr 1),      let alloc =-           CmmMachOp (mo_wordSub df)-              [ cmmOffsetW df hpExpr 1-              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)+           CmmMachOp (mo_wordSub platform)+              [ cmmOffsetW platform hpExpr 1+              , CmmLoad (nursery_bdescr_start df cnreg) (bWord platform)               ] -        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)+        alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit df)     in      -- tso->alloc_limit += alloc     mkStore alloc_limit (CmmMachOp (MO_Sub W64)                                [ CmmLoad alloc_limit b64-                               , CmmMachOp (mo_WordTo64 df) [alloc] ])+                               , CmmMachOp (mo_WordTo64 platform) [alloc] ])    ]  emitLoadThreadState :: FCode ()@@ -366,29 +371,30 @@ -- | Produce code to load the current thread state from @CurrentTSO@ loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph loadThreadState dflags = do-  tso <- newTemp (gcWord dflags)-  stack <- newTemp (gcWord dflags)+  let platform = targetPlatform dflags+  tso <- newTemp (gcWord platform)+  stack <- newTemp (gcWord platform)   open_nursery <- openNursery dflags tso   pure $ catAGraphs [     -- tso = CurrentTSO;     mkAssign (CmmLocal tso) currentTSOExpr,     -- stack = tso->stackobj;-    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),+    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord platform)),     -- Sp = stack->sp;-    mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),+    mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord platform)),     -- SpLim = stack->stack + RESERVED_STACK_WORDS;-    mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))+    mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK dflags))                                 (rESERVED_STACK_WORDS dflags)),     -- HpAlloc = 0;     --   HpAlloc is assumed to be set to non-zero only by a failed     --   a heap check, see HeapStackCheck.cmm:GC_GENERIC-    mkAssign hpAllocReg (zeroExpr dflags),+    mkAssign hpAllocReg (zeroExpr platform),     open_nursery,     -- and load the current cost centre stack from the TSO when profiling:     if gopt Opt_SccProfilingOn dflags        then storeCurCCS-              (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))-                 (tso_CCCS dflags)) (ccsType dflags))+              (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso))+                 (tso_CCCS dflags)) (ccsType platform))        else mkNop    ] @@ -396,7 +402,8 @@ emitOpenNursery :: FCode () emitOpenNursery = do   dflags <- getDynFlags-  tso <- newTemp (bWord dflags)+  platform <- getPlatform+  tso <- newTemp (bWord platform)   code <- openNursery dflags tso   emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code @@ -429,11 +436,12 @@ @ -} openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph-openNursery df tso = do+openNursery dflags tso = do   let tsoreg =  CmmLocal tso-  cnreg      <- CmmLocal <$> newTemp (bWord df)-  bdfreereg  <- CmmLocal <$> newTemp (bWord df)-  bdstartreg <- CmmLocal <$> newTemp (bWord df)+      platform = targetPlatform dflags+  cnreg      <- CmmLocal <$> newTemp (bWord platform)+  bdfreereg  <- CmmLocal <$> newTemp (bWord platform)+  bdstartreg <- CmmLocal <$> newTemp (bWord platform)    -- These assignments are carefully ordered to reduce register   -- pressure and generate not completely awful code on x86.  To see@@ -441,23 +449,23 @@   -- stg_returnToStackTop in rts/StgStartup.cmm.   pure $ catAGraphs [      mkAssign cnreg currentNurseryExpr,-     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),+     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free dflags cnreg)  (bWord platform)),       -- Hp = CurrentNursery->free - 1;-     mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)),+     mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), -     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),+     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start dflags cnreg) (bWord platform)),       -- HpLim = CurrentNursery->start +      --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;      mkAssign hpLimReg-         (cmmOffsetExpr df+         (cmmOffsetExpr platform              (CmmReg bdstartreg)-             (cmmOffset df-               (CmmMachOp (mo_wordMul df) [-                 CmmMachOp (MO_SS_Conv W32 (wordWidth df))-                   [CmmLoad (nursery_bdescr_blocks df cnreg) b32],-                 mkIntExpr df (bLOCK_SIZE df)+             (cmmOffset platform+               (CmmMachOp (mo_wordMul platform) [+                 CmmMachOp (MO_SS_Conv W32 (wordWidth platform))+                   [CmmLoad (nursery_bdescr_blocks dflags cnreg) b32],+                 mkIntExpr platform (bLOCK_SIZE dflags)                 ])                (-1)              )@@ -465,26 +473,26 @@       -- alloc = bd->free - bd->start      let alloc =-           CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]+           CmmMachOp (mo_wordSub platform) [CmmReg bdfreereg, CmmReg bdstartreg] -         alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)+         alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit dflags)      in       -- tso->alloc_limit += alloc      mkStore alloc_limit (CmmMachOp (MO_Add W64)                                [ CmmLoad alloc_limit b64-                               , CmmMachOp (mo_WordTo64 df) [alloc] ])+                               , CmmMachOp (mo_WordTo64 platform) [alloc] ])     ]  nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks   :: DynFlags -> CmmReg -> CmmExpr nursery_bdescr_free   dflags cn =-  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)+  cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_free dflags) nursery_bdescr_start  dflags cn =-  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)+  cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_start dflags) nursery_bdescr_blocks dflags cn =-  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)+  cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_blocks dflags)  tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)@@ -583,9 +591,11 @@ add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr add_shim dflags ty expr = case ty of   StgPlainType -> expr-  StgArrayType -> cmmOffsetB dflags expr (arrPtrsHdrSize dflags)-  StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)-  StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize dflags)+  StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize dflags)+  StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize dflags)+  StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize dflags)+  where+    platform = targetPlatform dflags  -- From a function, extract information needed to determine -- the offset of each argument when used as a C FFI argument.
compiler/GHC/StgToCmm/Heap.hs view
@@ -41,11 +41,12 @@ import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Utils-import CostCentre-import IdInfo( CafInfo(..), mayHaveCafRefs )-import Id ( Id )-import Module+import GHC.Types.CostCentre+import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs )+import GHC.Types.Id ( Id )+import GHC.Types.Module import GHC.Driver.Session+import GHC.Platform import FastString( mkFastString, fsLit ) import Panic( sorry ) @@ -143,7 +144,8 @@ emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs   = do dflags <- getDynFlags-       hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..])+       let platform = targetPlatform dflags+       hpStore base (zip (header dflags) [0, platformWordSizeInBytes platform ..])   where     header :: DynFlags -> [CmmExpr]     header dflags = [info_ptr] ++ dynProfHdr dflags ccs@@ -153,9 +155,9 @@ -- Store the item (expr,off) in base[off] hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode () hpStore base vals = do-  dflags <- getDynFlags+  platform <- getPlatform   sequence_ $-    [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ]+    [ emitStore (cmmOffsetB platform base off) val | (val,off) <- vals ]  ----------------------------------------------------------- --              Layout of static closures@@ -175,6 +177,7 @@   = mkStaticClosure dflags info_lbl ccs payload padding         static_link_field saved_info_field   where+    platform = targetPlatform dflags     info_lbl = cit_lbl info_tbl      -- CAFs must have consistent layout, regardless of whether they@@ -192,27 +195,27 @@     is_caf = isThunkRep (cit_rep info_tbl)      padding-        | is_caf && null payload = [mkIntCLit dflags 0]+        | is_caf && null payload = [mkIntCLit platform 0]         | otherwise = []      static_link_field         | is_caf-        = [mkIntCLit dflags 0]+        = [mkIntCLit platform 0]         | staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl         = [static_link_value]         | otherwise         = []      saved_info_field-        | is_caf     = [mkIntCLit dflags 0]+        | is_caf     = [mkIntCLit platform 0]         | otherwise  = []          -- For a static constructor which has NoCafRefs, we set the         -- static link field to a non-zero value so the garbage         -- collector will ignore it.     static_link_value-        | mayHaveCafRefs caf_refs  = mkIntCLit dflags 0-        | otherwise                = mkIntCLit dflags 3  -- No CAF refs+        | mayHaveCafRefs caf_refs  = mkIntCLit platform 0+        | otherwise                = mkIntCLit platform 3  -- No CAF refs                                       -- See Note [STATIC_LINK fields]                                       -- in rts/sm/Storage.h @@ -402,7 +405,8 @@ altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a altOrNoEscapeHeapCheck checkYield regs code = do     dflags <- getDynFlags-    case cannedGCEntryPoint dflags regs of+    platform <- getPlatform+    case cannedGCEntryPoint platform regs of       Nothing -> genericGC checkYield code       Just gc -> do         lret <- newBlockId@@ -415,8 +419,8 @@  altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a altHeapCheckReturnsTo regs lret off code-  = do dflags <- getDynFlags-       case cannedGCEntryPoint dflags regs of+  = do platform <- getPlatform+       case cannedGCEntryPoint platform regs of            Nothing -> genericGC False code            Just gc -> cannedGCReturnsTo False True gc regs lret off code @@ -455,8 +459,8 @@        call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []        heapCheck False checkYield (call <*> mkBranch lretry) code -cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr-cannedGCEntryPoint dflags regs+cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr+cannedGCEntryPoint platform regs   = case map localRegType regs of       []  -> Just (mkGcLabel "stg_gc_noregs")       [ty]@@ -466,9 +470,9 @@                                   W64       -> Just (mkGcLabel "stg_gc_d1")                                   _         -> Nothing -          | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")-          | width == W64              -> Just (mkGcLabel "stg_gc_l1")-          | otherwise                 -> Nothing+          | width == wordWidth platform -> Just (mkGcLabel "stg_gc_unbx_r1")+          | width == W64                -> Just (mkGcLabel "stg_gc_l1")+          | otherwise                   -> Nothing           where               width = typeWidth ty       [ty1,ty2]@@ -518,6 +522,7 @@     -- Emit heap checks, but be sure to do it lazily so     -- that the conditionals on hpHw don't cause a black hole     do  { dflags <- getDynFlags+        ; platform <- getPlatform         ; let mb_alloc_bytes                  | hpHw > mBLOCK_SIZE = sorry $ unlines                     [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",@@ -526,7 +531,7 @@                      "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",                      "Suggestion: read data from a file instead of having large static data",                      "structures in code."]-                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))+                 | hpHw > 0  = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform)))                  | otherwise = Nothing                  where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags               stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)@@ -598,26 +603,27 @@           -> FCode () do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do   dflags <- getDynFlags+  platform <- getPlatform   gc_id <- newBlockId    let     Just alloc_lit = mb_alloc_lit -    bump_hp   = cmmOffsetExprB dflags hpExpr alloc_lit+    bump_hp   = cmmOffsetExprB platform hpExpr alloc_lit      -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)     -- At the beginning of a function old + 0 = Sp     -- See Note [Single stack check]     sp_oflo sp_hwm =-         CmmMachOp (mo_wordULt dflags)-                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))+         CmmMachOp (mo_wordULt platform)+                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType platform spReg)))                              [CmmStackSlot Old 0, sp_hwm],                    CmmReg spLimReg]      -- Hp overflow if (Hp > HpLim)     -- (Hp has been incremented by now)     -- HpLim points to the LAST WORD of valid allocation space.-    hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]+    hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr, hpLimExpr]      alloc_n = mkAssign hpAllocReg alloc_lit @@ -643,9 +649,9 @@     else do       when (checkYield && not (gopt Opt_OmitYields dflags)) $ do          -- Yielding if HpLim == 0-         let yielding = CmmMachOp (mo_wordEq dflags)+         let yielding = CmmMachOp (mo_wordEq platform)                                   [CmmReg hpLimReg,-                                   CmmLit (zeroCLit dflags)]+                                   CmmLit (zeroCLit platform)]          emit =<< mkCmmIfGoto' yielding gc_id (Just False)    tscope <- getTickScope
compiler/GHC/StgToCmm/Hpc.hs view
@@ -12,10 +12,11 @@  import GHC.StgToCmm.Monad +import GHC.Platform import GHC.Cmm.Graph import GHC.Cmm.Expr import GHC.Cmm.CLabel-import Module+import GHC.Types.Module import GHC.Cmm.Utils import GHC.StgToCmm.Utils import GHC.Driver.Types@@ -23,14 +24,14 @@  import Control.Monad -mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph-mkTickBox dflags mod n+mkTickBox :: Platform -> Module -> Int -> CmmAGraph+mkTickBox platform mod n   = mkStore tick_box (CmmMachOp (MO_Add W64)                                 [ CmmLoad tick_box b64                                 , CmmLit (CmmInt 1 W64)                                 ])   where-    tick_box = cmmIndex dflags W64+    tick_box = cmmIndex platform W64                         (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)                         n
compiler/GHC/StgToCmm/Layout.hs view
@@ -49,11 +49,12 @@ import GHC.Cmm.Info import GHC.Cmm.CLabel import GHC.Stg.Syntax-import Id-import TyCon             ( PrimRep(..), primRepSizeB )-import BasicTypes        ( RepArity )+import GHC.Types.Id+import GHC.Core.TyCon    ( PrimRep(..), primRepSizeB )+import GHC.Types.Basic   ( RepArity ) import GHC.Driver.Session-import Module+import GHC.Platform+import GHC.Types.Module  import Util import Data.List@@ -78,12 +79,13 @@ emitReturn :: [CmmExpr] -> FCode ReturnKind emitReturn results   = do { dflags    <- getDynFlags+       ; platform  <- getPlatform        ; sequel    <- getSequel        ; updfr_off <- getUpdFrameOff        ; case sequel of            Return ->              do { adjustHpBackwards-                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)+                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)                 ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)                 }            AssignTo regs adjust ->@@ -189,6 +191,7 @@ -- (slowCall fun args) applies fun to args, returning the results to Sequel slowCall fun stg_args   = do  dflags <- getDynFlags+        platform <- getPlatform         argsreps <- getArgRepsAmodes stg_args         let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -227,8 +230,8 @@              is_tagged_lbl <- newBlockId              end_lbl <- newBlockId -             let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)-                                                  (mkIntExpr dflags n_args)+             let correct_arity = cmmEqWord platform (funInfoArity dflags fun_iptr)+                                                    (mkIntExpr platform n_args)               tscope <- getTickScope              emit (mkCbranch (cmmIsTagged dflags funv)@@ -389,9 +392,9 @@ getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr -- See Note [Virtual and real heap pointers] in GHC.StgToCmm.Monad getHpRelOffset virtual_offset-  = do dflags <- getDynFlags+  = do platform <- getPlatform        hp_usg <- getHpUsage-       return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))+       return (cmmRegOffW platform hpReg (hpRel (realHp hp_usg) virtual_offset))  data FieldOffOrPadding a     = FieldOff (NonVoid a) -- Something that needs an offset.@@ -426,15 +429,16 @@ mkVirtHeapOffsetsWithPadding dflags header things =     ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))     ( tot_wds-    , bytesToWordsRoundUp dflags bytes_of_ptrs+    , bytesToWordsRoundUp platform bytes_of_ptrs     , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad     )   where+    platform = targetPlatform dflags     hdr_words = case header of       NoHeader -> 0       StdHeader -> fixedHdrSizeW dflags       ThunkHeader -> thunkHdrSize dflags-    hdr_bytes = wordsToBytes dflags hdr_words+    hdr_bytes = wordsToBytes platform hdr_words      (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things @@ -443,7 +447,7 @@     (tot_bytes, non_ptrs_w_offsets) =        mapAccumL computeOffset bytes_of_ptrs non_ptrs -    tot_wds = bytesToWordsRoundUp dflags tot_bytes+    tot_wds = bytesToWordsRoundUp platform tot_bytes      final_pad_size = tot_wds * word_size - tot_bytes     final_pad@@ -451,7 +455,7 @@                                          (hdr_bytes + tot_bytes))]         | otherwise          = [] -    word_size = wORD_SIZE dflags+    word_size = platformWordSizeInBytes platform      computeOffset bytes_so_far nv_thing =         (new_bytes_so_far, with_padding field_off)@@ -459,7 +463,7 @@         (rep, thing) = fromNonVoid nv_thing          -- Size of the field in bytes.-        !sizeB = primRepSizeB dflags rep+        !sizeB = primRepSizeB platform rep          -- Align the start offset (eg, 2-byte value should be 2-byte aligned).         -- But not more than to a word.@@ -528,20 +532,20 @@ -- bring in ARG_P, ARG_N, etc. #include "rts/storage/FunTypes.h" -mkArgDescr :: DynFlags -> [Id] -> ArgDescr-mkArgDescr dflags args-  = let arg_bits = argBits dflags arg_reps+mkArgDescr :: Platform -> [Id] -> ArgDescr+mkArgDescr platform args+  = let arg_bits = argBits platform arg_reps         arg_reps = filter isNonV (map idArgRep args)            -- Getting rid of voids eases matching of standard patterns     in case stdPattern arg_reps of          Just spec_id -> ArgSpec spec_id          Nothing      -> ArgGen  arg_bits -argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr-argBits _      []           = []-argBits dflags (P   : args) = False : argBits dflags args-argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)-                    ++ argBits dflags args+argBits :: Platform -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr+argBits _         []           = []+argBits platform (P   : args) = False : argBits platform args+argBits platform (arg : args) = take (argRepSizeW platform arg) (repeat True)+                                 ++ argBits platform args  ---------------------- stdPattern :: [ArgRep] -> Maybe Int@@ -598,10 +602,11 @@                             -> FCode () emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body  = do   { dflags <- getDynFlags+        ; platform <- getPlatform         -- Bind the binder itself, but only if it's not a top-level         -- binding. We need non-top let-bindings to refer to the         -- top-level binding, which this binding would incorrectly shadow.-        ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)+        ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr)                   else bindToReg (NonVoid bndr) lf_info         ; let node_points = nodeMustPointToIt dflags lf_info         ; arg_regs <- bindArgsToRegs args
compiler/GHC/StgToCmm/Monad.hs view
@@ -22,7 +22,7 @@         emitOutOfLine, emitAssign, emitStore,         emitComment, emitTick, emitUnwind, -        getCmm, aGraphToGraph,+        getCmm, aGraphToGraph, getPlatform,         getCodeR, getCode, getCodeScoped, getHeapUsage,          mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,@@ -61,6 +61,7 @@  import GhcPrelude hiding( sequence, succ ) +import GHC.Platform import GHC.Cmm import GHC.StgToCmm.Closure import GHC.Driver.Session@@ -69,13 +70,13 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout-import Module-import Id-import VarEnv+import GHC.Types.Module+import GHC.Types.Id+import GHC.Types.Var.Env import OrdList-import BasicTypes( ConTagZ )-import Unique-import UniqSupply+import GHC.Types.Basic( ConTagZ )+import GHC.Types.Unique+import GHC.Types.Unique.Supply import FastString import Outputable import Util@@ -276,7 +277,7 @@ initCgInfoDown dflags mod   = MkCgInfoDown { cgd_dflags    = dflags                  , cgd_mod       = mod-                 , cgd_updfr_off = initUpdFrameOff dflags+                 , cgd_updfr_off = initUpdFrameOff (targetPlatform dflags)                  , cgd_ticky     = mkTopTickyCtrLabel                  , cgd_sequel    = initSequel                  , cgd_self_loop = Nothing@@ -285,8 +286,8 @@ initSequel :: Sequel initSequel = Return -initUpdFrameOff :: DynFlags -> UpdFrameOffset-initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA+initUpdFrameOff :: Platform -> UpdFrameOffset+initUpdFrameOff platform = platformWordSizeInBytes platform -- space for the RA   --------------------------------------------------------@@ -470,6 +471,9 @@ instance HasDynFlags FCode where     getDynFlags = liftM cgd_dflags getInfoDown +getPlatform :: FCode Platform+getPlatform = targetPlatform <$> getDynFlags+ getThisPackage :: FCode UnitId getThisPackage = liftM thisPackage getDynFlags @@ -562,12 +566,12 @@ --     re-bind the free variables to a field of the closure.  forkClosureBody body_code-  = do  { dflags <- getDynFlags+  = do  { platform <- getPlatform         ; info   <- getInfoDown         ; us     <- newUniqSupply         ; state  <- getState         ; let body_info_down = info { cgd_sequel    = initSequel-                                    , cgd_updfr_off = initUpdFrameOff dflags+                                    , cgd_updfr_off = initUpdFrameOff platform                                     , cgd_self_loop = Nothing }               fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }               ((),fork_state_out) = doFCode body_code body_info_down fork_state_in@@ -736,8 +740,8 @@    -> FCode ()  emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False-  = do  { dflags <- getDynFlags-        ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False+  = do  { platform <- getPlatform+        ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth platform)) False         } emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True         -- do layout@@ -758,7 +762,7 @@ emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped          -> Int -> Bool -> FCode () emitProc mb_info lbl live blocks offset do_layout-  = do  { dflags <- getDynFlags+  = do  { platform <- getPlatform         ; l <- newBlockId         ; let               blks :: CmmGraph@@ -768,7 +772,7 @@                     | otherwise            = mapEmpty                sinfo = StackInfo { arg_space = offset-                                , updfr_space = Just (initUpdFrameOff dflags)+                                , updfr_space = Just (initUpdFrameOff platform)                                 , do_layout = do_layout }                tinfo = TopInfo { info_tbls = infos
compiler/GHC/StgToCmm/Prim.hs view
@@ -37,14 +37,14 @@  import GHC.Driver.Session import GHC.Platform-import BasicTypes+import GHC.Types.Basic import GHC.Cmm.BlockId import GHC.Cmm.Graph import GHC.Stg.Syntax import GHC.Cmm-import Module   ( rtsUnitId )-import Type     ( Type, tyConAppTyCon )-import TyCon+import GHC.Types.Module ( rtsUnitId )+import GHC.Core.Type    ( Type, tyConAppTyCon )+import GHC.Core.TyCon import GHC.Cmm.CLabel import GHC.Cmm.Utils import PrimOp@@ -100,8 +100,8 @@                 emitReturn []            | ReturnsPrim rep <- result_info-          -> do dflags <- getDynFlags-                res <- newTemp (primRepCmmType dflags rep)+          -> do platform <- getPlatform+                res <- newTemp (primRepCmmType platform rep)                 f [res]                 emitReturn [CmmReg (CmmLocal res)] @@ -176,11 +176,11 @@    NewArrayOp -> \case     [(CmmLit (CmmInt n w)), init]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)       -> opAllDone $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel-        [ (mkIntExpr dflags (fromInteger n),+        [ (mkIntExpr platform (fromInteger n),            fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)-        , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),+        , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),            fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)         ]         (fromInteger n) init@@ -208,34 +208,34 @@    CloneArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)       -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    CloneMutableArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)       -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    FreezeArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)       -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    ThawArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)       -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    NewSmallArrayOp -> \case     [(CmmLit (CmmInt n w)), init]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)       -> opAllDone $ \ [res] ->         doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel-        [ (mkIntExpr dflags (fromInteger n),+        [ (mkIntExpr platform (fromInteger n),            fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)         ]         (fromInteger n) init@@ -253,25 +253,25 @@    CloneSmallArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)       -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    CloneSmallMutableArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)       -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    FreezeSmallArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)       -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External    ThawSmallArrayOp -> \case     [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)       -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)     _ -> PrimopCmmEmit_External @@ -290,7 +290,7 @@     -- refer to arg twice (once to pass to newSpark(), and once to     -- assign to res), so put it in a temporary.     tmp <- assignTemp arg-    tmp2 <- newTemp (bWord dflags)+    tmp2 <- newTemp (bWord platform)     emitCCall         [(tmp2,NoHint)]         (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))@@ -301,7 +301,7 @@     let       val        | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)-       | otherwise                      = CmmLit (zeroCLit dflags)+       | otherwise                      = CmmLit (zeroCLit platform)     emitAssign (CmmLocal res) val    GetCurrentCCSOp -> \[_] -> opAllDone $ \[res] -> do@@ -311,11 +311,11 @@     emitAssign (CmmLocal res) currentTSOExpr    ReadMutVarOp -> \[mutv] -> opAllDone $ \[res] -> do-    emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))+    emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform))    WriteMutVarOp -> \[mutv, var] -> opAllDone $ \res@[] -> do-    old_val <- CmmLocal <$> newTemp (cmmExprType dflags var)-    emitAssign old_val (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))+    old_val <- CmmLocal <$> newTemp (cmmExprType platform var)+    emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform))      -- Without this write barrier, other CPUs may see this pointer before     -- the writes for the closure it points to have occurred.@@ -323,7 +323,7 @@     -- that the read of old_val comes before another core's write to the     -- MutVar's value.     emitPrimCall res MO_WriteBarrier []-    emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var+    emitStore (cmmOffsetW platform mutv (fixedHdrSizeW dflags)) var     emitCCall             [{-no results-}]             (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))@@ -332,7 +332,7 @@ --  #define sizzeofByteArrayzh(r,a) \ --     r = ((StgArrBytes *)(a))->bytes   SizeofByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))+    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))  --  #define sizzeofMutableByteArrayzh(r,a) \ --      r = ((StgArrBytes *)(a))->bytes@@ -341,7 +341,7 @@ --  #define getSizzeofMutableByteArrayzh(r,a) \ --      r = ((StgArrBytes *)(a))->bytes   GetSizeofMutableByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do-    emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))+    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))   --  #define touchzh(o)                  /* nothing */@@ -350,14 +350,14 @@  --  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)   ByteArrayContents_Char -> \[arg] -> opAllDone $ \[res] -> do-    emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))+    emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize dflags))  --  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)   StableNameToIntOp -> \[arg] -> opAllDone $ \[res] -> do-    emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))+    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))    ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opAllDone $ \[res] -> do-    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])+    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2])  --  #define addrToHValuezh(r,a) r=(P_)a   AddrToAnyOp -> \[arg] -> opAllDone $ \[res] -> do@@ -434,17 +434,17 @@ -- Getting the size of pointer arrays    SizeofArrayOp -> \[arg] -> opAllDone $ \[res] -> do-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg-      (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))-        (bWord dflags))+    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg+      (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgMutArrPtrs_ptrs dflags))+        (bWord platform))   SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp   SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp   SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp   SizeofSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do     emit $ mkAssign (CmmLocal res)-     (cmmLoadIndexW dflags arg-     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))-        (bWord dflags))+     (cmmLoadIndexW platform arg+     (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgSmallMutArrPtrs_ptrs dflags))+        (bWord platform))    SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp   GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp@@ -452,281 +452,281 @@ -- IndexXXXoffAddr    IndexOffAddrOp_Char -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args   IndexOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args   IndexOffAddrOp_Int -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args+    doIndexOffAddrOp   Nothing (bWord platform) res args   IndexOffAddrOp_Word -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args+    doIndexOffAddrOp   Nothing (bWord platform) res args   IndexOffAddrOp_Addr -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args+    doIndexOffAddrOp   Nothing (bWord platform) res args   IndexOffAddrOp_Float -> \args -> opAllDone $ \res -> do     doIndexOffAddrOp   Nothing f32 res args   IndexOffAddrOp_Double -> \args -> opAllDone $ \res -> do     doIndexOffAddrOp   Nothing f64 res args   IndexOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args+    doIndexOffAddrOp   Nothing (bWord platform) res args   IndexOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+    doIndexOffAddrOp   (Just (mo_s_8ToWord platform)) b8  res args   IndexOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+    doIndexOffAddrOp   (Just (mo_s_16ToWord platform)) b16 res args   IndexOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+    doIndexOffAddrOp   (Just (mo_s_32ToWord platform)) b32 res args   IndexOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do     doIndexOffAddrOp   Nothing b64 res args   IndexOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8  res args   IndexOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+    doIndexOffAddrOp   (Just (mo_u_16ToWord platform)) b16 res args   IndexOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args   IndexOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do     doIndexOffAddrOp   Nothing b64 res args  -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.    ReadOffAddrOp_Char -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args   ReadOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args   ReadOffAddrOp_Int -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args+    doIndexOffAddrOp   Nothing (bWord platform) res args   ReadOffAddrOp_Word -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args+    doIndexOffAddrOp   Nothing (bWord platform) res args   ReadOffAddrOp_Addr -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args+    doIndexOffAddrOp   Nothing (bWord platform) res args   ReadOffAddrOp_Float -> \args -> opAllDone $ \res -> do     doIndexOffAddrOp   Nothing f32 res args   ReadOffAddrOp_Double -> \args -> opAllDone $ \res -> do     doIndexOffAddrOp   Nothing f64 res args   ReadOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args+    doIndexOffAddrOp   Nothing (bWord platform) res args   ReadOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+    doIndexOffAddrOp   (Just (mo_s_8ToWord platform)) b8  res args   ReadOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+    doIndexOffAddrOp   (Just (mo_s_16ToWord platform)) b16 res args   ReadOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+    doIndexOffAddrOp   (Just (mo_s_32ToWord platform)) b32 res args   ReadOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do     doIndexOffAddrOp   Nothing b64 res args   ReadOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8  res args   ReadOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+    doIndexOffAddrOp   (Just (mo_u_16ToWord platform)) b16 res args   ReadOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args   ReadOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do     doIndexOffAddrOp   Nothing b64 res args  -- IndexXXXArray    IndexByteArrayOp_Char -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args   IndexByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args   IndexByteArrayOp_Int -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args+    doIndexByteArrayOp   Nothing (bWord platform) res args   IndexByteArrayOp_Word -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args+    doIndexByteArrayOp   Nothing (bWord platform) res args   IndexByteArrayOp_Addr -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args+    doIndexByteArrayOp   Nothing (bWord platform) res args   IndexByteArrayOp_Float -> \args -> opAllDone $ \res -> do     doIndexByteArrayOp   Nothing f32 res args   IndexByteArrayOp_Double -> \args -> opAllDone $ \res -> do     doIndexByteArrayOp   Nothing f64 res args   IndexByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args+    doIndexByteArrayOp   Nothing (bWord platform) res args   IndexByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+    doIndexByteArrayOp   (Just (mo_s_8ToWord platform)) b8  res args   IndexByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+    doIndexByteArrayOp   (Just (mo_s_16ToWord platform)) b16  res args   IndexByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+    doIndexByteArrayOp   (Just (mo_s_32ToWord platform)) b32  res args   IndexByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do     doIndexByteArrayOp   Nothing b64  res args   IndexByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8  res args   IndexByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+    doIndexByteArrayOp   (Just (mo_u_16ToWord platform)) b16  res args   IndexByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32  res args   IndexByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do     doIndexByteArrayOp   Nothing b64  res args  -- ReadXXXArray, identical to IndexXXXArray.    ReadByteArrayOp_Char -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args   ReadByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args   ReadByteArrayOp_Int -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args+    doIndexByteArrayOp   Nothing (bWord platform) res args   ReadByteArrayOp_Word -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args+    doIndexByteArrayOp   Nothing (bWord platform) res args   ReadByteArrayOp_Addr -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args+    doIndexByteArrayOp   Nothing (bWord platform) res args   ReadByteArrayOp_Float -> \args -> opAllDone $ \res -> do     doIndexByteArrayOp   Nothing f32 res args   ReadByteArrayOp_Double -> \args -> opAllDone $ \res -> do     doIndexByteArrayOp   Nothing f64 res args   ReadByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args+    doIndexByteArrayOp   Nothing (bWord platform) res args   ReadByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+    doIndexByteArrayOp   (Just (mo_s_8ToWord platform)) b8  res args   ReadByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+    doIndexByteArrayOp   (Just (mo_s_16ToWord platform)) b16  res args   ReadByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+    doIndexByteArrayOp   (Just (mo_s_32ToWord platform)) b32  res args   ReadByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do     doIndexByteArrayOp   Nothing b64  res args   ReadByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8  res args   ReadByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+    doIndexByteArrayOp   (Just (mo_u_16ToWord platform)) b16  res args   ReadByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32  res args   ReadByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do     doIndexByteArrayOp   Nothing b64  res args  -- IndexWord8ArrayAsXXX    IndexByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args   IndexByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args   IndexByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args   IndexByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args   IndexByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args   IndexByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do     doIndexByteArrayOpAs   Nothing f32 b8 res args   IndexByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do     doIndexByteArrayOpAs   Nothing f64 b8 res args   IndexByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args   IndexByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+    doIndexByteArrayOpAs   (Just (mo_s_16ToWord platform)) b16 b8 res args   IndexByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+    doIndexByteArrayOpAs   (Just (mo_s_32ToWord platform)) b32 b8 res args   IndexByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do     doIndexByteArrayOpAs   Nothing b64 b8 res args   IndexByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+    doIndexByteArrayOpAs   (Just (mo_u_16ToWord platform)) b16 b8 res args   IndexByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args   IndexByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do     doIndexByteArrayOpAs   Nothing b64 b8 res args  -- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX    ReadByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args   ReadByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args   ReadByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args   ReadByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args   ReadByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args   ReadByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do     doIndexByteArrayOpAs   Nothing f32 b8 res args   ReadByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do     doIndexByteArrayOpAs   Nothing f64 b8 res args   ReadByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args   ReadByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+    doIndexByteArrayOpAs   (Just (mo_s_16ToWord platform)) b16 b8 res args   ReadByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+    doIndexByteArrayOpAs   (Just (mo_s_32ToWord platform)) b32 b8 res args   ReadByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do     doIndexByteArrayOpAs   Nothing b64 b8 res args   ReadByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+    doIndexByteArrayOpAs   (Just (mo_u_16ToWord platform)) b16 b8 res args   ReadByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args   ReadByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do     doIndexByteArrayOpAs   Nothing b64 b8 res args  -- WriteXXXoffAddr    WriteOffAddrOp_Char -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args   WriteOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args   WriteOffAddrOp_Int -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp Nothing (bWord dflags) res args+    doWriteOffAddrOp Nothing (bWord platform) res args   WriteOffAddrOp_Word -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp Nothing (bWord dflags) res args+    doWriteOffAddrOp Nothing (bWord platform) res args   WriteOffAddrOp_Addr -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp Nothing (bWord dflags) res args+    doWriteOffAddrOp Nothing (bWord platform) res args   WriteOffAddrOp_Float -> \args -> opAllDone $ \res -> do     doWriteOffAddrOp Nothing f32 res args   WriteOffAddrOp_Double -> \args -> opAllDone $ \res -> do     doWriteOffAddrOp Nothing f64 res args   WriteOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp Nothing (bWord dflags) res args+    doWriteOffAddrOp Nothing (bWord platform) res args   WriteOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args   WriteOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+    doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args   WriteOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args   WriteOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do     doWriteOffAddrOp Nothing b64 res args   WriteOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args   WriteOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+    doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args   WriteOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args   WriteOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do     doWriteOffAddrOp Nothing b64 res args  -- WriteXXXArray    WriteByteArrayOp_Char -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args   WriteByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args   WriteByteArrayOp_Int -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp Nothing (bWord dflags) res args+    doWriteByteArrayOp Nothing (bWord platform) res args   WriteByteArrayOp_Word -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp Nothing (bWord dflags) res args+    doWriteByteArrayOp Nothing (bWord platform) res args   WriteByteArrayOp_Addr -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp Nothing (bWord dflags) res args+    doWriteByteArrayOp Nothing (bWord platform) res args   WriteByteArrayOp_Float -> \args -> opAllDone $ \res -> do     doWriteByteArrayOp Nothing f32 res args   WriteByteArrayOp_Double -> \args -> opAllDone $ \res -> do     doWriteByteArrayOp Nothing f64 res args   WriteByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp Nothing (bWord dflags) res args+    doWriteByteArrayOp Nothing (bWord platform) res args   WriteByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args   WriteByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+    doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args   WriteByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args   WriteByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do     doWriteByteArrayOp Nothing b64 res args   WriteByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args+    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8  res args   WriteByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+    doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args   WriteByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args   WriteByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do     doWriteByteArrayOp Nothing b64 res args  -- WriteInt8ArrayAsXXX    WriteByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args   WriteByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args   WriteByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do     doWriteByteArrayOp Nothing b8 res args   WriteByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do@@ -740,15 +740,15 @@   WriteByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do     doWriteByteArrayOp Nothing b8 res args   WriteByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+    doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args   WriteByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args   WriteByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do     doWriteByteArrayOp Nothing b8 res args   WriteByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+    doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args   WriteByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args   WriteByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do     doWriteByteArrayOp Nothing b8 res args @@ -777,7 +777,7 @@   BSwap64Op -> \[w] -> opAllDone $ \[res] -> do     emitBSwapCall res w W64   BSwapOp -> \[w] -> opAllDone $ \[res] -> do-    emitBSwapCall res w (wordWidth dflags)+    emitBSwapCall res w (wordWidth platform)    BRev8Op -> \[w] -> opAllDone $ \[res] -> do     emitBRevCall res w W8@@ -788,7 +788,7 @@   BRev64Op -> \[w] -> opAllDone $ \[res] -> do     emitBRevCall res w W64   BRevOp -> \[w] -> opAllDone $ \[res] -> do-    emitBRevCall res w (wordWidth dflags)+    emitBRevCall res w (wordWidth platform)  -- Population count   PopCnt8Op -> \[w] -> opAllDone $ \[res] -> do@@ -800,7 +800,7 @@   PopCnt64Op -> \[w] -> opAllDone $ \[res] -> do     emitPopCntCall res w W64   PopCntOp -> \[w] -> opAllDone $ \[res] -> do-    emitPopCntCall res w (wordWidth dflags)+    emitPopCntCall res w (wordWidth platform)  -- Parallel bit deposit   Pdep8Op -> \[src, mask] -> opAllDone $ \[res] -> do@@ -812,7 +812,7 @@   Pdep64Op -> \[src, mask] -> opAllDone $ \[res] -> do     emitPdepCall res src mask W64   PdepOp -> \[src, mask] -> opAllDone $ \[res] -> do-    emitPdepCall res src mask (wordWidth dflags)+    emitPdepCall res src mask (wordWidth platform)  -- Parallel bit extract   Pext8Op -> \[src, mask] -> opAllDone $ \[res] -> do@@ -824,7 +824,7 @@   Pext64Op -> \[src, mask] -> opAllDone $ \[res] -> do     emitPextCall res src mask W64   PextOp -> \[src, mask] -> opAllDone $ \[res] -> do-    emitPextCall res src mask (wordWidth dflags)+    emitPextCall res src mask (wordWidth platform)  -- count leading zeros   Clz8Op -> \[w] -> opAllDone $ \[res] -> do@@ -836,7 +836,7 @@   Clz64Op -> \[w] -> opAllDone $ \[res] -> do     emitClzCall res w W64   ClzOp -> \[w] -> opAllDone $ \[res] -> do-    emitClzCall res w (wordWidth dflags)+    emitClzCall res w (wordWidth platform)  -- count trailing zeros   Ctz8Op -> \[w] -> opAllDone $ \[res] -> do@@ -848,7 +848,7 @@   Ctz64Op -> \[w] -> opAllDone $ \[res] -> do     emitCtzCall res w W64   CtzOp -> \[w] -> opAllDone $ \[res] -> do-    emitCtzCall res w (wordWidth dflags)+    emitCtzCall res w (wordWidth platform)  -- Unsigned int to floating point conversions   Word2FloatOp -> \[w] -> opAllDone $ \[res] -> do@@ -859,7 +859,7 @@ -- SIMD primops   (VecBroadcastOp vcat n w) -> \[e] -> opAllDone $ \[res] -> do     checkVecCompatibility dflags vcat n w-    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res+    doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res    where     zeros :: CmmExpr     zeros = CmmLit $ CmmVec (replicate n zero)@@ -877,7 +877,7 @@     checkVecCompatibility dflags vcat n w     when (es `lengthIsNot` n) $         panic "emitPrimOp: VecPackOp has wrong number of arguments"-    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res+    doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res    where     zeros :: CmmExpr     zeros = CmmLit $ CmmVec (replicate n zero)@@ -895,14 +895,14 @@     checkVecCompatibility dflags vcat n w     when (res `lengthIsNot` n) $         panic "emitPrimOp: VecUnpackOp has wrong number of results"-    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res+    doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecInsertOp vcat n w) -> \[v,e,i] -> opAllDone $ \[res] -> do     checkVecCompatibility dflags vcat n w-    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res+    doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res    where     ty :: CmmType     ty = vecVmmType vcat n w@@ -1041,23 +1041,23 @@  -- Atomic read-modify-write   FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do-    doAtomicRMW res AMO_Add mba ix (bWord dflags) n+    doAtomicRMW res AMO_Add mba ix (bWord platform) n   FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do-    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n+    doAtomicRMW res AMO_Sub mba ix (bWord platform) n   FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do-    doAtomicRMW res AMO_And mba ix (bWord dflags) n+    doAtomicRMW res AMO_And mba ix (bWord platform) n   FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do-    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n+    doAtomicRMW res AMO_Nand mba ix (bWord platform) n   FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do-    doAtomicRMW res AMO_Or mba ix (bWord dflags) n+    doAtomicRMW res AMO_Or mba ix (bWord platform) n   FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do-    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n+    doAtomicRMW res AMO_Xor mba ix (bWord platform) n   AtomicReadByteArrayOp_Int -> \[mba, ix] -> opAllDone $ \[res] -> do-    doAtomicReadByteArray res mba ix (bWord dflags)+    doAtomicReadByteArray res mba ix (bWord platform)   AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opAllDone $ \[] -> do-    doAtomicWriteByteArray mba ix (bWord dflags) val+    doAtomicWriteByteArray mba ix (bWord platform) val   CasByteArrayOp_Int -> \[mba, ix, old, new] -> opAllDone $ \[res] -> do-    doCasByteArray res mba ix (bWord dflags) old new+    doCasByteArray res mba ix (bWord platform) old new  -- The rest just translate straightforwardly @@ -1068,12 +1068,12 @@   ChrOp           -> \args -> opNop args  -- Int# and Char# are rep'd the same   OrdOp           -> \args -> opNop args -  Narrow8IntOp   -> \args -> opNarrow dflags args (MO_SS_Conv, W8)-  Narrow16IntOp  -> \args -> opNarrow dflags args (MO_SS_Conv, W16)-  Narrow32IntOp  -> \args -> opNarrow dflags args (MO_SS_Conv, W32)-  Narrow8WordOp  -> \args -> opNarrow dflags args (MO_UU_Conv, W8)-  Narrow16WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W16)-  Narrow32WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W32)+  Narrow8IntOp   -> \args -> opNarrow platform args (MO_SS_Conv, W8)+  Narrow16IntOp  -> \args -> opNarrow platform args (MO_SS_Conv, W16)+  Narrow32IntOp  -> \args -> opNarrow platform args (MO_SS_Conv, W32)+  Narrow8WordOp  -> \args -> opNarrow platform args (MO_UU_Conv, W8)+  Narrow16WordOp -> \args -> opNarrow platform args (MO_UU_Conv, W16)+  Narrow32WordOp -> \args -> opNarrow platform args (MO_UU_Conv, W32)    DoublePowerOp  -> \args -> opCallish args MO_F64_Pwr   DoubleSinOp    -> \args -> opCallish args MO_F64_Sin@@ -1115,70 +1115,70 @@  -- Native word signless ops -  IntAddOp       -> \args -> opTranslate args (mo_wordAdd dflags)-  IntSubOp       -> \args -> opTranslate args (mo_wordSub dflags)-  WordAddOp      -> \args -> opTranslate args (mo_wordAdd dflags)-  WordSubOp      -> \args -> opTranslate args (mo_wordSub dflags)-  AddrAddOp      -> \args -> opTranslate args (mo_wordAdd dflags)-  AddrSubOp      -> \args -> opTranslate args (mo_wordSub dflags)+  IntAddOp       -> \args -> opTranslate args (mo_wordAdd platform)+  IntSubOp       -> \args -> opTranslate args (mo_wordSub platform)+  WordAddOp      -> \args -> opTranslate args (mo_wordAdd platform)+  WordSubOp      -> \args -> opTranslate args (mo_wordSub platform)+  AddrAddOp      -> \args -> opTranslate args (mo_wordAdd platform)+  AddrSubOp      -> \args -> opTranslate args (mo_wordSub platform) -  IntEqOp        -> \args -> opTranslate args (mo_wordEq dflags)-  IntNeOp        -> \args -> opTranslate args (mo_wordNe dflags)-  WordEqOp       -> \args -> opTranslate args (mo_wordEq dflags)-  WordNeOp       -> \args -> opTranslate args (mo_wordNe dflags)-  AddrEqOp       -> \args -> opTranslate args (mo_wordEq dflags)-  AddrNeOp       -> \args -> opTranslate args (mo_wordNe dflags)+  IntEqOp        -> \args -> opTranslate args (mo_wordEq platform)+  IntNeOp        -> \args -> opTranslate args (mo_wordNe platform)+  WordEqOp       -> \args -> opTranslate args (mo_wordEq platform)+  WordNeOp       -> \args -> opTranslate args (mo_wordNe platform)+  AddrEqOp       -> \args -> opTranslate args (mo_wordEq platform)+  AddrNeOp       -> \args -> opTranslate args (mo_wordNe platform) -  AndOp          -> \args -> opTranslate args (mo_wordAnd dflags)-  OrOp           -> \args -> opTranslate args (mo_wordOr dflags)-  XorOp          -> \args -> opTranslate args (mo_wordXor dflags)-  NotOp          -> \args -> opTranslate args (mo_wordNot dflags)-  SllOp          -> \args -> opTranslate args (mo_wordShl dflags)-  SrlOp          -> \args -> opTranslate args (mo_wordUShr dflags)+  AndOp          -> \args -> opTranslate args (mo_wordAnd platform)+  OrOp           -> \args -> opTranslate args (mo_wordOr platform)+  XorOp          -> \args -> opTranslate args (mo_wordXor platform)+  NotOp          -> \args -> opTranslate args (mo_wordNot platform)+  SllOp          -> \args -> opTranslate args (mo_wordShl platform)+  SrlOp          -> \args -> opTranslate args (mo_wordUShr platform) -  AddrRemOp      -> \args -> opTranslate args (mo_wordURem dflags)+  AddrRemOp      -> \args -> opTranslate args (mo_wordURem platform)  -- Native word signed ops -  IntMulOp        -> \args -> opTranslate args (mo_wordMul dflags)-  IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth dflags))-  IntQuotOp       -> \args -> opTranslate args (mo_wordSQuot dflags)-  IntRemOp        -> \args -> opTranslate args (mo_wordSRem dflags)-  IntNegOp        -> \args -> opTranslate args (mo_wordSNeg dflags)+  IntMulOp        -> \args -> opTranslate args (mo_wordMul platform)+  IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth platform))+  IntQuotOp       -> \args -> opTranslate args (mo_wordSQuot platform)+  IntRemOp        -> \args -> opTranslate args (mo_wordSRem platform)+  IntNegOp        -> \args -> opTranslate args (mo_wordSNeg platform) -  IntGeOp        -> \args -> opTranslate args (mo_wordSGe dflags)-  IntLeOp        -> \args -> opTranslate args (mo_wordSLe dflags)-  IntGtOp        -> \args -> opTranslate args (mo_wordSGt dflags)-  IntLtOp        -> \args -> opTranslate args (mo_wordSLt dflags)+  IntGeOp        -> \args -> opTranslate args (mo_wordSGe platform)+  IntLeOp        -> \args -> opTranslate args (mo_wordSLe platform)+  IntGtOp        -> \args -> opTranslate args (mo_wordSGt platform)+  IntLtOp        -> \args -> opTranslate args (mo_wordSLt platform) -  AndIOp         -> \args -> opTranslate args (mo_wordAnd dflags)-  OrIOp          -> \args -> opTranslate args (mo_wordOr dflags)-  XorIOp         -> \args -> opTranslate args (mo_wordXor dflags)-  NotIOp         -> \args -> opTranslate args (mo_wordNot dflags)-  ISllOp         -> \args -> opTranslate args (mo_wordShl dflags)-  ISraOp         -> \args -> opTranslate args (mo_wordSShr dflags)-  ISrlOp         -> \args -> opTranslate args (mo_wordUShr dflags)+  AndIOp         -> \args -> opTranslate args (mo_wordAnd platform)+  OrIOp          -> \args -> opTranslate args (mo_wordOr platform)+  XorIOp         -> \args -> opTranslate args (mo_wordXor platform)+  NotIOp         -> \args -> opTranslate args (mo_wordNot platform)+  ISllOp         -> \args -> opTranslate args (mo_wordShl platform)+  ISraOp         -> \args -> opTranslate args (mo_wordSShr platform)+  ISrlOp         -> \args -> opTranslate args (mo_wordUShr platform)  -- Native word unsigned ops -  WordGeOp       -> \args -> opTranslate args (mo_wordUGe dflags)-  WordLeOp       -> \args -> opTranslate args (mo_wordULe dflags)-  WordGtOp       -> \args -> opTranslate args (mo_wordUGt dflags)-  WordLtOp       -> \args -> opTranslate args (mo_wordULt dflags)+  WordGeOp       -> \args -> opTranslate args (mo_wordUGe platform)+  WordLeOp       -> \args -> opTranslate args (mo_wordULe platform)+  WordGtOp       -> \args -> opTranslate args (mo_wordUGt platform)+  WordLtOp       -> \args -> opTranslate args (mo_wordULt platform) -  WordMulOp      -> \args -> opTranslate args (mo_wordMul dflags)-  WordQuotOp     -> \args -> opTranslate args (mo_wordUQuot dflags)-  WordRemOp      -> \args -> opTranslate args (mo_wordURem dflags)+  WordMulOp      -> \args -> opTranslate args (mo_wordMul platform)+  WordQuotOp     -> \args -> opTranslate args (mo_wordUQuot platform)+  WordRemOp      -> \args -> opTranslate args (mo_wordURem platform) -  AddrGeOp       -> \args -> opTranslate args (mo_wordUGe dflags)-  AddrLeOp       -> \args -> opTranslate args (mo_wordULe dflags)-  AddrGtOp       -> \args -> opTranslate args (mo_wordUGt dflags)-  AddrLtOp       -> \args -> opTranslate args (mo_wordULt dflags)+  AddrGeOp       -> \args -> opTranslate args (mo_wordUGe platform)+  AddrLeOp       -> \args -> opTranslate args (mo_wordULe platform)+  AddrGtOp       -> \args -> opTranslate args (mo_wordUGt platform)+  AddrLtOp       -> \args -> opTranslate args (mo_wordULt platform)  -- Int8# signed ops -  Int8Extend     -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth dflags))-  Int8Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W8)+  Int8Extend     -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform))+  Int8Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8)   Int8NegOp      -> \args -> opTranslate args (MO_S_Neg W8)   Int8AddOp      -> \args -> opTranslate args (MO_Add W8)   Int8SubOp      -> \args -> opTranslate args (MO_Sub W8)@@ -1195,8 +1195,8 @@  -- Word8# unsigned ops -  Word8Extend     -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth dflags))-  Word8Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W8)+  Word8Extend     -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform))+  Word8Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8)   Word8NotOp      -> \args -> opTranslate args (MO_Not W8)   Word8AddOp      -> \args -> opTranslate args (MO_Add W8)   Word8SubOp      -> \args -> opTranslate args (MO_Sub W8)@@ -1213,8 +1213,8 @@  -- Int16# signed ops -  Int16Extend     -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth dflags))-  Int16Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W16)+  Int16Extend     -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform))+  Int16Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16)   Int16NegOp      -> \args -> opTranslate args (MO_S_Neg W16)   Int16AddOp      -> \args -> opTranslate args (MO_Add W16)   Int16SubOp      -> \args -> opTranslate args (MO_Sub W16)@@ -1231,8 +1231,8 @@  -- Word16# unsigned ops -  Word16Extend     -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth dflags))-  Word16Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W16)+  Word16Extend     -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform))+  Word16Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16)   Word16NotOp      -> \args -> opTranslate args (MO_Not W16)   Word16AddOp      -> \args -> opTranslate args (MO_Add W16)   Word16SubOp      -> \args -> opTranslate args (MO_Sub W16)@@ -1249,12 +1249,12 @@  -- Char# ops -  CharEqOp       -> \args -> opTranslate args (MO_Eq (wordWidth dflags))-  CharNeOp       -> \args -> opTranslate args (MO_Ne (wordWidth dflags))-  CharGeOp       -> \args -> opTranslate args (MO_U_Ge (wordWidth dflags))-  CharLeOp       -> \args -> opTranslate args (MO_U_Le (wordWidth dflags))-  CharGtOp       -> \args -> opTranslate args (MO_U_Gt (wordWidth dflags))-  CharLtOp       -> \args -> opTranslate args (MO_U_Lt (wordWidth dflags))+  CharEqOp       -> \args -> opTranslate args (MO_Eq (wordWidth platform))+  CharNeOp       -> \args -> opTranslate args (MO_Ne (wordWidth platform))+  CharGeOp       -> \args -> opTranslate args (MO_U_Ge (wordWidth platform))+  CharLeOp       -> \args -> opTranslate args (MO_U_Le (wordWidth platform))+  CharGtOp       -> \args -> opTranslate args (MO_U_Gt (wordWidth platform))+  CharLtOp       -> \args -> opTranslate args (MO_U_Lt (wordWidth platform))  -- Double ops @@ -1314,32 +1314,32 @@  -- Conversions -  Int2DoubleOp   -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W64)-  Double2IntOp   -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth dflags))+  Int2DoubleOp   -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W64)+  Double2IntOp   -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth platform)) -  Int2FloatOp    -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W32)-  Float2IntOp    -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth dflags))+  Int2FloatOp    -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W32)+  Float2IntOp    -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth platform))    Float2DoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)   Double2FloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)  -- Word comparisons masquerading as more exotic things. -  SameMutVarOp            -> \args -> opTranslate args (mo_wordEq dflags)-  SameMVarOp              -> \args -> opTranslate args (mo_wordEq dflags)-  SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq dflags)-  SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq dflags)-  SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq dflags)-  SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq dflags)-  SameTVarOp              -> \args -> opTranslate args (mo_wordEq dflags)-  EqStablePtrOp           -> \args -> opTranslate args (mo_wordEq dflags)+  SameMutVarOp            -> \args -> opTranslate args (mo_wordEq platform)+  SameMVarOp              -> \args -> opTranslate args (mo_wordEq platform)+  SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq platform)+  SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq platform)+  SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform)+  SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform)+  SameTVarOp              -> \args -> opTranslate args (mo_wordEq platform)+  EqStablePtrOp           -> \args -> opTranslate args (mo_wordEq platform) -- See Note [Comparing stable names]-  EqStableNameOp          -> \args -> opTranslate args (mo_wordEq dflags)+  EqStableNameOp          -> \args -> opTranslate args (mo_wordEq platform)    IntQuotRemOp -> \args -> opCallishHandledLater args $     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem  (wordWidth dflags))-    else Right (genericIntQuotRemOp (wordWidth dflags))+    then Left (MO_S_QuotRem  (wordWidth platform))+    else Right (genericIntQuotRemOp (wordWidth platform))    Int8QuotRemOp -> \args -> opCallishHandledLater args $     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)@@ -1353,13 +1353,13 @@    WordQuotRemOp -> \args -> opCallishHandledLater args $     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem  (wordWidth dflags))-    else Right (genericWordQuotRemOp (wordWidth dflags))+    then Left (MO_U_QuotRem  (wordWidth platform))+    else Right (genericWordQuotRemOp (wordWidth platform))    WordQuotRem2Op -> \args -> opCallishHandledLater args $     if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_U_QuotRem2 (wordWidth dflags))-    else Right (genericWordQuotRem2Op dflags)+    then Left (MO_U_QuotRem2 (wordWidth platform))+    else Right (genericWordQuotRem2Op platform)    Word8QuotRemOp -> \args -> opCallishHandledLater args $     if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)@@ -1373,37 +1373,37 @@    WordAdd2Op -> \args -> opCallishHandledLater args $     if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_Add2       (wordWidth dflags))+    then Left (MO_Add2       (wordWidth platform))     else Right genericWordAdd2Op    WordAddCOp -> \args -> opCallishHandledLater args $     if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_AddWordC   (wordWidth dflags))+    then Left (MO_AddWordC   (wordWidth platform))     else Right genericWordAddCOp    WordSubCOp -> \args -> opCallishHandledLater args $     if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_SubWordC   (wordWidth dflags))+    then Left (MO_SubWordC   (wordWidth platform))     else Right genericWordSubCOp    IntAddCOp -> \args -> opCallishHandledLater args $     if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_AddIntC    (wordWidth dflags))+    then Left (MO_AddIntC    (wordWidth platform))     else Right genericIntAddCOp    IntSubCOp -> \args -> opCallishHandledLater args $     if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_SubIntC    (wordWidth dflags))+    then Left (MO_SubIntC    (wordWidth platform))     else Right genericIntSubCOp    WordMul2Op -> \args -> opCallishHandledLater args $     if ncg && (x86ish || ppc) || llvm-    then Left (MO_U_Mul2     (wordWidth dflags))+    then Left (MO_U_Mul2     (wordWidth platform))     else Right genericWordMul2Op    IntMul2Op  -> \args -> opCallishHandledLater args $     if ncg && x86ish-    then Left (MO_S_Mul2     (wordWidth dflags))+    then Left (MO_S_Mul2     (wordWidth platform))     else Right genericIntMul2Op    FloatFabsOp -> \args -> opCallishHandledLater args $@@ -1426,8 +1426,8 @@     -- That won't work.     let tycon = tyConAppTyCon res_ty     MASSERT(isEnumerationTyCon tycon)-    dflags <- getDynFlags-    pure [tagToClosure dflags tycon amode]+    platform <- getPlatform+    pure [tagToClosure platform tycon amode]  -- Out of line primops. -- TODO compiler need not know about these@@ -1523,6 +1523,7 @@   SetThreadAllocationCounter -> alwaysExternal   where+  platform = targetPlatform dflags   alwaysExternal = \_ -> PrimopCmmEmit_External   -- Note [QuotRem optimization]   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1549,11 +1550,11 @@   llvm = case hscTarget dflags of            HscLlvm -> True            _       -> False-  x86ish = case platformArch (targetPlatform dflags) of+  x86ish = case platformArch platform of              ArchX86    -> True              ArchX86_64 -> True              _          -> False-  ppc = case platformArch (targetPlatform dflags) of+  ppc = case platformArch platform of           ArchPPC      -> True           ArchPPC_64 _ -> True           _            -> False@@ -1573,12 +1574,12 @@   where [arg] = args  opNarrow-  :: DynFlags+  :: Platform   -> [CmmExpr]   -> (Width -> Width -> MachOp, Width)   -> PrimopCmmEmit-opNarrow dflags args (mop, rep) = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) $-  CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]+opNarrow platform args (mop, rep) = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) $+  CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]   where [arg] = args  -- | These primops are implemented by CallishMachOps, because they sometimes@@ -1626,21 +1627,21 @@                (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y]) genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp" -genericWordQuotRem2Op :: DynFlags -> GenericOp-genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]-    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low-    where    ty = cmmExprType dflags arg_x_high-             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]-             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]-             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]-             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]-             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]-             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]-             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]+genericWordQuotRem2Op :: Platform -> GenericOp+genericWordQuotRem2Op platform [res_q, res_r] [arg_x_high, arg_x_low, arg_y]+    = emit =<< f (widthInBits (wordWidth platform)) zero arg_x_high arg_x_low+    where    ty = cmmExprType platform arg_x_high+             shl   x i = CmmMachOp (MO_Shl   (wordWidth platform)) [x, i]+             shr   x i = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, i]+             or    x y = CmmMachOp (MO_Or    (wordWidth platform)) [x, y]+             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth platform)) [x, y]+             ne    x y = CmmMachOp (MO_Ne    (wordWidth platform)) [x, y]+             minus x y = CmmMachOp (MO_Sub   (wordWidth platform)) [x, y]+             times x y = CmmMachOp (MO_Mul   (wordWidth platform)) [x, y]              zero   = lit 0              one    = lit 1-             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)-             lit i = CmmLit (CmmInt i (wordWidth dflags))+             negone = lit (fromIntegral (platformWordSizeInBits platform) - 1)+             lit i = CmmLit (CmmInt i (wordWidth platform))               f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph              f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>@@ -1677,17 +1678,17 @@  genericWordAdd2Op :: GenericOp genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]-  = do dflags <- getDynFlags-       r1 <- newTemp (cmmExprType dflags arg_x)-       r2 <- newTemp (cmmExprType dflags arg_x)-       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]-           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]-           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]-           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]-           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]-           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))-                                (wordWidth dflags))-           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+  = do platform <- getPlatform+       r1 <- newTemp (cmmExprType platform arg_x)+       r2 <- newTemp (cmmExprType platform arg_x)+       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]+           toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]+           bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]+           add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]+           or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]+           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))+                                (wordWidth platform))+           hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))        emit $ catAGraphs           [mkAssign (CmmLocal r1)                (add (bottomHalf arg_x) (bottomHalf arg_y)),@@ -1711,19 +1712,19 @@ -- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/ genericWordAddCOp :: GenericOp genericWordAddCOp [res_r, res_c] [aa, bb]- = do dflags <- getDynFlags+ = do platform <- getPlatform       emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),         mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-            CmmMachOp (mo_wordOr dflags) [-              CmmMachOp (mo_wordAnd dflags) [aa,bb],-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordOr dflags) [aa,bb],-                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]+          CmmMachOp (mo_wordUShr platform) [+            CmmMachOp (mo_wordOr platform) [+              CmmMachOp (mo_wordAnd platform) [aa,bb],+              CmmMachOp (mo_wordAnd platform) [+                CmmMachOp (mo_wordOr platform) [aa,bb],+                CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)]               ]             ],-            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+            mkIntExpr platform (platformWordSizeInBits platform - 1)           ]         ] genericWordAddCOp _ _ = panic "genericWordAddCOp"@@ -1738,25 +1739,25 @@ -- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/ genericWordSubCOp :: GenericOp genericWordSubCOp [res_r, res_c] [aa, bb]- = do dflags <- getDynFlags+ = do platform <- getPlatform       emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),         mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-            CmmMachOp (mo_wordOr dflags) [-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordNot dflags) [aa],+          CmmMachOp (mo_wordUShr platform) [+            CmmMachOp (mo_wordOr platform) [+              CmmMachOp (mo_wordAnd platform) [+                CmmMachOp (mo_wordNot platform) [aa],                 bb               ],-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordOr dflags) [-                  CmmMachOp (mo_wordNot dflags) [aa],+              CmmMachOp (mo_wordAnd platform) [+                CmmMachOp (mo_wordOr platform) [+                  CmmMachOp (mo_wordNot platform) [aa],                   bb                 ],                 CmmReg (CmmLocal res_r)               ]             ],-            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+            mkIntExpr platform (platformWordSizeInBits platform - 1)           ]         ] genericWordSubCOp _ _ = panic "genericWordSubCOp"@@ -1783,16 +1784,16 @@    c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)  -}- = do dflags <- getDynFlags+ = do platform <- getPlatform       emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),         mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-                CmmMachOp (mo_wordAnd dflags) [-                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],-                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+          CmmMachOp (mo_wordUShr platform) [+                CmmMachOp (mo_wordAnd platform) [+                    CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]],+                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]                 ],-                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+                mkIntExpr platform (platformWordSizeInBits platform - 1)           ]         ] genericIntAddCOp _ _ = panic "genericIntAddCOp"@@ -1808,40 +1809,40 @@     c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) -}- = do dflags <- getDynFlags+ = do platform <- getPlatform       emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),         mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-                CmmMachOp (mo_wordAnd dflags) [-                    CmmMachOp (mo_wordXor dflags) [aa,bb],-                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+          CmmMachOp (mo_wordUShr platform) [+                CmmMachOp (mo_wordAnd platform) [+                    CmmMachOp (mo_wordXor platform) [aa,bb],+                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]                 ],-                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+                mkIntExpr platform (platformWordSizeInBits platform - 1)           ]         ] genericIntSubCOp _ _ = panic "genericIntSubCOp"  genericWordMul2Op :: GenericOp genericWordMul2Op [res_h, res_l] [arg_x, arg_y]- = do dflags <- getDynFlags-      let t = cmmExprType dflags arg_x+ = do platform <- getPlatform+      let t = cmmExprType platform arg_x       xlyl <- liftM CmmLocal $ newTemp t       xlyh <- liftM CmmLocal $ newTemp t       xhyl <- liftM CmmLocal $ newTemp t       r    <- liftM CmmLocal $ newTemp t       -- This generic implementation is very simple and slow. We might       -- well be able to do better, but for now this at least works.-      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]-          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]-          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]-          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]+          toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]+          bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]+          add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]           sum = foldl1 add-          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]-          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]-          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))-                               (wordWidth dflags))-          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+          mul x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y]+          or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]+          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))+                               (wordWidth platform))+          hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))       emit $ catAGraphs              [mkAssign xlyl                   (mul (bottomHalf arg_x) (bottomHalf arg_y)),@@ -1866,8 +1867,9 @@ genericIntMul2Op :: GenericOp genericIntMul2Op [res_c, res_h, res_l] [arg_x, arg_y]  = do dflags <- getDynFlags+      platform <- getPlatform       -- Implement algorithm from Hacker's Delight, 2nd edition, p.174-      let t = cmmExprType dflags arg_x+      let t = cmmExprType platform arg_x       p   <- newTemp t       -- 1) compute the multiplication as if numbers were unsigned       let wordMul2 = case emitPrimOp dflags WordMul2Op [arg_x,arg_y] of@@ -1883,7 +1885,7 @@           f   x y     = (carryFill x) `and` y           wwm1        = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)           rl x        = CmmReg (CmmLocal x)-          ww          = wordWidth dflags+          ww          = wordWidth platform       emit $ catAGraphs              [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)              , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))@@ -1897,7 +1899,7 @@ --             | otherwise = negateFloat x genericFabsOp :: Width -> GenericOp genericFabsOp w [res_r] [aa]- = do dflags <- getDynFlags+ = do platform <- getPlatform       let zero   = CmmLit (CmmFloat 0 w)            eq x y = CmmMachOp (MO_F_Eq w) [x, y]@@ -1908,7 +1910,7 @@           g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]           g2 = catAGraphs [mkAssign (CmmLocal res_r) aa] -      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)+      res_t <- CmmLocal <$> newTemp (cmmExprType platform aa)       let g3 = catAGraphs [mkAssign res_t aa,                            mkAssign (CmmLocal res_r) (neg (CmmReg res_t))] @@ -1982,7 +1984,8 @@                  -> FCode () doReadPtrArrayOp res addr idx    = do dflags <- getDynFlags-        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx+        platform <- getPlatform+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord platform) res addr (gcWord platform) idx  doWriteOffAddrOp :: Maybe MachOp                  -> CmmType@@ -2011,11 +2014,12 @@                   -> FCode () doWritePtrArrayOp addr idx val   = do dflags <- getDynFlags-       let ty = cmmExprType dflags val+       platform <- getPlatform+       let ty = cmmExprType platform val            hdr_size = arrPtrsHdrSize dflags        -- Update remembered set for non-moving collector-       whenUpdRemSetEnabled dflags-           $ emitUpdRemSetPush (cmmLoadIndexOffExpr dflags hdr_size ty addr ty idx)+       whenUpdRemSetEnabled+           $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform 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.@@ -2025,16 +2029,17 @@        -- the write barrier.  We must write a byte into the mark table:        -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]        emit $ mkStore (-         cmmOffsetExpr dflags-          (cmmOffsetExprW dflags (cmmOffsetB dflags addr hdr_size)+         cmmOffsetExpr platform+          (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)                          (loadArrPtrsSize dflags addr))-          (CmmMachOp (mo_wordUShr dflags) [idx,-                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])+          (CmmMachOp (mo_wordUShr platform) [idx,+                                           mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags)])          ) (CmmLit (CmmInt 1 W8))  loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr-loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform)  where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags+       platform = targetPlatform dflags  mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes                    -> Maybe MachOp -- Optional result cast@@ -2045,12 +2050,12 @@                    -> CmmExpr      -- Index                    -> FCode () mkBasicIndexedRead off Nothing ty res base idx_ty idx-   = do dflags <- getDynFlags-        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty 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-   = do dflags <- getDynFlags+   = do platform <- getPlatform         emitAssign (CmmLocal res) (CmmMachOp cast [-                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])+                                   cmmLoadIndexOffExpr platform off ty base idx_ty idx])  mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes                     -> Maybe MachOp -- Optional value cast@@ -2060,32 +2065,32 @@                     -> CmmExpr      -- Value to write                     -> FCode () mkBasicIndexedWrite off Nothing base idx_ty idx val-   = do dflags <- getDynFlags-        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val+   = do platform <- getPlatform+        emitStore (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])  -- ---------------------------------------------------------------------------- -- Misc utils -cmmIndexOffExpr :: DynFlags+cmmIndexOffExpr :: Platform                 -> ByteOff  -- Initial offset in bytes                 -> Width    -- Width of element by which we are indexing                 -> CmmExpr  -- Base address                 -> CmmExpr  -- Index                 -> CmmExpr-cmmIndexOffExpr dflags off width base idx-   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx+cmmIndexOffExpr platform off width base idx+   = cmmIndexExpr platform width (cmmOffsetB platform base off) idx -cmmLoadIndexOffExpr :: DynFlags+cmmLoadIndexOffExpr :: Platform                     -> 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 dflags off ty base idx_ty idx-   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty+cmmLoadIndexOffExpr platform off ty base idx_ty idx+   = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty  setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr@@ -2101,29 +2106,29 @@ vecCmmCat WordVec  = cmmBits vecCmmCat FloatVec = cmmFloat -vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemInjectCast _      FloatVec _   =  Nothing-vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)-vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)-vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)-vecElemInjectCast _      IntVec   W64 =  Nothing-vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)-vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)-vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)-vecElemInjectCast _      WordVec  W64 =  Nothing-vecElemInjectCast _      _        _   =  Nothing+vecElemInjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemInjectCast _        FloatVec _   =  Nothing+vecElemInjectCast platform   IntVec   W8  =  Just (mo_WordTo8  platform)+vecElemInjectCast platform   IntVec   W16 =  Just (mo_WordTo16 platform)+vecElemInjectCast platform   IntVec   W32 =  Just (mo_WordTo32 platform)+vecElemInjectCast _        IntVec   W64 =  Nothing+vecElemInjectCast platform   WordVec  W8  =  Just (mo_WordTo8  platform)+vecElemInjectCast platform   WordVec  W16 =  Just (mo_WordTo16 platform)+vecElemInjectCast platform   WordVec  W32 =  Just (mo_WordTo32 platform)+vecElemInjectCast _        WordVec  W64 =  Nothing+vecElemInjectCast _        _        _   =  Nothing -vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemProjectCast _      FloatVec _   =  Nothing-vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)-vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)-vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)-vecElemProjectCast _      IntVec   W64 =  Nothing-vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)-vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)-vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)-vecElemProjectCast _      WordVec  W64 =  Nothing-vecElemProjectCast _      _        _   =  Nothing+vecElemProjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemProjectCast _        FloatVec _   =  Nothing+vecElemProjectCast platform   IntVec   W8  =  Just (mo_s_8ToWord  platform)+vecElemProjectCast platform   IntVec   W16 =  Just (mo_s_16ToWord platform)+vecElemProjectCast platform   IntVec   W32 =  Just (mo_s_32ToWord platform)+vecElemProjectCast _        IntVec   W64 =  Nothing+vecElemProjectCast platform   WordVec  W8  =  Just (mo_u_8ToWord  platform)+vecElemProjectCast platform   WordVec  W16 =  Just (mo_u_16ToWord platform)+vecElemProjectCast platform   WordVec  W32 =  Just (mo_u_32ToWord platform)+vecElemProjectCast _        WordVec  W64 =  Nothing+vecElemProjectCast _        _        _   =  Nothing   -- NOTE [SIMD Design for the future]@@ -2267,10 +2272,10 @@               -> CmmFormal     -- Destination for result               -> FCode () doVecInsertOp maybe_pre_write_cast ty src e idx res = do-    dflags <- getDynFlags+    platform <- getPlatform     -- vector indices are always 32-bits     let idx' :: CmmExpr-        idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx]+        idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx]     if isFloatType (vecElemType ty)       then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])       else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])@@ -2324,8 +2329,8 @@                  -> [CmmExpr]                  -> FCode () doPrefetchValueOp  locality   [addr]-  =  do dflags <- getDynFlags-        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth dflags)))+  =  do platform <- getPlatform+        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth platform))) doPrefetchValueOp _ _   = panic "GHC.StgToCmm.Prim: doPrefetchValueOp" @@ -2336,8 +2341,8 @@                 -> CmmExpr      -- Index                 -> FCode () mkBasicPrefetch locality off base idx-   = do dflags <- getDynFlags-        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]+   = do platform <- getPlatform+        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr platform W8 (cmmOffsetB platform base off) idx]         return ()  -- ----------------------------------------------------------------------------@@ -2349,18 +2354,19 @@ doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () doNewByteArrayOp res_r n = do     dflags <- getDynFlags+    platform <- getPlatform      let info_ptr = mkLblExpr mkArrWords_infoLabel-        rep = arrWordsRep dflags n+        rep = arrWordsRep platform n -    tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)+    tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize dflags))+        (mkIntExpr platform (nonHdrSize platform rep))+        (zeroExpr platform)      let hdr_size = fixedHdrSize dflags      base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr dflags n,+                     [ (mkIntExpr platform n,                         hdr_size + oFFSET_StgArrBytes_bytes dflags)                      ] @@ -2373,8 +2379,9 @@                      -> FCode () doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do     dflags <- getDynFlags-    ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off-    ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off+    platform <- getPlatform+    ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize dflags)) ba1_off+    ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize dflags)) ba2_off      -- short-cut in case of equal pointers avoiding a costly     -- subroutine call to the memcmp(3) routine; the Cmm logic below@@ -2411,8 +2418,8 @@     l_ptr_eq <- newBlockId     l_ptr_ne <- newBlockId -    emit (mkAssign (CmmLocal res) (zeroExpr dflags))-    emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)+    emit (mkAssign (CmmLocal res) (zeroExpr platform))+    emit (mkCbranch (cmmEqWord platform ba1_p ba2_p)                     l_ptr_eq l_ptr_ne (Just False))      emitLabel l_ptr_ne@@ -2449,11 +2456,11 @@     -- we were provided are the same array!     -- TODO: Optimize branch for common case of no aliasing.     copy src dst dst_p src_p bytes align = do-        dflags <- getDynFlags+        platform <- getPlatform         (moveCall, cpyCall) <- forkAltPair             (getCode $ emitMemmoveCall dst_p src_p bytes align)             (getCode $ emitMemcpyCall  dst_p src_p bytes align)-        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall+        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall  emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr                       -> Alignment -> FCode ())@@ -2461,12 +2468,13 @@                   -> FCode () emitCopyByteArray copy src src_off dst dst_off n = do     dflags <- getDynFlags-    let byteArrayAlignment = wordAlignment dflags+    platform <- getPlatform+    let byteArrayAlignment = wordAlignment platform         srcOffAlignment = cmmExprAlignment src_off         dstOffAlignment = cmmExprAlignment dst_off         align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]-    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off-    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off+    dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off+    src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off     copy src dst dst_p src_p n align  -- | Takes a source 'ByteArray#', an offset in the source array, a@@ -2476,7 +2484,8 @@ doCopyByteArrayToAddrOp src src_off dst_p bytes = do     -- Use memcpy (we are allowed to assume the arrays aren't overlapping)     dflags <- getDynFlags-    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off+    platform <- getPlatform+    src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off     emitMemcpyCall dst_p src_p bytes (mkAlignment 1)  -- | Takes a source 'MutableByteArray#', an offset in the source array, a@@ -2493,7 +2502,8 @@ doCopyAddrToByteArrayOp src_p dst dst_off bytes = do     -- Use memcpy (we are allowed to assume the arrays aren't overlapping)     dflags <- getDynFlags-    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off+    platform <- getPlatform+    dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off     emitMemcpyCall dst_p src_p bytes (mkAlignment 1)  @@ -2507,12 +2517,13 @@                  -> FCode () doSetByteArrayOp ba off len c = do     dflags <- getDynFlags+    platform <- getPlatform -    let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap+    let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap         offsetAlignment = cmmExprAlignment off         align = min byteArrayAlignment offsetAlignment -    p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off+    p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize dflags)) off     emitMemsetCall p c len align  -- ----------------------------------------------------------------------------@@ -2528,20 +2539,21 @@              -> FCode () doNewArrayOp res_r rep info payload n init = do     dflags <- getDynFlags+    platform <- getPlatform      let info_ptr = mkLblExpr info -    tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)+    tickyAllocPrim (mkIntExpr platform (hdrSize dflags rep))+        (mkIntExpr platform (nonHdrSize platform rep))+        (zeroExpr platform)      base <- allocHeapClosure rep info_ptr cccsExpr payload -    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    arr <- CmmLocal `fmap` newTemp (bWord platform)     emit $ mkAssign arr base      -- Initialise all elements of the array-    let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)+    let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW dflags rep + off)         initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]     emit (catAGraphs initialization) @@ -2575,9 +2587,9 @@     -- Copy data (we assume the arrays aren't overlapping since     -- they're of different types)     copy _src _dst dst_p src_p bytes =-        do dflags <- getDynFlags-           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)-               (wordAlignment dflags)+        do platform <- getPlatform+           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)+               (wordAlignment platform)   -- | Takes a source 'MutableArray#', an offset in the source array, a@@ -2592,13 +2604,13 @@     -- we were provided are the same array!     -- TODO: Optimize branch for common case of no aliasing.     copy src dst dst_p src_p bytes = do-        dflags <- getDynFlags+        platform <- getPlatform         (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)-             (wordAlignment dflags))-            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)-             (wordAlignment dflags))-        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)+             (wordAlignment platform))+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform bytes)+             (wordAlignment platform))+        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall  emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff                   -> FCode ())  -- ^ copy function@@ -2611,6 +2623,7 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n =     when (n /= 0) $ do         dflags <- getDynFlags+        platform <- getPlatform          -- Passed as arguments (be careful)         src     <- assignTempE src0@@ -2618,22 +2631,22 @@         dst_off <- assignTempE dst_off0          -- Nonmoving collector write barrier-        emitCopyUpdRemSetPush dflags (arrPtrsHdrSizeW dflags) dst dst_off n+        emitCopyUpdRemSetPush platform (arrPtrsHdrSizeW dflags) dst dst_off n          -- Set the dirty bit in the header.         emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst+        dst_elems_p <- assignTempE $ cmmOffsetB platform dst                        (arrPtrsHdrSize dflags)-        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off-        src_p <- assignTempE $ cmmOffsetExprW dflags-                 (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off-        let bytes = wordsToBytes dflags n+        dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off+        src_p <- assignTempE $ cmmOffsetExprW platform+                 (cmmOffsetB platform src (arrPtrsHdrSize dflags)) src_off+        let bytes = wordsToBytes platform n          copy src dst dst_p src_p bytes          -- The base address of the destination card table-        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p+        dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p                        (loadArrPtrsSize dflags dst)          emitSetCards dst_off dst_cards_p n@@ -2645,9 +2658,9 @@     -- Copy data (we assume the arrays aren't overlapping since     -- they're of different types)     copy _src _dst dst_p src_p bytes =-        do dflags <- getDynFlags-           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)-               (wordAlignment dflags)+        do platform <- getPlatform+           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)+               (wordAlignment platform)   doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff@@ -2658,13 +2671,13 @@     -- we were provided are the same array!     -- TODO: Optimize branch for common case of no aliasing.     copy src dst dst_p src_p bytes = do-        dflags <- getDynFlags+        platform <- getPlatform         (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)-             (wordAlignment dflags))-            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)-             (wordAlignment dflags))-        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)+             (wordAlignment platform))+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform bytes)+             (wordAlignment platform))+        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall  emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff                        -> FCode ())  -- ^ copy function@@ -2677,22 +2690,23 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n =     when (n /= 0) $ do         dflags <- getDynFlags+        platform <- getPlatform          -- Passed as arguments (be careful)         src     <- assignTempE src0         dst     <- assignTempE dst0          -- Nonmoving collector write barrier-        emitCopyUpdRemSetPush dflags (smallArrPtrsHdrSizeW dflags) dst dst_off n+        emitCopyUpdRemSetPush platform (smallArrPtrsHdrSizeW dflags) dst dst_off n          -- Set the dirty bit in the header.         emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) -        dst_p <- assignTempE $ cmmOffsetExprW dflags-                 (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off-        src_p <- assignTempE $ cmmOffsetExprW dflags-                 (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off-        let bytes = wordsToBytes dflags n+        dst_p <- assignTempE $ cmmOffsetExprW platform+                 (cmmOffsetB platform dst (smallArrPtrsHdrSize dflags)) dst_off+        src_p <- assignTempE $ cmmOffsetExprW platform+                 (cmmOffsetB platform src (smallArrPtrsHdrSize dflags)) src_off+        let bytes = wordsToBytes platform n          copy src dst dst_p src_p bytes @@ -2704,34 +2718,35 @@                -> FCode () emitCloneArray info_p res_r src src_off n = do     dflags <- getDynFlags+    platform <- getPlatform      let info_ptr = mkLblExpr info_p         rep = arrPtrsRep dflags n -    tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)+    tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize dflags))+        (mkIntExpr platform (nonHdrSize platform rep))+        (zeroExpr platform)      let hdr_size = fixedHdrSize dflags      base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr dflags n,+                     [ (mkIntExpr platform n,                         hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)-                     , (mkIntExpr dflags (nonHdrSizeW rep),+                     , (mkIntExpr platform (nonHdrSizeW rep),                         hdr_size + oFFSET_StgMutArrPtrs_size dflags)                      ] -    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    arr <- CmmLocal `fmap` newTemp (bWord platform)     emit $ mkAssign arr base -    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)+    dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)              (arrPtrsHdrSize dflags)-    src_p <- assignTempE $ cmmOffsetExprW dflags src-             (cmmAddWord dflags-              (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)+    src_p <- assignTempE $ cmmOffsetExprW platform src+             (cmmAddWord platform+              (mkIntExpr platform (arrPtrsHdrSizeW dflags)) src_off) -    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))-        (wordAlignment dflags)+    emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))+        (wordAlignment platform)      emit $ mkAssign (CmmLocal res_r) (CmmReg arr) @@ -2743,32 +2758,33 @@                     -> FCode () emitCloneSmallArray info_p res_r src src_off n = do     dflags <- getDynFlags+    platform <- getPlatform      let info_ptr = mkLblExpr info_p         rep = smallArrPtrsRep n -    tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)+    tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize dflags))+        (mkIntExpr platform (nonHdrSize platform rep))+        (zeroExpr platform)      let hdr_size = fixedHdrSize dflags      base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr dflags n,+                     [ (mkIntExpr platform n,                         hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)                      ] -    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    arr <- CmmLocal `fmap` newTemp (bWord platform)     emit $ mkAssign arr base -    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)+    dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)              (smallArrPtrsHdrSize dflags)-    src_p <- assignTempE $ cmmOffsetExprW dflags src-             (cmmAddWord dflags-              (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)+    src_p <- assignTempE $ cmmOffsetExprW platform src+             (cmmAddWord platform+              (mkIntExpr platform (smallArrPtrsHdrSizeW dflags)) src_off) -    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))-        (wordAlignment dflags)+    emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))+        (wordAlignment platform)      emit $ mkAssign (CmmLocal res_r) (CmmReg arr) @@ -2779,20 +2795,22 @@ emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () emitSetCards dst_start dst_cards_start n = do     dflags <- getDynFlags+    platform <- getPlatform     start_card <- assignTempE $ cardCmm dflags dst_start     let end_card = cardCmm dflags-                   (cmmSubWord dflags-                    (cmmAddWord dflags dst_start (mkIntExpr dflags n))-                    (mkIntExpr dflags 1))-    emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)-        (mkIntExpr dflags 1)-        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))+                   (cmmSubWord platform+                    (cmmAddWord platform dst_start (mkIntExpr platform n))+                    (mkIntExpr platform 1))+    emitMemsetCall (cmmAddWord platform dst_cards_start start_card)+        (mkIntExpr platform 1)+        (cmmAddWord platform (cmmSubWord platform end_card start_card) (mkIntExpr platform 1))         (mkAlignment 1) -- no alignment (1 byte)  -- Convert an element index to a card index cardCmm :: DynFlags -> CmmExpr -> CmmExpr cardCmm dflags i =-    cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))+    cmmUShrWord platform i (mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags))+    where platform = targetPlatform dflags  ------------------------------------------------------------------------------ -- SmallArray PrimOp implementations@@ -2803,8 +2821,9 @@                       -> FCode () doReadSmallPtrArrayOp res addr idx = do     dflags <- getDynFlags-    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr-        (gcWord dflags) idx+    platform <- getPlatform+    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord platform) res addr+        (gcWord platform) idx  doWriteSmallPtrArrayOp :: CmmExpr                        -> CmmExpr@@ -2812,12 +2831,13 @@                        -> FCode () doWriteSmallPtrArrayOp addr idx val = do     dflags <- getDynFlags-    let ty = cmmExprType dflags val+    platform <- getPlatform+    let ty = cmmExprType platform val      -- Update remembered set for non-moving collector     tmp <- newTemp ty     mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx-    whenUpdRemSetEnabled dflags $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))+    whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))      emitPrimCall [] MO_WriteBarrier [] -- #12469     mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val@@ -2838,8 +2858,9 @@             -> FCode () doAtomicRMW res amop mba idx idx_ty n = do     dflags <- getDynFlags+    platform <- getPlatform     let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+        addr  = cmmIndexOffExpr platform (arrWordsHdrSize dflags)                 width mba idx     emitPrimCall         [ res ]@@ -2855,8 +2876,9 @@     -> FCode () doAtomicReadByteArray res mba idx idx_ty = do     dflags <- getDynFlags+    platform <- getPlatform     let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+        addr  = cmmIndexOffExpr platform (arrWordsHdrSize dflags)                 width mba idx     emitPrimCall         [ res ]@@ -2872,8 +2894,9 @@     -> FCode () doAtomicWriteByteArray mba idx idx_ty val = do     dflags <- getDynFlags+    platform <- getPlatform     let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+        addr  = cmmIndexOffExpr platform (arrWordsHdrSize dflags)                 width mba idx     emitPrimCall         [ {- no results -} ]@@ -2890,8 +2913,9 @@     -> FCode () doCasByteArray res mba idx idx_ty old new = do     dflags <- getDynFlags+    platform <- getPlatform     let width = (typeWidth idx_ty)-        addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+        addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags)                width mba idx     emitPrimCall         [ res ]@@ -2932,7 +2956,7 @@     -- code-gens currently call out to the @memcmp(3)@ C function.     -- This was easier than moving the sign-extensions into     -- all the code-gens.-    dflags <- getDynFlags+    platform <- getPlatform     let is32Bit = typeWidth (localRegType res) == W32      cres <- if is32Bit@@ -2947,7 +2971,7 @@     unless is32Bit $ do       emit $ mkAssign (CmmLocal res)                       (CmmMachOp-                         (mo_s_32ToWord dflags)+                         (mo_s_32ToWord platform)                          [(CmmReg (CmmLocal cres))])  emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()@@ -3005,15 +3029,15 @@  -- | Push a range of pointer-array elements that are about to be copied over to -- the update remembered set.-emitCopyUpdRemSetPush :: DynFlags+emitCopyUpdRemSetPush :: Platform                       -> WordOff    -- ^ array header size                       -> CmmExpr    -- ^ destination array                       -> CmmExpr    -- ^ offset in destination array (in words)                       -> Int        -- ^ number of elements to copy                       -> FCode ()-emitCopyUpdRemSetPush _dflags _hdr_size _dst _dst_off 0 = return ()-emitCopyUpdRemSetPush dflags hdr_size dst dst_off n =-    whenUpdRemSetEnabled dflags $ do+emitCopyUpdRemSetPush _platform _hdr_size _dst _dst_off 0 = return ()+emitCopyUpdRemSetPush platform hdr_size dst dst_off n =+    whenUpdRemSetEnabled $ do         updfr_off <- getUpdFrameOff         graph <- mkCall lbl (NativeNodeCall,NativeReturn) [] args updfr_off []         emit graph@@ -3021,8 +3045,8 @@     lbl = mkLblExpr $ mkPrimCallLabel           $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnitId     args =-      [ mkIntExpr dflags hdr_size+      [ mkIntExpr platform hdr_size       , dst       , dst_off-      , mkIntExpr dflags n+      , mkIntExpr platform n       ]
compiler/GHC/StgToCmm/Prof.hs view
@@ -25,6 +25,7 @@  import GhcPrelude +import GHC.Platform import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad@@ -35,10 +36,10 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel -import CostCentre+import GHC.Types.CostCentre import GHC.Driver.Session import FastString-import Module+import GHC.Types.Module as Module import Outputable  import Control.Monad@@ -51,10 +52,10 @@ -----------------------------------------------------------------------------  -- Expression representing the current cost centre stack-ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack+ccsType :: Platform -> CmmType -- Type of a cost-centre stack ccsType = bWord -ccType :: DynFlags -> CmmType -- Type of a cost centre+ccType :: Platform -> CmmType -- Type of a cost centre ccType = bWord  storeCurCCS :: CmmExpr -> CmmAGraph@@ -69,23 +70,29 @@ costCentreFrom :: DynFlags                -> CmmExpr         -- A closure pointer                -> CmmExpr        -- The cost centre from that closure-costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)+costCentreFrom dflags cl = CmmLoad (cmmOffsetB platform cl (oFFSET_StgHeader_ccs dflags)) (ccsType platform)+  where platform = targetPlatform dflags  -- | The profiling header words in a static closure staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] staticProfHdr dflags ccs- = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]+  | gopt Opt_SccProfilingOn dflags = [mkCCostCentreStack ccs, staticLdvInit platform]+  | otherwise                      = []+  where platform = targetPlatform dflags  -- | Profiling header words in a dynamic closure dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]-dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]+dynProfHdr dflags ccs+  | gopt Opt_SccProfilingOn dflags = [ccs, dynLdvInit dflags]+  | otherwise                      = []  -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode () initUpdFrameProf frame   = ifProfiling $        -- frame->header.prof.ccs = CCCS     do dflags <- getDynFlags-       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr+       platform <- getPlatform+       emitStore (cmmOffset platform frame (oFFSET_StgHeader_ccs dflags)) cccsExpr         -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)         -- is unnecessary because it is not used anyhow. @@ -122,9 +129,10 @@         -- Returns Nothing if profiling is off saveCurrentCostCentre   = do dflags <- getDynFlags+       platform <- getPlatform        if not (gopt Opt_SccProfilingOn dflags)            then return Nothing-           else do local_cc <- newTemp (ccType dflags)+           else do local_cc <- newTemp (ccType platform)                    emitAssign (CmmLocal local_cc) cccsExpr                    return (Just local_cc) @@ -145,7 +153,8 @@ profDynAlloc rep ccs   = ifProfiling $     do dflags <- getDynFlags-       profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs+       platform <- getPlatform+       profAlloc (mkIntExpr platform (heapClosureSizeW dflags rep)) ccs  -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts@@ -154,12 +163,13 @@ profAlloc words ccs   = ifProfiling $         do dflags <- getDynFlags+           platform <- getPlatform            let alloc_rep = rEP_CostCentreStack_mem_alloc dflags            emit (addToMemE alloc_rep-                       (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))-                       (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $-                         [CmmMachOp (mo_wordSub dflags) [words,-                                                         mkIntExpr dflags (profHdrSize dflags)]]))+                       (cmmOffsetB platform ccs (oFFSET_CostCentreStack_mem_alloc dflags))+                       (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $+                         [CmmMachOp (mo_wordSub platform) [words,+                                                           mkIntExpr platform (profHdrSize dflags)]]))                        -- subtract the "profiling overhead", which is the                        -- profiling header in a closure. @@ -189,12 +199,6 @@            then code            else return () -ifProfilingL :: DynFlags -> [a] -> [a]-ifProfilingL dflags xs-  | gopt Opt_SccProfilingOn dflags = xs-  | otherwise                      = []-- --------------------------------------------------------------- --        Initialising Cost Centres & CCSs ---------------------------------------------------------------@@ -211,8 +215,9 @@ emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do   { dflags <- getDynFlags-  ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF-               | otherwise  = zero dflags+  ; platform <- getPlatform+  ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF+               | otherwise  = zero platform                         -- NB. bytesFS: we want the UTF-8 bytes here (#5559)   ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)   ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS@@ -222,14 +227,14 @@                    showPpr dflags (costCentreSrcSpan cc)            -- XXX going via FastString to get UTF-8 encoding is silly   ; let-     lits = [ zero dflags,           -- StgInt ccID,-              label,        -- char *label,-              modl,        -- char *module,-              loc,      -- char *srcloc,-              zero64,   -- StgWord64 mem_alloc-              zero dflags,     -- StgWord time_ticks-              is_caf,   -- StgInt is_caf-              zero dflags      -- struct _CostCentre *link+     lits = [ zero platform,  -- StgInt ccID,+              label,          -- char *label,+              modl,           -- char *module,+              loc,            -- char *srcloc,+              zero64,         -- StgWord64 mem_alloc+              zero platform,  -- StgWord time_ticks+              is_caf,         -- StgInt is_caf+              zero platform   -- struct _CostCentre *link             ]   ; emitRawDataLits (mkCCLabel cc) lits   }@@ -239,9 +244,10 @@   = case maybeSingletonCCS ccs of     Just cc ->         do dflags <- getDynFlags-           let mk_lits cc = zero dflags :+           platform <- getPlatform+           let mk_lits cc = zero platform :                             mkCCostCentre cc :-                            replicate (sizeof_ccs_words dflags - 2) (zero dflags)+                            replicate (sizeof_ccs_words dflags - 2) (zero platform)                 -- Note: to avoid making any assumptions about how the                 -- C compiler (that compiles the RTS, in particular) does                 -- layouts of structs containing long-longs, simply@@ -250,8 +256,8 @@            emitRawDataLits (mkCCSLabel ccs) (mk_lits cc)     Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) -zero :: DynFlags -> CmmLit-zero dflags = mkIntCLit dflags 0+zero :: Platform -> CmmLit+zero platform = mkIntCLit platform 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 @@ -261,7 +267,8 @@   | ms == 0   = ws   | otherwise = ws + 1   where-   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags+   platform = targetPlatform dflags+   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` platformWordSizeInBytes platform  -- --------------------------------------------------------------------------- -- Set the current cost centre stack@@ -269,9 +276,10 @@ emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () emitSetCCC cc tick push  = do dflags <- getDynFlags+      platform <- getPlatform       if not (gopt Opt_SccProfilingOn dflags)           then return ()-          else do tmp <- newTemp (ccsType dflags)+          else do tmp <- newTemp (ccsType platform)                   pushCostCentre tmp cccsExpr cc                   when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))                   when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))@@ -287,7 +295,8 @@ bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph bumpSccCount dflags ccs   = addToMem (rEP_CostCentreStack_scc_count dflags)-         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1+         (cmmOffsetB platform ccs (oFFSET_CostCentreStack_scc_count dflags)) 1+  where platform = targetPlatform dflags  ----------------------------------------------------------------------------- --@@ -298,7 +307,7 @@ -- -- Initial value for the LDV field in a static closure ---staticLdvInit :: DynFlags -> CmmLit+staticLdvInit :: Platform -> CmmLit staticLdvInit = zeroCLit  --@@ -306,10 +315,12 @@ -- dynLdvInit :: DynFlags -> CmmExpr dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE-  CmmMachOp (mo_wordOr dflags) [-      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],-      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))+  CmmMachOp (mo_wordOr platform) [+      CmmMachOp (mo_wordShl platform) [loadEra dflags, mkIntExpr platform (lDV_SHIFT dflags)],+      CmmLit (mkWordCLit platform (iLDV_STATE_CREATE dflags))   ]+  where+   platform = targetPlatform dflags  -- -- Initialise the LDV word of a new closure@@ -327,34 +338,39 @@ ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode () ldvEnterClosure closure_info node_reg = do     dflags <- getDynFlags+    platform <- getPlatform     let tag = funTag dflags closure_info     -- don't forget to subtract node's tag-    ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))+    ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag))  ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do     dflags <- getDynFlags+    platform <- getPlatform     let -- don't forget to subtract node's tag         ldv_wd = ldvWord dflags cl_ptr-        new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))-                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))-                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))+        new_ldv_wd = cmmOrWord platform+                        (cmmAndWord platform (CmmLoad ldv_wd (bWord platform))+                                             (CmmLit (mkWordCLit platform (iLDV_CREATE_MASK dflags))))+                        (cmmOrWord platform (loadEra dflags) (CmmLit (mkWordCLit platform (iLDV_STATE_USE dflags))))     ifProfiling $          -- if (era > 0) {          --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |          --                era | LDV_STATE_USE }-        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])+        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra dflags, CmmLit (zeroCLit platform)])                      (mkStore ldv_wd new_ldv_wd)                      mkNop  loadEra :: DynFlags -> CmmExpr-loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth platform))     [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))              (cInt dflags)]+    where platform = targetPlatform dflags  ldvWord :: DynFlags -> CmmExpr -> CmmExpr -- Takes the address of a closure, and returns -- the address of the LDV word in the closure ldvWord dflags closure_ptr-    = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)+    = cmmOffsetB platform closure_ptr (oFFSET_StgHeader_ldvw dflags)+    where platform = targetPlatform dflags
compiler/GHC/StgToCmm/Ticky.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}  ----------------------------------------------------------------------------- --@@ -106,6 +107,7 @@  import GhcPrelude +import GHC.Platform import GHC.StgToCmm.ArgRep    ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils@@ -118,10 +120,10 @@ import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout -import Module-import Name-import Id-import BasicTypes+import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Id+import GHC.Types.Basic import FastString import Outputable import Util@@ -131,8 +133,8 @@ -- Turgid imports for showTypeCategory import PrelNames import TcType-import TyCon-import Predicate+import GHC.Core.TyCon+import GHC.Core.Predicate  import Data.Maybe import qualified Data.Char@@ -211,6 +213,7 @@     (>> return ctr_lbl) $     ifTicky $ do         { dflags <- getDynFlags+        ; platform <- getPlatform         ; parent <- getTickyCtrLabel         ; mod_name <- getModuleName @@ -246,14 +249,14 @@         -- 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 dflags 0,               -- registered?-              mkIntCLit dflags (length args),   -- Arity-              mkIntCLit dflags 0,               -- Heap allocated for this thing+            [ mkIntCLit platform 0,               -- registered?+              mkIntCLit platform (length args),   -- Arity+              mkIntCLit platform 0,               -- Heap allocated for this thing               fun_descr_lit,               arg_descr_lit,-              zeroCLit dflags,          -- Entries into this thing-              zeroCLit dflags,          -- Heap allocated by this thing-              zeroCLit dflags                   -- Link to next StgEntCounter+              zeroCLit platform,          -- Entries into this thing+              zeroCLit platform,          -- Heap allocated by this thing+              zeroCLit platform                   -- Link to next StgEntCounter             ]         } @@ -353,19 +356,20 @@ --          f_ct.registeredp = 1 } registerTickyCtr ctr_lbl = do   dflags <- getDynFlags+  platform <- getPlatform   let     -- krc: code generator doesn't handle Not, so we test for Eq 0 instead-    test = CmmMachOp (MO_Eq (wordWidth dflags))+    test = CmmMachOp (MO_Eq (wordWidth platform))               [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl-                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),-               zeroExpr dflags]+                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord platform),+               zeroExpr platform]     register_stmts       = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))-                   (CmmLoad ticky_entry_ctrs (bWord dflags))+                   (CmmLoad ticky_entry_ctrs (bWord platform))         , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)         , mkStore (CmmLit (cmmLabelOffB ctr_lbl                                 (oFFSET_StgEntCounter_registeredp dflags)))-                   (mkIntExpr dflags 1) ]+                   (mkIntExpr platform 1) ]     ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))   emit =<< mkCmmIfThen test (catAGraphs register_stmts) @@ -450,8 +454,10 @@ -- used to distinguish between closure types -- -- TODO what else to count while we're here?-tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->-  let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep+tickyDynAlloc mb_id rep lf = ifTicky $ do+  dflags <- getDynFlags+  let platform = targetPlatform dflags+      bytes = platformWordSizeInBytes platform * heapClosureSizeW dflags rep        countGlobal tot ctr = do         bumpTickyCounterBy tot bytes@@ -468,19 +474,18 @@   -- for now, since I don't currently know neither if we do nor how to   -- distinguish. NSF Mar 2013 -  in case () of-    _ | isConRep rep   ->-          ifTickyDynThunk countSpecific >>-          countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")-      | isThunkRep rep ->-          ifTickyDynThunk countSpecific >>-          if lfUpdatable lf-          then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")-          else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")-      | isFunRep   rep ->-          countSpecific >>-          countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")-      | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"+  if | isConRep rep   ->+         ifTickyDynThunk countSpecific >>+         countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")+     | isThunkRep rep ->+         ifTickyDynThunk countSpecific >>+         if lfUpdatable lf+         then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")+         else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")+     | isFunRep   rep ->+         countSpecific >>+         countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")+     | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"   @@ -493,24 +498,25 @@ tickyAllocHeap genuine hp   = ifTicky $     do  { dflags <- getDynFlags+        ; platform <- getPlatform         ; ticky_ctr <- getTickyCtrLabel         ; emit $ catAGraphs $             -- only test hp from within the emit so that the monadic             -- computation itself is not strict in hp (cf knot in             -- GHC.StgToCmm.Monad.getHeapUsage)           if hp == 0 then []-          else let !bytes = wORD_SIZE dflags * hp in [+          else let !bytes = platformWordSizeInBytes platform * hp in [             -- Bump the allocation total in the closure's StgEntCounter             addToMem (rEP_StgEntCounter_allocs dflags)                      (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))                      bytes,             -- Bump the global allocation total ALLOC_HEAP_tot-            addToMemLbl (bWord dflags)+            addToMemLbl (bWord platform)                         (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))                         bytes,             -- Bump the global allocation counter ALLOC_HEAP_ctr             if not genuine then mkNop-            else addToMemLbl (bWord dflags)+            else addToMemLbl (bWord platform)                              (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))                              1             ]}@@ -607,23 +613,24 @@  bumpTickyLitBy :: CmmLit -> Int -> FCode () bumpTickyLitBy lhs n = do-  dflags <- getDynFlags-  emit (addToMem (bWord dflags) (CmmLit lhs) n)+  platform <- getPlatform+  emit (addToMem (bWord platform) (CmmLit lhs) n)  bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode () bumpTickyLitByE lhs e = do-  dflags <- getDynFlags-  emit (addToMemE (bWord dflags) (CmmLit lhs) e)+  platform <- getPlatform+  emit (addToMemE (bWord platform) (CmmLit lhs) e)  bumpHistogram :: FastString -> Int -> FCode () bumpHistogram lbl n = do     dflags <- getDynFlags+    platform <- getPlatform     let offset = n `min` (tICKY_BIN_COUNT dflags - 1)-    emit (addToMem (bWord dflags)-           (cmmIndexExpr dflags-                (wordWidth dflags)+    emit (addToMem (bWord platform)+           (cmmIndexExpr platform+                (wordWidth platform)                 (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))-                (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))+                (CmmLit (CmmInt (fromIntegral offset) (wordWidth platform))))            1)  ------------------------------------------------------------------
compiler/GHC/StgToCmm/Utils.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}  ----------------------------------------------------------------------------- --@@ -51,6 +52,7 @@  import GhcPrelude +import GHC.Platform import GHC.StgToCmm.Monad import GHC.StgToCmm.Closure import GHC.Cmm@@ -62,22 +64,22 @@ import GHC.Cmm.Switch import GHC.StgToCmm.CgUtils -import ForeignCall-import IdInfo-import Type-import TyCon+import GHC.Types.ForeignCall+import GHC.Types.Id.Info+import GHC.Core.Type+import GHC.Core.TyCon import GHC.Runtime.Heap.Layout-import Module-import Literal+import GHC.Types.Module+import GHC.Types.Literal import Digraph import Util-import Unique-import UniqSupply (MonadUnique(..))+import GHC.Types.Unique+import GHC.Types.Unique.Supply (MonadUnique(..)) import GHC.Driver.Session import FastString import Outputable import GHC.Types.RepType-import CostCentre+import GHC.Types.CostCentre  import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8@@ -97,25 +99,26 @@ cgLit :: Literal -> FCode CmmLit cgLit (LitString s) = newByteStringCLit s  -- not unpackFS; we want the UTF-8 byte stream.-cgLit other_lit     = do dflags <- getDynFlags-                         return (mkSimpleLit dflags other_lit)+cgLit other_lit     = do platform <- getPlatform+                         return (mkSimpleLit platform other_lit) -mkSimpleLit :: DynFlags -> Literal -> CmmLit-mkSimpleLit dflags (LitChar   c)                = CmmInt (fromIntegral (ord c))-                                                         (wordWidth dflags)-mkSimpleLit dflags LitNullAddr                  = zeroCLit dflags-mkSimpleLit dflags (LitNumber LitNumInt i _)    = CmmInt i (wordWidth dflags)-mkSimpleLit _      (LitNumber LitNumInt64 i _)  = CmmInt i W64-mkSimpleLit dflags (LitNumber LitNumWord i _)   = CmmInt i (wordWidth dflags)-mkSimpleLit _      (LitNumber LitNumWord64 i _) = CmmInt i W64-mkSimpleLit _      (LitFloat r)                 = CmmFloat r W32-mkSimpleLit _      (LitDouble r)                = CmmFloat r W64-mkSimpleLit _      (LitLabel fs ms fod)-  = let -- TODO: Literal labels might not actually be in the current package...-        labelSrc = ForeignLabelInThisPackage-    in CmmLabel (mkForeignLabel fs ms labelSrc fod)--- NB: LitRubbish should have been lowered in "CoreToStg"-mkSimpleLit _      other = pprPanic "mkSimpleLit" (ppr other)+mkSimpleLit :: Platform -> Literal -> CmmLit+mkSimpleLit platform = \case+   (LitChar   c)                -> CmmInt (fromIntegral (ord c))+                                          (wordWidth platform)+   LitNullAddr                  -> zeroCLit platform+   (LitNumber LitNumInt i _)    -> CmmInt i (wordWidth platform)+   (LitNumber LitNumInt64 i _)  -> CmmInt i W64+   (LitNumber LitNumWord i _)   -> CmmInt i (wordWidth platform)+   (LitNumber LitNumWord64 i _) -> CmmInt i W64+   (LitFloat r)                 -> CmmFloat r W32+   (LitDouble r)                -> CmmFloat r W64+   (LitLabel fs ms fod)+     -> let -- TODO: Literal labels might not actually be in the current package...+            labelSrc = ForeignLabelInThisPackage+        in CmmLabel (mkForeignLabel fs ms labelSrc fod)+   -- NB: LitRubbish should have been lowered in "CoreToStg"+   other -> pprPanic "mkSimpleLit" (ppr other)  -------------------------------------------------------------------------- --@@ -151,13 +154,13 @@ -------------------------------------------------------------------------  mkTaggedObjectLoad-  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph+  :: Platform -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph -- (loadTaggedObjectField reg base off tag) generates assignment --      reg = bitsK[ base + off - tag ] -- where K is fixed by 'reg'-mkTaggedObjectLoad dflags reg base offset tag+mkTaggedObjectLoad platform reg base offset tag   = mkAssign (CmmLocal reg)-             (CmmLoad (cmmOffsetB dflags+             (CmmLoad (cmmOffsetB platform                                   (CmmReg (CmmLocal base))                                   (offset - tag))                       (localRegType reg))@@ -169,9 +172,9 @@ -- ------------------------------------------------------------------------- -tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr-tagToClosure dflags tycon tag-  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)+tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr+tagToClosure platform tycon tag+  = CmmLoad (cmmOffsetExprW platform closure_tbl tag) (bWord platform)   where closure_tbl = CmmLit (CmmLabel lbl)         lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs @@ -264,7 +267,7 @@      callerRestoreGlobalReg reg         = mkAssign (CmmGlobal reg)-                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))+                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType platform reg))   -------------------------------------------------------------------------@@ -338,9 +341,9 @@ -- due to them being trashed on foreign calls--though it means -- the optimization pass doesn't have to do as much work) assignTemp (CmmReg (CmmLocal reg)) = return reg-assignTemp e = do { dflags <- getDynFlags+assignTemp e = do { platform <- getPlatform                   ; uniq <- newUnique-                  ; let reg = LocalReg uniq (cmmExprType dflags e)+                  ; let reg = LocalReg uniq (cmmExprType platform e)                   ; emitAssign (CmmLocal reg) e                   ; return reg } @@ -355,15 +358,15 @@ -- regs it wants will save later assignments. newUnboxedTupleRegs res_ty   = ASSERT( isUnboxedTupleType res_ty )-    do  { dflags <- getDynFlags+    do  { platform <- getPlatform         ; sequel <- getSequel-        ; regs <- choose_regs dflags sequel+        ; regs <- choose_regs platform sequel         ; ASSERT( regs `equalLength` reps )           return (regs, map primRepForeignHint reps) }   where     reps = typePrimRep res_ty     choose_regs _ (AssignTo regs _) = return regs-    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps+    choose_regs platform _          = mapM (newTemp . primRepCmmType platform) reps   @@ -389,12 +392,12 @@ emitMultiAssign []    []    = return () emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs emitMultiAssign regs rhss   = do-  dflags <- getDynFlags+  platform <- getPlatform   ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )-    unscramble dflags ([1..] `zip` (regs `zip` rhss))+    unscramble platform ([1..] `zip` (regs `zip` rhss)) -unscramble :: DynFlags -> [Vrtx] -> FCode ()-unscramble dflags vertices = mapM_ do_component components+unscramble :: Platform -> [Vrtx] -> FCode ()+unscramble platform vertices = mapM_ do_component components   where         edges :: [ Node Key Vrtx ]         edges = [ DigraphNode vertex key1 (edges_from stmt1)@@ -417,25 +420,24 @@                 -- Cyclic?  Then go via temporaries.  Pick one to                 -- break the loop and try again with the rest.         do_component (CyclicSCC ((_,first_stmt) : rest)) = do-            dflags <- getDynFlags             u <- newUnique-            let (to_tmp, from_tmp) = split dflags u first_stmt+            let (to_tmp, from_tmp) = split u first_stmt             mk_graph to_tmp-            unscramble dflags rest+            unscramble platform rest             mk_graph from_tmp -        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)-        split dflags uniq (reg, rhs)+        split :: Unique -> Stmt -> (Stmt, Stmt)+        split uniq (reg, rhs)           = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))           where-            rep = cmmExprType dflags rhs+            rep = cmmExprType platform rhs             tmp = LocalReg uniq rep          mk_graph :: Stmt -> FCode ()         mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs          mustFollow :: Stmt -> Stmt -> Bool-        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs+        (reg, _) `mustFollow` (_, rhs) = regUsedIn platform (CmmLocal reg) rhs  ------------------------------------------------------------------------- --      mkSwitch@@ -518,8 +520,8 @@     deflt_lbl <- label_code join_lbl deflt     branches_lbls <- label_branches join_lbl branches -    dflags <- getDynFlags-    let cmm_ty = cmmExprType dflags scrut+    platform <- getPlatform+    let cmm_ty = cmmExprType platform scrut         rep = typeWidth cmm_ty      -- We find the necessary type information in the literals in the branches@@ -527,8 +529,8 @@                     (LitNumber nt _ _, _) -> litNumIsSigned nt                     _ -> False -    let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)-              | otherwise = (0, tARGET_MAX_WORD dflags)+    let range | signed    = (platformMinInt platform, platformMaxInt platform)+              | otherwise = (0, platformMaxWord platform)      if isFloatType cmm_ty     then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls@@ -551,28 +553,28 @@               -> [(Literal,BlockId)]               -> FCode CmmAGraph mk_float_switch rep scrut deflt _bounds [(lit,blk)]-  = do dflags <- getDynFlags-       return $ mkCbranch (cond dflags) deflt blk Nothing+  = do platform <- getPlatform+       return $ mkCbranch (cond platform) deflt blk Nothing   where-    cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]+    cond platform = CmmMachOp ne [scrut, CmmLit cmm_lit]       where-        cmm_lit = mkSimpleLit dflags lit+        cmm_lit = mkSimpleLit platform lit         ne      = MO_F_Ne rep  mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches-  = do dflags <- getDynFlags+  = do platform <- getPlatform        lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches        hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches-       mkCmmIfThenElse (cond dflags) lo_blk hi_blk+       mkCmmIfThenElse (cond platform) lo_blk hi_blk   where     (lo_branches, mid_lit, hi_branches) = divideBranches branches      bounds_lo = (lo_bound, Just mid_lit)     bounds_hi = (Just mid_lit, hi_bound) -    cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]+    cond platform = CmmMachOp lt [scrut, CmmLit cmm_lit]       where-        cmm_lit = mkSimpleLit dflags mid_lit+        cmm_lit = mkSimpleLit platform mid_lit         lt      = MO_F_Lt rep  @@ -609,8 +611,8 @@ assignTemp' e   | isTrivialCmmExpr e = return e   | otherwise = do-       dflags <- getDynFlags-       lreg <- newTemp (cmmExprType dflags e)+       platform <- getPlatform+       lreg <- newTemp (cmmExprType platform e)        let reg = CmmLocal lreg        emitAssign reg e        return (CmmReg reg)@@ -620,15 +622,16 @@ -- Pushing to the update remembered set --------------------------------------------------------------------------- -whenUpdRemSetEnabled :: DynFlags -> FCode a -> FCode ()-whenUpdRemSetEnabled dflags code = do+whenUpdRemSetEnabled :: FCode a -> FCode ()+whenUpdRemSetEnabled code = do+    platform <- getPlatform     do_it <- getCode code+    let+      enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord platform)+      zero = zeroExpr platform+      is_enabled = cmmNeWord platform enabled zero     the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)     emit the_if-  where-    enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord dflags)-    zero = zeroExpr dflags-    is_enabled = cmmNeWord dflags enabled zero  -- | Emit code to add an entry to a now-overwritten pointer to the update -- remembered set.
compiler/GHC/ThToHs.hs view
@@ -28,21 +28,21 @@  import GHC.Hs as Hs import PrelNames-import RdrName-import qualified Name-import Module+import GHC.Types.Name.Reader+import qualified GHC.Types.Name as Name+import GHC.Types.Module import RdrHsSyn-import OccName-import SrcLoc-import Type-import qualified Coercion ( Role(..) )+import GHC.Types.Name.Occurrence as OccName+import GHC.Types.SrcLoc+import GHC.Core.Type+import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import TysWiredIn-import BasicTypes as Hs-import ForeignCall-import Unique+import GHC.Types.Basic as Hs+import GHC.Types.ForeignCall+import GHC.Types.Unique import ErrUtils import Bag-import Lexeme+import GHC.Utils.Lexeme import Util import FastString import Outputable
compiler/GHC/Types/Name/Shape.hs view
@@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} -module GHC.Types.Name.Shape(-    NameShape(..),-    emptyNameShape,-    mkNameShape,-    extendNameShape,-    nameShapeExports,-    substNameShape,-    maybeSubstNameShape,-    ) where+module GHC.Types.Name.Shape+   ( NameShape(..)+   , emptyNameShape+   , mkNameShape+   , extendNameShape+   , nameShapeExports+   , substNameShape+   , maybeSubstNameShape+   )+where  #include "HsVersions.h" @@ -16,13 +17,13 @@  import Outputable import GHC.Driver.Types-import Module-import UniqFM-import Avail-import FieldLabel+import GHC.Types.Module+import GHC.Types.Unique.FM+import GHC.Types.Avail+import GHC.Types.FieldLabel -import Name-import NameEnv+import GHC.Types.Name+import GHC.Types.Name.Env import TcRnMonad import Util import GHC.Iface.Env
compiler/iface/BuildTyCl.hs view
@@ -20,27 +20,27 @@ import GhcPrelude  import GHC.Iface.Env-import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )+import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) import TysWiredIn( isCTupleTyConName ) import TysPrim ( voidPrimTy )-import DataCon-import PatSyn-import Var-import VarSet-import BasicTypes-import Name-import NameEnv-import MkId-import Class-import TyCon-import Type-import Id+import GHC.Core.DataCon+import GHC.Core.PatSyn+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Basic+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Id.Make+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Types.Id import TcType -import SrcLoc( SrcSpan, noSrcSpan )+import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) import GHC.Driver.Session import TcRnMonad-import UniqSupply+import GHC.Types.Unique.Supply import Util import Outputable @@ -102,7 +102,7 @@             -> TyConRepName             -> [HsSrcBang]             -> Maybe [HsImplBang]-                -- See Note [Bangs on imported data constructors] in MkId+                -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make            -> [FieldLabel]             -- Field labels            -> [TyVar]                  -- Universals            -> [TyCoVar]                -- Existentials
compiler/iface/FlagChecker.hs view
@@ -13,8 +13,8 @@ import Binary import GHC.Driver.Session import GHC.Driver.Types-import Module-import Name+import GHC.Types.Module+import GHC.Types.Name import Fingerprint import BinFingerprint -- import Outputable
compiler/main/Elf.hs view
@@ -19,6 +19,7 @@ import AsmUtils import Exception import GHC.Driver.Session+import GHC.Platform import ErrUtils import Maybes     (MaybeT(..),runMaybeT) import Util       (charToC)@@ -408,12 +409,12 @@ -- | Generate the GAS code to create a Note section -- -- Header fields for notes are 32-bit long (see Note [ELF specification]).-makeElfNote :: String -> String -> Word32 -> String -> SDoc-makeElfNote sectionName noteName typ contents = hcat [+makeElfNote :: Platform -> String -> String -> Word32 -> String -> SDoc+makeElfNote platform sectionName noteName typ contents = hcat [     text "\t.section ",     text sectionName,     text ",\"\",",-    sectionType "note",+    sectionType platform "note",     text "\n",     text "\t.balign 4\n",
compiler/main/HscStats.hs view
@@ -15,7 +15,7 @@ import Bag import GHC.Hs import Outputable-import SrcLoc+import GHC.Types.SrcLoc import Util  import Data.Char
compiler/main/StaticPtrTable.hs view
@@ -28,7 +28,7 @@ -- -- The linker must find the definitions matching the @extern StgPtr <name>@ -- declarations. For this to work, the identifiers of static pointers need to be--- exported. This is done in SetLevels.newLvlVar.+-- exported. This is done in GHC.Core.Op.SetLevels.newLvlVar. -- -- There is also a finalization function for the time when the module is -- unloaded.@@ -127,18 +127,18 @@ import GHC.Cmm.CLabel import GHC.Core import GHC.Core.Utils (collectMakeStaticArgs)-import DataCon+import GHC.Core.DataCon import GHC.Driver.Session import GHC.Driver.Types-import Id+import GHC.Types.Id import GHC.Core.Make (mkStringExprFSWith)-import Module-import Name+import GHC.Types.Module+import GHC.Types.Name import Outputable import GHC.Platform import PrelNames import TcEnv (lookupGlobal)-import Type+import GHC.Core.Type  import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State@@ -178,6 +178,7 @@         go (reverse fps' ++ fps) (bnd' : bs) xs'      dflags = hsc_dflags hsc_env+    platform = targetPlatform dflags      -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.     --@@ -219,8 +220,8 @@       staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName       return (fp, mkConApp staticPtrDataCon                                [ Type t-                               , mkWord64LitWordRep dflags w0-                               , mkWord64LitWordRep dflags w1+                               , mkWord64LitWordRep platform w0+                               , mkWord64LitWordRep platform w1                                , info                                , e ]) @@ -233,10 +234,10 @@      -- Choose either 'Word64#' or 'Word#' to represent the arguments of the     -- 'Fingerprint' data constructor.-    mkWord64LitWordRep dflags =-      case platformWordSize (targetPlatform dflags) of+    mkWord64LitWordRep platform =+      case platformWordSize platform of         PW4 -> mkWord64LitWord64-        PW8 -> mkWordLit dflags . toInteger+        PW8 -> mkWordLit platform . toInteger      lookupIdHscEnv :: Name -> IO Id     lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
compiler/main/SysTools.hs view
@@ -42,12 +42,13 @@  import GHC.Settings -import Module+import GHC.Types.Module import GHC.Driver.Packages import Outputable import ErrUtils import GHC.Platform import GHC.Driver.Session+import GHC.Driver.Ways  import Control.Monad.Trans.Except (runExceptT) import System.FilePath@@ -58,6 +59,7 @@ import SysTools.Tasks import SysTools.BaseDir import SysTools.Settings+import qualified Data.Set as Set  {- Note [How GHC finds toolchain utilities]@@ -254,7 +256,7 @@          | ( osElfTarget (platformOS (targetPlatform dflags)) ||              osMachOTarget (platformOS (targetPlatform dflags)) ) &&            dynLibLoader dflags == SystemDependent &&-           WayDyn `elem` ways dflags+           WayDyn `Set.member` ways dflags             = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]               -- See Note [-Xlinker -rpath vs -Wl,-rpath]          | otherwise = ["-L" ++ l]
compiler/main/SysTools/ExtraObj.hs view
@@ -19,8 +19,8 @@ import GHC.Driver.Packages import GHC.Platform import Outputable-import SrcLoc           ( noSrcSpan )-import Module+import GHC.Types.SrcLoc ( noSrcSpan )+import GHC.Types.Module import Elf import Util import GhcPrelude@@ -143,22 +143,23 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do    link_info <- getLinkInfo dflags dep_packages -   if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))+   if (platformSupportsSavingLinkOpts (platformOS platform ))      then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))      else return []    where+    platform = targetPlatform dflags     link_opts info = hcat [       -- "link info" section (see Note [LinkInfo section])-      makeElfNote ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,+      makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,        -- ALL generated assembly must have this section to disable       -- executable stacks.  See also       -- compiler/nativeGen/AsmCodeGen.hs for another instance       -- where we need to do this.-      if platformHasGnuNonexecStack (targetPlatform dflags)+      if platformHasGnuNonexecStack platform         then text ".section .note.GNU-stack,\"\","-             <> sectionType "progbits" <> char '\n'+             <> sectionType platform "progbits" <> char '\n'         else Outputable.empty       ]
compiler/main/SysTools/Process.hs view
@@ -18,7 +18,7 @@ import Panic import GhcPrelude import Util-import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )+import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )  import Control.Concurrent import Data.Char@@ -36,14 +36,10 @@ -- @process >= 1.6.8.0@). enableProcessJobs :: CreateProcess -> CreateProcess #if defined(MIN_VERSION_process)-#if MIN_VERSION_process(1,6,8) enableProcessJobs opts = opts { use_process_jobs = True } #else enableProcessJobs opts = opts #endif-#else-enableProcessJobs opts = opts-#endif  -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is -- inherited from the parent process, and output to stderr is not captured.@@ -344,10 +340,21 @@                     Nothing -> Nothing                 Nothing -> Nothing +-- | Break a line of an error message into a filename and the rest of the line,+-- taking care to ignore colons in Windows drive letters (as noted in #17786).+-- For instance,+--+-- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", "ABCD")@+-- * @"C:\hi.c: ABCD"@ is mapped to @Just ("C:\hi.c", "ABCD")@ breakColon :: String -> Maybe (String, String)-breakColon xs = case break (':' ==) xs of-                    (ys, _:zs) -> Just (ys, zs)-                    _ -> Nothing+breakColon = go []+  where+    -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@)+    go accum  (':':'\\':rest) = go ('\\':':':accum) rest+    go accum  (':':'/':rest)  = go ('/':':':accum) rest+    go accum  (':':rest)      = Just (reverse accum, rest)+    go accum  (c:rest)        = go (c:accum) rest+    go _accum []              = Nothing  breakIntColon :: String -> Maybe (Int, String) breakIntColon xs = case break (':' ==) xs of
compiler/main/UpdateCafInfos.hs view
@@ -7,24 +7,31 @@ import GhcPrelude  import GHC.Core+import GHC.Driver.Session import GHC.Driver.Types-import Id-import IdInfo-import InstEnv-import NameEnv-import NameSet+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core.InstEnv+import GHC.Types.Name.Env+import GHC.Types.Name.Set import Util-import Var+import GHC.Types.Var import Outputable  #include "HsVersions.h"  -- | Update CafInfos of all occurences (in rules, unfoldings, class instances) updateModDetailsCafInfos-  :: NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.+  :: DynFlags+  -> NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.   -> ModDetails -- ^ ModDetails to update   -> ModDetails-updateModDetailsCafInfos non_cafs mod_details =++updateModDetailsCafInfos dflags _ mod_details+  | gopt Opt_OmitInterfacePragmas dflags+  = mod_details++updateModDetailsCafInfos _ non_cafs mod_details =   {- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -}   let     ModDetails{ md_types = type_env -- for unfoldings
compiler/prelude/PrelInfo.hs view
@@ -49,26 +49,26 @@ import GhcPrelude  import KnownUniques-import Unique           ( isValidKnownKeyUnique )+import GHC.Types.Unique ( isValidKnownKeyUnique ) -import ConLike          ( ConLike(..) )+import GHC.Core.ConLike ( ConLike(..) ) import THNames          ( templateHaskellNames ) import PrelNames-import PrelRules-import Avail+import GHC.Core.Op.ConstantFold+import GHC.Types.Avail import PrimOp-import DataCon-import Id-import Name-import NameEnv-import MkId+import GHC.Core.DataCon+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Id.Make import Outputable import TysPrim import TysWiredIn import GHC.Driver.Types-import Class-import TyCon-import UniqFM+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Types.Unique.FM import Util import TcTypeNats ( typeNatTyCons ) @@ -89,18 +89,18 @@ * Wired-in things are Ids\/TyCons that are completely known to the compiler.   They are global values in GHC, (e.g.  listTyCon :: TyCon). -* A wired in Name contains the thing itself inside the Name:+* A wired-in Name contains the thing itself inside the Name:         see Name.wiredInNameTyThing_maybe   (E.g. listTyConName contains listTyCon.  * The name cache is initialised with (the names of) all wired-in things-  (except tuples and sums; see Note [Known-])+  (except tuples and sums; see Note [Infinite families of known-key names])  * The type environment itself contains no wired in things. The type   checker sees if the Name is wired in before looking up the name in   the type environment. -* GHC.Iface.Utils prunes out wired-in things before putting them in an interface file.+* GHC.Iface.Make prunes out wired-in things before putting them in an interface file.   So interface files never contain wired-in things. -}
compiler/prelude/THNames.hs view
@@ -9,11 +9,11 @@ import GhcPrelude ()  import PrelNames( mk_known_key_name )-import Module( Module, mkModuleNameFS, mkModule, thUnitId )-import Name( Name )-import OccName( tcName, clsName, dataName, varName )-import RdrName( RdrName, nameRdrName )-import Unique+import GHC.Types.Module( Module, mkModuleNameFS, mkModule, thUnitId )+import GHC.Types.Name( Name )+import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName )+import GHC.Types.Name.Reader( RdrName, nameRdrName )+import GHC.Types.Unique import FastString  -- To add a name, do three things@@ -108,7 +108,6 @@     -- Role     nominalRName, representationalRName, phantomRName, inferRName,     -- Kind-    varKName, conKName, tupleKName, arrowKName, listKName, appKName,     starKName, constraintKName,     -- FamilyResultSig     noSigName, kindSigName, tyVarSigName,@@ -171,13 +170,13 @@ mkTHModule m = mkModule thUnitId (mkModuleNameFS m)  libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name-libFun = mk_known_key_name OccName.varName  thLib-libTc  = mk_known_key_name OccName.tcName   thLib-thFun  = mk_known_key_name OccName.varName  thSyn-thTc   = mk_known_key_name OccName.tcName   thSyn-thCls  = mk_known_key_name OccName.clsName  thSyn-thCon  = mk_known_key_name OccName.dataName thSyn-qqFun  = mk_known_key_name OccName.varName  qqLib+libFun = mk_known_key_name varName  thLib+libTc  = mk_known_key_name tcName   thLib+thFun  = mk_known_key_name varName  thSyn+thTc   = mk_known_key_name tcName   thSyn+thCls  = mk_known_key_name clsName  thSyn+thCon  = mk_known_key_name dataName thSyn+qqFun  = mk_known_key_name varName  qqLib  -------------------- TH.Syntax ----------------------- liftClassName :: Name@@ -480,14 +479,7 @@ inferRName            = libFun (fsLit "inferR")            inferRIdKey  -- data Kind = ...-varKName, conKName, tupleKName, arrowKName, listKName, appKName,-  starKName, constraintKName :: Name-varKName        = libFun (fsLit "varK")         varKIdKey-conKName        = libFun (fsLit "conK")         conKIdKey-tupleKName      = libFun (fsLit "tupleK")       tupleKIdKey-arrowKName      = libFun (fsLit "arrowK")       arrowKIdKey-listKName       = libFun (fsLit "listK")        listKIdKey-appKName        = libFun (fsLit "appK")         appKIdKey+starKName, constraintKName :: Name starKName       = libFun (fsLit "starK")        starKIdKey constraintKName = libFun (fsLit "constraintK")  constraintKIdKey @@ -1001,14 +993,7 @@ inferRIdKey            = mkPreludeMiscIdUnique 418  -- data Kind = ...-varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,-  starKIdKey, constraintKIdKey :: Unique-varKIdKey         = mkPreludeMiscIdUnique 419-conKIdKey         = mkPreludeMiscIdUnique 420-tupleKIdKey       = mkPreludeMiscIdUnique 421-arrowKIdKey       = mkPreludeMiscIdUnique 422-listKIdKey        = mkPreludeMiscIdUnique 423-appKIdKey         = mkPreludeMiscIdUnique 424+starKIdKey, constraintKIdKey :: Unique starKIdKey        = mkPreludeMiscIdUnique 425 constraintKIdKey  = mkPreludeMiscIdUnique 426
− compiler/profiling/ProfInit.hs 
@@ -1,64 +0,0 @@--- ----------------------------------------------------------------------------------- (c) The University of Glasgow, 2011------ Generate code to initialise cost centres------ -------------------------------------------------------------------------------module ProfInit (profilingInitCode) where--import GhcPrelude--import GHC.Cmm.CLabel-import CostCentre-import GHC.Driver.Session-import Outputable-import Module---- -------------------------------------------------------------------------------- Initialising cost centres---- We must produce declarations for the cost-centres defined in this--- module;--profilingInitCode :: Module -> CollectedCCs -> SDoc-profilingInitCode this_mod (local_CCs, singleton_CCSs)- = sdocWithDynFlags $ \dflags ->-   if not (gopt Opt_SccProfilingOn dflags)-   then empty-   else vcat-    $  map emit_cc_decl local_CCs-    ++ map emit_ccs_decl singleton_CCSs-    ++ [emit_cc_list local_CCs]-    ++ [emit_ccs_list singleton_CCSs]-    ++ [ text "static void prof_init_" <> ppr this_mod-            <> text "(void) __attribute__((constructor));"-       , text "static void prof_init_" <> ppr this_mod <> text "(void)"-       , braces (vcat-                 [ text "registerCcList" <> parens local_cc_list_label <> semi-                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi-                 ])-       ]- where-   emit_cc_decl cc =-       text "extern CostCentre" <+> cc_lbl <> text "[];"-     where cc_lbl = ppr (mkCCLabel cc)-   local_cc_list_label = text "local_cc_" <> ppr this_mod-   emit_cc_list ccs =-      text "static CostCentre *" <> local_cc_list_label <> text "[] ="-      <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma-                         | cc <- ccs-                         ] ++ [text "NULL"])-      <> semi--   emit_ccs_decl ccs =-       text "extern CostCentreStack" <+> ccs_lbl <> text "[];"-     where ccs_lbl = ppr (mkCCSLabel ccs)-   singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod-   emit_ccs_list ccs =-      text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="-      <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma-                         | cc <- ccs-                         ] ++ [text "NULL"])-      <> semi
− compiler/simplCore/CSE.hs 
@@ -1,746 +0,0 @@-{--(c) The AQUA Project, Glasgow University, 1993-1998--\section{Common subexpression}--}--{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}--module CSE (cseProgram, cseOneExpr) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Core.Subst-import Var              ( Var )-import VarEnv           ( elemInScopeSet, mkInScopeSet )-import Id               ( Id, idType, isDeadBinder, idHasRules-                        , idInlineActivation, setInlineActivation-                        , zapIdOccInfo, zapIdUsageInfo, idInlinePragma-                        , isJoinId, isJoinId_maybe )-import GHC.Core.Utils        ( mkAltExpr, eqExpr-                        , exprIsTickedString-                        , stripTicksE, stripTicksT, mkTicks )-import GHC.Core.FVs          ( exprFreeVars )-import Type             ( tyConAppArgs )-import GHC.Core-import Outputable-import BasicTypes-import GHC.Core.Map-import Util             ( filterOut )-import Data.List        ( mapAccumL )--{--                        Simple common sub-expression-                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we see-        x1 = C a b-        x2 = C x1 b-we build up a reverse mapping:   C a b  -> x1-                                 C x1 b -> x2-and apply that to the rest of the program.--When we then see-        y1 = C a b-        y2 = C y1 b-we replace the C a b with x1.  But then we *dont* want to-add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1-so that a subsequent binding-        y2 = C y1 b-will get transformed to C x1 b, and then to x2.--So we carry an extra var->var substitution which we apply *before* looking up in the-reverse mapping.---Note [Shadowing]-~~~~~~~~~~~~~~~~-We have to be careful about shadowing.-For example, consider-        f = \x -> let y = x+x in-                      h = \x -> x+x-                  in ...--Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no-shadowing, but it doesn't any more (it proved too hard), so we clone as we go.-We can simply add clones to the substitution already described.---Note [CSE for bindings]-~~~~~~~~~~~~~~~~~~~~~~~-Let-bindings have two cases, implemented by addBinding.--* SUBSTITUTE: applies when the RHS is a variable--     let x = y in ...(h x)....--  Here we want to extend the /substitution/ with x -> y, so that the-  (h x) in the body might CSE with an enclosing (let v = h y in ...).-  NB: the substitution maps InIds, so we extend the substitution with-      a binding for the original InId 'x'--  How can we have a variable on the RHS? Doesn't the simplifier inline them?--    - First, the original RHS might have been (g z) which has CSE'd-      with an enclosing (let y = g z in ...).  This is super-important.-      See #5996:-         x1 = C a b-         x2 = C x1 b-         y1 = C a b-         y2 = C y1 b-      Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to-      the substitution so that we can CSE the binding for y2.--    - Second, we use addBinding for case expression scrutinees too;-      see Note [CSE for case expressions]--* EXTEND THE REVERSE MAPPING: applies in all other cases--     let x = h y in ...(h y)...--  Here we want to extend the /reverse mapping (cs_map)/ so that-  we CSE the (h y) call to x.--  Note that we use EXTEND even for a trivial expression, provided it-  is not a variable or literal. In particular this /includes/ type-  applications. This can be important (#13156); e.g.-     case f @ Int of { r1 ->-     case f @ Int of { r2 -> ...-  Here we want to common-up the two uses of (f @ Int) so we can-  remove one of the case expressions.--  See also Note [Corner case for case expressions] for another-  reason not to use SUBSTITUTE for all trivial expressions.--Notice that-  - The SUBSTITUTE situation extends the substitution (cs_subst)-  - The EXTEND situation extends the reverse mapping (cs_map)--Notice also that in the SUBSTITUTE case we leave behind a binding-  x = y-even though we /also/ carry a substitution x -> y.  Can we just drop-the binding instead?  Well, not at top level! See SimplUtils-Note [Top level and postInlineUnconditionally]; and in any case CSE-applies only to the /bindings/ of the program, and we leave it to the-simplifier to propate effects to the RULES.  Finally, it doesn't seem-worth the effort to discard the nested bindings because the simplifier-will do it next.--Note [CSE for case expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  case scrut_expr of x { ...alts... }-This is very like a strict let-binding-  let !x = scrut_expr in ...-So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a-result all the stuff under Note [CSE for bindings] applies directly.--For example:--* Trivial scrutinee-     f = \x -> case x of wild {-                 (a:as) -> case a of wild1 {-                             (p,q) -> ...(wild1:as)...--  Here, (wild1:as) is morally the same as (a:as) and hence equal to-  wild. But that's not quite obvious.  In the rest of the compiler we-  want to keep it as (wild1:as), but for CSE purpose that's a bad-  idea.--  By using addBinding we add the binding (wild1 -> a) to the substitution,-  which does exactly the right thing.--  (Notice this is exactly backwards to what the simplifier does, which-  is to try to replaces uses of 'a' with uses of 'wild1'.)--  This is the main reason that addBinding is called with a trivial rhs.--* Non-trivial scrutinee-     case (f x) of y { pat -> ...let z = f x in ... }--  By using addBinding we'll add (f x :-> y) to the cs_map, and-  thereby CSE the inner (f x) to y.--Note [CSE for INLINE and NOINLINE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are some subtle interactions of CSE with functions that the user-has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)-Consider--        yes :: Int  {-# NOINLINE yes #-}-        yes = undefined--        no :: Int   {-# NOINLINE no #-}-        no = undefined--        foo :: Int -> Int -> Int  {-# NOINLINE foo #-}-        foo m n = n--        {-# RULES "foo/no" foo no = id #-}--        bar :: Int -> Int-        bar = foo yes--We do not expect the rule to fire.  But if we do CSE, then we risk-getting yes=no, and the rule does fire.  Actually, it won't because-NOINLINE means that 'yes' will never be inlined, not even if we have-yes=no.  So that's fine (now; perhaps in the olden days, yes=no would-have substituted even if 'yes' was NOINLINE).--But we do need to take care.  Consider--        {-# NOINLINE bar #-}-        bar = <rhs>     -- Same rhs as foo--        foo = <rhs>--If CSE produces-        foo = bar-then foo will never be inlined to <rhs> (when it should be, if <rhs>-is small).  The conclusion here is this:--   We should not add-       <rhs> :-> bar-  to the CSEnv if 'bar' has any constraints on when it can inline;-  that is, if its 'activation' not always active.  Otherwise we-  might replace <rhs> by 'bar', and then later be unable to see that it-  really was <rhs>.--An except to the rule is when the INLINE pragma is not from the user, e.g. from-WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec-is then true.--Note that we do not (currently) do CSE on the unfolding stored inside-an Id, even if it is a 'stable' unfolding.  That means that when an-unfolding happens, it is always faithful to what the stable unfolding-originally was.--Note [CSE for stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   {-# Unf = Stable (\pq. build blah) #-}-   foo = x--Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.-(Turns out that this actually happens for the enumFromTo method of-the Integer instance of Enum in GHC.Enum.)  Suppose moreover that foo's-stable unfolding originates from an INLINE or INLINEABLE pragma on foo.-Then we obviously do NOT want to extend the substitution with (foo->x),-because we promised to inline foo as what the user wrote.  See similar-SimplUtils Note [Stable unfoldings and postInlineUnconditionally].--Nor do we want to change the reverse mapping. Suppose we have--   {-# Unf = Stable (\pq. build blah) #-}-   foo = <expr>-   bar = <expr>--There could conceivably be merit in rewriting the RHS of bar:-   bar = foo-but now bar's inlining behaviour will change, and importing-modules might see that.  So it seems dodgy and we don't do it.--Stable unfoldings are also created during worker/wrapper when we decide-that a function's definition is so small that it should always inline.-In this case we still want to do CSE (#13340). Hence the use of-isAnyInlinePragma rather than isStableUnfolding.--Note [Corner case for case expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here is another reason that we do not use SUBSTITUTE for-all trivial expressions. Consider-   case x |> co of (y::Array# Int) { ... }--We do not want to extend the substitution with (y -> x |> co); since y-is of unlifted type, this would destroy the let/app invariant if (x |>-co) was not ok-for-speculation.--But surely (x |> co) is ok-for-speculation, because it's a trivial-expression, and x's type is also unlifted, presumably.  Well, maybe-not if you are using unsafe casts.  I actually found a case where we-had-   (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)--Note [CSE for join points?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must not be naive about join points in CSE:-   join j = e in-   if b then jump j else 1 + e-The expression (1 + jump j) is not good (see Note [Invariants on join points] in-GHC.Core). This seems to come up quite seldom, but it happens (first seen-compiling ppHtml in Haddock.Backends.Xhtml).--We could try and be careful by tracking which join points are still valid at-each subexpression, but since join points aren't allocated or shared, there's-less to gain by trying to CSE them. (#13219)--Note [Look inside join-point binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Another way how CSE for joint points is tricky is--  let join foo x = (x, 42)-      join bar x = (x, 42)-  in … jump foo 1 … jump bar 2 …--naively, CSE would turn this into--  let join foo x = (x, 42)-      join bar = foo-  in … jump foo 1 … jump bar 2 …--but now bar is a join point that claims arity one, but its right-hand side-is not a lambda, breaking the join-point invariant (this was #15002).--So `cse_bind` must zoom past the lambdas of a join point (using-`collectNBinders`) and resume searching for CSE opportunities only in-the body of the join point.--Note [CSE for recursive bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f = \x ... f....-  g = \y ... g ...-where the "..." are identical.  Could we CSE them?  In full generality-with mutual recursion it's quite hard; but for self-recursive bindings-(which are very common) it's rather easy:--* Maintain a separate cs_rec_map, that maps-      (\f. (\x. ...f...) ) -> f-  Note the \f in the domain of the mapping!--* When we come across the binding for 'g', look up (\g. (\y. ...g...))-  Bingo we get a hit.  So we can replace the 'g' binding with-     g = f--We can't use cs_map for this, because the key isn't an expression of-the program; it's a kind of synthetic key for recursive bindings.---************************************************************************-*                                                                      *-\section{Common subexpression}-*                                                                      *-************************************************************************--}--cseProgram :: CoreProgram -> CoreProgram-cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)--cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind)-cseBind toplevel env (NonRec b e)-  = (env2, NonRec b2 e2)-  where-    (env1, b1)       = addBinder env b-    (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1--cseBind toplevel env (Rec [(in_id, rhs)])-  | noCSE in_id-  = (env1, Rec [(out_id, rhs')])--  -- See Note [CSE for recursive bindings]-  | Just previous <- lookupCSRecEnv env out_id rhs''-  , let previous' = mkTicks ticks previous-        out_id'   = delayInlining toplevel out_id-  = -- We have a hit in the recursive-binding cache-    (extendCSSubst env1 in_id previous', NonRec out_id' previous')--  | otherwise-  = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])--  where-    (env1, [out_id]) = addRecBinders env [in_id]-    rhs'  = cseExpr env1 rhs-    rhs'' = stripTicksE tickishFloatable rhs'-    ticks = stripTicksT tickishFloatable rhs'-    id_expr'  = varToCoreExpr out_id-    zapped_id = zapIdUsageInfo out_id--cseBind toplevel env (Rec pairs)-  = (env2, Rec pairs')-  where-    (env1, bndrs1) = addRecBinders env (map fst pairs)-    (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)--    do_one env (pr, b1) = cse_bind toplevel env pr b1---- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer--- to @in_id@ (@out_id@, created from addBinder or addRecBinders),--- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd)--- binding to the 'CSEnv', so that we attempt to CSE any expressions--- which are equal to @out_rhs@.-cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))-cse_bind toplevel env (in_id, in_rhs) out_id-  | isTopLevel toplevel, exprIsTickedString in_rhs-      -- See Note [Take care with literal strings]-  = (env', (out_id', in_rhs))--  | Just arity <- isJoinId_maybe in_id-      -- See Note [Look inside join-point binders]-  = let (params, in_body) = collectNBinders arity in_rhs-        (env', params') = addBinders env params-        out_body = tryForCSE env' in_body-    in (env, (out_id, mkLams params' out_body))--  | otherwise-  = (env', (out_id'', out_rhs))-  where-    (env', out_id') = addBinding env in_id out_id out_rhs-    (cse_done, out_rhs) = try_for_cse env in_rhs-    out_id'' | cse_done  = delayInlining toplevel out_id'-             | otherwise = out_id'--delayInlining :: TopLevelFlag -> Id -> Id--- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already--- See Note [Delay inlining after CSE]-delayInlining top_lvl bndr-  | isTopLevel top_lvl-  , isAlwaysActive (idInlineActivation bndr)-  , idHasRules bndr  -- Only if the Id has some RULES,-                     -- which might otherwise get lost-       -- These rules are probably auto-generated specialisations,-       -- since Ids with manual rules usually have manually-inserted-       -- delayed inlining anyway-  = bndr `setInlineActivation` activeAfterInitial-  | otherwise-  = bndr--addBinding :: CSEnv                      -- Includes InId->OutId cloning-           -> InVar                      -- Could be a let-bound type-           -> OutId -> OutExpr           -- Processed binding-           -> (CSEnv, OutId)             -- Final env, final bndr--- 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.-addBinding env in_id out_id rhs'-  | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)-  | noCSE in_id      = (env,                              out_id)-  | use_subst        = (extendCSSubst env in_id rhs',     out_id)-  | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)-  where-    id_expr'  = varToCoreExpr out_id-    zapped_id = zapIdUsageInfo out_id-       -- Putting the Id into the cs_map makes it possible that-       -- it'll become shared more than it is now, which would-       -- invalidate (the usage part of) its demand info.-       --    This caused #100218.-       -- Easiest thing is to zap the usage info; subsequently-       -- performing late demand-analysis will restore it.  Don't zap-       -- the strictness info; it's not necessary to do so, and losing-       -- it is bad for performance if you don't do late demand-       -- analysis--    -- Should we use SUBSTITUTE or EXTEND?-    -- See Note [CSE for bindings]-    use_subst = case rhs' of-                   Var {} -> True-                   _      -> False---- | Given a binder `let x = e`, this function--- determines whether we should add `e -> x` to the cs_map-noCSE :: InId -> Bool-noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&-            not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))-             -- See Note [CSE for INLINE and NOINLINE]-         || isAnyInlinePragma (idInlinePragma id)-             -- See Note [CSE for stable unfoldings]-         || isJoinId id-             -- See Note [CSE for join points?]---{- Note [Take care with literal strings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this example:--  x = "foo"#-  y = "foo"#-  ...x...y...x...y....--We would normally turn this into:--  x = "foo"#-  y = x-  ...x...x...x...x....--But this breaks an invariant of Core, namely that the RHS of a top-level binding-of type Addr# must be a string literal, not another variable. See Note-[Core top-level string literals] in GHC.Core.--For this reason, we special case top-level bindings to literal strings and leave-the original RHS unmodified. This produces:--  x = "foo"#-  y = "foo"#-  ...x...x...x...x....--Now 'y' will be discarded as dead code, and we are done.--The net effect is that for the y-binding we want to-  - Use SUBSTITUTE, by extending the substitution with  y :-> x-  - but leave the original binding for y undisturbed--This is done by cse_bind.  I got it wrong the first time (#13367).--Note [Delay inlining after CSE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose (#15445) we have-   f,g :: Num a => a -> a-   f x = ...f (x-1).....-   g y = ...g (y-1) ....--and we make some specialisations of 'g', either automatically, or via-a SPECIALISE pragma.  Then CSE kicks in and notices that the RHSs of-'f' and 'g' are identical, so we get-   f x = ...f (x-1)...-   g = f-   {-# RULES g @Int _ = $sg #-}--Now there is terrible danger that, in an importing module, we'll inline-'g' before we have a chance to run its specialisation!--Solution: during CSE, after a "hit" in the CSE cache-  * when adding a binding-        g = f-  * for a top-level function g-  * and g has specialisation RULES-add a NOINLINE[2] activation to it, to ensure it's not inlined-right away.--Notes:-* Why top level only?  Because for nested bindings we are already past-  phase 2 and will never return there.--* Why "only if g has RULES"?  Because there is no point in-  doing this if there are no RULES; and other things being-  equal it delays optimisation to delay inlining (#17409)------- Historical note -----This patch is simpler and more direct than an earlier-version:--  commit 2110738b280543698407924a16ac92b6d804dc36-  Author: Simon Peyton Jones <simonpj@microsoft.com>-  Date:   Mon Jul 30 13:43:56 2018 +0100--  Don't inline functions with RULES too early--We had to revert this patch because it made GHC itself slower.--Why? It delayed inlining of /all/ functions with RULES, and that was-very bad in TcFlatten.flatten_ty_con_app--* It delayed inlining of liftM-* That delayed the unravelling of the recursion in some dictionary-  bindings.-* That delayed some eta expansion, leaving-     flatten_ty_con_app = \x y. let <stuff> in \z. blah-* That allowed the float-out pass to put sguff between-  the \y and \z.-* And that permanently stopped eta expansion of the function,-  even once <stuff> was simplified.---}--tryForCSE :: CSEnv -> InExpr -> OutExpr-tryForCSE env expr = snd (try_for_cse env expr)--try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr)--- (False, e') => We did not CSE the entire expression,---                but we might have CSE'd some sub-expressions,---                yielding e'------ (True, te') => We CSE'd the entire expression,---                yielding the trivial expression te'-try_for_cse env expr-  | Just e <- lookupCSEnv env expr'' = (True,  mkTicks ticks e)-  | otherwise                        = (False, expr')-    -- The varToCoreExpr is needed if we have-    --   case e of xco { ...case e of yco { ... } ... }-    -- Then CSE will substitute yco -> xco;-    -- but these are /coercion/ variables-  where-    expr'  = cseExpr env expr-    expr'' = stripTicksE tickishFloatable expr'-    ticks  = stripTicksT tickishFloatable expr'-    -- We don't want to lose the source notes when a common sub-    -- expression gets eliminated. Hence we push all (!) of them on-    -- top of the replaced sub-expression. This is probably not too-    -- useful in practice, but upholds our semantics.---- | Runs CSE on a single expression.------ This entry point is not used in the compiler itself, but is provided--- as a convenient entry point for users of the GHC API.-cseOneExpr :: InExpr -> OutExpr-cseOneExpr e = cseExpr env e-  where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }--cseExpr :: CSEnv -> InExpr -> OutExpr-cseExpr env (Type t)              = Type (substTy (csEnvSubst env) t)-cseExpr env (Coercion c)          = Coercion (substCo (csEnvSubst env) c)-cseExpr _   (Lit lit)             = Lit lit-cseExpr env (Var v)               = lookupSubst env v-cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)-cseExpr env (Tick t e)            = Tick t (cseExpr env e)-cseExpr env (Cast e co)           = Cast (tryForCSE env e) (substCo (csEnvSubst env) co)-cseExpr env (Lam b e)             = let (env', b') = addBinder env b-                                    in Lam b' (cseExpr env' e)-cseExpr env (Let bind e)          = let (env', bind') = cseBind NotTopLevel env bind-                                    in Let bind' (cseExpr env' e)-cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts--cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr-cseCase env scrut bndr ty alts-  = Case scrut1 bndr3 ty' $-    combineAlts alt_env (map cse_alt alts)-  where-    ty' = substTy (csEnvSubst env) ty-    scrut1 = tryForCSE env scrut--    bndr1 = zapIdOccInfo bndr-      -- Zapping the OccInfo is needed because the extendCSEnv-      -- in cse_alt may mean that a dead case binder-      -- becomes alive, and Lint rejects that-    (env1, bndr2)    = addBinder env bndr1-    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1-         -- addBinding: see Note [CSE for case expressions]--    con_target :: OutExpr-    con_target = lookupSubst alt_env bndr--    arg_tys :: [OutType]-    arg_tys = tyConAppArgs (idType bndr3)--    -- Given case x of { K y z -> ...K y z... }-    -- CSE K y z into x...-    cse_alt (DataAlt con, args, rhs)-        | not (null args)-                -- ... but don't try CSE if there are no args; it just increases the number-                -- of live vars.  E.g.-                --      case x of { True -> ....True.... }-                -- Don't replace True by x!-                -- Hence the 'null args', which also deal with literals and DEFAULT-        = (DataAlt con, args', tryForCSE new_env rhs)-        where-          (env', args') = addBinders alt_env args-          new_env       = extendCSEnv env' con_expr con_target-          con_expr      = mkAltExpr (DataAlt con) args' arg_tys--    cse_alt (con, args, rhs)-        = (con, args', tryForCSE env' rhs)-        where-          (env', args') = addBinders alt_env args--combineAlts :: CSEnv -> [InAlt] -> [InAlt]--- See Note [Combine case alternatives]-combineAlts env ((_,bndrs1,rhs1) : rest_alts)-  | all isDeadBinder bndrs1-  = (DEFAULT, [], rhs1) : filtered_alts-  where-    in_scope = substInScope (csEnvSubst env)-    filtered_alts = filterOut identical rest_alts-    identical (_con, bndrs, rhs) = all ok bndrs && eqExpr in_scope rhs1 rhs-    ok bndr = isDeadBinder bndr || not (bndr `elemInScopeSet` in_scope)--combineAlts _ alts = alts  -- Default case--{- Note [Combine case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-combineAlts is just a more heavyweight version of the use of-combineIdenticalAlts in SimplUtils.prepareAlts.  The basic idea is-to transform--    DEFAULT -> e1-    K x     -> e1-    W y z   -> e2-===>-   DEFAULT -> e1-   W y z   -> e2--In the simplifier we use cheapEqExpr, because it is called a lot.-But here in CSE we use the full eqExpr.  After all, two alternatives usually-differ near the root, so it probably isn't expensive to compare the full-alternative.  It seems like the same kind of thing that CSE is supposed-to be doing, which is why I put it here.--I actually saw some examples in the wild, where some inlining made e1 too-big for cheapEqExpr to catch it.---************************************************************************-*                                                                      *-\section{The CSE envt}-*                                                                      *-************************************************************************--}--data CSEnv-  = CS { cs_subst :: Subst  -- Maps InBndrs to OutExprs-            -- The substitution variables to-            -- /trivial/ OutExprs, not arbitrary expressions--       , cs_map   :: CoreMap OutExpr   -- The reverse mapping-            -- Maps a OutExpr to a /trivial/ OutExpr-            -- The key of cs_map is stripped of all Ticks--       , cs_rec_map :: CoreMap OutExpr-            -- See Note [CSE for recursive bindings]-       }--emptyCSEnv :: CSEnv-emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap-                , cs_subst = emptySubst }--lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr-lookupCSEnv (CS { cs_map = csmap }) expr-  = lookupCoreMap csmap expr--extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv-extendCSEnv cse expr triv_expr-  = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }-  where-    sexpr = stripTicksE tickishFloatable expr--extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv--- See Note [CSE for recursive bindings]-extendCSRecEnv cse bndr expr triv_expr-  = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr }--lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr--- See Note [CSE for recursive bindings]-lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr-  = lookupCoreMap csmap (Lam bndr expr)--csEnvSubst :: CSEnv -> Subst-csEnvSubst = cs_subst--lookupSubst :: CSEnv -> Id -> OutExpr-lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x--extendCSSubst :: CSEnv -> Id  -> CoreExpr -> CSEnv-extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }---- | Add clones to the substitution to deal with shadowing.  See--- Note [Shadowing] for more details.  You should call this whenever--- you go under a binder.-addBinder :: CSEnv -> Var -> (CSEnv, Var)-addBinder cse v = (cse { cs_subst = sub' }, v')-                where-                  (sub', v') = substBndr (cs_subst cse) v--addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])-addBinders cse vs = (cse { cs_subst = sub' }, vs')-                where-                  (sub', vs') = substBndrs (cs_subst cse) vs--addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])-addRecBinders cse vs = (cse { cs_subst = sub' }, vs')-                where-                  (sub', vs') = substRecBndrs (cs_subst cse) vs
− compiler/simplCore/CallArity.hs 
@@ -1,763 +0,0 @@------ Copyright (c) 2014 Joachim Breitner-----module CallArity-    ( callArityAnalProgram-    , callArityRHS -- for testing-    ) where--import GhcPrelude--import VarSet-import VarEnv-import GHC.Driver.Session ( DynFlags )--import BasicTypes-import GHC.Core-import Id-import GHC.Core.Arity ( typeArity )-import GHC.Core.Utils ( exprIsCheap, exprIsTrivial )-import UnVarGraph-import Demand-import Util--import Control.Arrow ( first, second )---{--%************************************************************************-%*                                                                      *-              Call Arity Analysis-%*                                                                      *-%************************************************************************--Note [Call Arity: The goal]-~~~~~~~~~~~~~~~~~~~~~~~~~~~--The goal of this analysis is to find out if we can eta-expand a local function,-based on how it is being called. The motivating example is this code,-which comes up when we implement foldl using foldr, and do list fusion:--    let go = \x -> let d = case ... of-                              False -> go (x+1)-                              True  -> id-                   in \z -> d (x + z)-    in go 1 0--If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of-partial function applications, which would be bad.--The function `go` has a type of arity two, but only one lambda is manifest.-Furthermore, an analysis that only looks at the RHS of go cannot be sufficient-to eta-expand go: If `go` is ever called with one argument (and the result used-multiple times), we would be doing the work in `...` multiple times.--So `callArityAnalProgram` looks at the whole let expression to figure out if-all calls are nice, i.e. have a high enough arity. It then stores the result in-the `calledArity` field of the `IdInfo` of `go`, which the next simplifier-phase will eta-expand.--The specification of the `calledArity` field is:--    No work will be lost if you eta-expand me to the arity in `calledArity`.--What we want to know for a variable--------------------------------------For every let-bound variable we'd like to know:-  1. A lower bound on the arity of all calls to the variable, and-  2. whether the variable is being called at most once or possible multiple-     times.--It is always ok to lower the arity, or pretend that there are multiple calls.-In particular, "Minimum arity 0 and possible called multiple times" is always-correct.---What we want to know from an expression------------------------------------------In order to obtain that information for variables, we analyze expression and-obtain bits of information:-- I.  The arity analysis:-     For every variable, whether it is absent, or called,-     and if called, which what arity.-- II. The Co-Called analysis:-     For every two variables, whether there is a possibility that both are being-     called.-     We obtain as a special case: For every variables, whether there is a-     possibility that it is being called twice.--For efficiency reasons, we gather this information only for a set of-*interesting variables*, to avoid spending time on, e.g., variables from pattern matches.--The two analysis are not completely independent, as a higher arity can improve-the information about what variables are being called once or multiple times.--Note [Analysis I: The arity analysis]---------------------------------------The arity analysis is quite straight forward: The information about an-expression is an-    VarEnv Arity-where absent variables are bound to Nothing and otherwise to a lower bound to-their arity.--When we analyze an expression, we analyze it with a given context arity.-Lambdas decrease and applications increase the incoming arity. Analysizing a-variable will put that arity in the environment. In lets or cases all the-results from the various subexpressions are lubed, which takes the point-wise-minimum (considering Nothing an infinity).---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-we need to know which variables are possibly called together.--The data structure here is an undirected graph of variables, which is provided-by the abstract-    UnVarGraph--It is safe to return a larger graph, i.e. one with more edges. The worst case-(i.e. the least useful and always correct result) is the complete graph on all-free variables, which means that anything can be called together with anything-(including itself).--Notation for the following:-C(e)  is the co-called result for e.-G₁∪G₂ is the union of two graphs-fv    is the set of free variables (conveniently the domain of the arity analysis result)-S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ }-S²    is the complete graph on the set of variables S, S² = S×S-C'(e) is a variant for bound expression:-      If e is called at most once, or it is and stays a thunk (after the analysis),-      it is simply C(e). Otherwise, the expression can be called multiple times-      and we return (fv e)²--The interesting cases of the analysis:- * Var v:-   No other variables are being called.-   Return {} (the empty graph)- * Lambda v e, under arity 0:-   This means that e can be evaluated many times and we cannot get-   any useful co-call information.-   Return (fv e)²- * Case alternatives alt₁,alt₂,...:-   Only one can be execuded, so-   Return (alt₁ ∪ alt₂ ∪...)- * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂:-   We get the results from both sides, with the argument evaluated at most once.-   Additionally, anything called by e₁ can possibly be called with anything-   from e₂.-   Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂)- * App e₁ x:-   As this is already in A-normal form, CorePrep will not separately lambda-   bind (and hence share) x. So we conservatively assume multiple calls to x here-   Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)}- * Let v = rhs in body:-   In addition to the results from the subexpressions, add all co-calls from-   everything that the body calls together with v to everything that is called-   by v.-   Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)}- * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body-   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].--   Let V = {v₁,...vₙ}.-   Assume that the vs have been analysed with an incoming demand and-   cardinality consistent with the final result (this is the fixed-pointing).-   Again we can use the results from all subexpressions.-   In addition, for every variable vᵢ, we need to find out what it is called-   with (call this set Sᵢ). There are two cases:-    * If vᵢ is a function, we need to go through all right-hand-sides and bodies,-      and collect every variable that is called together with any variable from V:-      Sᵢ = {v' | j ∈ {1,...,n},      {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }-    * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to-      exclude it from this set:-      Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }-   Finally, combine all this:-   Return: C(body) ∪-           C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪-           (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ)--Using the result: Eta-Expansion----------------------------------We use the result of these two analyses to decide whether we can eta-expand the-rhs of a let-bound variable.--If the variable is already a function (exprIsCheap), and all calls to the-variables have a higher arity than the current manifest arity (i.e. the number-of lambdas), expand.--If the variable is a thunk we must be careful: Eta-Expansion will prevent-sharing of work, so this is only safe if there is at most one call to the-function. Therefore, we check whether {v,v} ∈ G.--    Example:--        let n = case .. of .. -- A thunk!-        in n 0 + n 1--    vs.--        let n = case .. of ..-        in case .. of T -> n 0-                      F -> n 1--    We are only allowed to eta-expand `n` if it is going to be called at most-    once in the body of the outer let. So we need to know, for each variable-    individually, that it is going to be called at most once.---Why the co-call graph?-------------------------Why is it not sufficient to simply remember which variables are called once and-which are called multiple times? It would be in the previous example, but consider--        let n = case .. of ..-        in case .. of-            True -> let go = \y -> case .. of-                                     True -> go (y + n 1)-                                     False > n-                    in go 1-            False -> n--vs.--        let n = case .. of ..-        in case .. of-            True -> let go = \y -> case .. of-                                     True -> go (y+1)-                                     False > n-                    in go 1-            False -> n--In both cases, the body and the rhs of the inner let call n at most once.-But only in the second case that holds for the whole expression! The-crucial difference is that in the first case, the rhs of `go` can call-*both* `go` and `n`, and hence can call `n` multiple times as it recurses,-while in the second case find out that `go` and `n` are not called together.---Why co-call information for functions?-----------------------------------------Although for eta-expansion we need the information only for thunks, we still-need to know whether functions are being called once or multiple times, and-together with what other functions.--    Example:--        let n = case .. of ..-            f x = n (x+1)-        in f 1 + f 2--    vs.--        let n = case .. of ..-            f x = n (x+1)-        in case .. of T -> f 0-                      F -> f 1--    Here, the body of f calls n exactly once, but f itself is being called-    multiple times, so eta-expansion is not allowed.---Note [Analysis type signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The work-hourse of the analysis is the function `callArityAnal`, with the-following type:--    type CallArityRes = (UnVarGraph, VarEnv Arity)-    callArityAnal ::-        Arity ->  -- The arity this expression is called with-        VarSet -> -- The set of interesting variables-        CoreExpr ->  -- The expression to analyse-        (CallArityRes, CoreExpr)--and the following specification:--  ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr--                            <=>--  Assume the expression `expr` is being passed `arity` arguments. Then it holds that-    * The domain of `callArityEnv` is a subset of `interestingIds`.-    * Any variable from `interestingIds` that is not mentioned in the `callArityEnv`-      is absent, i.e. not called at all.-    * Every call from `expr` to a variable bound to n in `callArityEnv` has at-      least n value arguments.-    * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`,-      then in no execution of `expr` both are being called.-  Furthermore, expr' is expr with the callArity field of the `IdInfo` updated.---Note [Which variables are interesting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The analysis would quickly become prohibitive expensive if we would analyse all-variables; for most variables we simply do not care about how often they are-called, i.e. variables bound in a pattern match. So interesting are variables that are- * top-level or let bound- * and possibly functions (typeArity > 0)--Note [Taking boring variables into account]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--If we decide that the variable bound in `let x = e1 in e2` is not interesting,-the analysis of `e2` will not report anything about `x`. To ensure that-`callArityBind` does still do the right thing we have to take that into account-every time we would be lookup up `x` in the analysis result of `e2`.-  * Instead of calling lookupCallArityRes, we return (0, True), indicating-    that this variable might be called many times with no arguments.-  * Instead of checking `calledWith x`, we assume that everything can be called-    with it.-  * In the recursive case, when calclulating the `cross_calls`, if there is-    any boring variable in the recursive group, we ignore all co-call-results-    and directly go to a very conservative assumption.--The last point has the nice side effect that the relatively expensive-integration of co-call results in a recursive groups is often skipped. This-helped to avoid the compile time blowup in some real-world code with large-recursive groups (#10293).--Note [Recursion and fixpointing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--For a mutually recursive let, we begin by- 1. analysing the body, using the same incoming arity as for the whole expression.- 2. Then we iterate, memoizing for each of the bound variables the last-    analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes.- 3. We combine the analysis result from the body and the memoized results for-    the arguments (if already present).- 4. For each variable, we find out the incoming arity and whether it is called-    once, based on the current analysis result. If this differs from the-    memoized results, we re-analyse the rhs and update the memoized table.- 5. If nothing had to be reanalyzed, we are done.-    Otherwise, repeat from step 3.---Note [Thunks in recursive groups]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We never eta-expand a thunk in a recursive group, on the grounds that if it is-part of a recursive group, then it will be called multiple times.--This is not necessarily true, e.g.  it would be safe to eta-expand t2 (but not-t1) in the following code:--  let go x = t1-      t1 = if ... then t2 else ...-      t2 = if ... then go 1 else ...-  in go 0--Detecting this would require finding out what variables are only ever called-from thunks. While this is certainly possible, we yet have to see this to be-relevant in the wild.---Note [Analysing top-level binds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We can eta-expand top-level-binds if they are not exported, as we see all calls-to them. The plan is as follows: Treat the top-level binds as nested lets around-a body representing “all external calls”, which returns a pessimistic-CallArityRes (the co-call graph is the complete graph, all arityies 0).--Note [Trimming arity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In the Call Arity papers, we are working on an untyped lambda calculus with no-other id annotations, where eta-expansion is always possible. But this is not-the case for Core!- 1. We need to ensure the invariant-      callArity e <= typeArity (exprType e)-    for the same reasons that exprArity needs this invariant (see Note-    [exprArity invariant] in GHC.Core.Arity).--    If we are not doing that, a too-high arity annotation will be stored with-    the id, confusing the simplifier later on.-- 2. Eta-expanding a right hand side might invalidate existing annotations. In-    particular, if an id has a strictness annotation of <...><...>b, then-    passing two arguments to it will definitely bottom out, so the simplifier-    will throw away additional parameters. This conflicts with Call Arity! So-    we ensure that we never eta-expand such a value beyond the number of-    arguments mentioned in the strictness signature.-    See #10176 for a real-world-example.--Note [What is a thunk]-~~~~~~~~~~~~~~~~~~~~~~--Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a-thunk, not eta-expanded, to avoid losing any sharing. This is also how the-published papers on Call Arity describe it.--In practice, there are thunks that do a just little work, such as-pattern-matching on a variable, and the benefits of eta-expansion likely-outweigh the cost of doing that repeatedly. Therefore, this implementation of-Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk.--Note [Call Arity and Join Points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The Call Arity analysis does not care about join points, and treats them just-like normal functions. This is ok.--The analysis *could* make use of the fact that join points are always evaluated-in the same context as the join-binding they are defined in and are always-one-shot, and handle join points separately, as suggested in-https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870.-This *might* be more efficient (for example, join points would not have to be-considered interesting variables), but it would also add redundant code. So for-now we do not do that.--The simplifier never eta-expands join points (it instead pushes extra arguments from-an eta-expanded context into the join point’s RHS), so the call arity-annotation on join points is not actually used. As it would be equally valid-(though less efficient) to eta-expand join points, this is the simplifier's-choice, and hence Call Arity sets the call arity for join points as well.--}---- Main entry point--callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram-callArityAnalProgram _dflags binds = binds'-  where-    (_, binds') = callArityTopLvl [] emptyVarSet binds---- See Note [Analysing top-level-binds]-callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])-callArityTopLvl exported _ []-    = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])-      , [] )-callArityTopLvl exported int1 (b:bs)-    = (ae2, b':bs')-  where-    int2 = bindersOf b-    exported' = filter isExportedId int2 ++ exported-    int' = int1 `addInterestingBinds` b-    (ae1, bs') = callArityTopLvl exported' int' bs-    (ae2, b')  = callArityBind (boringBinds b) ae1 int1 b---callArityRHS :: CoreExpr -> CoreExpr-callArityRHS = snd . callArityAnal 0 emptyVarSet---- The main analysis function. See Note [Analysis type signature]-callArityAnal ::-    Arity ->  -- The arity this expression is called with-    VarSet -> -- The set of interesting variables-    CoreExpr ->  -- The expression to analyse-    (CallArityRes, CoreExpr)-        -- How this expression uses its interesting variables-        -- and the expression with IdInfo updated---- The trivial base cases-callArityAnal _     _   e@(Lit _)-    = (emptyArityRes, e)-callArityAnal _     _   e@(Type _)-    = (emptyArityRes, e)-callArityAnal _     _   e@(Coercion _)-    = (emptyArityRes, e)--- The transparent cases-callArityAnal arity int (Tick t e)-    = second (Tick t) $ callArityAnal arity int e-callArityAnal arity int (Cast e co)-    = second (\e -> Cast e co) $ callArityAnal arity int e---- The interesting case: Variables, Lambdas, Lets, Applications, Cases-callArityAnal arity int e@(Var v)-    | v `elemVarSet` int-    = (unitArityRes v arity, e)-    | otherwise-    = (emptyArityRes, e)---- Non-value lambdas are ignored-callArityAnal arity int (Lam v e) | not (isId v)-    = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e---- We have a lambda that may be called multiple times, so its free variables--- can all be co-called.-callArityAnal 0     int (Lam v e)-    = (ae', Lam v e')-  where-    (ae, e') = callArityAnal 0 (int `delVarSet` v) e-    ae' = calledMultipleTimes ae--- We have a lambda that we are calling. decrease arity.-callArityAnal arity int (Lam v e)-    = (ae, Lam v e')-  where-    (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e---- Application. Increase arity for the called expression, nothing to know about--- the second-callArityAnal arity int (App e (Type t))-    = second (\e -> App e (Type t)) $ callArityAnal arity int e-callArityAnal arity int (App e1 e2)-    = (final_ae, App e1' e2')-  where-    (ae1, e1') = callArityAnal (arity + 1) int e1-    (ae2, e2') = callArityAnal 0           int e2-    -- If the argument is trivial (e.g. a variable), then it will _not_ be-    -- let-bound in the Core to STG transformation (CorePrep actually),-    -- so no sharing will happen here, and we have to assume many calls.-    ae2' | exprIsTrivial e2 = calledMultipleTimes ae2-         | otherwise        = ae2-    final_ae = ae1 `both` ae2'---- Case expression.-callArityAnal arity int (Case scrut bndr ty alts)-    = -- pprTrace "callArityAnal:Case"-      --          (vcat [ppr scrut, ppr final_ae])-      (final_ae, Case scrut' bndr ty alts')-  where-    (alt_aes, alts') = unzip $ map go alts-    go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e-                        in  (ae, (dc, bndrs, e'))-    alt_ae = lubRess alt_aes-    (scrut_ae, scrut') = callArityAnal 0 int scrut-    final_ae = scrut_ae `both` alt_ae---- For lets, use callArityBind-callArityAnal arity int (Let bind e)-  = -- pprTrace "callArityAnal:Let"-    --          (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])-    (final_ae, Let bind' e')-  where-    int_body = int `addInterestingBinds` bind-    (ae_body, e') = callArityAnal arity int_body e-    (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind---- Which bindings should we look at?--- See Note [Which variables are interesting]-isInteresting :: Var -> Bool-isInteresting v = not $ null (typeArity (idType v))--interestingBinds :: CoreBind -> [Var]-interestingBinds = filter isInteresting . bindersOf--boringBinds :: CoreBind -> VarSet-boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf--addInterestingBinds :: VarSet -> CoreBind -> VarSet-addInterestingBinds int bind-    = int `delVarSetList`    bindersOf bind -- Possible shadowing-          `extendVarSetList` interestingBinds bind---- Used for both local and top-level binds--- Second argument is the demand from the body-callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)--- Non-recursive let-callArityBind boring_vars ae_body int (NonRec v rhs)-  | otherwise-  = -- pprTrace "callArityBind:NonRec"-    --          (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]-    -- If v is boring, we will not find it in ae_body, but always assume (0, False)-    boring = v `elemVarSet` boring_vars--    (arity, called_once)-        | boring    = (0, False) -- See Note [Taking boring variables into account]-        | otherwise = lookupCallArityRes ae_body v-    safe_arity | called_once = arity-               | is_thunk    = 0      -- A thunk! Do not eta-expand-               | otherwise   = arity--    -- See Note [Trimming arity]-    trimmed_arity = trimArity v safe_arity--    (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs---    ae_rhs'| called_once     = ae_rhs-           | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once-           | otherwise       = calledMultipleTimes ae_rhs--    called_by_v = domRes ae_rhs'-    called_with_v-        | boring    = domRes ae_body-        | otherwise = calledWith ae_body v `delUnVarSet` v-    final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body--    v' = v `setIdCallArity` trimmed_arity----- Recursive let. See Note [Recursion and fixpointing]-callArityBind boring_vars ae_body int b@(Rec binds)-  = -- (if length binds > 300 then-    -- pprTrace "callArityBind:Rec"-    --           (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $-    (final_ae, Rec binds')-  where-    -- See Note [Taking boring variables into account]-    any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds]--    int_body = int `addInterestingBinds` b-    (ae_rhs, binds') = fix initial_binds-    final_ae = bindersOf b `resDelList` ae_rhs--    initial_binds = [(i,Nothing,e) | (i,e) <- binds]--    fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)])-    fix ann_binds-        | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $-          any_change-        = fix ann_binds'-        | otherwise-        = (ae, map (\(i, _, e) -> (i, e)) ann_binds')-      where-        aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ]-        ae = callArityRecEnv any_boring aes_old ae_body--        rerun (i, mbLastRun, rhs)-            | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae)-            -- No call to this yet, so do nothing-            = (False, (i, Nothing, rhs))--            | Just (old_called_once, old_arity, _) <- mbLastRun-            , called_once == old_called_once-            , new_arity == old_arity-            -- No change, no need to re-analyze-            = (False, (i, mbLastRun, rhs))--            | 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]--                  safe_arity | is_thunk    = 0  -- See Note [Thunks in recursive groups]-                             | otherwise   = new_arity--                  -- See Note [Trimming arity]-                  trimmed_arity = trimArity i safe_arity--                  (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs--                  ae_rhs' | called_once     = ae_rhs-                          | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once-                          | otherwise       = calledMultipleTimes ae_rhs--                  i' = i `setIdCallArity` trimmed_arity--              in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs'))-          where-            -- See Note [Taking boring variables into account]-            (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False)-                                     | otherwise                  = lookupCallArityRes ae i--        (changes, ann_binds') = unzip $ map rerun ann_binds-        any_change = or changes---- Combining the results from body and rhs, (mutually) recursive case--- See Note [Analysis II: The Co-Called analysis]-callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes-callArityRecEnv any_boring ae_rhss ae_body-    = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $-      ae_new-  where-    vars = map fst ae_rhss--    ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body--    cross_calls-        -- See Note [Taking boring variables into account]-        | any_boring               = completeGraph (domRes ae_combined)-        -- Also, calculating cross_calls is expensive. Simply be conservative-        -- if the mutually recursive group becomes too large.-        | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined)-        | otherwise                = unionUnVarGraphs $ map cross_call ae_rhss-    cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v-      where-        is_thunk = idCallArity v == 0-        -- What rhs are relevant as happening before (or after) calling v?-        --    If v is a thunk, everything from all the _other_ variables-        --    If v is not a thunk, everything can happen.-        ae_before_v | is_thunk  = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body-                    | otherwise = ae_combined-        -- What do we want to know from these?-        -- Which calls can happen next to any recursive call.-        called_with_v-            = unionUnVarSets $ map (calledWith ae_before_v) vars-        called_by_v = domRes ae_rhs--    ae_new = first (cross_calls `unionUnVarGraph`) ae_combined---- See Note [Trimming arity]-trimArity :: Id -> Arity -> Arity-trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]-  where-    max_arity_by_type = length (typeArity (idType v))-    max_arity_by_strsig-        | isBotDiv result_info = length demands-        | otherwise = a--    (demands, result_info) = splitStrictSig (idStrictness v)-------------------------------------------- Functions related to CallArityRes ---------------------------------------------- Result type for the two analyses.--- See Note [Analysis I: The arity analysis]--- and Note [Analysis II: The Co-Called analysis]-type CallArityRes = (UnVarGraph, VarEnv Arity)--emptyArityRes :: CallArityRes-emptyArityRes = (emptyUnVarGraph, emptyVarEnv)--unitArityRes :: Var -> Arity -> CallArityRes-unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity)--resDelList :: [Var] -> CallArityRes -> CallArityRes-resDelList vs ae = foldr resDel ae vs--resDel :: Var -> CallArityRes -> CallArityRes-resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v)--domRes :: CallArityRes -> UnVarSet-domRes (_, ae) = varEnvDom ae---- In the result, find out the minimum arity and whether the variable is called--- at most once.-lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)-lookupCallArityRes (g, ae) v-    = case lookupVarEnv ae v of-        Just a -> (a, not (g `hasLoopAt` v))-        Nothing -> (0, False)--calledWith :: CallArityRes -> Var -> UnVarSet-calledWith (g, _) v = neighbors g v--addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes-addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`)---- Replaces the co-call graph by a complete graph (i.e. no information)-calledMultipleTimes :: CallArityRes -> CallArityRes-calledMultipleTimes res = first (const (completeGraph (domRes res))) res---- Used for application and cases-both :: CallArityRes -> CallArityRes -> CallArityRes-both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2---- Used when combining results from alternative cases; take the minimum-lubRes :: CallArityRes -> CallArityRes -> CallArityRes-lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2)--lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity-lubArityEnv = plusVarEnv_C min--lubRess :: [CallArityRes] -> CallArityRes-lubRess = foldl' lubRes emptyArityRes
− compiler/simplCore/Exitify.hs 
@@ -1,499 +0,0 @@-module Exitify ( exitifyProgram ) where--{--Note [Exitification]-~~~~~~~~~~~~~~~~~~~~--This module implements Exitification. The goal is to pull as much code out of-recursive functions as possible, as the simplifier is better at inlining into-call-sites that are not in recursive functions.--Example:--  let t = foo bar-  joinrec go 0     x y = t (x*x)-          go (n-1) x y = jump go (n-1) (x+y)-  in …--We’d like to inline `t`, but that does not happen: Because t is a thunk and is-used in a recursive function, doing so might lose sharing in general. In-this case, however, `t` is on the _exit path_ of `go`, so called at most once.-How do we make this clearly visible to the simplifier?--A code path (i.e., an expression in a tail-recursive position) in a recursive-function is an exit path if it does not contain a recursive call. We can bind-this expression outside the recursive function, as a join-point.--Example result:--  let t = foo bar-  join exit x = t (x*x)-  joinrec go 0     x y = jump exit x-          go (n-1) x y = jump go (n-1) (x+y)-  in …--Now `t` is no longer in a recursive function, and good things happen!--}--import GhcPrelude-import Var-import Id-import IdInfo-import GHC.Core-import GHC.Core.Utils-import State-import Unique-import VarSet-import VarEnv-import GHC.Core.FVs-import FastString-import Type-import Util( mapSnd )--import Data.Bifunctor-import Control.Monad---- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them.--- The really interesting function is exitifyRec-exitifyProgram :: CoreProgram -> CoreProgram-exitifyProgram binds = map goTopLvl binds-  where-    goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e)-    goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs)-      -- Top-level bindings are never join points--    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds--    go :: InScopeSet -> CoreExpr -> CoreExpr-    go _    e@(Var{})       = e-    go _    e@(Lit {})      = e-    go _    e@(Type {})     = e-    go _    e@(Coercion {}) = e-    go in_scope (Cast e' c) = Cast (go in_scope e') c-    go in_scope (Tick t e') = Tick t (go in_scope e')-    go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2)--    go in_scope (Lam v e')-      = Lam v (go in_scope' e')-      where in_scope' = in_scope `extendInScopeSet` v--    go in_scope (Case scrut bndr ty alts)-      = Case (go in_scope scrut) bndr ty (map go_alt alts)-      where-        in_scope1 = in_scope `extendInScopeSet` bndr-        go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs)-           where in_scope' = in_scope1 `extendInScopeSetList` pats--    go in_scope (Let (NonRec bndr rhs) body)-      = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body)-      where-        in_scope' = in_scope `extendInScopeSet` bndr--    go in_scope (Let (Rec pairs) body)-      | is_join_rec = mkLets (exitifyRec in_scope' pairs') body'-      | otherwise   = Let (Rec pairs') body'-      where-        is_join_rec = any (isJoinId . fst) pairs-        in_scope'   = in_scope `extendInScopeSetList` bindersOf (Rec pairs)-        pairs'      = mapSnd (go in_scope') pairs-        body'       = go in_scope' body----- | State Monad used inside `exitify`-type ExitifyM =  State [(JoinId, CoreExpr)]---- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as---   join-points outside the joinrec.-exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]-exitifyRec in_scope pairs-  = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs']-  where-    -- We need the set of free variables of many subexpressions here, so-    -- annotate the AST with them-    -- see Note [Calculating free variables]-    ann_pairs = map (second freeVars) pairs--    -- Which are the recursive calls?-    recursive_calls = mkVarSet $ map fst pairs--    (pairs',exits) = (`runState` []) $ do-        forM ann_pairs $ \(x,rhs) -> do-            -- go past the lambdas of the join point-            let (args, body) = collectNAnnBndrs (idJoinArity x) rhs-            body' <- go args body-            let rhs' = mkLams args body'-            return (x, rhs')--    ----------------------    -- 'go' is the main working function.-    -- It goes through the RHS (tail-call positions only),-    -- checks if there are no more recursive calls, if so, abstracts over-    -- variables bound on the way and lifts it out as a join point.-    ---    -- ExitifyM is a state monad to keep track of floated binds-    go :: [Var]           -- ^ Variables that are in-scope here, but-                          -- not in scope at the joinrec; that is,-                          -- we must potentially abstract over them.-                          -- Invariant: they are kept in dependency order-       -> CoreExprWithFVs -- ^ Current expression in tail position-       -> ExitifyM CoreExpr--    -- We first look at the expression (no matter what it shape is)-    -- and determine if we can turn it into a exit join point-    go captured ann_e-        | -- An exit expression has no recursive calls-          let fvs = dVarSetToVarSet (freeVarsOf ann_e)-        , disjointVarSet fvs recursive_calls-        = go_exit captured (deAnnotate ann_e) fvs--    -- We could not turn it into a exit joint point. So now recurse-    -- into all expression where eligible exit join points might sit,-    -- i.e. into all tail-call positions:--    -- Case right hand sides are in tail-call position-    go captured (_, AnnCase scrut bndr ty alts) = do-        alts' <- forM alts $ \(dc, pats, rhs) -> do-            rhs' <- go (captured ++ [bndr] ++ pats) rhs-            return (dc, pats, rhs')-        return $ Case (deAnnotate scrut) bndr ty alts'--    go captured (_, AnnLet ann_bind body)-        -- join point, RHS and body are in tail-call position-        | AnnNonRec j rhs <- ann_bind-        , Just join_arity <- isJoinId_maybe j-        = do let (params, join_body) = collectNAnnBndrs join_arity rhs-             join_body' <- go (captured ++ params) join_body-             let rhs' = mkLams params join_body'-             body' <- go (captured ++ [j]) body-             return $ Let (NonRec j rhs') body'--        -- rec join point, RHSs and body are in tail-call position-        | AnnRec pairs <- ann_bind-        , isJoinId (fst (head pairs))-        = do let js = map fst pairs-             pairs' <- forM pairs $ \(j,rhs) -> do-                 let join_arity = idJoinArity j-                     (params, join_body) = collectNAnnBndrs join_arity rhs-                 join_body' <- go (captured ++ js ++ params) join_body-                 let rhs' = mkLams params join_body'-                 return (j, rhs')-             body' <- go (captured ++ js) body-             return $ Let (Rec pairs') body'--        -- normal Let, only the body is in tail-call position-        | otherwise-        = do body' <- go (captured ++ bindersOf bind ) body-             return $ Let bind body'-      where bind = deAnnBind ann_bind--    -- Cannot be turned into an exit join point, but also has no-    -- tail-call subexpression. Nothing to do here.-    go _ ann_e = return (deAnnotate ann_e)--    ----------------------    go_exit :: [Var]      -- Variables captured locally-            -> CoreExpr   -- An exit expression-            -> VarSet     -- Free vars of the expression-            -> ExitifyM CoreExpr-    -- go_exit deals with a tail expression that is floatable-    -- out as an exit point; that is, it mentions no recursive calls-    go_exit captured e fvs-      -- Do not touch an expression that is already a join jump where all arguments-      -- are captured variables. See Note [Idempotency]-      -- But _do_ float join jumps with interesting arguments.-      -- See Note [Jumps can be interesting]-      | (Var f, args) <- collectArgs e-      , isJoinId f-      , all isCapturedVarArg args-      = return e--      -- Do not touch a boring expression (see Note [Interesting expression])-      | not is_interesting-      = return e--      -- Cannot float out if local join points are used, as-      -- we cannot abstract over them-      | captures_join_points-      = return e--      -- We have something to float out!-      | otherwise-      = do { -- Assemble the RHS of the exit join point-             let rhs   = mkLams abs_vars e-                 avoid = in_scope `extendInScopeSetList` captured-             -- Remember this binding under a suitable name-           ; v <- addExit avoid (length abs_vars) rhs-             -- And jump to it from here-           ; return $ mkVarApps (Var v) abs_vars }--      where-        -- Used to detect exit expressions that are already proper exit jumps-        isCapturedVarArg (Var v) = v `elem` captured-        isCapturedVarArg _ = False--        -- An interesting exit expression has free, non-imported-        -- variables from outside the recursive group-        -- See Note [Interesting expression]-        is_interesting = anyVarSet isLocalId $-                         fvs `minusVarSet` mkVarSet captured--        -- The arguments of this exit join point-        -- See Note [Picking arguments to abstract over]-        abs_vars = snd $ foldr pick (fvs, []) captured-          where-            pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc)-                               | otherwise           = (fvs',               acc)--        -- We are going to abstract over these variables, so we must-        -- zap any IdInfo they have; see #15005-        -- cf. SetLevels.abstractVars-        zap v | isId v = setIdInfo v vanillaIdInfo-              | otherwise = v--        -- We cannot abstract over join points-        captures_join_points = any isJoinId abs_vars----- Picks a new unique, which is disjoint from---  * the free variables of the whole joinrec---  * any bound variables (captured)---  * any exit join points created so far.-mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId-mkExitJoinId in_scope ty join_arity = do-    fs <- get-    let avoid = in_scope `extendInScopeSetList` (map fst fs)-                         `extendInScopeSet` exit_id_tmpl -- just cosmetics-    return (uniqAway avoid exit_id_tmpl)-  where-    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty-                    `asJoinId` join_arity--addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId-addExit in_scope join_arity rhs = do-    -- Pick a suitable name-    let ty = exprType rhs-    v <- mkExitJoinId in_scope ty join_arity-    fs <- get-    put ((v,rhs):fs)-    return v--{--Note [Interesting expression]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do not want this to happen:--  joinrec go 0     x y = x-          go (n-1) x y = jump go (n-1) (x+y)-  in …-==>-  join exit x = x-  joinrec go 0     x y = jump exit x-          go (n-1) x y = jump go (n-1) (x+y)-  in …--because the floated exit path (`x`) is simply a parameter of `go`; there are-not useful interactions exposed this way.--Neither do we want this to happen--  joinrec go 0     x y = x+x-          go (n-1) x y = jump go (n-1) (x+y)-  in …-==>-  join exit x = x+x-  joinrec go 0     x y = jump exit x-          go (n-1) x y = jump go (n-1) (x+y)-  in …--where the floated expression `x+x` is a bit more complicated, but still not-intersting.--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])- * 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--So we only hoist an exit expression out if it mentiones at least one free,-non-imported variable.--Note [Jumps can be interesting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A jump to a join point can be interesting, if its arguments contain free-non-exported variables (z in the following example):--  joinrec go 0     x y = jump j (x+z)-          go (n-1) x y = jump go (n-1) (x+y)-  in …-==>-  join exit x y = jump j (x+z)-  joinrec go 0     x y = jump exit x-          go (n-1) x y = jump go (n-1) (x+y)---The join point itself can be interesting, even if none if its-arguments have free variables free in the joinrec.  For example--  join j p = case p of (x,y) -> x+y-  joinrec go 0     x y = jump j (x,y)-          go (n-1) x y = jump go (n-1) (x+y) y-  in …--Here, `j` would not be inlined because we do not inline something that looks-like an exit join point (see Note [Do not inline exit join points]). But-if we exitify the 'jump j (x,y)' we get--  join j p = case p of (x,y) -> x+y-  join exit x y = jump j (x,y)-  joinrec go 0     x y = jump exit x y-          go (n-1) x y = jump go (n-1) (x+y) y-  in …--and now 'j' can inline, and we get rid of the pair. Here's another-example (assume `g` to be an imported function that, on its own,-does not make this interesting):--  join j y = map f y-  joinrec go 0     x y = jump j (map g x)-          go (n-1) x y = jump go (n-1) (x+y)-  in …--Again, `j` would not be inlined because we do not inline something that looks-like an exit join point (see Note [Do not inline exit join points]).--But after exitification we have--  join j y = map f y-  join exit x = jump j (map g x)-  joinrec go 0     x y = jump j (map g x)-              go (n-1) x y = jump go (n-1) (x+y)-  in …--and now we can inline `j` and this will allow `map/map` to fire.---Note [Idempotency]-~~~~~~~~~~~~~~~~~~--We do not want this to happen, where we replace the floated expression with-essentially the same expression:--  join exit x = t (x*x)-  joinrec go 0     x y = jump exit x-          go (n-1) x y = jump go (n-1) (x+y)-  in …-==>-  join exit x = t (x*x)-  join exit' x = jump exit x-  joinrec go 0     x y = jump exit' x-          go (n-1) x y = jump go (n-1) (x+y)-  in …--So when the RHS is a join jump, and all of its arguments are captured variables,-then we leave it in place.--Note that `jump exit x` in this example looks interesting, as `exit` is a free-variable. Therefore, idempotency does not simply follow from floating only-interesting expressions.--Note [Calculating free variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have two options where to annotate the tree with free variables:-- A) The whole tree.- B) Each individual joinrec as we come across it.--Downside of A: We pay the price on the whole module, even outside any joinrecs.-Downside of B: We pay the price per joinrec, possibly multiple times when-joinrecs are nested.--Further downside of A: If the exitify function returns annotated expressions,-it would have to ensure that the annotations are correct.--We therefore choose B, and calculate the free variables in `exitify`.---Note [Do not inline exit join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have--  let t = foo bar-  join exit x = t (x*x)-  joinrec go 0     x y = jump exit x-          go (n-1) x y = jump go (n-1) (x+y)-  in …--we do not want the simplifier to simply inline `exit` back in (which it happily-would).--To prevent this, we need to recognize exit join points, and then disable-inlining.--Exit join points, recognizeable using `isExitJoinId` are join points with an-occurrence in a recursive group, and can be recognized (after the occurrence-analyzer ran!) using `isExitJoinId`.-This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`,-because the lambdas of a non-recursive join point are not considered for-`occ_in_lam`.  For example, in the following code, `j1` is /not/ marked-occ_in_lam, because `j2` is called only once.--  join j1 x = x+1-  join j2 y = join j1 (y+2)--To prevent inlining, we check for isExitJoinId-* In `preInlineUnconditionally` directly.-* In `simplLetUnfolding` we simply give exit join points no unfolding, which-  prevents inlining in `postInlineUnconditionally` and call sites.--Note [Placement of the exitification pass]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-I (Joachim) experimented with multiple positions for the Exitification pass in-the Core2Core pipeline:-- A) Before the `simpl_phases`- B) Between the `simpl_phases` and the "main" simplifier pass- C) After demand_analyser- D) Before the final simplification phase--Here is the table (this is without inlining join exit points in the final-simplifier run):--        Program |                       Allocs                      |                      Instrs-                | ABCD.log     A.log     B.log     C.log     D.log  | ABCD.log     A.log     B.log     C.log     D.log-----------------|---------------------------------------------------|-------------------------------------------------- fannkuch-redux |   -99.9%     +0.0%    -99.9%    -99.9%    -99.9%  |    -3.9%     +0.5%     -3.0%     -3.9%     -3.9%-          fasta |    -0.0%     +0.0%     +0.0%     -0.0%     -0.0%  |    -8.5%     +0.0%     +0.0%     -0.0%     -8.5%-            fem |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -2.2%     -0.1%     -0.1%     -2.1%     -2.1%-           fish |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -3.1%     +0.0%     -1.1%     -1.1%     -0.0%-   k-nucleotide |   -91.3%    -91.0%    -91.0%    -91.3%    -91.3%  |    -6.3%    +11.4%    +11.4%     -6.3%     -6.2%-            scs |    -0.0%     -0.0%     -0.0%     -0.0%     -0.0%  |    -3.4%     -3.0%     -3.1%     -3.3%     -3.3%-         simple |    -6.0%      0.0%     -6.0%     -6.0%     +0.0%  |    -3.4%     +0.0%     -5.2%     -3.4%     -0.1%-  spectral-norm |    -0.0%      0.0%      0.0%     -0.0%     +0.0%  |    -2.7%     +0.0%     -2.7%     -5.4%     -5.4%-----------------|---------------------------------------------------|--------------------------------------------------            Min |   -95.0%    -91.0%    -95.0%    -95.0%    -95.0%  |    -8.5%     -3.0%     -5.2%     -6.3%     -8.5%-            Max |    +0.2%     +0.2%     +0.2%     +0.2%     +1.5%  |    +0.4%    +11.4%    +11.4%     +0.4%     +1.5%- Geometric Mean |    -4.7%     -2.1%     -4.7%     -4.7%     -4.6%  |    -0.4%     +0.1%     -0.1%     -0.3%     -0.2%--Position A is disqualified, as it does not get rid of the allocations in-fannkuch-redux.-Position A and B are disqualified because it increases instructions in k-nucleotide.-Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta.--Assuming we have a budget of _one_ run of Exitification, then C wins (but we-could get more from running it multiple times, as seen in fish).--Note [Picking arguments to abstract over]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When we create an exit join point, so we need to abstract over those of its-free variables that are be out-of-scope at the destination of the exit join-point. So we go through the list `captured` and pick those that are actually-free variables of the join point.--We do not just `filter (`elemVarSet` fvs) captured`, as there might be-shadowing, and `captured` may contain multiple variables with the same Unique. I-these cases we want to abstract only over the last occurrence, hence the `foldr`-(with emphasis on the `r`). This is #15110.---}
− compiler/simplCore/FloatIn.hs 
@@ -1,772 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--************************************************************************-*                                                                      *-\section[FloatIn]{Floating Inwards pass}-*                                                                      *-************************************************************************--The main purpose of @floatInwards@ is floating into branches of a-case, so that we don't allocate things, save them on the stack, and-then discover that they aren't needed in the chosen branch.--}--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fprof-auto #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module FloatIn ( floatInwards ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Core-import GHC.Core.Make hiding ( wrapFloats )-import GHC.Driver.Types     ( ModGuts(..) )-import GHC.Core.Utils-import GHC.Core.FVs-import CoreMonad        ( CoreM )-import Id               ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )-import Var-import Type-import VarSet-import Util-import GHC.Driver.Session-import Outputable--- import Data.List        ( mapAccumL )-import BasicTypes       ( RecFlag(..), isRec )--{--Top-level interface function, @floatInwards@.  Note that we do not-actually float any bindings downwards from the top-level.--}--floatInwards :: ModGuts -> CoreM ModGuts-floatInwards pgm@(ModGuts { mg_binds = binds })-  = do { dflags <- getDynFlags-       ; return (pgm { mg_binds = map (fi_top_bind dflags) binds }) }-  where-    fi_top_bind dflags (NonRec binder rhs)-      = NonRec binder (fiExpr dflags [] (freeVars rhs))-    fi_top_bind dflags (Rec pairs)-      = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ]---{--************************************************************************-*                                                                      *-\subsection{Mail from Andr\'e [edited]}-*                                                                      *-************************************************************************--{\em Will wrote: What??? I thought the idea was to float as far-inwards as possible, no matter what.  This is dropping all bindings-every time it sees a lambda of any kind.  Help! }--You are assuming we DO DO full laziness AFTER floating inwards!  We-have to [not float inside lambdas] if we don't.--If we indeed do full laziness after the floating inwards (we could-check the compilation flags for that) then I agree we could be more-aggressive and do float inwards past lambdas.--Actually we are not doing a proper full laziness (see below), which-was another reason for not floating inwards past a lambda.--This can easily be fixed.  The problem is that we float lets outwards,-but there are a few expressions which are not let bound, like case-scrutinees and case alternatives.  After floating inwards the-simplifier could decide to inline the let and the laziness would be-lost, e.g.--\begin{verbatim}-let a = expensive             ==> \b -> case expensive of ...-in \ b -> case a of ...-\end{verbatim}-The fix is-\begin{enumerate}-\item-to let bind the algebraic case scrutinees (done, I think) and-the case alternatives (except the ones with an-unboxed type)(not done, I think). This is best done in the-SetLevels.hs module, which tags things with their level numbers.-\item-do the full laziness pass (floating lets outwards).-\item-simplify. The simplifier inlines the (trivial) lets that were- created but were not floated outwards.-\end{enumerate}--With the fix I think Will's suggestion that we can gain even more from-strictness by floating inwards past lambdas makes sense.--We still gain even without going past lambdas, as things may be-strict in the (new) context of a branch (where it was floated to) or-of a let rhs, e.g.-\begin{verbatim}-let a = something            case x of-in case x of                   alt1 -> case something of a -> a + a-     alt1 -> a + a      ==>    alt2 -> b-     alt2 -> b--let a = something           let b = case something of a -> a + a-in let b = a + a        ==> in (b,b)-in (b,b)-\end{verbatim}-Also, even if a is not found to be strict in the new context and is-still left as a let, if the branch is not taken (or b is not entered)-the closure for a is not built.--************************************************************************-*                                                                      *-\subsection{Main floating-inwards code}-*                                                                      *-************************************************************************--}--type FreeVarSet  = DIdSet-type BoundVarSet = DIdSet--data FloatInBind = FB BoundVarSet FreeVarSet FloatBind-        -- The FreeVarSet is the free variables of the binding.  In the case-        -- of recursive bindings, the set doesn't include the bound-        -- variables.--type FloatInBinds = [FloatInBind]-        -- In reverse dependency order (innermost binder first)--fiExpr :: DynFlags-       -> FloatInBinds      -- Binds we're trying to drop-                            -- as far "inwards" as possible-       -> CoreExprWithFVs   -- Input expr-       -> CoreExpr          -- Result--fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)-                                       -- See Note [Dead bindings]-fiExpr _ to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty-fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)-fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)-fiExpr dflags to_drop (_, AnnCast expr (co_ann, co))-  = wrapFloats (drop_here ++ co_drop) $-    Cast (fiExpr dflags e_drop expr) co-  where-    [drop_here, e_drop, co_drop]-      = sepBindsByDropPoint dflags False-          [freeVarsOf expr, freeVarsOfAnn co_ann]-          to_drop--{--Applications: we do float inside applications, mainly because we-need to get at all the arguments.  The next simplifier run will-pull out any silly ones.--}--fiExpr dflags to_drop ann_expr@(_,AnnApp {})-  = wrapFloats drop_here $ wrapFloats extra_drop $-    mkTicks ticks $-    mkApps (fiExpr dflags fun_drop ann_fun)-           (zipWith (fiExpr dflags) arg_drops ann_args)-  where-    (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr-    fun_ty  = exprType (deAnnotate ann_fun)-    fun_fvs = freeVarsOf ann_fun-    arg_fvs = map freeVarsOf ann_args--    (drop_here : extra_drop : fun_drop : arg_drops)-       = sepBindsByDropPoint dflags False-                             (extra_fvs : fun_fvs : arg_fvs)-                             to_drop-         -- Shortcut behaviour: if to_drop is empty,-         -- sepBindsByDropPoint returns a suitable bunch of empty-         -- lists without evaluating extra_fvs, and hence without-         -- peering into each argument--    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args-    extra_fvs0 = case ann_fun of-                   (_, AnnVar _) -> fun_fvs-                   _             -> emptyDVarSet-          -- Don't float the binding for f into f x y z; see Note [Join points]-          -- for why we *can't* do it when f is a join point. (If f isn't a-          -- join point, floating it in isn't especially harmful but it's-          -- useless since the simplifier will immediately float it back out.)--    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)-    add_arg (fun_ty, extra_fvs) (_, AnnType ty)-      = (piResultTy fun_ty ty, extra_fvs)--    add_arg (fun_ty, extra_fvs) (arg_fvs, arg)-      | noFloatIntoArg arg arg_ty-      = (res_ty, extra_fvs `unionDVarSet` arg_fvs)-      | otherwise-      = (res_ty, extra_fvs)-      where-       (arg_ty, res_ty) = splitFunTy fun_ty--{- Note [Dead bindings]-~~~~~~~~~~~~~~~~~~~~~~~-At a literal we won't usually have any floated bindings; the-only way that can happen is if the binding wrapped the literal-/in the original input program/.  e.g.-   case x of { DEFAULT -> 1# }-But, while this may be unusual it is not actually wrong, and it did-once happen (#15696).--Note [Do not destroy the let/app invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Watch out for-   f (x +# y)-We don't want to float bindings into here-   f (case ... of { x -> x +# y })-because that might destroy the let/app invariant, which requires-unlifted function arguments to be ok-for-speculation.--Note [Join points]-~~~~~~~~~~~~~~~~~~-Generally, we don't need to worry about join points - there are places we're-not allowed to float them, but since they can't have occurrences in those-places, we're not tempted.--We do need to be careful about jumps, however:--  joinrec j x y z = ... in-  jump j a b c--Previous versions often floated the definition of a recursive function into its-only non-recursive occurrence. But for a join point, this is a disaster:--  (joinrec j x y z = ... in-  jump j) a b c -- wrong!--Every jump must be exact, so the jump to j must have three arguments. Hence-we're careful not to float into the target of a jump (though we can float into-the arguments just fine).--Note [Floating in past a lambda group]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* We must be careful about floating inside a value lambda.-  That risks losing laziness.-  The float-out pass might rescue us, but then again it might not.--* We must be careful about type lambdas too.  At one time we did, and-  there is no risk of duplicating work thereby, but we do need to be-  careful.  In particular, here is a bad case (it happened in the-  cichelli benchmark:-        let v = ...-        in let f = /\t -> \a -> ...-           ==>-        let f = /\t -> let v = ... in \a -> ...-  This is bad as now f is an updatable closure (update PAP)-  and has arity 0.--* Hack alert!  We only float in through one-shot lambdas,-  not (as you might guess) through lone big lambdas.-  Reason: we float *out* past big lambdas (see the test in the Lam-  case of FloatOut.floatExpr) and we don't want to float straight-  back in again.--  It *is* important to float into one-shot lambdas, however;-  see the remarks with noFloatIntoRhs.--So we treat lambda in groups, using the following rule:-- Float in if (a) there is at least one Id,-         and (b) there are no non-one-shot Ids-- Otherwise drop all the bindings outside the group.--This is what the 'go' function in the AnnLam case is doing.--(Join points are handled similarly: a join point is considered one-shot iff-it's non-recursive, so we float only into non-recursive join points.)--Urk! if all are tyvars, and we don't float in, we may miss an-      opportunity to float inside a nested case branch---Note [Floating coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~-We could, in principle, have a coercion binding like-   case f x of co { DEFAULT -> e1 e2 }-It's not common to have a function that returns a coercion, but nothing-in Core prohibits it.  If so, 'co' might be mentioned in e1 or e2-/only in a type/.  E.g. suppose e1 was-  let (x :: Int |> co) = blah in blah2---But, with coercions appearing in types, there is a complication: we-might be floating in a "strict let" -- that is, a case. Case expressions-mention their return type. We absolutely can't float a coercion binding-inward to the point that the type of the expression it's about to wrap-mentions the coercion. So we include the union of the sets of free variables-of the types of all the drop points involved. If any of the floaters-bind a coercion variable mentioned in any of the types, that binder must-be dropped right away.---}--fiExpr dflags to_drop lam@(_, AnnLam _ _)-  | noFloatIntoLam bndrs       -- Dump it all here-     -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088-  = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body))--  | otherwise           -- Float inside-  = mkLams bndrs (fiExpr dflags to_drop body)--  where-    (bndrs, body) = collectAnnBndrs lam--{--We don't float lets inwards past an SCC.-        ToDo: keep info on current cc, and when passing-        one, if it is not the same, annotate all lets in binds with current-        cc, change current cc to the new one and float binds into expr.--}--fiExpr dflags to_drop (_, AnnTick tickish expr)-  | tickish `tickishScopesLike` SoftScope-  = Tick tickish (fiExpr dflags to_drop expr)--  | otherwise -- Wimp out for now - we could push values in-  = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr))--{--For @Lets@, the possible ``drop points'' for the \tr{to_drop}-bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,-or~(b2), in each of the RHSs of the pairs of a @Rec@.--Note that we do {\em weird things} with this let's binding.  Consider:-\begin{verbatim}-let-    w = ...-in {-    let v = ... w ...-    in ... v .. w ...-}-\end{verbatim}-Look at the inner \tr{let}.  As \tr{w} is used in both the bind and-body of the inner let, we could panic and leave \tr{w}'s binding where-it is.  But \tr{v} is floatable further into the body of the inner let, and-{\em then} \tr{w} will also be only in the body of that inner let.--So: rather than drop \tr{w}'s binding here, we add it onto the list of-things to drop in the outer let's body, and let nature take its-course.--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-again.  (It won't go inside the lambda else we risk losing work.)-In letrec, we need to be more careful still. We don't want to transform-        let x# = y# +# 1#-        in-        letrec f = \z. ...x#...f...-        in ...-into-        letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...-because now we can't float the let out again, because a letrec-can't have unboxed bindings.--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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  let x{rule mentioning y} = rhs in body-Here y is not free in rhs or body; but we still want to dump bindings-that bind y outside the let.  So we augment extra_fvs with the-idRuleAndUnfoldingVars of x.  No need for type variables, hence not using-idFreeVars.--}--fiExpr dflags to_drop (_,AnnLet bind body)-  = fiExpr dflags (after ++ new_float : before) body-           -- to_drop is in reverse dependency order-  where-    (before, new_float, after) = fiBind dflags to_drop bind body_fvs-    body_fvs    = freeVarsOf body--{- Note [Floating primops]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We try to float-in a case expression over an unlifted type.  The-motivating example was #5658: in particular, this change allows-array indexing operations, which have a single DEFAULT alternative-without any binders, to be floated inward.--SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed-scalars also need to be floated inward, but unpacks have a single non-DEFAULT-alternative that binds the elements of the tuple. We now therefore also support-floating in cases with a single alternative that may bind values.--But there are wrinkles--* Which unlifted cases do we float? See PrimOp.hs-  Note [PrimOp can_fail and has_side_effects] which explains:-   - We can float-in can_fail primops, but we can't float them out.-   - But we can float a has_side_effects primop, but NOT inside a lambda,-     so for now we don't float them at all.-  Hence exprOkForSideEffects--* Because we can float can-fail primops (array indexing, division) inwards-  but not outwards, we must be careful not to transform-     case a /# b of r -> f (F# r)-  ===>-    f (case a /# b of r -> F# r)-  because that creates a new thunk that wasn't there before.  And-  because it can't be floated out (can_fail), the thunk will stay-  there.  Disaster!  (This happened in nofib 'simple' and 'scs'.)--  Solution: only float cases into the branches of other cases, and-  not into the arguments of an application, or the RHS of a let. This-  is somewhat conservative, but it's simple.  And it still hits the-  cases like #5658.   This is implemented in sepBindsByJoinPoint;-  if is_case is False we dump all floating cases right here.--* #14511 is another example of why we want to restrict float-in-  of case-expressions.  Consider-     case indexArray# a n of (# r #) -> writeArray# ma i (f r)-  Now, floating that indexing operation into the (f r) thunk will-  not create any new thunks, but it will keep the array 'a' alive-  for much longer than the programmer expected.--  So again, not floating a case into a let or argument seems like-  the Right Thing--For @Case@, the possible drop points for the 'to_drop'-bindings are:-  (a) inside the scrutinee-  (b) inside one of the alternatives/default (default FVs always /first/!).---}--fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])-  | isUnliftedType (idType case_bndr)-  , exprOkForSideEffects (deAnnotate scrut)-      -- See Note [Floating primops]-  = wrapFloats shared_binds $-    fiExpr dflags (case_float : rhs_binds) rhs-  where-    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs-                    (FloatCase scrut' case_bndr con alt_bndrs)-    scrut'     = fiExpr dflags scrut_binds scrut-    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)-    scrut_fvs  = freeVarsOf scrut--    [shared_binds, scrut_binds, rhs_binds]-       = sepBindsByDropPoint dflags False-           [scrut_fvs, rhs_fvs]-           to_drop--fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)-  = wrapFloats drop_here1 $-    wrapFloats drop_here2 $-    Case (fiExpr dflags scrut_drops scrut) case_bndr ty-         (zipWith fi_alt alts_drops_s alts)-  where-        -- Float into the scrut and alts-considered-together just like App-    [drop_here1, scrut_drops, alts_drops]-       = sepBindsByDropPoint dflags False-           [scrut_fvs, all_alts_fvs]-           to_drop--        -- Float into the alts with the is_case flag set-    (drop_here2 : alts_drops_s)-      | [ _ ] <- alts = [] : [alts_drops]-      | otherwise     = sepBindsByDropPoint dflags True alts_fvs alts_drops--    scrut_fvs    = freeVarsOf scrut-    alts_fvs     = map alt_fvs alts-    all_alts_fvs = unionDVarSets alts_fvs-    alt_fvs (_con, args, rhs)-      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)-           -- Delete case_bndr and args from free vars of rhs-           -- to get free vars of alt--    fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs)---------------------fiBind :: DynFlags-       -> FloatInBinds      -- Binds we're trying to drop-                            -- as far "inwards" as possible-       -> CoreBindWithFVs   -- Input binding-       -> DVarSet           -- Free in scope of binding-       -> ( FloatInBinds    -- Land these before-          , FloatInBind     -- The binding itself-          , FloatInBinds)   -- Land these after--fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs-  = ( extra_binds ++ shared_binds          -- Land these before-                                           -- See Note [extra_fvs (1,2)]-    , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself-          (FloatLet (NonRec id rhs'))-    , body_binds )                         -- Land these after--  where-    body_fvs2 = body_fvs `delDVarSet` id--    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]-    extra_fvs | noFloatIntoRhs NonRecursive id rhs-              = rule_fvs `unionDVarSet` rhs_fvs-              | otherwise-              = rule_fvs-        -- See Note [extra_fvs (1): avoid floating into RHS]-        -- 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--    [shared_binds, extra_binds, rhs_binds, body_binds]-        = sepBindsByDropPoint dflags False-            [extra_fvs, rhs_fvs, body_fvs2]-            to_drop--        -- Push rhs_binds into the right hand side of the binding-    rhs'     = fiRhs dflags rhs_binds id ann_rhs-    rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs-                        -- Don't forget the rule_fvs; the binding mentions them!--fiBind dflags to_drop (AnnRec bindings) body_fvs-  = ( extra_binds ++ shared_binds-    , FB (mkDVarSet ids) rhs_fvs'-         (FloatLet (Rec (fi_bind rhss_binds bindings)))-    , body_binds )-  where-    (ids, rhss) = unzip bindings-    rhss_fvs = map freeVarsOf rhss--        -- See Note [extra_fvs (1,2)]-    rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids-    extra_fvs = rule_fvs `unionDVarSet`-                unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings-                              , noFloatIntoRhs Recursive bndr rhs ]--    (shared_binds:extra_binds:body_binds:rhss_binds)-        = sepBindsByDropPoint dflags False-            (extra_fvs:body_fvs:rhss_fvs)-            to_drop--    rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`-               unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`-               rule_fvs         -- Don't forget the rule variables!--    -- Push rhs_binds into the right hand side of the binding-    fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss-            -> [(Id, CoreExprWithFVs)]-            -> [(Id, CoreExpr)]--    fi_bind to_drops pairs-      = [ (binder, fiRhs dflags to_drop binder rhs)-        | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]---------------------fiRhs :: DynFlags -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr-fiRhs dflags to_drop bndr rhs-  | Just join_arity <- isJoinId_maybe bndr-  , let (bndrs, body) = collectNAnnBndrs join_arity rhs-  = mkLams bndrs (fiExpr dflags to_drop body)-  | otherwise-  = fiExpr dflags to_drop rhs---------------------noFloatIntoLam :: [Var] -> Bool-noFloatIntoLam bndrs = any bad bndrs-  where-    bad b = isId b && not (isOneShotBndr b)-    -- Don't float inside a non-one-shot lambda--noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool--- ^ True if it's a bad idea to float bindings into this RHS-noFloatIntoRhs is_rec bndr rhs-  | isJoinId bndr-  = isRec is_rec -- Joins are one-shot iff non-recursive--  | otherwise-  = noFloatIntoArg rhs (idType bndr)--noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool-noFloatIntoArg expr expr_ty-  | isUnliftedType expr_ty-  = True  -- See Note [Do not destroy the let/app invariant]--   | AnnLam bndr e <- expr-   , (bndrs, _) <- collectAnnBndrs e-   =  noFloatIntoLam (bndr:bndrs)  -- Wrinkle 1 (a)-   || all isTyVar (bndr:bndrs)     -- Wrinkle 1 (b)-      -- See Note [noFloatInto considerations] wrinkle 2--  | otherwise  -- Note [noFloatInto considerations] wrinkle 2-  = exprIsTrivial deann_expr || exprIsHNF deann_expr-  where-    deann_expr = deAnnotate' expr--{- Note [noFloatInto considerations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When do we want to float bindings into-   - noFloatIntoRHs: the RHS of a let-binding-   - noFloatIntoArg: the argument of a function application--Definitely don't float in if it has unlifted type; that-would destroy the let/app invariant.--* Wrinkle 1: do not float in if-     (a) any non-one-shot value lambdas-  or (b) all type lambdas-  In both cases we'll float straight back out again-  NB: Must line up with fiExpr (AnnLam...); see #7088--  (a) is important: we /must/ float into a one-shot lambda group-  (which includes join points). This makes a big difference-  for things like-     f x# = let x = I# x#-            in let j = \() -> ...x...-               in if <condition> then normal-path else j ()-  If x is used only in the error case join point, j, we must float the-  boxing constructor into it, else we box it every time which is very-  bad news indeed.--* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right-  back out again... not tragic, but a waste of time.--  For function arguments we will still end up with this-  in-then-out stuff; consider-    letrec x = e in f x-  Here x is not a HNF, so we'll produce-    f (letrec x = e in x)-  which is OK... it's not that common, and we'll end up-  floating out again, in CorePrep if not earlier.-  Still, we use exprIsTrivial to catch this case (sigh)---************************************************************************-*                                                                      *-\subsection{@sepBindsByDropPoint@}-*                                                                      *-************************************************************************--This is the crucial function.  The idea is: We have a wad of bindings-that we'd like to distribute inside a collection of {\em drop points};-insides the alternatives of a \tr{case} would be one example of some-drop points; the RHS and body of a non-recursive \tr{let} binding-would be another (2-element) collection.--So: We're given a list of sets-of-free-variables, one per drop point,-and a list of floating-inwards bindings.  If a binding can go into-only one drop point (without suddenly making something out-of-scope),-in it goes.  If a binding is used inside {\em multiple} drop points,-then it has to go in a you-must-drop-it-above-all-these-drop-points-point.--We have to maintain the order on these drop-point-related lists.--}---- pprFIB :: FloatInBinds -> SDoc--- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]--sepBindsByDropPoint-    :: DynFlags-    -> Bool                -- True <=> is case expression-    -> [FreeVarSet]        -- One set of FVs per drop point-                           -- Always at least two long!-    -> FloatInBinds        -- Candidate floaters-    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated-                           -- inside any drop point; the rest correspond-                           -- one-to-one with the input list of FV sets---- Every input floater is returned somewhere in the result;--- none are dropped, not even ones which don't seem to be--- free in *any* of the drop-point fvs.  Why?  Because, for example,--- a binding (let x = E in B) might have a specialised version of--- x (say x') stored inside x, but x' isn't free in E or B.--type DropBox = (FreeVarSet, FloatInBinds)--sepBindsByDropPoint dflags is_case drop_pts floaters-  | null floaters  -- Shortcut common case-  = [] : [[] | _ <- drop_pts]--  | otherwise-  = ASSERT( drop_pts `lengthAtLeast` 2 )-    go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))-  where-    n_alts = length drop_pts--    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]-        -- The *first* one in the argument list is the drop_here set-        -- The FloatInBinds in the lists are in the reverse of-        -- the normal FloatInBinds order; that is, they are the right way round!--    go [] drop_boxes = map (reverse . snd) drop_boxes--    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)-        = go binds new_boxes-        where-          -- "here" means the group of bindings dropped at the top of the fork--          (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs-                                        | (fvs, _) <- drop_boxes]--          drop_here = used_here || cant_push--          n_used_alts = count id used_in_flags -- returns number of Trues in list.--          cant_push-            | is_case   = n_used_alts == n_alts   -- Used in all, don't push-                                                  -- Remember n_alts > 1-                          || (n_used_alts > 1 && not (floatIsDupable dflags bind))-                             -- floatIsDupable: see Note [Duplicating floats]--            | otherwise = floatIsCase bind || n_used_alts > 1-                             -- floatIsCase: see Note [Floating primops]--          new_boxes | drop_here = (insert here_box : fork_boxes)-                    | otherwise = (here_box : new_fork_boxes)--          new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe-                                        fork_boxes used_in_flags--          insert :: DropBox -> DropBox-          insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops)--          insert_maybe box True  = insert box-          insert_maybe box False = box--    go _ _ = panic "sepBindsByDropPoint/go"---{- 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-     let x = I# y in-     case e of-       C -> error x-       D -> error x-       E -> ...not mentioning x...--If the thing is used in all RHSs there is nothing gained,-so we don't duplicate then.--}--floatedBindsFVs :: FloatInBinds -> FreeVarSet-floatedBindsFVs binds = mapUnionDVarSet fbFVs binds--fbFVs :: FloatInBind -> DVarSet-fbFVs (FB _ fvs _) = fvs--wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr--- Remember FloatInBinds is in *reverse* dependency order-wrapFloats []               e = e-wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)--floatIsDupable :: DynFlags -> FloatBind -> Bool-floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut-floatIsDupable dflags (FloatLet (Rec prs))    = all (exprIsDupable dflags . snd) prs-floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r--floatIsCase :: FloatBind -> Bool-floatIsCase (FloatCase {}) = True-floatIsCase (FloatLet {})  = False
− compiler/simplCore/FloatOut.hs 
@@ -1,757 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[FloatOut]{Float bindings outwards (towards the top level)}--``Long-distance'' floating of bindings towards the top level.--}--{-# LANGUAGE CPP #-}--module FloatOut ( floatOutwards ) where--import GhcPrelude--import GHC.Core-import GHC.Core.Utils-import GHC.Core.Make-import GHC.Core.Arity   ( etaExpand )-import CoreMonad        ( FloatOutSwitches(..) )--import GHC.Driver.Session-import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) )-import Id               ( Id, idArity, idType, isBottomingId,-                          isJoinId, isJoinId_maybe )-import SetLevels-import UniqSupply       ( UniqSupply )-import Bag-import Util-import Maybes-import Outputable-import Type-import qualified Data.IntMap as M--import Data.List        ( partition )--#include "HsVersions.h"--{--        ------------------        Overall game plan-        -------------------The Big Main Idea is:--        To float out sub-expressions that can thereby get outside-        a non-one-shot value lambda, and hence may be shared.---To achieve this we may need to do two things:--   a) Let-bind the sub-expression:--        f (g x)  ==>  let lvl = f (g x) in lvl--      Now we can float the binding for 'lvl'.--   b) More than that, we may need to abstract wrt a type variable--        \x -> ... /\a -> let v = ...a... in ....--      Here the binding for v mentions 'a' but not 'x'.  So we-      abstract wrt 'a', to give this binding for 'v':--            vp = /\a -> ...a...-            v  = vp a--      Now the binding for vp can float out unimpeded.-      I can't remember why this case seemed important enough to-      deal with, but I certainly found cases where important floats-      didn't happen if we did not abstract wrt tyvars.--With this in mind we can also achieve another goal: lambda lifting.-We can make an arbitrary (function) binding float to top level by-abstracting wrt *all* local variables, not just type variables, leaving-a binding that can be floated right to top level.  Whether or not this-happens is controlled by a flag.---Random comments-~~~~~~~~~~~~~~~--At the moment we never float a binding out to between two adjacent-lambdas.  For example:--@-        \x y -> let t = x+x in ...-===>-        \x -> let t = x+x in \y -> ...-@-Reason: this is less efficient in the case where the original lambda-is never partially applied.--But there's a case I've seen where this might not be true.  Consider:-@-elEm2 x ys-  = elem' x ys-  where-    elem' _ []  = False-    elem' x (y:ys)      = x==y || elem' x ys-@-It turns out that this generates a subexpression of the form-@-        \deq x ys -> let eq = eqFromEqDict deq in ...-@-which might usefully be separated to-@-        \deq -> let eq = eqFromEqDict deq in \xy -> ...-@-Well, maybe.  We don't do this at the moment.--Note [Join points]-~~~~~~~~~~~~~~~~~~-Every occurrence of a join point must be a tail call (see Note [Invariants on-join points] in GHC.Core), so we must be careful with how far we float them. The-mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling]-in SetLevels. For us, the significance is that a binder might be marked to be-dropped at the nearest boundary between tail calls and non-tail calls. For-example:--  (< join j = ... in-     let x = < ... > in-     case < ... > of-       A -> ...-       B -> ...-   >) < ... > < ... >--Here the join ceilings are marked with angle brackets. Either side of an-application is a join ceiling, as is the scrutinee position of a case-expression or the RHS of a let binding (but not a join point).--Why do we *want* do float join points at all? After all, they're never-allocated, so there's no sharing to be gained by floating them. However, the-other benefit of floating is making RHSes small, and this can have a significant-impact. In particular, stream fusion has been known to produce nested loops like-this:--  joinrec j1 x1 =-    joinrec j2 x2 =-      joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...-      in jump j3 x2-    in jump j2 x1-  in jump j1 x--(Assume x1 and x2 do *not* occur free in j3.)--Here j1 and j2 are wholly superfluous---each of them merely forwards its-argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make-everything one big mutual recursion:--  joinrec j1 x1 = jump j2 x1-          j2 x2 = jump j3 x2-          j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...-  in jump j1 x--Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.-Without floating, we're stuck with three loops instead of one.--************************************************************************-*                                                                      *-\subsection[floatOutwards]{@floatOutwards@: let-floating interface function}-*                                                                      *-************************************************************************--}--floatOutwards :: FloatOutSwitches-              -> DynFlags-              -> UniqSupply-              -> CoreProgram -> IO CoreProgram--floatOutwards float_sws dflags us pgm-  = do {-        let { annotated_w_levels = setLevels float_sws pgm us ;-              (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)-            } ;--        dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"-                  FormatCore-                  (vcat (map ppr annotated_w_levels));--        let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };--        dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"-                FormatText-                (hcat [ int tlets,  text " Lets floated to top level; ",-                        int ntlets, text " Lets floated elsewhere; from ",-                        int lams,   text " Lambda groups"]);--        return (bagToList (unionManyBags binds_s'))-    }--floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind)-floatTopBind bind-  = case (floatBind bind) of { (fs, floats, bind') ->-    let float_bag = flattenTopFloats floats-    in case bind' of-      -- bind' can't have unlifted values or join points, so can only be one-      -- value bind, rec or non-rec (see comment on floatBind)-      [Rec prs]    -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))-      [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e)-      _            -> pprPanic "floatTopBind" (ppr bind') }--{--************************************************************************-*                                                                      *-\subsection[FloatOut-Bind]{Floating in a binding (the business end)}-*                                                                      *-************************************************************************--}--floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind])-  -- Returns a list with either-  --   * A single non-recursive binding (value or join point), or-  --   * The following, in order:-  --     * Zero or more non-rec unlifted bindings-  --     * One or both of:-  --       * A recursive group of join binds-  --       * A recursive group of value binds-  -- See Note [Floating out of Rec rhss] for why things get arranged this way.-floatBind (NonRec (TB var _) rhs)-  = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') ->--        -- A tiresome hack:-        -- see Note [Bottoming floats: eta expansion] in SetLevels-    let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'-              | otherwise         = rhs'--    in (fs, rhs_floats, [NonRec var rhs'']) }--floatBind (Rec pairs)-  = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->-    let (new_ul_pairss, new_other_pairss) = unzip new_pairs-        (new_join_pairs, new_l_pairs)     = partition (isJoinId . fst)-                                                      (concat new_other_pairss)-        -- Can't put the join points and the values in the same rec group-        new_rec_binds | null new_join_pairs = [ Rec new_l_pairs    ]-                      | null new_l_pairs    = [ Rec new_join_pairs ]-                      | otherwise           = [ Rec new_l_pairs-                                              , Rec new_join_pairs ]-        new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ]-    in-    (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) }-  where-    do_pair :: (LevelledBndr, LevelledExpr)-            -> (FloatStats, FloatBinds,-                ([(Id,CoreExpr)],  -- Non-recursive unlifted value bindings-                 [(Id,CoreExpr)])) -- Join points and lifted value bindings-    do_pair (TB name spec, rhs)-      | isTopLvl dest_lvl  -- See Note [floatBind for top level]-      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->-        (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats)-                                                [(name, rhs')]))}-      | otherwise         -- Note [Floating out of Rec rhss]-      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->-        case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) ->-        case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) ->-        let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in-        (fs, rhs_floats', (ul_pairs, pairs')) }}}-      where-        dest_lvl = floatSpecLevel spec--splitRecFloats :: Bag FloatBind-               -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings-                   [(Id,CoreExpr)], -- Join points and lifted value bindings-                   Bag FloatBind)   -- A tail of further bindings--- The "tail" begins with a case--- See Note [Floating out of Rec rhss]-splitRecFloats fs-  = go [] [] (bagToList fs)-  where-    go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)-                                               , not (isJoinId b)-                                               = go ((b,r):ul_prs) prs fs-                                               | otherwise-                                               = go ul_prs ((b,r):prs) fs-    go ul_prs prs (FloatLet (Rec prs')   : fs) = go ul_prs (prs' ++ prs) fs-    go ul_prs prs fs                           = (reverse ul_prs, prs,-                                                  listToBag fs)-                                                   -- Order only matters for-                                                   -- non-rec--installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr--- Note [Floating out of Rec rhss]-installUnderLambdas floats e-  | isEmptyBag floats = e-  | otherwise         = go e-  where-    go (Lam b e)                 = Lam b (go e)-    go e                         = install floats e------------------floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])-floatList _ [] = (zeroStats, emptyFloats, [])-floatList f (a:as) = case f a            of { (fs_a,  binds_a,  b)  ->-                     case floatList f as of { (fs_as, binds_as, bs) ->-                     (fs_a `add_stats` fs_as, binds_a `plusFloats`  binds_as, b:bs) }}--{--Note [Floating out of Rec rhss]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider   Rec { f<1,0> = \xy. body }-From the body we may get some floats. The ones with level <1,0> must-stay here, since they may mention f.  Ideally we'd like to make them-part of the Rec block pairs -- but we can't if there are any-FloatCases involved.--Nor is it a good idea to dump them in the rhs, but outside the lambda-    f = case x of I# y -> \xy. body-because now f's arity might get worse, which is Not Good. (And if-there's an SCC around the RHS it might not get better again.-See #5342.)--So, gruesomely, we split the floats into- * the outer FloatLets, which can join the Rec, and- * an inner batch starting in a FloatCase, which are then-   pushed *inside* the lambdas.-This loses full-laziness the rare situation where there is a-FloatCase and a Rec interacting.--If there are unlifted FloatLets (that *aren't* join points) among the floats,-we can't add them to the recursive group without angering Core Lint, but since-they must be ok-for-speculation, they can't actually be making any recursive-calls, so we can safely pull them out and keep them non-recursive.--(Why is something getting floated to <1,0> that doesn't make a recursive call?-The case that came up in testing was that f *and* the unlifted binding were-getting floated *to the same place*:--  \x<2,0> ->-    ... <3,0>-    letrec { f<F<2,0>> =-      ... let x'<F<2,0>> = x +# 1# in ...-    } in ...--Everything gets labeled "float to <2,0>" because it all depends on x, but this-makes f and x' look mutually recursive when they're not.--The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the-wip/join-points branch.--TODO: This can probably be solved somehow in SetLevels. The difference between-"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very-important.)--Note [floatBind for top level]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus-         letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... }-The binding for bar will be in the "tops" part of the floating binds,-and thus not partioned by floatBody.--We could perhaps get rid of the 'tops' component of the floating binds,-but this case works just as well.---************************************************************************--\subsection[FloatOut-Expr]{Floating in expressions}-*                                                                      *-************************************************************************--}--floatBody :: Level-          -> LevelledExpr-          -> (FloatStats, FloatBinds, CoreExpr)--floatBody lvl arg       -- Used rec rhss, and case-alternative rhss-  = case (floatExpr arg) of { (fsa, floats, arg') ->-    case (partitionByLevel lvl floats) of { (floats', heres) ->-        -- Dump bindings are bound here-    (fsa, floats', install heres arg') }}---------------------{- Note [Floating past breakpoints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We used to disallow floating out of breakpoint ticks (see #10052). However, I-think this is too restrictive.--Consider the case of an expression scoped over by a breakpoint tick,--  tick<...> (let x = ... in f x)--In this case it is completely legal to float out x, despite the fact that-breakpoint ticks are scoped,--  let x = ... in (tick<...>  f x)--The reason here is that we know that the breakpoint will still be hit when the-expression is entered since the tick still scopes over the RHS.---}--floatExpr :: LevelledExpr-          -> (FloatStats, FloatBinds, CoreExpr)-floatExpr (Var v)   = (zeroStats, emptyFloats, Var v)-floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty)-floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co)-floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)--floatExpr (App e a)-  = case (atJoinCeiling $ floatExpr  e) of { (fse, floats_e, e') ->-    case (atJoinCeiling $ floatExpr  a) of { (fsa, floats_a, a') ->-    (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}--floatExpr lam@(Lam (TB _ lam_spec) _)-  = let (bndrs_w_lvls, body) = collectBinders lam-        bndrs                = [b | TB b _ <- bndrs_w_lvls]-        bndr_lvl             = asJoinCeilLvl (floatSpecLevel lam_spec)-        -- All the binders have the same level-        -- See SetLevels.lvlLamBndrs-        -- Use asJoinCeilLvl to make this the join ceiling-    in-    case (floatBody bndr_lvl body) of { (fs, floats, body') ->-    (add_to_stats fs floats, floats, mkLams bndrs body') }--floatExpr (Tick tickish expr)-  | tickish `tickishScopesLike` SoftScope -- not scoped, can just float-  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->-    (fs, floating_defns, Tick tickish expr') }--  | not (tickishCounts tickish) || tickishCanSplit tickish-  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->-    let -- Annotate bindings floated outwards past an scc expression-        -- with the cc.  We mark that cc as "duplicated", though.-        annotated_defns = wrapTick (mkNoCount tickish) floating_defns-    in-    (fs, annotated_defns, Tick tickish expr') }--  -- Note [Floating past breakpoints]-  | Breakpoint{} <- tickish-  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->-    (fs, floating_defns, Tick tickish expr') }--  | otherwise-  = pprPanic "floatExpr tick" (ppr tickish)--floatExpr (Cast expr co)-  = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->-    (fs, floating_defns, Cast expr' co) }--floatExpr (Let bind body)-  = case bind_spec of-      FloatMe dest_lvl-        -> case (floatBind bind) of { (fsb, bind_floats, binds') ->-           case (floatExpr body) of { (fse, body_floats, body') ->-           let new_bind_floats = foldr plusFloats emptyFloats-                                   (map (unitLetFloat dest_lvl) binds') in-           ( add_stats fsb fse-           , bind_floats `plusFloats` new_bind_floats-                         `plusFloats` body_floats-           , body') }}--      StayPut bind_lvl  -- See Note [Avoiding unnecessary floating]-        -> case (floatBind bind)          of { (fsb, bind_floats, binds') ->-           case (floatBody bind_lvl body) of { (fse, body_floats, body') ->-           ( add_stats fsb fse-           , bind_floats `plusFloats` body_floats-           , foldr Let body' binds' ) }}-  where-    bind_spec = case bind of-                 NonRec (TB _ s) _     -> s-                 Rec ((TB _ s, _) : _) -> s-                 Rec []                -> panic "floatExpr:rec"--floatExpr (Case scrut (TB case_bndr case_spec) ty alts)-  = case case_spec of-      FloatMe dest_lvl  -- Case expression moves-        | [(con@(DataAlt {}), bndrs, rhs)] <- alts-        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->-           case                 floatExpr rhs   of { (fsb, fdb, rhs') ->-           let-             float = unitCaseFloat dest_lvl scrut'-                          case_bndr con [b | TB b _ <- bndrs]-           in-           (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }}-        | otherwise-        -> pprPanic "Floating multi-case" (ppr alts)--      StayPut bind_lvl  -- Case expression stays put-        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->-           case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts')  ->-           (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')-           }}-  where-    float_alt bind_lvl (con, bs, rhs)-        = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->-          (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }--floatRhs :: CoreBndr-         -> LevelledExpr-         -> (FloatStats, FloatBinds, CoreExpr)-floatRhs bndr rhs-  | Just join_arity <- isJoinId_maybe bndr-  , Just (bndrs, body) <- try_collect join_arity rhs []-  = case bndrs of-      []                -> floatExpr rhs-      (TB _ lam_spec):_ ->-        let lvl = floatSpecLevel lam_spec in-        case floatBody lvl body of { (fs, floats, body') ->-        (fs, floats, mkLams [b | TB b _ <- bndrs] body') }-  | otherwise-  = atJoinCeiling $ floatExpr rhs-  where-    try_collect 0 expr      acc = Just (reverse acc, expr)-    try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc)-    try_collect _ _         _   = Nothing--{--Note [Avoiding unnecessary floating]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general we want to avoid floating a let unnecessarily, because-it might worsen strictness:-    let-       x = ...(let y = e in y+y)....-Here y is demanded.  If we float it outside the lazy 'x=..' then-we'd have to zap its demand info, and it may never be restored.--So at a 'let' we leave the binding right where the are unless-the binding will escape a value lambda, e.g.--(\x -> let y = fac 100 in y)--That's what the partitionByMajorLevel does in the floatExpr (Let ...)-case.--Notice, though, that we must take care to drop any bindings-from the body of the let that depend on the staying-put bindings.--We used instead to do the partitionByMajorLevel on the RHS of an '=',-in floatRhs.  But that was quite tiresome.  We needed to test for-values or trivial rhss, because (in particular) we don't want to insert-new bindings between the "=" and the "\".  E.g.-        f = \x -> let <bind> in <body>-We do not want-        f = let <bind> in \x -> <body>-(a) The simplifier will immediately float it further out, so we may-        as well do so right now; in general, keeping rhss as manifest-        values is good-(b) If a float-in pass follows immediately, it might add yet more-        bindings just after the '='.  And some of them might (correctly)-        be strict even though the 'let f' is lazy, because f, being a value,-        gets its demand-info zapped by the simplifier.-And even all that turned out to be very fragile, and broke-altogether when profiling got in the way.--So now we do the partition right at the (Let..) itself.--************************************************************************-*                                                                      *-\subsection{Utility bits for floating stats}-*                                                                      *-************************************************************************--I didn't implement this with unboxed numbers.  I don't want to be too-strict in this stuff, as it is rarely turned on.  (WDP 95/09)--}--data FloatStats-  = FlS Int  -- Number of top-floats * lambda groups they've been past-        Int  -- Number of non-top-floats * lambda groups they've been past-        Int  -- Number of lambda (groups) seen--get_stats :: FloatStats -> (Int, Int, Int)-get_stats (FlS a b c) = (a, b, c)--zeroStats :: FloatStats-zeroStats = FlS 0 0 0--sum_stats :: [FloatStats] -> FloatStats-sum_stats xs = foldr add_stats zeroStats xs--add_stats :: FloatStats -> FloatStats -> FloatStats-add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)-  = FlS (a1 + a2) (b1 + b2) (c1 + c2)--add_to_stats :: FloatStats -> FloatBinds -> FloatStats-add_to_stats (FlS a b c) (FB tops ceils others)-  = FlS (a + lengthBag tops)-        (b + lengthBag ceils + lengthBag (flattenMajor others))-        (c + 1)--{--************************************************************************-*                                                                      *-\subsection{Utility bits for floating}-*                                                                      *-************************************************************************--Note [Representation of FloatBinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The FloatBinds types is somewhat important.  We can get very large numbers-of floating bindings, often all destined for the top level.  A typical example-is     x = [4,2,5,2,5, .... ]-Then we get lots of small expressions like (fromInteger 4), which all get-lifted to top level.--The trouble is that-  (a) we partition these floating bindings *at every binding site*-  (b) SetLevels introduces a new bindings site for every float-So we had better not look at each binding at each binding site!--That is why MajorEnv is represented as a finite map.--We keep the bindings destined for the *top* level separate, because-we float them out even if they don't escape a *value* lambda; see-partitionByMajorLevel.--}--type FloatLet = CoreBind        -- INVARIANT: a FloatLet is always lifted-type MajorEnv = M.IntMap MinorEnv         -- Keyed by major level-type MinorEnv = M.IntMap (Bag FloatBind)  -- Keyed by minor level--data FloatBinds  = FB !(Bag FloatLet)           -- Destined for top level-                      !(Bag FloatBind)          -- Destined for join ceiling-                      !MajorEnv                 -- Other levels-     -- See Note [Representation of FloatBinds]--instance Outputable FloatBinds where-  ppr (FB fbs ceils defs)-      = text "FB" <+> (braces $ vcat-           [ text "tops ="     <+> ppr fbs-           , text "ceils ="    <+> ppr ceils-           , text "non-tops =" <+> ppr defs ])--flattenTopFloats :: FloatBinds -> Bag CoreBind-flattenTopFloats (FB tops ceils defs)-  = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )-    ASSERT2( isEmptyBag ceils, ppr ceils )-    tops--addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]-addTopFloatPairs float_bag prs-  = foldr add prs float_bag-  where-    add (NonRec b r) prs  = (b,r):prs-    add (Rec prs1)   prs2 = prs1 ++ prs2--flattenMajor :: MajorEnv -> Bag FloatBind-flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag--flattenMinor :: MinorEnv -> Bag FloatBind-flattenMinor = M.foldr unionBags emptyBag--emptyFloats :: FloatBinds-emptyFloats = FB emptyBag emptyBag M.empty--unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds-unitCaseFloat (Level major minor t) e b con bs-  | t == JoinCeilLvl-  = FB emptyBag floats M.empty-  | otherwise-  = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats))-  where-    floats = unitBag (FloatCase e b con bs)--unitLetFloat :: Level -> FloatLet -> FloatBinds-unitLetFloat lvl@(Level major minor t) b-  | isTopLvl lvl     = FB (unitBag b) emptyBag M.empty-  | t == JoinCeilLvl = FB emptyBag floats M.empty-  | otherwise        = FB emptyBag emptyBag (M.singleton major-                                              (M.singleton minor floats))-  where-    floats = unitBag (FloatLet b)--plusFloats :: FloatBinds -> FloatBinds -> FloatBinds-plusFloats (FB t1 c1 l1) (FB t2 c2 l2)-  = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)--plusMajor :: MajorEnv -> MajorEnv -> MajorEnv-plusMajor = M.unionWith plusMinor--plusMinor :: MinorEnv -> MinorEnv -> MinorEnv-plusMinor = M.unionWith unionBags--install :: Bag FloatBind -> CoreExpr -> CoreExpr-install defn_groups expr-  = foldr wrapFloat expr defn_groups--partitionByLevel-        :: Level                -- Partitioning level-        -> FloatBinds           -- Defns to be divided into 2 piles...-        -> (FloatBinds,         -- Defns  with level strictly < partition level,-            Bag FloatBind)      -- The rest--{----       ---- partitionByMajorLevel ------- Float it if we escape a value lambda,---     *or* if we get to the top level---     *or* if it's a case-float and its minor level is < current------ If we can get to the top level, say "yes" anyway. This means that---      x = f e--- transforms to---    lvl = e---    x = f lvl--- which is as it should be--partitionByMajorLevel (Level major _) (FB tops defns)-  = (FB tops outer, heres `unionBags` flattenMajor inner)-  where-    (outer, mb_heres, inner) = M.splitLookup major defns-    heres = case mb_heres of-               Nothing -> emptyBag-               Just h  -> flattenMinor h--}--partitionByLevel (Level major minor typ) (FB tops ceils defns)-  = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min),-     here_min `unionBags` here_ceil-              `unionBags` flattenMinor inner_min-              `unionBags` flattenMajor inner_maj)--  where-    (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns-    (outer_min, mb_here_min, inner_min) = case mb_here_maj of-                                            Nothing -> (M.empty, Nothing, M.empty)-                                            Just min_defns -> M.splitLookup minor min_defns-    here_min = mb_here_min `orElse` emptyBag-    (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag)-                        | otherwise          = (emptyBag, ceils)---- Like partitionByLevel, but instead split out the bindings that are marked--- to float to the nearest join ceiling (see Note [Join points])-partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind)-partitionAtJoinCeiling (FB tops ceils defs)-  = (FB tops emptyBag defs, ceils)---- Perform some action at a join ceiling, i.e., don't let join points float out--- (see Note [Join points])-atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr)-              -> (FloatStats, FloatBinds, CoreExpr)-atJoinCeiling (fs, floats, expr')-  = (fs, floats', install ceils expr')-  where-    (floats', ceils) = partitionAtJoinCeiling floats--wrapTick :: Tickish Id -> FloatBinds -> FloatBinds-wrapTick t (FB tops ceils defns)-  = FB (mapBag wrap_bind tops) (wrap_defns ceils)-       (M.map (M.map wrap_defns) defns)-  where-    wrap_defns = mapBag wrap_one--    wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)-    wrap_bind (Rec pairs)         = Rec (mapSnd maybe_tick pairs)--    wrap_one (FloatLet bind)      = FloatLet (wrap_bind bind)-    wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs--    maybe_tick e | exprIsHNF e = tickHNFArgs t e-                 | otherwise   = mkTick t e-      -- we don't need to wrap a tick around an HNF when we float it-      -- outside a tick: that is an invariant of the tick semantics-      -- Conversely, inlining of HNFs inside an SCC is allowed, and-      -- indeed the HNF we're floating here might well be inlined back-      -- again, and we don't want to end up with duplicate ticks.
− compiler/simplCore/LiberateCase.hs 
@@ -1,442 +0,0 @@-{--(c) The AQUA Project, Glasgow University, 1994-1998--\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}--}--{-# LANGUAGE CPP #-}-module LiberateCase ( liberateCase ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Driver.Session-import GHC.Core-import GHC.Core.Unfold  ( couldBeSmallEnoughToInline )-import TysWiredIn       ( unitDataConId )-import Id-import VarEnv-import Util             ( notNull )--{--The liberate-case transformation-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This module walks over @Core@, and looks for @case@ on free variables.-The criterion is:-        if there is case on a free on the route to the recursive call,-        then the recursive call is replaced with an unfolding.--Example--   f = \ t -> case v of-                 V a b -> a : f t--=> the inner f is replaced.--   f = \ t -> case v of-                 V a b -> a : (letrec-                                f =  \ t -> case v of-                                               V a b -> a : f t-                               in f) t-(note the NEED for shadowing)--=> Simplify--  f = \ t -> case v of-                 V a b -> a : (letrec-                                f = \ t -> a : f t-                               in f t)--Better code, because 'a' is  free inside the inner letrec, rather-than needing projection from v.--Note that this deals with *free variables*.  SpecConstr deals with-*arguments* that are of known form.  E.g.--        last []     = error-        last (x:[]) = x-        last (x:xs) = last xs---Note [Scrutinee with cast]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:-    f = \ t -> case (v `cast` co) of-                 V a b -> a : f t--Exactly the same optimisation (unrolling one call to f) will work here,-despite the cast.  See mk_alt_env in the Case branch of libCase.---To think about (Apr 94)-~~~~~~~~~~~~~~-Main worry: duplicating code excessively.  At the moment we duplicate-the entire binding group once at each recursive call.  But there may-be a group of recursive calls which share a common set of evaluated-free variables, in which case the duplication is a plain waste.--Another thing we could consider adding is some unfold-threshold thing,-so that we'll only duplicate if the size of the group rhss isn't too-big.--Data types-~~~~~~~~~~-The ``level'' of a binder tells how many-recursive defns lexically enclose the binding-A recursive defn "encloses" its RHS, not its-scope.  For example:-\begin{verbatim}-        letrec f = let g = ... in ...-        in-        let h = ...-        in ...-\end{verbatim}-Here, the level of @f@ is zero, the level of @g@ is one,-and the level of @h@ is zero (NB not one).---************************************************************************-*                                                                      *-         Top-level code-*                                                                      *-************************************************************************--}--liberateCase :: DynFlags -> CoreProgram -> CoreProgram-liberateCase dflags binds = do_prog (initEnv dflags) binds-  where-    do_prog _   [] = []-    do_prog env (bind:binds) = bind' : do_prog env' binds-                             where-                               (env', bind') = libCaseBind env bind--{--************************************************************************-*                                                                      *-         Main payload-*                                                                      *-************************************************************************--Bindings-~~~~~~~~--}--libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)--libCaseBind env (NonRec binder rhs)-  = (addBinders env [binder], NonRec binder (libCase env rhs))--libCaseBind env (Rec pairs)-  = (env_body, Rec pairs')-  where-    binders = map fst pairs--    env_body = addBinders env binders--    pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]--        -- We extend the rec-env by binding each Id to its rhs, first-        -- processing the rhs with an *un-extended* environment, so-        -- that the same process doesn't occur for ever!-    env_rhs | is_dupable_bind = addRecBinds env dup_pairs-            | otherwise       = env--    dup_pairs = [ (localiseId binder, libCase env_body rhs)-                | (binder, rhs) <- pairs ]-        -- localiseID : see Note [Need to localiseId in libCaseBind]--    is_dupable_bind = small_enough && all ok_pair pairs--    -- Size: we are going to duplicate dup_pairs; to find their-    --       size, build a fake binding (let { dup_pairs } in (),-    --       and find the size of that-    -- See Note [Small enough]-    small_enough = case bombOutSize env of-                      Nothing   -> True   -- Infinity-                      Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $-                                   Let (Rec dup_pairs) (Var unitDataConId)--    ok_pair (id,_)-        =  idArity id > 0          -- Note [Only functions!]-        && not (isBottomingId id)  -- Note [Not bottoming ids]--{- Note [Not bottoming Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do not specialise error-functions (this is unusual, but I once saw it,-(actually in Data.Typable.Internal)--Note [Only functions!]-~~~~~~~~~~~~~~~~~~~~~~-Consider the following code--       f = g (case v of V a b -> a : t f)--where g is expensive. If we aren't careful, liberate case will turn this into--       f = g (case v of-               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)-                                in f)-             )--Yikes! We evaluate g twice. This leads to a O(2^n) explosion-if g calls back to the same code recursively.--Solution: make sure that we only do the liberate-case thing on *functions*--Note [Small enough]-~~~~~~~~~~~~~~~~~~~-Consider-  \fv. letrec-         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...-         g = \y. SMALL...f...--Then we *can* in principle do liberate-case on 'g' (small RHS) but not-for 'f' (too big).  But doing so is not profitable, because duplicating-'g' at its call site in 'f' doesn't get rid of any cases.  So we just-ask for the whole group to be small enough.--Note [Need to localiseId in libCaseBind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The call to localiseId is needed for two subtle reasons-(a)  Reset the export flags on the binders so-        that we don't get name clashes on exported things if the-        local binding floats out to top level.  This is most unlikely-        to happen, since the whole point concerns free variables.-        But resetting the export flag is right regardless.--(b)  Make the name an Internal one.  External Names should never be-        nested; if it were floated to the top level, we'd get a name-        clash at code generation time.--Expressions-~~~~~~~~~~~--}--libCase :: LibCaseEnv-        -> CoreExpr-        -> CoreExpr--libCase env (Var v)             = libCaseApp env v []-libCase _   (Lit lit)           = Lit lit-libCase _   (Type ty)           = Type ty-libCase _   (Coercion co)       = Coercion co-libCase env e@(App {})          | let (fun, args) = collectArgs e-                                , Var v <- fun-                                = libCaseApp env v args-libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)-libCase env (Tick tickish body) = Tick tickish (libCase env body)-libCase env (Cast e co)         = Cast (libCase env e) co--libCase env (Lam binder body)-  = Lam binder (libCase (addBinders env [binder]) body)--libCase env (Let bind body)-  = Let bind' (libCase env_body body)-  where-    (env_body, bind') = libCaseBind env bind--libCase env (Case scrut bndr ty alts)-  = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)-  where-    env_alts = addBinders (mk_alt_env scrut) [bndr]-    mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var-    mk_alt_env (Cast scrut _)  = mk_alt_env scrut       -- Note [Scrutinee with cast]-    mk_alt_env _               = env--libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)-                         -> (AltCon, [CoreBndr], CoreExpr)-libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)--{--Ids-~~~--To unfold, we can't just wrap the id itself in its binding if it's a join point:--  jump j a b c  =>  (joinrec j x y z = ... in jump j) a b c -- wrong!!!--Every jump must provide all arguments, so we have to be careful to wrap the-whole jump instead:--  jump j a b c  =>  joinrec j x y z = ... in jump j a b c -- right---}--libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr-libCaseApp env v args-  | Just the_bind <- lookupRecId env v  -- It's a use of a recursive thing-  , notNull free_scruts                 -- with free vars scrutinised in RHS-  = Let the_bind expr'--  | otherwise-  = expr'--  where-    rec_id_level = lookupLevel env v-    free_scruts  = freeScruts env rec_id_level-    expr'        = mkApps (Var v) (map (libCase env) args)--freeScruts :: LibCaseEnv-           -> LibCaseLevel      -- Level of the recursive Id-           -> [Id]              -- Ids that are scrutinised between the binding-                                -- of the recursive Id and here-freeScruts env rec_bind_lvl-  = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env-       , scrut_bind_lvl <= rec_bind_lvl-       , scrut_at_lvl > rec_bind_lvl]-        -- Note [When to specialise]-        -- Note [Avoiding fruitless liberate-case]--{--Note [When to specialise]-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f = \x. letrec g = \y. case x of-                           True  -> ... (f a) ...-                           False -> ... (g b) ...--We get the following levels-          f  0-          x  1-          g  1-          y  2--Then 'x' is being scrutinised at a deeper level than its binding, so-it's added to lc_sruts:  [(x,1)]--We do *not* want to specialise the call to 'f', because 'x' is not free-in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).--We *do* want to specialise the call to 'g', because 'x' is free in g.-Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).--Note [Avoiding fruitless liberate-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider also:-  f = \x. case top_lvl_thing of-                I# _ -> let g = \y. ... g ...-                        in ...--Here, top_lvl_thing is scrutinised at a level (1) deeper than its-binding site (0).  Nevertheless, we do NOT want to specialise the call-to 'g' because all the structure in its free variables is already-visible at the definition site for g.  Hence, when considering specialising-an occurrence of 'g', we want to check that there's a scruted-var v st--   a) v's binding site is *outside* g-   b) v's scrutinisation site is *inside* g---************************************************************************-*                                                                      *-        Utility functions-*                                                                      *-************************************************************************--}--addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv-addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders-  = env { lc_lvl_env = lvl_env' }-  where-    lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)--addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv-addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env,-                             lc_rec_env = rec_env}) pairs-  = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' }-  where-    lvl'     = lvl + 1-    lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]-    rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]--addScrutedVar :: LibCaseEnv-              -> Id             -- This Id is being scrutinised by a case expression-              -> LibCaseEnv--addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,-                                lc_scruts = scruts }) scrut_var-  | bind_lvl < lvl-  = env { lc_scruts = scruts' }-        -- Add to scruts iff the scrut_var is being scrutinised at-        -- a deeper level than its defn--  | otherwise = env-  where-    scruts'  = (scrut_var, bind_lvl, lvl) : scruts-    bind_lvl = case lookupVarEnv lvl_env scrut_var of-                 Just lvl -> lvl-                 Nothing  -> topLevel--lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind-lookupRecId env id = lookupVarEnv (lc_rec_env env) id--lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel-lookupLevel env id-  = case lookupVarEnv (lc_lvl_env env) id of-      Just lvl -> lvl-      Nothing  -> topLevel--{--************************************************************************-*                                                                      *-         The environment-*                                                                      *-************************************************************************--}--type LibCaseLevel = Int--topLevel :: LibCaseLevel-topLevel = 0--data LibCaseEnv-  = LibCaseEnv {-        lc_dflags :: DynFlags,--        lc_lvl :: LibCaseLevel, -- Current level-                -- The level is incremented when (and only when) going-                -- inside the RHS of a (sufficiently small) recursive-                -- function.--        lc_lvl_env :: IdEnv LibCaseLevel,-                -- Binds all non-top-level in-scope Ids (top-level and-                -- imported things have a level of zero)--        lc_rec_env :: IdEnv CoreBind,-                -- Binds *only* recursively defined ids, to their own-                -- binding group, and *only* in their own RHSs--        lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]-                -- Each of these Ids was scrutinised by an enclosing-                -- case expression, at a level deeper than its binding-                -- level.-                ---                -- The first LibCaseLevel is the *binding level* of-                --   the scrutinised Id,-                -- The second is the level *at which it was scrutinised*.-                --   (see Note [Avoiding fruitless liberate-case])-                -- The former is a bit redundant, since you could always-                -- look it up in lc_lvl_env, but it's just cached here-                ---                -- The order is insignificant; it's a bag really-                ---                -- There's one element per scrutinisation;-                --    in principle the same Id may appear multiple times,-                --    although that'd be unusual:-                --       case x of { (a,b) -> ....(case x of ...) .. }-        }--initEnv :: DynFlags -> LibCaseEnv-initEnv dflags-  = LibCaseEnv { lc_dflags = dflags,-                 lc_lvl = 0,-                 lc_lvl_env = emptyVarEnv,-                 lc_rec_env = emptyVarEnv,-                 lc_scruts = [] }---- Bomb-out size for deciding if--- potential liberatees are too big.--- (passed in from cmd-line args)-bombOutSize :: LibCaseEnv -> Maybe Int-bombOutSize = liberateCaseThreshold . lc_dflags
− compiler/simplCore/SAT.hs 
@@ -1,433 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---************************************************************************--               Static Argument Transformation pass--************************************************************************--May be seen as removing invariants from loops:-Arguments of recursive functions that do not change in recursive-calls are removed from the recursion, which is done locally-and only passes the arguments which effectively change.--Example:-map = /\ ab -> \f -> \xs -> case xs of-                 []       -> []-                 (a:b) -> f a : map f b--as map is recursively called with the same argument f (unmodified)-we transform it to--map = /\ ab -> \f -> \xs -> let map' ys = case ys of-                       []     -> []-                       (a:b) -> f a : map' b-                in map' xs--Notice that for a compiler that uses lambda lifting this is-useless as map' will be transformed back to what map was.--We could possibly do the same for big lambdas, but we don't as-they will eventually be removed in later stages of the compiler,-therefore there is no penalty in keeping them.--We only apply the SAT when the number of static args is > 2. This-produces few bad cases.  See-                should_transform-in saTransform.--Here are the headline nofib results:-                  Size    Allocs   Runtime-Min             +0.0%    -13.7%    -21.4%-Max             +0.1%     +0.0%     +5.4%-Geometric Mean  +0.0%     -0.2%     -6.9%--The previous patch, to fix polymorphic floatout demand signatures, is-essential to make this work well!--}--{-# LANGUAGE CPP #-}-module SAT ( doStaticArgs ) where--import GhcPrelude--import Var-import GHC.Core-import GHC.Core.Utils-import Type-import Coercion-import Id-import Name-import VarEnv-import UniqSupply-import Util-import UniqFM-import VarSet-import Unique-import UniqSet-import Outputable--import Data.List (mapAccumL)-import FastString--#include "HsVersions.h"--doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram-doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds-  where-    sat_bind_threaded_us us bind =-        let (us1, us2) = splitUniqSupply us-        in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet))---- We don't bother to SAT recursive groups since it can lead--- to massive code expansion: see Andre Santos' thesis for details.--- This means we only apply the actual SAT to Rec groups of one element,--- but we want to recurse into the others anyway to discover other binds-satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)-satBind (NonRec binder expr) interesting_ids = do-    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids-    return (NonRec binder expr', finalizeApp expr_app sat_info_expr)-satBind (Rec [(binder, rhs)]) interesting_ids = do-    let interesting_ids' = interesting_ids `addOneToUniqSet` binder-        (rhs_binders, rhs_body) = collectBinders rhs-    (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids'-    let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders)-        sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body--        shadowing = binder `elementOfUniqSet` interesting_ids-        sat_info_rhs'' = if shadowing-                        then sat_info_rhs' `delFromUFM` binder -- For safety-                        else sat_info_rhs'--    bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder)-                              rhs_binders rhs_body'-    return (bind', sat_info_rhs'')-satBind (Rec pairs) interesting_ids = do-    let (binders, rhss) = unzip pairs-    rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss-    let (rhss', sat_info_rhss') = unzip rhss_SATed-    return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')--data App = VarApp Id | TypeApp Type | CoApp Coercion-data Staticness a = Static a | NotStatic--type IdAppInfo = (Id, SATInfo)--type SATInfo = [Staticness App]-type IdSATInfo = IdEnv SATInfo-emptyIdSATInfo :: IdSATInfo-emptyIdSATInfo = emptyUFM--{--pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info))-  where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info)--}--pprSATInfo :: SATInfo -> SDoc-pprSATInfo staticness = hcat $ map pprStaticness staticness--pprStaticness :: Staticness App -> SDoc-pprStaticness (Static (VarApp _))  = text "SV"-pprStaticness (Static (TypeApp _)) = text "ST"-pprStaticness (Static (CoApp _))   = text "SC"-pprStaticness NotStatic            = text "NS"---mergeSATInfo :: SATInfo -> SATInfo -> SATInfo-mergeSATInfo l r = zipWith mergeSA l r-  where-    mergeSA NotStatic _ = NotStatic-    mergeSA _ NotStatic = NotStatic-    mergeSA (Static (VarApp v)) (Static (VarApp v'))-      | v == v'   = Static (VarApp v)-      | otherwise = NotStatic-    mergeSA (Static (TypeApp t)) (Static (TypeApp t'))-      | t `eqType` t' = Static (TypeApp t)-      | otherwise     = NotStatic-    mergeSA (Static (CoApp c)) (Static (CoApp c'))-      | c `eqCoercion` c' = Static (CoApp c)-      | otherwise             = NotStatic-    mergeSA _ _  = pprPanic "mergeSATInfo" $-                          text "Left:"-                       <> pprSATInfo l <> text ", "-                       <> text "Right:"-                       <> pprSATInfo r--mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo-mergeIdSATInfo = plusUFM_C mergeSATInfo--mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo-mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo--bindersToSATInfo :: [Id] -> SATInfo-bindersToSATInfo vs = map (Static . binderToApp) vs-    where binderToApp v | isId v    = VarApp v-                        | isTyVar v = TypeApp $ mkTyVarTy v-                        | otherwise = CoApp $ mkCoVarCo v--finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo-finalizeApp Nothing id_sat_info = id_sat_info-finalizeApp (Just (v, sat_info')) id_sat_info =-    let sat_info'' = case lookupUFM id_sat_info v of-                        Nothing -> sat_info'-                        Just sat_info -> mergeSATInfo sat_info sat_info'-    in extendVarEnv id_sat_info v sat_info''--satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)-satTopLevelExpr expr interesting_ids = do-    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids-    return (expr', finalizeApp expr_app sat_info_expr)--satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)-satExpr var@(Var v) interesting_ids = do-    let app_info = if v `elementOfUniqSet` interesting_ids-                   then Just (v, [])-                   else Nothing-    return (var, emptyIdSATInfo, app_info)--satExpr lit@(Lit _) _ = do-    return (lit, emptyIdSATInfo, Nothing)--satExpr (Lam binders body) interesting_ids = do-    (body', sat_info, this_app) <- satExpr body interesting_ids-    return (Lam binders body', finalizeApp this_app sat_info, Nothing)--satExpr (App fn arg) interesting_ids = do-    (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids-    let satRemainder = boring fn' sat_info_fn-    case fn_app of-        Nothing -> satRemainder Nothing-        Just (fn_id, fn_app_info) ->-            -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)-            let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])-            in case arg of-                Type t     -> satRemainderWithStaticness $ Static (TypeApp t)-                Coercion c -> satRemainderWithStaticness $ Static (CoApp c)-                Var v      -> satRemainderWithStaticness $ Static (VarApp v)-                _          -> satRemainderWithStaticness $ NotStatic-  where-    boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)-    boring fn' sat_info_fn app_info =-        do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids-           let sat_info_arg' = finalizeApp arg_app sat_info_arg-               sat_info = mergeIdSATInfo sat_info_fn sat_info_arg'-           return (App fn' arg', sat_info, app_info)--satExpr (Case expr bndr ty alts) interesting_ids = do-    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids-    let sat_info_expr' = finalizeApp expr_app sat_info_expr--    zipped_alts' <- mapM satAlt alts-    let (alts', sat_infos_alts) = unzip zipped_alts'-    return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing)-  where-    satAlt (con, bndrs, expr) = do-        (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids-        return ((con, bndrs, expr'), sat_info_expr)--satExpr (Let bind body) interesting_ids = do-    (body', sat_info_body, body_app) <- satExpr body interesting_ids-    (bind', sat_info_bind) <- satBind bind interesting_ids-    return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app)--satExpr (Tick tickish expr) interesting_ids = do-    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids-    return (Tick tickish expr', sat_info_expr, expr_app)--satExpr ty@(Type _) _ = do-    return (ty, emptyIdSATInfo, Nothing)--satExpr co@(Coercion _) _ = do-    return (co, emptyIdSATInfo, Nothing)--satExpr (Cast expr coercion) interesting_ids = do-    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids-    return (Cast expr' coercion, sat_info_expr, expr_app)--{--************************************************************************--                Static Argument Transformation Monad--************************************************************************--}--type SatM result = UniqSM result--runSAT :: UniqSupply -> SatM a -> a-runSAT = initUs_--newUnique :: SatM Unique-newUnique = getUniqueM--{--************************************************************************--                Static Argument Transformation Monad--************************************************************************--To do the transformation, the game plan is to:--1. Create a small nonrecursive RHS that takes the-   original arguments to the function but discards-   the ones that are static and makes a call to the-   SATed version with the remainder. We intend that-   this will be inlined later, removing the overhead--2. Bind this nonrecursive RHS over the original body-   WITH THE SAME UNIQUE as the original body so that-   any recursive calls to the original now go via-   the small wrapper--3. Rebind the original function to a new one which contains-   our SATed function and just makes a call to it:-   we call the thing making this call the local body--Example: transform this--    map :: forall a b. (a->b) -> [a] -> [b]-    map = /\ab. \(f:a->b) (as:[a]) -> body[map]-to-    map :: forall a b. (a->b) -> [a] -> [b]-    map = /\ab. \(f:a->b) (as:[a]) ->-         letrec map' :: [a] -> [b]-                    -- The "worker function-                map' = \(as:[a]) ->-                         let map :: forall a' b'. (a -> b) -> [a] -> [b]-                                -- The "shadow function-                             map = /\a'b'. \(f':(a->b) (as:[a]).-                                   map' as-                         in body[map]-         in map' as--Note [Shadow binding]-~~~~~~~~~~~~~~~~~~~~~-The calls to the inner map inside body[map] should get inlined-by the local re-binding of 'map'.  We call this the "shadow binding".--But we can't use the original binder 'map' unchanged, because-it might be exported, in which case the shadow binding won't be-discarded as dead code after it is inlined.--So we use a hack: we make a new SysLocal binder with the *same* unique-as binder.  (Another alternative would be to reset the export flag.)--Note [Binder type capture]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Notice that in the inner map (the "shadow function"), the static arguments-are discarded -- it's as if they were underscores.  Instead, mentions-of these arguments (notably in the types of dynamic arguments) are bound-by the *outer* lambdas of the main function.  So we must make up fresh-names for the static arguments so that they do not capture variables-mentioned in the types of dynamic args.--In the map example, the shadow function must clone the static type-argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a'-is bound by the outer forall.  We clone f' too for consistency, but-that doesn't matter either way because static Id arguments aren't-mentioned in the shadow binding at all.--If we don't we get something like this:--[Exported]-[Arity 3]-GHC.Base.until =-  \ (@ a_aiK)-    (p_a6T :: a_aiK -> GHC.Types.Bool)-    (f_a6V :: a_aiK -> a_aiK)-    (x_a6X :: a_aiK) ->-    letrec {-      sat_worker_s1aU :: a_aiK -> a_aiK-      []-      sat_worker_s1aU =-        \ (x_a6X :: a_aiK) ->-          let {-            sat_shadow_r17 :: forall a_a3O.-                              (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O-            []-            sat_shadow_r17 =-              \ (@ a_aiK)-                (p_a6T :: a_aiK -> GHC.Types.Bool)-                (f_a6V :: a_aiK -> a_aiK)-                (x_a6X :: a_aiK) ->-                sat_worker_s1aU x_a6X } in-          case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] {-            GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X);-            GHC.Types.True -> x_a6X-          }; } in-    sat_worker_s1aU x_a6X--Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK-type argument. This is bad because it means the application sat_worker_s1aU x_a6X-is not well typed.--}--saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind-saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body-  | Just arg_staticness <- maybe_arg_staticness-  , should_transform arg_staticness-  = saTransform binder arg_staticness rhs_binders rhs_body-  | otherwise-  = return (Rec [(binder, mkLams rhs_binders rhs_body)])-  where-    should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT-      where-        n_static_args = count isStaticValue staticness--saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind-saTransform binder arg_staticness rhs_binders rhs_body-  = do  { shadow_lam_bndrs <- mapM clone binders_w_staticness-        ; uniq             <- newUnique-        ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) }-  where-    -- Running example: foldr-    -- foldr \alpha \beta c n xs = e, for some e-    -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic]-    -- rhs_binders = [\alpha, \beta, c, n, xs]-    -- rhs_body = e--    binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic)-                                        -- Any extra args are assumed NotStatic--    non_static_args :: [Var]-            -- non_static_args = [xs]-            -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs]-    non_static_args = [v | (v, NotStatic) <- binders_w_staticness]--    clone (bndr, NotStatic) = return bndr-    clone (bndr, _        ) = do { uniq <- newUnique-                                 ; return (setVarUnique bndr uniq) }--    -- new_rhs = \alpha beta c n xs ->-    --           let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs ->-    --                                       sat_worker xs-    --                                   in e-    --           in sat_worker xs-    mk_new_rhs uniq shadow_lam_bndrs-        = mkLams rhs_binders $-          Let (Rec [(rec_body_bndr, rec_body)])-          local_body-        where-          local_body = mkVarApps (Var rec_body_bndr) non_static_args--          rec_body = mkLams non_static_args $-                     Let (NonRec shadow_bndr shadow_rhs) rhs_body--            -- See Note [Binder type capture]-          shadow_rhs = mkLams shadow_lam_bndrs local_body-            -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs--          rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body)-            -- rec_body_bndr = sat_worker--            -- See Note [Shadow binding]; make a SysLocal-          shadow_bndr = mkSysLocal (occNameFS (getOccName binder))-                                   (idUnique binder)-                                   (exprType shadow_rhs)--isStaticValue :: Staticness App -> Bool-isStaticValue (Static (VarApp _)) = True-isStaticValue _                   = False
− compiler/simplCore/SetLevels.hs 
@@ -1,1771 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section{SetLevels}--                ***************************-                        Overview-                ***************************--1. We attach binding levels to Core bindings, in preparation for floating-   outwards (@FloatOut@).--2. We also let-ify many expressions (notably case scrutinees), so they-   will have a fighting chance of being floated sensible.--3. Note [Need for cloning during float-out]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   We clone the binders of any floatable let-binding, so that when it is-   floated out it will be unique. Example-      (let x=2 in x) + (let x=3 in x)-   we must clone before floating so we get-      let x1=2 in-      let x2=3 in-      x1+x2--   NOTE: this can't be done using the uniqAway idea, because the variable-         must be unique in the whole program, not just its current scope,-         because two variables in different scopes may float out to the-         same top level place--   NOTE: Very tiresomely, we must apply this substitution to-         the rules stored inside a variable too.--   We do *not* clone top-level bindings, because some of them must not change,-   but we *do* clone bindings that are heading for the top level--4. Note [Binder-swap during float-out]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   In the expression-        case x of wild { p -> ...wild... }-   we substitute x for wild in the RHS of the case alternatives:-        case x of wild { p -> ...x... }-   This means that a sub-expression involving x is not "trapped" inside the RHS.-   And it's not inconvenient because we already have a substitution.--  Note that this is EXACTLY BACKWARDS from the what the simplifier does.-  The simplifier tries to get rid of occurrences of x, in favour of wild,-  in the hope that there will only be one remaining occurrence of x, namely-  the scrutinee of the case, and we can inline it.--}--{-# LANGUAGE CPP, MultiWayIf #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-module SetLevels (-        setLevels,--        Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,-        LevelledBind, LevelledExpr, LevelledBndr,-        FloatSpec(..), floatSpecLevel,--        incMinorLvl, ltMajLvl, ltLvl, isTopLvl-    ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Core-import CoreMonad        ( FloatOutSwitches(..) )-import GHC.Core.Utils   ( exprType, exprIsHNF-                        , exprOkForSpeculation-                        , exprIsTopLevelBindable-                        , isExprLevPoly-                        , collectMakeStaticArgs-                        )-import GHC.Core.Arity   ( exprBotStrictness_maybe )-import GHC.Core.FVs     -- all of it-import GHC.Core.Subst-import GHC.Core.Make    ( sortQuantVars )--import Id-import IdInfo-import Var-import VarSet-import UniqSet          ( nonDetFoldUniqSet )-import UniqDSet         ( getUniqDSet )-import VarEnv-import Literal          ( litIsTrivial )-import Demand           ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )-import Cpr              ( mkCprSig, botCpr )-import Name             ( getOccName, mkSystemVarName )-import OccName          ( occNameString )-import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType-                        , mightBeUnliftedType, closeOverKindsDSet )-import BasicTypes       ( Arity, RecFlag(..), isRec )-import DataCon          ( dataConOrigResTy )-import TysWiredIn-import UniqSupply-import Util-import Outputable-import FastString-import UniqDFM-import FV-import Data.Maybe-import MonadUtils       ( mapAccumLM )--{--************************************************************************-*                                                                      *-\subsection{Level numbers}-*                                                                      *-************************************************************************--}--type LevelledExpr = TaggedExpr FloatSpec-type LevelledBind = TaggedBind FloatSpec-type LevelledBndr = TaggedBndr FloatSpec--data Level = Level Int  -- Level number of enclosing lambdas-                   Int  -- Number of big-lambda and/or case expressions and/or-                        -- context boundaries between-                        -- here and the nearest enclosing lambda-                   LevelType -- Binder or join ceiling?-data LevelType = BndrLvl | JoinCeilLvl deriving (Eq)--data FloatSpec-  = FloatMe Level       -- Float to just inside the binding-                        --    tagged with this level-  | StayPut Level       -- Stay where it is; binding is-                        --     tagged with this level--floatSpecLevel :: FloatSpec -> Level-floatSpecLevel (FloatMe l) = l-floatSpecLevel (StayPut l) = l--{--The {\em level number} on a (type-)lambda-bound variable is the-nesting depth of the (type-)lambda which binds it.  The outermost lambda-has level 1, so (Level 0 0) means that the variable is bound outside any lambda.--On an expression, it's the maximum level number of its free-(type-)variables.  On a let(rec)-bound variable, it's the level of its-RHS.  On a case-bound variable, it's the number of enclosing lambdas.--Top-level variables: level~0.  Those bound on the RHS of a top-level-definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown-as ``subscripts'')...-\begin{verbatim}-a_0 = let  b_? = ...  in-           x_1 = ... b ... in ...-\end{verbatim}--The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@).-That's meant to be the level number of the enclosing binder in the-final (floated) program.  If the level number of a sub-expression is-less than that of the context, then it might be worth let-binding the-sub-expression so that it will indeed float.--If you can float to level @Level 0 0@ worth doing so because then your-allocation becomes static instead of dynamic.  We always start with-context @Level 0 0@.---Note [FloatOut inside INLINE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:-to say "don't float anything out of here".  That's exactly what we-want for the body of an INLINE, where we don't want to float anything-out at all.  See notes with lvlMFE below.--But, check this out:---- At one time I tried the effect of not floating anything out of an InlineMe,--- but it sometimes works badly.  For example, consider PrelArr.done.  It--- has the form         __inline (\d. e)--- where e doesn't mention d.  If we float this to---      __inline (let x = e in \d. x)--- things are bad.  The inliner doesn't even inline it because it doesn't look--- like a head-normal form.  So it seems a lesser evil to let things float.--- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe--- which discourages floating out.--So the conclusion is: don't do any floating at all inside an InlineMe.-(In the above example, don't float the {x=e} out of the \d.)--One particular case is that of workers: we don't want to float the-call to the worker outside the wrapper, otherwise the worker might get-inlined into the floated expression, and an importing module won't see-the worker at all.--Note [Join ceiling]-~~~~~~~~~~~~~~~~~~~-Join points can't float very far; too far, and they can't remain join points-So, suppose we have:--  f x = (joinrec j y = ... x ... in jump j x) + 1--One may be tempted to float j out to the top of f's RHS, but then the jump-would not be a tail call. Thus we keep track of a level called the *join-ceiling* past which join points are not allowed to float.--The troublesome thing is that, unlike most levels to which something might-float, there is not necessarily an identifier to which the join ceiling is-attached. Fortunately, if something is to be floated to a join ceiling, it must-be dropped at the *nearest* join ceiling. Thus each level is marked as to-whether it is a join ceiling, so that FloatOut can tell which binders are being-floated to the nearest join ceiling and which to a particular binder (or set of-binders).--}--instance Outputable FloatSpec where-  ppr (FloatMe l) = char 'F' <> ppr l-  ppr (StayPut l) = ppr l--tOP_LEVEL :: Level-tOP_LEVEL   = Level 0 0 BndrLvl--incMajorLvl :: Level -> Level-incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl--incMinorLvl :: Level -> Level-incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl--asJoinCeilLvl :: Level -> Level-asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl--maxLvl :: Level -> Level -> Level-maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)-  | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1-  | otherwise                                      = l2--ltLvl :: Level -> Level -> Bool-ltLvl (Level maj1 min1 _) (Level maj2 min2 _)-  = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)--ltMajLvl :: Level -> Level -> Bool-    -- Tells if one level belongs to a difft *lambda* level to another-ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2--isTopLvl :: Level -> Bool-isTopLvl (Level 0 0 _) = True-isTopLvl _             = False--isJoinCeilLvl :: Level -> Bool-isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl--instance Outputable Level where-  ppr (Level maj min typ)-    = hcat [ char '<', int maj, char ',', int min, char '>'-           , ppWhen (typ == JoinCeilLvl) (char 'C') ]--instance Eq Level where-  (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2--{--************************************************************************-*                                                                      *-\subsection{Main level-setting code}-*                                                                      *-************************************************************************--}--setLevels :: FloatOutSwitches-          -> CoreProgram-          -> UniqSupply-          -> [LevelledBind]--setLevels float_lams binds us-  = initLvl us (do_them init_env binds)-  where-    init_env = initialEnv float_lams--    do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]-    do_them _ [] = return []-    do_them env (b:bs)-      = do { (lvld_bind, env') <- lvlTopBind env b-           ; lvld_binds <- do_them env' bs-           ; return (lvld_bind : lvld_binds) }--lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)-lvlTopBind env (NonRec bndr rhs)-  = do { rhs' <- lvl_top env NonRecursive bndr rhs-       ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]-       ; return (NonRec bndr' rhs', env') }--lvlTopBind env (Rec pairs)-  = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL-                                               (map fst pairs)-       ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs-       ; return (Rec (bndrs' `zip` rhss'), env') }--lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr-lvl_top env is_rec bndr rhs-  = lvlRhs env is_rec-           (isBottomingId bndr)-           Nothing  -- Not a join point-           (freeVars rhs)--{--************************************************************************-*                                                                      *-\subsection{Setting expression levels}-*                                                                      *-************************************************************************--Note [Floating over-saturated applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we see (f x y), and (f x) is a redex (ie f's arity is 1),-we call (f x) an "over-saturated application"--Should we float out an over-sat app, if can escape a value lambda?-It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).-But we don't want to do it for class selectors, because the work saved-is minimal, and the extra local thunks allocated cost money.--Arguably we could float even class-op applications if they were going to-top level -- but then they must be applied to a constant dictionary and-will almost certainly be optimised away anyway.--}--lvlExpr :: LevelEnv             -- Context-        -> CoreExprWithFVs      -- Input expression-        -> LvlM LevelledExpr    -- Result expression--{--The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing-binder.  Here's an example--        v = \x -> ...\y -> let r = case (..x..) of-                                        ..x..-                           in ..--When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's-the level of @r@, even though it's inside a level-2 @\y@.  It's-important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we-don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE---- because it isn't a *maximal* free expression.--If there were another lambda in @r@'s rhs, it would get level-2 as well.--}--lvlExpr env (_, AnnType ty)     = return (Type (GHC.Core.Subst.substTy (le_subst env) ty))-lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))-lvlExpr env (_, AnnVar v)       = return (lookupVar env v)-lvlExpr _   (_, AnnLit lit)     = return (Lit lit)--lvlExpr env (_, AnnCast expr (_, co)) = do-    expr' <- lvlNonTailExpr env expr-    return (Cast expr' (substCo (le_subst env) co))--lvlExpr env (_, AnnTick tickish expr) = do-    expr' <- lvlNonTailExpr env expr-    let tickish' = substTickish (le_subst env) tickish-    return (Tick tickish' expr')--lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr)---- We don't split adjacent lambdas.  That is, given---      \x y -> (x+1,y)--- we don't float to give---      \x -> let v = x+1 in \y -> (v,y)--- Why not?  Because partial applications are fairly rare, and splitting--- lambdas makes them more expensive.--lvlExpr env expr@(_, AnnLam {})-  = do { new_body <- lvlNonTailMFE new_env True body-       ; return (mkLams new_bndrs new_body) }-  where-    (bndrs, body)        = collectAnnBndrs expr-    (env1, bndrs1)       = substBndrsSL NonRecursive env bndrs-    (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1-        -- At one time we called a special version of collectBinders,-        -- which ignored coercions, because we don't want to split-        -- a lambda like this (\x -> coerce t (\s -> ...))-        -- This used to happen quite a bit in state-transformer programs,-        -- but not nearly so much now non-recursive newtypes are transparent.-        -- [See SetLevels rev 1.50 for a version with this approach.]--lvlExpr env (_, AnnLet bind body)-  = do { (bind', new_env) <- lvlBind env bind-       ; body' <- lvlExpr new_env body-           -- No point in going via lvlMFE here.  If the binding is alive-           -- (mentioned in body), and the whole let-expression doesn't-           -- float, then neither will the body-       ; return (Let bind' body') }--lvlExpr env (_, AnnCase scrut case_bndr ty alts)-  = do { scrut' <- lvlNonTailMFE env True scrut-       ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }--lvlNonTailExpr :: LevelEnv             -- Context-               -> CoreExprWithFVs      -- Input expression-               -> LvlM LevelledExpr    -- Result expression-lvlNonTailExpr env expr-  = lvlExpr (placeJoinCeiling env) expr----------------------------------------------lvlApp :: LevelEnv-       -> CoreExprWithFVs-       -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application-        -> LvlM LevelledExpr                   -- Result expression-lvlApp env orig_expr ((_,AnnVar fn), args)-  | floatOverSat env   -- See Note [Floating over-saturated applications]-  , arity > 0-  , arity < n_val_args-  , Nothing <- isClassOpId_maybe fn-  =  do { rargs' <- mapM (lvlNonTailMFE env False) rargs-        ; lapp'  <- lvlNonTailMFE env False lapp-        ; return (foldl' App lapp' rargs') }--  | otherwise-  = do { (_, args') <- mapAccumLM lvl_arg stricts args-            -- Take account of argument strictness; see-            -- Note [Floating to the top]-       ; return (foldl' App (lookupVar env fn) args') }-  where-    n_val_args = count (isValArg . deAnnotate) args-    arity      = idArity fn--    stricts :: [Demand]   -- True for strict /value/ arguments-    stricts = case splitStrictSig (idStrictness fn) of-                (arg_ds, _) | arg_ds `lengthExceeds` n_val_args-                            -> []-                            | otherwise-                            -> arg_ds--    -- Separate out the PAP that we are floating from the extra-    -- arguments, by traversing the spine until we have collected-    -- (n_val_args - arity) value arguments.-    (lapp, rargs) = left (n_val_args - arity) orig_expr []--    left 0 e               rargs = (e, rargs)-    left n (_, AnnApp f a) rargs-       | isValArg (deAnnotate a) = left (n-1) f (a:rargs)-       | otherwise               = left n     f (a:rargs)-    left _ _ _                   = panic "SetLevels.lvlExpr.left"--    is_val_arg :: CoreExprWithFVs -> Bool-    is_val_arg (_, AnnType {}) = False-    is_val_arg _               = True--    lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)-    lvl_arg strs arg | (str1 : strs') <- strs-                     , is_val_arg arg-                     = do { arg' <- lvlMFE env (isStrictDmd str1) arg-                          ; return (strs', arg') }-                     | otherwise-                     = do { arg' <- lvlMFE env False arg-                          ; return (strs, arg') }--lvlApp env _ (fun, args)-  =  -- No PAPs that we can float: just carry on with the-     -- arguments and the function.-     do { args' <- mapM (lvlNonTailMFE env False) args-        ; fun'  <- lvlNonTailExpr env fun-        ; return (foldl' App fun' args') }----------------------------------------------lvlCase :: LevelEnv             -- Level of in-scope names/tyvars-        -> DVarSet              -- Free vars of input scrutinee-        -> LevelledExpr         -- Processed scrutinee-        -> Id -> Type           -- Case binder and result type-        -> [CoreAltWithFVs]     -- Input alternatives-        -> LvlM LevelledExpr    -- Result expression-lvlCase env scrut_fvs scrut' case_bndr ty alts-  -- See Note [Floating single-alternative cases]-  | [(con@(DataAlt {}), bs, body)] <- alts-  , exprIsHNF (deTagExpr scrut')  -- See Note [Check the output scrutinee for exprIsHNF]-  , not (isTopLvl dest_lvl)       -- Can't have top-level cases-  , not (floatTopLvlOnly env)     -- Can float anywhere-  =     -- Always float the case if possible-        -- Unlike lets we don't insist that it escapes a value lambda-    do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)-       ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'-       ; body' <- lvlMFE rhs_env True body-       ; let alt' = (con, map (stayPut dest_lvl) bs', body')-       ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }--  | otherwise     -- Stays put-  = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]-             alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'-       ; alts' <- mapM (lvl_alt alts_env) alts-       ; return (Case scrut' case_bndr' ty' alts') }-  where-    ty' = substTy (le_subst env) ty--    incd_lvl = incMinorLvl (le_ctxt_lvl env)-    dest_lvl = maxFvLevel (const True) env scrut_fvs-            -- Don't abstract over type variables, hence const True--    lvl_alt alts_env (con, bs, rhs)-      = do { rhs' <- lvlMFE new_env True rhs-           ; return (con, bs', rhs') }-      where-        (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs--{- Note [Floating single-alternative cases]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:-  data T a = MkT !a-  f :: T Int -> blah-  f x vs = case x of { MkT y ->-             let f vs = ...(case y of I# w -> e)...f..-             in f vs--Here we can float the (case y ...) out, because y is sure-to be evaluated, to give-  f x vs = case x of { MkT y ->-           case y of I# w ->-             let f vs = ...(e)...f..-             in f vs--That saves unboxing it every time round the loop.  It's important in-some DPH stuff where we really want to avoid that repeated unboxing in-the inner loop.--Things to note:-- * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation.--     - exrpIsHNF catches the key case of an evaluated variable--     - exprOkForSpeculation is /false/ of an evaluated variable;-       See Note [exprOkForSpeculation and evaluated variables] in GHC.Core.Utils-       So we'd actually miss the key case!--     - Nothing is gained from the extra generality of exprOkForSpeculation-       since we only consider floating a case whose single alternative-       is a DataAlt   K a b -> rhs-- * We can't float a case to top level-- * It's worth doing this float even if we don't float-   the case outside a value lambda.  Example-     case x of {-       MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)-   If we floated the cases out we could eliminate one of them.-- * We only do this with a single-alternative case---Note [Setting levels when floating single-alternative cases]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Handling level-setting when floating a single-alternative case binding-is a bit subtle, as evidenced by #16978.  In particular, we must keep-in mind that we are merely moving the case and its binders, not the-body. For example, suppose 'a' is known to be evaluated and we have--  \z -> case a of-          (x,_) -> <body involving x and z>--After floating we may have:--  case a of-    (x,_) -> \z -> <body involving x and z>-      {- some expression involving x and z -}--When analysing <body involving...> we want to use the /ambient/ level,-and /not/ the destination level of the 'case a of (x,-) ->' binding.--#16978 was caused by us setting the context level to the destination-level of `x` when analysing <body>. This led us to conclude that we-needed to quantify over some of its free variables (e.g. z), resulting-in shadowing and very confusing Core Lint failures.---Note [Check the output scrutinee for exprIsHNF]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:-  case x of y {-    A -> ....(case y of alts)....-  }--Because of the binder-swap, the inner case will get substituted to-(case x of ..).  So when testing whether the scrutinee is in HNF we-must be careful to test the *result* scrutinee ('x' in this case), not-the *input* one 'y'.  The latter *is* in HNF here (because y is-evaluated), but the former is not -- and indeed we can't float the-inner case out, at least not unless x is also evaluated at its binding-site.  See #5453.--That's why we apply exprIsHNF to scrut' and not to scrut.--See Note [Floating single-alternative cases] for why-we use exprIsHNF in the first place.--}--lvlNonTailMFE :: LevelEnv             -- Level of in-scope names/tyvars-              -> Bool                 -- True <=> strict context [body of case-                                      --   or let]-              -> CoreExprWithFVs      -- input expression-              -> LvlM LevelledExpr    -- Result expression-lvlNonTailMFE env strict_ctxt ann_expr-  = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr--lvlMFE ::  LevelEnv             -- Level of in-scope names/tyvars-        -> Bool                 -- True <=> strict context [body of case or let]-        -> CoreExprWithFVs      -- input expression-        -> LvlM LevelledExpr    -- Result expression--- lvlMFE is just like lvlExpr, except that it might let-bind--- the expression, so that it can itself be floated.--lvlMFE env _ (_, AnnType ty)-  = return (Type (GHC.Core.Subst.substTy (le_subst env) ty))---- No point in floating out an expression wrapped in a coercion or note--- If we do we'll transform  lvl = e |> co---                       to  lvl' = e; lvl = lvl' |> co--- and then inline lvl.  Better just to float out the payload.-lvlMFE env strict_ctxt (_, AnnTick t e)-  = do { e' <- lvlMFE env strict_ctxt e-       ; let t' = substTickish (le_subst env) t-       ; return (Tick t' e') }--lvlMFE env strict_ctxt (_, AnnCast e (_, co))-  = do  { e' <- lvlMFE env strict_ctxt e-        ; return (Cast e' (substCo (le_subst env) co)) }--lvlMFE env strict_ctxt e@(_, AnnCase {})-  | strict_ctxt       -- Don't share cases in a strict context-  = lvlExpr env e     -- See Note [Case MFEs]--lvlMFE env strict_ctxt ann_expr-  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)-         -- Only floating to the top level is allowed.-  || anyDVarSet isJoinId fvs   -- If there is a free join, don't float-                               -- See Note [Free join points]-  || isExprLevPoly expr-         -- We can't let-bind levity polymorphic expressions-         -- See Note [Levity polymorphism invariants] in GHC.Core-  || notWorthFloating expr abs_vars-  || not float_me-  =     -- Don't float it out-    lvlExpr env ann_expr--  |  float_is_new_lam || exprIsTopLevelBindable expr expr_ty-         -- No wrapping needed if the type is lifted, or is a literal string-         -- or if we are wrapping it in one or more value lambdas-  = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive-                              (isJust mb_bot_str)-                              join_arity_maybe-                              ann_expr-                  -- Treat the expr just like a right-hand side-       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static-       ; let var2 = annotateBotStr var float_n_lams mb_bot_str-       ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)-                     (mkVarApps (Var var2) abs_vars)) }--  -- OK, so the float has an unlifted type (not top-level bindable)-  --     and no new value lambdas (float_is_new_lam is False)-  -- Try for the boxing strategy-  -- See Note [Floating MFEs of unlifted type]-  | escapes_value_lam-  , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions-                         -- See Note [Test cheapness with exprOkForSpeculation]-  , Just (tc, _) <- splitTyConApp_maybe expr_ty-  , Just dc <- boxingDataCon_maybe tc-  , let dc_res_ty = dataConOrigResTy dc  -- No free type variables-        [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty]-  = do { expr1 <- lvlExpr rhs_env ann_expr-       ; let l1r       = incMinorLvlFrom rhs_env-             float_rhs = mkLams abs_vars_w_lvls $-                         Case expr1 (stayPut l1r ubx_bndr) dc_res_ty-                             [(DEFAULT, [], mkConApp dc [Var ubx_bndr])]--       ; var <- newLvlVar float_rhs Nothing is_mk_static-       ; let l1u      = incMinorLvlFrom env-             use_expr = Case (mkVarApps (Var var) abs_vars)-                             (stayPut l1u bx_bndr) expr_ty-                             [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)]-       ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)-                     use_expr) }--  | otherwise          -- e.g. do not float unboxed tuples-  = lvlExpr env ann_expr--  where-    expr         = deAnnotate ann_expr-    expr_ty      = exprType expr-    fvs          = freeVarsOf ann_expr-    fvs_ty       = tyCoVarsOfType expr_ty-    is_bot       = isBottomThunk mb_bot_str-    is_function  = isFunction ann_expr-    mb_bot_str   = exprBotStrictness_maybe expr-                           -- See Note [Bottoming floats]-                           -- esp Bottoming floats (2)-    expr_ok_for_spec = exprOkForSpeculation expr-    dest_lvl     = destLevel env fvs fvs_ty is_function is_bot False-    abs_vars     = abstractVars dest_lvl env fvs--    -- float_is_new_lam: the floated thing will be a new value lambda-    -- replacing, say (g (x+4)) by (lvl x).  No work is saved, nor is-    -- allocation saved.  The benefit is to get it to the top level-    -- and hence out of the body of this function altogether, making-    -- it smaller and more inlinable-    float_is_new_lam = float_n_lams > 0-    float_n_lams     = count isId abs_vars--    (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars--    join_arity_maybe = Nothing--    is_mk_static = isJust (collectMakeStaticArgs expr)-        -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable--        -- A decision to float entails let-binding this thing, and we only do-        -- that if we'll escape a value lambda, or will go to the top level.-    float_me = saves_work || saves_alloc || is_mk_static--    -- We can save work if we can move a redex outside a value lambda-    -- But if float_is_new_lam is True, then the redex is wrapped in a-    -- a new lambda, so no work is saved-    saves_work = escapes_value_lam && not float_is_new_lam--    escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)-                  -- See Note [Escaping a value lambda]--    -- See Note [Floating to the top]-    saves_alloc =  isTopLvl dest_lvl-                && floatConsts env-                && (not strict_ctxt || is_bot || exprIsHNF expr)--isBottomThunk :: Maybe (Arity, s) -> Bool--- See Note [Bottoming floats] (2)-isBottomThunk (Just (0, _)) = True   -- Zero arity-isBottomThunk _             = False--{- Note [Floating to the top]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We are keen to float something to the top level, even if it does not-escape a value lambda (and hence save work), for two reasons:--  * Doing so makes the function smaller, by floating out-    bottoming expressions, or integer or string literals.  That in-    turn makes it easier to inline, with less duplication.--  * (Minor) Doing so may turn a dynamic allocation (done by machine-    instructions) into a static one. Minor because we are assuming-    we are not escaping a value lambda.--But do not so if:-     - the context is a strict, and-     - the expression is not a HNF, and-     - the expression is not bottoming--Exammples:--* Bottoming-      f x = case x of-              0 -> error <big thing>-              _ -> x+1-  Here we want to float (error <big thing>) to top level, abstracting-  over 'x', so as to make f's RHS smaller.--* HNF-      f = case y of-            True  -> p:q-            False -> blah-  We may as well float the (p:q) so it becomes a static data structure.--* Case scrutinee-      f = case g True of ....-  Don't float (g True) to top level; then we have the admin of a-  top-level thunk to worry about, with zero gain.--* Case alternative-      h = case y of-             True  -> g True-             False -> False-  Don't float (g True) to the top level--* Arguments-     t = f (g True)-  If f is lazy, we /do/ float (g True) because then we can allocate-  the thunk statically rather than dynamically.  But if f is strict-  we don't (see the use of idStrictness in lvlApp).  It's not clear-  if this test is worth the bother: it's only about CAFs!--It's controlled by a flag (floatConsts), because doing this too-early loses opportunities for RULES which (needless to say) are-important in some nofib programs (gcd is an example).  [SPJ note:-I think this is obsolete; the flag seems always on.]--Note [Floating join point bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Mostly we only float a join point if it can /stay/ a join point.  But-there is one exception: if it can go to the top level (#13286).-Consider-  f x = joinrec j y n = <...j y' n'...>-        in jump j x 0--Here we may just as well produce-  j y n = <....j y' n'...>-  f x = j x 0--and now there is a chance that 'f' will be inlined at its call sites.-It shouldn't make a lot of difference, but these tests-  perf/should_run/MethSharing-  simplCore/should_compile/spec-inline-and one nofib program, all improve if you do float to top, because-of the resulting inlining of f.  So ok, let's do it.--Note [Free join points]-~~~~~~~~~~~~~~~~~~~~~~~-We never float a MFE that has a free join-point variable.  You might think-this can never occur.  After all, consider-     join j x = ...-     in ....(jump j x)....-How might we ever want to float that (jump j x)?-  * If it would escape a value lambda, thus-        join j x = ... in (\y. ...(jump j x)... )-    then 'j' isn't a valid join point in the first place.--But consider-     join j x = .... in-     joinrec j2 y =  ...(jump j x)...(a+b)....--Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec.-But it is emphatically /not/ good to float the (jump j x) out:- (a) 'j' will stop being a join point- (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no-     work would be saved by floating it out of the \y.--Even if we floated 'j' to top level, (b) would still hold.--Bottom line: never float a MFE that has a free JoinId.--Note [Floating MFEs of unlifted type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-   case f x of (r::Int#) -> blah-we'd like to float (f x). But it's not trivial because it has type-Int#, and we don't want to evaluate it too early.  But we can instead-float a boxed version-   y = case f x of r -> I# r-and replace the original (f x) with-   case (case y of I# r -> r) of r -> blah--Being able to float unboxed expressions is sometimes important; see-#12603.  I'm not sure how /often/ it is important, but it's-not hard to achieve.--We only do it for a fixed collection of types for which we have a-convenient boxing constructor (see boxingDataCon_maybe).  In-particular we /don't/ do it for unboxed tuples; it's better to float-the components of the tuple individually.--I did experiment with a form of boxing that works for any type, namely-wrapping in a function.  In our example--   let y = case f x of r -> \v. f x-   in case y void of r -> blah--It works fine, but it's 50% slower (based on some crude benchmarking).-I suppose we could do it for types not covered by boxingDataCon_maybe,-but it's more code and I'll wait to see if anyone wants it.--Note [Test cheapness with exprOkForSpeculation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't want to float very cheap expressions by boxing and unboxing.-But we use exprOkForSpeculation for the test, not exprIsCheap.-Why?  Because it's important /not/ to transform-     f (a /# 3)-to-     f (case bx of I# a -> a /# 3)-and float bx = I# (a /# 3), because the application of f no-longer obeys the let/app invariant.  But (a /# 3) is ok-for-spec-due to a special hack that says division operators can't fail-when the denominator is definitely non-zero.  And yet that-same expression says False to exprIsCheap.  Simplest way to-guarantee the let/app invariant is to use the same function!--If an expression is okay for speculation, we could also float it out-*without* boxing and unboxing, since evaluating it early is okay.-However, it turned out to usually be better not to float such expressions,-since they tend to be extremely cheap things like (x +# 1#). Even the-cost of spilling the let-bound variable to the stack across a call may-exceed the cost of recomputing such an expression. (And we can't float-unlifted bindings to top-level.)--We could try to do something smarter here, and float out expensive yet-okay-for-speculation things, such as division by non-zero constants.-But I suspect it's a narrow target.--Note [Bottoming floats]-~~~~~~~~~~~~~~~~~~~~~~~-If we see-        f = \x. g (error "urk")-we'd like to float the call to error, to get-        lvl = error "urk"-        f = \x. g lvl--But, as ever, we need to be careful:--(1) We want to float a bottoming-    expression even if it has free variables:-        f = \x. g (let v = h x in error ("urk" ++ v))-    Then we'd like to abstract over 'x' can float the whole arg of g:-        lvl = \x. let v = h x in error ("urk" ++ v)-        f = \x. g (lvl x)-    To achieve this we pass is_bot to destLevel--(2) We do not do this for lambdas that return-    bottom.  Instead we treat the /body/ of such a function specially,-    via point (1).  For example:-        f = \x. ....(\y z. if x then error y else error z)....-    ===>-        lvl = \x z y. if b then error y else error z-        f = \x. ...(\y z. lvl x z y)...-    (There is no guarantee that we'll choose the perfect argument order.)--(3) If we have a /binding/ that returns bottom, we want to float it to top-    level, even if it has free vars (point (1)), and even it has lambdas.-    Example:-       ... let { v = \y. error (show x ++ show y) } in ...-    We want to abstract over x and float the whole thing to top:-       lvl = \xy. errror (show x ++ show y)-       ...let {v = lvl x} in ...--    Then of course we don't want to separately float the body (error ...)-    as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot-    argument.--See Maessen's paper 1999 "Bottom extraction: factoring error handling out-of functional programs" (unpublished I think).--When we do this, we set the strictness and arity of the new bottoming-Id, *immediately*, for three reasons:--  * To prevent the abstracted thing being immediately inlined back in again-    via preInlineUnconditionally.  The latter has a test for bottoming Ids-    to stop inlining them, so we'd better make sure it *is* a bottoming Id!--  * So that it's properly exposed as such in the interface file, even if-    this is all happening after strictness analysis.--  * In case we do CSE with the same expression that *is* marked bottom-        lvl          = error "urk"-          x{str=bot) = error "urk"-    Here we don't want to replace 'x' with 'lvl', else we may get Lint-    errors, e.g. via a case with empty alternatives:  (case x of {})-    Lint complains unless the scrutinee of such a case is clearly bottom.--    This was reported in #11290.   But since the whole bottoming-float-    thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure-    that it'll nail all such cases.--Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Tiresomely, though, the simplifier has an invariant that the manifest-arity of the RHS should be the same as the arity; but we can't call-etaExpand during SetLevels because it works over a decorated form of-CoreExpr.  So we do the eta expansion later, in FloatOut.--Note [Case MFEs]-~~~~~~~~~~~~~~~~-We don't float a case expression as an MFE from a strict context.  Why not?-Because in doing so we share a tiny bit of computation (the switch) but-in exchange we build a thunk, which is bad.  This case reduces allocation-by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.-Doesn't change any other allocation at all.--We will make a separate decision for the scrutinee and alternatives.--However this can have a knock-on effect for fusion: consider-    \v -> foldr k z (case x of I# y -> build ..y..)-Perhaps we can float the entire (case x of ...) out of the \v.  Then-fusion will not happen, but we will get more sharing.  But if we don't-float the case (as advocated here) we won't float the (build ...y..)-either, so fusion will happen.  It can be a big effect, esp in some-artificial benchmarks (e.g. integer, queens), but there is no perfect-answer.---}--annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id--- See Note [Bottoming floats] for why we want to add--- bottoming information right now------ n_extra are the number of extra value arguments added during floating-annotateBotStr id n_extra mb_str-  = case mb_str of-      Nothing           -> id-      Just (arity, sig) -> id `setIdArity`      (arity + n_extra)-                              `setIdStrictness` (increaseStrictSigArity n_extra sig)-                              `setIdCprInfo`    mkCprSig (arity + n_extra) botCpr--notWorthFloating :: CoreExpr -> [Var] -> Bool--- Returns True if the expression would be replaced by--- something bigger than it is now.  For example:---   abs_vars = tvars only:  return True if e is trivial,---                           but False for anything bigger---   abs_vars = [x] (an Id): return True for trivial, or an application (f x)---                           but False for (f x x)------ One big goal is that floating should be idempotent.  Eg if--- we replace e with (lvl79 x y) and then run FloatOut again, don't want--- to replace (lvl79 x y) with (lvl83 x y)!--notWorthFloating e abs_vars-  = go e (count isId abs_vars)-  where-    go (Var {}) n    = n >= 0-    go (Lit lit) n   = ASSERT( n==0 )-                       litIsTrivial lit   -- Note [Floating literals]-    go (Tick t e) n  = not (tickishIsCode t) && go e n-    go (Cast e _)  n = go e n-    go (App e arg) n-       -- See Note [Floating applications to coercions]-       | Type {} <- arg = go e n-       | n==0           = False-       | is_triv arg    = go e (n-1)-       | otherwise      = False-    go _ _              = False--    is_triv (Lit {})              = True        -- Treat all literals as trivial-    is_triv (Var {})              = True        -- (ie not worth floating)-    is_triv (Cast e _)            = is_triv e-    is_triv (App e (Type {}))     = is_triv e   -- See Note [Floating applications to coercions]-    is_triv (Tick t e)            = not (tickishIsCode t) && is_triv e-    is_triv _                     = False--{--Note [Floating literals]-~~~~~~~~~~~~~~~~~~~~~~~~-It's important to float Integer literals, so that they get shared,-rather than being allocated every time round the loop.-Hence the litIsTrivial.--Ditto literal strings (LitString), which we'd like to float to top-level, which is now possible.--Note [Floating applications to coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don’t float out variables applied only to type arguments, since the-extra binding would be pointless: type arguments are completely erased.-But *coercion* arguments aren’t (see Note [Coercion tokens] in-CoreToStg.hs and Note [Count coercion arguments in boring contexts] in-CoreUnfold.hs), so we still want to float out variables applied only to-coercion arguments.--Note [Escaping a value lambda]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to float even cheap expressions out of value lambdas,-because that saves allocation.  Consider-        f = \x.  .. (\y.e) ...-Then we'd like to avoid allocating the (\y.e) every time we call f,-(assuming e does not mention x). An example where this really makes a-difference is simplrun009.--Another reason it's good is because it makes SpecContr fire on functions.-Consider-        f = \x. ....(f (\y.e))....-After floating we get-        lvl = \y.e-        f = \x. ....(f lvl)...-and that is much easier for SpecConstr to generate a robust-specialisation for.--However, if we are wrapping the thing in extra value lambdas (in-abs_vars), then nothing is saved.  E.g.-        f = \xyz. ...(e1[y],e2)....-If we float-        lvl = \y. (e1[y],e2)-        f = \xyz. ...(lvl y)...-we have saved nothing: one pair will still be allocated for each-call of 'f'.  Hence the (not float_is_lam) in float_me.---************************************************************************-*                                                                      *-\subsection{Bindings}-*                                                                      *-************************************************************************--The binding stuff works for top level too.--}--lvlBind :: LevelEnv-        -> CoreBindWithFVs-        -> LvlM (LevelledBind, LevelEnv)--lvlBind env (AnnNonRec bndr rhs)-  | isTyVar bndr    -- Don't do anything for TyVar binders-                    --   (simplifier gets rid of them pronto)-  || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)-                    -- so we will ignore this case for now-  || not (profitableFloat env dest_lvl)-  || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))-          -- We can't float an unlifted binding to top level (except-          -- literal strings), so we don't float it at all.  It's a-          -- bit brutal, but unlifted bindings aren't expensive either--  = -- No float-    do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs-       ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)-              (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]-       ; return (NonRec bndr' rhs', env') }--  -- Otherwise we are going to float-  | null abs_vars-  = do {  -- No type abstraction; clone existing binder-         rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive-                             is_bot mb_join_arity rhs-       ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]-       ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str-       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }--  | otherwise-  = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc-         rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive-                             is_bot mb_join_arity rhs-       ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]-       ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str-       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }--  where-    bndr_ty    = idType bndr-    ty_fvs     = tyCoVarsOfType bndr_ty-    rhs_fvs    = freeVarsOf rhs-    bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr-    abs_vars   = abstractVars dest_lvl env bind_fvs-    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join--    deann_rhs  = deAnnotate rhs-    mb_bot_str = exprBotStrictness_maybe deann_rhs-    is_bot     = isJust mb_bot_str-        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)--    n_extra    = count isId abs_vars-    mb_join_arity = isJoinId_maybe bndr-    is_join       = isJust mb_join_arity--lvlBind env (AnnRec pairs)-  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)-         -- Only floating to the top level is allowed.-  || not (profitableFloat env dest_lvl)-  || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs)-       -- This mightBeUnliftedType stuff is the same test as in the non-rec case-       -- You might wonder whether we can have a recursive binding for-       -- an unlifted value -- but we can if it's a /join binding/ (#16978)-       -- (Ultimately I think we should not use SetLevels to-       -- float join bindings at all, but that's another story.)-  =    -- No float-    do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)-             (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs-             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r-       ; rhss' <- mapM lvl_rhs pairs-       ; return (Rec (bndrs' `zip` rhss'), env') }--  -- Otherwise we are going to float-  | null abs_vars-  = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs-       ; new_rhss <- mapM (do_rhs new_env) pairs-       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)-                , new_env) }---- ToDo: when enabling the floatLambda stuff,---       I think we want to stop doing this-  | [(bndr,rhs)] <- pairs-  , count isId abs_vars > 1-  = do  -- Special case for self recursion where there are-        -- several variables carried around: build a local loop:-        --      poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars-        -- This just makes the closures a bit smaller.  If we don't do-        -- this, allocation rises significantly on some programs-        ---        -- We could elaborate it for the case where there are several-        -- mutually recursive functions, but it's quite a bit more complicated-        ---        -- This all seems a bit ad hoc -- sigh-    let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars-        rhs_lvl = le_ctxt_lvl rhs_env--    (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]-    let-        (lam_bndrs, rhs_body)   = collectAnnBndrs rhs-        (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs-        (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1-    new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body-    (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]-    return (Rec [(TB poly_bndr (FloatMe dest_lvl)-                 , mkLams abs_vars_w_lvls $-                   mkLams lam_bndrs2 $-                   Let (Rec [( TB new_bndr (StayPut rhs_lvl)-                             , mkLams lam_bndrs2 new_rhs_body)])-                       (mkVarApps (Var new_bndr) lam_bndrs1))]-           , poly_env)--  | otherwise  -- Non-null abs_vars-  = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs-       ; new_rhss <- mapM (do_rhs new_env) pairs-       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)-                , new_env) }--  where-    (bndrs,rhss) = unzip pairs-    is_join  = isJoinId (head bndrs)-                -- bndrs is always non-empty and if one is a join they all are-                -- Both are checked by Lint-    is_fun   = all isFunction rhss-    is_bot   = False  -- It's odd to have an unconditionally divergent-                      -- function in a Rec, and we don't much care what-                      -- happens to it.  False is simple!--    do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive-                                        is_bot (get_join bndr)-                                        rhs--    get_join bndr | need_zap  = Nothing-                  | otherwise = isJoinId_maybe bndr-    need_zap = dest_lvl `ltLvl` joinCeilingLevel env--        -- Finding the free vars of the binding group is annoying-    bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])-                `unionDVarSet`-                (fvDVarSet $ unionsFV [ idFVs bndr-                                      | (bndr, (_,_)) <- pairs]))-               `delDVarSetList`-                bndrs--    ty_fvs   = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs-    dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join-    abs_vars = abstractVars dest_lvl env bind_fvs--profitableFloat :: LevelEnv -> Level -> Bool-profitableFloat env dest_lvl-  =  (dest_lvl `ltMajLvl` le_ctxt_lvl env)  -- Escapes a value lambda-  || isTopLvl dest_lvl                      -- Going all the way to top level---------------------------------------------------------- Three help functions for the type-abstraction case--lvlRhs :: LevelEnv-       -> RecFlag-       -> Bool               -- Is this a bottoming function-       -> Maybe JoinArity-       -> CoreExprWithFVs-       -> LvlM LevelledExpr-lvlRhs env rec_flag is_bot mb_join_arity expr-  = lvlFloatRhs [] (le_ctxt_lvl env) env-                rec_flag is_bot mb_join_arity expr--lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag-            -> Bool   -- Binding is for a bottoming function-            -> Maybe JoinArity-            -> CoreExprWithFVs-            -> LvlM (Expr LevelledBndr)--- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline-lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs-  = do { body' <- if not is_bot  -- See Note [Floating from a RHS]-                     && any isId bndrs-                  then lvlMFE  body_env True body-                  else lvlExpr body_env      body-       ; return (mkLams bndrs' body') }-  where-    (bndrs, body)     | Just join_arity <- mb_join_arity-                      = collectNAnnBndrs join_arity rhs-                      | otherwise-                      = collectAnnBndrs rhs-    (env1, bndrs1)    = substBndrsSL NonRecursive env bndrs-    all_bndrs         = abs_vars ++ bndrs1-    (body_env, bndrs') | Just _ <- mb_join_arity-                      = lvlJoinBndrs env1 dest_lvl rec all_bndrs-                      | otherwise-                      = case lvlLamBndrs env1 dest_lvl all_bndrs of-                          (env2, bndrs') -> (placeJoinCeiling env2, bndrs')-        -- The important thing here is that we call lvlLamBndrs on-        -- all these binders at once (abs_vars and bndrs), so they-        -- all get the same major level.  Otherwise we create stupid-        -- let-bindings inside, joyfully thinking they can float; but-        -- in the end they don't because we never float bindings in-        -- between lambdas--{- Note [Floating from a RHS]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When floating the RHS of a let-binding, we don't always want to apply-lvlMFE to the body of a lambda, as we usually do, because the entire-binding body is already going to the right place (dest_lvl).--A particular example is the top level.  Consider-   concat = /\ a -> foldr ..a.. (++) []-We don't want to float the body of the lambda to get-   lvl    = /\ a -> foldr ..a.. (++) []-   concat = /\ a -> lvl a-That would be stupid.--Previously this was avoided in a much nastier way, by testing strict_ctxt-in float_me in lvlMFE.  But that wasn't even right because it would fail-to float out the error sub-expression in-    f = \x. case x of-              True  -> error ("blah" ++ show x)-              False -> ...--But we must be careful:--* If we had-    f = \x -> factorial 20-  we /would/ want to float that (factorial 20) out!  Functions are treated-  differently: see the use of isFunction in the calls to destLevel. If-  there are only type lambdas, then destLevel will say "go to top, and-  abstract over the free tyvars" and we don't want that here.--* But if we had-    f = \x -> error (...x....)-  we would NOT want to float the bottoming expression out to give-    lvl = \x -> error (...x...)-    f = \x -> lvl x--Conclusion: use lvlMFE if there are-  * any value lambdas in the original function, and-  * this is not a bottoming function (the is_bot argument)-Use lvlExpr otherwise.  A little subtle, and I got it wrong at least twice-(e.g. #13369).--}--{--************************************************************************-*                                                                      *-\subsection{Deciding floatability}-*                                                                      *-************************************************************************--}--substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])-substAndLvlBndrs is_rec env lvl bndrs-  = lvlBndrs subst_env lvl subst_bndrs-  where-    (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs--substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])--- So named only to avoid the name clash with GHC.Core.Subst.substBndrs-substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs-  = ( env { le_subst    = subst'-          , le_env      = foldl' add_id  id_env (bndrs `zip` bndrs') }-    , bndrs')-  where-    (subst', bndrs') = case is_rec of-                         NonRecursive -> substBndrs    subst bndrs-                         Recursive    -> substRecBndrs subst bndrs--lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])--- Compute the levels for the binders of a lambda group-lvlLamBndrs env lvl bndrs-  = lvlBndrs env new_lvl bndrs-  where-    new_lvl | any is_major bndrs = incMajorLvl lvl-            | otherwise          = incMinorLvl lvl--    is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr)-       -- The "probably" part says "don't float things out of a-       -- probable one-shot lambda"-       -- See Note [Computing one-shot info] in Demand.hs--lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]-             -> (LevelEnv, [LevelledBndr])-lvlJoinBndrs env lvl rec bndrs-  = lvlBndrs env new_lvl bndrs-  where-    new_lvl | isRec rec = incMajorLvl lvl-            | otherwise = incMinorLvl lvl-      -- Non-recursive join points are one-shot; recursive ones are not--lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])--- The binders returned are exactly the same as the ones passed,--- apart from applying the substitution, but they are now paired--- with a (StayPut level)------ The returned envt has le_ctxt_lvl updated to the new_lvl------ All the new binders get the same level, because--- any floating binding is either going to float past--- all or none.  We never separate binders.-lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs-  = ( env { le_ctxt_lvl = new_lvl-          , le_join_ceil = new_lvl-          , le_lvl_env  = addLvls new_lvl lvl_env bndrs }-    , map (stayPut new_lvl) bndrs)--stayPut :: Level -> OutVar -> LevelledBndr-stayPut new_lvl bndr = TB bndr (StayPut new_lvl)--  -- Destination level is the max Id level of the expression-  -- (We'll abstract the type variables, if any.)-destLevel :: LevelEnv-          -> DVarSet    -- Free vars of the term-          -> TyCoVarSet -- Free in the /type/ of the term-                        -- (a subset of the previous argument)-          -> Bool   -- True <=> is function-          -> Bool   -- True <=> is bottom-          -> Bool   -- True <=> is a join point-          -> Level--- INVARIANT: if is_join=True then result >= join_ceiling-destLevel env fvs fvs_ty is_function is_bot is_join-  | isTopLvl max_fv_id_level  -- Float even joins if they get to top level-                              -- See Note [Floating join point bindings]-  = tOP_LEVEL--  | is_join  -- Never float a join point past the join ceiling-             -- See Note [Join points] in FloatOut-  = if max_fv_id_level `ltLvl` join_ceiling-    then join_ceiling-    else max_fv_id_level--  | is_bot              -- Send bottoming bindings to the top-  = as_far_as_poss      -- regardless; see Note [Bottoming floats]-                        -- Esp Bottoming floats (1)--  | Just n_args <- floatLams env-  , n_args > 0  -- n=0 case handled uniformly by the 'otherwise' case-  , is_function-  , countFreeIds fvs <= n_args-  = as_far_as_poss  -- Send functions to top level; see-                    -- the comments with isFunction--  | otherwise = max_fv_id_level-  where-    join_ceiling    = joinCeilingLevel env-    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the-                                              -- tyvars will be abstracted--    as_far_as_poss = maxFvLevel' isId env fvs_ty-                     -- See Note [Floating and kind casts]--{- Note [Floating and kind casts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-   case x of-     K (co :: * ~# k) -> let v :: Int |> co-                             v = e-                         in blah--Then, even if we are abstracting over Ids, or if e is bottom, we can't-float v outside the 'co' binding.  Reason: if we did we'd get-    v' :: forall k. (Int ~# Age) => Int |> co-and now 'co' isn't in scope in that type. The underlying reason is-that 'co' is a value-level thing and we can't abstract over that in a-type (else we'd get a dependent type).  So if v's /type/ mentions 'co'-we can't float it out beyond the binding site of 'co'.--That's why we have this as_far_as_poss stuff.  Usually as_far_as_poss-is just tOP_LEVEL; but occasionally a coercion variable (which is an-Id) mentioned in type prevents this.--Example #14270 comment:15.--}---isFunction :: CoreExprWithFVs -> Bool--- The idea here is that we want to float *functions* to--- the top level.  This saves no work, but---      (a) it can make the host function body a lot smaller,---              and hence inlinable.---      (b) it can also save allocation when the function is recursive:---          h = \x -> letrec f = \y -> ...f...y...x...---                    in f x---     becomes---          f = \x y -> ...(f x)...y...x...---          h = \x -> f x x---     No allocation for f now.--- We may only want to do this if there are sufficiently few free--- variables.  We certainly only want to do it for values, and not for--- constructors.  So the simple thing is just to look for lambdas-isFunction (_, AnnLam b e) | isId b    = True-                           | otherwise = isFunction e--- isFunction (_, AnnTick _ e)         = isFunction e  -- dubious-isFunction _                           = False--countFreeIds :: DVarSet -> Int-countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet-  -- It's OK to use nonDetFoldUDFM here because we're just counting things.-  where-    add :: Var -> Int -> Int-    add v n | isId v    = n+1-            | otherwise = n--{--************************************************************************-*                                                                      *-\subsection{Free-To-Level Monad}-*                                                                      *-************************************************************************--}--data LevelEnv-  = LE { le_switches :: FloatOutSwitches-       , le_ctxt_lvl :: Level           -- The current level-       , le_lvl_env  :: VarEnv Level    -- Domain is *post-cloned* TyVars and Ids-       , le_join_ceil:: Level           -- Highest level to which joins float-                                        -- Invariant: always >= le_ctxt_lvl--       -- See Note [le_subst and le_env]-       , le_subst    :: Subst           -- Domain is pre-cloned TyVars and Ids-                                        -- The Id -> CoreExpr in the Subst is ignored-                                        -- (since we want to substitute a LevelledExpr for-                                        -- an Id via le_env) but we do use the Co/TyVar substs-       , le_env      :: IdEnv ([OutVar], LevelledExpr)  -- Domain is pre-cloned Ids-    }--{- Note [le_subst and le_env]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We clone let- and case-bound variables so that they are still distinct-when floated out; hence the le_subst/le_env.  (see point 3 of the-module overview comment).  We also use these envs when making a-variable polymorphic because we want to float it out past a big-lambda.--The le_subst and le_env always implement the same mapping,-     in_x :->  out_x a b-where out_x is an OutVar, and a,b are its arguments (when-we perform abstraction at the same time as floating).--  le_subst maps to CoreExpr-  le_env   maps to LevelledExpr--Since the range is always a variable or application, there is never-any difference between the two, but sadly the types differ.  The-le_subst is used when substituting in a variable's IdInfo; the le_env-when we find a Var.--In addition the le_env records a [OutVar] of variables free in the-OutExpr/LevelledExpr, just so we don't have to call freeVars-repeatedly.  This list is always non-empty, and the first element is-out_x--The domain of the both envs is *pre-cloned* Ids, though--The domain of the le_lvl_env is the *post-cloned* Ids--}--initialEnv :: FloatOutSwitches -> LevelEnv-initialEnv float_lams-  = LE { le_switches = float_lams-       , le_ctxt_lvl = tOP_LEVEL-       , le_join_ceil = panic "initialEnv"-       , le_lvl_env = emptyVarEnv-       , le_subst = emptySubst-       , le_env = emptyVarEnv }--addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level-addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl--addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level-addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs--floatLams :: LevelEnv -> Maybe Int-floatLams le = floatOutLambdas (le_switches le)--floatConsts :: LevelEnv -> Bool-floatConsts le = floatOutConstants (le_switches le)--floatOverSat :: LevelEnv -> Bool-floatOverSat le = floatOutOverSatApps (le_switches le)--floatTopLvlOnly :: LevelEnv -> Bool-floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)--incMinorLvlFrom :: LevelEnv -> Level-incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env)---- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can--- See Note [Binder-swap during float-out]-extendCaseBndrEnv :: LevelEnv-                  -> Id                 -- Pre-cloned case binder-                  -> Expr LevelledBndr  -- Post-cloned scrutinee-                  -> LevelEnv-extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })-                  case_bndr (Var scrut_var)-  = le { le_subst   = extendSubstWithVar subst case_bndr scrut_var-       , le_env     = add_id id_env (case_bndr, scrut_var) }-extendCaseBndrEnv env _ _ = env---- See Note [Join ceiling]-placeJoinCeiling :: LevelEnv -> LevelEnv-placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })-  = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' }-  where-    lvl' = asJoinCeilLvl (incMinorLvl lvl)--maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level-maxFvLevel max_me env var_set-  = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set--maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level--- Same but for TyCoVarSet-maxFvLevel' max_me env var_set-  = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set--maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level-maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl-  = case lookupVarEnv id_env in_var of-      Just (abs_vars, _) -> foldr max_out lvl abs_vars-      Nothing            -> max_out in_var lvl-  where-    max_out out_var lvl-        | max_me out_var = case lookupVarEnv lvl_env out_var of-                                Just lvl' -> maxLvl lvl' lvl-                                Nothing   -> lvl-        | otherwise = lvl       -- Ignore some vars depending on max_me--lookupVar :: LevelEnv -> Id -> LevelledExpr-lookupVar le v = case lookupVarEnv (le_env le) v of-                    Just (_, expr) -> expr-                    _              -> Var v---- Level to which join points are allowed to float (boundary of current tail--- context). See Note [Join ceiling]-joinCeilingLevel :: LevelEnv -> Level-joinCeilingLevel = le_join_ceil--abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]-        -- Find the variables in fvs, free vars of the target expression,-        -- whose level is greater than the destination level-        -- These are the ones we are going to abstract out-        ---        -- Note that to get reproducible builds, the variables need to be-        -- abstracted in deterministic order, not dependent on the values of-        -- Uniques. This is achieved by using DVarSets, deterministic free-        -- variable computation and deterministic sort.-        -- See Note [Unique Determinism] in Unique for explanation of why-        -- Uniques are not deterministic.-abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs-  =  -- NB: sortQuantVars might not put duplicates next to each other-    map zap $ sortQuantVars $-    filter abstract_me      $-    dVarSetElems            $-    closeOverKindsDSet      $-    substDVarSet subst in_fvs-        -- NB: it's important to call abstract_me only on the OutIds the-        -- come from substDVarSet (not on fv, which is an InId)-  where-    abstract_me v = case lookupVarEnv lvl_env v of-                        Just lvl -> dest_lvl `ltLvl` lvl-                        Nothing  -> False--        -- We are going to lambda-abstract, so nuke any IdInfo,-        -- and add the tyvars of the Id (if necessary)-    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||-                           not (isEmptyRuleInfo (idSpecialisation v)),-                           text "absVarsOf: discarding info on" <+> ppr v )-                     setIdInfo v vanillaIdInfo-          | otherwise = v--type LvlM result = UniqSM result--initLvl :: UniqSupply -> UniqSM a -> a-initLvl = initUs_--newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]-             -> LvlM (LevelEnv, [OutId])--- The envt is extended to bind the new bndrs to dest_lvl, but--- the le_ctxt_lvl is unaffected-newPolyBndrs dest_lvl-             env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })-             abs_vars bndrs- = ASSERT( all (not . isCoVar) bndrs )   -- What would we add to the CoSubst in this case. No easy answer.-   do { uniqs <- getUniquesM-      ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs-            bndr_prs  = bndrs `zip` new_bndrs-            env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs-                       , le_subst   = foldl' add_subst subst   bndr_prs-                       , le_env     = foldl' add_id    id_env  bndr_prs }-      ; return (env', new_bndrs) }-  where-    add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)-    add_id    env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)--    mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $         -- Note [transferPolyIdInfo] in Id.hs-                             transfer_join_info bndr $-                             mkSysLocal (mkFastString str) uniq poly_ty-                           where-                             str     = "poly_" ++ occNameString (getOccName bndr)-                             poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr))--    -- If we are floating a join point to top level, it stops being-    -- a join point.  Otherwise it continues to be a join point,-    -- but we may need to adjust its arity-    dest_is_top = isTopLvl dest_lvl-    transfer_join_info bndr new_bndr-      | Just join_arity <- isJoinId_maybe bndr-      , not dest_is_top-      = new_bndr `asJoinId` join_arity + length abs_vars-      | otherwise-      = new_bndr--newLvlVar :: LevelledExpr        -- The RHS of the new binding-          -> Maybe JoinArity     -- Its join arity, if it is a join point-          -> Bool                -- True <=> the RHS looks like (makeStatic ...)-          -> LvlM Id-newLvlVar lvld_rhs join_arity_maybe is_mk_static-  = do { uniq <- getUniqueM-       ; return (add_join_info (mk_id uniq rhs_ty))-       }-  where-    add_join_info var = var `asJoinId_maybe` join_arity_maybe-    de_tagged_rhs = deTagExpr lvld_rhs-    rhs_ty        = exprType de_tagged_rhs--    mk_id uniq rhs_ty-      -- See Note [Grand plan for static forms] in StaticPtrTable.-      | is_mk_static-      = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))-                            rhs_ty-      | otherwise-      = mkSysLocal (mkFastString "lvl") uniq rhs_ty---- | Clone the binders bound by a single-alternative case.-cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])-cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })-               new_lvl vs-  = do { us <- getUniqueSupplyM-       ; let (subst', vs') = cloneBndrs subst us vs-             -- N.B. We are not moving the body of the case, merely its case-             -- binders.  Consequently we should *not* set le_ctxt_lvl and-             -- le_join_ceil.  See Note [Setting levels when floating-             -- single-alternative cases].-             env' = env { le_lvl_env   = addLvls new_lvl lvl_env vs'-                        , le_subst     = subst'-                        , le_env       = foldl' add_id id_env (vs `zip` vs') }--       ; return (env', vs') }--cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]-             -> LvlM (LevelEnv, [OutVar])--- See Note [Need for cloning during float-out]--- Works for Ids bound by let(rec)--- The dest_lvl is attributed to the binders in the new env,--- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env-cloneLetVars is_rec-          env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })-          dest_lvl vs-  = do { us <- getUniqueSupplyM-       ; let vs1  = map zap vs-                      -- See Note [Zapping the demand info]-             (subst', vs2) = case is_rec of-                               NonRecursive -> cloneBndrs      subst us vs1-                               Recursive    -> cloneRecIdBndrs subst us vs1-             prs  = vs `zip` vs2-             env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2-                        , le_subst   = subst'-                        , le_env     = foldl' add_id id_env prs }--       ; return (env', vs2) }-  where-    zap :: Var -> Var-    zap v | isId v    = zap_join (zapIdDemandInfo v)-          | otherwise = v--    zap_join | isTopLvl dest_lvl = zapJoinId-             | otherwise         = id--add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)-add_id id_env (v, v1)-  | isTyVar v = delVarEnv    id_env v-  | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)--{--Note [Zapping the demand info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-VERY IMPORTANT: we must zap the demand info if the thing is going to-float out, because it may be less demanded than at its original-binding site.  Eg-   f :: Int -> Int-   f x = let v = 3*4 in v+x-Here v is strict; but if we float v to top level, it isn't any more.--Similarly, if we're floating a join point, it won't be one anymore, so we zap-join point information as well.--}
− compiler/simplCore/SimplCore.hs 
@@ -1,1037 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[SimplCore]{Driver for simplifying @Core@ programs}--}--{-# LANGUAGE CPP #-}--module SimplCore ( core2core, simplifyExpr ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Driver.Session-import GHC.Core-import GHC.Driver.Types-import CSE              ( cseProgram )-import GHC.Core.Rules   ( mkRuleBase, unionRuleBase,-                          extendRuleBaseList, ruleCheckProgram, addRuleInfo,-                          getRules )-import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )-import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )-import IdInfo-import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )-import GHC.Core.Utils   ( mkTicks, stripTicksTop )-import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,-                          lintAnnots )-import Simplify         ( simplTopBinds, simplExpr, simplRules )-import SimplUtils       ( simplEnvForGHCi, activeRule, activeUnfolding )-import SimplEnv-import SimplMonad-import CoreMonad-import qualified ErrUtils as Err-import FloatIn          ( floatInwards )-import FloatOut         ( floatOutwards )-import FamInstEnv-import Id-import ErrUtils         ( withTiming, withTimingD, DumpFormat (..) )-import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma )-import VarSet-import VarEnv-import LiberateCase     ( liberateCase )-import SAT              ( doStaticArgs )-import Specialise       ( specProgram)-import SpecConstr       ( specConstrProgram)-import DmdAnal          ( dmdAnalProgram )-import CprAnal          ( cprAnalProgram )-import CallArity        ( callArityAnalProgram )-import Exitify          ( exitifyProgram )-import WorkWrap         ( wwTopBinds )-import SrcLoc-import Util-import Module-import GHC.Driver.Plugins ( withPlugins, installCoreToDos )-import GHC.Runtime.Loader -- ( initializePlugins )--import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )-import UniqFM-import Outputable-import Control.Monad-import qualified GHC.LanguageExtensions as LangExt-{--************************************************************************-*                                                                      *-\subsection{The driver for the simplifier}-*                                                                      *-************************************************************************--}--core2core :: HscEnv -> ModGuts -> IO ModGuts-core2core hsc_env guts@(ModGuts { mg_module  = mod-                                , mg_loc     = loc-                                , mg_deps    = deps-                                , mg_rdr_env = rdr_env })-  = do { -- make sure all plugins are loaded--       ; let builtin_passes = getCoreToDo dflags-             orph_mods = mkModuleSet (mod : dep_orphs deps)-             uniq_mask = 's'-       ;-       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod-                                    orph_mods print_unqual loc $-                           do { hsc_env' <- getHscEnv-                              ; dflags' <- liftIO $ initializePlugins hsc_env'-                                                      (hsc_dflags hsc_env')-                              ; all_passes <- withPlugins dflags'-                                                installCoreToDos-                                                builtin_passes-                              ; runCorePasses all_passes guts }--       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats-             "Grand total simplifier statistics"-             FormatText-             (pprSimplCount stats)--       ; return guts2 }-  where-    dflags         = hsc_dflags hsc_env-    home_pkg_rules = hptRules hsc_env (dep_mods deps)-    hpt_rule_base  = mkRuleBase home_pkg_rules-    print_unqual   = mkPrintUnqualified dflags rdr_env-    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.-    -- This is very convienent for the users of the monad (e.g. plugins do not have to-    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may-    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which-    -- would mean our cached value would go out of date.--{--************************************************************************-*                                                                      *-           Generating the main optimisation pipeline-*                                                                      *-************************************************************************--}--getCoreToDo :: DynFlags -> [CoreToDo]-getCoreToDo dflags-  = flatten_todos core_todo-  where-    opt_level     = optLevel           dflags-    phases        = simplPhases        dflags-    max_iter      = maxSimplIterations dflags-    rule_check    = ruleCheck          dflags-    call_arity    = gopt Opt_CallArity                    dflags-    exitification = gopt Opt_Exitification                dflags-    strictness    = gopt Opt_Strictness                   dflags-    full_laziness = gopt Opt_FullLaziness                 dflags-    do_specialise = gopt Opt_Specialise                   dflags-    do_float_in   = gopt Opt_FloatIn                      dflags-    cse           = gopt Opt_CSE                          dflags-    spec_constr   = gopt Opt_SpecConstr                   dflags-    liberate_case = gopt Opt_LiberateCase                 dflags-    late_dmd_anal = gopt Opt_LateDmdAnal                  dflags-    late_specialise = gopt Opt_LateSpecialise             dflags-    static_args   = gopt Opt_StaticArgumentTransformation dflags-    rules_on      = gopt Opt_EnableRewriteRules           dflags-    eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags-    ww_on         = gopt Opt_WorkerWrapper                dflags-    static_ptrs   = xopt LangExt.StaticPointers           dflags--    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)--    maybe_strictness_before phase-      = runWhen (phase `elem` strictnessBefore dflags) CoreDoDemand--    base_mode = SimplMode { sm_phase      = panic "base_mode"-                          , sm_names      = []-                          , sm_dflags     = dflags-                          , sm_rules      = rules_on-                          , sm_eta_expand = eta_expand_on-                          , sm_inline     = True-                          , sm_case_case  = True }--    simpl_phase phase names iter-      = CoreDoPasses-      $   [ maybe_strictness_before phase-          , CoreDoSimplify iter-                (base_mode { sm_phase = Phase phase-                           , sm_names = names })--          , maybe_rule_check (Phase phase) ]--    simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter-                                | phase <- [phases, phases-1 .. 1] ]---        -- initial simplify: mk specialiser happy: minimum effort please-    simpl_gently = CoreDoSimplify max_iter-                       (base_mode { sm_phase = InitialPhase-                                  , sm_names = ["Gentle"]-                                  , sm_rules = rules_on   -- Note [RULEs enabled in InitialPhase]-                                  , sm_inline = True-                                              -- See Note [Inline in InitialPhase]-                                  , sm_case_case = False })-                          -- Don't do case-of-case transformations.-                          -- This makes full laziness work better--    dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper]-                          else [CoreDoDemand,CoreDoCpr]---    demand_analyser = (CoreDoPasses (-                           dmd_cpr_ww ++-                           [simpl_phase 0 ["post-worker-wrapper"] max_iter]-                           ))--    -- Static forms are moved to the top level with the FloatOut pass.-    -- See Note [Grand plan for static forms] in StaticPtrTable.-    static_ptrs_float_outwards =-      runWhen static_ptrs $ CoreDoPasses-        [ simpl_gently -- Float Out can't handle type lets (sometimes created-                       -- by simpleOptPgm via mkParallelBindings)-        , CoreDoFloatOutwards FloatOutSwitches-          { floatOutLambdas   = Just 0-          , floatOutConstants = True-          , floatOutOverSatApps = False-          , floatToTopLevelOnly = True-          }-        ]--    core_todo =-     if opt_level == 0 then-       [ static_ptrs_float_outwards,-         CoreDoSimplify max_iter-             (base_mode { sm_phase = Phase 0-                        , sm_names = ["Non-opt simplification"] })-       ]--     else {- opt_level >= 1 -} [--    -- We want to do the static argument transform before full laziness as it-    -- may expose extra opportunities to float things outwards. However, to fix-    -- up the output of the transformation we need at do at least one simplify-    -- after this before anything else-        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),--        -- initial simplify: mk specialiser happy: minimum effort please-        simpl_gently,--        -- Specialisation is best done before full laziness-        -- so that overloaded functions have all their dictionary lambdas manifest-        runWhen do_specialise CoreDoSpecialising,--        if full_laziness then-           CoreDoFloatOutwards FloatOutSwitches {-                                 floatOutLambdas   = Just 0,-                                 floatOutConstants = True,-                                 floatOutOverSatApps = False,-                                 floatToTopLevelOnly = False }-                -- Was: gentleFloatOutSwitches-                ---                -- I have no idea why, but not floating constants to-                -- top level is very bad in some cases.-                ---                -- Notably: p_ident in spectral/rewrite-                --          Changing from "gentle" to "constantsOnly"-                --          improved rewrite's allocation by 19%, and-                --          made 0.0% difference to any other nofib-                --          benchmark-                ---                -- Not doing floatOutOverSatApps yet, we'll do-                -- that later on when we've had a chance to get more-                -- accurate arity information.  In fact it makes no-                -- difference at all to performance if we do it here,-                -- but maybe we save some unnecessary to-and-fro in-                -- the simplifier.-        else-           -- Even with full laziness turned off, we still need to float static-           -- forms to the top level. See Note [Grand plan for static forms] in-           -- StaticPtrTable.-           static_ptrs_float_outwards,--        simpl_phases,--                -- Phase 0: allow all Ids to be inlined now-                -- This gets foldr inlined before strictness analysis--                -- At least 3 iterations because otherwise we land up with-                -- huge dead expressions because of an infelicity in the-                -- simplifier.-                --      let k = BIG in foldr k z xs-                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs-                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs-                -- Don't stop now!-        simpl_phase 0 ["main"] (max max_iter 3),--        runWhen do_float_in CoreDoFloatInwards,-            -- Run float-inwards immediately before the strictness analyser-            -- Doing so pushes bindings nearer their use site and hence makes-            -- them more likely to be strict. These bindings might only show-            -- up after the inlining from simplification.  Example in fulsom,-            -- Csg.calc, where an arg of timesDouble thereby becomes strict.--        runWhen call_arity $ CoreDoPasses-            [ CoreDoCallArity-            , simpl_phase 0 ["post-call-arity"] max_iter-            ],--        runWhen strictness demand_analyser,--        runWhen exitification CoreDoExitify,-            -- See note [Placement of the exitification pass]--        runWhen full_laziness $-           CoreDoFloatOutwards FloatOutSwitches {-                                 floatOutLambdas     = floatLamArgs dflags,-                                 floatOutConstants   = True,-                                 floatOutOverSatApps = True,-                                 floatToTopLevelOnly = False },-                -- nofib/spectral/hartel/wang doubles in speed if you-                -- do full laziness late in the day.  It only happens-                -- after fusion and other stuff, so the early pass doesn't-                -- catch it.  For the record, the redex is-                --        f_el22 (f_el21 r_midblock)---        runWhen cse CoreCSE,-                -- We want CSE to follow the final full-laziness pass, because it may-                -- succeed in commoning up things floated out by full laziness.-                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more--        runWhen do_float_in CoreDoFloatInwards,--        maybe_rule_check (Phase 0),--                -- Case-liberation for -O2.  This should be after-                -- strictness analysis and the simplification which follows it.-        runWhen liberate_case (CoreDoPasses [-            CoreLiberateCase,-            simpl_phase 0 ["post-liberate-case"] max_iter-            ]),         -- Run the simplifier after LiberateCase to vastly-                        -- reduce the possibility of shadowing-                        -- Reason: see Note [Shadowing] in SpecConstr.hs--        runWhen spec_constr CoreDoSpecConstr,--        maybe_rule_check (Phase 0),--        runWhen late_specialise-          (CoreDoPasses [ CoreDoSpecialising-                        , simpl_phase 0 ["post-late-spec"] max_iter]),--        -- LiberateCase can yield new CSE opportunities because it peels-        -- off one layer of a recursive function (concretely, I saw this-        -- in wheel-sieve1), and I'm guessing that SpecConstr can too-        -- And CSE is a very cheap pass. So it seems worth doing here.-        runWhen ((liberate_case || spec_constr) && cse) CoreCSE,--        -- Final clean-up simplification:-        simpl_phase 0 ["final"] max_iter,--        runWhen late_dmd_anal $ CoreDoPasses (-            dmd_cpr_ww ++-            [simpl_phase 0 ["post-late-ww"] max_iter]-          ),--        -- Final run of the demand_analyser, ensures that one-shot thunks are-        -- really really one-shot thunks. Only needed if the demand analyser-        -- has run at all. See Note [Final Demand Analyser run] in DmdAnal-        -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution-        -- can become /exponentially/ more expensive. See #11731, #12996.-        runWhen (strictness || late_dmd_anal) CoreDoDemand,--        maybe_rule_check (Phase 0)-     ]--    -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.-    flatten_todos [] = []-    flatten_todos (CoreDoNothing : rest) = flatten_todos rest-    flatten_todos (CoreDoPasses passes : rest) =-      flatten_todos passes ++ flatten_todos rest-    flatten_todos (todo : rest) = todo : flatten_todos rest--{- Note [Inline in InitialPhase]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is-confusing for users because when they say INLINE they expect the function to inline-right away.--So now we do inlining immediately, even in the InitialPhase, assuming that the-Id's Activation allows it.--This is a surprisingly big deal. Compiler performance improved a lot-when I made this change:--   perf/compiler/T5837.run            T5837 [stat too good] (normal)-   perf/compiler/parsing001.run       parsing001 [stat too good] (normal)-   perf/compiler/T12234.run           T12234 [stat too good] (optasm)-   perf/compiler/T9020.run            T9020 [stat too good] (optasm)-   perf/compiler/T3064.run            T3064 [stat too good] (normal)-   perf/compiler/T9961.run            T9961 [stat too good] (normal)-   perf/compiler/T13056.run           T13056 [stat too good] (optasm)-   perf/compiler/T9872d.run           T9872d [stat too good] (normal)-   perf/compiler/T783.run             T783 [stat too good] (normal)-   perf/compiler/T12227.run           T12227 [stat too good] (normal)-   perf/should_run/lazy-bs-alloc.run  lazy-bs-alloc [stat too good] (normal)-   perf/compiler/T1969.run            T1969 [stat too good] (normal)-   perf/compiler/T9872a.run           T9872a [stat too good] (normal)-   perf/compiler/T9872c.run           T9872c [stat too good] (normal)-   perf/compiler/T9872b.run           T9872b [stat too good] (normal)-   perf/compiler/T9872d.run           T9872d [stat too good] (normal)--Note [RULEs enabled in InitialPhase]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-RULES are enabled when doing "gentle" simplification in InitialPhase,-or with -O0.  Two reasons:--  * We really want the class-op cancellation to happen:-        op (df d1 d2) --> $cop3 d1 d2-    because this breaks the mutual recursion between 'op' and 'df'--  * I wanted the RULE-        lift String ===> ...-    to work in Template Haskell when simplifying-    splices, so we get simpler code for literal strings--But watch out: list fusion can prevent floating.  So use phase control-to switch off those rules until after floating.--************************************************************************-*                                                                      *-                  The CoreToDo interpreter-*                                                                      *-************************************************************************--}--runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts-runCorePasses passes guts-  = foldM do_pass guts passes-  where-    do_pass guts CoreDoNothing = return guts-    do_pass guts (CoreDoPasses ps) = runCorePasses ps guts-    do_pass guts pass = do-       withTimingD (ppr pass <+> brackets (ppr mod))-                   (const ()) $ do-            { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts-            ; endPass pass (mg_binds guts') (mg_rules guts')-            ; return guts' }--    mod = mg_module guts--doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts-doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}-                                       simplifyPgm pass--doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}-                                       doPass cseProgram--doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}-                                       doPassD liberateCase--doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}-                                       floatInwards--doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}-                                       doPassDUM (floatOutwards f)--doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}-                                       doPassU doStaticArgs--doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}-                                       doPassD callArityAnalProgram--doCorePass CoreDoExitify             = {-# SCC "Exitify" #-}-                                       doPass exitifyProgram--doCorePass CoreDoDemand              = {-# SCC "DmdAnal" #-}-                                       doPassDFM dmdAnalProgram--doCorePass CoreDoCpr                 = {-# SCC "CprAnal" #-}-                                       doPassDFM cprAnalProgram--doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}-                                       doPassDFU wwTopBinds--doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}-                                       specProgram--doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}-                                       specConstrProgram--doCorePass CoreDoPrintCore              = observe   printCore-doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat-doCorePass CoreDoNothing                = return-doCorePass (CoreDoPasses passes)        = runCorePasses passes--doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass--doCorePass pass@CoreDesugar          = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CoreDesugarOpt       = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CoreTidy             = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CorePrep             = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CoreOccurAnal        = pprPanic "doCorePass" (ppr pass)--{--************************************************************************-*                                                                      *-\subsection{Core pass combinators}-*                                                                      *-************************************************************************--}--printCore :: DynFlags -> CoreProgram -> IO ()-printCore dflags binds-    = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)--ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts-ruleCheckPass current_phase pat guts =-    withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts))-                (const ()) $ do-    { rb <- getRuleBase-    ; dflags <- getDynFlags-    ; vis_orphs <- getVisibleOrphanMods-    ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn-                        ++ (mg_rules guts)-    ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan-                   (defaultDumpStyle dflags)-                   (ruleCheckProgram current_phase pat-                      rule_fn (mg_binds guts))-    ; return guts }--doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDUM do_pass = doPassM $ \binds -> do-    dflags <- getDynFlags-    us     <- getUniqueSupplyM-    liftIO $ do_pass dflags us binds--doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))--doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)--doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)--doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassU do_pass = doPassDU (const do_pass)--doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDFM do_pass guts = do-    dflags <- getDynFlags-    p_fam_env <- getPackageFamInstEnv-    let fam_envs = (p_fam_env, mg_fam_inst_env guts)-    doPassM (liftIO . do_pass dflags fam_envs) guts--doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPassDFU do_pass guts = do-    dflags <- getDynFlags-    us     <- getUniqueSupplyM-    p_fam_env <- getPackageFamInstEnv-    let fam_envs = (p_fam_env, mg_fam_inst_env guts)-    doPass (do_pass dflags fam_envs us) guts---- Most passes return no stats and don't change rules: these combinators--- let us lift them to the full blown ModGuts+CoreM world-doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts-doPassM bind_f guts = do-    binds' <- bind_f (mg_binds guts)-    return (guts { mg_binds = binds' })--doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts-doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }---- Observer passes just peek; don't modify the bindings at all-observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts-observe do_pass = doPassM $ \binds -> do-    dflags <- getDynFlags-    _ <- liftIO $ do_pass dflags binds-    return binds--{--************************************************************************-*                                                                      *-        Gentle simplification-*                                                                      *-************************************************************************--}--simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do-             -> CoreExpr-             -> IO CoreExpr--- simplifyExpr is called by the driver to simplify an--- expression typed in at the interactive prompt-simplifyExpr hsc_env expr-  = withTiming dflags (text "Simplify [expr]") (const ()) $-    do  { eps <- hscEPS hsc_env ;-        ; let rule_env  = mkRuleEnv (eps_rule_base eps) []-              fi_env    = ( eps_fam_inst_env eps-                          , extendFamInstEnvList emptyFamInstEnv $-                            snd $ ic_instances $ hsc_IC hsc_env )-              simpl_env = simplEnvForGHCi dflags--        ; us <-  mkSplitUniqSupply 's'-        ; let sz = exprSize expr--        ; (expr', counts) <- initSmpl dflags rule_env fi_env us sz $-                             simplExprGently simpl_env expr--        ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)-                  "Simplifier statistics" (pprSimplCount counts)--        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"-                        FormatCore-                        (pprCoreExpr expr')--        ; return expr'-        }-  where-    dflags = hsc_dflags hsc_env--simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr--- Simplifies an expression---      does occurrence analysis, then simplification---      and repeats (twice currently) because one pass---      alone leaves tons of crud.--- Used (a) for user expressions typed in at the interactive prompt---      (b) the LHS and RHS of a RULE---      (c) Template Haskell splices------ The name 'Gently' suggests that the SimplMode is InitialPhase,--- and in fact that is so.... but the 'Gently' in simplExprGently doesn't--- 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--- simplifier does indeed do eta reduction (it's in Simplify.completeLam)--- but only if -O is on.--simplExprGently env expr = do-    expr1 <- simplExpr env (occurAnalyseExpr expr)-    simplExpr env (occurAnalyseExpr expr1)--{--************************************************************************-*                                                                      *-\subsection{The driver for the simplifier}-*                                                                      *-************************************************************************--}--simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts-simplifyPgm pass guts-  = do { hsc_env <- getHscEnv-       ; us <- getUniqueSupplyM-       ; rb <- getRuleBase-       ; liftIOWithCount $-         simplifyPgmIO pass hsc_env us rb guts }--simplifyPgmIO :: CoreToDo-              -> HscEnv-              -> UniqSupply-              -> RuleBase-              -> ModGuts-              -> IO (SimplCount, ModGuts)  -- New bindings--simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)-              hsc_env us hpt_rule_base-              guts@(ModGuts { mg_module = this_mod-                            , mg_rdr_env = rdr_env-                            , mg_deps = deps-                            , mg_binds = binds, mg_rules = rules-                            , mg_fam_inst_env = fam_inst_env })-  = do { (termination_msg, it_count, counts_out, guts')-           <- do_iteration us 1 [] binds rules--        ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&-                                dopt Opt_D_dump_simpl_stats  dflags)-                  "Simplifier statistics for following pass"-                  (vcat [text termination_msg <+> text "after" <+> ppr it_count-                                              <+> text "iterations",-                         blankLine,-                         pprSimplCount counts_out])--        ; return (counts_out, guts')-    }-  where-    dflags       = hsc_dflags hsc_env-    print_unqual = mkPrintUnqualified dflags rdr_env-    simpl_env    = mkSimplEnv mode-    active_rule  = activeRule mode-    active_unf   = activeUnfolding mode--    do_iteration :: UniqSupply-                 -> Int          -- Counts iterations-                 -> [SimplCount] -- Counts from earlier iterations, reversed-                 -> CoreProgram  -- Bindings in-                 -> [CoreRule]   -- and orphan rules-                 -> IO (String, Int, SimplCount, ModGuts)--    do_iteration us iteration_no counts_so_far binds rules-        -- iteration_no is the number of the iteration we are-        -- about to begin, with '1' for the first-      | iteration_no > max_iterations   -- Stop if we've run out of iterations-      = WARN( debugIsOn && (max_iterations > 2)-            , hang (text "Simplifier bailing out after" <+> int max_iterations-                    <+> text "iterations"-                    <+> (brackets $ hsep $ punctuate comma $-                         map (int . simplCountN) (reverse counts_so_far)))-                 2 (text "Size =" <+> ppr (coreBindsStats binds)))--                -- Subtract 1 from iteration_no to get the-                -- number of iterations we actually completed-        return ( "Simplifier baled out", iteration_no - 1-               , totalise counts_so_far-               , guts { mg_binds = binds, mg_rules = rules } )--      -- Try and force thunks off the binds; significantly reduces-      -- space usage, especially with -O.  JRS, 000620.-      | let sz = coreBindsSize binds-      , () <- sz `seq` ()     -- Force it-      = do {-                -- Occurrence analysis-           let { tagged_binds = {-# SCC "OccAnal" #-}-                     occurAnalysePgm this_mod active_unf active_rule rules-                                     binds-               } ;-           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"-                     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-                -- 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-           eps <- hscEPS hsc_env ;-           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)-                ; rule_base2 = extendRuleBaseList rule_base1 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 dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $-               do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}-                                      simplTopBinds simpl_env tagged_binds--                      -- Apply the substitution to rules defined in this module-                      -- for imported Ids.  Eg  RULE map my_f = blah-                      -- If we have a substitution my_f :-> other_f, we'd better-                      -- apply it to the rule to, or it'll never match-                  ; rules1 <- simplRules env1 Nothing rules Nothing--                  ; return (getTopFloatBinds floats, rules1) } ;--                -- Stop if nothing happened; don't dump output-                -- See Note [Which transformations are innocuous] in CoreMonad-           if isZeroSimplCount counts1 then-                return ( "Simplifier reached fixed point", iteration_no-                       , totalise (counts1 : counts_so_far)  -- Include "free" ticks-                       , guts { mg_binds = binds1, mg_rules = rules1 } )-           else do {-                -- Short out indirections-                -- We do this *after* at least one run of the simplifier-                -- because indirection-shorting uses the export flag on *occurrences*-                -- and that isn't guaranteed to be ok until after the first run propagates-                -- stuff from the binding site to its occurrences-                ---                -- ToDo: alas, this means that indirection-shorting does not happen at all-                --       if the simplifier does nothing (not common, I know, but unsavoury)-           let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;--                -- Dump the result of this iteration-           dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;-           lintPassResult hsc_env pass binds2 ;--                -- Loop-           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1-           } }-#if __GLASGOW_HASKELL__ <= 810-      | otherwise = panic "do_iteration"-#endif-      where-        (us1, us2) = splitUniqSupply us--        -- Remember the counts_so_far are reversed-        totalise :: [SimplCount] -> SimplCount-        totalise = foldr (\c acc -> acc `plusSimplCount` c)-                         (zeroSimplCount dflags)--simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"----------------------dump_end_iteration :: DynFlags -> PrintUnqualified -> Int-                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()-dump_end_iteration dflags print_unqual iteration_no counts binds rules-  = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules-  where-    mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations-            | otherwise                               = Nothing-            -- Show details if Opt_D_dump_simpl_iterations is on--    hdr = text "Simplifier iteration=" <> int iteration_no-    pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr-                     , pprSimplCount counts-                     , text "---- End of simplifier counts for" <+> hdr ]--{--************************************************************************-*                                                                      *-                Shorting out indirections-*                                                                      *-************************************************************************--If we have this:--        x_local = <expression>-        ...bindings...-        x_exported = x_local--where x_exported is exported, and x_local is not, then we replace it with this:--        x_exported = <expression>-        x_local = x_exported-        ...bindings...--Without this we never get rid of the x_exported = x_local thing.  This-save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and-makes strictness information propagate better.  This used to happen in-the final phase, but it's tidier to do it here.--Note [Messing up the exported Id's RULES]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must be careful about discarding (obviously) or even merging the-RULES on the exported Id. The example that went bad on me at one stage-was this one:--    iterate :: (a -> a) -> a -> [a]-        [Exported]-    iterate = iterateList--    iterateFB c f x = x `c` iterateFB c f (f x)-    iterateList f x =  x : iterateList f (f x)-        [Not exported]--    {-# RULES-    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)-    "iterateFB"                 iterateFB (:) = iterateList-     #-}--This got shorted out to:--    iterateList :: (a -> a) -> a -> [a]-    iterateList = iterate--    iterateFB c f x = x `c` iterateFB c f (f x)-    iterate f x =  x : iterate f (f x)--    {-# RULES-    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)-    "iterateFB"                 iterateFB (:) = iterate-     #-}--And now we get an infinite loop in the rule system-        iterate f x -> build (\cn -> iterateFB c f x)-                    -> iterateFB (:) f x-                    -> iterate f x--Old "solution":-        use rule switching-off pragmas to get rid-        of iterateList in the first place--But in principle the user *might* want rules that only apply to the Id-he says.  And inline pragmas are similar-   {-# NOINLINE f #-}-   f = local-   local = <stuff>-Then we do not want to get rid of the NOINLINE.--Hence hasShortableIdinfo.---Note [Rules and indirection-zapping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Problem: what if x_exported has a RULE that mentions something in ...bindings...?-Then the things mentioned can be out of scope!  Solution- a) Make sure that in this pass the usage-info from x_exported is-        available for ...bindings...- b) If there are any such RULES, rec-ify the entire top-level.-    It'll get sorted out next time round--Other remarks-~~~~~~~~~~~~~-If more than one exported thing is equal to a local thing (i.e., the-local thing really is shared), then we do one only:-\begin{verbatim}-        x_local = ....-        x_exported1 = x_local-        x_exported2 = x_local-==>-        x_exported1 = ....--        x_exported2 = x_exported1-\end{verbatim}--We rely on prior eta reduction to simplify things like-\begin{verbatim}-        x_exported = /\ tyvars -> x_local tyvars-==>-        x_exported = x_local-\end{verbatim}-Hence,there's a possibility of leaving unchanged something like this:-\begin{verbatim}-        x_local = ....-        x_exported1 = x_local Int-\end{verbatim}-By the time we've thrown away the types in STG land this-could be eliminated.  But I don't think it's very common-and it's dangerous to do this fiddling in STG land-because we might eliminate a binding that's mentioned in the-unfolding for something.--Note [Indirection zapping and ticks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Unfortunately this is another place where we need a special case for-ticks. The following happens quite regularly:--        x_local = <expression>-        x_exported = tick<x> x_local--Which we want to become:--        x_exported =  tick<x> <expression>--As it makes no sense to keep the tick and the expression on separate-bindings. Note however that that this might increase the ticks scoping-over the execution of x_local, so we can only do this for floatable-ticks. More often than not, other references will be unfoldings of-x_exported, and therefore carry the tick anyway.--}--type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks--shortOutIndirections :: CoreProgram -> CoreProgram-shortOutIndirections binds-  | isEmptyVarEnv ind_env = binds-  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]-  | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff-  where-    ind_env            = makeIndEnv binds-    -- These exported Ids are the subjects  of the indirection-elimination-    exp_ids            = map fst $ nonDetEltsUFM ind_env-      -- It's OK to use nonDetEltsUFM here because we forget the ordering-      -- by immediately converting to a set or check if all the elements-      -- satisfy a predicate.-    exp_id_set         = mkVarSet exp_ids-    no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids-    binds'             = concatMap zap binds--    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]-    zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]--    zapPair (bndr, rhs)-        | bndr `elemVarSet` exp_id_set-        = []   -- Kill the exported-id binding--        | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr-        , (exp_id', lcl_id') <- transferIdInfo exp_id bndr-        =      -- Turn a local-id binding into two bindings-               --    exp_id = rhs; lcl_id = exp_id-          [ (exp_id', mkTicks ticks rhs),-            (lcl_id', Var exp_id') ]--        | otherwise-        = [(bndr,rhs)]--makeIndEnv :: [CoreBind] -> IndEnv-makeIndEnv binds-  = foldl' add_bind emptyVarEnv binds-  where-    add_bind :: IndEnv -> CoreBind -> IndEnv-    add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)-    add_bind env (Rec pairs)              = foldl' add_pair env pairs--    add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv-    add_pair env (exported_id, exported)-        | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported-        , shortMeOut env exported_id local_id-        = extendVarEnv env local_id (exported_id, ticks)-    add_pair env _ = env--------------------shortMeOut :: IndEnv -> Id -> Id -> Bool-shortMeOut ind_env exported_id local_id--- The if-then-else stuff is just so I can get a pprTrace to see--- how often I don't get shorting out because of IdInfo stuff-  = if isExportedId exported_id &&              -- Only if this is exported--       isLocalId local_id &&                    -- Only if this one is defined in this-                                                --      module, so that we *can* change its-                                                --      binding to be the exported thing!--       not (isExportedId local_id) &&           -- Only if this one is not itself exported,-                                                --      since the transformation will nuke it--       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]-        else WARN( True, text "Not shorting out:" <+> ppr exported_id )-             False-    else-        False--------------------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]-hasShortableIdInfo id-  =  isEmptyRuleInfo (ruleInfo info)-  && isDefaultInlinePragma (inlinePragInfo info)-  && not (isStableUnfolding (unfoldingInfo info))-  where-     info = idInfo id--------------------{- Note [Transferring IdInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-     lcl_id = e; exp_id = lcl_id--and lcl_id has useful IdInfo, we don't want to discard it by going-     gbl_id = e; lcl_id = gbl_id--Instead, transfer IdInfo from lcl_id to exp_id, specifically-* (Stable) unfolding-* Strictness-* Rules-* Inline pragma--Overwriting, rather than merging, seems to work ok.--We also zap the InlinePragma on the lcl_id. It might originally-have had a NOINLINE, which we have now transferred; and we really-want the lcl_id to inline now that its RHS is trivial!--}--transferIdInfo :: Id -> Id -> (Id, Id)--- See Note [Transferring IdInfo]-transferIdInfo exported_id local_id-  = ( modifyIdInfo transfer exported_id-    , local_id `setInlinePragma` defaultInlinePragma )-  where-    local_info = idInfo local_id-    transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info-                                 `setCprInfo`           cprInfo local_info-                                 `setUnfoldingInfo`     unfoldingInfo local_info-                                 `setInlinePragInfo`    inlinePragInfo local_info-                                 `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info-    new_info = setRuleInfoHead (idName exported_id)-                               (ruleInfo local_info)-        -- Remember to set the function-name field of the-        -- rules as we transfer them from one function to another
− compiler/simplCore/SimplEnv.hs 
@@ -1,938 +0,0 @@-{--(c) The AQUA Project, Glasgow University, 1993-1998--\section[SimplMonad]{The simplifier Monad}--}--{-# LANGUAGE CPP #-}--module SimplEnv (-        -- * The simplifier mode-        setMode, getMode, updMode, seDynFlags,--        -- * Environments-        SimplEnv(..), pprSimplEnv,   -- Temp not abstract-        mkSimplEnv, extendIdSubst,-        SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,-        zapSubstEnv, setSubstEnv,-        getInScope, setInScopeFromE, setInScopeFromF,-        setInScopeSet, modifyInScope, addNewInScopeIds,-        getSimplRules,--        -- * Substitution results-        SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,--        -- * Simplifying 'Id' binders-        simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,-        simplBinder, simplBinders,-        substTy, substTyVar, getTCvSubst,-        substCo, substCoVar,--        -- * Floats-        SimplFloats(..), emptyFloats, mkRecFloats,-        mkFloatBind, addLetFloats, addJoinFloats, addFloats,-        extendFloats, wrapFloats,-        doFloatFromRhs, getTopFloatBinds,--        -- * LetFloats-        LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,-        addLetFlts,  mapLetFloats,--        -- * JoinFloats-        JoinFloat, JoinFloats, emptyJoinFloats,-        wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts-    ) where--#include "HsVersions.h"--import GhcPrelude--import SimplMonad-import CoreMonad                ( SimplMode(..) )-import GHC.Core-import GHC.Core.Utils-import Var-import VarEnv-import VarSet-import OrdList-import Id-import GHC.Core.Make            ( mkWildValBinder )-import GHC.Driver.Session       ( DynFlags )-import TysWiredIn-import qualified Type-import Type hiding              ( substTy, substTyVar, substTyVarBndr )-import qualified Coercion-import Coercion hiding          ( substCo, substCoVar, substCoVarBndr )-import BasicTypes-import MonadUtils-import Outputable-import Util-import UniqFM                   ( pprUniqFM )--import Data.List (mapAccumL)--{--************************************************************************-*                                                                      *-\subsubsection{The @SimplEnv@ type}-*                                                                      *-************************************************************************--}--data SimplEnv-  = SimplEnv {-     ----------- Static part of the environment ------------     -- Static in the sense of lexically scoped,-     -- wrt the original expression--        seMode      :: SimplMode--        -- The current substitution-      , seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType-      , seCvSubst   :: CvSubstEnv      -- InCoVar |--> OutCoercion-      , seIdSubst   :: SimplIdSubst    -- InId    |--> OutExpr--     ----------- Dynamic part of the environment ------------     -- Dynamic in the sense of describing the setup where-     -- the expression finally ends up--        -- The current set of in-scope variables-        -- They are all OutVars, and all bound in this module-      , seInScope   :: InScopeSet       -- OutVars only-    }--data SimplFloats-  = SimplFloats-      { -- Ordinary let bindings-        sfLetFloats  :: LetFloats-                -- See Note [LetFloats]--        -- Join points-      , sfJoinFloats :: JoinFloats-                -- Handled separately; they don't go very far-                -- We consider these to be /inside/ sfLetFloats-                -- because join points can refer to ordinary bindings,-                -- but not vice versa--        -- Includes all variables bound by sfLetFloats and-        -- sfJoinFloats, plus at least whatever is in scope where-        -- these bindings land up.-      , sfInScope :: InScopeSet  -- All OutVars-      }--instance Outputable SimplFloats where-  ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })-    = text "SimplFloats"-      <+> braces (vcat [ text "lets: " <+> ppr lf-                       , text "joins:" <+> ppr jf-                       , text "in_scope:" <+> ppr is ])--emptyFloats :: SimplEnv -> SimplFloats-emptyFloats env-  = SimplFloats { sfLetFloats  = emptyLetFloats-                , sfJoinFloats = emptyJoinFloats-                , sfInScope    = seInScope env }--pprSimplEnv :: SimplEnv -> SDoc--- Used for debugging; selective-pprSimplEnv env-  = vcat [text "TvSubst:" <+> ppr (seTvSubst env),-          text "CvSubst:" <+> ppr (seCvSubst env),-          text "IdSubst:" <+> id_subst_doc,-          text "InScope:" <+> in_scope_vars_doc-    ]-  where-   id_subst_doc = pprUniqFM ppr (seIdSubst env)-   in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))-                                 (vcat . map ppr_one)-   ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)-             | otherwise = ppr v--type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr-        -- See Note [Extending the Subst] in GHC.Core.Subst---- | A substitution result.-data SimplSR-  = DoneEx OutExpr (Maybe JoinArity)-       -- If  x :-> DoneEx e ja   is in the SimplIdSubst-       -- then replace occurrences of x by e-       -- and  ja = Just a <=> x is a join-point of arity a-       -- See Note [Join arity in SimplIdSubst]---  | DoneId OutId-       -- If  x :-> DoneId v   is in the SimplIdSubst-       -- then replace occurrences of x by v-       -- and  v is a join-point of arity a-       --      <=> x is a join-point of arity a--  | ContEx TvSubstEnv                 -- A suspended substitution-           CvSubstEnv-           SimplIdSubst-           InExpr-      -- If   x :-> ContEx tv cv id e   is in the SimplISubst-      -- then replace occurrences of x by (subst (tv,cv,id) e)--instance Outputable SimplSR where-  ppr (DoneId v)    = text "DoneId" <+> ppr v-  ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e-    where-      pp_mj = case mj of-                Nothing -> empty-                Just n  -> parens (int n)--  ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,-                                ppr (filter_env tv), ppr (filter_env id) -}]-        -- where-        -- fvs = exprFreeVars e-        -- filter_env env = filterVarEnv_Directly keep env-        -- keep uniq _ = uniq `elemUFM_Directly` fvs--{--Note [SimplEnv invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~-seInScope:-        The in-scope part of Subst includes *all* in-scope TyVars and Ids-        The elements of the set may have better IdInfo than the-        occurrences of in-scope Ids, and (more important) they will-        have a correctly-substituted type.  So we use a lookup in this-        set to replace occurrences--        The Ids in the InScopeSet are replete with their Rules,-        and as we gather info about the unfolding of an Id, we replace-        it in the in-scope set.--        The in-scope set is actually a mapping OutVar -> OutVar, and-        in case expressions we sometimes bind--seIdSubst:-        The substitution is *apply-once* only, because InIds and OutIds-        can overlap.-        For example, we generally omit mappings-                a77 -> a77-        from the substitution, when we decide not to clone a77, but it's quite-        legitimate to put the mapping in the substitution anyway.--        Furthermore, consider-                let x = case k of I# x77 -> ... in-                let y = case k of I# x77 -> ... in ...-        and suppose the body is strict in both x and y.  Then the simplifier-        will pull the first (case k) to the top; so the second (case k) will-        cancel out, mapping x77 to, well, x77!  But one is an in-Id and the-        other is an out-Id.--        Of course, the substitution *must* applied! Things in its domain-        simply aren't necessarily bound in the result.--* substId adds a binding (DoneId new_id) to the substitution if-        the Id's unique has changed--  Note, though that the substitution isn't necessarily extended-  if the type of the Id changes.  Why not?  Because of the next point:--* We *always, always* finish by looking up in the in-scope set-  any variable that doesn't get a DoneEx or DoneVar hit in the substitution.-  Reason: so that we never finish up with a "old" Id in the result.-  An old Id might point to an old unfolding and so on... which gives a space-  leak.--  [The DoneEx and DoneVar hits map to "new" stuff.]--* It follows that substExpr must not do a no-op if the substitution is empty.-  substType is free to do so, however.--* When we come to a let-binding (say) we generate new IdInfo, including an-  unfolding, attach it to the binder, and add this newly adorned binder to-  the in-scope set.  So all subsequent occurrences of the binder will get-  mapped to the full-adorned binder, which is also the one put in the-  binding site.--* The in-scope "set" usually maps x->x; we use it simply for its domain.-  But sometimes we have two in-scope Ids that are synomyms, and should-  map to the same target:  x->x, y->x.  Notably:-        case y of x { ... }-  That's why the "set" is actually a VarEnv Var--Note [Join arity in SimplIdSubst]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have to remember which incoming variables are join points: the occurrences-may not be marked correctly yet, and we're in change of propagating the change if-OccurAnal makes something a join point).--Normally the in-scope set is where we keep the latest information, but-the in-scope set tracks only OutVars; if a binding is unconditionally-inlined (via DoneEx), it never makes it into the in-scope set, and we-need to know at the occurrence site that the variable is a join point-so that we know to drop the context. Thus we remember which join-points we're substituting. -}--mkSimplEnv :: SimplMode -> SimplEnv-mkSimplEnv mode-  = SimplEnv { seMode = mode-             , seInScope = init_in_scope-             , seTvSubst = emptyVarEnv-             , seCvSubst = emptyVarEnv-             , seIdSubst = emptyVarEnv }-        -- The top level "enclosing CC" is "SUBSUMED".--init_in_scope :: InScopeSet-init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))-              -- See Note [WildCard binders]--{--Note [WildCard binders]-~~~~~~~~~~~~~~~~~~~~~~~-The program to be simplified may have wild binders-    case e of wild { p -> ... }-We want to *rename* them away, so that there are no-occurrences of 'wild-id' (with wildCardKey).  The easy-way to do that is to start of with a representative-Id in the in-scope set--There can be *occurrences* of wild-id.  For example,-GHC.Core.Make.mkCoreApp transforms-   e (a /# b)   -->   case (a /# b) of wild { DEFAULT -> e wild }-This is ok provided 'wild' isn't free in 'e', and that's the delicate-thing. Generally, you want to run the simplifier to get rid of the-wild-ids before doing much else.--It's a very dark corner of GHC.  Maybe it should be cleaned up.--}--getMode :: SimplEnv -> SimplMode-getMode env = seMode env--seDynFlags :: SimplEnv -> DynFlags-seDynFlags env = sm_dflags (seMode env)--setMode :: SimplMode -> SimplEnv -> SimplEnv-setMode mode env = env { seMode = mode }--updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv-updMode upd env = env { seMode = upd (seMode env) }------------------------extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv-extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res-  = ASSERT2( isId var && not (isCoVar var), ppr var )-    env { seIdSubst = extendVarEnv subst var res }--extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv-extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res-  = ASSERT2( isTyVar var, ppr var $$ ppr res )-    env {seTvSubst = extendVarEnv tsubst var res}--extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv-extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co-  = ASSERT( isCoVar var )-    env {seCvSubst = extendVarEnv csubst var co}------------------------getInScope :: SimplEnv -> InScopeSet-getInScope env = seInScope env--setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv-setInScopeSet env in_scope = env {seInScope = in_scope}--setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv--- See Note [Setting the right in-scope set]-setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env }--setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv-setInScopeFromF env floats = env { seInScope = sfInScope floats }--addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv-        -- The new Ids are guaranteed to be freshly allocated-addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs-  = env { seInScope = in_scope `extendInScopeSetList` vs,-          seIdSubst = id_subst `delVarEnvList` vs }-        -- Why delete?  Consider-        --      let x = a*b in (x, \x -> x+3)-        -- We add [x |-> a*b] to the substitution, but we must-        -- _delete_ it from the substitution when going inside-        -- the (\x -> ...)!--modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv--- The variable should already be in scope, but--- replace the existing version with this new one--- which has more information-modifyInScope env@(SimplEnv {seInScope = in_scope}) v-  = env {seInScope = extendInScopeSet in_scope v}--{- Note [Setting the right in-scope set]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  \x. (let x = e in b) arg[x]-where the let shadows the lambda.  Really this means something like-  \x1. (let x2 = e in b) arg[x1]--- When we capture the 'arg' in an ApplyToVal continuation, we capture-  the environment, which says what 'x' is bound to, namely x1--- Then that continuation gets pushed under the let--- Finally we simplify 'arg'.  We want-     - the static, lexical environment binding x :-> x1-     - the in-scopeset from "here", under the 'let' which includes-       both x1 and x2--It's important to have the right in-scope set, else we may rename a-variable to one that is already in scope.  So we must pick up the-in-scope set from "here", but otherwise use the environment we-captured along with 'arg'.  This transfer of in-scope set is done by-setInScopeFromE.--}------------------------zapSubstEnv :: SimplEnv -> SimplEnv-zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}--setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv-setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }--mkContEx :: SimplEnv -> InExpr -> SimplSR-mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e--{--************************************************************************-*                                                                      *-\subsection{LetFloats}-*                                                                      *-************************************************************************--Note [LetFloats]-~~~~~~~~~~~~~~~~-The LetFloats is a bunch of bindings, classified by a FloatFlag.--* All of them satisfy the let/app invariant--Examples--  NonRec x (y:ys)       FltLifted-  Rec [(x,rhs)]         FltLifted--  NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?-  NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n--  NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge--Can't happen:-  NonRec x# (a /# b)    -- Might fail; does not satisfy let/app-  NonRec x# (f y)       -- Might diverge; does not satisfy let/app--}--data LetFloats = LetFloats (OrdList OutBind) FloatFlag-                 -- See Note [LetFloats]--type JoinFloat  = OutBind-type JoinFloats = OrdList JoinFloat--data FloatFlag-  = FltLifted   -- All bindings are lifted and lazy *or*-                --     consist of a single primitive string literal-                --  Hence ok to float to top level, or recursive--  | FltOkSpec   -- All bindings are FltLifted *or*-                --      strict (perhaps because unlifted,-                --      perhaps because of a strict binder),-                --        *and* ok-for-speculation-                --  Hence ok to float out of the RHS-                --  of a lazy non-recursive let binding-                --  (but not to top level, or into a rec group)--  | FltCareful  -- At least one binding is strict (or unlifted)-                --      and not guaranteed cheap-                --      Do not float these bindings out of a lazy let--instance Outputable LetFloats where-  ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds)--instance Outputable FloatFlag where-  ppr FltLifted  = text "FltLifted"-  ppr FltOkSpec  = text "FltOkSpec"-  ppr FltCareful = text "FltCareful"--andFF :: FloatFlag -> FloatFlag -> FloatFlag-andFF FltCareful _          = FltCareful-andFF FltOkSpec  FltCareful = FltCareful-andFF FltOkSpec  _          = FltOkSpec-andFF FltLifted  flt        = flt--doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool--- If you change this function look also at FloatIn.noFloatFromRhs-doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs-  =  not (isNilOL fs) && want_to_float && can_float-  where-     want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs-                     -- See Note [Float when cheap or expandable]-     can_float = case ff of-                   FltLifted  -> True-                   FltOkSpec  -> isNotTopLevel lvl && isNonRec rec-                   FltCareful -> isNotTopLevel lvl && isNonRec rec && str--{--Note [Float when cheap or expandable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to float a let from a let if the residual RHS is-   a) cheap, such as (\x. blah)-   b) expandable, such as (f b) if f is CONLIKE-But there are-  - cheap things that are not expandable (eg \x. expensive)-  - expandable things that are not cheap (eg (f b) where b is CONLIKE)-so we must take the 'or' of the two.--}--emptyLetFloats :: LetFloats-emptyLetFloats = LetFloats nilOL FltLifted--emptyJoinFloats :: JoinFloats-emptyJoinFloats = nilOL--unitLetFloat :: OutBind -> LetFloats--- This key function constructs a singleton float with the right form-unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))-                    LetFloats (unitOL bind) (flag bind)-  where-    flag (Rec {})                = FltLifted-    flag (NonRec bndr rhs)-      | not (isStrictId bndr)    = FltLifted-      | exprIsTickedString rhs   = FltLifted-          -- String literals can be floated freely.-          -- See Note [Core top-level string literals] in GHC.Core.-      | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)-      | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )-                                   FltCareful-      -- Unlifted binders can only be let-bound if exprOkForSpeculation holds--unitJoinFloat :: OutBind -> JoinFloats-unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))-                     unitOL bind--mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)--- Make a singleton SimplFloats, and--- extend the incoming SimplEnv's in-scope set with its binders--- These binders may already be in the in-scope set,--- but may have by now been augmented with more IdInfo-mkFloatBind env bind-  = (floats, env { seInScope = in_scope' })-  where-    floats-      | isJoinBind bind-      = SimplFloats { sfLetFloats  = emptyLetFloats-                    , sfJoinFloats = unitJoinFloat bind-                    , sfInScope    = in_scope' }-      | otherwise-      = SimplFloats { sfLetFloats  = unitLetFloat bind-                    , sfJoinFloats = emptyJoinFloats-                    , sfInScope    = in_scope' }--    in_scope' = seInScope env `extendInScopeSetBind` bind--extendFloats :: SimplFloats -> OutBind -> SimplFloats--- Add this binding to the floats, and extend the in-scope env too-extendFloats (SimplFloats { sfLetFloats  = floats-                          , sfJoinFloats = jfloats-                          , sfInScope    = in_scope })-             bind-  | isJoinBind bind-  = SimplFloats { sfInScope    = in_scope'-                , sfLetFloats  = floats-                , sfJoinFloats = jfloats' }-  | otherwise-  = SimplFloats { sfInScope    = in_scope'-                , sfLetFloats  = floats'-                , sfJoinFloats = jfloats }-  where-    in_scope' = in_scope `extendInScopeSetBind` bind-    floats'   = floats  `addLetFlts`  unitLetFloat bind-    jfloats'  = jfloats `addJoinFlts` unitJoinFloat bind--addLetFloats :: SimplFloats -> LetFloats -> SimplFloats--- Add the let-floats for env2 to env1;--- *plus* the in-scope set for env2, which is bigger--- than that for env1-addLetFloats floats let_floats@(LetFloats binds _)-  = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats-           , sfInScope   = foldlOL extendInScopeSetBind-                                   (sfInScope floats) binds }--addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats-addJoinFloats floats join_floats-  = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats-           , sfInScope    = foldlOL extendInScopeSetBind-                                    (sfInScope floats) join_floats }--extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet-extendInScopeSetBind in_scope bind-  = extendInScopeSetList in_scope (bindersOf bind)--addFloats :: SimplFloats -> SimplFloats -> SimplFloats--- Add both let-floats and join-floats for env2 to env1;--- *plus* the in-scope set for env2, which is bigger--- than that for env1-addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 })-          (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope })-  = SimplFloats { sfLetFloats  = lf1 `addLetFlts` lf2-                , sfJoinFloats = jf1 `addJoinFlts` jf2-                , sfInScope    = in_scope }--addLetFlts :: LetFloats -> LetFloats -> LetFloats-addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2)-  = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2)--letFloatBinds :: LetFloats -> [CoreBind]-letFloatBinds (LetFloats bs _) = fromOL bs--addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats-addJoinFlts = appOL--mkRecFloats :: SimplFloats -> SimplFloats--- Flattens the floats from env2 into a single Rec group,--- They must either all be lifted LetFloats or all JoinFloats-mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs ff-                                , sfJoinFloats = jbs-                                , sfInScope    = in_scope })-  = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )-    ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )-    SimplFloats { sfLetFloats  = floats'-                , sfJoinFloats = jfloats'-                , sfInScope    = in_scope }-  where-    floats'  | isNilOL bs  = emptyLetFloats-             | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))-    jfloats' | isNilOL jbs = emptyJoinFloats-             | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))--wrapFloats :: SimplFloats -> OutExpr -> OutExpr--- Wrap the floats around the expression; they should all--- satisfy the let/app invariant, so mkLets should do the job just fine-wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs _-                        , sfJoinFloats = jbs }) body-  = foldrOL Let (wrapJoinFloats jbs body) bs-     -- Note: Always safe to put the joins on the inside-     -- since the values can't refer to them--wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr)--- Wrap the sfJoinFloats of the env around the expression,--- and take them out of the SimplEnv-wrapJoinFloatsX floats body-  = ( floats { sfJoinFloats = emptyJoinFloats }-    , wrapJoinFloats (sfJoinFloats floats) body )--wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr--- Wrap the sfJoinFloats of the env around the expression,--- and take them out of the SimplEnv-wrapJoinFloats join_floats body-  = foldrOL Let body join_floats--getTopFloatBinds :: SimplFloats -> [CoreBind]-getTopFloatBinds (SimplFloats { sfLetFloats  = lbs-                              , sfJoinFloats = jbs})-  = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings-    letFloatBinds lbs--mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats-mapLetFloats (LetFloats fs ff) fun-   = LetFloats (mapOL app fs) ff-   where-    app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'-    app (Rec bs)     = Rec (map fun bs)--{--************************************************************************-*                                                                      *-                Substitution of Vars-*                                                                      *-************************************************************************--Note [Global Ids in the substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We look up even a global (eg imported) Id in the substitution. Consider-   case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }-The binder-swap in the occurrence analyser will add a binding-for a LocalId version of g (with the same unique though):-   case X.g_34 of b { (a,b) ->  let g_34 = b in-                                ... case X.g_34 of { (p,q) -> ...} ... }-So we want to look up the inner X.g_34 in the substitution, where we'll-find that it has been substituted by b.  (Or conceivably cloned.)--}--substId :: SimplEnv -> InId -> SimplSR--- Returns DoneEx only on a non-Var expression-substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v-  = case lookupVarEnv ids v of  -- Note [Global Ids in the substitution]-        Nothing               -> DoneId (refineFromInScope in_scope v)-        Just (DoneId v)       -> DoneId (refineFromInScope in_scope v)-        Just res              -> res    -- DoneEx non-var, or ContEx--        -- Get the most up-to-date thing from the in-scope set-        -- Even though it isn't in the substitution, it may be in-        -- the in-scope set with better IdInfo.-        ---        -- See also Note [In-scope set as a substitution] in Simplify.--refineFromInScope :: InScopeSet -> Var -> Var-refineFromInScope in_scope v-  | isLocalId v = case lookupInScope in_scope v of-                  Just v' -> v'-                  Nothing -> WARN( True, ppr v ) v  -- This is an error!-  | otherwise = v--lookupRecBndr :: SimplEnv -> InId -> OutId--- Look up an Id which has been put into the envt by simplRecBndrs,--- but where we have not yet done its RHS-lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v-  = case lookupVarEnv ids v of-        Just (DoneId v) -> v-        Just _ -> pprPanic "lookupRecBndr" (ppr v)-        Nothing -> refineFromInScope in_scope v--{--************************************************************************-*                                                                      *-\section{Substituting an Id binder}-*                                                                      *-************************************************************************---These functions are in the monad only so that they can be made strict via seq.--Note [Return type for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--   (join j :: Char -> Int -> Int) 77-   (     j x = \y. y + ord x    )-   (in case v of                )-   (     A -> j 'x'             )-   (     B -> j 'y'             )-   (     C -> <blah>            )--The simplifier pushes the "apply to 77" continuation inwards to give--   join j :: Char -> Int-        j x = (\y. y + ord x) 77-   in case v of-        A -> j 'x'-        B -> j 'y'-        C -> <blah> 77--Notice that the "apply to 77" continuation went into the RHS of the-join point.  And that meant that the return type of the join point-changed!!--That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr-takes a (Just res_ty) argument so that it knows to do the type-changing-thing.--}--simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])-simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs----------------simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)--- Used for lambda and case-bound variables--- Clone Id if necessary, substitute type--- Return with IdInfo already substituted, but (fragile) occurrence info zapped--- The substitution is extended only if the variable is cloned, because--- we *don't* need to use it to track occurrence info.-simplBinder env bndr-  | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr-                        ; seqTyVar tv `seq` return (env', tv) }-  | otherwise     = do  { let (env', id) = substIdBndr Nothing env bndr-                        ; seqId id `seq` return (env', id) }------------------simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)--- A non-recursive let binder-simplNonRecBndr env id-  = do  { let (env1, id1) = substIdBndr Nothing env id-        ; seqId id1 `seq` return (env1, id1) }------------------simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr-                    -> SimplM (SimplEnv, OutBndr)--- A non-recursive let binder for a join point;--- context being pushed inward may change the type--- See Note [Return type for join points]-simplNonRecJoinBndr env res_ty id-  = do  { let (env1, id1) = substIdBndr (Just res_ty) env id-        ; seqId id1 `seq` return (env1, id1) }------------------simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv--- Recursive let binders-simplRecBndrs env@(SimplEnv {}) ids-  = ASSERT(all (not . isJoinId) ids)-    do  { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids-        ; seqIds ids1 `seq` return env1 }------------------simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv--- Recursive let binders for join points;--- context being pushed inward may change types--- See Note [Return type for join points]-simplRecJoinBndrs env@(SimplEnv {}) res_ty ids-  = ASSERT(all isJoinId ids)-    do  { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids-        ; seqIds ids1 `seq` return env1 }------------------substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr)--- Might be a coercion variable-substIdBndr new_res_ty env bndr-  | isCoVar bndr  = substCoVarBndr env bndr-  | otherwise     = substNonCoVarIdBndr new_res_ty env bndr------------------substNonCoVarIdBndr-   :: Maybe OutType -- New result type, if a join binder-                    -- See Note [Return type for join points]-   -> SimplEnv-   -> InBndr    -- Env and binder to transform-   -> (SimplEnv, OutBndr)--- Clone Id if necessary, substitute its type--- Return an Id with its---      * Type substituted---      * UnfoldingInfo, Rules, WorkerInfo zapped---      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]---      * Robust info, retained especially arity and demand info,---         so that they are available to occurrences that occur in an---         earlier binding of a letrec------ For the robust info, see Note [Arity robustness]------ Augment the substitution  if the unique changed--- Extend the in-scope set with the new Id------ Similar to GHC.Core.Subst.substIdBndr, except that---      the type of id_subst differs---      all fragile info is zapped-substNonCoVarIdBndr new_res_ty-                    env@(SimplEnv { seInScope = in_scope-                                  , seIdSubst = id_subst })-                    old_id-  = ASSERT2( not (isCoVar old_id), ppr old_id )-    (env { seInScope = in_scope `extendInScopeSet` new_id,-           seIdSubst = new_subst }, new_id)-  where-    id1    = uniqAway in_scope old_id-    id2    = substIdType env id1--    id3    | Just res_ty <- new_res_ty-           = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2)-                             -- See Note [Return type for join points]-           | otherwise-           = id2--    new_id = zapFragileIdInfo id3       -- Zaps rules, worker-info, unfolding-                                        -- and fragile OccInfo--        -- Extend the substitution if the unique has changed,-        -- or there's some useful occurrence information-        -- See the notes with substTyVarBndr for the delSubstEnv-    new_subst | new_id /= old_id-              = extendVarEnv id_subst old_id (DoneId new_id)-              | otherwise-              = delVarEnv id_subst old_id---------------------------------------seqTyVar :: TyVar -> ()-seqTyVar b = b `seq` ()--seqId :: Id -> ()-seqId id = seqType (idType id)  `seq`-           idInfo id            `seq`-           ()--seqIds :: [Id] -> ()-seqIds []       = ()-seqIds (id:ids) = seqId id `seq` seqIds ids--{--Note [Arity robustness]-~~~~~~~~~~~~~~~~~~~~~~~-We *do* transfer the arity from from the in_id of a let binding to the-out_id.  This is important, so that the arity of an Id is visible in-its own RHS.  For example:-        f = \x. ....g (\y. f y)....-We can eta-reduce the arg to g, because f is a value.  But that-needs to be visible.--This interacts with the 'state hack' too:-        f :: Bool -> IO Int-        f = \x. case x of-                  True  -> f y-                  False -> \s -> ...-Can we eta-expand f?  Only if we see that f has arity 1, and then we-take advantage of the 'state hack' on the result of-(f y) :: State# -> (State#, Int) to expand the arity one more.--There is a disadvantage though.  Making the arity visible in the RHS-allows us to eta-reduce-        f = \x -> f x-to-        f = f-which technically is not sound.   This is very much a corner case, so-I'm not worried about it.  Another idea is to ensure that f's arity-never decreases; its arity started as 1, and we should never eta-reduce-below that.---Note [Robust OccInfo]-~~~~~~~~~~~~~~~~~~~~~-It's important that we *do* retain the loop-breaker OccInfo, because-that's what stops the Id getting inlined infinitely, in the body of-the letrec.--}---{--************************************************************************-*                                                                      *-                Impedance matching to type substitution-*                                                                      *-************************************************************************--}--getTCvSubst :: SimplEnv -> TCvSubst-getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env-                      , seCvSubst = cv_env })-  = mkTCvSubst in_scope (tv_env, cv_env)--substTy :: SimplEnv -> Type -> Type-substTy env ty = Type.substTy (getTCvSubst env) ty--substTyVar :: SimplEnv -> TyVar -> Type-substTyVar env tv = Type.substTyVar (getTCvSubst env) tv--substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)-substTyVarBndr env tv-  = case Type.substTyVarBndr (getTCvSubst env) tv of-        (TCvSubst in_scope' tv_env' cv_env', tv')-           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')--substCoVar :: SimplEnv -> CoVar -> Coercion-substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv--substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)-substCoVarBndr env cv-  = case Coercion.substCoVarBndr (getTCvSubst env) cv of-        (TCvSubst in_scope' tv_env' cv_env', cv')-           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')--substCo :: SimplEnv -> Coercion -> Coercion-substCo env co = Coercion.substCo (getTCvSubst env) co---------------------substIdType :: SimplEnv -> Id -> Id-substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id-  |  (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)-  || noFreeVarsOfType old_ty-  = id-  | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)-                -- The tyCoVarsOfType is cheaper than it looks-                -- because we cache the free tyvars of the type-                -- in a Note in the id's type itself-  where-    old_ty = idType id
− compiler/simplCore/SimplMonad.hs 
@@ -1,252 +0,0 @@-{--(c) The AQUA Project, Glasgow University, 1993-1998--\section[SimplMonad]{The simplifier Monad}--}--{-# LANGUAGE DeriveFunctor #-}-module SimplMonad (-        -- The monad-        SimplM,-        initSmpl, traceSmpl,-        getSimplRules, getFamEnvs,--        -- Unique supply-        MonadUnique(..), newId, newJoinId,--        -- Counting-        SimplCount, tick, freeTick, checkedTick,-        getSimplCount, zeroSimplCount, pprSimplCount,-        plusSimplCount, isZeroSimplCount-    ) where--import GhcPrelude--import Var              ( Var, isId, mkLocalVar )-import Name             ( mkSystemVarName )-import Id               ( Id, mkSysLocalOrCoVar )-import IdInfo           ( IdDetails(..), vanillaIdInfo, setArityInfo )-import Type             ( Type, mkLamTypes )-import FamInstEnv       ( FamInstEnv )-import GHC.Core         ( RuleEnv(..) )-import UniqSupply-import GHC.Driver.Session-import CoreMonad-import Outputable-import FastString-import MonadUtils-import ErrUtils as Err-import Util                ( count )-import Panic               (throwGhcExceptionIO, GhcException (..))-import BasicTypes          ( IntWithInf, treatZeroAsInf, mkIntWithInf )-import Control.Monad       ( ap )--{--************************************************************************-*                                                                      *-\subsection{Monad plumbing}-*                                                                      *-************************************************************************--For the simplifier monad, we want to {\em thread} a unique supply and a counter.-(Command-line switches move around through the explicitly-passed SimplEnv.)--}--newtype SimplM result-  =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much-                -> UniqSupply   -- We thread the unique supply because-                                -- constantly splitting it is rather expensive-                -> SimplCount-                -> IO (result, UniqSupply, SimplCount)}-  -- we only need IO here for dump output-    deriving (Functor)--data SimplTopEnv-  = STE { st_flags     :: DynFlags-        , st_max_ticks :: IntWithInf  -- Max #ticks in this simplifier run-        , st_rules     :: RuleEnv-        , st_fams      :: (FamInstEnv, FamInstEnv) }--initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)-         -> UniqSupply          -- No init count; set to 0-         -> Int                 -- Size of the bindings, used to limit-                                -- the number of ticks we allow-         -> SimplM a-         -> IO (a, SimplCount)--initSmpl dflags rules fam_envs us size m-  = do (result, _, count) <- unSM m env us (zeroSimplCount dflags)-       return (result, count)-  where-    env = STE { st_flags = dflags, st_rules = rules-              , st_max_ticks = computeMaxTicks dflags size-              , st_fams = fam_envs }--computeMaxTicks :: DynFlags -> Int -> IntWithInf--- Compute the max simplifier ticks as---     (base-size + pgm-size) * magic-multiplier * tick-factor/100--- where---    magic-multiplier is a constant that gives reasonable results---    base-size is a constant to deal with size-zero programs-computeMaxTicks dflags size-  = treatZeroAsInf $-    fromInteger ((toInteger (size + base_size)-                  * toInteger (tick_factor * magic_multiplier))-          `div` 100)-  where-    tick_factor      = simplTickFactor dflags-    base_size        = 100-    magic_multiplier = 40-        -- MAGIC NUMBER, multiplies the simplTickFactor-        -- We can afford to be generous; this is really-        -- just checking for loops, and shouldn't usually fire-        -- A figure of 20 was too small: see #5539.--{-# INLINE thenSmpl #-}-{-# INLINE thenSmpl_ #-}-{-# INLINE returnSmpl #-}---instance Applicative SimplM where-    pure  = returnSmpl-    (<*>) = ap-    (*>)  = thenSmpl_--instance Monad SimplM where-   (>>)   = (*>)-   (>>=)  = thenSmpl--returnSmpl :: a -> SimplM a-returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))--thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b-thenSmpl_ :: SimplM a -> SimplM b -> SimplM b--thenSmpl m k-  = SM $ \st_env us0 sc0 -> do-      (m_result, us1, sc1) <- unSM m st_env us0 sc0-      unSM (k m_result) st_env us1 sc1--thenSmpl_ m k-  = SM $ \st_env us0 sc0 -> do-      (_, us1, sc1) <- unSM m st_env us0 sc0-      unSM k st_env us1 sc1---- TODO: this specializing is not allowed--- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}--- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}--- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}--traceSmpl :: String -> SDoc -> SimplM ()-traceSmpl herald doc-  = do { dflags <- getDynFlags-       ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"-           FormatText-           (hang (text herald) 2 doc) }--{--************************************************************************-*                                                                      *-\subsection{The unique supply}-*                                                                      *-************************************************************************--}--instance MonadUnique SimplM where-    getUniqueSupplyM-       = SM (\_st_env us sc -> case splitUniqSupply us of-                                (us1, us2) -> return (us1, us2, sc))--    getUniqueM-       = SM (\_st_env us sc -> case takeUniqFromSupply us of-                                (u, us') -> return (u, us', sc))--    getUniquesM-        = SM (\_st_env us sc -> case splitUniqSupply us of-                                (us1, us2) -> return (uniqsFromSupply us1, us2, sc))--instance HasDynFlags SimplM where-    getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))--instance MonadIO SimplM where-    liftIO m = SM $ \_ us sc -> do-      x <- m-      return (x, us, sc)--getSimplRules :: SimplM RuleEnv-getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))--getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)-getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))--newId :: FastString -> Type -> SimplM Id-newId fs ty = do uniq <- getUniqueM-                 return (mkSysLocalOrCoVar fs uniq ty)--newJoinId :: [Var] -> Type -> SimplM Id-newJoinId bndrs body_ty-  = do { uniq <- getUniqueM-       ; let name       = mkSystemVarName uniq (fsLit "$j")-             join_id_ty = mkLamTypes bndrs body_ty  -- Note [Funky mkLamTypes]-             arity      = count isId bndrs-             -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core-             join_arity = length bndrs-             details    = JoinId join_arity-             id_info    = vanillaIdInfo `setArityInfo` arity---                                        `setOccInfo` strongLoopBreaker--       ; return (mkLocalVar details name join_id_ty id_info) }--{--************************************************************************-*                                                                      *-\subsection{Counting up what we've done}-*                                                                      *-************************************************************************--}--getSimplCount :: SimplM SimplCount-getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))--tick :: Tick -> SimplM ()-tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc-                              in sc' `seq` return ((), us, sc'))--checkedTick :: Tick -> SimplM ()--- Try to take a tick, but fail if too many-checkedTick t-  = SM (\st_env us sc ->-           if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)-           then throwGhcExceptionIO $-                  PprProgramError "Simplifier ticks exhausted" (msg sc)-           else let sc' = doSimplTick (st_flags st_env) t sc-                in sc' `seq` return ((), us, sc'))-  where-    msg sc = vcat-      [ text "When trying" <+> ppr t-      , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."-      , space-      , text "If you need to increase the limit substantially, please file a"-      , text "bug report and indicate the factor you needed."-      , space-      , text "If GHC was unable to complete compilation even"-               <+> text "with a very large factor"-      , text "(a thousand or more), please consult the"-                <+> doubleQuotes (text "Known bugs or infelicities")-      , text "section in the Users Guide before filing a report. There are a"-      , text "few situations unlikely to occur in practical programs for which"-      , text "simplifier non-termination has been judged acceptable."-      , space-      , pp_details sc-      , pprSimplCount sc ]-    pp_details sc-      | hasDetailedCounts sc = empty-      | otherwise = text "To see detailed counts use -ddump-simpl-stats"---freeTick :: Tick -> SimplM ()--- Record a tick, but don't add to the total tick count, which is--- used to decide when nothing further has happened-freeTick t-   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc-                           in sc' `seq` return ((), us, sc'))
− compiler/simplCore/SimplUtils.hs 
@@ -1,2324 +0,0 @@-{--(c) The AQUA Project, Glasgow University, 1993-1998--\section[SimplUtils]{The simplifier utilities}--}--{-# LANGUAGE CPP #-}--module SimplUtils (-        -- Rebuilding-        mkLam, mkCase, prepareAlts, tryEtaExpandRhs,--        -- Inlining,-        preInlineUnconditionally, postInlineUnconditionally,-        activeUnfolding, activeRule,-        getUnfoldingInRuleMatch,-        simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,--        -- The continuation type-        SimplCont(..), DupFlag(..), StaticEnv,-        isSimplified, contIsStop,-        contIsDupable, contResultType, contHoleType,-        contIsTrivial, contArgs,-        countArgs,-        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,-        interestingCallContext,--        -- ArgInfo-        ArgInfo(..), ArgSpec(..), mkArgInfo,-        addValArgTo, addCastTo, addTyArgTo,-        argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,--        abstractFloats,--        -- Utilities-        isExitJoinId-    ) where--#include "HsVersions.h"--import GhcPrelude--import SimplEnv-import CoreMonad        ( SimplMode(..), Tick(..) )-import GHC.Driver.Session-import GHC.Core-import qualified GHC.Core.Subst-import GHC.Core.Ppr-import TyCoPpr          ( pprParendType )-import GHC.Core.FVs-import GHC.Core.Utils-import GHC.Core.Arity-import GHC.Core.Unfold-import Name-import Id-import IdInfo-import Var-import Demand-import SimplMonad-import Type     hiding( substTy )-import Coercion hiding( substCo )-import DataCon          ( dataConWorkId, isNullaryRepDataCon )-import VarSet-import BasicTypes-import Util-import OrdList          ( isNilOL )-import MonadUtils-import Outputable-import PrelRules-import FastString       ( fsLit )--import Control.Monad    ( when )-import Data.List        ( sortBy )--{--************************************************************************-*                                                                      *-                The SimplCont and DupFlag types-*                                                                      *-************************************************************************--A SimplCont allows the simplifier to traverse the expression in a-zipper-like fashion.  The SimplCont represents the rest of the expression,-"above" the point of interest.--You can also think of a SimplCont as an "evaluation context", using-that term in the way it is used for operational semantics. This is the-way I usually think of it, For example you'll often see a syntax for-evaluation context looking like-        C ::= []  |  C e   |  case C of alts  |  C `cast` co-That's the kind of thing we are doing here, and I use that syntax in-the comments.---Key points:-  * A SimplCont describes a *strict* context (just like-    evaluation contexts do).  E.g. Just [] is not a SimplCont--  * A SimplCont describes a context that *does not* bind-    any variables.  E.g. \x. [] is not a SimplCont--}--data SimplCont-  = Stop                -- Stop[e] = e-        OutType         -- Type of the <hole>-        CallCtxt        -- Tells if there is something interesting about-                        --          the context, and hence the inliner-                        --          should be a bit keener (see interestingCallContext)-                        -- Specifically:-                        --     This is an argument of a function that has RULES-                        --     Inlining the call might allow the rule to fire-                        -- Never ValAppCxt (use ApplyToVal instead)-                        -- or CaseCtxt (use Select instead)--  | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]-        OutCoercion             -- The coercion simplified-                                -- Invariant: never an identity coercion-        SimplCont--  | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]-      { sc_dup  :: DupFlag      -- See Note [DupFlag invariants]-      , sc_arg  :: InExpr       -- The argument,-      , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]-      , sc_cont :: SimplCont }--  | 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]-      , sc_cont    :: SimplCont }--  | Select             -- (Select alts K)[e] = K[ case e of alts ]-      { sc_dup  :: DupFlag        -- See Note [DupFlag invariants]-      , sc_bndr :: InId           -- case binder-      , sc_alts :: [InAlt]        -- Alternatives-      , sc_env  :: StaticEnv      -- See Note [StaticEnv invariant]-      , sc_cont :: SimplCont }--  -- The two strict forms have no DupFlag, because we never duplicate them-  | StrictBind          -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b]-                        --       or, equivalently,  = K[ (\x xs.b) e ]-      { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]-      , sc_bndr  :: InId-      , sc_bndrs :: [InBndr]-      , sc_body  :: InExpr-      , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]-      , sc_cont  :: SimplCont }--  | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]-      { sc_dup  :: DupFlag     -- Always Simplified or OkToDup-      , sc_fun  :: ArgInfo     -- Specifies f, e1..en, Whether f has rules, etc-                               --     plus strictness flags for *further* args-      , sc_cci  :: CallCtxt    -- Whether *this* argument position is interesting-      , sc_cont :: SimplCont }--  | TickIt              -- (TickIt t K)[e] = K[ tick t e ]-        (Tickish Id)    -- Tick tickish <hole>-        SimplCont--type StaticEnv = SimplEnv       -- Just the static part is relevant--data DupFlag = NoDup       -- Unsimplified, might be big-             | Simplified  -- Simplified-             | OkToDup     -- Simplified and small--isSimplified :: DupFlag -> Bool-isSimplified NoDup = False-isSimplified _     = True       -- Invariant: the subst-env is empty--perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type-perhapsSubstTy dup env ty-  | isSimplified dup = ty-  | otherwise        = substTy env ty--{- Note [StaticEnv invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We pair up an InExpr or InAlts with a StaticEnv, which establishes the-lexical scope for that InExpr.  When we simplify that InExpr/InAlts, we-use-  - Its captured StaticEnv-  - Overriding its InScopeSet with the larger one at the-    simplification point.--Why override the InScopeSet?  Example:-      (let y = ey in f) ex-By the time we simplify ex, 'y' will be in scope.--However the InScopeSet in the StaticEnv is not irrelevant: it should-include all the free vars of applying the substitution to the InExpr.-Reason: contHoleType uses perhapsSubstTy to apply the substitution to-the expression, and that (rightly) gives ASSERT failures if the InScopeSet-isn't big enough.--Note [DupFlag invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~-In both (ApplyToVal dup _ env k)-   and  (Select dup _ _ env k)-the following invariants hold--  (a) if dup = OkToDup, then continuation k is also ok-to-dup-  (b) if dup = OkToDup or Simplified, the subst-env is empty-      (and and hence no need to re-simplify)--}--instance Outputable DupFlag where-  ppr OkToDup    = text "ok"-  ppr NoDup      = text "nodup"-  ppr Simplified = text "simpl"--instance Outputable SimplCont where-  ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty-  ppr (CastIt co cont  )    = (text "CastIt" <+> pprOptCo co) $$ ppr cont-  ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont-  ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })-    = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont-  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })-    = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)-                                        $$ ppr cont-  ppr (StrictBind { sc_bndr = b, sc_cont = cont })-    = (text "StrictBind" <+> ppr b) $$ ppr cont-  ppr (StrictArg { sc_fun = ai, sc_cont = cont })-    = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont-  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })-    = (text "Select" <+> ppr dup <+> ppr bndr) $$-       whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont---{- Note [The hole type in ApplyToTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The sc_hole_ty field of ApplyToTy records the type of the "hole" in the-continuation.  It is absolutely necessary to compute contHoleType, but it is-not used for anything else (and hence may not be evaluated).--Why is it necessary for contHoleType?  Consider the continuation-     ApplyToType Int (Stop Int)-corresponding to-     (<hole> @Int) :: Int-What is the type of <hole>?  It could be (forall a. Int) or (forall a. a),-and there is no way to know which, so we must record it.--In a chain of applications  (f @t1 @t2 @t3) we'll lazily compute exprType-for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably-doesn't matter because we'll never compute them all.--************************************************************************-*                                                                      *-                ArgInfo and ArgSpec-*                                                                      *-************************************************************************--}--data ArgInfo-  = ArgInfo {-        ai_fun   :: OutId,      -- The function-        ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)--        ai_type  :: OutType,    -- Type of (f a1 ... an)--        ai_rules :: FunRules,   -- Rules for this function--        ai_encl :: Bool,        -- Flag saying whether this function-                                -- or an enclosing one has rules (recursively)-                                --      True => be keener to inline in all args--        ai_strs :: [Bool],      -- Strictness of remaining arguments-                                --   Usually infinite, but if it is finite it guarantees-                                --   that the function diverges after being given-                                --   that number of args-        ai_discs :: [Int]       -- Discounts for remaining arguments; non-zero => be keener to inline-                                --   Always infinite-    }--data ArgSpec-  = ValArg OutExpr                    -- Apply to this (coercion or value); c.f. ApplyToVal-  | TyArg { as_arg_ty  :: OutType     -- Apply to this type; c.f. ApplyToTy-          , as_hole_ty :: OutType }   -- Type of the function (presumably forall a. blah)-  | CastBy OutCoercion                -- Cast by this; c.f. CastIt--instance Outputable ArgSpec where-  ppr (ValArg e)                 = text "ValArg" <+> ppr e-  ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty-  ppr (CastBy c)                 = text "CastBy" <+> ppr c--addValArgTo :: ArgInfo -> OutExpr -> ArgInfo-addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai-                        , ai_type = applyTypeToArg (ai_type ai) arg-                        , ai_rules = decRules (ai_rules ai) }--addTyArgTo :: ArgInfo -> OutType -> ArgInfo-addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai-                          , ai_type = piResultTy poly_fun_ty arg_ty-                          , ai_rules = decRules (ai_rules ai) }-  where-    poly_fun_ty = ai_type ai-    arg_spec    = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty }--addCastTo :: ArgInfo -> OutCoercion -> ArgInfo-addCastTo ai co = ai { ai_args = CastBy co : ai_args ai-                     , ai_type = coercionRKind co }--argInfoAppArgs :: [ArgSpec] -> [OutExpr]-argInfoAppArgs []                              = []-argInfoAppArgs (CastBy {}                : _)  = []  -- Stop at a cast-argInfoAppArgs (ValArg e                 : as) = e       : argInfoAppArgs as-argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as--pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont-pushSimplifiedArgs _env []           k = k-pushSimplifiedArgs env  (arg : args) k-  = case arg of-      TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }-               -> ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }-      ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest }-      CastBy c -> CastIt c rest-  where-    rest = pushSimplifiedArgs env args k-           -- The env has an empty SubstEnv--argInfoExpr :: OutId -> [ArgSpec] -> OutExpr--- NB: the [ArgSpec] is reversed so that the first arg--- in the list is the last one in the application-argInfoExpr fun rev_args-  = go rev_args-  where-    go []                              = Var fun-    go (ValArg a                 : as) = go as `App` a-    go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty-    go (CastBy co                : as) = mkCast (go as) co---type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function-     -- Nothing => No rules-     -- Just (n, rules) => some rules, requiring at least n more type/value args--decRules :: FunRules -> FunRules-decRules (Just (n, rules)) = Just (n-1, rules)-decRules Nothing           = Nothing--mkFunRules :: [CoreRule] -> FunRules-mkFunRules [] = Nothing-mkFunRules rs = Just (n_required, rs)-  where-    n_required = maximum (map ruleArity rs)--{--************************************************************************-*                                                                      *-                Functions on SimplCont-*                                                                      *-************************************************************************--}--mkBoringStop :: OutType -> SimplCont-mkBoringStop ty = Stop ty BoringCtxt--mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in GHC.Core.Unfold-mkRhsStop ty = Stop ty RhsCtxt--mkLazyArgStop :: OutType -> CallCtxt -> SimplCont-mkLazyArgStop ty cci = Stop ty cci----------------------contIsRhsOrArg :: SimplCont -> Bool-contIsRhsOrArg (Stop {})       = True-contIsRhsOrArg (StrictBind {}) = True-contIsRhsOrArg (StrictArg {})  = True-contIsRhsOrArg _               = False--contIsRhs :: SimplCont -> Bool-contIsRhs (Stop _ RhsCtxt) = True-contIsRhs _                = False----------------------contIsStop :: SimplCont -> Bool-contIsStop (Stop {}) = True-contIsStop _         = False--contIsDupable :: SimplCont -> Bool-contIsDupable (Stop {})                         = True-contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k-contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]-contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto...-contIsDupable (StrictArg { sc_dup = OkToDup })  = True -- ...ditto...-contIsDupable (CastIt _ k)                      = contIsDupable k-contIsDupable _                                 = False----------------------contIsTrivial :: SimplCont -> Bool-contIsTrivial (Stop {})                                         = True-contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k-contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k-contIsTrivial (CastIt _ k)                                      = contIsTrivial k-contIsTrivial _                                                 = False----------------------contResultType :: SimplCont -> OutType-contResultType (Stop ty _)                  = ty-contResultType (CastIt _ k)                 = contResultType k-contResultType (StrictBind { sc_cont = k }) = contResultType k-contResultType (StrictArg { sc_cont = k })  = contResultType k-contResultType (Select { sc_cont = k })     = contResultType k-contResultType (ApplyToTy  { sc_cont = k }) = contResultType k-contResultType (ApplyToVal { sc_cont = k }) = contResultType k-contResultType (TickIt _ k)                 = contResultType k--contHoleType :: SimplCont -> OutType-contHoleType (Stop ty _)                      = ty-contHoleType (TickIt _ k)                     = contHoleType k-contHoleType (CastIt co _)                    = coercionLKind co-contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })-  = perhapsSubstTy dup se (idType b)-contHoleType (StrictArg { sc_fun = ai })      = funArgTy (ai_type ai)-contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]-contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k })-  = mkVisFunTy (perhapsSubstTy dup se (exprType e))-               (contHoleType k)-contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })-  = perhapsSubstTy d se (idType b)----------------------countArgs :: SimplCont -> Int--- Count all arguments, including types, coercions, and other values-countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont-countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont-countArgs _                               = 0--contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)--- Summarises value args, discards type args and coercions--- The returned continuation of the call is only used to--- answer questions like "are you interesting?"-contArgs cont-  | lone cont = (True, [], cont)-  | otherwise = go [] cont-  where-    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in GHC.Core.Unfold-    lone (ApplyToVal {}) = False-    lone (CastIt {})     = False-    lone _               = True--    go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })-                                        = go (is_interesting arg se : args) k-    go args (ApplyToTy { sc_cont = k }) = go args k-    go args (CastIt _ k)                = go args k-    go args k                           = (False, reverse args, k)--    is_interesting arg se = interestingArg se arg-                   -- Do *not* use short-cutting substitution here-                   -- because we want to get as much IdInfo as possible-----------------------mkArgInfo :: SimplEnv-          -> Id-          -> [CoreRule] -- Rules for function-          -> Int        -- Number of value args-          -> SimplCont  -- Context of the call-          -> ArgInfo--mkArgInfo env fun rules n_val_args call_cont-  | n_val_args < idArity fun            -- Note [Unsaturated functions]-  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty-            , ai_rules = fun_rules-            , ai_encl = False-            , ai_strs = vanilla_stricts-            , ai_discs = vanilla_discounts }-  | otherwise-  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty-            , ai_rules = fun_rules-            , ai_encl  = interestingArgContext rules call_cont-            , ai_strs  = arg_stricts-            , ai_discs = arg_discounts }-  where-    fun_ty = idType fun--    fun_rules = mkFunRules rules--    vanilla_discounts, arg_discounts :: [Int]-    vanilla_discounts = repeat 0-    arg_discounts = case idUnfolding fun of-                        CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}-                              -> discounts ++ vanilla_discounts-                        _     -> vanilla_discounts--    vanilla_stricts, arg_stricts :: [Bool]-    vanilla_stricts  = repeat False--    arg_stricts-      | not (sm_inline (seMode env))-      = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False]-      | otherwise-      = add_type_str fun_ty $-        case splitStrictSig (idStrictness fun) of-          (demands, result_info)-                | not (demands `lengthExceeds` n_val_args)-                ->      -- Enough args, use the strictness given.-                        -- For bottoming functions we used to pretend that the arg-                        -- is lazy, so that we don't treat the arg as an-                        -- interesting context.  This avoids substituting-                        -- top-level bindings for (say) strings into-                        -- calls to error.  But now we are more careful about-                        -- inlining lone variables, so its ok (see SimplUtils.analyseCont)-                   if isBotDiv result_info then-                        map isStrictDmd demands         -- Finite => result is bottom-                   else-                        map isStrictDmd demands ++ vanilla_stricts-               | otherwise-               -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)-                                <+> ppr n_val_args <+> ppr demands )-                   vanilla_stricts      -- Not enough args, or no strictness--    add_type_str :: Type -> [Bool] -> [Bool]-    -- If the function arg types are strict, record that in the 'strictness bits'-    -- No need to instantiate because unboxed types (which dominate the strict-    --   types) can't instantiate type variables.-    -- add_type_str is done repeatedly (for each call);-    --   might be better once-for-all in the function-    -- But beware primops/datacons with no strictness--    add_type_str _ [] = []-    add_type_str fun_ty all_strs@(str:strs)-      | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info-      = (str || Just False == isLiftedType_maybe arg_ty)-        : add_type_str fun_ty' strs-          -- If the type is levity-polymorphic, we can't know whether it's-          -- strict. isLiftedType_maybe will return Just False only when-          -- we're sure the type is unlifted.--      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty-      = add_type_str fun_ty' all_strs     -- Look through foralls--      | otherwise-      = all_strs--{- Note [Unsaturated functions]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (test eyeball/inline4)-        x = a:as-        y = f x-where f has arity 2.  Then we do not want to inline 'x', because-it'll just be floated out again.  Even if f has lots of discounts-on its first argument -- it must be saturated for these to kick in--Note [Do not expose strictness if sm_inline=False]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-#15163 showed a case in which we had--  {-# INLINE [1] zip #-}-  zip = undefined--  {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}--If we expose zip's bottoming nature when simplifying the LHS of the-RULE we get-  {-# RULES "foo" forall as bs.-                   stream (case zip of {}) = ..blah... #-}-discarding the arguments to zip.  Usually this is fine, but on the-LHS of a rule it's not, because 'as' and 'bs' are now not bound on-the LHS.--This is a pretty pathological example, so I'm not losing sleep over-it, but the simplest solution was to check sm_inline; if it is False,-which it is on the LHS of a rule (see updModeForRules), then don't-make use of the strictness info for the function.--}---{--************************************************************************-*                                                                      *-        Interesting arguments-*                                                                      *-************************************************************************--Note [Interesting call context]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to avoid inlining an expression where there can't possibly be-any gain, such as in an argument position.  Hence, if the continuation-is interesting (eg. a case scrutinee, application etc.) then we-inline, otherwise we don't.--Previously some_benefit used to return True only if the variable was-applied to some value arguments.  This didn't work:--        let x = _coerce_ (T Int) Int (I# 3) in-        case _coerce_ Int (T Int) x of-                I# y -> ....--we want to inline x, but can't see that it's a constructor in a case-scrutinee position, and some_benefit is False.--Another example:--dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)--....  case dMonadST _@_ x0 of (a,b,c) -> ....--we'd really like to inline dMonadST here, but we *don't* want to-inline if the case expression is just--        case x of y { DEFAULT -> ... }--since we can just eliminate this case instead (x is in WHNF).  Similar-applies when x is bound to a lambda expression.  Hence-contIsInteresting looks for case expressions with just a single-default case.--Note [No case of case is boring]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we see-   case f x of <alts>--we'd usually treat the context as interesting, to encourage 'f' to-inline.  But if case-of-case is off, it's really not so interesting-after all, because we are unlikely to be able to push the case-expression into the branches of any case in f's unfolding.  So, to-reduce unnecessary code expansion, we just make the context look boring.-This made a small compile-time perf improvement in perf/compiler/T6048,-and it looks plausible to me.--}--interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt--- See Note [Interesting call context]-interestingCallContext env cont-  = interesting cont-  where-    interesting (Select {})-       | sm_case_case (getMode env) = CaseCtxt-       | otherwise                  = BoringCtxt-       -- See Note [No case of case is boring]--    interesting (ApplyToVal {}) = ValAppCtxt-        -- Can happen if we have (f Int |> co) y-        -- If f has an INLINE prag we need to give it some-        -- motivation to inline. See Note [Cast then apply]-        -- in GHC.Core.Unfold--    interesting (StrictArg { sc_cci = cci }) = cci-    interesting (StrictBind {})              = BoringCtxt-    interesting (Stop _ cci)                 = cci-    interesting (TickIt _ k)                 = interesting k-    interesting (ApplyToTy { sc_cont = k })  = interesting k-    interesting (CastIt _ k)                 = interesting k-        -- If this call is the arg of a strict function, the context-        -- is a bit interesting.  If we inline here, we may get useful-        -- evaluation information to avoid repeated evals: e.g.-        --      x + (y * z)-        -- Here the contIsInteresting makes the '*' keener to inline,-        -- which in turn exposes a constructor which makes the '+' inline.-        -- Assuming that +,* aren't small enough to inline regardless.-        ---        -- It's also very important to inline in a strict context for things-        -- like-        --              foldr k z (f x)-        -- Here, the context of (f x) is strict, and if f's unfolding is-        -- a build it's *great* to inline it here.  So we must ensure that-        -- the context for (f x) is not totally uninteresting.--interestingArgContext :: [CoreRule] -> SimplCont -> Bool--- If the argument has form (f x y), where x,y are boring,--- and f is marked INLINE, then we don't want to inline f.--- But if the context of the argument is---      g (f x y)--- where g has rules, then we *do* want to inline f, in case it--- exposes a rule that might fire.  Similarly, if the context is---      h (g (f x x))--- where h has rules, then we do want to inline f; hence the--- call_cont argument to interestingArgContext------ The ai-rules flag makes this happen; if it's--- set, the inliner gets just enough keener to inline f--- regardless of how boring f's arguments are, if it's marked INLINE------ The alternative would be to *always* inline an INLINE function,--- regardless of how boring its context is; but that seems overkill--- For example, it'd mean that wrapper functions were always inlined------ The call_cont passed to interestingArgContext is the context of--- the call itself, e.g. g <hole> in the example above-interestingArgContext rules call_cont-  = notNull rules || enclosing_fn_has_rules-  where-    enclosing_fn_has_rules = go call_cont--    go (Select {})                  = False-    go (ApplyToVal {})              = False  -- Shouldn't really happen-    go (ApplyToTy  {})              = False  -- Ditto-    go (StrictArg { sc_cci = cci }) = interesting cci-    go (StrictBind {})              = False      -- ??-    go (CastIt _ c)                 = go c-    go (Stop _ cci)                 = interesting cci-    go (TickIt _ c)                 = go c--    interesting RuleArgCtxt = True-    interesting _           = False---{- Note [Interesting arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An argument is interesting if it deserves a discount for unfoldings-with a discount in that argument position.  The idea is to avoid-unfolding a function that is applied only to variables that have no-unfolding (i.e. they are probably lambda bound): f x y z There is-little point in inlining f here.--Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But-we must look through lets, eg (let x = e in C a b), because the let will-float, exposing the value, if we inline.  That makes it different to-exprIsHNF.--Before 2009 we said it was interesting if the argument had *any* structure-at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see #3016.--But we don't regard (f x y) as interesting, unless f is unsaturated.-If it's saturated and f hasn't inlined, then it's probably not going-to now!--Note [Conlike is interesting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-        f d = ...((*) d x y)...-        ... f (df d')...-where df is con-like. Then we'd really like to inline 'f' so that the-rule for (*) (df d) can fire.  To do this-  a) we give a discount for being an argument of a class-op (eg (*) d)-  b) we say that a con-like argument (eg (df d)) is interesting--}--interestingArg :: SimplEnv -> CoreExpr -> ArgSummary--- See Note [Interesting arguments]-interestingArg env e = go env 0 e-  where-    -- n is # value args to which the expression is applied-    go env n (Var v)-       = case substId env v of-           DoneId v'            -> go_var n v'-           DoneEx e _           -> go (zapSubstEnv env)             n e-           ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e--    go _   _ (Lit {})          = ValueArg-    go _   _ (Type _)          = TrivArg-    go _   _ (Coercion _)      = TrivArg-    go env n (App fn (Type _)) = go env n fn-    go env n (App fn _)        = go env (n+1) fn-    go env n (Tick _ a)        = go env n a-    go env n (Cast e _)        = go env n e-    go env n (Lam v e)-       | isTyVar v             = go env n e-       | n>0                   = NonTrivArg     -- (\x.b) e   is NonTriv-       | otherwise             = ValueArg-    go _ _ (Case {})           = NonTrivArg-    go env n (Let b e)         = case go env' n e of-                                   ValueArg -> ValueArg-                                   _        -> NonTrivArg-                               where-                                 env' = env `addNewInScopeIds` bindersOf b--    go_var n v-       | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that-                                        --    data constructors here-       | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding-       | n > 0             = NonTrivArg -- Saturated or unknown call-       | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding-                                        -- See Note [Conlike is interesting]-       | otherwise         = TrivArg    -- n==0, no useful unfolding-       where-         conlike_unfolding = isConLikeUnfolding (idUnfolding v)--{--************************************************************************-*                                                                      *-                  SimplMode-*                                                                      *-************************************************************************--The SimplMode controls several switches; see its definition in-CoreMonad-        sm_rules      :: Bool     -- Whether RULES are enabled-        sm_inline     :: Bool     -- Whether inlining is enabled-        sm_case_case  :: Bool     -- Whether case-of-case is enabled-        sm_eta_expand :: Bool     -- Whether eta-expansion is enabled--}--simplEnvForGHCi :: DynFlags -> SimplEnv-simplEnvForGHCi dflags-  = mkSimplEnv $ SimplMode { sm_names  = ["GHCi"]-                           , sm_phase  = InitialPhase-                           , sm_dflags = dflags-                           , sm_rules  = rules_on-                           , sm_inline = False-                           , sm_eta_expand = eta_expand_on-                           , sm_case_case  = True }-  where-    rules_on      = gopt Opt_EnableRewriteRules   dflags-    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags-   -- Do not do any inlining, in case we expose some unboxed-   -- tuple stuff that confuses the bytecode interpreter--updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode--- See Note [Simplifying inside stable unfoldings]-updModeForStableUnfoldings inline_rule_act current_mode-  = current_mode { sm_phase      = phaseFromActivation inline_rule_act-                 , sm_inline     = True-                 , sm_eta_expand = False }-                     -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]-       -- For sm_rules, just inherit; sm_rules might be "off"-       -- because of -fno-enable-rewrite-rules-  where-    phaseFromActivation (ActiveAfter _ n) = Phase n-    phaseFromActivation _                 = InitialPhase--updModeForRules :: SimplMode -> SimplMode--- See Note [Simplifying rules]-updModeForRules current_mode-  = current_mode { sm_phase      = InitialPhase-                 , sm_inline     = False  -- See Note [Do not expose strictness if sm_inline=False]-                 , sm_rules      = False-                 , sm_eta_expand = False }--{- Note [Simplifying rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When simplifying a rule LHS, refrain from /any/ inlining or applying-of other RULES.--Doing anything to the LHS is plain confusing, because it means that what the-rule matches is not what the user wrote. c.f. #10595, and #10528.-Moreover, inlining (or applying rules) on rule LHSs risks introducing-Ticks into the LHS, which makes matching trickier. #10665, #10745.--Doing this to either side confounds tools like HERMIT, which seek to reason-about and apply the RULES as originally written. See #10829.--Note [No eta expansion in stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have a stable unfolding--  f :: Ord a => a -> IO ()-  -- Unfolding template-  --    = /\a \(d:Ord a) (x:a). bla--we do not want to eta-expand to--  f :: Ord a => a -> IO ()-  -- Unfolding template-  --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co--because not specialisation of the overloading doesn't work properly-(see Note [Specialisation shape] in Specialise), #9509.--So we disable eta-expansion in stable unfoldings.--Note [Inlining in gentle mode]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Something is inlined if-   (i)   the sm_inline flag is on, AND-   (ii)  the thing has an INLINE pragma, AND-   (iii) the thing is inlinable in the earliest phase.--Example of why (iii) is important:-  {-# INLINE [~1] g #-}-  g = ...--  {-# INLINE f #-}-  f x = g (g x)--If we were to inline g into f's inlining, then an importing module would-never be able to do-        f e --> g (g e) ---> RULE fires-because the stable unfolding for f has had g inlined into it.--On the other hand, it is bad not to do ANY inlining into an-stable unfolding, because then recursive knots in instance declarations-don't get unravelled.--However, *sometimes* SimplGently must do no call-site inlining at all-(hence sm_inline = False).  Before full laziness we must be careful-not to inline wrappers, because doing so inhibits floating-    e.g. ...(case f x of ...)...-    ==> ...(case (case x of I# x# -> fw x#) of ...)...-    ==> ...(case x of I# x# -> case fw x# of ...)...-and now the redex (f x) isn't floatable any more.--The no-inlining thing is also important for Template Haskell.  You might be-compiling in one-shot mode with -O2; but when TH compiles a splice before-running it, we don't want to use -O2.  Indeed, we don't want to inline-anything, because the byte-code interpreter might get confused about-unboxed tuples and suchlike.--Note [Simplifying inside stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must take care with simplification inside stable unfoldings (which come from-INLINE pragmas).--First, consider the following example-        let f = \pq -> BIG-        in-        let g = \y -> f y y-            {-# INLINE g #-}-        in ...g...g...g...g...g...-Now, if that's the ONLY occurrence of f, it might be inlined inside g,-and thence copied multiple times when g is inlined. HENCE we treat-any occurrence in a stable unfolding as a multiple occurrence, not a single-one; see OccurAnal.addRuleUsage.--Second, we do want *do* to some modest rules/inlining stuff in stable-unfoldings, partly to eliminate senseless crap, and partly to break-the recursive knots generated by instance declarations.--However, suppose we have-        {-# INLINE <act> f #-}-        f = <rhs>-meaning "inline f in phases p where activation <act>(p) holds".-Then what inlinings/rules can we apply to the copy of <rhs> captured in-f's stable unfolding?  Our model is that literally <rhs> is substituted for-f when it is inlined.  So our conservative plan (implemented by-updModeForStableUnfoldings) is this:--  --------------------------------------------------------------  When simplifying the RHS of a stable unfolding, set the phase-  to the phase in which the stable unfolding first becomes active-  ---------------------------------------------------------------That ensures that--  a) Rules/inlinings that *cease* being active before p will-     not apply to the stable unfolding, consistent with it being-     inlined in its *original* form in phase p.--  b) Rules/inlinings that only become active *after* p will-     not apply to the stable unfolding, again to be consistent with-     inlining the *original* rhs in phase p.--For example,-        {-# INLINE f #-}-        f x = ...g...--        {-# NOINLINE [1] g #-}-        g y = ...--        {-# RULE h g = ... #-}-Here we must not inline g into f's RHS, even when we get to phase 0,-because when f is later inlined into some other module we want the-rule for h to fire.--Similarly, consider-        {-# INLINE f #-}-        f x = ...g...--        g y = ...-and suppose that there are auto-generated specialisations and a strictness-wrapper for g.  The specialisations get activation AlwaysActive, and the-strictness wrapper get activation (ActiveAfter 0).  So the strictness-wrepper fails the test and won't be inlined into f's stable unfolding. That-means f can inline, expose the specialised call to g, so the specialisation-rules can fire.--A note about wrappers-~~~~~~~~~~~~~~~~~~~~~-It's also important not to inline a worker back into a wrapper.-A wrapper looks like-        wraper = inline_me (\x -> ...worker... )-Normally, the inline_me prevents the worker getting inlined into-the wrapper (initially, the worker's only call site!).  But,-if the wrapper is sure to be called, the strictness analyser will-mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf-continuation.--}--activeUnfolding :: SimplMode -> Id -> Bool-activeUnfolding mode id-  | isCompulsoryUnfolding (realIdUnfolding id)-  = True   -- Even sm_inline can't override compulsory unfoldings-  | otherwise-  = isActive (sm_phase mode) (idInlineActivation id)-  && sm_inline mode-      -- `or` isStableUnfolding (realIdUnfolding id)-      -- Inline things when-      --  (a) they are active-      --  (b) sm_inline says so, except that for stable unfoldings-      --                         (ie pragmas) we inline anyway--getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv--- When matching in RULE, we want to "look through" an unfolding--- (to see a constructor) if *rules* are on, even if *inlinings*--- are not.  A notable example is DFuns, which really we want to--- match in rules like (op dfun) in gentle mode. Another example--- is 'otherwise' which we want exprIsConApp_maybe to be able to--- see very early on-getUnfoldingInRuleMatch env-  = (in_scope, id_unf)-  where-    in_scope = seInScope env-    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)-------------------------activeRule :: SimplMode -> Activation -> Bool--- Nothing => No rules at all-activeRule mode-  | not (sm_rules mode) = \_ -> False     -- Rewriting is off-  | otherwise           = isActive (sm_phase mode)--{--************************************************************************-*                                                                      *-                  preInlineUnconditionally-*                                                                      *-************************************************************************--preInlineUnconditionally-~~~~~~~~~~~~~~~~~~~~~~~~-@preInlineUnconditionally@ examines a bndr to see if it is used just-once in a completely safe way, so that it is safe to discard the-binding inline its RHS at the (unique) usage site, REGARDLESS of how-big the RHS might be.  If this is the case we don't simplify the RHS-first, but just inline it un-simplified.--This is much better than first simplifying a perhaps-huge RHS and then-inlining and re-simplifying it.  Indeed, it can be at least quadratically-better.  Consider--        x1 = e1-        x2 = e2[x1]-        x3 = e3[x2]-        ...etc...-        xN = eN[xN-1]--We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.-This can happen with cascades of functions too:--        f1 = \x1.e1-        f2 = \xs.e2[f1]-        f3 = \xs.e3[f3]-        ...etc...--THE MAIN INVARIANT is this:--        ----  preInlineUnconditionally invariant ------   IF preInlineUnconditionally chooses to inline x = <rhs>-   THEN doing the inlining should not change the occurrence-        info for the free vars of <rhs>-        ------------------------------------------------For example, it's tempting to look at trivial binding like-        x = y-and inline it unconditionally.  But suppose x is used many times,-but this is the unique occurrence of y.  Then inlining x would change-y's occurrence info, which breaks the invariant.  It matters: y-might have a BIG rhs, which will now be dup'd at every occurrence of x.---Even RHSs labelled InlineMe aren't caught here, because there might be-no benefit from inlining at the call site.--[Sept 01] Don't unconditionally inline a top-level thing, because that-can simply make a static thing into something built dynamically.  E.g.-        x = (a,b)-        main = \s -> h x--[Remember that we treat \s as a one-shot lambda.]  No point in-inlining x unless there is something interesting about the call site.--But watch out: if you aren't careful, some useful foldr/build fusion-can be lost (most notably in spectral/hartel/parstof) because the-foldr didn't see the build.  Doing the dynamic allocation isn't a big-deal, in fact, but losing the fusion can be.  But the right thing here-seems to be to do a callSiteInline based on the fact that there is-something interesting about the call site (it's strict).  Hmm.  That-seems a bit fragile.--Conclusion: inline top level things gaily until Phase 0 (the last-phase), at which point don't.--Note [pre/postInlineUnconditionally in gentle mode]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Even in gentle mode we want to do preInlineUnconditionally.  The-reason is that too little clean-up happens if you don't inline-use-once things.  Also a bit of inlining is *good* for full laziness;-it can expose constant sub-expressions.  Example in-spectral/mandel/Mandel.hs, where the mandelset function gets a useful-let-float if you inline windowToViewport--However, as usual for Gentle mode, do not inline things that are-inactive in the initial stages.  See Note [Gentle mode].--Note [Stable unfoldings and preInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!-Example--   {-# INLINE f #-}-   f :: Eq a => a -> a-   f x = ...--   fInt :: Int -> Int-   fInt = f Int dEqInt--   ...fInt...fInt...fInt...--Here f occurs just once, in the RHS of fInt. But if we inline it there-it might make fInt look big, and we'll lose the opportunity to inline f-at each of fInt's call sites.  The INLINE pragma will only inline when-the application is saturated for exactly this reason; and we don't-want PreInlineUnconditionally to second-guess it.  A live example is-#3736.-    c.f. Note [Stable unfoldings and postInlineUnconditionally]--NB: if the pragma is INLINEABLE, then we don't want to behave in-this special way -- an INLINEABLE pragma just says to GHC "inline this-if you like".  But if there is a unique occurrence, we want to inline-the stable unfolding, not the RHS.--Note [Top-level bottoming Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Don't inline top-level Ids that are bottoming, even if they are used just-once, because FloatOut has gone to some trouble to extract them out.-Inlining them won't make the program run faster!--Note [Do not inline CoVars unconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Coercion variables appear inside coercions, and the RHS of a let-binding-is a term (not a coercion) so we can't necessarily inline the latter in-the former.--}--preInlineUnconditionally-    :: SimplEnv -> TopLevelFlag -> InId-    -> InExpr -> StaticEnv  -- These two go together-    -> Maybe SimplEnv       -- Returned env has extended substitution--- Precondition: rhs satisfies the let/app invariant--- See Note [Core let/app invariant] in GHC.Core--- Reason: we don't want to inline single uses, or discard dead bindings,---         for unlifted, side-effect-ful bindings-preInlineUnconditionally env top_lvl bndr rhs rhs_env-  | not pre_inline_unconditionally           = Nothing-  | not active                               = Nothing-  | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids]-  | isCoVar bndr                             = Nothing -- Note [Do not inline CoVars unconditionally]-  | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]-                                                       -- in module Exitify-  | not (one_occ (idOccInfo bndr))           = Nothing-  | not (isStableUnfolding unf)              = Just (extend_subst_with rhs)--  -- Note [Stable unfoldings and preInlineUnconditionally]-  | isInlinablePragma inline_prag-  , Just inl <- maybeUnfoldingTemplate unf   = Just (extend_subst_with inl)-  | otherwise                                = Nothing-  where-    unf = idUnfolding bndr-    extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)--    one_occ IAmDead = True -- Happens in ((\x.1) v)-    one_occ OneOcc{ occ_one_br = InOneBranch-                  , occ_in_lam = NotInsideLam }   = isNotTopLevel top_lvl || early_phase-    one_occ OneOcc{ occ_one_br = InOneBranch-                  , occ_in_lam = IsInsideLam-                  , occ_int_cxt = IsInteresting } = canInlineInLam rhs-    one_occ _                                     = False--    pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env)-    mode   = getMode env-    active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag)-             -- See Note [pre/postInlineUnconditionally in gentle mode]-    inline_prag = idInlinePragma bndr---- Be very careful before inlining inside a lambda, because (a) we must not--- invalidate occurrence information, and (b) we want to avoid pushing a--- single allocation (here) into multiple allocations (inside lambda).--- Inlining a *function* with a single *saturated* call would be ok, mind you.---      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)---      where---              is_cheap = exprIsCheap rhs---              ok = is_cheap && int_cxt--        --      int_cxt         The context isn't totally boring-        -- E.g. let f = \ab.BIG in \y. map f xs-        --      Don't want to substitute for f, because then we allocate-        --      its closure every time the \y is called-        -- But: let f = \ab.BIG in \y. map (f y) xs-        --      Now we do want to substitute for f, even though it's not-        --      saturated, because we're going to allocate a closure for-        --      (f y) every time round the loop anyhow.--        -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,-        -- so substituting rhs inside a lambda doesn't change the occ info.-        -- Sadly, not quite the same as exprIsHNF.-    canInlineInLam (Lit _)    = True-    canInlineInLam (Lam b e)  = isRuntimeVar b || canInlineInLam e-    canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e-    canInlineInLam _          = False-      -- not ticks.  Counting ticks cannot be duplicated, and non-counting-      -- ticks around a Lam will disappear anyway.--    early_phase = case sm_phase mode of-                    Phase 0 -> False-                    _       -> True--- If we don't have this early_phase test, consider---      x = length [1,2,3]--- The full laziness pass carefully floats all the cons cells to--- top level, and preInlineUnconditionally floats them all back in.--- Result is (a) static allocation replaced by dynamic allocation---           (b) many simplifier iterations because this tickles---               a related problem; only one inlining per pass------ On the other hand, I have seen cases where top-level fusion is--- lost if we don't inline top level thing (e.g. string constants)--- Hence the test for phase zero (which is the phase for all the final--- simplifications).  Until phase zero we take no special notice of--- top level things, but then we become more leery about inlining--- them.--{--************************************************************************-*                                                                      *-                  postInlineUnconditionally-*                                                                      *-************************************************************************--postInlineUnconditionally-~~~~~~~~~~~~~~~~~~~~~~~~~-@postInlineUnconditionally@ decides whether to unconditionally inline-a thing based on the form of its RHS; in particular if it has a-trivial RHS.  If so, we can inline and discard the binding altogether.--NB: a loop breaker has must_keep_binding = True and non-loop-breakers-only have *forward* references. Hence, it's safe to discard the binding--NOTE: This isn't our last opportunity to inline.  We're at the binding-site right now, and we'll get another opportunity when we get to the-occurrence(s)--Note that we do this unconditional inlining only for trivial RHSs.-Don't inline even WHNFs inside lambdas; doing so may simply increase-allocation when the function is called. This isn't the last chance; see-NOTE above.--NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?-Because we don't even want to inline them into the RHS of constructor-arguments. See NOTE above--NB: At one time even NOINLINE was ignored here: if the rhs is trivial-it's best to inline it anyway.  We often get a=E; b=a from desugaring,-with both a and b marked NOINLINE.  But that seems incompatible with-our new view that inlining is like a RULE, so I'm sticking to the 'active'-story for now.--}--postInlineUnconditionally-    :: SimplEnv -> TopLevelFlag-    -> OutId            -- The binder (*not* a CoVar), including its unfolding-    -> OccInfo          -- From the InId-    -> OutExpr-    -> Bool--- Precondition: rhs satisfies the let/app invariant--- See Note [Core let/app invariant] in GHC.Core--- Reason: we don't want to inline single uses, or discard dead bindings,---         for unlifted, side-effect-ful bindings-postInlineUnconditionally env top_lvl bndr occ_info rhs-  | not active                  = False-  | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline-                                        -- because it might be referred to "earlier"-  | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]-  | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]-  | exprIsTrivial rhs           = True-  | otherwise-  = case occ_info of-        -- The point of examining occ_info here is that for *non-values*-        -- that occur outside a lambda, the call-site inliner won't have-        -- a chance (because it doesn't know that the thing-        -- only occurs once).   The pre-inliner won't have gotten-        -- it either, if the thing occurs in more than one branch-        -- So the main target is things like-        --      let x = f y in-        --      case v of-        --         True  -> case x of ...-        --         False -> case x of ...-        -- This is very important in practice; e.g. wheel-seive1 doubles-        -- in allocation if you miss this out-      OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt }-               -- OneOcc => no code-duplication issue-        ->     smallEnoughToInline dflags unfolding     -- Small enough to dup-                        -- ToDo: consider discount on smallEnoughToInline if int_cxt is true-                        ---                        -- NB: Do NOT inline arbitrarily big things, even if one_br is True-                        -- Reason: doing so risks exponential behaviour.  We simplify a big-                        --         expression, inline it, and simplify it again.  But if the-                        --         very same thing happens in the big expression, we get-                        --         exponential cost!-                        -- PRINCIPLE: when we've already simplified an expression once,-                        -- make sure that we only inline it if it's reasonably small.--           && (in_lam == NotInsideLam ||-                        -- Outside a lambda, we want to be reasonably aggressive-                        -- about inlining into multiple branches of case-                        -- e.g. let x = <non-value>-                        --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }-                        -- Inlining can be a big win if C3 is the hot-spot, even if-                        -- the uses in C1, C2 are not 'interesting'-                        -- An example that gets worse if you add int_cxt here is 'clausify'--                (isCheapUnfolding unfolding && int_cxt == IsInteresting))-                        -- isCheap => acceptable work duplication; in_lam may be true-                        -- int_cxt to prevent us inlining inside a lambda without some-                        -- good reason.  See the notes on int_cxt in preInlineUnconditionally--      IAmDead -> True   -- This happens; for example, the case_bndr during case of-                        -- known constructor:  case (a,b) of x { (p,q) -> ... }-                        -- Here x isn't mentioned in the RHS, so we don't want to-                        -- create the (dead) let-binding  let x = (a,b) in ...--      _ -> False---- Here's an example that we don't handle well:---      let f = if b then Left (\x.BIG) else Right (\y.BIG)---      in \y. ....case f of {...} ....--- Here f is used just once, and duplicating the case work is fine (exprIsCheap).--- But---  - We can't preInlineUnconditionally because that would invalidate---    the occ info for b.---  - We can't postInlineUnconditionally because the RHS is big, and---    that risks exponential behaviour---  - We can't call-site inline, because the rhs is big--- Alas!--  where-    unfolding = idUnfolding bndr-    dflags    = seDynFlags env-    active    = isActive (sm_phase (getMode env)) (idInlineActivation bndr)-        -- See Note [pre/postInlineUnconditionally in gentle mode]--{--Note [Top level and postInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't do postInlineUnconditionally for top-level things (even for-ones that are trivial):--  * Doing so will inline top-level error expressions that have been-    carefully floated out by FloatOut.  More generally, it might-    replace static allocation with dynamic.--  * Even for trivial expressions there's a problem.  Consider-      {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-}-      blah xs = reverse xs-      ruggle = sort-    In one simplifier pass we might fire the rule, getting-      blah xs = ruggle xs-    but in *that* simplifier pass we must not do postInlineUnconditionally-    on 'ruggle' because then we'll have an unbound occurrence of 'ruggle'--    If the rhs is trivial it'll be inlined by callSiteInline, and then-    the binding will be dead and discarded by the next use of OccurAnal--  * There is less point, because the main goal is to get rid of local-    bindings used in multiple case branches.--  * The inliner should inline trivial things at call sites anyway.--  * The Id might be exported.  We could check for that separately,-    but since we aren't going to postInlineUnconditionally /any/-    top-level bindings, we don't need to test.--Note [Stable unfoldings and postInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do not do postInlineUnconditionally if the Id has a stable unfolding,-otherwise we lose the unfolding.  Example--     -- f has stable unfolding with rhs (e |> co)-     --   where 'e' is big-     f = e |> co--Then there's a danger we'll optimise to--     f' = e-     f = f' |> co--and now postInlineUnconditionally, losing the stable unfolding on f.  Now f'-won't inline because 'e' is too big.--    c.f. Note [Stable unfoldings and preInlineUnconditionally]---************************************************************************-*                                                                      *-        Rebuilding a lambda-*                                                                      *-************************************************************************--}--mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr--- mkLam tries three things---      a) eta reduction, if that gives a trivial expression---      b) eta expansion [only if there are some value lambdas]--mkLam _env [] body _cont-  = return body-mkLam env bndrs body cont-  = do { dflags <- getDynFlags-       ; mkLam' dflags bndrs body }-  where-    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr-    mkLam' dflags bndrs (Cast body co)-      | not (any bad bndrs)-        -- Note [Casts and lambdas]-      = do { lam <- mkLam' dflags bndrs body-           ; return (mkCast lam (mkPiCos Representational bndrs co)) }-      where-        co_vars  = tyCoVarsOfCo co-        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars--    mkLam' dflags bndrs body@(Lam {})-      = mkLam' dflags (bndrs ++ bndrs1) body1-      where-        (bndrs1, body1) = collectBinders body--    mkLam' dflags bndrs (Tick t expr)-      | tickishFloatable t-      = mkTick t <$> mkLam' dflags bndrs expr--    mkLam' dflags bndrs body-      | gopt Opt_DoEtaReduction dflags-      , Just etad_lam <- tryEtaReduce bndrs body-      = do { tick (EtaReduction (head bndrs))-           ; return etad_lam }--      | not (contIsRhs cont)   -- See Note [Eta-expanding lambdas]-      , sm_eta_expand (getMode env)-      , any isRuntimeVar bndrs-      , let body_arity = exprEtaExpandArity dflags body-      , body_arity > 0-      = do { tick (EtaExpansion (head bndrs))-           ; let res = mkLams bndrs (etaExpand body_arity body)-           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)-                                          , text "after" <+> ppr res])-           ; return res }--      | otherwise-      = return (mkLams bndrs body)--{--Note [Eta expanding lambdas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general we *do* want to eta-expand lambdas. Consider-   f (\x -> case x of (a,b) -> \s -> blah)-where 's' is a state token, and hence can be eta expanded.  This-showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather-important function!--The eta-expansion will never happen unless we do it now.  (Well, it's-possible that CorePrep will do it, but CorePrep only has a half-baked-eta-expander that can't deal with casts.  So it's much better to do it-here.)--However, when the lambda is let-bound, as the RHS of a let, we have a-better eta-expander (in the form of tryEtaExpandRhs), so we don't-bother to try expansion in mkLam in that case; hence the contIsRhs-guard.--NB: We check the SimplEnv (sm_eta_expand), not DynFlags.-    See Note [No eta expansion in stable unfoldings]--Note [Casts and lambdas]-~~~~~~~~~~~~~~~~~~~~~~~~-Consider-        (\x. (\y. e) `cast` g1) `cast` g2-There is a danger here that the two lambdas look separated, and the-full laziness pass might float an expression to between the two.--So this equation in mkLam' floats the g1 out, thus:-        (\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)-where x:tx.--In general, this floats casts outside lambdas, where (I hope) they-might meet and cancel with some other cast:-        \x. e `cast` co   ===>   (\x. e) `cast` (tx -> co)-        /\a. e `cast` co  ===>   (/\a. e) `cast` (/\a. co)-        /\g. e `cast` co  ===>   (/\g. e) `cast` (/\g. co)-                          (if not (g `in` co))--Notice that it works regardless of 'e'.  Originally it worked only-if 'e' was itself a lambda, but in some cases that resulted in-fruitless iteration in the simplifier.  A good example was when-compiling Text.ParserCombinators.ReadPrec, where we had a definition-like    (\x. Get `cast` g)-where Get is a constructor with nonzero arity.  Then mkLam eta-expanded-the Get, and the next iteration eta-reduced it, and then eta-expanded-it again.--Note also the side condition for the case of coercion binders.-It does not make sense to transform-        /\g. e `cast` g  ==>  (/\g.e) `cast` (/\g.g)-because the latter is not well-kinded.--************************************************************************-*                                                                      *-              Eta expansion-*                                                                      *-************************************************************************--}--tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr-                -> SimplM (Arity, Bool, OutExpr)--- See Note [Eta-expanding at let bindings]--- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then---   (a) rhs' has manifest arity n---   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom-tryEtaExpandRhs mode bndr rhs-  | Just join_arity <- isJoinId_maybe bndr-  = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs-       ; return (count isId join_bndrs, exprIsBottom join_body, rhs) }-         -- Note [Do not eta-expand join points]-         -- But do return the correct arity and bottom-ness, because-         -- these are used to set the bndr's IdInfo (#15517)-         -- Note [Invariants on join points] invariant 2b, in GHC.Core--  | otherwise-  = do { (new_arity, is_bot, new_rhs) <- try_expand--       ; WARN( new_arity < old_id_arity,-               (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity-                <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )-                        -- Note [Arity decrease] in Simplify-         return (new_arity, is_bot, new_rhs) }-  where-    try_expand-      | exprIsTrivial rhs-      = return (exprArity rhs, False, rhs)--      | sm_eta_expand mode      -- Provided eta-expansion is on-      , new_arity > old_arity   -- And the current manifest arity isn't enough-      = do { tick (EtaExpansion bndr)-           ; return (new_arity, is_bot, etaExpand new_arity rhs) }--      | otherwise-      = return (old_arity, is_bot && new_arity == old_arity, rhs)--    dflags       = sm_dflags mode-    old_arity    = exprArity rhs -- See Note [Do not expand eta-expand PAPs]-    old_id_arity = idArity bndr--    (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity-    new_arity2 = idCallArity bndr-    new_arity  = max new_arity1 new_arity2--{--Note [Eta-expanding at let bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We now eta expand at let-bindings, which is where the payoff comes.-The most significant thing is that we can do a simple arity analysis-(in GHC.Core.Arity.findRhsArity), which we can't do for free-floating lambdas--One useful consequence of not eta-expanding lambdas is this example:-   genMap :: C a => ...-   {-# INLINE genMap #-}-   genMap f xs = ...--   myMap :: D a => ...-   {-# INLINE myMap #-}-   myMap = genMap--Notice that 'genMap' should only inline if applied to two arguments.-In the stable unfolding for myMap we'll have the unfolding-    (\d -> genMap Int (..d..))-We do not want to eta-expand to-    (\d f xs -> genMap Int (..d..) f xs)-because then 'genMap' will inline, and it really shouldn't: at least-as far as the programmer is concerned, it's not applied to two-arguments!--Note [Do not eta-expand join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Similarly to CPR (see Note [Don't w/w join points for CPR] in WorkWrap), a join point-stands well to gain from its outer binding's eta-expansion, and eta-expanding a-join point is fraught with issues like how to deal with a cast:--    let join $j1 :: IO ()-             $j1 = ...-             $j2 :: Int -> IO ()-             $j2 n = if n > 0 then $j1-                              else ...--    =>--    let join $j1 :: IO ()-             $j1 = (\eta -> ...)-                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())-                                 ~  IO ()-             $j2 :: Int -> IO ()-             $j2 n = (\eta -> if n > 0 then $j1-                                       else ...)-                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())-                                 ~  IO ()--The cast here can't be pushed inside the lambda (since it's not casting to a-function type), so the lambda has to stay, but it can't because it contains a-reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather-than try and detect this situation (and whatever other situations crop up!), we-don't bother; again, any surrounding eta-expansion will improve these join-points anyway, since an outer cast can *always* be pushed inside. By the time-CorePrep comes around, the code is very likely to look more like this:--    let join $j1 :: State# RealWorld -> (# State# RealWorld, ())-             $j1 = (...) eta-             $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())-             $j2 = if n > 0 then $j1-                            else (...) eta--Note [Do not eta-expand PAPs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to have old_arity = manifestArity rhs, which meant that we-would eta-expand even PAPs.  But this gives no particular advantage,-and can lead to a massive blow-up in code size, exhibited by #9020.-Suppose we have a PAP-    foo :: IO ()-    foo = returnIO ()-Then we can eta-expand do-    foo = (\eta. (returnIO () |> sym g) eta) |> g-where-    g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)--But there is really no point in doing this, and it generates masses of-coercions and whatnot that eventually disappear again. For T9020, GHC-allocated 6.6G before, and 0.8G afterwards; and residency dropped from-1.8G to 45M.--But note that this won't eta-expand, say-  f = \g -> map g-Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps-strictness analysis will have less to bite on?---************************************************************************-*                                                                      *-\subsection{Floating lets out of big lambdas}-*                                                                      *-************************************************************************--Note [Floating and type abstraction]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:-        x = /\a. C e1 e2-We'd like to float this to-        y1 = /\a. e1-        y2 = /\a. e2-        x  = /\a. C (y1 a) (y2 a)-for the usual reasons: we want to inline x rather vigorously.--You may think that this kind of thing is rare.  But in some programs it is-common.  For example, if you do closure conversion you might get:--        data a :-> b = forall e. (e -> a -> b) :$ e--        f_cc :: forall a. a :-> a-        f_cc = /\a. (\e. id a) :$ ()--Now we really want to inline that f_cc thing so that the-construction of the closure goes away.--So I have elaborated simplLazyBind to understand right-hand sides that look-like-        /\ a1..an. body--and treat them specially. The real work is done in SimplUtils.abstractFloats,-but there is quite a bit of plumbing in simplLazyBind as well.--The same transformation is good when there are lets in the body:--        /\abc -> let(rec) x = e in b-   ==>-        let(rec) x' = /\abc -> let x = x' a b c in e-        in-        /\abc -> let x = x' a b c in b--This is good because it can turn things like:--        let f = /\a -> letrec g = ... g ... in g-into-        letrec g' = /\a -> ... g' a ...-        in-        let f = /\ a -> g' a--which is better.  In effect, it means that big lambdas don't impede-let-floating.--This optimisation is CRUCIAL in eliminating the junk introduced by-desugaring mutually recursive definitions.  Don't eliminate it lightly!--[May 1999]  If we do this transformation *regardless* then we can-end up with some pretty silly stuff.  For example,--        let-            st = /\ s -> let { x1=r1 ; x2=r2 } in ...-        in ..-becomes-        let y1 = /\s -> r1-            y2 = /\s -> r2-            st = /\s -> ...[y1 s/x1, y2 s/x2]-        in ..--Unless the "..." is a WHNF there is really no point in doing this.-Indeed it can make things worse.  Suppose x1 is used strictly,-and is of the form--        x1* = case f y of { (a,b) -> e }--If we abstract this wrt the tyvar we then can't do the case inline-as we would normally do.--That's why the whole transformation is part of the same process that-floats let-bindings and constructor arguments out of RHSs.  In particular,-it is guarded by the doFloatFromRhs call in simplLazyBind.--Note [Which type variables to abstract over]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Abstract only over the type variables free in the rhs wrt which the-new binding is abstracted.  Note that--  * The naive approach of abstracting wrt the-    tyvars free in the Id's /type/ fails. Consider:-        /\ a b -> let t :: (a,b) = (e1, e2)-                      x :: a     = fst t-                  in ...-    Here, b isn't free in x's type, but we must nevertheless-    abstract wrt b as well, because t's type mentions b.-    Since t is floated too, we'd end up with the bogus:-         poly_t = /\ a b -> (e1, e2)-         poly_x = /\ a   -> fst (poly_t a *b*)--  * We must do closeOverKinds.  Example (#10934):-       f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...-    Here we want to float 't', but we must remember to abstract over-    'k' as well, even though it is not explicitly mentioned in the RHS,-    otherwise we get-       t = /\ (f:k->*) (a:k). AccFailure @ (f a)-    which is obviously bogus.--}--abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats-              -> OutExpr -> SimplM ([OutBind], OutExpr)-abstractFloats dflags top_lvl main_tvs floats body-  = ASSERT( notNull body_floats )-    ASSERT( isNilOL (sfJoinFloats floats) )-    do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats-        ; return (float_binds, GHC.Core.Subst.substExpr (text "abstract_floats1") subst body) }-  where-    is_top_lvl  = isTopLevel top_lvl-    main_tv_set = mkVarSet main_tvs-    body_floats = letFloatBinds (sfLetFloats floats)-    empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats)--    abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)-    abstract subst (NonRec id rhs)-      = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id-           ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'-                 subst' = GHC.Core.Subst.extendIdSubst subst id poly_app-           ; return (subst', NonRec poly_id2 poly_rhs) }-      where-        rhs' = GHC.Core.Subst.substExpr (text "abstract_floats2") subst rhs--        -- tvs_here: see Note [Which type variables to abstract over]-        tvs_here = scopedSort $-                   filter (`elemVarSet` main_tv_set) $-                   closeOverKindsList $-                   exprSomeFreeVarsList isTyVar rhs'--    abstract subst (Rec prs)-       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids-            ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)-                  poly_pairs = [ mk_poly2 poly_id tvs_here rhs'-                               | (poly_id, rhs) <- poly_ids `zip` rhss-                               , let rhs' = GHC.Core.Subst.substExpr (text "abstract_floats")-                                                                subst' rhs ]-            ; return (subst', Rec poly_pairs) }-       where-         (ids,rhss) = unzip prs-                -- For a recursive group, it's a bit of a pain to work out the minimal-                -- set of tyvars over which to abstract:-                --      /\ a b c.  let x = ...a... in-                --                 letrec { p = ...x...q...-                --                          q = .....p...b... } in-                --                 ...-                -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted-                -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.-                -- Since it's a pain, we just use the whole set, which is always safe-                ---                -- If you ever want to be more selective, remember this bizarre case too:-                --      x::a = x-                -- Here, we must abstract 'x' over 'a'.-         tvs_here = scopedSort main_tvs--    mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)-    mk_poly1 tvs_here var-      = do { uniq <- getUniqueM-           ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name-                  poly_ty   = mkInvForAllTys tvs_here (idType var) -- But new type of course-                  poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs-                              mkLocalId poly_name poly_ty-           ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }-                -- In the olden days, it was crucial to copy the occInfo of the original var,-                -- because we were looking at occurrence-analysed but as yet unsimplified code!-                -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking-                -- at already simplified code, so it doesn't matter-                ---                -- It's even right to retain single-occurrence or dead-var info:-                -- Suppose we started with  /\a -> let x = E in B-                -- where x occurs once in B. Then we transform to:-                --      let x' = /\a -> E in /\a -> let x* = x' a in B-                -- where x* has an INLINE prag on it.  Now, once x* is inlined,-                -- the occurrences of x' will be just the occurrences originally-                -- pinned on x.--    mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)-    mk_poly2 poly_id tvs_here rhs-      = (poly_id `setIdUnfolding` unf, poly_rhs)-      where-        poly_rhs = mkLams tvs_here rhs-        unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs--        -- We want the unfolding.  Consider-        --      let-        --            x = /\a. let y = ... in Just y-        --      in body-        -- Then we float the y-binding out (via abstractFloats and addPolyBind)-        -- but 'x' may well then be inlined in 'body' in which case we'd like the-        -- opportunity to inline 'y' too.--{--Note [Abstract over coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the-type variable a.  Rather than sort this mess out, we simply bale out and abstract-wrt all the type variables if any of them are coercion variables.---Historical note: if you use let-bindings instead of a substitution, beware of this:--                -- Suppose we start with:-                ---                --      x = /\ a -> let g = G in E-                ---                -- Then we'll float to get-                ---                --      x = let poly_g = /\ a -> G-                --          in /\ a -> let g = poly_g a in E-                ---                -- But now the occurrence analyser will see just one occurrence-                -- of poly_g, not inside a lambda, so the simplifier will-                -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!-                -- (I used to think that the "don't inline lone occurrences" stuff-                --  would stop this happening, but since it's the *only* occurrence,-                --  PreInlineUnconditionally kicks in first!)-                ---                -- Solution: put an INLINE note on g's RHS, so that poly_g seems-                --           to appear many times.  (NB: mkInlineMe eliminates-                --           such notes on trivial RHSs, so do it manually.)--************************************************************************-*                                                                      *-                prepareAlts-*                                                                      *-************************************************************************--prepareAlts tries these things:--1.  Eliminate alternatives that cannot match, including the-    DEFAULT alternative.--2.  If the DEFAULT alternative can match only one possible constructor,-    then make that constructor explicit.-    e.g.-        case e of x { DEFAULT -> rhs }-     ===>-        case e of x { (a,b) -> rhs }-    where the type is a single constructor type.  This gives better code-    when rhs also scrutinises x or e.--3. Returns a list of the constructors that cannot holds in the-   DEFAULT alternative (if there is one)--Here "cannot match" includes knowledge from GADTs--It's a good idea to do this stuff before simplifying the alternatives, to-avoid simplifying alternatives we know can't happen, and to come up with-the list of constructors that are handled, to put into the IdInfo of the-case binder, for use when simplifying the alternatives.--Eliminating the default alternative in (1) isn't so obvious, but it can-happen:--data Colour = Red | Green | Blue--f x = case x of-        Red -> ..-        Green -> ..-        DEFAULT -> h x--h y = case y of-        Blue -> ..-        DEFAULT -> [ case y of ... ]--If we inline h into f, the default case of the inlined h can't happen.-If we don't notice this, we may end up filtering out *all* the cases-of the inner case y, which give us nowhere to go!--}--prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])--- The returned alternatives can be empty, none are possible-prepareAlts scrut case_bndr' alts-  | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr')-           -- Case binder is needed just for its type. Note that as an-           --   OutId, it has maximum information; this is important.-           --   Test simpl013 is an example-  = do { us <- getUniquesM-       ; let (idcs1, alts1)       = filterAlts tc tys imposs_cons alts-             (yes2,  alts2)       = refineDefaultAlt us tc tys idcs1 alts1-             (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2-             -- "idcs" stands for "impossible default data constructors"-             -- i.e. the constructors that can't match the default case-       ; when yes2 $ tick (FillInCaseDefault case_bndr')-       ; when yes3 $ tick (AltMerge case_bndr')-       ; return (idcs3, alts3) }--  | otherwise  -- Not a data type, so nothing interesting happens-  = return ([], alts)-  where-    imposs_cons = case scrut of-                    Var v -> otherCons (idUnfolding v)-                    _     -> []---{--************************************************************************-*                                                                      *-                mkCase-*                                                                      *-************************************************************************--mkCase tries these things--* Note [Nerge nested cases]-* Note [Eliminate identity case]-* Note [Scrutinee constant folding]--Note [Merge Nested Cases]-~~~~~~~~~~~~~~~~~~~~~~~~~-       case e of b {             ==>   case e of b {-         p1 -> rhs1                      p1 -> rhs1-         ...                             ...-         pm -> rhsm                      pm -> rhsm-         _  -> case b of b' {            pn -> let b'=b in rhsn-                     pn -> rhsn          ...-                     ...                 po -> let b'=b in rhso-                     po -> rhso          _  -> let b'=b in rhsd-                     _  -> rhsd-       }--which merges two cases in one case when -- the default alternative of-the outer case scrutises the same variable as the outer case. This-transformation is called Case Merging.  It avoids that the same-variable is scrutinised multiple times.--Note [Eliminate Identity Case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        case e of               ===> e-                True  -> True;-                False -> False--and similar friends.--Note [Scrutinee Constant Folding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-     case x op# k# of _ {  ===> case x of _ {-        a1# -> e1                  (a1# inv_op# k#) -> e1-        a2# -> e2                  (a2# inv_op# k#) -> e2-        ...                        ...-        DEFAULT -> ed              DEFAULT -> ed--     where (x op# k#) inv_op# k# == x--And similarly for commuted arguments and for some unary operations.--The purpose of this transformation is not only to avoid an arithmetic-operation at runtime but to allow other transformations to apply in cascade.--Example with the "Merge Nested Cases" optimization (from #12877):--      main = case t of t0-         0##     -> ...-         DEFAULT -> case t0 `minusWord#` 1## of t1-            0##    -> ...-            DEFAUT -> case t1 `minusWord#` 1## of t2-               0##     -> ...-               DEFAULT -> case t2 `minusWord#` 1## of _-                  0##     -> ...-                  DEFAULT -> ...--  becomes:--      main = case t of _-      0##     -> ...-      1##     -> ...-      2##     -> ...-      3##     -> ...-      DEFAULT -> ...--There are some wrinkles--* Do not apply caseRules if there is just a single DEFAULT alternative-     case e +# 3# of b { DEFAULT -> rhs }-  If we applied the transformation here we would (stupidly) get-     case a of b' { DEFAULT -> let b = e +# 3# in rhs }-  and now the process may repeat, because that let will really-  be a case.--* The type of the scrutinee might change.  E.g.-        case tagToEnum (x :: Int#) of (b::Bool)-          False -> e1-          True -> e2-  ==>-        case x of (b'::Int#)-          DEFAULT -> e1-          1#      -> e2--* The case binder may be used in the right hand sides, so we need-  to make a local binding for it, if it is alive.  e.g.-         case e +# 10# of b-           DEFAULT -> blah...b...-           44#     -> blah2...b...-  ===>-         case e of b'-           DEFAULT -> let b = b' +# 10# in blah...b...-           34#     -> let b = 44# in blah2...b...--  Note that in the non-DEFAULT cases we know what to bind 'b' to,-  whereas in the DEFAULT case we must reconstruct the original value.-  But NB: we use b'; we do not duplicate 'e'.--* In dataToTag we might need to make up some fake binders;-  see Note [caseRules for dataToTag] in PrelRules--}--mkCase, mkCase1, mkCase2, mkCase3-   :: DynFlags-   -> OutExpr -> OutId-   -> OutType -> [OutAlt]               -- Alternatives in standard (increasing) order-   -> SimplM OutExpr-------------------------------------------------------      1. Merge Nested Cases-----------------------------------------------------mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)-  | gopt Opt_CaseMerge dflags-  , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)-       <- stripTicksTop tickishFloatable deflt_rhs-  , inner_scrut_var == outer_bndr-  = do  { tick (CaseMerge outer_bndr)--        ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args )-                                          (con, args, wrap_rhs rhs)-                -- Simplifier's no-shadowing invariant should ensure-                -- that outer_bndr is not shadowed by the inner patterns-              wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs-                -- The let is OK even for unboxed binders,--              wrapped_alts | isDeadBinder inner_bndr = inner_alts-                           | otherwise               = map wrap_alt inner_alts--              merged_alts = mergeAlts outer_alts wrapped_alts-                -- NB: mergeAlts gives priority to the left-                --      case x of-                --        A -> e1-                --        DEFAULT -> case x of-                --                      A -> e2-                --                      B -> e3-                -- When we merge, we must ensure that e1 takes-                -- precedence over e2 as the value for A!--        ; fmap (mkTicks ticks) $-          mkCase1 dflags scrut outer_bndr alts_ty merged_alts-        }-        -- Warning: don't call mkCase recursively!-        -- Firstly, there's no point, because inner alts have already had-        -- mkCase applied to them, so they won't have a case in their default-        -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr-        -- in munge_rhs may put a case into the DEFAULT branch!--mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts-------------------------------------------------------      2. Eliminate Identity Case-----------------------------------------------------mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case-  | all identity_alt alts-  = do { tick (CaseIdentity case_bndr)-       ; return (mkTicks ticks $ re_cast scrut rhs1) }-  where-    ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts)-    identity_alt (con, args, rhs) = check_eq rhs con args--    check_eq (Cast rhs co) con args        -- See Note [RHS casts]-      = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args-    check_eq (Tick t e) alt args-      = tickishFloatable t && check_eq e alt args--    check_eq (Lit lit) (LitAlt lit') _     = lit == lit'-    check_eq (Var v) _ _  | v == case_bndr = True-    check_eq (Var v)   (DataAlt con) args-      | null arg_tys, null args            = v == dataConWorkId con-                                             -- Optimisation only-    check_eq rhs        (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $-                                             mkConApp2 con arg_tys args-    check_eq _          _             _    = False--    arg_tys = tyConAppArgs (idType case_bndr)--        -- Note [RHS casts]-        -- ~~~~~~~~~~~~~~~~-        -- We've seen this:-        --      case e of x { _ -> x `cast` c }-        -- And we definitely want to eliminate this case, to give-        --      e `cast` c-        -- So we throw away the cast from the RHS, and reconstruct-        -- it at the other end.  All the RHS casts must be the same-        -- if (all identity_alt alts) holds.-        ---        -- Don't worry about nested casts, because the simplifier combines them--    re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co-    re_cast scrut _             = scrut--mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts-------------------------------------------------------      2. Scrutinee Constant Folding-----------------------------------------------------mkCase2 dflags scrut bndr alts_ty alts-  | -- See Note [Scrutinee Constant Folding]-    case alts of  -- Not if there is just a DEFAULT alternative-      [(DEFAULT,_,_)] -> False-      _               -> True-  , gopt Opt_CaseFolding dflags-  , Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut-  = do { bndr' <- newId (fsLit "lwild") (exprType scrut')--       ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts-                  -- mapMaybeM: discard unreachable alternatives-                  -- See Note [Unreachable caseRules alternatives]-                  -- in PrelRules--       ; mkCase3 dflags scrut' bndr' alts_ty $-         add_default (re_sort alts')-       }--  | otherwise-  = mkCase3 dflags scrut bndr alts_ty alts-  where-    -- We need to keep the correct association between the scrutinee and its-    -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with-    -- "let bndr = ... in":-    ---    --     case v + 10 of y        =====> case v of y-    --        20      -> e1                 10      -> let y = 20     in e1-    --        DEFAULT -> e2                 DEFAULT -> let y = v + 10 in e2-    ---    -- Other transformations give: =====> case v of y'-    --                                      10      -> let y = 20      in e1-    --                                      DEFAULT -> let y = y' + 10 in e2-    ---    -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules,-    -- to construct an expression equivalent to the original one, for use-    -- in the DEFAULT case--    tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id-           -> CoreAlt -> SimplM (Maybe CoreAlt)-    tx_alt tx_con mk_orig new_bndr (con, bs, rhs)-      = case tx_con con of-          Nothing   -> return Nothing-          Just con' -> do { bs' <- mk_new_bndrs new_bndr con'-                          ; return (Just (con', bs', rhs')) }-      where-        rhs' | isDeadBinder bndr = rhs-             | otherwise         = bindNonRec bndr orig_val rhs--        orig_val = case con of-                      DEFAULT    -> mk_orig new_bndr-                      LitAlt l   -> Lit l-                      DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs--    mk_new_bndrs new_bndr (DataAlt dc)-      | not (isNullaryRepDataCon dc)-      = -- For non-nullary data cons we must invent some fake binders-        -- See Note [caseRules for dataToTag] in PrelRules-        do { us <- getUniquesM-           ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc-                                        (tyConAppArgs (idType new_bndr))-           ; return (ex_tvs ++ arg_ids) }-    mk_new_bndrs _ _ = return []--    re_sort :: [CoreAlt] -> [CoreAlt]-    -- Sort the alternatives to re-establish-    -- GHC.Core Note [Case expression invariants]-    re_sort alts = sortBy cmpAlt alts--    add_default :: [CoreAlt] -> [CoreAlt]-    -- See Note [Literal cases]-    add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts-    add_default alts                          = alts--{- Note [Literal cases]-~~~~~~~~~~~~~~~~~~~~~~~-If we have-  case tagToEnum (a ># b) of-     False -> e1-     True  -> e2--then caseRules for TagToEnum will turn it into-  case tagToEnum (a ># b) of-     0# -> e1-     1# -> e2--Since the case is exhaustive (all cases are) we can convert it to-  case tagToEnum (a ># b) of-     DEFAULT -> e1-     1#      -> e2--This may generate sligthtly better code (although it should not, since-all cases are exhaustive) and/or optimise better.  I'm not certain that-it's necessary, but currently we do make this change.  We do it here,-NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]-in PrelRules)--}-------------------------------------------------------      Catch-all----------------------------------------------------mkCase3 _dflags scrut bndr alts_ty alts-  = return (Case scrut bndr alts_ty alts)---- See Note [Exitification] and Note [Do not inline exit join points] in Exitify.hs--- This lives here (and not in Id) because occurrence info is only valid on--- InIds, so it's crucial that isExitJoinId is only called on freshly--- occ-analysed code. It's not a generic function you can call anywhere.-isExitJoinId :: Var -> Bool-isExitJoinId id-  = isJoinId id-  && isOneOcc (idOccInfo id)-  && occ_in_lam (idOccInfo id) == IsInsideLam--{--Note [Dead binders]-~~~~~~~~~~~~~~~~~~~~-Note that dead-ness is maintained by the simplifier, so that it is-accurate after simplification as well as before.---Note [Cascading case merge]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Case merging should cascade in one sweep, because it-happens bottom-up--      case e of a {-        DEFAULT -> case a of b-                      DEFAULT -> case b of c {-                                     DEFAULT -> e-                                     A -> ea-                      B -> eb-        C -> ec-==>-      case e of a {-        DEFAULT -> case a of b-                      DEFAULT -> let c = b in e-                      A -> let c = b in ea-                      B -> eb-        C -> ec-==>-      case e of a {-        DEFAULT -> let b = a in let c = b in e-        A -> let b = a in let c = b in ea-        B -> let b = a in eb-        C -> ec---However here's a tricky case that we still don't catch, and I don't-see how to catch it in one pass:--  case x of c1 { I# a1 ->-  case a1 of c2 ->-    0 -> ...-    DEFAULT -> case x of c3 { I# a2 ->-               case a2 of ...--After occurrence analysis (and its binder-swap) we get this--  case x of c1 { I# a1 ->-  let x = c1 in         -- Binder-swap addition-  case a1 of c2 ->-    0 -> ...-    DEFAULT -> case x of c3 { I# a2 ->-               case a2 of ...--When we simplify the inner case x, we'll see that-x=c1=I# a1.  So we'll bind a2 to a1, and get--  case x of c1 { I# a1 ->-  case a1 of c2 ->-    0 -> ...-    DEFAULT -> case a1 of ...--This is correct, but we can't do a case merge in this sweep-because c2 /= a1.  Reason: the binding c1=I# a1 went inwards-without getting changed to c1=I# c2.--I don't think this is worth fixing, even if I knew how. It'll-all come out in the next pass anyway.--}
− compiler/simplCore/Simplify.hs 
@@ -1,3665 +0,0 @@-{--(c) The AQUA Project, Glasgow University, 1993-1998--\section[Simplify]{The main module of the simplifier}--}--{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-module Simplify ( simplTopBinds, simplExpr, simplRules ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Driver.Session-import SimplMonad-import Type hiding      ( substTy, substTyVar, extendTvSubst, extendCvSubst )-import SimplEnv-import SimplUtils-import OccurAnal        ( occurAnalyseExpr )-import FamInstEnv       ( FamInstEnv )-import Literal          ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326-import Id-import MkId             ( seqId )-import GHC.Core.Make           ( FloatBind, mkImpossibleExpr, castBottomExpr )-import qualified GHC.Core.Make-import IdInfo-import Name             ( mkSystemVarName, isExternalName, getOccFS )-import Coercion hiding  ( substCo, substCoVar )-import OptCoercion      ( optCoercion )-import FamInstEnv       ( topNormaliseType_maybe )-import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness-                        , dataConRepArgTys, isUnboxedTupleCon-                        , StrictnessMark (..) )-import CoreMonad        ( Tick(..), SimplMode(..) )-import GHC.Core-import Demand           ( StrictSig(..), dmdTypeDepth, isStrictDmd-                        , mkClosedStrictSig, topDmd, botDiv )-import Cpr              ( mkCprSig, botCpr )-import GHC.Core.Ppr     ( pprCoreExpr )-import GHC.Core.Unfold-import GHC.Core.Utils-import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg-                          , joinPointBinding_maybe, joinPointBindings_maybe )-import GHC.Core.Rules   ( mkRuleInfo, lookupRule, getRules )-import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel,-                          RecFlag(..), Arity )-import MonadUtils       ( mapAccumLM, liftIO )-import Var              ( isTyCoVar )-import Maybes           (  orElse )-import Control.Monad-import Outputable-import FastString-import Util-import ErrUtils-import Module          ( moduleName, pprModuleName )-import PrimOp          ( PrimOp (SeqOp) )---{--The guts of the simplifier is in this module, but the driver loop for-the simplifier is in SimplCore.hs.--Note [The big picture]-~~~~~~~~~~~~~~~~~~~~~~-The general shape of the simplifier is this:--  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)-  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)-- * SimplEnv contains-     - Simplifier mode (which includes DynFlags for convenience)-     - Ambient substitution-     - InScopeSet-- * SimplFloats contains-     - Let-floats (which includes ok-for-spec case-floats)-     - Join floats-     - InScopeSet (including all the floats)-- * Expressions-      simplExpr :: SimplEnv -> InExpr -> SimplCont-                -> SimplM (SimplFloats, OutExpr)-   The result of simplifying an /expression/ is (floats, expr)-      - A bunch of floats (let bindings, join bindings)-      - A simplified expression.-   The overall result is effectively (let floats in expr)-- * Bindings-      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)-   The result of simplifying a binding is-     - A bunch of floats, the last of which is the simplified binding-       There may be auxiliary bindings too; see prepareRhs-     - An environment suitable for simplifying the scope of the binding--   The floats may also be empty, if the binding is inlined unconditionally;-   in that case the returned SimplEnv will have an augmented substitution.--   The returned floats and env both have an in-scope set, and they are-   guaranteed to be the same.---Note [Shadowing]-~~~~~~~~~~~~~~~~-The simplifier used to guarantee that the output had no shadowing, but-it does not do so any more.   (Actually, it never did!)  The reason is-documented with simplifyArgs.---Eta expansion-~~~~~~~~~~~~~~-For eta expansion, we want to catch things like--        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r--If the \x was on the RHS of a let, we'd eta expand to bring the two-lambdas together.  And in general that's a good thing to do.  Perhaps-we should eta expand wherever we find a (value) lambda?  Then the eta-expansion at a let RHS can concentrate solely on the PAP case.--Note [In-scope set as a substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As per Note [Lookups in in-scope set], an in-scope set can act as-a substitution. Specifically, it acts as a substitution from variable to-variables /with the same unique/.--Why do we need this? Well, during the course of the simplifier, we may want to-adjust inessential properties of a variable. For instance, when performing a-beta-reduction, we change--    (\x. e) u ==> let x = u in e--We typically want to add an unfolding to `x` so that it inlines to (the-simplification of) `u`.--We do that by adding the unfolding to the binder `x`, which is added to the-in-scope set. When simplifying occurrences of `x` (every occurrence!), they are-replaced by their “updated” version from the in-scope set, hence inherit the-unfolding. This happens in `SimplEnv.substId`.--Another example. Consider--   case x of y { Node a b -> ...y...-               ; Leaf v   -> ...y... }--In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we-want y's unfolding to be (Leaf v). We achieve this by adding the appropriate-unfolding to y, and re-adding it to the in-scope set. See the calls to-`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.--It's quite convenient. This way we don't need to manipulate the substitution all-the time: every update to a binder is automatically reflected to its bound-occurrences.--************************************************************************-*                                                                      *-\subsection{Bindings}-*                                                                      *-************************************************************************--}--simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)--- See Note [The big picture]-simplTopBinds env0 binds0-  = do  {       -- Put all the top-level binders into scope at the start-                -- so that if a transformation 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 OccurAnal.-        ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)-        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0-        ; freeTick SimplifierDone-        ; return (floats, env2) }-  where-        -- We need to track the zapped top-level binders, because-        -- they should have their fragile IdInfo zapped (notably occurrence info)-        -- That's why we run down binds and bndrs' simultaneously.-        ---    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)-    simpl_binds env []           = return (emptyFloats env, env)-    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind-                                      ; (floats, env2) <- simpl_binds env1 binds-                                      ; return (float `addFloats` floats, env2) }--    simpl_bind env (Rec pairs)-      = simplRecBind env TopLevel Nothing pairs-    simpl_bind env (NonRec b r)-      = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing-           ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }--{--************************************************************************-*                                                                      *-        Lazy bindings-*                                                                      *-************************************************************************--simplRecBind is used for-        * recursive bindings only--}--simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont-             -> [(InId, InExpr)]-             -> SimplM (SimplFloats, SimplEnv)-simplRecBind env0 top_lvl mb_cont pairs0-  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0-        ; (rec_floats, env1) <- go env_with_info triples-        ; return (mkRecFloats rec_floats, env1) }-  where-    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))-        -- Add the (substituted) rules to the binder-    add_rules env (bndr, rhs)-        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont-             ; return (env', (bndr, bndr', rhs)) }--    go env [] = return (emptyFloats env, env)--    go env ((old_bndr, new_bndr, rhs) : pairs)-        = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont-                                                  old_bndr new_bndr rhs-             ; (floats, env2) <- go env1 pairs-             ; return (float `addFloats` floats, env2) }--{--simplOrTopPair is used for-        * recursive bindings (whether top level or not)-        * top-level non-recursive bindings--It assumes the binder has already been simplified, but not its IdInfo.--}--simplRecOrTopPair :: SimplEnv-                  -> TopLevelFlag -> RecFlag -> MaybeJoinCont-                  -> InId -> OutBndr -> InExpr  -- Binder and rhs-                  -> SimplM (SimplFloats, SimplEnv)--simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs-  | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env-  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}-    trace_bind "pre-inline-uncond" $-    do { tick (PreInlineUnconditionally old_bndr)-       ; return ( emptyFloats env, env' ) }--  | Just cont <- mb_cont-  = {-#SCC "simplRecOrTopPair-join" #-}-    ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )-    trace_bind "join" $-    simplJoinBind env cont old_bndr new_bndr rhs env--  | otherwise-  = {-#SCC "simplRecOrTopPair-normal" #-}-    trace_bind "normal" $-    simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env--  where-    dflags = seDynFlags env--    -- trace_bind emits a trace for each top-level binding, which-    -- helps to locate the tracing for inlining and rule firing-    trace_bind what thing_inside-      | not (dopt Opt_D_verbose_core2core dflags)-      = thing_inside-      | otherwise-      = traceAction dflags ("SimplBind " ++ what)-         (ppr old_bndr) thing_inside-----------------------------simplLazyBind :: SimplEnv-              -> TopLevelFlag -> RecFlag-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- Not a JoinId-                                        -- The OutId has IdInfo, except arity, unfolding-                                        -- Ids only, no TyVars-              -> InExpr -> SimplEnv     -- The RHS and its environment-              -> SimplM (SimplFloats, SimplEnv)--- Precondition: not a JoinId--- Precondition: rhs obeys the let/app invariant--- NOT used for JoinIds-simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se-  = ASSERT( isId bndr )-    ASSERT2( not (isJoinId bndr), ppr bndr )-    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $-    do  { let   rhs_env     = rhs_se `setInScopeFromE` env-                (tvs, body) = case collectTyAndValBinders rhs of-                                (tvs, [], body)-                                  | surely_not_lam body -> (tvs, body)-                                _                       -> ([], rhs)--                surely_not_lam (Lam {})     = False-                surely_not_lam (Tick t e)-                  | not (tickishFloatable t) = surely_not_lam e-                   -- eta-reduction could float-                surely_not_lam _            = True-                        -- Do not do the "abstract tyvar" thing if there's-                        -- a lambda inside, because it defeats eta-reduction-                        --    f = /\a. \x. g a x-                        -- should eta-reduce.---        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs-                -- See Note [Floating and type abstraction] in SimplUtils--        -- Simplify the RHS-        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))-        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont--              -- Never float join-floats out of a non-join let-binding-              -- So wrap the body in the join-floats right now-              -- Hence: body_floats1 consists only of let-floats-        ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0--        -- ANF-ise a constructor or PAP rhs-        -- We get at most one float per argument here-        ; (let_floats, body2) <- {-#SCC "prepareRhs" #-} prepareRhs (getMode env) top_lvl-                                            (getOccFS bndr1) (idInfo bndr1) body1-        ; let body_floats2 = body_floats1 `addLetFloats` let_floats--        ; (rhs_floats, rhs')-            <-  if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2)-                then                    -- No floating, revert to body1-                     {-#SCC "simplLazyBind-no-floating" #-}-                     do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont-                        ; return (emptyFloats env, rhs') }--                else if null tvs then   -- Simple floating-                     {-#SCC "simplLazyBind-simple-floating" #-}-                     do { tick LetFloatFromLet-                        ; return (body_floats2, body2) }--                else                    -- Do type-abstraction first-                     {-#SCC "simplLazyBind-type-abstraction-first" #-}-                     do { tick LetFloatFromLet-                        ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl-                                                                tvs' body_floats2 body2-                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds-                        ; rhs' <- mkLam env tvs' body3 rhs_cont-                        ; return (floats, rhs') }--        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)-                                             top_lvl Nothing bndr bndr1 rhs'-        ; return (rhs_floats `addFloats` bind_float, env2) }-----------------------------simplJoinBind :: SimplEnv-              -> SimplCont-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- The OutId has IdInfo, except arity,-                                        --   unfolding-              -> InExpr -> SimplEnv     -- The right hand side and its env-              -> SimplM (SimplFloats, SimplEnv)-simplJoinBind env cont old_bndr new_bndr rhs rhs_se-  = do  { let rhs_env = rhs_se `setInScopeFromE` env-        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont-        ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' }-----------------------------simplNonRecX :: SimplEnv-             -> InId            -- Old binder; not a JoinId-             -> OutExpr         -- Simplified RHS-             -> SimplM (SimplFloats, SimplEnv)--- A specialised variant of simplNonRec used when the RHS is already--- simplified, notably in knownCon.  It uses case-binding where necessary.------ Precondition: rhs satisfies the let/app invariant--simplNonRecX env bndr new_rhs-  | ASSERT2( not (isJoinId bndr), ppr bndr )-    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }-  = return (emptyFloats env, env)    --  Here c is dead, and we avoid-                                         --  creating the binding c = (a,b)--  | Coercion co <- new_rhs-  = return (emptyFloats env, extendCvSubst env bndr co)--  | otherwise-  = do  { (env', bndr') <- simplBinder env bndr-        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }-                -- simplNonRecX is only used for NotTopLevel things-----------------------------completeNonRecX :: TopLevelFlag -> SimplEnv-                -> Bool-                -> InId                 -- Old binder; not a JoinId-                -> OutId                -- New binder-                -> OutExpr              -- Simplified RHS-                -> SimplM (SimplFloats, SimplEnv)    -- The new binding is in the floats--- Precondition: rhs satisfies the let/app invariant---               See Note [Core let/app invariant] in GHC.Core--completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs-  = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )-    do  { (prepd_floats, rhs1) <- prepareRhs (getMode env) top_lvl (getOccFS new_bndr)-                                             (idInfo new_bndr) new_rhs-        ; let floats = emptyFloats env `addLetFloats` prepd_floats-        ; (rhs_floats, rhs2) <--                if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1-                then    -- Add the floats to the main env-                     do { tick LetFloatFromLet-                        ; return (floats, rhs1) }-                else    -- Do not float; wrap the floats around the RHS-                     return (emptyFloats env, wrapFloats floats rhs1)--        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)-                                             NotTopLevel Nothing-                                             old_bndr new_bndr rhs2-        ; return (rhs_floats `addFloats` bind_float, env2) }---{- *********************************************************************-*                                                                      *-           prepareRhs, makeTrivial-*                                                                      *-************************************************************************--Note [prepareRhs]-~~~~~~~~~~~~~~~~~-prepareRhs takes a putative RHS, checks whether it's a PAP or-constructor application and, if so, converts it to ANF, so that the-resulting thing can be inlined more easily.  Thus-        x = (f a, g b)-becomes-        t1 = f a-        t2 = g b-        x = (t1,t2)--We also want to deal well cases like this-        v = (f e1 `cast` co) e2-Here we want to make e1,e2 trivial and get-        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2-That's what the 'go' loop in prepareRhs does--}--prepareRhs :: SimplMode -> TopLevelFlag-           -> FastString   -- Base for any new variables-           -> IdInfo       -- IdInfo for the LHS of this binding-           -> OutExpr-           -> SimplM (LetFloats, OutExpr)--- Transforms a RHS into a better RHS by adding floats--- e.g        x = Just e--- becomes    a = e---            x = Just a--- See Note [prepareRhs]-prepareRhs mode top_lvl occ info (Cast rhs co)  -- Note [Float coercions]-  | let ty1 = coercionLKind co         -- Do *not* do this if rhs has an unlifted type-  , not (isUnliftedType ty1)                 -- see Note [Float coercions (unlifted)]-  = do  { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs-        ; return (floats, Cast rhs' co) }-  where-    sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info-                                   `setCprInfo`        cprInfo info-                                   `setDemandInfo`     demandInfo info--prepareRhs mode top_lvl occ _ rhs0-  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0-        ; return (floats, rhs1) }-  where-    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)-    go n_val_args (Cast rhs co)-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; return (is_exp, floats, Cast rhs' co) }-    go n_val_args (App fun (Type ty))-        = do { (is_exp, floats, rhs') <- go n_val_args fun-             ; return (is_exp, floats, App rhs' (Type ty)) }-    go n_val_args (App fun arg)-        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun-             ; case is_exp of-                False -> return (False, emptyLetFloats, App fun arg)-                True  -> do { (floats2, arg') <- makeTrivial mode top_lvl occ arg-                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }-    go n_val_args (Var fun)-        = return (is_exp, emptyLetFloats, Var fun)-        where-          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP-                        -- See Note [CONLIKE pragma] in BasicTypes-                        -- The definition of is_exp should match that in-                        -- OccurAnal.occAnalApp--    go n_val_args (Tick t rhs)-        -- We want to be able to float bindings past this-        -- tick. Non-scoping ticks don't care.-        | tickishScoped t == NoScope-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; return (is_exp, floats, Tick t rhs') }--        -- On the other hand, for scoping ticks we need to be able to-        -- copy them on the floats, which in turn is only allowed if-        -- we can obtain non-counting ticks.-        | (not (tickishCounts t) || tickishCanSplit t)-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)-                   floats' = mapLetFloats floats tickIt-             ; return (is_exp, floats', Tick t rhs') }--    go _ other-        = return (False, emptyLetFloats, other)--{--Note [Float coercions]-~~~~~~~~~~~~~~~~~~~~~~-When we find the binding-        x = e `cast` co-we'd like to transform it to-        x' = e-        x = x `cast` co         -- A trivial binding-There's a chance that e will be a constructor application or function, or something-like that, so moving the coercion to the usage site may well cancel the coercions-and lead to further optimisation.  Example:--     data family T a :: *-     data instance T Int = T Int--     foo :: Int -> Int -> Int-     foo m n = ...-        where-          x = T m-          go 0 = 0-          go n = case x of { T m -> go (n-m) }-                -- This case should optimise--Note [Preserve strictness when floating coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the Note [Float coercions] transformation, keep the strictness info.-Eg-        f = e `cast` co    -- f has strictness SSL-When we transform to-        f' = e             -- f' also has strictness SSL-        f = f' `cast` co   -- f still has strictness SSL--Its not wrong to drop it on the floor, but better to keep it.--Note [Float coercions (unlifted)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-BUT don't do [Float coercions] if 'e' has an unlifted type.-This *can* happen:--     foo :: Int = (error (# Int,Int #) "urk")-                  `cast` CoUnsafe (# Int,Int #) Int--If do the makeTrivial thing to the error call, we'll get-    foo = case error (# Int,Int #) "urk" of v -> v `cast` ...-But 'v' isn't in scope!--These strange casts can happen as a result of case-of-case-        bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of-                (# p,q #) -> p+q--}--makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)-makeTrivialArg mode (ValArg e)-  = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e-       ; return (floats, ValArg e') }-makeTrivialArg _ arg-  = return (emptyLetFloats, arg)  -- CastBy, TyArg--makeTrivial :: SimplMode -> TopLevelFlag-            -> FastString  -- ^ A "friendly name" to build the new binder from-            -> OutExpr     -- ^ This expression satisfies the let/app invariant-            -> SimplM (LetFloats, OutExpr)--- Binds the expression to a variable, if it's not trivial, returning the variable-makeTrivial mode top_lvl context expr- = makeTrivialWithInfo mode top_lvl context vanillaIdInfo expr--makeTrivialWithInfo :: SimplMode -> TopLevelFlag-                    -> FastString  -- ^ a "friendly name" to build the new binder from-                    -> IdInfo-                    -> OutExpr     -- ^ This expression satisfies the let/app invariant-                    -> SimplM (LetFloats, OutExpr)--- Propagate strictness and demand info to the new binder--- Note [Preserve strictness when floating coercions]--- Returned SimplEnv has same substitution as incoming one-makeTrivialWithInfo mode top_lvl occ_fs info expr-  | exprIsTrivial expr                          -- Already trivial-  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise-                                                --   See Note [Cannot trivialise]-  = return (emptyLetFloats, expr)--  | otherwise-  = do  { (floats, expr1) <- prepareRhs mode top_lvl occ_fs info expr-        ; if   exprIsTrivial expr1  -- See Note [Trivial after prepareRhs]-          then return (floats, expr1)-          else do-        { uniq <- getUniqueM-        ; let name = mkSystemVarName uniq occ_fs-              var  = mkLocalIdWithInfo name expr_ty info--        -- Now something very like completeBind,-        -- but without the postInlineUnconditinoally part-        ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1-        ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2--        ; let final_id = addLetBndrInfo var arity is_bot unf-              bind     = NonRec final_id expr2--        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }}-   where-     expr_ty = exprType expr--bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool--- True iff we can have a binding of this expression at this level--- Precondition: the type is the type of the expression-bindingOk top_lvl expr expr_ty-  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty-  | otherwise          = True--{- Note [Trivial after prepareRhs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we call makeTrival on (e |> co), the recursive use of prepareRhs-may leave us with-   { a1 = e }  and   (a1 |> co)-Now the latter is trivial, so we don't want to let-bind it.--Note [Cannot trivialise]-~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-   f :: Int -> Addr#--   foo :: Bar-   foo = Bar (f 3)--Then we can't ANF-ise foo, even though we'd like to, because-we can't make a top-level binding for the Addr# (f 3). And if-so we don't want to turn it into-   foo = let x = f 3 in Bar x-because we'll just end up inlining x back, and that makes the-simplifier loop.  Better not to ANF-ise it at all.--Literal strings are an exception.--   foo = Ptr "blob"#--We want to turn this into:--   foo1 = "blob"#-   foo = Ptr foo1--See Note [Core top-level string literals] in GHC.Core.--************************************************************************-*                                                                      *-          Completing a lazy binding-*                                                                      *-************************************************************************--completeBind-  * deals only with Ids, not TyVars-  * takes an already-simplified binder and RHS-  * is used for both recursive and non-recursive bindings-  * is used for both top-level and non-top-level bindings--It does the following:-  - tries discarding a dead binding-  - tries PostInlineUnconditionally-  - add unfolding [this is the only place we add an unfolding]-  - add arity--It does *not* attempt to do let-to-case.  Why?  Because it is used for-  - top-level bindings (when let-to-case is impossible)-  - many situations where the "rhs" is known to be a WHNF-                (so let-to-case is inappropriate).--Nor does it do the atomic-argument thing--}--completeBind :: SimplEnv-             -> TopLevelFlag            -- Flag stuck into unfolding-             -> MaybeJoinCont           -- Required only for join point-             -> InId                    -- Old binder-             -> OutId -> OutExpr        -- New binder and RHS-             -> SimplM (SimplFloats, SimplEnv)--- completeBind may choose to do its work---      * by extending the substitution (e.g. let x = y in ...)---      * or by adding to the floats in the envt------ Binder /can/ be a JoinId--- Precondition: rhs obeys the let/app invariant-completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs- | isCoVar old_bndr- = case new_rhs of-     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)-     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))-- | otherwise- = ASSERT( isId new_bndr )-   do { let old_info = idInfo old_bndr-            old_unf  = unfoldingInfo old_info-            occ_info = occInfo old_info--         -- Do eta-expansion on the RHS of the binding-         -- See Note [Eta-expanding at let bindings] in SimplUtils-      ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env)-                                                          new_bndr new_rhs--        -- Simplify the unfolding-      ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr-                                           final_rhs (idType new_bndr) old_unf--      ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding-        -- See Note [In-scope set as a substitution]--      ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs--        then -- Inline and discard the binding-             do  { tick (PostInlineUnconditionally old_bndr)-                 ; return ( emptyFloats env-                          , extendIdSubst env old_bndr $-                            DoneEx final_rhs (isJoinId_maybe new_bndr)) }-                -- Use the substitution to make quite, quite sure that the-                -- substitution will happen, since we are going to discard the binding--        else -- Keep the binding-             -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $-             return (mkFloatBind env (NonRec final_bndr final_rhs)) }--addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId-addLetBndrInfo new_bndr new_arity is_bot new_unf-  = new_bndr `setIdInfo` info5-  where-    info1 = idInfo new_bndr `setArityInfo` new_arity--    -- Unfolding info: Note [Setting the new unfolding]-    info2 = info1 `setUnfoldingInfo` new_unf--    -- Demand info: Note [Setting the demand info]-    -- We also have to nuke demand info if for some reason-    -- eta-expansion *reduces* the arity of the binding to less-    -- than that of the strictness sig. This can happen: see Note [Arity decrease].-    info3 | isEvaldUnfolding new_unf-            || (case strictnessInfo info2 of-                  StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)-          = zapDemandInfo info2 `orElse` info2-          | otherwise-          = info2--    -- Bottoming bindings: see Note [Bottoming bindings]-    info4 | is_bot    = info3-                          `setStrictnessInfo`-                            mkClosedStrictSig (replicate new_arity topDmd) botDiv-                          `setCprInfo` mkCprSig new_arity botCpr-          | otherwise = info3--     -- Zap call arity info. We have used it by now (via-     -- `tryEtaExpandRhs`), and the simplifier can invalidate this-     -- information, leading to broken code later (e.g. #13479)-    info5 = zapCallArityInfo info4---{- Note [Arity decrease]-~~~~~~~~~~~~~~~~~~~~~~~~-Generally speaking the arity of a binding should not decrease.  But it *can*-legitimately happen because of RULES.  Eg-        f = g Int-where g has arity 2, will have arity 2.  But if there's a rewrite rule-        g Int --> h-where h has arity 1, then f's arity will decrease.  Here's a real-life example,-which is in the output of Specialise:--     Rec {-        $dm {Arity 2} = \d.\x. op d-        {-# RULES forall d. $dm Int d = $s$dm #-}--        dInt = MkD .... opInt ...-        opInt {Arity 1} = $dm dInt--        $s$dm {Arity 0} = \x. op dInt }--Here opInt has arity 1; but when we apply the rule its arity drops to 0.-That's why Specialise goes to a little trouble to pin the right arity-on specialised functions too.--Note [Bottoming bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-   let x = error "urk"-   in ...(case x of <alts>)...-or-   let f = \x. error (x ++ "urk")-   in ...(case f "foo" of <alts>)...--Then we'd like to drop the dead <alts> immediately.  So it's good to-propagate the info that x's RHS is bottom to x's IdInfo as rapidly as-possible.--We use tryEtaExpandRhs on every binding, and it turns ou that the-arity computation it performs (via GHC.Core.Arity.findRhsArity) already-does a simple bottoming-expression analysis.  So all we need to do-is propagate that info to the binder's IdInfo.--This showed up in #12150; see comment:16.--Note [Setting the demand info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the unfolding is a value, the demand info may-go pear-shaped, so we nuke it.  Example:-     let x = (a,b) in-     case x of (p,q) -> h p q x-Here x is certainly demanded. But after we've nuked-the case, we'll get just-     let x = (a,b) in h a b x-and now x is not demanded (I'm assuming h is lazy)-This really happens.  Similarly-     let f = \x -> e in ...f..f...-After inlining f at some of its call sites the original binding may-(for example) be no longer strictly demanded.-The solution here is a bit ad hoc...---************************************************************************-*                                                                      *-\subsection[Simplify-simplExpr]{The main function: simplExpr}-*                                                                      *-************************************************************************--The reason for this OutExprStuff stuff is that we want to float *after*-simplifying a RHS, not before.  If we do so naively we get quadratic-behaviour as things float out.--To see why it's important to do it after, consider this (real) example:--        let t = f x-        in fst t-==>-        let t = let a = e1-                    b = e2-                in (a,b)-        in fst t-==>-        let a = e1-            b = e2-            t = (a,b)-        in-        a       -- Can't inline a this round, cos it appears twice-==>-        e1--Each of the ==> steps is a round of simplification.  We'd save a-whole round if we float first.  This can cascade.  Consider--        let f = g d-        in \x -> ...f...-==>-        let f = let d1 = ..d.. in \y -> e-        in \x -> ...f...-==>-        let d1 = ..d..-        in \x -> ...(\y ->e)...--Only in this second round can the \y be applied, and it-might do the same again.--}--simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr-simplExpr env (Type ty)-  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]-       ; return (Type ty') }--simplExpr env expr-  = simplExprC env expr (mkBoringStop expr_out_ty)-  where-    expr_out_ty :: OutType-    expr_out_ty = substTy env (exprType expr)-    -- NB: Since 'expr' is term-valued, not (Type ty), this call-    --     to exprType will succeed.  exprType fails on (Type ty).--simplExprC :: SimplEnv-           -> InExpr     -- A term-valued expression, never (Type ty)-           -> SimplCont-           -> SimplM OutExpr-        -- Simplify an expression, given a continuation-simplExprC env expr cont-  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $-    do  { (floats, expr') <- simplExprF env expr cont-        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $-          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $-          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $-          return (wrapFloats floats expr') }-----------------------------------------------------simplExprF :: SimplEnv-           -> InExpr     -- A term-valued expression, never (Type ty)-           -> SimplCont-           -> SimplM (SimplFloats, OutExpr)--simplExprF env e cont-  = {- pprTrace "simplExprF" (vcat-      [ ppr e-      , text "cont =" <+> ppr cont-      , text "inscope =" <+> ppr (seInScope env)-      , text "tvsubst =" <+> ppr (seTvSubst env)-      , text "idsubst =" <+> ppr (seIdSubst env)-      , text "cvsubst =" <+> ppr (seCvSubst env)-      ]) $ -}-    simplExprF1 env e cont--simplExprF1 :: SimplEnv -> InExpr -> SimplCont-            -> SimplM (SimplFloats, OutExpr)--simplExprF1 _ (Type ty) _-  = pprPanic "simplExprF: type" (ppr ty)-    -- simplExprF does only with term-valued expressions-    -- The (Type ty) case is handled separately by simplExpr-    -- and by the other callers of simplExprF--simplExprF1 env (Var v)        cont = {-#SCC "simplIdF" #-} simplIdF env v cont-simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont-simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont-simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont-simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont--simplExprF1 env (App fun arg) cont-  = {-#SCC "simplExprF1-App" #-} case arg of-      Type ty -> do { -- The argument type will (almost) certainly be used-                      -- in the output program, so just force it now.-                      -- See Note [Avoiding space leaks in OutType]-                      arg' <- simplType env ty--                      -- But use substTy, not simplType, to avoid forcing-                      -- the hole type; it will likely not be needed.-                      -- See Note [The hole type in ApplyToTy]-                    ; let hole' = substTy env (exprType fun)--                    ; simplExprF env fun $-                      ApplyToTy { sc_arg_ty  = arg'-                                , sc_hole_ty = hole'-                                , sc_cont    = cont } }-      _       -> simplExprF env fun $-                 ApplyToVal { sc_arg = arg, sc_env = env-                            , sc_dup = NoDup, sc_cont = cont }--simplExprF1 env expr@(Lam {}) cont-  = {-#SCC "simplExprF1-Lam" #-}-    simplLam env zapped_bndrs body cont-        -- The main issue here is under-saturated lambdas-        --   (\x1. \x2. e) arg1-        -- Here x1 might have "occurs-once" occ-info, because occ-info-        -- is computed assuming that a group of lambdas is applied-        -- all at once.  If there are too few args, we must zap the-        -- occ-info, UNLESS the remaining binders are one-shot-  where-    (bndrs, body) = collectBinders expr-    zapped_bndrs | need_to_zap = map zap bndrs-                 | otherwise   = bndrs--    need_to_zap = any zappable_bndr (drop n_args bndrs)-    n_args = countArgs cont-        -- NB: countArgs counts all the args (incl type args)-        -- and likewise drop counts all binders (incl type lambdas)--    zappable_bndr b = isId b && not (isOneShotBndr b)-    zap b | isTyVar b = b-          | otherwise = zapLamIdInfo b--simplExprF1 env (Case scrut bndr _ alts) cont-  = {-#SCC "simplExprF1-Case" #-}-    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr-                                 , sc_alts = alts-                                 , sc_env = env, sc_cont = cont })--simplExprF1 env (Let (Rec pairs) body) cont-  | Just pairs' <- joinPointBindings_maybe pairs-  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont--  | otherwise-  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont--simplExprF1 env (Let (NonRec bndr rhs) body) cont-  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)-  = {-#SCC "simplExprF1-NonRecLet-Type" #-}-    ASSERT( isTyVar bndr )-    do { ty' <- simplType env ty-       ; simplExprF (extendTvSubst env bndr ty') body cont }--  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs-  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont--  | otherwise-  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont--{- Note [Avoiding space leaks in OutType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Since the simplifier is run for multiple iterations, we need to ensure-that any thunks in the output of one simplifier iteration are forced-by the evaluation of the next simplifier iteration. Otherwise we may-retain multiple copies of the Core program and leak a terrible amount-of memory (as in #13426).--The simplifier is naturally strict in the entire "Expr part" of the-input Core program, because any expression may contain binders, which-we must find in order to extend the SimplEnv accordingly. But types-do not contain binders and so it is tempting to write things like--    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!--This is Bad because the result includes a thunk (substTy env ty) which-retains a reference to the whole simplifier environment; and the next-simplifier iteration will not force this thunk either, because the-line above is not strict in ty.--So instead our strategy is for the simplifier to fully evaluate-OutTypes when it emits them into the output Core program, for example--    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good-                                 ; return (Type ty') }--where the only difference from above is that simplType calls seqType-on the result of substTy.--However, SimplCont can also contain OutTypes and it's not necessarily-a good idea to force types on the way in to SimplCont, because they-may end up not being used and forcing them could be a lot of wasted-work. T5631 is a good example of this.--- For ApplyToTy's sc_arg_ty, we force the type on the way in because-  the type will almost certainly appear as a type argument in the-  output program.--- For the hole types in Stop and ApplyToTy, we force the type when we-  emit it into the output program, after obtaining it from-  contResultType. (The hole type in ApplyToTy is only directly used-  to form the result type in a new Stop continuation.)--}-------------------------------------- Simplify a join point, adding the context.--- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:---   \x1 .. xn -> e => \x1 .. xn -> E[e]--- Note that we need the arity of the join point, since e may be a lambda--- (though this is unlikely). See Note [Case-of-case and join points].-simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont-             -> SimplM OutExpr-simplJoinRhs env bndr expr cont-  | Just arity <- isJoinId_maybe bndr-  =  do { let (join_bndrs, join_body) = collectNBinders arity expr-        ; (env', join_bndrs') <- simplLamBndrs env join_bndrs-        ; join_body' <- simplExprC env' join_body cont-        ; return $ mkLams join_bndrs' join_body' }--  | otherwise-  = pprPanic "simplJoinRhs" (ppr bndr)------------------------------------simplType :: SimplEnv -> InType -> SimplM OutType-        -- Kept monadic just so we can do the seqType-        -- See Note [Avoiding space leaks in OutType]-simplType env ty-  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $-    seqType new_ty `seq` return new_ty-  where-    new_ty = substTy env ty------------------------------------simplCoercionF :: SimplEnv -> InCoercion -> SimplCont-               -> SimplM (SimplFloats, OutExpr)-simplCoercionF env co cont-  = do { co' <- simplCoercion env co-       ; rebuild env (Coercion co') cont }--simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion-simplCoercion env co-  = do { dflags <- getDynFlags-       ; let opt_co = optCoercion dflags (getTCvSubst env) co-       ; seqCo opt_co `seq` return opt_co }---------------------------------------- | Push a TickIt context outwards past applications and cases, as--- long as this is a non-scoping tick, to let case and application--- optimisations apply.--simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont-          -> SimplM (SimplFloats, OutExpr)-simplTick env tickish expr cont-  -- A scoped tick turns into a continuation, so that we can spot-  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do-  -- it this way, then it would take two passes of the simplifier to-  -- reduce ((scc t (\x . e)) e').-  -- NB, don't do this with counting ticks, because if the expr is-  -- bottom, then rebuildCall will discard the continuation.---- XXX: we cannot do this, because the simplifier assumes that--- the context can be pushed into a case with a single branch. e.g.---    scc<f>  case expensive of p -> e--- becomes---    case expensive of p -> scc<f> e------ So I'm disabling this for now.  It just means we will do more--- simplifier iterations that necessary in some cases.----  | tickishScoped tickish && not (tickishCounts tickish)---  = simplExprF env expr (TickIt tickish cont)--  -- For unscoped or soft-scoped ticks, we are allowed to float in new-  -- cost, so we simply push the continuation inside the tick.  This-  -- has the effect of moving the tick to the outside of a case or-  -- application context, allowing the normal case and application-  -- optimisations to fire.-  | tickish `tickishScopesLike` SoftScope-  = do { (floats, expr') <- simplExprF env expr cont-       ; return (floats, mkTick tickish expr')-       }--  -- Push tick inside if the context looks like this will allow us to-  -- do a case-of-case - see Note [case-of-scc-of-case]-  | Select {} <- cont, Just expr' <- push_tick_inside-  = simplExprF env expr' cont--  -- We don't want to move the tick, but we might still want to allow-  -- floats to pass through with appropriate wrapping (or not, see-  -- wrap_floats below)-  --- | not (tickishCounts tickish) || tickishCanSplit tickish-  -- = wrap_floats--  | otherwise-  = no_floating_past_tick-- where--  -- Try to push tick inside a case, see Note [case-of-scc-of-case].-  push_tick_inside =-    case expr0 of-      Case scrut bndr ty alts-             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)-      _other -> Nothing-   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)-         movable t      = not (tickishCounts t) ||-                          t `tickishScopesLike` NoScope ||-                          tickishCanSplit t-         tickScrut e    = foldr mkTick e ticks-         -- Alternatives get annotated with all ticks that scope in some way,-         -- but we don't want to count entries.-         tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope)-         ts_scope         = map mkNoCount $-                            filter (not . (`tickishScopesLike` NoScope)) ticks--  no_floating_past_tick =-    do { let (inc,outc) = splitCont cont-       ; (floats, expr1) <- simplExprF env expr inc-       ; let expr2    = wrapFloats floats expr1-             tickish' = simplTickish env tickish-       ; rebuild env (mkTick tickish' expr2) outc-       }---- Alternative version that wraps outgoing floats with the tick.  This--- results in ticks being duplicated, as we don't make any attempt to--- eliminate the tick if we re-inline the binding (because the tick--- semantics allows unrestricted inlining of HNFs), so I'm not doing--- this any more.  FloatOut will catch any real opportunities for--- floating.------  wrap_floats =---    do { let (inc,outc) = splitCont cont---       ; (env', expr') <- simplExprF (zapFloats env) expr inc---       ; let tickish' = simplTickish env tickish---       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),---                                   mkTick (mkNoCount tickish') rhs)---              -- when wrapping a float with mkTick, we better zap the Id's---              -- strictness info and arity, because it might be wrong now.---       ; let env'' = addFloats env (mapFloats env' wrap_float)---       ; rebuild env'' expr' (TickIt tickish' outc)---       }---  simplTickish env tickish-    | Breakpoint n ids <- tickish-          = Breakpoint n (map (getDoneId . substId env) ids)-    | otherwise = tickish--  -- Push type application and coercion inside a tick-  splitCont :: SimplCont -> (SimplCont, SimplCont)-  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)-    where (inc,outc) = splitCont tail-  splitCont (CastIt co c) = (CastIt co inc, outc)-    where (inc,outc) = splitCont c-  splitCont other = (mkBoringStop (contHoleType other), other)--  getDoneId (DoneId id)  = id-  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst-  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:------        case scctick<code_string.r1>---             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje---             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->---             (ww1_s13f, ww2_s13g, ww3_s13h)---             }---        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->---        tick<code_string.f1>---        (ww_s12Y,---         ww1_s12Z,---         PTTrees.PT---           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)---        }------ We really want this case-of-case to fire, because then the 3-tuple--- will go away (indeed, the CPR optimisation is relying on this--- happening).  But the scctick is in the way - we need to push it--- inside to expose the case-of-case.  So we perform this--- transformation on the inner case:------   scctick c (case e of { p1 -> e1; ...; pn -> en })---    ==>---   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }------ So we've moved a constant amount of work out of the scc to expose--- the case.  We only do this when the continuation is interesting: in--- for now, it has to be another Case (maybe generalise this later).--{--************************************************************************-*                                                                      *-\subsection{The main rebuilder}-*                                                                      *-************************************************************************--}--rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)--- At this point the substitution in the SimplEnv should be irrelevant;--- only the in-scope set matters-rebuild env expr cont-  = case cont of-      Stop {}          -> return (emptyFloats env, expr)-      TickIt t cont    -> rebuild env (mkTick t expr) cont-      CastIt co cont   -> rebuild env (mkCast expr co) cont-                       -- NB: mkCast implements the (Coercion co |> g) optimisation--      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }-        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont--      StrictArg { sc_fun = fun, sc_cont = cont }-        -> rebuildCall env (fun `addValArgTo` expr) cont-      StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body-                 , sc_env = se, sc_cont = cont }-        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr-                                  -- expr satisfies let/app since it started life-                                  -- in a call to simplNonRecE-              ; (floats2, expr') <- simplLam env' bs body cont-              ; return (floats1 `addFloats` floats2, expr') }--      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}-        -> rebuild env (App expr (Type ty)) cont--      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}-        -- See Note [Avoid redundant simplification]-        -> do { (_, _, arg') <- simplArg env dup_flag se arg-              ; rebuild env (App expr arg') cont }--{--************************************************************************-*                                                                      *-\subsection{Lambdas}-*                                                                      *-************************************************************************--}--{- Note [Optimising reflexivity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important (for compiler performance) to get rid of reflexivity as soon-as it appears.  See #11735, #14737, and #15019.--In particular, we want to behave well on-- *  e |> co1 |> co2-    where the two happen to cancel out entirely. That is quite common;-    e.g. a newtype wrapping and unwrapping cancel.--- * (f |> co) @t1 @t2 ... @tn x1 .. xm-   Here we wil use pushCoTyArg and pushCoValArg successively, which-   build up NthCo stacks.  Silly to do that if co is reflexive.--However, we don't want to call isReflexiveCo too much, because it uses-type equality which is expensive on big types (#14737 comment:7).--A good compromise (determined experimentally) seems to be to call-isReflexiveCo- * when composing casts, and- * at the end--In investigating this I saw missed opportunities for on-the-fly-coercion shrinkage. See #15090.--}---simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont-          -> SimplM (SimplFloats, OutExpr)-simplCast env body co0 cont0-  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0-        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}-                   if isReflCo co1-                   then return cont0  -- See Note [Optimising reflexivity]-                   else addCoerce co1 cont0-        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }-  where-        -- If the first parameter is MRefl, then simplifying revealed a-        -- reflexive coercion. Omit.-        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont-        addCoerceM MRefl   cont = return cont-        addCoerceM (MCo co) cont = addCoerce co cont--        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont-        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]-          | isReflexiveCo co' = return cont-          | otherwise         = addCoerce co' cont-          where-            co' = mkTransCo co1 co2--        addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })-          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty-            -- N.B. As mentioned in Note [The hole type in ApplyToTy] this is-            -- only needed by `sc_hole_ty` which is often not forced.-            -- Consequently it is worthwhile using a lazy pattern match here to-            -- avoid unnecessary coercionKind evaluations.-          , let hole_ty = coercionLKind co-          = {-#SCC "addCoerce-pushCoTyArg" #-}-            do { tail' <- addCoerceM m_co' tail-               ; return (cont { sc_arg_ty  = arg_ty'-                              , sc_hole_ty = hole_ty  -- NB!  As the cast goes past, the-                                                      -- type of the hole changes (#16312)-                              , sc_cont    = tail' }) }--        addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se-                                      , sc_dup = dup, sc_cont = tail })-          | Just (co1, m_co2) <- pushCoValArg co-          , let new_ty = coercionRKind co1-          , not (isTypeLevPoly new_ty)  -- Without this check, we get a lev-poly arg-                                        -- See Note [Levity polymorphism invariants] in GHC.Core-                                        -- test: typecheck/should_run/EtaExpandLevPoly-          = {-#SCC "addCoerce-pushCoValArg" #-}-            do { tail' <- addCoerceM m_co2 tail-               ; if isReflCo co1-                 then return (cont { sc_cont = tail' })-                      -- Avoid simplifying if possible;-                      -- See Note [Avoiding exponential behaviour]-                 else do-               { (dup', arg_se', arg') <- simplArg env dup arg_se arg-                    -- When we build the ApplyTo we can't mix the OutCoercion-                    -- 'co' with the InExpr 'arg', so we simplify-                    -- to make it all consistent.  It's a bit messy.-                    -- But it isn't a common case.-                    -- Example of use: #995-               ; return (ApplyToVal { sc_arg  = mkCast arg' co1-                                    , sc_env  = arg_se'-                                    , sc_dup  = dup'-                                    , sc_cont = tail' }) } }--        addCoerce co cont-          | isReflexiveCo co = return cont  -- Having this at the end makes a huge-                                            -- difference in T12227, for some reason-                                            -- See Note [Optimising reflexivity]-          | otherwise        = return (CastIt co cont)--simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr-         -> SimplM (DupFlag, StaticEnv, OutExpr)-simplArg env dup_flag arg_env arg-  | isSimplified dup_flag-  = return (dup_flag, arg_env, arg)-  | otherwise-  = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg-       ; return (Simplified, zapSubstEnv arg_env, arg') }--{--************************************************************************-*                                                                      *-\subsection{Lambdas}-*                                                                      *-************************************************************************--}--simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont-         -> SimplM (SimplFloats, OutExpr)--simplLam env [] body cont-  = simplExprF env body cont--simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })-  = do { tick (BetaReduction bndr)-       ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont }--simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se-                                           , sc_cont = cont, sc_dup = dup })-  | isSimplified dup  -- Don't re-simplify if we've simplified it once-                      -- See Note [Avoiding exponential behaviour]-  = do  { tick (BetaReduction bndr)-        ; (floats1, env') <- simplNonRecX env zapped_bndr arg-        ; (floats2, expr') <- simplLam env' bndrs body cont-        ; return (floats1 `addFloats` floats2, expr') }--  | otherwise-  = do  { tick (BetaReduction bndr)-        ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont }-  where-    zapped_bndr  -- See Note [Zap unfolding when beta-reducing]-      | isId bndr = zapStableUnfolding bndr-      | otherwise = bndr--      -- Discard a non-counting tick on a lambda.  This may change the-      -- cost attribution slightly (moving the allocation of the-      -- lambda elsewhere), but we don't care: optimisation changes-      -- cost attribution all the time.-simplLam env bndrs body (TickIt tickish cont)-  | not (tickishCounts tickish)-  = simplLam env bndrs body cont--        -- Not enough args, so there are real lambdas left to put in the result-simplLam env bndrs body cont-  = do  { (env', bndrs') <- simplLamBndrs env bndrs-        ; body' <- simplExpr env' body-        ; new_lam <- mkLam env bndrs' body' cont-        ; rebuild env' new_lam cont }----------------simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)--- Used for lambda binders.  These sometimes have unfoldings added by--- the worker/wrapper pass that must be preserved, because they can't--- be reconstructed from context.  For example:---      f x = case x of (a,b) -> fw a b x---      fw a b x{=(a,b)} = ...--- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.-simplLamBndr env bndr-  | isId bndr && isFragileUnfolding old_unf   -- Special case-  = do { (env1, bndr1) <- simplBinder env bndr-       ; unf'          <- simplStableUnfolding env1 NotTopLevel Nothing bndr-                                               old_unf (idType bndr1)-       ; let bndr2 = bndr1 `setIdUnfolding` unf'-       ; return (modifyInScope env1 bndr2, bndr2) }--  | otherwise-  = simplBinder env bndr                -- Normal case-  where-    old_unf = idUnfolding bndr--simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])-simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs---------------------simplNonRecE :: SimplEnv-             -> InId                    -- The binder, always an Id-                                        -- Never a join point-             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)-             -> ([InBndr], InExpr)      -- Body of the let/lambda-                                        --      \xs.e-             -> SimplCont-             -> SimplM (SimplFloats, OutExpr)---- simplNonRecE is used for---  * non-top-level non-recursive non-join-point lets in expressions---  * beta reduction------ simplNonRec env b (rhs, rhs_se) (bs, body) k---   = let env in---     cont< let b = rhs_se(rhs) in \bs.body >------ It deals with strict bindings, via the StrictBind continuation,--- which may abort the whole process------ Precondition: rhs satisfies the let/app invariant---               Note [Core let/app invariant] in GHC.Core------ The "body" of the binding comes as a pair of ([InId],InExpr)--- representing a lambda; so we recurse back to simplLam--- Why?  Because of the binder-occ-info-zapping done before---       the call to simplLam in simplExprF (Lam ...)--simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont-  | ASSERT( isId bndr && not (isJoinId bndr) ) True-  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se-  = do { tick (PreInlineUnconditionally bndr)-       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $-         simplLam env' bndrs body cont }--  -- Deal with strict bindings-  | isStrictId bndr          -- Includes coercions-  , sm_case_case (getMode env)-  = simplExprF (rhs_se `setInScopeFromE` env) rhs-               (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body-                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })--  -- Deal with lazy bindings-  | otherwise-  = ASSERT( not (isTyVar bndr) )-    do { (env1, bndr1) <- simplNonRecBndr env bndr-       ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing-       ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se-       ; (floats2, expr') <- simplLam env3 bndrs body cont-       ; return (floats1 `addFloats` floats2, expr') }---------------------simplRecE :: SimplEnv-          -> [(InId, InExpr)]-          -> InExpr-          -> SimplCont-          -> SimplM (SimplFloats, OutExpr)---- simplRecE is used for---  * non-top-level recursive lets in expressions-simplRecE env pairs body cont-  = do  { let bndrs = map fst pairs-        ; MASSERT(all (not . isJoinId) bndrs)-        ; env1 <- simplRecBndrs env bndrs-                -- NB: bndrs' don't have unfoldings or rules-                -- We add them as we go down-        ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs-        ; (floats2, expr') <- simplExprF env2 body cont-        ; return (floats1 `addFloats` floats2, expr') }--{- Note [Avoiding exponential behaviour]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-One way in which we can get exponential behaviour is if we simplify a-big expression, and the re-simplify it -- and then this happens in a-deeply-nested way.  So we must be jolly careful about re-simplifying-an expression.  That is why completeNonRecX does not try-preInlineUnconditionally.--Example:-  f BIG, where f has a RULE-Then- * We simplify BIG before trying the rule; but the rule does not fire- * We inline f = \x. x True- * So if we did preInlineUnconditionally we'd re-simplify (BIG True)--However, if BIG has /not/ already been simplified, we'd /like/ to-simplify BIG True; maybe good things happen.  That is why--* simplLam has-    - a case for (isSimplified dup), which goes via simplNonRecX, and-    - a case for the un-simplified case, which goes via simplNonRecE--* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,-  in at least two places-    - In simplCast/addCoerce, where we check for isReflCo-    - In rebuildCall we avoid simplifying arguments before we have to-      (see Note [Trying rewrite rules])---Note [Zap unfolding when beta-reducing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Lambda-bound variables can have stable unfoldings, such as-   $j = \x. \b{Unf=Just x}. e-See Note [Case binders and join points] below; the unfolding for lets-us optimise e better.  However when we beta-reduce it we want to-revert to using the actual value, otherwise we can end up in the-stupid situation of-          let x = blah in-          let b{Unf=Just x} = y-          in ...b...-Here it'd be far better to drop the unfolding and use the actual RHS.--************************************************************************-*                                                                      *-                     Join points-*                                                                      *-********************************************************************* -}--{- Note [Rules and unfolding for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--   simplExpr (join j x = rhs                         ) cont-             (      {- RULE j (p:ps) = blah -}       )-             (      {- StableUnfolding j = blah -}   )-             (in blah                                )--Then we will push 'cont' into the rhs of 'j'.  But we should *also* push-'cont' into the RHS of-  * Any RULEs for j, e.g. generated by SpecConstr-  * Any stable unfolding for j, e.g. the result of an INLINE pragma--Simplifying rules and stable-unfoldings happens a bit after-simplifying the right-hand side, so we remember whether or not it-is a join point, and what 'cont' is, in a value of type MaybeJoinCont--#13900 wsa caused by forgetting to push 'cont' into the RHS-of a SpecConstr-generated RULE for a join point.--}--type MaybeJoinCont = Maybe SimplCont-  -- Nothing => Not a join point-  -- Just k  => This is a join binding with continuation k-  -- See Note [Rules and unfolding for join points]--simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr-                     -> InExpr -> SimplCont-                     -> SimplM (SimplFloats, OutExpr)-simplNonRecJoinPoint env bndr rhs body cont-  | ASSERT( isJoinId bndr ) True-  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env-  = do { tick (PreInlineUnconditionally bndr)-       ; simplExprF env' body cont }--   | otherwise-   = wrapJoinCont env cont $ \ env cont ->-     do { -- We push join_cont into the join RHS and the body;-          -- and wrap wrap_cont around the whole thing-        ; let res_ty = contResultType cont-        ; (env1, bndr1)    <- simplNonRecJoinBndr env res_ty bndr-        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (Just cont)-        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env-        ; (floats2, body') <- simplExprF env3 body cont-        ; return (floats1 `addFloats` floats2, body') }----------------------simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]-                  -> InExpr -> SimplCont-                  -> SimplM (SimplFloats, OutExpr)-simplRecJoinPoint env pairs body cont-  = wrapJoinCont env cont $ \ env cont ->-    do { let bndrs = map fst pairs-             res_ty = contResultType cont-       ; env1 <- simplRecJoinBndrs env res_ty bndrs-               -- NB: bndrs' don't have unfoldings or rules-               -- We add them as we go down-       ; (floats1, env2)  <- simplRecBind env1 NotTopLevel (Just cont) pairs-       ; (floats2, body') <- simplExprF env2 body cont-       ; return (floats1 `addFloats` floats2, body') }-----------------------wrapJoinCont :: SimplEnv -> SimplCont-             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))-             -> SimplM (SimplFloats, OutExpr)--- Deal with making the continuation duplicable if necessary,--- and with the no-case-of-case situation.-wrapJoinCont env cont thing_inside-  | contIsStop cont        -- Common case; no need for fancy footwork-  = thing_inside env cont--  | not (sm_case_case (getMode env))-    -- See Note [Join points with -fno-case-of-case]-  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))-       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1-       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont-       ; return (floats2 `addFloats` floats3, expr3) }--  | otherwise-    -- Normal case; see Note [Join points and case-of-case]-  = do { (floats1, cont')  <- mkDupableCont env cont-       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'-       ; return (floats1 `addFloats` floats2, result) }------------------------trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont--- Drop outer context from join point invocation (jump)--- See Note [Join points and case-of-case]--trimJoinCont _ Nothing cont-  = cont -- Not a jump-trimJoinCont var (Just arity) cont-  = trim arity cont-  where-    trim 0 cont@(Stop {})-      = cont-    trim 0 cont-      = mkBoringStop (contResultType cont)-    trim n cont@(ApplyToVal { sc_cont = k })-      = cont { sc_cont = trim (n-1) k }-    trim n cont@(ApplyToTy { sc_cont = k })-      = cont { sc_cont = trim (n-1) k } -- join arity counts types!-    trim _ cont-      = pprPanic "completeCall" $ ppr var $$ ppr cont---{- Note [Join points and case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we perform the case-of-case transform (or otherwise push continuations-inward), we want to treat join points specially. Since they're always-tail-called and we want to maintain this invariant, we can do this (for any-evaluation context E):--  E[join j = e-    in case ... of-         A -> jump j 1-         B -> jump j 2-         C -> f 3]--    -->--  join j = E[e]-  in case ... of-       A -> jump j 1-       B -> jump j 2-       C -> E[f 3]--As is evident from the example, there are two components to this behavior:--  1. When entering the RHS of a join point, copy the context inside.-  2. When a join point is invoked, discard the outer context.--We need to be very careful here to remain consistent---neither part is-optional!--We need do make the continuation E duplicable (since we are duplicating it)-with mkDuableCont.---Note [Join points with -fno-case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Supose case-of-case is switched off, and we are simplifying--    case (join j x = <j-rhs> in-          case y of-             A -> j 1-             B -> j 2-             C -> e) of <outer-alts>--Usually, we'd push the outer continuation (case . of <outer-alts>) into-both the RHS and the body of the join point j.  But since we aren't doing-case-of-case we may then end up with this totally bogus result--    join x = case <j-rhs> of <outer-alts> in-    case (case y of-             A -> j 1-             B -> j 2-             C -> e) of <outer-alts>--This would be OK in the language of the paper, but not in GHC: j is no longer-a join point.  We can only do the "push continuation into the RHS of the-join point j" if we also push the continuation right down to the /jumps/ to-j, so that it can evaporate there.  If we are doing case-of-case, we'll get to--    join x = case <j-rhs> of <outer-alts> in-    case y of-      A -> j 1-      B -> j 2-      C -> case e of <outer-alts>--which is great.--Bottom line: if case-of-case is off, we must stop pushing the continuation-inwards altogether at any join point.  Instead simplify the (join ... in ...)-with a Stop continuation, and wrap the original continuation around the-outside.  Surprisingly tricky!---************************************************************************-*                                                                      *-                     Variables-*                                                                      *-************************************************************************--}--simplVar :: SimplEnv -> InVar -> SimplM OutExpr--- Look up an InVar in the environment-simplVar env var-  | isTyVar var = return (Type (substTyVar env var))-  | isCoVar var = return (Coercion (substCoVar env var))-  | otherwise-  = case substId env var of-        ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e-        DoneId var1          -> return (Var var1)-        DoneEx e _           -> return e--simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)-simplIdF env var cont-  = case substId env var of-      ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont-                                -- Don't trim; haven't already simplified e,-                                -- so the cont is not embodied in e--      DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont)--      DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont)-              -- Note [zapSubstEnv]-              -- The template is already simplified, so don't re-substitute.-              -- This is VITAL.  Consider-              --      let x = e in-              --      let y = \z -> ...x... in-              --      \ x -> ...y...-              -- We'll clone the inner \x, adding x->x' in the id_subst-              -- Then when we inline y, we must *not* replace x by x' in-              -- the inlined copy!!--------------------------------------------------------------      Dealing with a call site--completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)-completeCall env var cont-  | Just expr <- callSiteInline dflags var active_unf-                                lone_variable arg_infos interesting_cont-  -- Inline the variable's RHS-  = do { checkedTick (UnfoldingDone var)-       ; dump_inline expr cont-       ; simplExprF (zapSubstEnv env) expr cont }--  | otherwise-  -- Don't inline; instead rebuild the call-  = do { rule_base <- getSimplRules-       ; let info = mkArgInfo env var (getRules rule_base var)-                              n_val_args call_cont-       ; rebuildCall env info cont }--  where-    dflags = seDynFlags env-    (lone_variable, arg_infos, call_cont) = contArgs cont-    n_val_args       = length arg_infos-    interesting_cont = interestingCallContext env call_cont-    active_unf       = activeUnfolding (getMode env) var--    log_inlining doc-      = liftIO $ dumpAction dflags-           (mkUserStyle dflags alwaysQualify AllTheWay)-           (dumpOptionsFromFlag Opt_D_dump_inlinings)-           "" FormatText doc--    dump_inline unfolding cont-      | not (dopt Opt_D_dump_inlinings dflags) = return ()-      | not (dopt Opt_D_verbose_core2core dflags)-      = when (isExternalName (idName var)) $-            log_inlining $-                sep [text "Inlining done:", nest 4 (ppr var)]-      | otherwise-      = liftIO $ log_inlining $-           sep [text "Inlining done: " <> ppr var,-                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),-                              text "Cont:  " <+> ppr cont])]--rebuildCall :: SimplEnv-            -> ArgInfo-            -> SimplCont-            -> SimplM (SimplFloats, OutExpr)--- We decided not to inline, so---    - simplify the arguments---    - try rewrite rules---    - and rebuild------------ Bottoming applications ---------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont-  -- When we run out of strictness args, it means-  -- that the call is definitely bottom; see SimplUtils.mkArgInfo-  -- Then we want to discard the entire strict continuation.  E.g.-  --    * case (error "hello") of { ... }-  --    * (error "Hello") arg-  --    * f (error "Hello") where f is strict-  --    etc-  -- Then, especially in the first of these cases, we'd like to discard-  -- the continuation, leaving just the bottoming expression.  But the-  -- type might not be right, so we may have to add a coerce.-  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial-                                 -- continuation to discard, else we do it-                                 -- again and again!-  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]-    return (emptyFloats env, castBottomExpr res cont_ty)-  where-    res     = argInfoExpr fun rev_args-    cont_ty = contResultType cont------------ Try rewrite RULES ----------------- See Note [Trying rewrite rules]-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args-                              , ai_rules = Just (nr_wanted, rules) }) cont-  | 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]-    -- See also Note [Rules for recursive functions]-    do { mb_match <- tryRules env rules fun (reverse rev_args) cont-       ; case mb_match of-             Just (env', rhs, cont') -> simplExprF env' rhs cont'-             Nothing                 -> rebuildCall env info' cont }-  where-    no_more_args = case cont of-                      ApplyToTy  {} -> False-                      ApplyToVal {} -> False-                      _             -> True------------- Simplify applications and casts ---------------rebuildCall env info (CastIt co cont)-  = rebuildCall env (addCastTo info co) cont--rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })-  = rebuildCall env (addTyArgTo info arg_ty) cont--rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty-                              , ai_strs = str:strs, ai_discs = disc:discs })-            (ApplyToVal { sc_arg = arg, sc_env = arg_se-                        , sc_dup = dup_flag, sc_cont = cont })-  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]-  = rebuildCall env (addValArgTo info' arg) cont--  | str         -- Strict argument-  , sm_case_case (getMode env)-  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $-    simplExprF (arg_se `setInScopeFromE` env) arg-               (StrictArg { sc_fun = info', sc_cci = cci_strict-                          , sc_dup = Simplified, sc_cont = cont })-                -- Note [Shadowing]--  | otherwise                           -- Lazy argument-        -- DO NOT float anything outside, hence simplExprC-        -- There is no benefit (unlike in a let-binding), and we'd-        -- have to be very careful about bogus strictness through-        -- floating a demanded let.-  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg-                             (mkLazyArgStop arg_ty cci_lazy)-        ; rebuildCall env (addValArgTo info' arg') cont }-  where-    info'  = info { ai_strs = strs, ai_discs = discs }-    arg_ty = funArgTy fun_ty--    -- Use this for lazy arguments-    cci_lazy | encl_rules = RuleArgCtxt-             | disc > 0   = DiscArgCtxt  -- Be keener here-             | otherwise  = BoringCtxt   -- Nothing interesting--    -- ..and this for strict arguments-    cci_strict | encl_rules = RuleArgCtxt-               | disc > 0   = DiscArgCtxt-               | otherwise  = RhsCtxt-      -- Why RhsCtxt?  if we see f (g x) (h x), and f is strict, we-      -- want to be a bit more eager to inline g, because it may-      -- expose an eval (on x perhaps) that can be eliminated or-      -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1-      -- It's worth an 18% improvement in allocation for this-      -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'------------ No further useful info, revert to generic rebuild -------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont-  = rebuild env (argInfoExpr fun rev_args) cont--{- Note [Trying rewrite rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet-simplified.  We want to simplify enough arguments to allow the rules-to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone-is sufficient.  Example: class ops-   (+) dNumInt e2 e3-If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the-latter's strictness when simplifying e2, e3.  Moreover, suppose we have-  RULE  f Int = \x. x True--Then given (f Int e1) we rewrite to-   (\x. x True) e1-without simplifying e1.  Now we can inline x into its unique call site,-and absorb the True into it all in the same pass.  If we simplified-e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].--So we try to apply rules if either-  (a) no_more_args: we've run out of argument that the rules can "see"-  (b) nr_wanted: none of the rules wants any more arguments---Note [RULES apply to simplified arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very desirable to try RULES once the arguments have been simplified, because-doing so ensures that rule cascades work in one pass.  Consider-   {-# RULES g (h x) = k x-             f (k x) = x #-}-   ...f (g (h x))...-Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If-we match f's rules against the un-simplified RHS, it won't match.  This-makes a particularly big difference when superclass selectors are involved:-        op ($p1 ($p2 (df d)))-We want all this to unravel in one sweep.--Note [Avoid redundant simplification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because RULES apply to simplified arguments, there's a danger of repeatedly-simplifying already-simplified arguments.  An important example is that of-        (>>=) d e1 e2-Here e1, e2 are simplified before the rule is applied, but don't really-participate in the rule firing. So we mark them as Simplified to avoid-re-simplifying them.--Note [Shadowing]-~~~~~~~~~~~~~~~~-This part of the simplifier may break the no-shadowing invariant-Consider-        f (...(\a -> e)...) (case y of (a,b) -> e')-where f is strict in its second arg-If we simplify the innermost one first we get (...(\a -> e)...)-Simplifying the second arg makes us float the case out, so we end up with-        case y of (a,b) -> f (...(\a -> e)...) e'-So the output does not have the no-shadowing invariant.  However, there is-no danger of getting name-capture, because when the first arg was simplified-we used an in-scope set that at least mentioned all the variables free in its-static environment, and that is enough.--We can't just do innermost first, or we'd end up with a dual problem:-        case x of (a,b) -> f e (...(\a -> e')...)--I spent hours trying to recover the no-shadowing invariant, but I just could-not think of an elegant way to do it.  The simplifier is already knee-deep in-continuations.  We have to keep the right in-scope set around; AND we have-to get the effect that finding (error "foo") in a strict arg position will-discard the entire application and replace it with (error "foo").  Getting-all this at once is TOO HARD!---************************************************************************-*                                                                      *-                Rewrite rules-*                                                                      *-************************************************************************--}--tryRules :: SimplEnv -> [CoreRule]-         -> Id -> [ArgSpec]-         -> SimplCont-         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--tryRules env rules fn args call_cont-  | null rules-  = return Nothing--{- Disabled until we fix #8326-  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]-  , [_type_arg, val_arg] <- args-  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont-  , isDeadBinder bndr-  = do { let enum_to_tag :: CoreAlt -> CoreAlt-                -- Takes   K -> e  into   tagK# -> e-                -- where tagK# is the tag of constructor K-             enum_to_tag (DataAlt con, [], rhs)-               = ASSERT( isEnumerationTyCon (dataConTyCon con) )-                (LitAlt tag, [], rhs)-              where-                tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))-             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)--             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts-             new_bndr = setIdType bndr intPrimTy-                 -- The binder is dead, but should have the right type-      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }--}--  | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env)-                                        (activeRule (getMode env)) fn-                                        (argInfoAppArgs args) rules-  -- Fire a rule for the function-  = do { checkedTick (RuleFired (ruleName rule))-       ; let cont' = pushSimplifiedArgs zapped_env-                                        (drop (ruleArity rule) args)-                                        call_cont-                     -- (ruleArity rule) says how-                     -- many args the rule consumed--             occ_anald_rhs = occurAnalyseExpr rule_rhs-                 -- See Note [Occurrence-analyse after rule firing]-       ; dump rule rule_rhs-       ; return (Just (zapped_env, occ_anald_rhs, cont')) }-            -- The occ_anald_rhs and cont' are all Out things-            -- hence zapping the environment--  | otherwise  -- No rule fires-  = do { nodump  -- This ensures that an empty file is written-       ; return Nothing }--  where-    dflags     = seDynFlags env-    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]--    printRuleModule rule-      = parens (maybe (text "BUILTIN")-                      (pprModuleName . moduleName)-                      (ruleModule rule))--    dump rule rule_rhs-      | dopt Opt_D_dump_rule_rewrites dflags-      = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat-          [ text "Rule:" <+> ftext (ruleName rule)-          , text "Module:" <+>  printRuleModule rule-          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))-          , text "After: " <+> pprCoreExpr rule_rhs-          , text "Cont:  " <+> ppr call_cont ]--      | dopt Opt_D_dump_rule_firings dflags-      = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $-          ftext (ruleName rule)-            <+> printRuleModule rule--      | otherwise-      = return ()--    nodump-      | dopt Opt_D_dump_rule_rewrites dflags-      = liftIO $ do-         touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites)--      | dopt Opt_D_dump_rule_firings dflags-      = liftIO $ do-         touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings)--      | otherwise-      = return ()--    log_rule dflags flag hdr details-      = liftIO $ do-         let sty = mkDumpStyle dflags alwaysQualify-         dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $-           sep [text hdr, nest 4 details]--trySeqRules :: SimplEnv-            -> OutExpr -> InExpr   -- Scrutinee and RHS-            -> SimplCont-            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--- See Note [User-defined RULES for seq]-trySeqRules in_env scrut rhs cont-  = do { rule_base <- getSimplRules-       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }-  where-    no_cast_scrut = drop_casts scrut-    scrut_ty  = exprType no_cast_scrut-    seq_id_ty = idType seqId-    res1_ty   = piResultTy seq_id_ty rhs_rep-    res2_ty   = piResultTy res1_ty   scrut_ty-    rhs_ty    = substTy in_env (exprType rhs)-    rhs_rep   = getRuntimeRep rhs_ty-    out_args  = [ TyArg { as_arg_ty  = rhs_rep-                        , as_hole_ty = seq_id_ty }-                , TyArg { as_arg_ty  = scrut_ty-                        , as_hole_ty = res1_ty }-                , TyArg { as_arg_ty  = rhs_ty-                        , as_hole_ty = res2_ty }-                , ValArg no_cast_scrut]-    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs-                           , sc_env = in_env, sc_cont = cont }-    -- Lazily evaluated, so we don't do most of this--    drop_casts (Cast e _) = drop_casts e-    drop_casts e          = e--{- Note [User-defined RULES for seq]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given-   case (scrut |> co) of _ -> rhs-look for rules that match the expression-   seq @t1 @t2 scrut-where scrut :: t1-      rhs   :: t2--If you find a match, rewrite it, and apply to 'rhs'.--Notice that we can simply drop casts on the fly here, which-makes it more likely that a rule will match.--See Note [User-defined RULES for seq] in MkId.--Note [Occurrence-analyse after rule firing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-After firing a rule, we occurrence-analyse the instantiated RHS before-simplifying it.  Usually this doesn't make much difference, but it can-be huge.  Here's an example (simplCore/should_compile/T7785)--  map f (map f (map f xs)--= -- Use build/fold form of map, twice-  map f (build (\cn. foldr (mapFB c f) n-                           (build (\cn. foldr (mapFB c f) n xs))))--= -- Apply fold/build rule-  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))--= -- Beta-reduce-  -- Alas we have no occurrence-analysed, so we don't know-  -- that c is used exactly once-  map f (build (\cn. let c1 = mapFB c f in-                     foldr (mapFB c1 f) n xs))--= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)-  -- We can do this because (mapFB c n) is a PAP and hence expandable-  map f (build (\cn. let c1 = mapFB c n in-                     foldr (mapFB c (f.f)) n x))--This is not too bad.  But now do the same with the outer map, and-we get another use of mapFB, and t can interact with /both/ remaining-mapFB calls in the above expression.  This is stupid because actually-that 'c1' binding is dead.  The outer map introduces another c2. If-there is a deep stack of maps we get lots of dead bindings, and lots-of redundant work as we repeatedly simplify the result of firing rules.--The easy thing to do is simply to occurrence analyse the result of-the rule firing.  Note that this occ-anals not only the RHS of the-rule, but also the function arguments, which by now are OutExprs.-E.g.-      RULE f (g x) = x+1--Call   f (g BIG)  -->   (\x. x+1) BIG--The rule binders are lambda-bound and applied to the OutExpr arguments-(here BIG) which lack all internal occurrence info.--Is this inefficient?  Not really: we are about to walk over the result-of the rule firing to simplify it, so occurrence analysis is at most-a constant factor.--Possible improvement: occ-anal the rules when putting them in the-database; and in the simplifier just occ-anal the OutExpr arguments.-But that's more complicated and the rule RHS is usually tiny; so I'm-just doing the simple thing.--Historical note: previously we did occ-anal the rules in Rule.hs,-but failed to occ-anal the OutExpr arguments, which led to the-nasty performance problem described above.---Note [Optimising tagToEnum#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an enumeration data type:--  data Foo = A | B | C--Then we want to transform--   case tagToEnum# x of   ==>    case x of-     A -> e1                       DEFAULT -> e1-     B -> e2                       1#      -> e2-     C -> e3                       2#      -> e3--thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT-alternative we retain it (remember it comes first).  If not the case must-be exhaustive, and we reflect that in the transformed version by adding-a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.-See #8317.--Note [Rules for recursive functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-You might think that we shouldn't apply rules for a loop breaker:-doing so might give rise to an infinite loop, because a RULE is-rather like an extra equation for the function:-     RULE:           f (g x) y = x+y-     Eqn:            f a     y = a-y--But it's too drastic to disable rules for loop breakers.-Even the foldr/build rule would be disabled, because foldr-is recursive, and hence a loop breaker:-     foldr k z (build g) = g k z-So it's up to the programmer: rules can cause divergence---************************************************************************-*                                                                      *-                Rebuilding a case expression-*                                                                      *-************************************************************************--Note [Case elimination]-~~~~~~~~~~~~~~~~~~~~~~~-The case-elimination transformation discards redundant case expressions.-Start with a simple situation:--        case x# of      ===>   let y# = x# in e-          y# -> e--(when x#, y# are of primitive type, of course).  We can't (in general)-do this for algebraic cases, because we might turn bottom into-non-bottom!--The code in SimplUtils.prepareAlts has the effect of generalise this-idea to look for a case where we're scrutinising a variable, and we-know that only the default case can match.  For example:--        case x of-          0#      -> ...-          DEFAULT -> ...(case x of-                         0#      -> ...-                         DEFAULT -> ...) ...--Here the inner case is first trimmed to have only one alternative, the-DEFAULT, after which it's an instance of the previous case.  This-really only shows up in eliminating error-checking code.--Note that SimplUtils.mkCase combines identical RHSs.  So--        case e of       ===> case e of DEFAULT -> r-           True  -> r-           False -> r--Now again the case may be eliminated by the CaseElim transformation.-This includes things like (==# a# b#)::Bool so that we simplify-      case ==# a# b# of { True -> x; False -> x }-to just-      x-This particular example shows up in default methods for-comparison operations (e.g. in (>=) for Int.Int32)--Note [Case to let transformation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a case over a lifted type has a single alternative, and is being-used as a strict 'let' (all isDeadBinder bndrs), we may want to do-this transformation:--    case e of r       ===>   let r = e in ...r...-      _ -> ...r...--We treat the unlifted and lifted cases separately:--* Unlifted case: 'e' satisfies exprOkForSpeculation-  (ok-for-spec is needed to satisfy the let/app invariant).-  This turns     case a +# b of r -> ...r...-  into           let r = a +# b in ...r...-  and thence     .....(a +# b)....--  However, if we have-      case indexArray# a i of r -> ...r...-  we might like to do the same, and inline the (indexArray# a i).-  But indexArray# is not okForSpeculation, so we don't build a let-  in rebuildCase (lest it get floated *out*), so the inlining doesn't-  happen either.  Annoying.--* Lifted case: we need to be sure that the expression is already-  evaluated (exprIsHNF).  If it's not already evaluated-      - we risk losing exceptions, divergence or-        user-specified thunk-forcing-      - even if 'e' is guaranteed to converge, we don't want to-        create a thunk (call by need) instead of evaluating it-        right away (call by value)--  However, we can turn the case into a /strict/ let if the 'r' is-  used strictly in the body.  Then we won't lose divergence; and-  we won't build a thunk because the let is strict.-  See also Note [Case-to-let for strictly-used binders]--  NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in GHC.Core.Make.-  We want to turn-     case (absentError "foo") of r -> ...MkT r...-  into-     let r = absentError "foo" in ...MkT r...---Note [Case-to-let for strictly-used binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have this:-   case <scrut> of r { _ -> ..r.. }--where 'r' is used strictly in (..r..), we can safely transform to-   let r = <scrut> in ...r...--This is a Good Thing, because 'r' might be dead (if the body just-calls error), or might be used just once (in which case it can be-inlined); or we might be able to float the let-binding up or down.-E.g. #15631 has an example.--Note that this can change the error behaviour.  For example, we might-transform-    case x of { _ -> error "bad" }-    --> error "bad"-which is might be puzzling if 'x' currently lambda-bound, but later gets-let-bound to (error "good").--Nevertheless, the paper "A semantics for imprecise exceptions" allows-this transformation. If you want to fix the evaluation order, use-'pseq'.  See #8900 for an example where the loss of this-transformation bit us in practice.--See also Note [Empty case alternatives] in GHC.Core.--Historical notes--There have been various earlier versions of this patch:--* By Sept 18 the code looked like this:-     || scrut_is_demanded_var scrut--    scrut_is_demanded_var :: CoreExpr -> Bool-    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s-    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)-    scrut_is_demanded_var _          = False--  This only fired if the scrutinee was a /variable/, which seems-  an unnecessary restriction. So in #15631 I relaxed it to allow-  arbitrary scrutinees.  Less code, less to explain -- but the change-  had 0.00% effect on nofib.--* Previously, in Jan 13 the code looked like this:-     || case_bndr_evald_next rhs--    case_bndr_evald_next :: CoreExpr -> Bool-      -- See Note [Case binder next]-    case_bndr_evald_next (Var v)         = v == case_bndr-    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e-    case_bndr_evald_next (App e _)       = case_bndr_evald_next e-    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e-    case_bndr_evald_next _               = False--  This patch was part of fixing #7542. See also-  Note [Eta reduction of an eval'd function] in GHC.Core.Utils.)---Further notes about case elimination-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:       test :: Integer -> IO ()-                test = print--Turns out that this compiles to:-    Print.test-      = \ eta :: Integer-          eta1 :: Void# ->-          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->-          case hPutStr stdout-                 (PrelNum.jtos eta ($w[] @ Char))-                 eta1-          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}--Notice the strange '<' which has no effect at all. This is a funny one.-It started like this:--f x y = if x < 0 then jtos x-          else if y==0 then "" else jtos x--At a particular call site we have (f v 1).  So we inline to get--        if v < 0 then jtos x-        else if 1==0 then "" else jtos x--Now simplify the 1==0 conditional:--        if v<0 then jtos v else jtos v--Now common-up the two branches of the case:--        case (v<0) of DEFAULT -> jtos v--Why don't we drop the case?  Because it's strict in v.  It's technically-wrong to drop even unnecessary evaluations, and in practice they-may be a result of 'seq' so we *definitely* don't want to drop those.-I don't really know how to improve this situation.---Note [FloatBinds from constructor wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have FloatBinds coming from the constructor wrapper-(as in Note [exprIsConApp_maybe on data constructors with wrappers]),-ew cannot float past them. We'd need to float the FloatBind-together with the simplify floats, unfortunately the-simplifier doesn't have case-floats. The simplest thing we can-do is to wrap all the floats here. The next iteration of the-simplifier will take care of all these cases and lets.--Given data T = MkT !Bool, this allows us to simplify-case $WMkT b of { MkT x -> f x }-to-case b of { b' -> f b' }.--We could try and be more clever (like maybe wfloats only contain-let binders, so we could float them). But the need for the-extra complication is not clear.--}--------------------------------------------------------------      Eliminate the case if possible--rebuildCase, reallyRebuildCase-   :: SimplEnv-   -> OutExpr          -- Scrutinee-   -> InId             -- Case binder-   -> [InAlt]          -- Alternatives (increasing order)-   -> SimplCont-   -> SimplM (SimplFloats, OutExpr)-------------------------------------------------------      1. Eliminate the case if there's a known constructor-----------------------------------------------------rebuildCase env scrut case_bndr alts cont-  | Lit lit <- scrut    -- No need for same treatment as constructors-                        -- because literals are inlined more vigorously-  , not (litIsLifted lit)-  = do  { tick (KnownBranch case_bndr)-        ; case findAlt (LitAlt lit) alts of-            Nothing           -> missingAlt env case_bndr alts cont-            Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs }--  | Just (in_scope', wfloats, con, ty_args, other_args)-      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut-        -- Works when the scrutinee is a variable with a known unfolding-        -- as well as when it's an explicit constructor application-  , let env0 = setInScopeSet env in_scope'-  = do  { tick (KnownBranch case_bndr)-        ; case findAlt (DataAlt con) alts of-            Nothing  -> missingAlt env0 case_bndr alts cont-            Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con)-                                                 `mkTyApps` ty_args-                                                 `mkApps`   other_args-                                       in simple_rhs env0 wfloats con_app bs rhs-            Just (_, bs, rhs)       -> knownCon env0 scrut wfloats con ty_args other_args-                                                case_bndr bs rhs cont-        }-  where-    simple_rhs env wfloats scrut' bs rhs =-      ASSERT( null bs )-      do { (floats1, env') <- simplNonRecX env case_bndr scrut'-             -- scrut is a constructor application,-             -- hence satisfies let/app invariant-         ; (floats2, expr') <- simplExprF env' rhs cont-         ; case wfloats of-             [] -> return (floats1 `addFloats` floats2, expr')-             _ -> return-               -- See Note [FloatBinds from constructor wrappers]-                   ( emptyFloats env,-                     GHC.Core.Make.wrapFloats wfloats $-                     wrapFloats (floats1 `addFloats` floats2) expr' )}--------------------------------------------------------      2. Eliminate the case if scrutinee is evaluated-----------------------------------------------------rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont-  -- See if we can get rid of the case altogether-  -- See Note [Case elimination]-  -- mkCase made sure that if all the alternatives are equal,-  -- then there is now only one (DEFAULT) rhs--  -- 2a.  Dropping the case altogether, if-  --      a) it binds nothing (so it's really just a 'seq')-  --      b) evaluating the scrutinee has no side effects-  | is_plain_seq-  , exprOkForSideEffects scrut-          -- The entire case is dead, so we can drop it-          -- if the scrutinee converges without having imperative-          -- side effects or raising a Haskell exception-          -- See Note [PrimOp can_fail and has_side_effects] in PrimOp-   = simplExprF env rhs cont--  -- 2b.  Turn the case into a let, if-  --      a) it binds only the case-binder-  --      b) unlifted case: the scrutinee is ok-for-speculation-  --           lifted case: the scrutinee is in HNF (or will later be demanded)-  -- See Note [Case to let transformation]-  | all_dead_bndrs-  , doCaseToLet scrut case_bndr-  = do { tick (CaseElim case_bndr)-       ; (floats1, env') <- simplNonRecX env case_bndr scrut-       ; (floats2, expr') <- simplExprF env' rhs cont-       ; return (floats1 `addFloats` floats2, expr') }--  -- 2c. Try the seq rules if-  --     a) it binds only the case binder-  --     b) a rule for seq applies-  -- See Note [User-defined RULES for seq] in MkId-  | is_plain_seq-  = do { mb_rule <- trySeqRules env scrut rhs cont-       ; case mb_rule of-           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'-           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }-  where-    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]-    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect--rebuildCase env scrut case_bndr alts cont-  = reallyRebuildCase env scrut case_bndr alts cont---doCaseToLet :: OutExpr          -- Scrutinee-            -> InId             -- Case binder-            -> Bool--- The situation is         case scrut of b { DEFAULT -> body }--- Can we transform thus?   let { b = scrut } in body-doCaseToLet scrut case_bndr-  | isTyCoVar case_bndr    -- Respect GHC.Core-  = isTyCoArg scrut        -- Note [Core type and coercion invariant]--  | isUnliftedType (idType case_bndr)-  = exprOkForSpeculation scrut--  | otherwise  -- Scrut has a lifted type-  = exprIsHNF scrut-    || isStrictDmd (idDemandInfo case_bndr)-    -- See Note [Case-to-let for strictly-used binders]-------------------------------------------------------      3. Catch-all case-----------------------------------------------------reallyRebuildCase env scrut case_bndr alts cont-  | not (sm_case_case (getMode env))-  = do { case_expr <- simplAlts env scrut case_bndr alts-                                (mkBoringStop (contHoleType cont))-       ; rebuild env case_expr cont }--  | otherwise-  = do { (floats, cont') <- mkDupableCaseCont env alts cont-       ; case_expr <- simplAlts (env `setInScopeFromF` floats)-                                scrut case_bndr alts cont'-       ; return (floats, case_expr) }--{--simplCaseBinder checks whether the scrutinee is a variable, v.  If so,-try to eliminate uses of v in the RHSs in favour of case_bndr; that-way, there's a chance that v will now only be used once, and hence-inlined.--Historical note: we use to do the "case binder swap" in the Simplifier-so there were additional complications if the scrutinee was a variable.-Now the binder-swap stuff is done in the occurrence analyser; see-OccurAnal Note [Binder swap].--Note [knownCon occ info]-~~~~~~~~~~~~~~~~~~~~~~~~-If the case binder is not dead, then neither are the pattern bound-variables:-        case <any> of x { (a,b) ->-        case x of { (p,q) -> p } }-Here (a,b) both look dead, but come alive after the inner case is eliminated.-The point is that we bring into the envt a binding-        let x = (a,b)-after the outer case, and that makes (a,b) alive.  At least we do unless-the case binder is guaranteed dead.--Note [Case alternative occ info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we are simply reconstructing a case (the common case), we always-zap the occurrence info on the binders in the alternatives.  Even-if the case binder is dead, the scrutinee is usually a variable, and *that*-can bring the case-alternative binders back to life.-See Note [Add unfolding for scrutinee]--Note [Improving seq]-~~~~~~~~~~~~~~~~~~~-Consider-        type family F :: * -> *-        type instance F Int = Int--We'd like to transform-        case e of (x :: F Int) { DEFAULT -> rhs }-===>-        case e `cast` co of (x'::Int)-           I# x# -> let x = x' `cast` sym co-                    in rhs--so that 'rhs' can take advantage of the form of x'.  Notice that Note-[Case of cast] (in OccurAnal) may then apply to the result.--We'd also like to eliminate empty types (#13468). So if--    data Void-    type instance F Bool = Void--then we'd like to transform-        case (x :: F Bool) of { _ -> error "urk" }-===>-        case (x |> co) of (x' :: Void) of {}--Nota Bene: we used to have a built-in rule for 'seq' that dropped-casts, so that-    case (x |> co) of { _ -> blah }-dropped the cast; in order to improve the chances of trySeqRules-firing.  But that works in the /opposite/ direction to Note [Improving-seq] so there's a danger of flip/flopping.  Better to make trySeqRules-insensitive to the cast, which is now is.--The need for [Improving seq] showed up in Roman's experiments.  Example:-  foo :: F Int -> Int -> Int-  foo t n = t `seq` bar n-     where-       bar 0 = 0-       bar n = bar (n - case t of TI i -> i)-Here we'd like to avoid repeated evaluating t inside the loop, by-taking advantage of the `seq`.--At one point I did transformation in LiberateCase, but it's more-robust here.  (Otherwise, there's a danger that we'll simply drop the-'seq' altogether, before LiberateCase gets to see it.)--}--simplAlts :: SimplEnv-          -> OutExpr         -- Scrutinee-          -> InId            -- Case binder-          -> [InAlt]         -- Non-empty-          -> SimplCont-          -> SimplM OutExpr  -- Returns the complete simplified case expression--simplAlts env0 scrut case_bndr alts cont'-  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr-                                      , text "cont':" <+> ppr cont'-                                      , text "in_scope" <+> ppr (seInScope env0) ])-        ; (env1, case_bndr1) <- simplBinder env0 case_bndr-        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding-              env2       = modifyInScope env1 case_bndr2-              -- See Note [Case binder evaluated-ness]--        ; fam_envs <- getFamEnvs-        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut-                                                       case_bndr case_bndr2 alts--        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts-          -- NB: it's possible that the returned in_alts is empty: this is handled-          -- by the caller (rebuildCase) in the missingAlt function--        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts-        ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $--        ; let alts_ty' = contResultType cont'-        -- See Note [Avoiding space leaks in OutType]-        ; seqType alts_ty' `seq`-          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }----------------------------------------improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv-           -> OutExpr -> InId -> OutId -> [InAlt]-           -> SimplM (SimplEnv, OutExpr, OutId)--- Note [Improving seq]-improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]-  | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)-  = do { case_bndr2 <- newId (fsLit "nt") ty2-        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing-              env2 = extendIdSubst env case_bndr rhs-        ; return (env2, scrut `Cast` co, case_bndr2) }--improveSeq _ env scrut _ case_bndr1 _-  = return (env, scrut, case_bndr1)----------------------------------------simplAlt :: SimplEnv-         -> Maybe OutExpr  -- The scrutinee-         -> [AltCon]       -- These constructors can't be present when-                           -- matching the DEFAULT alternative-         -> OutId          -- The case binder-         -> SimplCont-         -> InAlt-         -> SimplM OutAlt--simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)-  = ASSERT( null bndrs )-    do  { let env' = addBinderUnfolding env case_bndr'-                                        (mkOtherCon imposs_deflt_cons)-                -- Record the constructors that the case-binder *can't* be.-        ; rhs' <- simplExprC env' rhs cont'-        ; return (DEFAULT, [], rhs') }--simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)-  = ASSERT( null bndrs )-    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)-        ; rhs' <- simplExprC env' rhs cont'-        ; return (LitAlt lit, [], rhs') }--simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)-  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]-          let vs_with_evals = addEvals scrut' con vs-        ; (env', vs') <- simplLamBndrs env vs_with_evals--                -- Bind the case-binder to (con args)-        ; let inst_tys' = tyConAppArgs (idType case_bndr')-              con_app :: OutExpr-              con_app   = mkConApp2 con inst_tys' vs'--        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app-        ; rhs' <- simplExprC env'' rhs cont'-        ; return (DataAlt con, vs', rhs') }--{- Note [Adding evaluatedness info to pattern-bound variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-addEvals records the evaluated-ness of the bound variables of-a case pattern.  This is *important*.  Consider--     data T = T !Int !Int--     case x of { T a b -> T (a+1) b }--We really must record that b is already evaluated so that we don't-go and re-evaluate it when constructing the result.-See Note [Data-con worker strictness] in MkId.hs--NB: simplLamBinders preserves this eval info--In addition to handling data constructor fields with !s, addEvals-also records the fact that the result of seq# is always in WHNF.-See Note [seq# magic] in PrelRules.  Example (#15226):--  case seq# v s of-    (# s', v' #) -> E--we want the compiler to be aware that v' is in WHNF in E.--Open problem: we don't record that v itself is in WHNF (and we can't-do it here).  The right thing is to do some kind of binder-swap;-see #15226 for discussion.--}--addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]--- See Note [Adding evaluatedness info to pattern-bound variables]-addEvals scrut con vs-  -- Deal with seq# applications-  | Just scr <- scrut-  , isUnboxedTupleCon con-  , [s,x] <- vs-    -- Use stripNArgs rather than collectArgsTicks to avoid building-    -- a list of arguments only to throw it away immediately.-  , Just (Var f) <- stripNArgs 4 scr-  , Just SeqOp <- isPrimOpId_maybe f-  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x-  = [s, x']--  -- Deal with banged datacon fields-addEvals _scrut con vs = go vs the_strs-    where-      the_strs = dataConRepStrictness con--      go [] [] = []-      go (v:vs') strs | isTyVar v = v : go vs' strs-      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs-      go _ _ = pprPanic "Simplify.addEvals"-                (ppr con $$-                 ppr vs  $$-                 ppr_with_length (map strdisp the_strs) $$-                 ppr_with_length (dataConRepArgTys con) $$-                 ppr_with_length (dataConRepStrictness con))-        where-          ppr_with_length list-            = ppr list <+> parens (text "length =" <+> ppr (length list))-          strdisp MarkedStrict = text "MarkedStrict"-          strdisp NotMarkedStrict = text "NotMarkedStrict"--zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id-zapIdOccInfoAndSetEvald str v =-  setCaseBndrEvald str $ -- Add eval'dness info-  zapIdOccInfo v         -- And kill occ info;-                         -- see Note [Case alternative occ info]--addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv-addAltUnfoldings env scrut case_bndr con_app-  = do { let con_app_unf = mk_simple_unf con_app-             env1 = addBinderUnfolding env case_bndr con_app_unf--             -- See Note [Add unfolding for scrutinee]-             env2 = case scrut of-                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf-                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $-                                                mk_simple_unf (Cast con_app (mkSymCo co))-                      _                      -> env1--       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])-       ; return env2 }-  where-    mk_simple_unf = mkSimpleUnfolding (seDynFlags env)--addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv-addBinderUnfolding env bndr unf-  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf-  = WARN( not (eqType (idType bndr) (exprType tmpl)),-          ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )-    modifyInScope env (bndr `setIdUnfolding` unf)--  | otherwise-  = modifyInScope env (bndr `setIdUnfolding` unf)--zapBndrOccInfo :: Bool -> Id -> Id--- Consider  case e of b { (a,b) -> ... }--- Then if we bind b to (a,b) in "...", and b is not dead,--- then we must zap the deadness info on a,b-zapBndrOccInfo keep_occ_info pat_id-  | keep_occ_info = pat_id-  | otherwise     = zapIdOccInfo pat_id--{- Note [Case binder evaluated-ness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We pin on a (OtherCon []) unfolding to the case-binder of a Case,-even though it'll be over-ridden in every case alternative with a more-informative unfolding.  Why?  Because suppose a later, less clever, pass-simply replaces all occurrences of the case binder with the binder itself;-then Lint may complain about the let/app invariant.  Example-    case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in ....-                ; K       -> blah }--The let/app invariant requires that y is evaluated in the call to-reallyUnsafePtrEq#, which it is.  But we still want that to be true if we-propagate binders to occurrences.--This showed up in #13027.--Note [Add unfolding for scrutinee]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general it's unlikely that a variable scrutinee will appear-in the case alternatives   case x of { ...x unlikely to appear... }-because the binder-swap in OccAnal has got rid of all such occurrences-See Note [Binder swap] in OccAnal.--BUT it is still VERY IMPORTANT to add a suitable unfolding for a-variable scrutinee, in simplAlt.  Here's why-   case x of y-     (a,b) -> case b of c-                I# v -> ...(f y)...-There is no occurrence of 'b' in the (...(f y)...).  But y gets-the unfolding (a,b), and *that* mentions b.  If f has a RULE-    RULE f (p, I# q) = ...-we want that rule to match, so we must extend the in-scope env with a-suitable unfolding for 'y'.  It's *essential* for rule matching; but-it's also good for case-elimintation -- suppose that 'f' was inlined-and did multi-level case analysis, then we'd solve it in one-simplifier sweep instead of two.--Exactly the same issue arises in SpecConstr;-see Note [Add scrutinee to ValueEnv too] in SpecConstr--HOWEVER, given-  case x of y { Just a -> r1; Nothing -> r2 }-we do not want to add the unfolding x -> y to 'x', which might seem cool,-since 'y' itself has different unfoldings in r1 and r2.  Reason: if we-did that, we'd have to zap y's deadness info and that is a very useful-piece of information.--So instead we add the unfolding x -> Just a, and x -> Nothing in the-respective RHSs.---************************************************************************-*                                                                      *-\subsection{Known constructor}-*                                                                      *-************************************************************************--We are a bit careful with occurrence info.  Here's an example--        (\x* -> case x of (a*, b) -> f a) (h v, e)--where the * means "occurs once".  This effectively becomes-        case (h v, e) of (a*, b) -> f a)-and then-        let a* = h v; b = e in f a-and then-        f (h v)--All this should happen in one sweep.--}--knownCon :: SimplEnv-         -> OutExpr                                           -- The scrutinee-         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)-         -> InId -> [InBndr] -> InExpr                        -- The alternative-         -> SimplCont-         -> SimplM (SimplFloats, OutExpr)--knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont-  = do  { (floats1, env1)  <- bind_args env bs dc_args-        ; (floats2, env2) <- bind_case_bndr env1-        ; (floats3, expr') <- simplExprF env2 rhs cont-        ; case dc_floats of-            [] ->-              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')-            _ ->-              return ( emptyFloats env-               -- See Note [FloatBinds from constructor wrappers]-                     , GHC.Core.Make.wrapFloats dc_floats $-                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }-  where-    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId--                  -- Ugh!-    bind_args env' [] _  = return (emptyFloats env', env')--    bind_args env' (b:bs') (Type ty : args)-      = ASSERT( isTyVar b )-        bind_args (extendTvSubst env' b ty) bs' args--    bind_args env' (b:bs') (Coercion co : args)-      = ASSERT( isCoVar b )-        bind_args (extendCvSubst env' b co) bs' args--    bind_args env' (b:bs') (arg : args)-      = ASSERT( isId b )-        do { let b' = zap_occ b-             -- Note that the binder might be "dead", because it doesn't-             -- occur in the RHS; and simplNonRecX may therefore discard-             -- it via postInlineUnconditionally.-             -- Nevertheless we must keep it if the case-binder is alive,-             -- because it may be used in the con_app.  See Note [knownCon occ info]-           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant-           ; (floats2, env3)  <- bind_args env2 bs' args-           ; return (floats1 `addFloats` floats2, env3) }--    bind_args _ _ _ =-      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$-                             text "scrut:" <+> ppr scrut--       -- It's useful to bind bndr to scrut, rather than to a fresh-       -- binding      x = Con arg1 .. argn-       -- because very often the scrut is a variable, so we avoid-       -- creating, and then subsequently eliminating, a let-binding-       -- BUT, if scrut is a not a variable, we must be careful-       -- about duplicating the arg redexes; in that case, make-       -- a new con-app from the args-    bind_case_bndr env-      | isDeadBinder bndr   = return (emptyFloats env, env)-      | exprIsTrivial scrut = return (emptyFloats env-                                     , extendIdSubst env bndr (DoneEx scrut Nothing))-      | otherwise           = do { dc_args <- mapM (simplVar env) bs-                                         -- dc_ty_args are already OutTypes,-                                         -- but bs are InBndrs-                                 ; let con_app = Var (dataConWorkId dc)-                                                 `mkTyApps` dc_ty_args-                                                 `mkApps`   dc_args-                                 ; simplNonRecX env bndr con_app }----------------------missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont-           -> SimplM (SimplFloats, OutExpr)-                -- This isn't strictly an error, although it is unusual.-                -- It's possible that the simplifier might "see" that-                -- an inner case has no accessible alternatives before-                -- it "sees" that the entire branch of an outer case is-                -- inaccessible.  So we simply put an error case here instead.-missingAlt env case_bndr _ cont-  = WARN( True, text "missingAlt" <+> ppr case_bndr )-    -- See Note [Avoiding space leaks in OutType]-    let cont_ty = contResultType cont-    in seqType cont_ty `seq`-       return (emptyFloats env, mkImpossibleExpr cont_ty)--{--************************************************************************-*                                                                      *-\subsection{Duplicating continuations}-*                                                                      *-************************************************************************--Consider-  let x* = case e of { True -> e1; False -> e2 }-  in b-where x* is a strict binding.  Then mkDupableCont will be given-the continuation-   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop-and will split it into-   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop-   join floats:  $j1 = e1, $j2 = e2-   non_dupable:  let x* = [] in b; stop--Putting this back together would give-   let x* = let { $j1 = e1; $j2 = e2 } in-            case e of { True -> $j1; False -> $j2 }-   in b-(Of course we only do this if 'e' wants to duplicate that continuation.)-Note how important it is that the new join points wrap around the-inner expression, and not around the whole thing.--In contrast, any let-bindings introduced by mkDupableCont can wrap-around the entire thing.--Note [Bottom alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have-     case (case x of { A -> error .. ; B -> e; C -> error ..)-       of alts-then we can just duplicate those alts because the A and C cases-will disappear immediately.  This is more direct than creating-join points and inlining them away.  See #4930.--}-----------------------mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont-                  -> SimplM (SimplFloats, SimplCont)-mkDupableCaseCont env alts cont-  | altsWouldDup alts = mkDupableCont env cont-  | otherwise         = return (emptyFloats env, cont)--altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative-altsWouldDup []  = False        -- See Note [Bottom alternatives]-altsWouldDup [_] = False-altsWouldDup (alt:alts)-  | is_bot_alt alt = altsWouldDup alts-  | otherwise      = not (all is_bot_alt alts)-  where-    is_bot_alt (_,_,rhs) = exprIsBottom rhs----------------------------mkDupableCont :: SimplEnv -> SimplCont-              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with-                                       --   extra let/join-floats and in-scope variables-                        , SimplCont)   -- dup_cont: duplicable continuation--mkDupableCont env cont-  | contIsDupable cont-  = return (emptyFloats env, cont)--mkDupableCont _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn--mkDupableCont env (CastIt ty cont)-  = do  { (floats, cont') <- mkDupableCont env cont-        ; return (floats, CastIt ty cont') }---- Duplicating ticks for now, not sure if this is good or not-mkDupableCont env (TickIt t cont)-  = do  { (floats, cont') <- mkDupableCont env cont-        ; return (floats, TickIt t cont') }--mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs-                              , sc_body = body, sc_env = se, sc_cont = cont})-  -- See Note [Duplicating StrictBind]-  = do { let sb_env = se `setInScopeFromE` env-       ; (sb_env1, bndr') <- simplBinder sb_env bndr-       ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont-          -- No need to use mkDupableCont before simplLam; we-          -- use cont once here, and then share the result if necessary--       ; let join_body = wrapFloats floats1 join_inner-             res_ty    = contResultType cont--       ; (floats2, body2)-            <- if exprIsDupable (seDynFlags env) join_body-               then return (emptyFloats env, join_body)-               else do { join_bndr <- newJoinId [bndr'] res_ty-                       ; let join_call = App (Var join_bndr) (Var bndr')-                             join_rhs  = Lam (setOneShotLambda bndr') join_body-                             join_bind = NonRec join_bndr join_rhs-                             floats    = emptyFloats env `extendFloats` join_bind-                       ; return (floats, join_call) }-       ; return ( floats2-                , StrictBind { sc_bndr = bndr', sc_bndrs = []-                             , sc_body = body2-                             , sc_env  = zapSubstEnv se `setInScopeFromF` floats2-                                         -- See Note [StaticEnv invariant] in SimplUtils-                             , sc_dup  = OkToDup-                             , sc_cont = mkBoringStop res_ty } ) }--mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })-        -- See Note [Duplicating StrictArg]-        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-  = do { (floats1, cont') <- mkDupableCont env cont-       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))-                                           (ai_args info)-       ; return ( foldl' addLetFloats floats1 floats_s-                , StrictArg { sc_fun = info { ai_args = args' }-                            , sc_cci = cci-                            , sc_cont = cont'-                            , sc_dup = OkToDup} ) }--mkDupableCont env (ApplyToTy { sc_cont = cont-                             , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })-  = do  { (floats, cont') <- mkDupableCont env cont-        ; return (floats, ApplyToTy { sc_cont = cont'-                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }--mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup-                              , sc_env = se, sc_cont = cont })-  =     -- e.g.         [...hole...] (...arg...)-        --      ==>-        --              let a = ...arg...-        --              in [...hole...] a-        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { (floats1, cont') <- mkDupableCont env cont-        ; let env' = env `setInScopeFromF` floats1-        ; (_, se', arg') <- simplArg env' dup se arg-        ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg'-        ; let all_floats = floats1 `addLetFloats` let_floats2-        ; return ( all_floats-                 , ApplyToVal { sc_arg = arg''-                              , sc_env = se' `setInScopeFromF` all_floats-                                         -- Ensure that sc_env includes the free vars of-                                         -- arg'' in its in-scope set, even if makeTrivial-                                         -- has turned arg'' into a fresh variable-                                         -- See Note [StaticEnv invariant] in SimplUtils-                              , sc_dup = OkToDup, sc_cont = cont' }) }--mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts-                          , sc_env = se, sc_cont = cont })-  =     -- e.g.         (case [...hole...] of { pi -> ei })-        --      ===>-        --              let ji = \xij -> ei-        --              in case [...hole...] of { pi -> ji xij }-        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { tick (CaseOfCase case_bndr)-        ; (floats, alt_cont) <- mkDupableCaseCont env alts cont-                -- NB: We call mkDupableCaseCont here to make cont duplicable-                --     (if necessary, depending on the number of alts)-                -- And this is important: see Note [Fusing case continuations]--        ; let alt_env = se `setInScopeFromF` floats-        ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr-        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts-        -- Safe to say that there are no handled-cons for the DEFAULT case-                -- NB: simplBinder does not zap deadness occ-info, so-                -- a dead case_bndr' will still advertise its deadness-                -- This is really important because in-                --      case e of b { (# p,q #) -> ... }-                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),-                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.-                -- In the new alts we build, we have the new case binder, so it must retain-                -- its deadness.-        -- NB: we don't use alt_env further; it has the substEnv for-        --     the alternatives, and we don't want that--        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (seDynFlags env) case_bndr')-                                              emptyJoinFloats alts'--        ; let all_floats = floats `addJoinFloats` join_floats-                           -- Note [Duplicated env]-        ; return (all_floats-                 , Select { sc_dup  = OkToDup-                          , sc_bndr = case_bndr'-                          , sc_alts = alts''-                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats-                                      -- See Note [StaticEnv invariant] in SimplUtils-                          , sc_cont = mkBoringStop (contResultType cont) } ) }--mkDupableAlt :: DynFlags -> OutId-             -> JoinFloats -> OutAlt-             -> SimplM (JoinFloats, OutAlt)-mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs')-  | exprIsDupable dflags rhs'  -- Note [Small alternative rhs]-  = return (jfloats, (con, bndrs', rhs'))--  | otherwise-  = do  { let rhs_ty'  = exprType rhs'-              scrut_ty = idType case_bndr-              case_bndr_w_unf-                = case con of-                      DEFAULT    -> case_bndr-                      DataAlt dc -> setIdUnfolding case_bndr unf-                          where-                                 -- See Note [Case binders and join points]-                             unf = mkInlineUnfolding rhs-                             rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'--                      LitAlt {} -> WARN( True, text "mkDupableAlt"-                                                <+> ppr case_bndr <+> ppr con )-                                   case_bndr-                           -- The case binder is alive but trivial, so why has-                           -- it not been substituted away?--              final_bndrs'-                | isDeadBinder case_bndr = filter abstract_over bndrs'-                | otherwise              = bndrs' ++ [case_bndr_w_unf]--              abstract_over bndr-                  | isTyVar bndr = True -- Abstract over all type variables just in case-                  | otherwise    = not (isDeadBinder bndr)-                        -- The deadness info on the new Ids is preserved by simplBinders-              final_args = varsToCoreExprs final_bndrs'-                           -- Note [Join point abstraction]--                -- We make the lambdas into one-shot-lambdas.  The-                -- join point is sure to be applied at most once, and doing so-                -- prevents the body of the join point being floated out by-                -- the full laziness pass-              really_final_bndrs     = map one_shot final_bndrs'-              one_shot v | isId v    = setOneShotLambda v-                         | otherwise = v-              join_rhs   = mkLams really_final_bndrs rhs'--        ; join_bndr <- newJoinId final_bndrs' rhs_ty'--        ; let join_call = mkApps (Var join_bndr) final_args-              alt'      = (con, bndrs', join_call)--        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)-                 , alt') }-                -- See Note [Duplicated env]--{--Note [Fusing case continuations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important to fuse two successive case continuations when the-first has one alternative.  That's why we call prepareCaseCont here.-Consider this, which arises from thunk splitting (see Note [Thunk-splitting] in WorkWrap):--      let-        x* = case (case v of {pn -> rn}) of-               I# a -> I# a-      in body--The simplifier will find-    (Var v) with continuation-            Select (pn -> rn) (-            Select [I# a -> I# a] (-            StrictBind body Stop--So we'll call mkDupableCont on-   Select [I# a -> I# a] (StrictBind body Stop)-There is just one alternative in the first Select, so we want to-simplify the rhs (I# a) with continuation (StrictBind body Stop)-Supposing that body is big, we end up with-          let $j a = <let x = I# a in body>-          in case v of { pn -> case rn of-                                 I# a -> $j a }-This is just what we want because the rn produces a box that-the case rn cancels with.--See #4957 a fuller example.--Note [Case binders and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-   case (case .. ) of c {-     I# c# -> ....c....--If we make a join point with c but not c# we get-  $j = \c -> ....c....--But if later inlining scrutinises the c, thus--  $j = \c -> ... case c of { I# y -> ... } ...--we won't see that 'c' has already been scrutinised.  This actually-happens in the 'tabulate' function in wave4main, and makes a significant-difference to allocation.--An alternative plan is this:--   $j = \c# -> let c = I# c# in ...c....--but that is bad if 'c' is *not* later scrutinised.--So instead we do both: we pass 'c' and 'c#' , and record in c's inlining-(a stable unfolding) that it's really I# c#, thus--   $j = \c# -> \c[=I# c#] -> ...c....--Absence analysis may later discard 'c'.--NB: take great care when doing strictness analysis;-    see Note [Lambda-bound unfoldings] in DmdAnal.--Also note that we can still end up passing stuff that isn't used.  Before-strictness analysis we have-   let $j x y c{=(x,y)} = (h c, ...)-   in ...-After strictness analysis we see that h is strict, we end up with-   let $j x y c{=(x,y)} = ($wh x y, ...)-and c is unused.--Note [Duplicated env]-~~~~~~~~~~~~~~~~~~~~~-Some of the alternatives are simplified, but have not been turned into a join point-So they *must* have a zapped subst-env.  So we can't use completeNonRecX to-bind the join point, because it might to do PostInlineUnconditionally, and-we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,-but zapping it (as we do in mkDupableCont, the Select case) is safe, and-at worst delays the join-point inlining.--Note [Small alternative rhs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It is worth checking for a small RHS because otherwise we-get extra let bindings that may cause an extra iteration of the simplifier to-inline back in place.  Quite often the rhs is just a variable or constructor.-The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra-iterations because the version with the let bindings looked big, and so wasn't-inlined, but after the join points had been inlined it looked smaller, and so-was inlined.--NB: we have to check the size of rhs', not rhs.-Duplicating a small InAlt might invalidate occurrence information-However, if it *is* dupable, we return the *un* simplified alternative,-because otherwise we'd need to pair it up with an empty subst-env....-but we only have one env shared between all the alts.-(Remember we must zap the subst-env before re-simplifying something).-Rather than do this we simply agree to re-simplify the original (small) thing later.--Note [Funky mkLamTypes]-~~~~~~~~~~~~~~~~~~~~~~-Notice the funky mkLamTypes.  If the constructor has existentials-it's possible that the join point will be abstracted over-type variables as well as term variables.- Example:  Suppose we have-        data T = forall t.  C [t]- Then faced with-        case (case e of ...) of-            C t xs::[t] -> rhs- We get the join point-        let j :: forall t. [t] -> ...-            j = /\t \xs::[t] -> rhs-        in-        case (case e of ...) of-            C t xs::[t] -> j t xs--Note [Duplicating StrictArg]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We make a StrictArg duplicable simply by making all its-stored-up arguments (in sc_fun) trivial, by let-binding-them.  Thus:-        f E [..hole..]-        ==>     let a = E-                in f a [..hole..]-Now if the thing in the hole is a case expression (which is when-we'll call mkDupableCont), we'll push the function call into the-branches, which is what we want.  Now RULES for f may fire, and-call-pattern specialisation.  Here's an example from #3116-     go (n+1) (case l of-                 1  -> bs'-                 _  -> Chunk p fpc (o+1) (l-1) bs')-If we can push the call for 'go' inside the case, we get-call-pattern specialisation for 'go', which is *crucial* for-this program.--Here is the (&&) example:-        && E (case x of { T -> F; F -> T })-  ==>   let a = E in-        case x of { T -> && a F; F -> && a T }-Much better!--Notice that-  * Arguments to f *after* the strict one are handled by-    the ApplyToVal case of mkDupableCont.  Eg-        f [..hole..] E--  * We can only do the let-binding of E because the function-    part of a StrictArg continuation is an explicit syntax-    tree.  In earlier versions we represented it as a function-    (CoreExpr -> CoreEpxr) which we couldn't take apart.--Historical aide: previously we did this (where E is a-big argument:-        f E [..hole..]-        ==>     let $j = \a -> f E a-                in $j [..hole..]--But this is terrible! Here's an example:-        && E (case x of { T -> F; F -> T })-Now, && is strict so we end up simplifying the case with-an ArgOf continuation.  If we let-bind it, we get-        let $j = \v -> && E v-        in simplExpr (case x of { T -> F; F -> T })-                     (ArgOf (\r -> $j r)-And after simplifying more we get-        let $j = \v -> && E v-        in case x of { T -> $j F; F -> $j T }-Which is a Very Bad Thing---Note [Duplicating StrictBind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We make a StrictBind duplicable in a very similar way to-that for case expressions.  After all,-   let x* = e in b   is similar to    case e of x -> b--So we potentially make a join-point for the body, thus:-   let x = [] in b   ==>   join j x = b-                           in let x = [] in j x---Note [Join point abstraction]  Historical note-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: This note is now historical, describing how (in the past) we used-to add a void argument to nullary join points.  But now that "join-point" is not a fuzzy concept but a formal syntactic construct (as-distinguished by the JoinId constructor of IdDetails), each of these-concerns is handled separately, with no need for a vestigial extra-argument.--Join points always have at least one value argument,-for several reasons--* If we try to lift a primitive-typed something out-  for let-binding-purposes, we will *caseify* it (!),-  with potentially-disastrous strictness results.  So-  instead we turn it into a function: \v -> e-  where v::Void#.  The value passed to this function is void,-  which generates (almost) no code.--* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now-  we make the join point into a function whenever used_bndrs'-  is empty.  This makes the join-point more CPR friendly.-  Consider:       let j = if .. then I# 3 else I# 4-                  in case .. of { A -> j; B -> j; C -> ... }--  Now CPR doesn't w/w j because it's a thunk, so-  that means that the enclosing function can't w/w either,-  which is a lose.  Here's the example that happened in practice:-          kgmod :: Int -> Int -> Int-          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0-                      then 78-                      else 5--* Let-no-escape.  We want a join point to turn into a let-no-escape-  so that it is implemented as a jump, and one of the conditions-  for LNE is that it's not updatable.  In CoreToStg, see-  Note [What is a non-escaping let]--* Floating.  Since a join point will be entered once, no sharing is-  gained by floating out, but something might be lost by doing-  so because it might be allocated.--I have seen a case alternative like this:-        True -> \v -> ...-It's a bit silly to add the realWorld dummy arg in this case, making-        $j = \s v -> ...-           True -> $j s-(the \v alone is enough to make CPR happy) but I think it's rare--There's a slight infelicity here: we pass the overall-case_bndr to all the join points if it's used in *any* RHS,-because we don't know its usage in each RHS separately----************************************************************************-*                                                                      *-                    Unfoldings-*                                                                      *-************************************************************************--}--simplLetUnfolding :: SimplEnv-> TopLevelFlag-                  -> MaybeJoinCont-                  -> InId-                  -> OutExpr -> OutType-                  -> Unfolding -> SimplM Unfolding-simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf-  | isStableUnfolding unf-  = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty-  | isExitJoinId id-  = return noUnfolding -- See Note [Do not inline exit join points] in Exitify-  | otherwise-  = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs----------------------mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource-               -> InId -> OutExpr -> SimplM Unfolding-mkLetUnfolding dflags top_lvl src id new_rhs-  = is_bottoming `seq`  -- See Note [Force bottoming field]-    return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)-            -- We make an  unfolding *even for loop-breakers*.-            -- Reason: (a) It might be useful to know that they are WHNF-            --         (b) In GHC.Iface.Tidy we currently assume that, if we want to-            --             expose the unfolding then indeed we *have* an unfolding-            --             to expose.  (We could instead use the RHS, but currently-            --             we don't.)  The simple thing is always to have one.-  where-    is_top_lvl   = isTopLevel top_lvl-    is_bottoming = isBottomingId id----------------------simplStableUnfolding :: SimplEnv -> TopLevelFlag-                     -> MaybeJoinCont  -- Just k => a join point with continuation k-                     -> InId-                     -> Unfolding -> OutType -> SimplM Unfolding--- Note [Setting the new unfolding]-simplStableUnfolding env top_lvl mb_cont id unf rhs_ty-  = case unf of-      NoUnfolding   -> return unf-      BootUnfolding -> return unf-      OtherCon {}   -> return unf--      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }-        -> do { (env', bndrs') <- simplBinders unf_env bndrs-              ; args' <- mapM (simplExpr env') args-              ; return (mkDFunUnfolding bndrs' con args') }--      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }-        | isStableSource src-        -> do { expr' <- case mb_cont of -- See Note [Rules and unfolding for join points]-                           Just cont -> simplJoinRhs unf_env id expr cont-                           Nothing   -> simplExprC unf_env expr (mkBoringStop rhs_ty)-              ; case guide of-                  UnfWhen { ug_arity = arity-                          , ug_unsat_ok = sat_ok-                          , ug_boring_ok = boring_ok-                          }-                          -- Happens for INLINE things-                     -> let guide' =-                              UnfWhen { ug_arity = arity-                                      , ug_unsat_ok = sat_ok-                                      , ug_boring_ok =-                                          boring_ok || inlineBoringOk expr'-                                      }-                        -- Refresh the boring-ok flag, in case expr'-                        -- has got small. This happens, notably in the inlinings-                        -- for dfuns for single-method classes; see-                        -- Note [Single-method classes] in TcInstDcls.-                        -- A test case is #4138-                        -- But retain a previous boring_ok of True; e.g. see-                        -- the way it is set in calcUnfoldingGuidanceWithArity-                        in return (mkCoreUnfolding src is_top_lvl expr' guide')-                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold--                  _other              -- Happens for INLINABLE things-                     -> mkLetUnfolding dflags top_lvl src id expr' }-                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE-                -- unfolding, and we need to make sure the guidance is kept up-                -- to date with respect to any changes in the unfolding.--        | otherwise -> return noUnfolding   -- Discard unstable unfoldings-  where-    dflags     = seDynFlags env-    is_top_lvl = isTopLevel top_lvl-    act        = idInlineActivation id-    unf_env    = updMode (updModeForStableUnfoldings act) env-         -- See Note [Simplifying inside stable unfoldings] in SimplUtils--{--Note [Force bottoming field]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to force bottoming, or the new unfolding holds-on to the old unfolding (which is part of the id).--Note [Setting the new unfolding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we-  should do nothing at all, but simplifying gently might get rid of-  more crap.--* If not, we make an unfolding from the new RHS.  But *only* for-  non-loop-breakers. Making loop breakers not have an unfolding at all-  means that we can avoid tests in exprIsConApp, for example.  This is-  important: if exprIsConApp says 'yes' for a recursive thing, then we-  can get into an infinite loop--If there's a stable unfolding on a loop breaker (which happens for-INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the-user did say 'INLINE'.  May need to revisit this choice.--************************************************************************-*                                                                      *-                    Rules-*                                                                      *-************************************************************************--Note [Rules in a letrec]-~~~~~~~~~~~~~~~~~~~~~~~~-After creating fresh binders for the binders of a letrec, we-substitute the RULES and add them back onto the binders; this is done-*before* processing any of the RHSs.  This is important.  Manuel found-cases where he really, really wanted a RULE for a recursive function-to apply in that function's own right-hand side.--See Note [Forming Rec groups] in OccurAnal--}--addBndrRules :: SimplEnv -> InBndr -> OutBndr-             -> MaybeJoinCont   -- Just k for a join point binder-                                -- Nothing otherwise-             -> SimplM (SimplEnv, OutBndr)--- Rules are added back into the bin-addBndrRules env in_id out_id mb_cont-  | null old_rules-  = return (env, out_id)-  | otherwise-  = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont-       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules-       ; return (modifyInScope env final_id, final_id) }-  where-    old_rules = ruleInfoRules (idSpecialisation in_id)--simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]-           -> MaybeJoinCont -> SimplM [CoreRule]-simplRules env mb_new_id rules mb_cont-  = mapM simpl_rule rules-  where-    simpl_rule rule@(BuiltinRule {})-      = return rule--    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args-                          , ru_fn = fn_name, ru_rhs = rhs })-      = do { (env', bndrs') <- simplBinders env bndrs-           ; let rhs_ty = substTy env' (exprType rhs)-                 rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]-                                Nothing   -> mkBoringStop rhs_ty-                                Just cont -> ASSERT2( join_ok, bad_join_msg )-                                             cont-                 rule_env = updMode updModeForRules env'-                 fn_name' = case mb_new_id of-                              Just id -> idName id-                              Nothing -> fn_name--                 -- join_ok is an assertion check that the join-arity of the-                 -- binder matches that of the rule, so that pushing the-                 -- continuation into the RHS makes sense-                 join_ok = case mb_new_id of-                             Just id | Just join_arity <- isJoinId_maybe id-                                     -> length args == join_arity-                             _ -> False-                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule-                                     , ppr (fmap isJoinId_maybe mb_new_id) ]--           ; args' <- mapM (simplExpr rule_env) args-           ; rhs'  <- simplExprC rule_env rhs rhs_cont-           ; return (rule { ru_bndrs = bndrs'-                          , ru_fn    = fn_name'-                          , ru_args  = args'-                          , ru_rhs   = rhs' }) }
− compiler/specialise/SpecConstr.hs 
@@ -1,2360 +0,0 @@-{--ToDo [Oct 2013]-~~~~~~~~~~~~~~~-1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim)-2. Nuke NoSpecConstr---(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[SpecConstr]{Specialise over constructors}--}--{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module SpecConstr(-        specConstrProgram,-        SpecConstrAnnotation(..)-    ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Core-import GHC.Core.Subst-import GHC.Core.Utils-import GHC.Core.Unfold  ( couldBeSmallEnoughToInline )-import GHC.Core.FVs     ( exprsFreeVarsList )-import CoreMonad-import Literal          ( litIsLifted )-import GHC.Driver.Types ( ModGuts(..) )-import WwLib            ( isWorkerSmallEnough, mkWorkerArgs )-import DataCon-import Coercion         hiding( substCo )-import GHC.Core.Rules-import Type             hiding ( substTy )-import TyCon            ( tyConName )-import Id-import GHC.Core.Ppr     ( pprParendExpr )-import GHC.Core.Make    ( mkImpossibleExpr )-import VarEnv-import VarSet-import Name-import BasicTypes-import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )-                          , gopt, hasPprDebug )-import Maybes           ( orElse, catMaybes, isJust, isNothing )-import Demand-import Cpr-import GHC.Serialized   ( deserializeWithData )-import Util-import Pair-import UniqSupply-import Outputable-import FastString-import UniqFM-import MonadUtils-import Control.Monad    ( zipWithM )-import Data.List-import PrelNames        ( specTyConName )-import Module-import TyCon ( TyCon )-import GHC.Exts( SpecConstrAnnotation(..) )-import Data.Ord( comparing )--{--------------------------------------------------------                        Game plan--------------------------------------------------------Consider-        drop n []     = []-        drop 0 xs     = []-        drop n (x:xs) = drop (n-1) xs--After the first time round, we could pass n unboxed.  This happens in-numerical code too.  Here's what it looks like in Core:--        drop n xs = case xs of-                      []     -> []-                      (y:ys) -> case n of-                                  I# n# -> case n# of-                                             0 -> []-                                             _ -> drop (I# (n# -# 1#)) xs--Notice that the recursive call has an explicit constructor as argument.-Noticing this, we can make a specialised version of drop--        RULE: drop (I# n#) xs ==> drop' n# xs--        drop' n# xs = let n = I# n# in ...orig RHS...--Now the simplifier will apply the specialisation in the rhs of drop', giving--        drop' n# xs = case xs of-                      []     -> []-                      (y:ys) -> case n# of-                                  0 -> []-                                  _ -> drop' (n# -# 1#) xs--Much better!--We'd also like to catch cases where a parameter is carried along unchanged,-but evaluated each time round the loop:--        f i n = if i>0 || i>n then i else f (i*2) n--Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.-In Core, by the time we've w/wd (f is strict in i) we get--        f i# n = case i# ># 0 of-                   False -> I# i#-                   True  -> case n of { I# n# ->-                            case i# ># n# of-                                False -> I# i#-                                True  -> f (i# *# 2#) n--At the call to f, we see that the argument, n is known to be (I# n#),-and n is evaluated elsewhere in the body of f, so we can play the same-trick as above.---Note [Reboxing]-~~~~~~~~~~~~~~~-We must be careful not to allocate the same constructor twice.  Consider-        f p = (...(case p of (a,b) -> e)...p...,-               ...let t = (r,s) in ...t...(f t)...)-At the recursive call to f, we can see that t is a pair.  But we do NOT want-to make a specialised copy:-        f' a b = let p = (a,b) in (..., ...)-because now t is allocated by the caller, then r and s are passed to the-recursive call, which allocates the (r,s) pair again.--This happens if-  (a) the argument p is used in other than a case-scrutinisation way.-  (b) the argument to the call is not a 'fresh' tuple; you have to-        look into its unfolding to see that it's a tuple--Hence the "OR" part of Note [Good arguments] below.--ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves-allocation, but does perhaps save evals. In the RULE we'd have-something like--  f (I# x#) = f' (I# x#) x#--If at the call site the (I# x) was an unfolding, then we'd have to-rely on CSE to eliminate the duplicate allocation.... This alternative-doesn't look attractive enough to pursue.--ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that-the conservative reboxing story prevents many useful functions from being-specialised.  Example:-        foo :: Maybe Int -> Int -> Int-        foo   (Just m) 0 = 0-        foo x@(Just m) n = foo x (n-m)-Here the use of 'x' will clearly not require boxing in the specialised function.--The strictness analyser has the same problem, in fact.  Example:-        f p@(a,b) = ...-If we pass just 'a' and 'b' to the worker, it might need to rebox the-pair to create (a,b).  A more sophisticated analysis might figure out-precisely the cases in which this could happen, but the strictness-analyser does no such analysis; it just passes 'a' and 'b', and hopes-for the best.--So my current choice is to make SpecConstr similarly aggressive, and-ignore the bad potential of reboxing.---Note [Good arguments]-~~~~~~~~~~~~~~~~~~~~~-So we look for--* A self-recursive function.  Ignore mutual recursion for now,-  because it's less common, and the code is simpler for self-recursion.--* EITHER--   a) At a recursive call, one or more parameters is an explicit-      constructor application-        AND-      That same parameter is scrutinised by a case somewhere in-      the RHS of the function--  OR--    b) At a recursive call, one or more parameters has an unfolding-       that is an explicit constructor application-        AND-      That same parameter is scrutinised by a case somewhere in-      the RHS of the function-        AND-      Those are the only uses of the parameter (see Note [Reboxing])---What to abstract over-~~~~~~~~~~~~~~~~~~~~~-There's a bit of a complication with type arguments.  If the call-site looks like--        f p = ...f ((:) [a] x xs)...--then our specialised function look like--        f_spec x xs = let p = (:) [a] x xs in ....as before....--This only makes sense if either-  a) the type variable 'a' is in scope at the top of f, or-  b) the type variable 'a' is an argument to f (and hence fs)--Actually, (a) may hold for value arguments too, in which case-we may not want to pass them.  Suppose 'x' is in scope at f's-defn, but xs is not.  Then we'd like--        f_spec xs = let p = (:) [a] x xs in ....as before....--Similarly (b) may hold too.  If x is already an argument at the-call, no need to pass it again.--Finally, if 'a' is not in scope at the call site, we could abstract-it as we do the term variables:--        f_spec a x xs = let p = (:) [a] x xs in ...as before...--So the grand plan is:--        * abstract the call site to a constructor-only pattern-          e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)--        * Find the free variables of the abstracted pattern--        * Pass these variables, less any that are in scope at-          the fn defn.  But see Note [Shadowing] below.---NOTICE that we only abstract over variables that are not in scope,-so we're in no danger of shadowing variables used in "higher up"-in f_spec's RHS.---Note [Shadowing]-~~~~~~~~~~~~~~~~-In this pass we gather up usage information that may mention variables-that are bound between the usage site and the definition site; or (more-seriously) may be bound to something different at the definition site.-For example:--        f x = letrec g y v = let x = ...-                             in ...(g (a,b) x)...--Since 'x' is in scope at the call site, we may make a rewrite rule that-looks like-        RULE forall a,b. g (a,b) x = ...-But this rule will never match, because it's really a different 'x' at-the call site -- and that difference will be manifest by the time the-simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*-no-shadowing, so perhaps it may not be distinct?]--Anyway, the rule isn't actually wrong, it's just not useful.  One possibility-is to run deShadowBinds before running SpecConstr, but instead we run the-simplifier.  That gives the simplest possible program for SpecConstr to-chew on; and it virtually guarantees no shadowing.--Note [Specialising for constant parameters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This one is about specialising on a *constant* (but not necessarily-constructor) argument--    foo :: Int -> (Int -> Int) -> Int-    foo 0 f = 0-    foo m f = foo (f m) (+1)--It produces--    lvl_rmV :: GHC.Base.Int -> GHC.Base.Int-    lvl_rmV =-      \ (ds_dlk :: GHC.Base.Int) ->-        case ds_dlk of wild_alH { GHC.Base.I# x_alG ->-        GHC.Base.I# (GHC.Prim.+# x_alG 1)--    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->-    GHC.Prim.Int#-    T.$wfoo =-      \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->-        case ww_sme of ds_Xlw {-          __DEFAULT ->-        case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->-        T.$wfoo ww1_Xmz lvl_rmV-        };-          0 -> 0-        }--The recursive call has lvl_rmV as its argument, so we could create a specialised copy-with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.--When is this worth it?  Call the constant 'lvl'-- If 'lvl' has an unfolding that is a constructor, see if the corresponding-  parameter is scrutinised anywhere in the body.--- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding-  parameter is applied (...to enough arguments...?)--  Also do this is if the function has RULES?--Also--Note [Specialising for lambda parameters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    foo :: Int -> (Int -> Int) -> Int-    foo 0 f = 0-    foo m f = foo (f m) (\n -> n-m)--This is subtly different from the previous one in that we get an-explicit lambda as the argument:--    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->-    GHC.Prim.Int#-    T.$wfoo =-      \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->-        case ww_sm8 of ds_Xlr {-          __DEFAULT ->-        case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->-        T.$wfoo-          ww1_Xmq-          (\ (n_ad3 :: GHC.Base.Int) ->-             case n_ad3 of wild_alB { GHC.Base.I# x_alA ->-             GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)-             })-        };-          0 -> 0-        }--I wonder if SpecConstr couldn't be extended to handle this? After all,-lambda is a sort of constructor for functions and perhaps it already-has most of the necessary machinery?--Furthermore, there's an immediate win, because you don't need to allocate the lambda-at the call site; and if perchance it's called in the recursive call, then you-may avoid allocating it altogether.  Just like for constructors.--Looks cool, but probably rare...but it might be easy to implement.---Note [SpecConstr for casts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    data family T a :: *-    data instance T Int = T Int--    foo n = ...-       where-         go (T 0) = 0-         go (T n) = go (T (n-1))--The recursive call ends up looking like-        go (T (I# ...) `cast` g)-So we want to spot the constructor application inside the cast.-That's why we have the Cast case in argToPat--Note [Local recursive groups]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For a *local* recursive group, we can see all the calls to the-function, so we seed the specialisation loop from the calls in the-body, not from the calls in the RHS.  Consider:--  bar m n = foo n (n,n) (n,n) (n,n) (n,n)-   where-     foo n p q r s-       | n == 0    = m-       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }-       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }-       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }-       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }--If we start with the RHSs of 'foo', we get lots and lots of specialisations,-most of which are not needed.  But if we start with the (single) call-in the rhs of 'bar' we get exactly one fully-specialised copy, and all-the recursive calls go to this fully-specialised copy. Indeed, the original-function is later collected as dead code.  This is very important in-specialising the loops arising from stream fusion, for example in NDP where-we were getting literally hundreds of (mostly unused) specialisations of-a local function.--In a case like the above we end up never calling the original un-specialised-function.  (Although we still leave its code around just in case.)--However, if we find any boring calls in the body, including *unsaturated*-ones, such as-      letrec foo x y = ....foo...-      in map foo xs-then we will end up calling the un-specialised function, so then we *should*-use the calls in the un-specialised RHS as seeds.  We call these-"boring call patterns", and callsToPats reports if it finds any of these.--Note [Seeding top-level recursive groups]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This seeding is done in the binding for seed_calls in specRec.--1. If all the bindings in a top-level recursive group are local (not-   exported), then all the calls are in the rest of the top-level-   bindings.  This means we can specialise with those call patterns-   ONLY, and NOT with the RHSs of the recursive group (exactly like-   Note [Local recursive groups])--2. But if any of the bindings are exported, the function may be called-   with any old arguments, so (for lack of anything better) we specialise-   based on-     (a) the call patterns in the RHS-     (b) the call patterns in the rest of the top-level bindings-   NB: before Apr 15 we used (a) only, but Dimitrios had an example-       where (b) was crucial, so I added that.-       Adding (b) also improved nofib allocation results:-                  multiplier: 4%   better-                  minimax:    2.8% better--Actually in case (2), instead of using the calls from the RHS, it-would be better to specialise in the importing module.  We'd need to-add an INLINABLE pragma to the function, and then it can be-specialised in the importing scope, just as is done for type classes-in Specialise.specImports. This remains to be done (#10346).--Note [Top-level recursive groups]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To get the call usage information from "the rest of the top level-bindings" (c.f. Note [Seeding top-level recursive groups]), we work-backwards through the top-level bindings so we see the usage before we-get to the binding of the function.  Before we can collect the usage-though, we go through all the bindings and add them to the-environment. This is necessary because usage is only tracked for-functions in the environment.  These two passes are called-   'go' and 'goEnv'-in specConstrProgram.  (Looks a bit revolting to me.)--Note [Do not specialise diverging functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Specialising a function that just diverges is a waste of code.-Furthermore, it broke GHC (simpl014) thus:-   {-# STR Sb #-}-   f = \x. case x of (a,b) -> f x-If we specialise f we get-   f = \x. case x of (a,b) -> fspec a b-But fspec doesn't have decent strictness info.  As it happened,-(f x) :: IO t, so the state hack applied and we eta expanded fspec,-and hence f.  But now f's strictness is less than its arity, which-breaks an invariant.---Note [Forcing specialisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-With stream fusion and in other similar cases, we want to fully-specialise some (but not necessarily all!) loops regardless of their-size and the number of specialisations.--We allow a library to do this, in one of two ways (one which is-deprecated):--  1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body.--  2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts,-     and then add *that* type as a parameter to the loop body--The reason #2 is deprecated is because it requires GHCi, which isn't-available for things like a cross compiler using stage1.--Here's a (simplified) example from the `vector` package. You may bring-the special 'force specialization' type into scope by saying:--  import GHC.Types (SPEC(..))--or by defining your own type (again, deprecated):--  data SPEC = SPEC | SPEC2-  {-# ANN type SPEC ForceSpecConstr #-}--(Note this is the exact same definition of GHC.Types.SPEC, just-without the annotation.)--After that, you say:--  foldl :: (a -> b -> a) -> a -> Stream b -> a-  {-# INLINE foldl #-}-  foldl f z (Stream step s _) = foldl_loop SPEC z s-    where-      foldl_loop !sPEC z s = case step s of-                              Yield x s' -> foldl_loop sPEC (f z x) s'-                              Skip       -> foldl_loop sPEC z s'-                              Done       -> z--SpecConstr will spot the SPEC parameter and always fully specialise-foldl_loop. Note that--  * We have to prevent the SPEC argument from being removed by-    w/w which is why (a) SPEC is a sum type, and (b) we have to seq on-    the SPEC argument.--  * And lastly, the SPEC argument is ultimately eliminated by-    SpecConstr itself so there is no runtime overhead.--This is all quite ugly; we ought to come up with a better design.--ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set-sc_force to True when calling specLoop. This flag does four things:--  * Ignore specConstrThreshold, to specialise functions of arbitrary size-        (see scTopBind)-  * Ignore specConstrCount, to make arbitrary numbers of specialisations-        (see specialise)-  * Specialise even for arguments that are not scrutinised in the loop-        (see argToPat; #4448)-  * Only specialise on recursive types a finite number of times-        (see is_too_recursive; #5550; Note [Limit recursive specialisation])--The flag holds only for specialising a single binding group, and NOT-for nested bindings.  (So really it should be passed around explicitly-and not stored in ScEnv.)  #14379 turned out to be caused by-   f SPEC x = let g1 x = ...-              in ...-We force-specialise f (because of the SPEC), but that generates a specialised-copy of g1 (as well as the original).  Alas g1 has a nested binding g2; and-in each copy of g1 we get an unspecialised and specialised copy of g2; and so-on. Result, exponential.  So the force-spec flag now only applies to one-level of bindings at a time.--Mechanism for this one-level-only thing:-- - Switch it on at the call to specRec, in scExpr and scTopBinds- - Switch it off when doing the RHSs;-   this can be done very conveniently in decreaseSpecCount--What alternatives did I consider?--* Annotating the loop itself doesn't work because (a) it is local and-  (b) it will be w/w'ed and having w/w propagating annotations somehow-  doesn't seem like a good idea. The types of the loop arguments-  really seem to be the most persistent thing.--* Annotating the types that make up the loop state doesn't work,-  either, because (a) it would prevent us from using types like Either-  or tuples here, (b) we don't want to restrict the set of types that-  can be used in Stream states and (c) some types are fixed by the-  user (e.g., the accumulator here) but we still want to specialise as-  much as possible.--Alternatives to ForceSpecConstr-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instead of giving the loop an extra argument of type SPEC, we-also considered *wrapping* arguments in SPEC, thus-  data SPEC a = SPEC a | SPEC2--  loop = \arg -> case arg of-                     SPEC state ->-                        case state of (x,y) -> ... loop (SPEC (x',y')) ...-                        S2 -> error ...-The idea is that a SPEC argument says "specialise this argument-regardless of whether the function case-analyses it".  But this-doesn't work well:-  * SPEC must still be a sum type, else the strictness analyser-    eliminates it-  * But that means that 'loop' won't be strict in its real payload-This loss of strictness in turn screws up specialisation, because-we may end up with calls like-   loop (SPEC (case z of (p,q) -> (q,p)))-Without the SPEC, if 'loop' were strict, the case would move out-and we'd see loop applied to a pair. But if 'loop' isn't strict-this doesn't look like a specialisable call.--Note [Limit recursive specialisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It is possible for ForceSpecConstr to cause an infinite loop of specialisation.-Because there is no limit on the number of specialisations, a recursive call with-a recursive constructor as an argument (for example, list cons) will generate-a specialisation for that constructor. If the resulting specialisation also-contains a recursive call with the constructor, this could proceed indefinitely.--For example, if ForceSpecConstr is on:-  loop :: [Int] -> [Int] -> [Int]-  loop z []         = z-  loop z (x:xs)     = loop (x:z) xs-this example will create a specialisation for the pattern-  loop (a:b) c      = loop' a b c--  loop' a b []      = (a:b)-  loop' a b (x:xs)  = loop (x:(a:b)) xs-and a new pattern is found:-  loop (a:(b:c)) d  = loop'' a b c d-which can continue indefinitely.--Roman's suggestion to fix this was to stop after a couple of times on recursive types,-but still specialising on non-recursive types as much as possible.--To implement this, we count the number of times we have gone round the-"specialise recursively" loop ('go' in 'specRec').  Once have gone round-more than N times (controlled by -fspec-constr-recursive=N) we check--  - If sc_force is off, and sc_count is (Just max) then we don't-    need to do anything: trim_pats will limit the number of specs--  - Otherwise check if any function has now got more than (sc_count env)-    specialisations.  If sc_count is "no limit" then we arbitrarily-    choose 10 as the limit (ugh).--See #5550.   Also #13623, where this test had become over-aggressive,-and we lost a wonderful specialisation that we really wanted!--Note [NoSpecConstr]-~~~~~~~~~~~~~~~~~~~-The ignoreDataCon stuff allows you to say-    {-# ANN type T NoSpecConstr #-}-to mean "don't specialise on arguments of this type".  It was added-before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised-regardless of size; and then we needed a way to turn that *off*.  Now-that we have ForceSpecConstr, this NoSpecConstr is probably redundant.-(Used only for PArray, TODO: remove?)--------------------------------------------------------                Stuff not yet handled--------------------------------------------------------Here are notes arising from Roman's work that I don't want to lose.--Example 1-~~~~~~~~~-    data T a = T !a--    foo :: Int -> T Int -> Int-    foo 0 t = 0-    foo x t | even x    = case t of { T n -> foo (x-n) t }-            | otherwise = foo (x-1) t--SpecConstr does no specialisation, because the second recursive call-looks like a boxed use of the argument.  A pity.--    $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#-    $wfoo_sFw =-      \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->-         case ww_sFo of ds_Xw6 [Just L] {-           __DEFAULT ->-                case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {-                  __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;-                  0 ->-                    case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->-                    case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->-                    $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy-                    } } };-           0 -> 0--Example 2-~~~~~~~~~-    data a :*: b = !a :*: !b-    data T a = T !a--    foo :: (Int :*: T Int) -> Int-    foo (0 :*: t) = 0-    foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }-                  | otherwise = foo ((x-1) :*: t)--Very similar to the previous one, except that the parameters are now in-a strict tuple. Before SpecConstr, we have--    $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#-    $wfoo_sG3 =-      \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T-    GHC.Base.Int) ->-        case ww_sFU of ds_Xws [Just L] {-          __DEFAULT ->-        case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {-          __DEFAULT ->-            case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->-            $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1-            };-          0 ->-            case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->-            case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->-            $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2-            } } };-          0 -> 0 }--We get two specialisations:-"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}-                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)-                  = Foo.$s$wfoo1 a_sFB sc_sGC ;-"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}-                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))-                  = Foo.$s$wfoo y_aFp sc_sGC ;--But perhaps the first one isn't good.  After all, we know that tpl_B2 is-a T (I# x) really, because T is strict and Int has one constructor.  (We can't-unbox the strict fields, because T is polymorphic!)--************************************************************************-*                                                                      *-\subsection{Top level wrapper stuff}-*                                                                      *-************************************************************************--}--specConstrProgram :: ModGuts -> CoreM ModGuts-specConstrProgram guts-  = do-      dflags <- getDynFlags-      us     <- getUniqueSupplyM-      (_, annos) <- getFirstAnnotations deserializeWithData guts-      this_mod <- getModule-      let binds' = reverse $ fst $ initUs us $ do-                    -- Note [Top-level recursive groups]-                    (env, binds) <- goEnv (initScEnv dflags this_mod annos)-                                          (mg_binds guts)-                        -- binds is identical to (mg_binds guts), except that the-                        -- binders on the LHS have been replaced by extendBndr-                        --   (SPJ this seems like overkill; I don't think the binders-                        --    will change at all; and we don't substitute in the RHSs anyway!!)-                    go env nullUsage (reverse binds)--      return (guts { mg_binds = binds' })-  where-    -- See Note [Top-level recursive groups]-    goEnv env []            = return (env, [])-    goEnv env (bind:binds)  = do (env', bind')   <- scTopBindEnv env bind-                                 (env'', binds') <- goEnv env' binds-                                 return (env'', bind' : binds')--    -- Arg list of bindings is in reverse order-    go _   _   []           = return []-    go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind-                                 binds' <- go env usg' binds-                                 return (bind' : binds')--{--************************************************************************-*                                                                      *-\subsection{Environment: goes downwards}-*                                                                      *-************************************************************************--Note [Work-free values only in environment]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The sc_vals field keeps track of in-scope value bindings, so-that if we come across (case x of Just y ->...) we can reduce the-case from knowing that x is bound to a pair.--But only *work-free* values are ok here. For example if the envt had-    x -> Just (expensive v)-then we do NOT want to expand to-     let y = expensive v in ...-because the x-binding still exists and we've now duplicated (expensive v).--This seldom happens because let-bound constructor applications are-ANF-ised, but it can happen as a result of on-the-fly transformations in-SpecConstr itself.  Here is #7865:--        let {-          a'_shr =-            case xs_af8 of _ {-              [] -> acc_af6;-              : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] ->-                (expensive x_af7, x_af7-            } } in-        let {-          ds_sht =-            case a'_shr of _ { (p'_afd, q'_afe) ->-            TSpecConstr_DoubleInline.recursive-              (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd)-            } } in--When processed knowing that xs_af8 was bound to a cons, we simplify to-   a'_shr = (expensive x_af7, x_af7)-and we do NOT want to inline that at the occurrence of a'_shr in ds_sht.-(There are other occurrences of a'_shr.)  No no no.--It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned-into a work-free value again, thus-   a1 = expensive x_af7-   a'_shr = (a1, x_af7)-but that's more work, so until its shown to be important I'm going to-leave it for now.--Note [Making SpecConstr keener]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this, in (perf/should_run/T9339)-   last (filter odd [1..1000])--After optimisation, including SpecConstr, we get:-   f :: Int# -> Int -> Int-   f x y = case case remInt# x 2# of-             __DEFAULT -> case x of-                            __DEFAULT -> f (+# wild_Xp 1#) (I# x)-                            1000000# -> ...-             0# -> case x of-                     __DEFAULT -> f (+# wild_Xp 1#) y-                    1000000#   -> y--Not good!  We build an (I# x) box every time around the loop.-SpecConstr (as described in the paper) does not specialise f, despite-the call (f ... (I# x)) because 'y' is not scrutinised in the body.-But it is much better to specialise f for the case where the argument-is of form (I# x); then we build the box only when returning y, which-is on the cold path.--Another example:--   f x = ...(g x)....--Here 'x' is not scrutinised in f's body; but if we did specialise 'f'-then the call (g x) might allow 'g' to be specialised in turn.--So sc_keen controls whether or not we take account of whether argument is-scrutinised in the body.  True <=> ignore that, and specialise whenever-the function is applied to a data constructor.--}--data ScEnv = SCE { sc_dflags    :: DynFlags,-                   sc_module    :: !Module,-                   sc_size      :: Maybe Int,   -- Size threshold-                                                -- Nothing => no limit--                   sc_count     :: Maybe Int,   -- Max # of specialisations for any one fn-                                                -- Nothing => no limit-                                                -- See Note [Avoiding exponential blowup]--                   sc_recursive :: Int,         -- Max # of specialisations over recursive type.-                                                -- Stops ForceSpecConstr from diverging.--                   sc_keen     :: Bool,         -- Specialise on arguments that are known-                                                -- constructors, even if they are not-                                                -- scrutinised in the body.  See-                                                -- Note [Making SpecConstr keener]--                   sc_force     :: Bool,        -- Force specialisation?-                                                -- See Note [Forcing specialisation]--                   sc_subst     :: Subst,       -- Current substitution-                                                -- Maps InIds to OutExprs--                   sc_how_bound :: HowBoundEnv,-                        -- Binds interesting non-top-level variables-                        -- Domain is OutVars (*after* applying the substitution)--                   sc_vals      :: ValueEnv,-                        -- Domain is OutIds (*after* applying the substitution)-                        -- Used even for top-level bindings (but not imported ones)-                        -- The range of the ValueEnv is *work-free* values-                        -- such as (\x. blah), or (Just v)-                        -- but NOT (Just (expensive v))-                        -- See Note [Work-free values only in environment]--                   sc_annotations :: UniqFM SpecConstrAnnotation-             }------------------------type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars------------------------type ValueEnv = IdEnv Value             -- Domain is OutIds-data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors-                                        --   The AltCon is never DEFAULT-              | LambdaVal               -- Inlinable lambdas or PAPs--instance Outputable Value where-   ppr (ConVal con args) = ppr con <+> interpp'SP args-   ppr LambdaVal         = text "<Lambda>"------------------------initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv-initScEnv dflags this_mod anns-  = SCE { sc_dflags      = dflags,-          sc_module      = this_mod,-          sc_size        = specConstrThreshold dflags,-          sc_count       = specConstrCount     dflags,-          sc_recursive   = specConstrRecursive dflags,-          sc_keen        = gopt Opt_SpecConstrKeen dflags,-          sc_force       = False,-          sc_subst       = emptySubst,-          sc_how_bound   = emptyVarEnv,-          sc_vals        = emptyVarEnv,-          sc_annotations = anns }--data HowBound = RecFun  -- These are the recursive functions for which-                        -- we seek interesting call patterns--              | RecArg  -- These are those functions' arguments, or their sub-components;-                        -- we gather occurrence information for these--instance Outputable HowBound where-  ppr RecFun = text "RecFun"-  ppr RecArg = text "RecArg"--scForce :: ScEnv -> Bool -> ScEnv-scForce env b = env { sc_force = b }--lookupHowBound :: ScEnv -> Id -> Maybe HowBound-lookupHowBound env id = lookupVarEnv (sc_how_bound env) id--scSubstId :: ScEnv -> Id -> CoreExpr-scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v--scSubstTy :: ScEnv -> Type -> Type-scSubstTy env ty = substTy (sc_subst env) ty--scSubstCo :: ScEnv -> Coercion -> Coercion-scSubstCo env co = substCo (sc_subst env) co--zapScSubst :: ScEnv -> ScEnv-zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }--extendScInScope :: ScEnv -> [Var] -> ScEnv-        -- Bring the quantified variables into scope-extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }--        -- Extend the substitution-extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv-extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }--extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv-extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }--extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv-extendHowBound env bndrs how_bound-  = env { sc_how_bound = extendVarEnvList (sc_how_bound env)-                            [(bndr,how_bound) | bndr <- bndrs] }--extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])-extendBndrsWith how_bound env bndrs-  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')-  where-    (subst', bndrs') = substBndrs (sc_subst env) bndrs-    hb_env' = sc_how_bound env `extendVarEnvList`-                    [(bndr,how_bound) | bndr <- bndrs']--extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)-extendBndrWith how_bound env bndr-  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')-  where-    (subst', bndr') = substBndr (sc_subst env) bndr-    hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound--extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])-extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')-                      where-                        (subst', bndrs') = substRecBndrs (sc_subst env) bndrs--extendBndr :: ScEnv -> Var -> (ScEnv, Var)-extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')-                      where-                        (subst', bndr') = substBndr (sc_subst env) bndr--extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv-extendValEnv env _  Nothing   = env-extendValEnv env id (Just cv)- | valueIsWorkFree cv      -- Don't duplicate work!!  #7865- = env { sc_vals = extendVarEnv (sc_vals env) id cv }-extendValEnv env _ _ = env--extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])--- When we encounter---      case scrut of b---          C x y -> ...--- we want to bind b, to (C x y)--- NB1: Extends only the sc_vals part of the envt--- NB2: Kill the dead-ness info on the pattern binders x,y, since---      they are potentially made alive by the [b -> C x y] binding-extendCaseBndrs env scrut case_bndr con alt_bndrs-   = (env2, alt_bndrs')- where-   live_case_bndr = not (isDeadBinder case_bndr)-   env1 | Var v <- stripTicksTopE (const True) scrut-                         = extendValEnv env v cval-        | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]-   env2 | live_case_bndr = extendValEnv env1 case_bndr cval-        | otherwise      = env1--   alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }-              = map zap alt_bndrs-              | otherwise-              = alt_bndrs--   cval = case con of-                DEFAULT    -> Nothing-                LitAlt {}  -> Just (ConVal con [])-                DataAlt {} -> Just (ConVal con vanilla_args)-                      where-                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++-                                       varsToCoreExprs alt_bndrs--   zap v | isTyVar v = v                -- See NB2 above-         | otherwise = zapIdOccInfo v---decreaseSpecCount :: ScEnv -> Int -> ScEnv--- See Note [Avoiding exponential blowup]-decreaseSpecCount env n_specs-  = env { sc_force = False   -- See Note [Forcing specialisation]-        , sc_count = case sc_count env of-                       Nothing -> Nothing-                       Just n  -> Just (n `div` (n_specs + 1)) }-        -- The "+1" takes account of the original function;-        -- See Note [Avoiding exponential blowup]-------------------------------------------------------- See Note [Forcing specialisation]-ignoreType    :: ScEnv -> Type   -> Bool-ignoreDataCon  :: ScEnv -> DataCon -> Bool-forceSpecBndr :: ScEnv -> Var    -> Bool--ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)--ignoreType env ty-  = case tyConAppTyCon_maybe ty of-      Just tycon -> ignoreTyCon env tycon-      _          -> False--ignoreTyCon :: ScEnv -> TyCon -> Bool-ignoreTyCon env tycon-  = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr--forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var--forceSpecFunTy :: ScEnv -> Type -> Bool-forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys--forceSpecArgTy :: ScEnv -> Type -> Bool-forceSpecArgTy env ty-  | Just ty' <- coreView ty = forceSpecArgTy env ty'--forceSpecArgTy env ty-  | Just (tycon, tys) <- splitTyConApp_maybe ty-  , tycon /= funTyCon-      = tyConName tycon == specTyConName-        || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr-        || any (forceSpecArgTy env) tys--forceSpecArgTy _ _ = False--{--Note [Add scrutinee to ValueEnv too]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:-   case x of y-     (a,b) -> case b of c-                I# v -> ...(f y)...-By the time we get to the call (f y), the ValueEnv-will have a binding for y, and for c-    y -> (a,b)-    c -> I# v-BUT that's not enough!  Looking at the call (f y) we-see that y is pair (a,b), but we also need to know what 'b' is.-So in extendCaseBndrs we must *also* add the binding-   b -> I# v-else we lose a useful specialisation for f.  This is necessary even-though the simplifier has systematically replaced uses of 'x' with 'y'-and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came-from outside the case.  See #4908 for the live example.--Note [Avoiding exponential blowup]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The sc_count field of the ScEnv says how many times we are prepared to-duplicate a single function.  But we must take care with recursive-specialisations.  Consider--        let $j1 = let $j2 = let $j3 = ...-                            in-                            ...$j3...-                  in-                  ...$j2...-        in-        ...$j1...--If we specialise $j1 then in each specialisation (as well as the original)-we can specialise $j2, and similarly $j3.  Even if we make just *one*-specialisation of each, because we also have the original we'll get 2^n-copies of $j3, which is not good.--So when recursively specialising we divide the sc_count by the number of-copies we are making at this level, including the original.---************************************************************************-*                                                                      *-\subsection{Usage information: flows upwards}-*                                                                      *-************************************************************************--}--data ScUsage-   = SCU {-        scu_calls :: CallEnv,           -- Calls-                                        -- The functions are a subset of the-                                        --      RecFuns in the ScEnv--        scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences-     }                                  -- The domain is OutIds--type CallEnv = IdEnv [Call]-data Call = Call Id [CoreArg] ValueEnv-        -- The arguments of the call, together with the-        -- env giving the constructor bindings at the call site-        -- We keep the function mainly for debug output--instance Outputable ScUsage where-  ppr (SCU { scu_calls = calls, scu_occs = occs })-    = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls-                                         , text "occs =" <+> ppr occs ])--instance Outputable Call where-  ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)--nullUsage :: ScUsage-nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }--combineCalls :: CallEnv -> CallEnv -> CallEnv-combineCalls = plusVarEnv_C (++)-  where---    plus cs ds | length res > 1---               = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs---                                               , text "ds:" <+> ppr ds])---                 res---               | otherwise = res---       where---          res = cs ++ ds--combineUsage :: ScUsage -> ScUsage -> ScUsage-combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),-                           scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }--combineUsages :: [ScUsage] -> ScUsage-combineUsages [] = nullUsage-combineUsages us = foldr1 combineUsage us--lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])-lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs-  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},-     [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])--data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument-            | UnkOcc    -- Used in some unknown way--            | ScrutOcc  -- See Note [ScrutOcc]-                 (DataConEnv [ArgOcc])   -- How the sub-components are used--type DataConEnv a = UniqFM a     -- Keyed by DataCon--{- Note  [ScrutOcc]-~~~~~~~~~~~~~~~~~~~-An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,-is *only* taken apart or applied.--  Functions, literal: ScrutOcc emptyUFM-  Data constructors:  ScrutOcc subs,--where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,-The domain of the UniqFM is the Unique of the data constructor--The [ArgOcc] is the occurrences of the *pattern-bound* components-of the data structure.  E.g.-        data T a = forall b. MkT a b (b->a)-A pattern binds b, x::a, y::b, z::b->a, but not 'a'!---}--instance Outputable ArgOcc where-  ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs-  ppr UnkOcc        = text "unk-occ"-  ppr NoOcc         = text "no-occ"--evalScrutOcc :: ArgOcc-evalScrutOcc = ScrutOcc emptyUFM---- Experimentally, this version of combineOcc makes ScrutOcc "win", so--- that if the thing is scrutinised anywhere then we get to see that--- in the overall result, even if it's also used in a boxed way--- This might be too aggressive; see Note [Reboxing] Alternative 3-combineOcc :: ArgOcc -> ArgOcc -> ArgOcc-combineOcc NoOcc         occ           = occ-combineOcc occ           NoOcc         = occ-combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)-combineOcc UnkOcc        (ScrutOcc ys) = ScrutOcc ys-combineOcc (ScrutOcc xs) UnkOcc        = ScrutOcc xs-combineOcc UnkOcc        UnkOcc        = UnkOcc--combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]-combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys--setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage--- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee--- is a variable, and an interesting variable-setScrutOcc env usg (Cast e _) occ      = setScrutOcc env usg e occ-setScrutOcc env usg (Tick _ e) occ      = setScrutOcc env usg e occ-setScrutOcc env usg (Var v)    occ-  | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }-  | otherwise                           = usg-setScrutOcc _env usg _other _occ        -- Catch-all-  = usg--{--************************************************************************-*                                                                      *-\subsection{The main recursive function}-*                                                                      *-************************************************************************--The main recursive function gathers up usage information, and-creates specialised versions of functions.--}--scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)-        -- The unique supply is needed when we invent-        -- a new name for the specialised function and its args--scExpr env e = scExpr' env e--scExpr' env (Var v)      = case scSubstId env v of-                            Var v' -> return (mkVarUsage env v' [], Var v')-                            e'     -> scExpr (zapScSubst env) e'--scExpr' env (Type t)     = return (nullUsage, Type (scSubstTy env t))-scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))-scExpr' _   e@(Lit {})   = return (nullUsage, e)-scExpr' env (Tick t e)   = do (usg, e') <- scExpr env e-                              return (usg, Tick t e')-scExpr' env (Cast e co)  = do (usg, e') <- scExpr env e-                              return (usg, mkCast e' (scSubstCo env co))-                              -- Important to use mkCast here-                              -- See Note [SpecConstr call patterns]-scExpr' env e@(App _ _)  = scApp env (collectArgs e)-scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b-                              (usg, e') <- scExpr env' e-                              return (usg, Lam b' e')--scExpr' env (Case scrut b ty alts)-  = do  { (scrut_usg, scrut') <- scExpr env scrut-        ; case isValue (sc_vals env) scrut' of-                Just (ConVal con args) -> sc_con_app con args scrut'-                _other                 -> sc_vanilla scrut_usg scrut'-        }-  where-    sc_con_app con args scrut'  -- Known constructor; simplify-     = do { let (_, bs, rhs) = findAlt con alts-                                  `orElse` (DEFAULT, [], mkImpossibleExpr ty)-                alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)-          ; scExpr alt_env' rhs }--    sc_vanilla scrut_usg scrut' -- Normal case-     = do { let (alt_env,b') = extendBndrWith RecArg env b-                        -- Record RecArg for the components--          ; (alt_usgs, alt_occs, alts')-                <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts--          ; let scrut_occ  = foldr combineOcc NoOcc alt_occs-                scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ-                -- The combined usage of the scrutinee is given-                -- by scrut_occ, which is passed to scScrut, which-                -- in turn treats a bare-variable scrutinee specially--          ; return (foldr combineUsage scrut_usg' alt_usgs,-                    Case scrut' b' (scSubstTy env ty) alts') }--    sc_alt env scrut' b' (con,bs,rhs)-     = do { let (env1, bs1) = extendBndrsWith RecArg env bs-                (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1-          ; (usg, rhs') <- scExpr env2 rhs-          ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)-                scrut_occ = case con of-                               DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)-                               _          -> ScrutOcc emptyUFM-          ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }--scExpr' env (Let (NonRec bndr rhs) body)-  | isTyVar bndr        -- Type-lets may be created by doBeta-  = scExpr' (extendScSubst env bndr rhs) body--  | otherwise-  = do  { let (body_env, bndr') = extendBndr env bndr-        ; rhs_info  <- scRecRhs env (bndr',rhs)--        ; let body_env2 = extendHowBound body_env [bndr'] RecFun-                           -- Note [Local let bindings]-              rhs'      = ri_new_rhs rhs_info-              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')--        ; (body_usg, body') <- scExpr body_env3 body--          -- NB: For non-recursive bindings we inherit sc_force flag from-          -- the parent function (see Note [Forcing specialisation])-        ; (spec_usg, specs) <- specNonRec env body_usg rhs_info--        ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }-                    `combineUsage` spec_usg,  -- Note [spec_usg includes rhs_usg]-                  mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body')-        }----- A *local* recursive group: see Note [Local recursive groups]-scExpr' env (Let (Rec prs) body)-  = do  { let (bndrs,rhss)      = unzip prs-              (rhs_env1,bndrs') = extendRecBndrs env bndrs-              rhs_env2          = extendHowBound rhs_env1 bndrs' RecFun-              force_spec        = any (forceSpecBndr env) bndrs'-                -- Note [Forcing specialisation]--        ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)-        ; (body_usg, body')     <- scExpr rhs_env2 body--        -- NB: start specLoop from body_usg-        ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec)-                                       body_usg rhs_infos-                -- Do not unconditionally generate specialisations from rhs_usgs-                -- Instead use them only if we find an unspecialised call-                -- See Note [Local recursive groups]--        ; let all_usg = spec_usg `combineUsage` body_usg  -- Note [spec_usg includes rhs_usg]-              bind'   = Rec (concat (zipWith ruleInfoBinds rhs_infos specs))--        ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },-                  Let bind' body') }--{--Note [Local let bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~-It is not uncommon to find this--   let $j = \x. <blah> in ...$j True...$j True...--Here $j is an arbitrary let-bound function, but it often comes up for-join points.  We might like to specialise $j for its call patterns.-Notice the difference from a letrec, where we look for call patterns-in the *RHS* of the function.  Here we look for call patterns in the-*body* of the let.--At one point I predicated this on the RHS mentioning the outer-recursive function, but that's not essential and might even be-harmful.  I'm not sure.--}--scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)--scApp env (Var fn, args)        -- Function is a variable-  = ASSERT( not (null args) )-    do  { args_w_usgs <- mapM (scExpr env) args-        ; let (arg_usgs, args') = unzip args_w_usgs-              arg_usg = combineUsages arg_usgs-        ; case scSubstId env fn of-            fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')-                        -- Do beta-reduction and try again--            Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',-                               mkApps (Var fn') args')--            other_fn' -> return (arg_usg, mkApps other_fn' args') }-                -- NB: doing this ignores any usage info from the substituted-                --     function, but I don't think that matters.  If it does-                --     we can fix it.-  where-    doBeta :: OutExpr -> [OutExpr] -> OutExpr-    -- ToDo: adjust for System IF-    doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)-    doBeta fn              args         = mkApps fn args---- The function is almost always a variable, but not always.--- In particular, if this pass follows float-in,--- which it may, we can get---      (let f = ...f... in f) arg1 arg2-scApp env (other_fn, args)-  = do  { (fn_usg,   fn')   <- scExpr env other_fn-        ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args-        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }-------------------------mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage-mkVarUsage env fn args-  = case lookupHowBound env fn of-        Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)]-                           , scu_occs  = emptyVarEnv }-        Just RecArg -> SCU { scu_calls = emptyVarEnv-                           , scu_occs  = unitVarEnv fn arg_occ }-        Nothing     -> nullUsage-  where-    -- I rather think we could use UnkOcc all the time-    arg_occ | null args = UnkOcc-            | otherwise = evalScrutOcc-------------------------scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)-scTopBindEnv env (Rec prs)-  = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs-              rhs_env2          = extendHowBound rhs_env1 bndrs RecFun--              prs'              = zip bndrs' rhss-        ; return (rhs_env2, Rec prs') }-  where-    (bndrs,rhss) = unzip prs--scTopBindEnv env (NonRec bndr rhs)-  = do  { let (env1, bndr') = extendBndr env bndr-              env2          = extendValEnv env1 bndr' (isValue (sc_vals env) rhs)-        ; return (env2, NonRec bndr' rhs) }-------------------------scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)--{--scTopBind _ usage _-  | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False-  = error "false"--}--scTopBind env body_usage (Rec prs)-  | Just threshold <- sc_size env-  , not force_spec-  , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss)-                -- No specialisation-  = -- pprTrace "scTopBind: nospec" (ppr bndrs) $-    do  { (rhs_usgs, rhss')   <- mapAndUnzipM (scExpr env) rhss-        ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) }--  | otherwise   -- Do specialisation-  = do  { rhs_infos <- mapM (scRecRhs env) prs--        ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec)-                                         body_usage rhs_infos--        ; return (body_usage `combineUsage` spec_usage,-                  Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) }-  where-    (bndrs,rhss) = unzip prs-    force_spec   = any (forceSpecBndr env) bndrs-      -- Note [Forcing specialisation]--scTopBind env usage (NonRec bndr rhs)   -- Oddly, we don't seem to specialise top-level non-rec functions-  = do  { (rhs_usg', rhs') <- scExpr env rhs-        ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') }-------------------------scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo-scRecRhs env (bndr,rhs)-  = do  { let (arg_bndrs,body)       = collectBinders rhs-              (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs-        ; (body_usg, body')         <- scExpr body_env body-        ; let (rhs_usg, arg_occs)    = lookupOccs body_usg arg_bndrs'-        ; return (RI { ri_rhs_usg = rhs_usg-                     , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body'-                     , ri_lam_bndrs = arg_bndrs, ri_lam_body = body-                     , ri_arg_occs = arg_occs }) }-                -- The arg_occs says how the visible,-                -- lambda-bound binders of the RHS are used-                -- (including the TyVar binders)-                -- Two pats are the same if they match both ways-------------------------ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]-ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs })-              (SI { si_specs = specs })-  = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] ++-              -- First the specialised bindings--    [(fn `addIdSpecialisations` rules, new_rhs)]-              -- And now the original binding-  where-    rules = [r | OS { os_rule = r } <- specs]--{--************************************************************************-*                                                                      *-                The specialiser itself-*                                                                      *-************************************************************************--}--data RhsInfo-  = RI { ri_fn :: OutId                 -- The binder-       , ri_new_rhs :: OutExpr          -- The specialised RHS (in current envt)-       , ri_rhs_usg :: ScUsage          -- Usage info from specialising RHS--       , ri_lam_bndrs :: [InVar]       -- The *original* RHS (\xs.body)-       , ri_lam_body  :: InExpr        --   Note [Specialise original body]-       , ri_arg_occs  :: [ArgOcc]      -- Info on how the xs occur in body-    }--data SpecInfo       -- Info about specialisations for a particular Id-  = SI { si_specs :: [OneSpec]          -- The specialisations we have generated--       , si_n_specs :: Int              -- Length of si_specs; used for numbering them--       , si_mb_unspec :: Maybe ScUsage  -- Just cs  => we have not yet used calls in the-       }                                --             from calls in the *original* RHS as-                                        --             seeds for new specialisations;-                                        --             if you decide to do so, here is the-                                        --             RHS usage (which has not yet been-                                        --             unleashed)-                                        -- Nothing => we have-                                        -- See Note [Local recursive groups]-                                        -- See Note [spec_usg includes rhs_usg]--        -- One specialisation: Rule plus definition-data OneSpec =-  OS { os_pat  :: CallPat    -- Call pattern that generated this specialisation-     , os_rule :: CoreRule   -- Rule connecting original id with the specialisation-     , os_id   :: OutId      -- Spec id-     , os_rhs  :: OutExpr }  -- Spec rhs--noSpecInfo :: SpecInfo-noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing }-------------------------specNonRec :: ScEnv-           -> ScUsage         -- Body usage-           -> RhsInfo         -- Structure info usage info for un-specialised RHS-           -> UniqSM (ScUsage, SpecInfo)       -- Usage from RHSs (specialised and not)-                                               --     plus details of specialisations--specNonRec env body_usg rhs_info-  = specialise env (scu_calls body_usg) rhs_info-               (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) })-------------------------specRec :: TopLevelFlag -> ScEnv-        -> ScUsage                         -- Body usage-        -> [RhsInfo]                       -- Structure info and usage info for un-specialised RHSs-        -> UniqSM (ScUsage, [SpecInfo])    -- Usage from all RHSs (specialised and not)-                                           --     plus details of specialisations--specRec top_lvl env body_usg rhs_infos-  = go 1 seed_calls nullUsage init_spec_infos-  where-    (seed_calls, init_spec_infos)    -- Note [Seeding top-level recursive groups]-       | isTopLevel top_lvl-       , any (isExportedId . ri_fn) rhs_infos   -- Seed from body and RHSs-       = (all_calls,     [noSpecInfo | _ <- rhs_infos])-       | otherwise                              -- Seed from body only-       = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) }-                         | ri <- rhs_infos])--    calls_in_body = scu_calls body_usg-    calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos-    all_calls = calls_in_rhss `combineCalls` calls_in_body--    -- Loop, specialising, until you get no new specialisations-    go :: Int   -- Which iteration of the "until no new specialisations"-                -- loop we are on; first iteration is 1-       -> CallEnv   -- Seed calls-                    -- Two accumulating parameters:-       -> ScUsage      -- Usage from earlier specialisations-       -> [SpecInfo]   -- Details of specialisations so far-       -> UniqSM (ScUsage, [SpecInfo])-    go n_iter seed_calls usg_so_far spec_infos-      | isEmptyVarEnv seed_calls-      = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos)-        --                           , ppr seed_calls-        --                           , ppr body_usg ]) $-        return (usg_so_far, spec_infos)--      -- Limit recursive specialisation-      -- See Note [Limit recursive specialisation]-      | n_iter > sc_recursive env  -- Too many iterations of the 'go' loop-      , sc_force env || isNothing (sc_count env)-           -- If both of these are false, the sc_count-           -- threshold will prevent non-termination-      , any ((> the_limit) . si_n_specs) spec_infos-      = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $-        return (usg_so_far, spec_infos)--      | otherwise-      = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)-        --                           , text "iteration" <+> int n_iter-        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)-        --                    ]) $-        do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos-            ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg-                  extra_usg = combineUsages extra_usg_s-                  all_usg   = usg_so_far `combineUsage` extra_usg-            ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos }--    -- See Note [Limit recursive specialisation]-    the_limit = case sc_count env of-                  Nothing  -> 10    -- Ugh!-                  Just max -> max--------------------------specialise-   :: ScEnv-   -> CallEnv                     -- Info on newly-discovered calls to this function-   -> RhsInfo-   -> SpecInfo                    -- Original RHS plus patterns dealt with-   -> UniqSM (ScUsage, SpecInfo)  -- New specialised versions and their usage---- See Note [spec_usg includes rhs_usg]---- Note: this only generates *specialised* bindings--- The original binding is added by ruleInfoBinds------ Note: the rhs here is the optimised version of the original rhs--- So when we make a specialised copy of the RHS, we're starting--- from an RHS whose nested functions have been optimised already.--specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs-                              , ri_lam_body = body, ri_arg_occs = arg_occs })-               spec_info@(SI { si_specs = specs, si_n_specs = spec_count-                             , si_mb_unspec = mb_unspec })-  | isBottomingId fn      -- Note [Do not specialise diverging functions]-                          -- and do not generate specialisation seeds from its RHS-  = -- pprTrace "specialise bot" (ppr fn) $-    return (nullUsage, spec_info)--  | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation]-    || null arg_bndrs                     -- Only specialise functions-  = -- pprTrace "specialise inactive" (ppr fn) $-    case mb_unspec of    -- Behave as if there was a single, boring call-      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })-                         -- See Note [spec_usg includes rhs_usg]-      Nothing      -> return (nullUsage, spec_info)--  | Just all_calls <- lookupVarEnv bind_calls fn-  = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $-    do  { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls--        ; let n_pats = length new_pats---        ; if (not (null new_pats) || isJust mb_unspec) then---            pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"---                                        , text "mb_unspec" <+> ppr (isJust mb_unspec)---                                        , text "arg_occs" <+> ppr arg_occs---                                        , text "good pats" <+> ppr new_pats])  $---               return ()---          else return ()--        ; let spec_env = decreaseSpecCount env n_pats-        ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)-                                                 (new_pats `zip` [spec_count..])-                -- See Note [Specialise original body]--        ; let spec_usg = combineUsages spec_usgs--              -- If there were any boring calls among the seeds (= all_calls), then those-              -- calls will call the un-specialised function.  So we should use the seeds-              -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning-              -- then in new_usg.-              (new_usg, mb_unspec')-                  = case mb_unspec of-                      Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)-                      _                          -> (spec_usg,                      mb_unspec)----        ; pprTrace "specialise return }"---             (vcat [ ppr fn---                   , text "boring_call:" <+> ppr boring_call---                   , text "new calls:" <+> ppr (scu_calls new_usg)]) $---          return ()--          ; return (new_usg, SI { si_specs = new_specs ++ specs-                                , si_n_specs = spec_count + n_pats-                                , si_mb_unspec = mb_unspec' }) }--  | otherwise  -- No new seeds, so return nullUsage-  = return (nullUsage, spec_info)---------------------------spec_one :: ScEnv-         -> OutId       -- Function-         -> [InVar]     -- Lambda-binders of RHS; should match patterns-         -> InExpr      -- Body of the original function-         -> (CallPat, Int)-         -> UniqSM (ScUsage, OneSpec)   -- Rule and binding---- spec_one creates a specialised copy of the function, together--- with a rule for using it.  I'm very proud of how short this--- function is, considering what it does :-).--{--  Example--     In-scope: a, x::a-     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...-          [c::*, v::(b,c) are presumably bound by the (...) part]-  ==>-     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->-                  (...entire body of f...) [b -> (b,c),-                                            y -> ((:) (a,(b,c)) (x,v) hw)]--     RULE:  forall b::* c::*,           -- Note, *not* forall a, x-                   v::(b,c),-                   hw::[(a,(b,c))] .--            f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw--}--spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)-  = do  { spec_uniq <- getUniqueM-        ; let spec_env   = extendScSubstList (extendScInScope env qvars)-                                             (arg_bndrs `zip` pats)-              fn_name    = idName fn-              fn_loc     = nameSrcSpan fn_name-              fn_occ     = nameOccName fn_name-              spec_occ   = mkSpecOcc fn_occ-              -- We use fn_occ rather than fn in the rule_name string-              -- as we don't want the uniq to end up in the rule, and-              -- hence in the ABI, as that can cause spurious ABI-              -- changes (#4012).-              rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)-              spec_name  = mkInternalName spec_uniq spec_occ fn_loc---      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn---                              <+> ppr pats <+> text "-->" <+> ppr spec_name) $---        return ()--        -- Specialise the body-        ; (spec_usg, spec_body) <- scExpr spec_env body----      ; pprTrace "done spec_one}" (ppr fn) $---        return ()--                -- And build the results-        ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env)-                                                             qvars body_ty-                -- Usual w/w hack to avoid generating-                -- a spec_rhs of unlifted type and no args--              spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args-                -- Annotate the variables with the strictness information from-                -- the function (see Note [Strictness information in worker binders])--              spec_join_arity | isJoinId fn = Just (length spec_lam_args)-                              | otherwise   = Nothing-              spec_id    = mkLocalId spec_name-                                     (mkLamTypes spec_lam_args body_ty)-                             -- See Note [Transfer strictness]-                             `setIdStrictness` spec_str-                             `setIdCprInfo` topCprSig-                             `setIdArity` count isId spec_lam_args-                             `asJoinId_maybe` spec_join_arity-              spec_str   = calcSpecStrictness fn spec_lam_args pats---                -- Conditionally use result of new worker-wrapper transform-              spec_rhs   = mkLams spec_lam_args_str spec_body-              body_ty    = exprType spec_body-              rule_rhs   = mkVarApps (Var spec_id) spec_call_args-              inline_act = idInlineActivation fn-              this_mod   = sc_module spec_env-              rule       = mkRule this_mod True {- Auto -} True {- Local -}-                                  rule_name inline_act fn_name qvars pats rule_rhs-                           -- See Note [Transfer activation]-        ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule-                               , os_id = spec_id-                               , os_rhs = spec_rhs }) }----- See Note [Strictness information in worker binders]-handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]-handOutStrictnessInformation = go-  where-    go _ [] = []-    go [] vs = vs-    go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs-    go dmds (v:vs) = v : go dmds vs--calcSpecStrictness :: Id                     -- The original function-                   -> [Var] -> [CoreExpr]    -- Call pattern-                   -> StrictSig              -- Strictness of specialised thing--- See Note [Transfer strictness]-calcSpecStrictness fn qvars pats-  = mkClosedStrictSig spec_dmds topDiv-  where-    spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]-    StrictSig (DmdType _ dmds _) = idStrictness fn--    dmd_env = go emptyVarEnv dmds pats--    go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv-    go env ds (Type {} : pats)     = go env ds pats-    go env ds (Coercion {} : pats) = go env ds pats-    go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats-    go env _      _                = env--    go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv-    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d-    go_one env d e-           | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict-           , (Var _, args) <- collectArgs e = go env ds args-    go_one env _         _ = env--{--Note [spec_usg includes rhs_usg]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In calls to 'specialise', the returned ScUsage must include the rhs_usg in-the passed-in SpecInfo, unless there are no calls at all to the function.--The caller can, indeed must, assume this.  He should not combine in rhs_usg-himself, or he'll get rhs_usg twice -- and that can lead to an exponential-blowup of duplicates in the CallEnv.  This is what gave rise to the massive-performance loss in #8852.--Note [Specialise original body]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The RhsInfo for a binding keeps the *original* body of the binding.  We-must specialise that, *not* the result of applying specExpr to the RHS-(which is also kept in RhsInfo). Otherwise we end up specialising a-specialised RHS, and that can lead directly to exponential behaviour.--Note [Transfer activation]-~~~~~~~~~~~~~~~~~~~~~~~~~~-  This note is for SpecConstr, but exactly the same thing-  happens in the overloading specialiser; see-  Note [Auto-specialisation and RULES] in Specialise.--In which phase should the specialise-constructor rules be active?-Originally I made them always-active, but Manuel found that this-defeated some clever user-written rules.  Then I made them active only-in Phase 0; after all, currently, the specConstr transformation is-only run after the simplifier has reached Phase 0, but that meant-that specialisations didn't fire inside wrappers; see test-simplCore/should_compile/spec-inline.--So now I just use the inline-activation of the parent Id, as the-activation for the specialisation RULE, just like the main specialiser;--This in turn means there is no point in specialising NOINLINE things,-so we test for that.--Note [Transfer strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We must transfer strictness information from the original function to-the specialised one.  Suppose, for example--  f has strictness     SS-        and a RULE     f (a:as) b = f_spec a as b--Now we want f_spec to have strictness  LLS, otherwise we'll use call-by-need-when calling f_spec instead of call-by-value.  And that can result in-unbounded worsening in space (cf the classic foldl vs foldl')--See #3437 for a good example.--The function calcSpecStrictness performs the calculation.--Note [Strictness information in worker binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--After having calculated the strictness annotation for the worker (see Note-[Transfer strictness] above), we also want to have this information attached to-the worker’s arguments, for the benefit of later passes. The function-handOutStrictnessInformation decomposes the strictness annotation calculated by-calcSpecStrictness and attaches them to the variables.--************************************************************************-*                                                                      *-\subsection{Argument analysis}-*                                                                      *-************************************************************************--This code deals with analysing call-site arguments to see whether-they are constructor applications.--Note [Free type variables of the qvar types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In a call (f @a x True), that we want to specialise, what variables should-we quantify over.  Clearly over 'a' and 'x', but what about any type variables-free in x's type?  In fact we don't need to worry about them because (f @a)-can only be a well-typed application if its type is compatible with x, so any-variables free in x's type must be free in (f @a), and hence either be gathered-via 'a' itself, or be in scope at f's defn.  Hence we just take-  (exprsFreeVars pats).--BUT phantom type synonyms can mess this reasoning up,-  eg   x::T b   with  type T b = Int-So we apply expandTypeSynonyms to the bound Ids.-See # 5458.  Yuk.--Note [SpecConstr call patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A "call patterns" that we collect is going to become the LHS of a RULE.-It's important that it doesn't have-     e |> Refl-or-    e |> g1 |> g2-because both of these will be optimised by Simplify.simplRule. In the-former case such optimisation benign, because the rule will match more-terms; but in the latter we may lose a binding of 'g1' or 'g2', and-end up with a rule LHS that doesn't bind the template variables-(#10602).--The simplifier eliminates such things, but SpecConstr itself constructs-new terms by substituting.  So the 'mkCast' in the Cast case of scExpr-is very important!--Note [Choosing patterns]-~~~~~~~~~~~~~~~~~~~~~~~~-If we get lots of patterns we may not want to make a specialisation-for each of them (code bloat), so we choose as follows, implemented-by trim_pats.--* The flag -fspec-constr-count-N sets the sc_count field-  of the ScEnv to (Just n).  This limits the total number-  of specialisations for a given function to N.--* -fno-spec-constr-count sets the sc_count field to Nothing,-  which switches of the limit.--* The ghastly ForceSpecConstr trick also switches of the limit-  for a particular function--* Otherwise we sort the patterns to choose the most general-  ones first; more general => more widely applicable.--Note [SpecConstr and casts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#14270) a call like--    let f = e-    in ... f (K @(a |> co)) ...--where 'co' is a coercion variable not in scope at f's definition site.-If we aren't caereful we'll get--    let $sf a co = e (K @(a |> co))-        RULE "SC:f" forall a co.  f (K @(a |> co)) = $sf a co-        f = e-    in ...--But alas, when we match the call we won't bind 'co', because type-matching-(for good reasons) discards casts).--I don't know how to solve this, so for now I'm just discarding any-call patterns that-  * Mentions a coercion variable in a type argument-  * That is not in scope at the binding of the function--I think this is very rare.--It is important (e.g. #14936) that this /only/ applies to-coercions mentioned in casts.  We don't want to be discombobulated-by casts in terms!  For example, consider-   f ((e1,e2) |> sym co)-where, say,-   f  :: Foo -> blah-   co :: Foo ~R (Int,Int)--Here we definitely do want to specialise for that pair!  We do not-match on the structure of the coercion; instead we just match on a-coercion variable, so the RULE looks like--   forall (x::Int, y::Int, co :: (Int,Int) ~R Foo)-     f ((x,y) |> co) = $sf x y co--Often the body of f looks like-   f arg = ...(case arg |> co' of-                (x,y) -> blah)...--so that the specialised f will turn into-   $sf x y co = let arg = (x,y) |> co-                in ...(case arg>| co' of-                         (x,y) -> blah)....--which will simplify to not use 'co' at all.  But we can't guarantee-that co will end up unused, so we still pass it.  Absence analysis-may remove it later.--Note that this /also/ discards the call pattern if we have a cast in a-/term/, although in fact Rules.match does make a very flaky and-fragile attempt to match coercions.  e.g. a call like-    f (Maybe Age) (Nothing |> co) blah-    where co :: Maybe Int ~ Maybe Age-will be discarded.  It's extremely fragile to match on the form of a-coercion, so I think it's better just not to try.  A more complicated-alternative would be to discard calls that mention coercion variables-only in kind-casts, but I'm doing the simple thing for now.--}--type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments-                                        -- See Note [SpecConstr call patterns]--callsToNewPats :: ScEnv -> Id-               -> SpecInfo-               -> [ArgOcc] -> [Call]-               -> UniqSM (Bool, [CallPat])-        -- Result has no duplicate patterns,-        -- nor ones mentioned in done_pats-        -- Bool indicates that there was at least one boring pattern-callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls-  = do  { mb_pats <- mapM (callToPats env bndr_occs) calls--        ; let have_boring_call = any isNothing mb_pats--              good_pats :: [CallPat]-              good_pats = catMaybes mb_pats--              -- Remove patterns we have already done-              new_pats = filterOut is_done good_pats-              is_done p = any (samePat p . os_pat) done_specs--              -- Remove duplicates-              non_dups = nubBy samePat new_pats--              -- Remove ones that have too many worker variables-              small_pats = filterOut too_big non_dups-              too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars)-                  -- We are about to construct w/w pair in 'spec_one'.-                  -- Omit specialisation leading to high arity workers.-                  -- See Note [Limit w/w arity] in WwLib--                -- Discard specialisations if there are too many of them-              trimmed_pats = trim_pats env fn spec_info small_pats----        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls---                                       , text "done_specs:" <+> ppr (map os_pat done_specs)---                                       , text "good_pats:" <+> ppr good_pats ]) $---          return ()--        ; return (have_boring_call, trimmed_pats) }---trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]--- See Note [Choosing patterns]-trim_pats env fn (SI { si_n_specs = done_spec_count }) pats-  | sc_force env-    || isNothing mb_scc-    || n_remaining >= n_pats-  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)-    pats          -- No need to trim--  | otherwise-  = emit_trace $  -- Need to trim, so keep the best ones-    take n_remaining sorted_pats--  where-    n_pats         = length pats-    spec_count'    = n_pats + done_spec_count-    n_remaining    = max_specs - done_spec_count-    mb_scc         = sc_count env-    Just max_specs = mb_scc--    sorted_pats = map fst $-                  sortBy (comparing snd) $-                  [(pat, pat_cons pat) | pat <- pats]-     -- Sort in order of increasing number of constructors-     -- (i.e. decreasing generality) and pick the initial-     -- segment of this list--    pat_cons :: CallPat -> Int-    -- How many data constructors of literals are in-    -- the pattern.  More data-cons => less general-    pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps-       where-          q_set = mkVarSet qs-          n_cons (Var v) | v `elemVarSet` q_set = 0-                         | otherwise            = 1-          n_cons (Cast e _)  = n_cons e-          n_cons (App e1 e2) = n_cons e1 + n_cons e2-          n_cons (Lit {})    = 1-          n_cons _           = 0--    emit_trace result-       | debugIsOn || hasPprDebug (sc_dflags env)-         -- Suppress this scary message for ordinary users!  #5125-       = pprTrace "SpecConstr" msg result-       | otherwise-       = result-    msg = vcat [ sep [ text "Function" <+> quotes (ppr fn)-                     , nest 2 (text "has" <+>-                               speakNOf spec_count' (text "call pattern") <> comma <+>-                               text "but the limit is" <+> int max_specs) ]-               , text "Use -fspec-constr-count=n to set the bound"-               , text "done_spec_count =" <+> int done_spec_count-               , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats-               , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]---callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)-        -- The [Var] is the variables to quantify over in the rule-        --      Type variables come first, since they may scope-        --      over the following term variables-        -- The [CoreExpr] are the argument patterns for the rule-callToPats env bndr_occs call@(Call _ args con_env)-  | args `ltLength` bndr_occs      -- Check saturated-  = return Nothing-  | otherwise-  = do  { let in_scope = substInScope (sc_subst env)-        ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs-        ; let pat_fvs = exprsFreeVarsList pats-                -- To get determinism we need the list of free variables in-                -- deterministic order. Otherwise we end up creating-                -- lambdas with different argument orders. See-                -- determinism/simplCore/should_compile/spec-inline-determ.hs-                -- for an example. For explanation of determinism-                -- considerations See Note [Unique Determinism] in Unique.--              in_scope_vars = getInScopeVars in_scope-              is_in_scope v = v `elemVarSet` in_scope_vars-              qvars         = filterOut is_in_scope pat_fvs-                -- Quantify over variables that are not in scope-                -- at the call site-                -- See Note [Free type variables of the qvar types]-                -- See Note [Shadowing] at the top--              (ktvs, ids)   = partition isTyVar qvars-              qvars'        = scopedSort ktvs ++ map sanitise ids-                -- Order into kind variables, type variables, term variables-                -- The kind of a type variable may mention a kind variable-                -- and the type of a term variable may mention a type variable--              sanitise id   = id `setIdType` expandTypeSynonyms (idType id)-                -- See Note [Free type variables of the qvar types]--              -- Bad coercion variables: see Note [SpecConstr and casts]-              bad_covars :: CoVarSet-              bad_covars = mapUnionVarSet get_bad_covars pats-              get_bad_covars :: CoreArg -> CoVarSet-              get_bad_covars (Type ty)-                = filterVarSet (\v -> isId v && not (is_in_scope v)) $-                  tyCoVarsOfType ty-              get_bad_covars _-                = emptyVarSet--        ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $-          WARN( not (isEmptyVarSet bad_covars)-              , text "SpecConstr: bad covars:" <+> ppr bad_covars-                $$ ppr call )-          if interesting && isEmptyVarSet bad_covars-          then return (Just (qvars', pats))-          else return Nothing }--    -- argToPat takes an actual argument, and returns an abstracted-    -- version, consisting of just the "constructor skeleton" of the-    -- argument, with non-constructor sub-expression replaced by new-    -- placeholder variables.  For example:-    --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)--argToPat :: ScEnv-         -> InScopeSet                  -- What's in scope at the fn defn site-         -> ValueEnv                    -- ValueEnv at the call site-         -> CoreArg                     -- A call arg (or component thereof)-         -> ArgOcc-         -> UniqSM (Bool, CoreArg)---- Returns (interesting, pat),--- where pat is the pattern derived from the argument---            interesting=True if the pattern is non-trivial (not a variable or type)--- E.g.         x:xs         --> (True, x:xs)---              f xs         --> (False, w)        where w is a fresh wildcard---              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard---              \x. x+y      --> (True, \x. x+y)---              lvl7         --> (True, lvl7)      if lvl7 is bound---                                                 somewhere further out--argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ-  = return (False, arg)--argToPat env in_scope val_env (Tick _ arg) arg_occ-  = argToPat env in_scope val_env arg arg_occ-        -- Note [Notes in call patterns]-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        -- Ignore Notes.  In particular, we want to ignore any InlineMe notes-        -- Perhaps we should not ignore profiling notes, but I'm going to-        -- ride roughshod over them all for now.-        --- See Note [Notes in RULE matching] in GHC.Core.Rules--argToPat env in_scope val_env (Let _ arg) arg_occ-  = argToPat env in_scope val_env arg arg_occ-        -- See Note [Matching lets] in Rule.hs-        -- Look through let expressions-        -- e.g.         f (let v = rhs in (v,w))-        -- Here we can specialise for f (v,w)-        -- because the rule-matcher will look through the let.--{- Disabled; see Note [Matching cases] in Rule.hs-argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ-  | exprOkForSpeculation scrut  -- See Note [Matching cases] in Rule.hhs-  = argToPat env in_scope val_env rhs arg_occ--}--argToPat env in_scope val_env (Cast arg co) arg_occ-  | not (ignoreType env ty2)-  = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ-        ; if not interesting then-                wildCardPat ty2-          else do-        { -- Make a wild-card pattern for the coercion-          uniq <- getUniqueM-        ; let co_name = mkSysTvName uniq (fsLit "sg")-              co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)-        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }-  where-    Pair ty1 ty2 = coercionKind co----{-      Disabling lambda specialisation for now-        It's fragile, and the spec_loop can be infinite-argToPat in_scope val_env arg arg_occ-  | is_value_lam arg-  = return (True, arg)-  where-    is_value_lam (Lam v e)         -- Spot a value lambda, even if-        | isId v       = True      -- it is inside a type lambda-        | otherwise    = is_value_lam e-    is_value_lam other = False--}--  -- Check for a constructor application-  -- NB: this *precedes* the Var case, so that we catch nullary constrs-argToPat env in_scope val_env arg arg_occ-  | Just (ConVal (DataAlt dc) args) <- isValue val_env arg-  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]-  , Just arg_occs <- mb_scrut dc-  = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args-        ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs-        ; return (True,-                  mkConApp dc (ty_args ++ args')) }-  where-    mb_scrut dc = case arg_occ of-                    ScrutOcc bs | Just occs <- lookupUFM bs dc-                                -> Just (occs)  -- See Note [Reboxing]-                    _other      | sc_force env || sc_keen env-                                -> Just (repeat UnkOcc)-                                | otherwise-                                -> Nothing--  -- Check if the argument is a variable that-  --    (a) is used in an interesting way in the function body-  --    (b) we know what its value is-  -- In that case it counts as "interesting"-argToPat env in_scope val_env (Var v) arg_occ-  | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)-    is_value,                                                            -- (b)-       -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]-       -- So sc_keen focused just on f (I# x), where we have freshly-allocated-       -- box that we can eliminate in the caller-    not (ignoreType env (varType v))-  = return (True, Var v)-  where-    is_value-        | isLocalId v = v `elemInScopeSet` in_scope-                        && isJust (lookupVarEnv val_env v)-                -- Local variables have values in val_env-        | otherwise   = isValueUnfolding (idUnfolding v)-                -- Imports have unfoldings----      I'm really not sure what this comment means---      And by not wild-carding we tend to get forall'd---      variables that are in scope, which in turn can---      expose the weakness in let-matching---      See Note [Matching lets] in GHC.Core.Rules--  -- Check for a variable bound inside the function.-  -- Don't make a wild-card, because we may usefully share-  --    e.g.  f a = let x = ... in f (x,x)-  -- NB: this case follows the lambda and con-app cases!!--- argToPat _in_scope _val_env (Var v) _arg_occ---   = return (False, Var v)-        -- SLPJ : disabling this to avoid proliferation of versions-        -- also works badly when thinking about seeding the loop-        -- from the body of the let-        --       f x y = letrec g z = ... in g (x,y)-        -- We don't want to specialise for that *particular* x,y--  -- The default case: make a wild-card-  -- We use this for coercions too-argToPat _env _in_scope _val_env arg _arg_occ-  = wildCardPat (exprType arg)--wildCardPat :: Type -> UniqSM (Bool, CoreArg)-wildCardPat ty-  = do { uniq <- getUniqueM-       ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty-       ; return (False, varToCoreExpr id) }--argsToPats :: ScEnv -> InScopeSet -> ValueEnv-           -> [CoreArg] -> [ArgOcc]  -- Should be same length-           -> UniqSM (Bool, [CoreArg])-argsToPats env in_scope val_env args occs-  = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs-       ; let (interesting_s, args') = unzip stuff-       ; return (or interesting_s, args') }--isValue :: ValueEnv -> CoreExpr -> Maybe Value-isValue _env (Lit lit)-  | litIsLifted lit = Nothing-  | otherwise       = Just (ConVal (LitAlt lit) [])--isValue env (Var v)-  | Just cval <- lookupVarEnv env v-  = Just cval  -- You might think we could look in the idUnfolding here-               -- but that doesn't take account of which branch of a-               -- case we are in, which is the whole point--  | not (isLocalId v) && isCheapUnfolding unf-  = isValue env (unfoldingTemplate unf)-  where-    unf = idUnfolding v-        -- However we do want to consult the unfolding-        -- as well, for let-bound constructors!--isValue env (Lam b e)-  | isTyVar b = case isValue env e of-                  Just _  -> Just LambdaVal-                  Nothing -> Nothing-  | otherwise = Just LambdaVal--isValue env (Tick t e)-  | not (tickishIsCode t)-  = isValue env e--isValue _env expr       -- Maybe it's a constructor application-  | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr-  = case isDataConWorkId_maybe fun of--        Just con | args `lengthAtLeast` dataConRepArity con-                -- Check saturated; might be > because the-                --                  arity excludes type args-                -> Just (ConVal (DataAlt con) args)--        _other | valArgCount args < idArity fun-                -- Under-applied function-               -> Just LambdaVal        -- Partial application--        _other -> Nothing--isValue _env _expr = Nothing--valueIsWorkFree :: Value -> Bool-valueIsWorkFree LambdaVal       = True-valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args--samePat :: CallPat -> CallPat -> Bool-samePat (vs1, as1) (vs2, as2)-  = all2 same as1 as2-  where-    same (Var v1) (Var v2)-        | v1 `elem` vs1 = v2 `elem` vs2-        | v2 `elem` vs2 = False-        | otherwise     = v1 == v2--    same (Lit l1)    (Lit l2)    = l1==l2-    same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2--    same (Type {}) (Type {}) = True     -- Note [Ignore type differences]-    same (Coercion {}) (Coercion {}) = True-    same (Tick _ e1) e2 = same e1 e2  -- Ignore casts and notes-    same (Cast e1 _) e2 = same e1 e2-    same e1 (Tick _ e2) = same e1 e2-    same e1 (Cast e2 _) = same e1 e2--    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)-                 False  -- Let, lambda, case should not occur-    bad (Case {}) = True-    bad (Let {})  = True-    bad (Lam {})  = True-    bad _other    = False--{--Note [Ignore type differences]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do not want to generate specialisations where the call patterns-differ only in their type arguments!  Not only is it utterly useless,-but it also means that (with polymorphic recursion) we can generate-an infinite number of specialisations. Example is Data.Sequence.adjustTree,-I think.--}
− compiler/specialise/Specialise.hs 
@@ -1,2720 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1993-1998--\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-module Specialise ( specProgram, specUnfolding ) where--#include "HsVersions.h"--import GhcPrelude--import Id-import TcType hiding( substTy )-import Type   hiding( substTy, extendTvSubstList )-import Predicate-import Module( Module, HasModule(..) )-import Coercion( Coercion )-import CoreMonad-import qualified GHC.Core.Subst-import GHC.Core.Unfold-import Var              ( isLocalVar )-import VarSet-import VarEnv-import GHC.Core-import GHC.Core.Rules-import GHC.Core.SimpleOpt ( collectBindersPushingCo )-import GHC.Core.Utils     ( exprIsTrivial, mkCast, exprType )-import GHC.Core.FVs-import GHC.Core.Arity     ( etaExpandToJoinPointRule )-import UniqSupply-import Name-import MkId             ( voidArgId, voidPrimId )-import Maybes           ( mapMaybe, isJust )-import MonadUtils       ( foldlM )-import BasicTypes-import GHC.Driver.Types-import Bag-import GHC.Driver.Session-import Util-import Outputable-import FastString-import State-import UniqDFM-import TyCoRep (TyCoBinder (..))--import Control.Monad-import qualified Control.Monad.Fail as MonadFail--{--************************************************************************-*                                                                      *-\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}-*                                                                      *-************************************************************************--These notes describe how we implement specialisation to eliminate-overloading.--The specialisation pass works on Core-syntax, complete with all the explicit dictionary application,-abstraction and construction as added by the type checker.  The-existing type checker remains largely as it is.--One important thought: the {\em types} passed to an overloaded-function, and the {\em dictionaries} passed are mutually redundant.-If the same function is applied to the same type(s) then it is sure to-be applied to the same dictionary(s)---or rather to the same {\em-values}.  (The arguments might look different but they will evaluate-to the same value.)--Second important thought: we know that we can make progress by-treating dictionary arguments as static and worth specialising on.  So-we can do without binding-time analysis, and instead specialise on-dictionary arguments and no others.--The basic idea-~~~~~~~~~~~~~~-Suppose we have--        let f = <f_rhs>-        in <body>--and suppose f is overloaded.--STEP 1: CALL-INSTANCE COLLECTION--We traverse <body>, accumulating all applications of f to types and-dictionaries.--(Might there be partial applications, to just some of its types and-dictionaries?  In principle yes, but in practice the type checker only-builds applications of f to all its types and dictionaries, so partial-applications could only arise as a result of transformation, and even-then I think it's unlikely.  In any case, we simply don't accumulate such-partial applications.)---STEP 2: EQUIVALENCES--So now we have a collection of calls to f:-        f t1 t2 d1 d2-        f t3 t4 d3 d4-        ...-Notice that f may take several type arguments.  To avoid ambiguity, we-say that f is called at type t1/t2 and t3/t4.--We take equivalence classes using equality of the *types* (ignoring-the dictionary args, which as mentioned previously are redundant).--STEP 3: SPECIALISATION--For each equivalence class, choose a representative (f t1 t2 d1 d2),-and create a local instance of f, defined thus:--        f@t1/t2 = <f_rhs> t1 t2 d1 d2--f_rhs presumably has some big lambdas and dictionary lambdas, so lots-of simplification will now result.  However we don't actually *do* that-simplification.  Rather, we leave it for the simplifier to do.  If we-*did* do it, though, we'd get more call instances from the specialised-RHS.  We can work out what they are by instantiating the call-instance-set from f's RHS with the types t1, t2.--Add this new id to f's IdInfo, to record that f has a specialised version.--Before doing any of this, check that f's IdInfo doesn't already-tell us about an existing instance of f at the required type/s.-(This might happen if specialisation was applied more than once, or-it might arise from user SPECIALIZE pragmas.)--Recursion-~~~~~~~~~-Wait a minute!  What if f is recursive?  Then we can't just plug in-its right-hand side, can we?--But it's ok.  The type checker *always* creates non-recursive definitions-for overloaded recursive functions.  For example:--        f x = f (x+x)           -- Yes I know its silly--becomes--        f a (d::Num a) = let p = +.sel a d-                         in-                         letrec fl (y::a) = fl (p y y)-                         in-                         fl--We still have recursion for non-overloaded functions which we-specialise, but the recursive call should get specialised to the-same recursive version.---Polymorphism 1-~~~~~~~~~~~~~~--All this is crystal clear when the function is applied to *constant-types*; that is, types which have no type variables inside.  But what if-it is applied to non-constant types?  Suppose we find a call of f at type-t1/t2.  There are two possibilities:--(a) The free type variables of t1, t2 are in scope at the definition point-of f.  In this case there's no problem, we proceed just as before.  A common-example is as follows.  Here's the Haskell:--        g y = let f x = x+x-              in f y + f y--After typechecking we have--        g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x-                                in +.sel a d (f a d y) (f a d y)--Notice that the call to f is at type type "a"; a non-constant type.-Both calls to f are at the same type, so we can specialise to give:--        g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x-                                in +.sel a d (f@a y) (f@a y)---(b) The other case is when the type variables in the instance types-are *not* in scope at the definition point of f.  The example we are-working with above is a good case.  There are two instances of (+.sel a d),-but "a" is not in scope at the definition of +.sel.  Can we do anything?-Yes, we can "common them up", a sort of limited common sub-expression deal.-This would give:--        g a (d::Num a) (y::a) = let +.sel@a = +.sel a d-                                    f@a (x::a) = +.sel@a x x-                                in +.sel@a (f@a y) (f@a y)--This can save work, and can't be spotted by the type checker, because-the two instances of +.sel weren't originally at the same type.--Further notes on (b)--* There are quite a few variations here.  For example, the defn of-  +.sel could be floated outside the \y, to attempt to gain laziness.-  It certainly mustn't be floated outside the \d because the d has to-  be in scope too.--* We don't want to inline f_rhs in this case, because-that will duplicate code.  Just commoning up the call is the point.--* Nothing gets added to +.sel's IdInfo.--* Don't bother unless the equivalence class has more than one item!--Not clear whether this is all worth it.  It is of course OK to-simply discard call-instances when passing a big lambda.--Polymorphism 2 -- Overloading-~~~~~~~~~~~~~~-Consider a function whose most general type is--        f :: forall a b. Ord a => [a] -> b -> b--There is really no point in making a version of g at Int/Int and another-at Int/Bool, because it's only instantiating the type variable "a" which-buys us any efficiency. Since g is completely polymorphic in b there-ain't much point in making separate versions of g for the different-b types.--That suggests that we should identify which of g's type variables-are constrained (like "a") and which are unconstrained (like "b").-Then when taking equivalence classes in STEP 2, we ignore the type args-corresponding to unconstrained type variable.  In STEP 3 we make-polymorphic versions.  Thus:--        f@t1/ = /\b -> <f_rhs> t1 b d1 d2--We do this.---Dictionary floating-~~~~~~~~~~~~~~~~~~~-Consider this--        f a (d::Num a) = let g = ...-                         in-                         ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...--Here, g is only called at one type, but the dictionary isn't in scope at the-definition point for g.  Usually the type checker would build a-definition for d1 which enclosed g, but the transformation system-might have moved d1's defn inward.  Solution: float dictionary bindings-outwards along with call instances.--Consider--        f x = let g p q = p==q-                  h r s = (r+s, g r s)-              in-              h x x---Before specialisation, leaving out type abstractions we have--        f df x = let g :: Eq a => a -> a -> Bool-                     g dg p q = == dg p q-                     h :: Num a => a -> a -> (a, Bool)-                     h dh r s = let deq = eqFromNum dh-                                in (+ dh r s, g deq r s)-              in-              h df x x--After specialising h we get a specialised version of h, like this:--                    h' r s = let deq = eqFromNum df-                             in (+ df r s, g deq r s)--But we can't naively make an instance for g from this, because deq is not in scope-at the defn of g.  Instead, we have to float out the (new) defn of deq-to widen its scope.  Notice that this floating can't be done in advance -- it only-shows up when specialisation is done.--User SPECIALIZE pragmas-~~~~~~~~~~~~~~~~~~~~~~~-Specialisation pragmas can be digested by the type checker, and implemented-by adding extra definitions along with that of f, in the same way as before--        f@t1/t2 = <f_rhs> t1 t2 d1 d2--Indeed the pragmas *have* to be dealt with by the type checker, because-only it knows how to build the dictionaries d1 and d2!  For example--        g :: Ord a => [a] -> [a]-        {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}--Here, the specialised version of g is an application of g's rhs to the-Ord dictionary for (Tree Int), which only the type checker can conjure-up.  There might not even *be* one, if (Tree Int) is not an instance of-Ord!  (All the other specialision has suitable dictionaries to hand-from actual calls.)--Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because-it is buried in a complex (as-yet-un-desugared) binding group.-Maybe we should say--        f@t1/t2 = f* t1 t2 d1 d2--where f* is the Id f with an IdInfo which says "inline me regardless!".-Indeed all the specialisation could be done in this way.-That in turn means that the simplifier has to be prepared to inline absolutely-any in-scope let-bound thing.---Again, the pragma should permit polymorphism in unconstrained variables:--        h :: Ord a => [a] -> b -> b-        {-# SPECIALIZE h :: [Int] -> b -> b #-}--We *insist* that all overloaded type variables are specialised to ground types,-(and hence there can be no context inside a SPECIALIZE pragma).-We *permit* unconstrained type variables to be specialised to-        - a ground type-        - or left as a polymorphic type variable-but nothing in between.  So--        {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}--is *illegal*.  (It can be handled, but it adds complication, and gains the-programmer nothing.)---SPECIALISING INSTANCE DECLARATIONS-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--        instance Foo a => Foo [a] where-                ...-        {-# SPECIALIZE instance Foo [Int] #-}--The original instance decl creates a dictionary-function-definition:--        dfun.Foo.List :: forall a. Foo a -> Foo [a]--The SPECIALIZE pragma just makes a specialised copy, just as for-ordinary function definitions:--        dfun.Foo.List@Int :: Foo [Int]-        dfun.Foo.List@Int = dfun.Foo.List Int dFooInt--The information about what instance of the dfun exist gets added to-the dfun's IdInfo in the same way as a user-defined function too.---Automatic instance decl specialisation?-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Can instance decls be specialised automatically?  It's tricky.-We could collect call-instance information for each dfun, but-then when we specialised their bodies we'd get new call-instances-for ordinary functions; and when we specialised their bodies, we might get-new call-instances of the dfuns, and so on.  This all arises because of-the unrestricted mutual recursion between instance decls and value decls.--Still, there's no actual problem; it just means that we may not do all-the specialisation we could theoretically do.--Furthermore, instance decls are usually exported and used non-locally,-so we'll want to compile enough to get those specialisations done.--Lastly, there's no such thing as a local instance decl, so we can-survive solely by spitting out *usage* information, and then reading that-back in as a pragma when next compiling the file.  So for now,-we only specialise instance decls in response to pragmas.---SPITTING OUT USAGE INFORMATION-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--To spit out usage information we need to traverse the code collecting-call-instance information for all imported (non-prelude?) functions-and data types. Then we equivalence-class it and spit it out.--This is done at the top-level when all the call instances which escape-must be for imported functions and data types.--*** Not currently done ***---Partial specialisation by pragmas-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What about partial specialisation:--        k :: (Ord a, Eq b) => [a] -> b -> b -> [a]-        {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}--or even--        {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}--Seems quite reasonable.  Similar things could be done with instance decls:--        instance (Foo a, Foo b) => Foo (a,b) where-                ...-        {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}-        {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}--Ho hum.  Things are complex enough without this.  I pass.---Requirements for the simplifier-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The simplifier has to be able to take advantage of the specialisation.--* When the simplifier finds an application of a polymorphic f, it looks in-f's IdInfo in case there is a suitable instance to call instead.  This converts--        f t1 t2 d1 d2   ===>   f_t1_t2--Note that the dictionaries get eaten up too!--* Dictionary selection operations on constant dictionaries must be-  short-circuited:--        +.sel Int d     ===>  +Int--The obvious way to do this is in the same way as other specialised-calls: +.sel has inside it some IdInfo which tells that if it's applied-to the type Int then it should eat a dictionary and transform to +Int.--In short, dictionary selectors need IdInfo inside them for constant-methods.--* Exactly the same applies if a superclass dictionary is being-  extracted:--        Eq.sel Int d   ===>   dEqInt--* Something similar applies to dictionary construction too.  Suppose-dfun.Eq.List is the function taking a dictionary for (Eq a) to-one for (Eq [a]).  Then we want--        dfun.Eq.List Int d      ===> dEq.List_Int--Where does the Eq [Int] dictionary come from?  It is built in-response to a SPECIALIZE pragma on the Eq [a] instance decl.--In short, dfun Ids need IdInfo with a specialisation for each-constant instance of their instance declaration.--All this uses a single mechanism: the SpecEnv inside an Id---What does the specialisation IdInfo look like?-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The SpecEnv of an Id maps a list of types (the template) to an expression--        [Type]  |->  Expr--For example, if f has this RuleInfo:--        [Int, a]  ->  \d:Ord Int. f' a--it means that we can replace the call--        f Int t  ===>  (\d. f' t)--This chucks one dictionary away and proceeds with the-specialised version of f, namely f'.---What can't be done this way?-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is no way, post-typechecker, to get a dictionary for (say)-Eq a from a dictionary for Eq [a].  So if we find--        ==.sel [t] d--we can't transform to--        eqList (==.sel t d')--where-        eqList :: (a->a->Bool) -> [a] -> [a] -> Bool--Of course, we currently have no way to automatically derive-eqList, nor to connect it to the Eq [a] instance decl, but you-can imagine that it might somehow be possible.  Taking advantage-of this is permanently ruled out.--Still, this is no great hardship, because we intend to eliminate-overloading altogether anyway!--A note about non-tyvar dictionaries-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some Ids have types like--        forall a,b,c. Eq a -> Ord [a] -> tau--This seems curious at first, because we usually only have dictionary-args whose types are of the form (C a) where a is a type variable.-But this doesn't hold for the functions arising from instance decls,-which sometimes get arguments with types of form (C (T a)) for some-type constructor T.--Should we specialise wrt this compound-type dictionary?  We used to say-"no", saying:-        "This is a heuristic judgement, as indeed is the fact that we-        specialise wrt only dictionaries.  We choose *not* to specialise-        wrt compound dictionaries because at the moment the only place-        they show up is in instance decls, where they are simply plugged-        into a returned dictionary.  So nothing is gained by specialising-        wrt them."--But it is simpler and more uniform to specialise wrt these dicts too;-and in future GHC is likely to support full fledged type signatures-like-        f :: Eq [(a,b)] => ...---************************************************************************-*                                                                      *-\subsubsection{The new specialiser}-*                                                                      *-************************************************************************--Our basic game plan is this.  For let(rec) bound function-        f :: (C a, D c) => (a,b,c,d) -> Bool--* Find any specialised calls of f, (f ts ds), where-  ts are the type arguments t1 .. t4, and-  ds are the dictionary arguments d1 .. d2.--* Add a new definition for f1 (say):--        f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2--  Note that we abstract over the unconstrained type arguments.--* Add the mapping--        [t1,b,t3,d]  |->  \d1 d2 -> f1 b d--  to the specialisations of f.  This will be used by the-  simplifier to replace calls-                (f t1 t2 t3 t4) da db-  by-                (\d1 d1 -> f1 t2 t4) da db--  All the stuff about how many dictionaries to discard, and what types-  to apply the specialised function to, are handled by the fact that the-  SpecEnv contains a template for the result of the specialisation.--We don't build *partial* specialisations for f.  For example:--  f :: Eq a => a -> a -> Bool-  {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}--Here, little is gained by making a specialised copy of f.-There's a distinct danger that the specialised version would-first build a dictionary for (Eq b, Eq c), and then select the (==)-method from it!  Even if it didn't, not a great deal is saved.--We do, however, generate polymorphic, but not overloaded, specialisations:--  f :: Eq a => [a] -> b -> b -> b-  ... SPECIALISE f :: [Int] -> b -> b -> b ...--Hence, the invariant is this:--        *** no specialised version is overloaded ***---************************************************************************-*                                                                      *-\subsubsection{The exported function}-*                                                                      *-************************************************************************--}---- | Specialise calls to type-class overloaded functions occurring in a program.-specProgram :: ModGuts -> CoreM ModGuts-specProgram guts@(ModGuts { mg_module = this_mod-                          , mg_rules = local_rules-                          , mg_binds = binds })-  = do { dflags <- getDynFlags--             -- Specialise the bindings of this module-       ; (binds', uds) <- runSpecM dflags this_mod (go binds)--             -- Specialise imported functions-       ; hpt_rules <- getRuleBase-       ; let rule_base = extendRuleBaseList hpt_rules local_rules-       ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet-                                                [] rule_base uds--       ; let final_binds-               | null spec_binds = binds'-               | otherwise       = Rec (flattenBinds spec_binds) : binds'-                   -- Note [Glom the bindings if imported functions are specialised]--       ; return (guts { mg_binds = final_binds-                      , mg_rules = new_rules ++ local_rules }) }-  where-        -- We need to start with a Subst that knows all the things-        -- that are in scope, so that the substitution engine doesn't-        -- accidentally re-use a unique that's already in use-        -- Easiest thing is to do it all at once, as if all the top-level-        -- decls were mutually recursive-    top_env = SE { se_subst = GHC.Core.Subst.mkEmptySubst $ mkInScopeSet $ mkVarSet $-                              bindersOfBinds binds-                 , se_interesting = emptyVarSet }--    go []           = return ([], emptyUDs)-    go (bind:binds) = do (binds', uds) <- go binds-                         (bind', uds') <- specBind top_env bind uds-                         return (bind' ++ binds', uds')--{--Note [Wrap bindings returned by specImports]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-'specImports' returns a set of specialized bindings. However, these are lacking-necessary floated dictionary bindings, which are returned by-UsageDetails(ud_binds). These dictionaries need to be brought into scope with-'wrapDictBinds' before the bindings returned by 'specImports' can be used. See,-for instance, the 'specImports' call in 'specProgram'.---Note [Disabling cross-module specialisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Since GHC 7.10 we have performed specialisation of INLINABLE bindings living-in modules outside of the current module. This can sometimes uncover user code-which explodes in size when aggressively optimized. The--fno-cross-module-specialise option was introduced to allow users to being-bitten by such instances to revert to the pre-7.10 behavior.--See #10491--}---- | An argument that we might want to specialise.--- See Note [Specialising Calls] for the nitty gritty details.-data SpecArg-  =-    -- | Type arguments that should be specialised, due to appearing-    -- free in the type of a 'SpecDict'.-    SpecType Type-    -- | Type arguments that should remain polymorphic.-  | UnspecType-    -- | Dictionaries that should be specialised.-  | SpecDict DictExpr-    -- | Value arguments that should not be specialised.-  | UnspecArg--instance Outputable SpecArg where-  ppr (SpecType t) = text "SpecType" <+> ppr t-  ppr UnspecType   = text "UnspecType"-  ppr (SpecDict d) = text "SpecDict" <+> ppr d-  ppr UnspecArg    = text "UnspecArg"--getSpecDicts :: [SpecArg] -> [DictExpr]-getSpecDicts = mapMaybe go-  where-    go (SpecDict d) = Just d-    go _            = Nothing--getSpecTypes :: [SpecArg] -> [Type]-getSpecTypes = mapMaybe go-  where-    go (SpecType t) = Just t-    go _            = Nothing--isUnspecArg :: SpecArg -> Bool-isUnspecArg UnspecArg  = True-isUnspecArg UnspecType = True-isUnspecArg _          = False--isValueArg :: SpecArg -> Bool-isValueArg UnspecArg    = True-isValueArg (SpecDict _) = True-isValueArg _            = False---- | Given binders from an original function 'f', and the 'SpecArg's--- corresponding to its usage, compute everything necessary to build--- a specialisation.------ We will use a running example. Consider the function------    foo :: forall a b. Eq a => Int -> blah---    foo @a @b dEqA i = blah------ which is called with the 'CallInfo'------    [SpecType T1, UnspecType, SpecDict dEqT1, UnspecArg]------ We'd eventually like to build the RULE------    RULE "SPEC foo @T1 _"---      forall @a @b (dEqA' :: Eq a).---        foo @T1 @b dEqA' = $sfoo @b------ and the specialisation '$sfoo'------    $sfoo :: forall b. Int -> blah---    $sfoo @b = \i -> SUBST[a->T1, dEqA->dEqA'] blah------ The cases for 'specHeader' below are presented in the same order as this--- running example. The result of 'specHeader' for this example is as follows:------    ( -- Returned arguments---      env + [a -> T1, deqA -> dEqA']---    , []------      -- RULE helpers---    , [b, dx', i]---    , [T1, b, dx', i]------      -- Specialised function helpers---    , [b, i]---    , [dx]---    , [T1, b, dx_spec, i]---    )-specHeader-     :: SpecEnv-     -> [CoreBndr]  -- The binders from the original function 'f'-     -> [SpecArg]   -- From the CallInfo-     -> SpecM ( -- Returned arguments-                SpecEnv      -- Substitution to apply to the body of 'f'-              , [CoreBndr]   -- All the remaining unspecialised args from the original function 'f'--                -- RULE helpers-              , [CoreBndr]   -- Binders for the RULE-              , [CoreArg]    -- Args for the LHS of the rule--                -- Specialised function helpers-              , [CoreBndr]   -- Binders for $sf-              , [DictBind]   -- Auxiliary dictionary bindings-              , [CoreExpr]   -- Specialised arguments for unfolding-              )---- We want to specialise on type 'T1', and so we must construct a substitution--- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding--- details.-specHeader env (bndr : bndrs) (SpecType t : args)-  = do { let env' = extendTvSubstList env [(bndr, t)]-       ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)-            <- specHeader env' bndrs args-       ; pure ( env''-              , unused_bndrs-              , rule_bs-              , Type t : rule_es-              , bs'-              , dx-              , Type t : spec_args-              )-       }---- Next we have a type that we don't want to specialise. We need to perform--- a substitution on it (in case the type refers to 'a'). Additionally, we need--- to produce a binder, LHS argument and RHS argument for the resulting rule,--- /and/ a binder for the specialised body.-specHeader env (bndr : bndrs) (UnspecType : args)-  = do { let (env', bndr') = substBndr env bndr-       ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)-            <- specHeader env' bndrs args-       ; pure ( env''-              , unused_bndrs-              , bndr' : rule_bs-              , varToCoreExpr bndr' : rule_es-              , bndr' : bs'-              , dx-              , varToCoreExpr bndr' : spec_args-              )-       }---- Next we want to specialise the 'Eq a' dict away. We need to construct--- a wildcard binder to match the dictionary (See Note [Specialising Calls] for--- the nitty-gritty), as a LHS rule and unfolding details.-specHeader env (bndr : bndrs) (SpecDict d : args)-  = do { inst_dict_id <- newDictBndr env bndr-       ; let (rhs_env2, dx_binds, spec_dict_args')-                = bindAuxiliaryDicts env [bndr] [d] [inst_dict_id]-       ; (env', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)-             <- specHeader rhs_env2 bndrs args-       ; pure ( env'-              , unused_bndrs-              -- See Note [Evidence foralls]-              , exprFreeIdsList (varToCoreExpr inst_dict_id) ++ rule_bs-              , varToCoreExpr inst_dict_id : rule_es-              , bs'-              , dx_binds ++ dx-              , spec_dict_args' ++ spec_args-              )-       }---- Finally, we have the unspecialised argument 'i'. We need to produce--- a binder, LHS and RHS argument for the RULE, and a binder for the--- specialised body.------ NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is--- why 'i' doesn't appear in our RULE above. But we have no guarantee that--- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so--- this case must be here.-specHeader env (bndr : bndrs) (UnspecArg : args)-  = do { let (env', bndr') = substBndr env bndr-       ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)-             <- specHeader env' bndrs args-       ; pure ( env''-              , unused_bndrs-              , bndr' : rule_bs-              , varToCoreExpr bndr' : rule_es-              , bndr' : bs'-              , dx-              , varToCoreExpr bndr' : spec_args-              )-       }---- Return all remaining binders from the original function. These have the--- invariant that they should all correspond to unspecialised arguments, so--- it's safe to stop processing at this point.-specHeader env bndrs [] = pure (env, bndrs, [], [], [], [], [])-specHeader env [] _     = pure (env, [], [], [], [], [], [])----- | Specialise a set of calls to imported bindings-specImports :: DynFlags-            -> Module-            -> SpecEnv          -- Passed in so that all top-level Ids are in scope-            -> VarSet           -- Don't specialise these ones-                                -- See Note [Avoiding recursive specialisation]-            -> [Id]             -- Stack of imported functions being specialised-            -> RuleBase         -- Rules from this module and the home package-                                -- (but not external packages, which can change)-            -> UsageDetails     -- Calls for imported things, and floating bindings-            -> CoreM ( [CoreRule]   -- New rules-                     , [CoreBind] ) -- Specialised bindings-                                    -- See Note [Wrapping bindings returned by specImports]-specImports dflags this_mod top_env done callers rule_base-            (MkUD { ud_binds = dict_binds, ud_calls = calls })-  -- See Note [Disabling cross-module specialisation]-  | not $ gopt Opt_CrossModuleSpecialise dflags-  = return ([], [])--  | otherwise-  = do { let import_calls = dVarEnvElts calls-       ; (rules, spec_binds) <- go rule_base import_calls--             -- Don't forget to wrap the specialized bindings with-             -- bindings for the needed dictionaries.-             -- See Note [Wrap bindings returned by specImports]-       ; let spec_binds' = wrapDictBinds dict_binds spec_binds--       ; return (rules, spec_binds') }-  where-    go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])-    go _ [] = return ([], [])-    go rb (cis@(CIS fn _) : other_calls)-      = do { let ok_calls = filterCalls cis dict_binds-                     -- Drop calls that (directly or indirectly) refer to fn-                     -- See Note [Avoiding loops]---           ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn---                                                       , text "calls" <+> ppr cis---                                                       , text "ud_binds =" <+> ppr dict_binds---                                                       , text "dump set =" <+> ppr dump_set---                                                       , text "filtered calls =" <+> ppr ok_calls ])-           ; (rules1, spec_binds1) <- specImport dflags this_mod top_env-                                                 done callers rb fn ok_calls--           ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls-           ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }--specImport :: DynFlags-           -> Module-           -> SpecEnv               -- Passed in so that all top-level Ids are in scope-           -> VarSet                -- Don't specialise these-                                    -- See Note [Avoiding recursive specialisation]-           -> [Id]                  -- Stack of imported functions being specialised-           -> RuleBase              -- Rules from this module-           -> Id -> [CallInfo]      -- Imported function and calls for it-           -> CoreM ( [CoreRule]    -- New rules-                    , [CoreBind] )  -- Specialised bindings-specImport dflags this_mod top_env done callers rb fn calls_for_fn-  | fn `elemVarSet` done-  = return ([], [])     -- No warning.  This actually happens all the time-                        -- when specialising a recursive function, because-                        -- the RHS of the specialised function contains a recursive-                        -- call to the original function--  | null calls_for_fn   -- We filtered out all the calls in deleteCallsMentioning-  = return ([], [])--  | wantSpecImport dflags unfolding-  , Just rhs <- maybeUnfoldingTemplate unfolding-  = do {     -- Get rules from the external package state-             -- We keep doing this in case we "page-fault in"-             -- more rules as we go along-       ; 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--       ; (rules1, spec_pairs, uds)-             <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $-                runSpecM dflags this_mod $-                specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs-       ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]-             -- After the rules kick in we may get recursion, but-             -- we rely on a global GlomBinds to sort that out later-             -- See Note [Glom the bindings if imported functions are specialised]--              -- Now specialise any cascaded calls-       ; (rules2, spec_binds2) <- -- pprTrace "specImport 2" (ppr fn $$ ppr rules1 $$ ppr spec_binds1) $-                                  specImports dflags this_mod top_env-                                              (extendVarSet done fn)-                                              (fn:callers)-                                              (extendRuleBaseList rb rules1)-                                              uds--       ; let final_binds = spec_binds2 ++ spec_binds1--       ; return (rules2 ++ rules1, final_binds) }--  | otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn-                   ; return ([], [])}--  where-    unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers---- | Returns whether or not to show a missed-spec warning.--- If -Wall-missed-specializations is on, show the warning.--- Otherwise, if -Wmissed-specializations is on, only show a warning--- if there is at least one imported function being specialized,--- and if all imported functions are marked with an inline pragma--- Use the most specific warning as the reason.-tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()--- See Note [Warning about missed specialisations]-tryWarnMissingSpecs dflags callers fn calls_for_fn-  | wopt Opt_WarnMissedSpecs dflags-    && not (null callers)-    && allCallersInlined                  = doWarn $ Reason Opt_WarnMissedSpecs-  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ Reason Opt_WarnAllMissedSpecs-  | otherwise                             = return ()-  where-    allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers-    doWarn reason =-      warnMsg reason-        (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))-                2 (vcat [ text "when specialising" <+> quotes (ppr caller)-                        | caller <- callers])-          , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))-          , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])--wantSpecImport :: DynFlags -> Unfolding -> Bool--- See Note [Specialise imported INLINABLE things]-wantSpecImport dflags unf- = case unf of-     NoUnfolding      -> False-     BootUnfolding    -> False-     OtherCon {}      -> False-     DFunUnfolding {} -> True-     CoreUnfolding { uf_src = src, uf_guidance = _guidance }-       | gopt Opt_SpecialiseAggressively dflags -> True-       | isStableSource src -> True-               -- Specialise even INLINE things; it hasn't inlined yet,-               -- so perhaps it never will.  Moreover it may have calls-               -- inside it that we want to specialise-       | otherwise -> False    -- Stable, not INLINE, hence INLINABLE--{- Note [Warning about missed specialisations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose- * In module Lib, you carefully mark a function 'foo' INLINABLE- * Import Lib(foo) into another module M- * Call 'foo' at some specialised type in M-Then you jolly well expect it to be specialised in M.  But what if-'foo' calls another function 'Lib.bar'.  Then you'd like 'bar' to be-specialised too.  But if 'bar' is not marked INLINABLE it may well-not be specialised.  The warning Opt_WarnMissedSpecs warns about this.--It's more noisy to warning about a missed specialisation opportunity-for /every/ overloaded imported function, but sometimes useful. That-is what Opt_WarnAllMissedSpecs does.--ToDo: warn about missed opportunities for local functions.--Note [Specialise imported INLINABLE things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What imported functions do we specialise?  The basic set is- * DFuns and things with INLINABLE pragmas.-but with -fspecialise-aggressively we add- * Anything with an unfolding template--#8874 has a good example of why we want to auto-specialise DFuns.--We have the -fspecialise-aggressively flag (usually off), because we-risk lots of orphan modules from over-vigorous specialisation.-However it's not a big deal: anything non-recursive with an-unfolding-template will probably have been inlined already.--Note [Glom the bindings if imported functions are specialised]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have an imported, *recursive*, INLINABLE function-   f :: Eq a => a -> a-   f = /\a \d x. ...(f a d)...-In the module being compiled we have-   g x = f (x::Int)-Now we'll make a specialised function-   f_spec :: Int -> Int-   f_spec = \x -> ...(f Int dInt)...-   {-# RULE  f Int _ = f_spec #-}-   g = \x. f Int dInt x-Note that f_spec doesn't look recursive-After rewriting with the RULE, we get-   f_spec = \x -> ...(f_spec)...-BUT since f_spec was non-recursive before it'll *stay* non-recursive.-The occurrence analyser never turns a NonRec into a Rec.  So we must-make sure that f_spec is recursive.  Easiest thing is to make all-the specialisations for imported bindings recursive.---Note [Avoiding recursive specialisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we specialise 'f' we may find new overloaded calls to 'g', 'h' in-'f's RHS.  So we want to specialise g,h.  But we don't want to-specialise f any more!  It's possible that f's RHS might have a-recursive yet-more-specialised call, so we'd diverge in that case.-And if the call is to the same type, one specialisation is enough.-Avoiding this recursive specialisation loop is the reason for the-'done' VarSet passed to specImports and specImport.--************************************************************************-*                                                                      *-\subsubsection{@specExpr@: the main function}-*                                                                      *-************************************************************************--}--data SpecEnv-  = SE { se_subst :: GHC.Core.Subst.Subst-             -- We carry a substitution down:-             -- a) we must clone any binding that might float outwards,-             --    to avoid name clashes-             -- b) we carry a type substitution to use when analysing-             --    the RHS of specialised bindings (no type-let!)---       , se_interesting :: VarSet-             -- Dict Ids that we know something about-             -- and hence may be worth specialising against-             -- See Note [Interesting dictionary arguments]-     }--specVar :: SpecEnv -> Id -> CoreExpr-specVar env v = GHC.Core.Subst.lookupIdSubst (text "specVar") (se_subst env) v--specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)------------------ First the easy cases ---------------------specExpr env (Type ty)     = return (Type     (substTy env ty), emptyUDs)-specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)-specExpr env (Var v)       = return (specVar env v, emptyUDs)-specExpr _   (Lit lit)     = return (Lit lit,       emptyUDs)-specExpr env (Cast e co)-  = do { (e', uds) <- specExpr env e-       ; return ((mkCast e' (substCo env co)), uds) }-specExpr env (Tick tickish body)-  = do { (body', uds) <- specExpr env body-       ; return (Tick (specTickish env tickish) body', uds) }------------------ Applications might generate a call instance ---------------------specExpr env expr@(App {})-  = go expr []-  where-    go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg-                               (fun', uds_app) <- go fun (arg':args)-                               return (App fun' arg', uds_arg `plusUDs` uds_app)--    go (Var f)       args = case specVar env f of-                                Var f' -> return (Var f', mkCallUDs env f' args)-                                e'     -> return (e', emptyUDs) -- I don't expect this!-    go other         _    = specExpr env other------------------ Lambda/case require dumping of usage details ---------------------specExpr env e@(Lam _ _) = do-    (body', uds) <- specExpr env' body-    let (free_uds, dumped_dbs) = dumpUDs bndrs' uds-    return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds)-  where-    (bndrs, body) = collectBinders e-    (env', bndrs') = substBndrs env bndrs-        -- More efficient to collect a group of binders together all at once-        -- and we don't want to split a lambda group with dumped bindings--specExpr env (Case scrut case_bndr ty alts)-  = do { (scrut', scrut_uds) <- specExpr env scrut-       ; (scrut'', case_bndr', alts', alts_uds)-             <- specCase env scrut' case_bndr alts-       ; return (Case scrut'' case_bndr' (substTy env ty) alts'-                , scrut_uds `plusUDs` alts_uds) }------------------ Finally, let is the interesting case ---------------------specExpr env (Let bind body)-  = do { -- Clone binders-         (rhs_env, body_env, bind') <- cloneBindSM env bind--         -- Deal with the body-       ; (body', body_uds) <- specExpr body_env body--        -- Deal with the bindings-      ; (binds', uds) <- specBind rhs_env bind' body_uds--        -- All done-      ; return (foldr Let body' binds', uds) }--specTickish :: SpecEnv -> Tickish Id -> Tickish Id-specTickish env (Breakpoint ix ids)-  = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]-  -- drop vars from the list if they have a non-variable substitution.-  -- should never happen, but it's harmless to drop them anyway.-specTickish _ other_tickish = other_tickish--specCase :: SpecEnv-         -> CoreExpr            -- Scrutinee, already done-         -> Id -> [CoreAlt]-         -> SpecM ( CoreExpr    -- New scrutinee-                  , Id-                  , [CoreAlt]-                  , UsageDetails)-specCase env scrut' case_bndr [(con, args, rhs)]-  | isDictId case_bndr           -- See Note [Floating dictionaries out of cases]-  , interestingDict env scrut'-  , not (isDeadBinder case_bndr && null sc_args')-  = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')--       ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')-                              [(con, args', Var sc_arg')]-                       | sc_arg' <- sc_args' ]--             -- Extend the substitution for RHS to map the *original* binders-             -- to their floated versions.-             mb_sc_flts :: [Maybe DictId]-             mb_sc_flts = map (lookupVarEnv clone_env) args'-             clone_env  = zipVarEnv sc_args' sc_args_flt-             subst_prs  = (case_bndr, Var case_bndr_flt)-                        : [ (arg, Var sc_flt)-                          | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]-             env_rhs' = env_rhs { se_subst = GHC.Core.Subst.extendIdSubstList (se_subst env_rhs) subst_prs-                                , se_interesting = se_interesting env_rhs `extendVarSetList`-                                                   (case_bndr_flt : sc_args_flt) }--       ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs-       ; let scrut_bind    = mkDB (NonRec case_bndr_flt scrut')-             case_bndr_set = unitVarSet case_bndr_flt-             sc_binds      = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)-                             | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]-             flt_binds     = scrut_bind : sc_binds-             (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds-             all_uds = flt_binds `addDictBinds` free_uds-             alt'    = (con, args', wrapDictBindsE dumped_dbs rhs')-       ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }-  where-    (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)-    sc_args' = filter is_flt_sc_arg args'--    clone_me bndr = do { uniq <- getUniqueM-                       ; return (mkUserLocalOrCoVar occ uniq ty loc) }-       where-         name = idName bndr-         ty   = idType bndr-         occ  = nameOccName name-         loc  = getSrcSpan name--    arg_set = mkVarSet args'-    is_flt_sc_arg var =  isId var-                      && not (isDeadBinder var)-                      && isDictTy var_ty-                      && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set)-       where-         var_ty = idType var---specCase env scrut case_bndr alts-  = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts-       ; return (scrut, case_bndr', alts', uds_alts) }-  where-    (env_alt, case_bndr') = substBndr env case_bndr-    spec_alt (con, args, rhs) = do-          (rhs', uds) <- specExpr env_rhs rhs-          let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds-          return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)-        where-          (env_rhs, args') = substBndrs env_alt args--{--Note [Floating dictionaries out of cases]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   g = \d. case d of { MkD sc ... -> ...(f sc)... }-Naively we can't float d2's binding out of the case expression,-because 'sc' is bound by the case, and that in turn means we can't-specialise f, which seems a pity.--So we invert the case, by floating out a binding-for 'sc_flt' thus:-    sc_flt = case d of { MkD sc ... -> sc }-Now we can float the call instance for 'f'.  Indeed this is just-what'll happen if 'sc' was originally bound with a let binding,-but case is more efficient, and necessary with equalities. So it's-good to work with both.--You might think that this won't make any difference, because the-call instance will only get nuked by the \d.  BUT if 'g' itself is-specialised, then transitively we should be able to specialise f.--In general, given-   case e of cb { MkD sc ... -> ...(f sc)... }-we transform to-   let cb_flt = e-       sc_flt = case cb_flt of { MkD sc ... -> sc }-   in-   case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }--The "_flt" things are the floated binds; we use the current substitution-to substitute sc -> sc_flt in the RHS--************************************************************************-*                                                                      *-                     Dealing with a binding-*                                                                      *-************************************************************************--}--specBind :: SpecEnv                     -- Use this for RHSs-         -> CoreBind                    -- Binders are already cloned by cloneBindSM,-                                        -- but RHSs are un-processed-         -> UsageDetails                -- Info on how the scope of the binding-         -> SpecM ([CoreBind],          -- New bindings-                   UsageDetails)        -- And info to pass upstream---- Returned UsageDetails:---    No calls for binders of this bind-specBind rhs_env (NonRec fn rhs) body_uds-  = do { (rhs', rhs_uds) <- specExpr rhs_env rhs-       ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs--       ; let pairs = spec_defns ++ [(fn', rhs')]-                        -- fn' mentions the spec_defns in its rules,-                        -- so put the latter first--             combined_uds = body_uds1 `plusUDs` rhs_uds--             (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds--             final_binds :: [DictBind]-             -- See Note [From non-recursive to recursive]-             final_binds-               | not (isEmptyBag dump_dbs)-               , not (null spec_defns)-               = [recWithDumpedDicts pairs dump_dbs]-               | otherwise-               = [mkDB $ NonRec b r | (b,r) <- pairs]-                 ++ bagToList dump_dbs--       ; if float_all then-             -- Rather than discard the calls mentioning the bound variables-             -- we float this (dictionary) binding along with the others-              return ([], free_uds `snocDictBinds` final_binds)-         else-             -- No call in final_uds mentions bound variables,-             -- so we can just leave the binding here-              return (map fst final_binds, free_uds) }---specBind rhs_env (Rec pairs) body_uds-       -- Note [Specialising a recursive group]-  = do { let (bndrs,rhss) = unzip pairs-       ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss-       ; let scope_uds = body_uds `plusUDs` rhs_uds-                       -- Includes binds and calls arising from rhss--       ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs--       ; (bndrs3, spec_defns3, uds3)-             <- if null spec_defns1  -- Common case: no specialisation-                then return (bndrs1, [], uds1)-                else do {            -- Specialisation occurred; do it again-                          (bndrs2, spec_defns2, uds2)-                              <- specDefns rhs_env uds1 (bndrs1 `zip` rhss)-                        ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }--       ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3-             final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')-                                             dumped_dbs--       ; if float_all then-              return ([], final_uds `snocDictBind` final_bind)-         else-              return ([fst final_bind], final_uds) }-------------------------------specDefns :: SpecEnv-          -> UsageDetails               -- Info on how it is used in its scope-          -> [(OutId,InExpr)]           -- The things being bound and their un-processed RHS-          -> SpecM ([OutId],            -- Original Ids with RULES added-                    [(OutId,OutExpr)],  -- Extra, specialised bindings-                    UsageDetails)       -- Stuff to fling upwards from the specialised versions---- Specialise a list of bindings (the contents of a Rec), but flowing usages--- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }--- Then if the input CallDetails has a specialised call for 'g', whose specialisation--- in turn generates a specialised call for 'f', we catch that in this one sweep.--- But not vice versa (it's a fixpoint problem).--specDefns _env uds []-  = return ([], [], uds)-specDefns env uds ((bndr,rhs):pairs)-  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs-       ; (bndr1, spec_defns2, uds2)  <- specDefn env uds1 bndr rhs-       ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }------------------------------specDefn :: SpecEnv-         -> UsageDetails                -- Info on how it is used in its scope-         -> OutId -> InExpr             -- The thing being bound and its un-processed RHS-         -> SpecM (Id,                  -- Original Id with added RULES-                   [(Id,CoreExpr)],     -- Extra, specialised bindings-                   UsageDetails)        -- Stuff to fling upwards from the specialised versions--specDefn env body_uds fn rhs-  = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds-             rules_for_me = idCoreRules fn-       ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me-                                                    calls_for_me fn rhs-       ; return ( fn `addIdSpecialisations` rules-                , spec_defns-                , body_uds_without_me `plusUDs` spec_uds) }-                -- It's important that the `plusUDs` is this way-                -- round, because body_uds_without_me may bind-                -- dictionaries that are used in calls_for_me passed-                -- to specDefn.  So the dictionary bindings in-                -- spec_uds may mention dictionaries bound in-                -- body_uds_without_me------------------------------specCalls :: Maybe Module      -- Just this_mod  =>  specialising imported fn-                               -- Nothing        =>  specialising local fn-          -> SpecEnv-          -> [CoreRule]        -- Existing RULES for the fn-          -> [CallInfo]-          -> OutId -> InExpr-          -> SpecM SpecInfo    -- New rules, specialised bindings, and usage details---- This function checks existing rules, and does not create--- duplicate ones. So the caller does not need to do this filtering.--- See 'already_covered'--type SpecInfo = ( [CoreRule]       -- Specialisation rules-                , [(Id,CoreExpr)]  -- Specialised definition-                , UsageDetails )   -- Usage details from specialised RHSs--specCalls mb_mod env existing_rules calls_for_me fn rhs-        -- The first case is the interesting one-  |  callSpecArity pis <= fn_arity      -- See Note [Specialisation Must Preserve Sharing]-  && notNull calls_for_me               -- And there are some calls to specialise-  && not (isNeverActive (idInlineActivation fn))-        -- Don't specialise NOINLINE things-        -- See Note [Auto-specialisation and RULES]----   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small---      See Note [Inline specialisation] for why we do not---      switch off specialisation for inline functions--  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $-    foldlM spec_call ([], [], emptyUDs) calls_for_me--  | otherwise   -- No calls or RHS doesn't fit our preconceptions-  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,-          text "Missed specialisation opportunity for"-                                 <+> ppr fn $$ _trace_doc )-          -- Note [Specialisation shape]-    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $-    return ([], [], emptyUDs)-  where-    _trace_doc = sep [ ppr rhs_tyvars, ppr rhs_bndrs-                     , ppr (idInlineActivation fn) ]--    fn_type                 = idType fn-    fn_arity                = idArity fn-    fn_unf                  = realIdUnfolding fn  -- Ignore loop-breaker-ness here-    pis                     = fst $ splitPiTys fn_type-    theta                   = getTheta pis-    n_dicts                 = length theta-    inl_prag                = idInlinePragma fn-    inl_act                 = inlinePragmaActivation inl_prag-    is_local                = isLocalId fn--        -- Figure out whether the function has an INLINE pragma-        -- See Note [Inline specialisations]--    (rhs_bndrs, rhs_body)      = collectBindersPushingCo rhs-                                 -- See Note [Account for casts in binding]-    rhs_tyvars = filter isTyVar rhs_bndrs--    in_scope = GHC.Core.Subst.substInScope (se_subst env)--    already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool-    already_covered dflags new_rules args      -- Note [Specialisations already covered]-       = isJust (lookupRule dflags (in_scope, realIdUnfolding)-                            (const True) fn args-                            (new_rules ++ existing_rules))-         -- NB: we look both in the new_rules (generated by this invocation-         --     of specCalls), and in existing_rules (passed in to specCalls)--    -----------------------------------------------------------        -- Specialise to one particular call pattern-    spec_call :: SpecInfo                         -- Accumulating parameter-              -> CallInfo                         -- Call instance-              -> SpecM SpecInfo-    spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)-              (CI { ci_key = call_args, ci_arity = call_arity })-      = ASSERT(call_arity <= fn_arity)--        -- See Note [Specialising Calls]-        do { (rhs_env2, unused_bndrs, rule_bndrs, rule_args, unspec_bndrs, dx_binds, spec_args)-               <- specHeader env rhs_bndrs $ dropWhileEndLE isUnspecArg call_args-           ; let rhs_body' = mkLams unused_bndrs rhs_body-           ; dflags <- getDynFlags-           ; if already_covered dflags rules_acc rule_args-             then return spec_acc-             else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids-                  --                           , text "rhs_env2" <+> ppr (se_subst rhs_env2)-                  --                           , ppr dx_binds ]) $-                  do-           {    -- Figure out the type of the specialised function-             let body = mkLams unspec_bndrs rhs_body'-                 body_ty = substTy rhs_env2 $ exprType body-                 (lam_extra_args, app_args)     -- See Note [Specialisations Must Be Lifted]-                   | isUnliftedType body_ty     -- C.f. WwLib.mkWorkerArgs-                   , not (isJoinId fn)-                   = ([voidArgId], voidPrimId : unspec_bndrs)-                   | otherwise = ([], unspec_bndrs)-                 join_arity_change = length app_args - length rule_args-                 spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn-                                 = Just (orig_join_arity + join_arity_change)-                                 | otherwise-                                 = Nothing--           ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_extra_args body)-           ; let spec_id_ty = exprType spec_rhs-           ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity-           ; this_mod <- getModule-           ; let-                -- The rule to put in the function's specialisation is:-                --      forall x @b d1' d2'.-                --          f x @T1 @b @T2 d1' d2' = f1 x @b-                -- See Note [Specialising Calls]-                herald = case mb_mod of-                           Nothing        -- Specialising local fn-                               -> text "SPEC"-                           Just this_mod  -- Specialising imported fn-                               -> text "SPEC/" <> ppr this_mod--                rule_name = mkFastString $ showSDoc dflags $-                            herald <+> ftext (occNameFS (getOccName fn))-                                   <+> hsep (mapMaybe ppr_call_key_ty call_args)-                            -- This name ends up in interface files, so use occNameString.-                            -- Otherwise uniques end up there, making builds-                            -- less deterministic (See #4012 comment:61 ff)--                rule_wout_eta = mkRule-                                  this_mod-                                  True {- Auto generated -}-                                  is_local-                                  rule_name-                                  inl_act       -- Note [Auto-specialisation and RULES]-                                  (idName fn)-                                  rule_bndrs-                                  rule_args-                                  (mkVarApps (Var spec_f) app_args)--                spec_rule-                  = case isJoinId_maybe fn of-                      Just join_arity -> etaExpandToJoinPointRule join_arity-                                                                  rule_wout_eta-                      Nothing -> rule_wout_eta--                -- Add the { d1' = dx1; d2' = dx2 } usage stuff-                -- See Note [Specialising Calls]-                spec_uds = foldr consDictBind rhs_uds dx_binds--                ---------------------------------------                -- Add a suitable unfolding if the spec_inl_prag says so-                -- See Note [Inline specialisations]-                (spec_inl_prag, spec_unf)-                  | not is_local && isStrongLoopBreaker (idOccInfo fn)-                  = (neverInlinePragma, noUnfolding)-                        -- See Note [Specialising imported functions] in OccurAnal--                  | InlinePragma { inl_inline = Inlinable } <- inl_prag-                  = (inl_prag { inl_inline = NoUserInline }, noUnfolding)--                  | otherwise-                  = (inl_prag, specUnfolding dflags unspec_bndrs spec_app n_dicts fn_unf)--                spec_app e = e `mkApps` spec_args--                ---------------------------------------                -- Adding arity information just propagates it a bit faster-                --      See Note [Arity decrease] in Simplify-                -- Copy InlinePragma information from the parent Id.-                -- So if f has INLINE[1] so does spec_f-                spec_f_w_arity = spec_f `setIdArity`      max 0 (fn_arity - n_dicts)-                                        `setInlinePragma` spec_inl_prag-                                        `setIdUnfolding`  spec_unf-                                        `asJoinId_maybe`  spec_join_arity--                _rule_trace_doc = vcat [ ppr spec_f, ppr fn_type, ppr spec_id_ty-                                       , ppr rhs_bndrs, ppr call_args-                                       , ppr spec_rule-                                       ]--           ; -- pprTrace "spec_call: rule" _rule_trace_doc-             return ( spec_rule                  : rules_acc-                    , (spec_f_w_arity, spec_rhs) : pairs_acc-                    , spec_uds           `plusUDs` uds_acc-                    ) } }--{- Note [Specialisation Must Preserve Sharing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a function:--    f :: forall a. Eq a => a -> blah-    f =-      if expensive-         then f1-         else f2--As written, all calls to 'f' will share 'expensive'. But if we specialise 'f'-at 'Int', eg:--    $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2)--    RULE "SPEC f"-      forall (d :: Eq Int).-        f Int _ = $sfIntf--We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes!--To avoid this, we only generate specialisations for functions whose arity is-enough to bind all of the arguments we need to specialise.  This ensures our-specialised functions don't do any work before receiving all of their dicts,-and thus avoids the 'f' case above.--Note [Specialisations Must Be Lifted]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a function 'f':--    f = forall a. Eq a => Array# a--used like--    case x of-      True -> ...f @Int dEqInt...-      False -> 0--Naively, we might generate an (expensive) specialisation--    $sfInt :: Array# Int--even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to-the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to-preserve laziness.--Note [Specialising Calls]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have a function:--    f :: Int -> forall a b c. (Foo a, Foo c) => Bar -> Qux-    f = \x -> /\ a b c -> \d1 d2 bar -> rhs--and suppose it is called at:--    f 7 @T1 @T2 @T3 dFooT1 dFooT3 bar--This call is described as a 'CallInfo' whose 'ci_key' is--    [ UnspecArg, SpecType T1, UnspecType, SpecType T3, SpecDict dFooT1-    , SpecDict dFooT3, UnspecArg ]--Why are 'a' and 'c' identified as 'SpecType', while 'b' is 'UnspecType'?-Because we must specialise the function on type variables that appear-free in its *dictionary* arguments; but not on type variables that do not-appear in any dictionaries, i.e. are fully polymorphic.--Because this call has dictionaries applied, we'd like to specialise-the call on any type argument that appears free in those dictionaries.-In this case, those are (a ~ T1, c ~ T3).--As a result, we'd like to generate a function:--    $sf :: Int -> forall b. Bar -> Qux-    $sf = SUBST[a->T1, c->T3, d1->d1', d2->d2'] (\x -> /\ b -> \bar -> rhs)--Note that the substitution is applied to the whole thing.  This is-convenient, but just slightly fragile.  Notably:-  * There had better be no name clashes in a/b/c--We must construct a rewrite rule:--    RULE "SPEC f @T1 _ @T3"-      forall (x :: Int) (@b :: Type) (d1' :: Foo T1) (d2' :: Foo T3).-        f x @T1 @b @T3 d1' d2' = $sf x @b--In the rule, d1' and d2' are just wildcards, not used in the RHS.  Note-additionally that 'bar' isn't captured by this rule --- we bind only-enough etas in order to capture all of the *specialised* arguments.--Finally, we must also construct the usage-details--     { d1' = dx1; d2' = dx2 }--where d1', d2' are cloned versions of d1,d2, with the type substitution-applied.  These auxiliary bindings just avoid duplication of dx1, dx2.--Note [Account for casts in binding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f :: Eq a => a -> IO ()-   {-# INLINABLE f-       StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g-     #-}-   f = ...--In f's stable unfolding we have done some modest simplification which-has pushed the cast to the outside.  (I wonder if this is the Right-Thing, but it's what happens now; see SimplUtils Note [Casts and-lambdas].)  Now that stable unfolding must be specialised, so we want-to push the cast back inside. It would be terrible if the cast-defeated specialisation!  Hence the use of collectBindersPushingCo.--Note [Evidence foralls]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose (#12212) that we are specialising-   f :: forall a b. (Num a, F a ~ F b) => blah-with a=b=Int. Then the RULE will be something like-   RULE forall (d:Num Int) (g :: F Int ~ F Int).-        f Int Int d g = f_spec-But both varToCoreExpr (when constructing the LHS args), and the-simplifier (when simplifying the LHS args), will transform to-   RULE forall (d:Num Int) (g :: F Int ~ F Int).-        f Int Int d <F Int> = f_spec-by replacing g with Refl.  So now 'g' is unbound, which results in a later-crash. So we use Refl right off the bat, and do not forall-quantify 'g':- * varToCoreExpr generates a Refl- * exprsFreeIdsList returns the Ids bound by the args,-   which won't include g--You might wonder if this will match as often, but the simplifier replaces-complicated Refl coercions with Refl pretty aggressively.--Note [Orphans and auto-generated rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we specialise an INLINABLE function, or when we have--fspecialise-aggressively, we auto-generate RULES that are orphans.-We don't want to warn about these, or we'd generate a lot of warnings.-Thus, we only warn about user-specified orphan rules.--Indeed, we don't even treat the module as an orphan module if it has-auto-generated *rule* orphans.  Orphan modules are read every time we-compile, so they are pretty obtrusive and slow down every compilation,-even non-optimised ones.  (Reason: for type class instances it's a-type correctness issue.)  But specialisation rules are strictly for-*optimisation* only so it's fine not to read the interface.--What this means is that a SPEC rules from auto-specialisation in-module M will be used in other modules only if M.hi has been read for-some other reason, which is actually pretty likely.--}--bindAuxiliaryDicts-        :: SpecEnv-        -> [DictId] -> [CoreExpr]   -- Original dict bndrs, and the witnessing expressions-        -> [DictId]                 -- A cloned dict-id for each dict arg-        -> (SpecEnv,                -- Substitute for all orig_dicts-            [DictBind],             -- Auxiliary dict bindings-            [CoreExpr])             -- Witnessing expressions (all trivial)--- Bind any dictionary arguments to fresh names, to preserve sharing-bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })-                   orig_dict_ids call_ds inst_dict_ids-  = (env', dx_binds, spec_dict_args)-  where-    (dx_binds, spec_dict_args) = go call_ds inst_dict_ids-    env' = env { se_subst = subst `GHC.Core.Subst.extendSubstList`-                                     (orig_dict_ids `zip` spec_dict_args)-                                  `GHC.Core.Subst.extendInScopeList` dx_ids-               , se_interesting = interesting `unionVarSet` interesting_dicts }--    dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds]-    interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds-                                 , interestingDict env dx ]-                  -- See Note [Make the new dictionaries interesting]--    go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr])-    go [] _  = ([], [])-    go (dx:dxs) (dx_id:dx_ids)-      | exprIsTrivial dx = (dx_binds,                          dx        : args)-      | otherwise        = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args)-      where-        (dx_binds, args) = go dxs dx_ids-             -- In the first case extend the substitution but not bindings;-             -- in the latter extend the bindings but not the substitution.-             -- For the former, note that we bind the *original* dict in the substitution,-             -- overriding any d->dx_id binding put there by substBndrs-    go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids)--{--Note [Make the new dictionaries interesting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Important!  We're going to substitute dx_id1 for d-and we want it to look "interesting", else we won't gather *any*-consequential calls. E.g.-    f d = ...g d....-If we specialise f for a call (f (dfun dNumInt)), we'll get-a consequent call (g d') with an auxiliary definition-    d' = df dNumInt-We want that consequent call to look interesting---Note [From non-recursive to recursive]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Even in the non-recursive case, if any dict-binds depend on 'fn' we might-have built a recursive knot--      f a d x = <blah>-      MkUD { ud_binds = NonRec d7  (MkD ..f..)-           , ud_calls = ...(f T d7)... }--The we generate--     Rec { fs x = <blah>[T/a, d7/d]-           f a d x = <blah>-               RULE f T _ = fs-           d7 = ...f... }--Here the recursion is only through the RULE.--However we definitely should /not/ make the Rec in this wildly common-case:-      d = ...-      MkUD { ud_binds = NonRec d7 (...d...)-           , ud_calls = ...(f T d7)... }--Here we want simply to add d to the floats, giving-      MkUD { ud_binds = NonRec d (...)-                        NonRec d7 (...d...)-           , ud_calls = ...(f T d7)... }--In general, we need only make this Rec if-  - there are some specialisations (spec_binds non-empty)-  - there are some dict_binds that depend on f (dump_dbs non-empty)--Note [Avoiding loops]-~~~~~~~~~~~~~~~~~~~~~-When specialising /dictionary functions/ we must be very careful to-avoid building loops. Here is an example that bit us badly: #3591--     class Eq a => C a-     instance Eq [a] => C [a]--This translates to-     dfun :: Eq [a] -> C [a]-     dfun a d = MkD a d (meth d)--     d4 :: Eq [T] = <blah>-     d2 ::  C [T] = dfun T d4-     d1 :: Eq [T] = $p1 d2-     d3 ::  C [T] = dfun T d1--None of these definitions is recursive. What happened was that we-generated a specialisation:--     RULE forall d. dfun T d = dT  :: C [T]-     dT = (MkD a d (meth d)) [T/a, d1/d]-        = MkD T d1 (meth d1)--But now we use the RULE on the RHS of d2, to get--    d2 = dT = MkD d1 (meth d1)-    d1 = $p1 d2--and now d1 is bottom!  The problem is that when specialising 'dfun' we-should first dump "below" the binding all floated dictionary bindings-that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be-placed below 'dfun', and thus unavailable to it when specialising-'dfun'.  That in turn means that the call (dfun T d1) must be-discarded.  On the other hand, the call (dfun T d4) is fine, assuming-d4 doesn't mention dfun.--Solution:-  Discard all calls that mention dictionaries that depend-  (directly or indirectly) on the dfun we are specialising.-  This is done by 'filterCalls'-----------------Here's another example, this time for an imported dfun, so the call-to filterCalls is in specImports (#13429). Suppose we have-  class Monoid v => C v a where ...--We start with a call-   f @ [Integer] @ Integer $fC[]Integer--Specialising call to 'f' gives dict bindings-   $dMonoid_1 :: Monoid [Integer]-   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer--   $dC_1 :: C [Integer] (Node [Integer] Integer)-   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1--...plus a recursive call to-   f @ [Integer] @ (Node [Integer] Integer) $dC_1--Specialising that call gives-   $dMonoid_2  :: Monoid [Integer]-   $dMonoid_2  = M.$p1C @ [Integer] $dC_1--   $dC_2 :: C [Integer] (Node [Integer] Integer)-   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2--Now we have two calls to the imported function-  M.$fCvNode :: Monoid v => C v a-  M.$fCvNode @v @a m = C m some_fun--But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)-for specialisation, else we get:--  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1-  $dMonoid_2 = M.$p1C @ [Integer] $dC_1-  $s$fCvNode = C $dMonoid_2 ...-    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode--Now use the rule to rewrite the call in the RHS of $dC_1-and we get a loop!-----------------Here's yet another example--  class C a where { foo,bar :: [a] -> [a] }--  instance C Int where-     foo x = r_bar x-     bar xs = reverse xs--  r_bar :: C a => [a] -> [a]-  r_bar xs = bar (xs ++ xs)--That translates to:--    r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)--    Rec { $fCInt :: C Int = MkC foo_help reverse-          foo_help (xs::[Int]) = r_bar Int $fCInt xs }--The call (r_bar $fCInt) mentions $fCInt,-                        which mentions foo_help,-                        which mentions r_bar-But we DO want to specialise r_bar at Int:--    Rec { $fCInt :: C Int = MkC foo_help reverse-          foo_help (xs::[Int]) = r_bar Int $fCInt xs--          r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)-            RULE r_bar Int _ = r_bar_Int--          r_bar_Int xs = bar Int $fCInt (xs ++ xs)-           }--Note that, because of its RULE, r_bar joins the recursive-group.  (In this case it'll unravel a short moment later.)---Note [Specialising a recursive group]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    let rec { f x = ...g x'...-            ; g y = ...f y'.... }-    in f 'a'-Here we specialise 'f' at Char; but that is very likely to lead to-a specialisation of 'g' at Char.  We must do the latter, else the-whole point of specialisation is lost.--But we do not want to keep iterating to a fixpoint, because in the-presence of polymorphic recursion we might generate an infinite number-of specialisations.--So we use the following heuristic:-  * Arrange the rec block in dependency order, so far as possible-    (the occurrence analyser already does this)--  * Specialise it much like a sequence of lets--  * Then go through the block a second time, feeding call-info from-    the RHSs back in the bottom, as it were--In effect, the ordering maxmimises the effectiveness of each sweep,-and we do just two sweeps.   This should catch almost every case of-monomorphic recursion -- the exception could be a very knotted-up-recursion with multiple cycles tied up together.--This plan is implemented in the Rec case of specBindItself.--Note [Specialisations already covered]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We obviously don't want to generate two specialisations for the same-argument pattern.  There are two wrinkles--1. We do the already-covered test in specDefn, not when we generate-the CallInfo in mkCallUDs.  We used to test in the latter place, but-we now iterate the specialiser somewhat, and the Id at the call site-might therefore not have all the RULES that we can see in specDefn--2. What about two specialisations where the second is an *instance*-of the first?  If the more specific one shows up first, we'll generate-specialisations for both.  If the *less* specific one shows up first,-we *don't* currently generate a specialisation for the more specific-one.  (See the call to lookupRule in already_covered.)  Reasons:-  (a) lookupRule doesn't say which matches are exact (bad reason)-  (b) if the earlier specialisation is user-provided, it's-      far from clear that we should auto-specialise further--Note [Auto-specialisation and RULES]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-   g :: Num a => a -> a-   g = ...--   f :: (Int -> Int) -> Int-   f w = ...-   {-# RULE f g = 0 #-}--Suppose that auto-specialisation makes a specialised version of-g::Int->Int That version won't appear in the LHS of the RULE for f.-So if the specialisation rule fires too early, the rule for f may-never fire.--It might be possible to add new rules, to "complete" the rewrite system.-Thus when adding-        RULE forall d. g Int d = g_spec-also add-        RULE f g_spec = 0--But that's a bit complicated.  For now we ask the programmer's help,-by *copying the INLINE activation pragma* to the auto-specialised-rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule-will also not be active until phase 2.  And that's what programmers-should jolly well do anyway, even aside from specialisation, to ensure-that g doesn't inline too early.--This in turn means that the RULE would never fire for a NOINLINE-thing so not much point in generating a specialisation at all.--Note [Specialisation shape]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We only specialise a function if it has visible top-level lambdas-corresponding to its overloading.  E.g. if-        f :: forall a. Eq a => ....-then its body must look like-        f = /\a. \d. ...--Reason: when specialising the body for a call (f ty dexp), we want to-substitute dexp for d, and pick up specialised calls in the body of f.--This doesn't always work.  One example I came across was this:-        newtype Gen a = MkGen{ unGen :: Int -> a }--        choose :: Eq a => a -> Gen a-        choose n = MkGen (\r -> n)--        oneof = choose (1::Int)--It's a silly example, but we get-        choose = /\a. g `cast` co-where choose doesn't have any dict arguments.  Thus far I have not-tried to fix this (wait till there's a real example).--Mind you, then 'choose' will be inlined (since RHS is trivial) so-it doesn't matter.  This comes up with single-method classes--   class C a where { op :: a -> a }-   instance C a => C [a] where ....-==>-   $fCList :: C a => C [a]-   $fCList = $copList |> (...coercion>...)-   ....(uses of $fCList at particular types)...--So we suppress the WARN if the rhs is trivial.--Note [Inline specialisations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here is what we do with the InlinePragma of the original function-  * Activation/RuleMatchInfo: both transferred to the-                              specialised function-  * InlineSpec:-       (a) An INLINE pragma is transferred-       (b) An INLINABLE pragma is *not* transferred--Why (a): transfer INLINE pragmas? The point of INLINE was precisely to-specialise the function at its call site, and arguably that's not so-important for the specialised copies.  BUT *pragma-directed*-specialisation now takes place in the typechecker/desugarer, with-manually specified INLINEs.  The specialisation here is automatic.-It'd be very odd if a function marked INLINE was specialised (because-of some local use), and then forever after (including importing-modules) the specialised version wasn't INLINEd.  After all, the-programmer said INLINE!--You might wonder why we specialise INLINE functions at all.  After-all they should be inlined, right?  Two reasons:-- * Even INLINE functions are sometimes not inlined, when they aren't-   applied to interesting arguments.  But perhaps the type arguments-   alone are enough to specialise (even though the args are too boring-   to trigger inlining), and it's certainly better to call the-   specialised version.-- * The RHS of an INLINE function might call another overloaded function,-   and we'd like to generate a specialised version of that function too.-   This actually happens a lot. Consider-      replicateM_ :: (Monad m) => Int -> m a -> m ()-      {-# INLINABLE replicateM_ #-}-      replicateM_ d x ma = ...-   The strictness analyser may transform to-      replicateM_ :: (Monad m) => Int -> m a -> m ()-      {-# INLINE replicateM_ #-}-      replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma--      $wreplicateM_ :: (Monad m) => Int# -> m a -> m ()-      {-# INLINABLE $wreplicateM_ #-}-      $wreplicateM_ = ...-   Now an importing module has a specialised call to replicateM_, say-   (replicateM_ dMonadIO).  We certainly want to specialise $wreplicateM_!-   This particular example had a huge effect on the call to replicateM_-   in nofib/shootout/n-body.--Why (b): discard INLINABLE pragmas? See #4874 for persuasive examples.-Suppose we have-    {-# INLINABLE f #-}-    f :: Ord a => [a] -> Int-    f xs = letrec f' = ...f'... in f'-Then, when f is specialised and optimised we might get-    wgo :: [Int] -> Int#-    wgo = ...wgo...-    f_spec :: [Int] -> Int-    f_spec xs = case wgo xs of { r -> I# r }-and we clearly want to inline f_spec at call sites.  But if we still-have the big, un-optimised of f (albeit specialised) captured in an-INLINABLE pragma for f_spec, we won't get that optimisation.--So we simply drop INLINABLE pragmas when specialising. It's not really-a complete solution; ignoring specialisation for now, INLINABLE functions-don't get properly strictness analysed, for example. But it works well-for examples involving specialisation, which is the dominant use of-INLINABLE.  See #4874.---************************************************************************-*                                                                      *-\subsubsection{UsageDetails and suchlike}-*                                                                      *-************************************************************************--}--data UsageDetails-  = MkUD {-      ud_binds :: !(Bag DictBind),-               -- See Note [Floated dictionary bindings]-               -- The order is important;-               -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1-               -- (Remember, Bags preserve order in GHC.)--      ud_calls :: !CallDetails--      -- INVARIANT: suppose bs = bindersOf ud_binds-      -- Then 'calls' may *mention* 'bs',-      -- but there should be no calls *for* bs-    }---- | A 'DictBind' is a binding along with a cached set containing its free--- variables (both type variables and dictionaries)-type DictBind = (CoreBind, VarSet)--{- Note [Floated dictionary bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We float out dictionary bindings for the reasons described under-"Dictionary floating" above.  But not /just/ dictionary bindings.-Consider--   f :: Eq a => blah-   f a d = rhs--   $c== :: T -> T -> Bool-   $c== x y = ...--   $df :: Eq T-   $df = Eq $c== ...--   gurgle = ...(f @T $df)...--We gather the call info for (f @T $df), and we don't want to drop it-when we come across the binding for $df.  So we add $df to the floats-and continue.  But then we have to add $c== to the floats, and so on.-These all float above the binding for 'f', and now we can-successfully specialise 'f'.--So the DictBinds in (ud_binds :: Bag DictBind) may contain-non-dictionary bindings too.--}--instance Outputable UsageDetails where-  ppr (MkUD { ud_binds = dbs, ud_calls = calls })-        = text "MkUD" <+> braces (sep (punctuate comma-                [text "binds" <+> equals <+> ppr dbs,-                 text "calls" <+> equals <+> ppr calls]))--emptyUDs :: UsageDetails-emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }---------------------------------------------------------------type CallDetails  = DIdEnv CallInfoSet-  -- The order of specialized binds and rules depends on how we linearize-  -- CallDetails, so to get determinism we must use a deterministic set here.-  -- See Note [Deterministic UniqFM] in UniqDFM--data CallInfoSet = CIS Id (Bag CallInfo)-  -- The list of types and dictionaries is guaranteed to-  -- match the type of f-  -- The Bag may contain duplicate calls (i.e. f @T and another f @T)-  -- These dups are eliminated by already_covered in specCalls--data CallInfo-  = CI { ci_key  :: [SpecArg]   -- All arguments-       , ci_arity :: Int        -- The number of variables necessary to bind-                                -- all of the specialised arguments-       , ci_fvs  :: VarSet      -- Free vars of the ci_key-                                -- call (including tyvars)-                                -- [*not* include the main id itself, of course]-    }--type DictExpr = CoreExpr--ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet-ciSetFilter p (CIS id a) = CIS id (filterBag p a)--instance Outputable CallInfoSet where-  ppr (CIS fn map) = hang (text "CIS" <+> ppr fn)-                        2 (ppr map)--pprCallInfo :: Id -> CallInfo -> SDoc-pprCallInfo fn (CI { ci_key = key })-  = ppr fn <+> ppr key--ppr_call_key_ty :: SpecArg -> Maybe SDoc-ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty-ppr_call_key_ty UnspecType    = Just $ char '_'-ppr_call_key_ty (SpecDict _)  = Nothing-ppr_call_key_ty UnspecArg     = Nothing--instance Outputable CallInfo where-  ppr (CI { ci_key = key, ci_fvs = fvs })-    = text "CI" <> braces (hsep [ fsep (mapMaybe ppr_call_key_ty key), ppr fvs ])--unionCalls :: CallDetails -> CallDetails -> CallDetails-unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2--unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet-unionCallInfoSet (CIS f calls1) (CIS _ calls2) =-  CIS f (calls1 `unionBags` calls2)--callDetailsFVs :: CallDetails -> VarSet-callDetailsFVs calls =-  nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls-  -- It's OK to use nonDetFoldUDFM here because we forget the ordering-  -- immediately by converting to a nondeterministic set.--callInfoFVs :: CallInfoSet -> VarSet-callInfoFVs (CIS _ call_info) =-  foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info--computeArity :: [SpecArg] -> Int-computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg--callSpecArity :: [TyCoBinder] -> Int-callSpecArity = length . filter (not . isNamedBinder) . dropWhileEndLE isVisibleBinder--getTheta :: [TyCoBinder] -> [PredType]-getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder)----------------------------------------------------------------singleCall :: Id -> [SpecArg] -> UsageDetails-singleCall id args-  = MkUD {ud_binds = emptyBag,-          ud_calls = unitDVarEnv id $ CIS id $-                     unitBag (CI { ci_key  = args -- used to be tys-                                 , ci_arity = computeArity args-                                 , ci_fvs  = call_fvs }) }-  where-    tys      = getSpecTypes args-    dicts    = getSpecDicts args-    call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs-    tys_fvs  = tyCoVarsOfTypes tys-        -- The type args (tys) are guaranteed to be part of the dictionary-        -- types, because they are just the constrained types,-        -- and the dictionary is therefore sure to be bound-        -- inside the binding for any type variables free in the type;-        -- hence it's safe to neglect tyvars free in tys when making-        -- the free-var set for this call-        -- BUT I don't trust this reasoning; play safe and include tys_fvs-        ---        -- We don't include the 'id' itself.--mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails-mkCallUDs env f args-  = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ])-    res-  where-    res = mkCallUDs' env f args--mkCallUDs' env f args-  | not (want_calls_for f)  -- Imported from elsewhere-  || null theta             -- Not overloaded-  = emptyUDs--  |  not (all type_determines_value theta)-  || not (computeArity ci_key <= idArity f)-  || not (length dicts == length theta)-  || not (any (interestingDict env) dicts)    -- Note [Interesting dictionary arguments]-  -- See also Note [Specialisations already covered]-  = -- pprTrace "mkCallUDs: discarding" _trace_doc-    emptyUDs    -- Not overloaded, or no specialisation wanted--  | otherwise-  = -- pprTrace "mkCallUDs: keeping" _trace_doc-    singleCall f ci_key-  where-    _trace_doc = vcat [ppr f, ppr args, ppr (map (interestingDict env) dicts)]-    pis                = fst $ splitPiTys $ idType f-    theta              = getTheta pis-    constrained_tyvars = tyCoVarsOfTypes theta--    ci_key :: [SpecArg]-    ci_key = fmap (\(t, a) ->-      case t of-        Named (binderVar -> tyVar)-          |  tyVar `elemVarSet` constrained_tyvars-          -> case a of-              Type ty -> SpecType ty-              _ -> pprPanic "ci_key" $ ppr a-          |  otherwise-          -> UnspecType-        Anon InvisArg _ -> SpecDict a-        Anon VisArg _ -> UnspecArg-                ) $ zip pis args--    dicts = getSpecDicts ci_key--    want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))-         -- For imported things, we gather call instances if-         -- there is an unfolding that we could in principle specialise-         -- We might still decide not to use it (consulting dflags)-         -- in specImports-         -- Use 'realIdUnfolding' to ignore the loop-breaker flag!--    type_determines_value pred    -- See Note [Type determines value]-        = case classifyPredType pred of-            ClassPred cls _ -> not (isIPClass cls)  -- Superclasses can't be IPs-            EqPred {}       -> True-            IrredPred {}    -> True   -- Things like (D []) where D is a-                                      -- Constraint-ranged family; #7785-            ForAllPred {}   -> True--{--Note [Type determines value]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Only specialise if all overloading is on non-IP *class* params,-because these are the ones whose *type* determines their *value*.  In-parrticular, with implicit params, the type args *don't* say what the-value of the implicit param is!  See #7101--However, consider-         type family D (v::*->*) :: Constraint-         type instance D [] = ()-         f :: D v => v Char -> Int-If we see a call (f "foo"), we'll pass a "dictionary"-  () |> (g :: () ~ D [])-and it's good to specialise f at this dictionary.--So the question is: can an implicit parameter "hide inside" a-type-family constraint like (D a).  Well, no.  We don't allow-        type instance D Maybe = ?x:Int-Hence the IrredPred case in type_determines_value.-See #7785.--Note [Interesting dictionary arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-         \a.\d:Eq a.  let f = ... in ...(f d)...-There really is not much point in specialising f wrt the dictionary d,-because the code for the specialised f is not improved at all, because-d is lambda-bound.  We simply get junk specialisations.--What is "interesting"?  Just that it has *some* structure.  But what about-variables?-- * A variable might be imported, in which case its unfolding-   will tell us whether it has useful structure-- * Local variables are cloned on the way down (to avoid clashes when-   we float dictionaries), and cloning drops the unfolding-   (cloneIdBndr).  Moreover, we make up some new bindings, and it's a-   nuisance to give them unfoldings.  So we keep track of the-   "interesting" dictionaries as a VarSet in SpecEnv.-   We have to take care to put any new interesting dictionary-   bindings in the set.--We accidentally lost accurate tracking of local variables for a long-time, because cloned variables don't have unfoldings. But makes a-massive difference in a few cases, eg #5113. For nofib as a-whole it's only a small win: 2.2% improvement in allocation for ansi,-1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.--}--interestingDict :: SpecEnv -> CoreExpr -> Bool--- A dictionary argument is interesting if it has *some* structure--- NB: "dictionary" arguments include constraints of all sorts,---     including equality constraints; hence the Coercion case-interestingDict env (Var v) =  hasSomeUnfolding (idUnfolding v)-                            || isDataConWorkId v-                            || v `elemVarSet` se_interesting env-interestingDict _ (Type _)                = False-interestingDict _ (Coercion _)            = False-interestingDict env (App fn (Type _))     = interestingDict env fn-interestingDict env (App fn (Coercion _)) = interestingDict env fn-interestingDict env (Tick _ a)            = interestingDict env a-interestingDict env (Cast e _)            = interestingDict env e-interestingDict _ _                       = True--plusUDs :: UsageDetails -> UsageDetails -> UsageDetails-plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})-        (MkUD {ud_binds = db2, ud_calls = calls2})-  = MkUD { ud_binds = db1    `unionBags`   db2-         , ud_calls = calls1 `unionCalls`  calls2 }--------------------------------_dictBindBndrs :: Bag DictBind -> [Id]-_dictBindBndrs dbs = foldr ((++) . bindersOf . fst) [] dbs---- | Construct a 'DictBind' from a 'CoreBind'-mkDB :: CoreBind -> DictBind-mkDB bind = (bind, bind_fvs bind)---- | Identify the free variables of a 'CoreBind'-bind_fvs :: CoreBind -> VarSet-bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)-bind_fvs (Rec prs)         = foldl' delVarSet rhs_fvs bndrs-                           where-                             bndrs = map fst prs-                             rhs_fvs = unionVarSets (map pair_fvs prs)--pair_fvs :: (Id, CoreExpr) -> VarSet-pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs-                       `unionVarSet` idFreeVars bndr-        -- idFreeVars: don't forget variables mentioned in-        -- the rules of the bndr.  C.f. OccAnal.addRuleUsage-        -- Also tyvars mentioned in its type; they may not appear-        -- in the RHS-        --      type T a = Int-        --      x :: T a = 3-  where-    interesting :: InterestingVarFun-    interesting v = isLocalVar v || (isId v && isDFunId v)-        -- Very important: include DFunIds /even/ if it is imported-        -- Reason: See Note [Avoiding loops], the second example-        --         involving an imported dfun.  We must know whether-        --         a dictionary binding depends on an imported dfun,-        --         in case we try to specialise that imported dfun-        --         #13429 illustrates---- | Flatten a set of "dumped" 'DictBind's, and some other binding--- pairs, into a single recursive binding.-recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind-recWithDumpedDicts pairs dbs-  = (Rec bindings, fvs)-  where-    (bindings, fvs) = foldr add-                               ([], emptyVarSet)-                               (dbs `snocBag` mkDB (Rec pairs))-    add (NonRec b r, fvs') (pairs, fvs) =-      ((b,r) : pairs, fvs `unionVarSet` fvs')-    add (Rec prs1,   fvs') (pairs, fvs) =-      (prs1 ++ pairs, fvs `unionVarSet` fvs')--snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails--- Add ud_binds to the tail end of the bindings in uds-snocDictBinds uds dbs-  = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs }--consDictBind :: DictBind -> UsageDetails -> UsageDetails-consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds }--addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails-addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }--snocDictBind :: UsageDetails -> DictBind -> UsageDetails-snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }--wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]-wrapDictBinds dbs binds-  = foldr add binds dbs-  where-    add (bind,_) binds = bind : binds--wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr-wrapDictBindsE dbs expr-  = foldr add expr dbs-  where-    add (bind,_) expr = Let bind expr-------------------------dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)--- Used at a lambda or case binder; just dump anything mentioning the binder-dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })-  | null bndrs = (uds, emptyBag)  -- Common in case alternatives-  | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $-                 (free_uds, dump_dbs)-  where-    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }-    bndr_set = mkVarSet bndrs-    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set-    free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor-                 deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be-                                                    -- no calls for any of the dicts in dump_dbs--dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)--- Used at a let(rec) binding.--- We return a boolean indicating whether the binding itself is mentioned,--- directly or indirectly, by any of the ud_calls; in that case we want to--- float the binding itself;--- See Note [Floated dictionary bindings]-dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })-  = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $-    (free_uds, dump_dbs, float_all)-  where-    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }-    bndr_set = mkVarSet bndrs-    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set-    free_calls = deleteCallsFor bndrs orig_calls-    float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls--callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])-callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })-  = -- pprTrace ("callsForMe")-    --          (vcat [ppr fn,-    --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),-    --                 text "Orig calls ="   <+> ppr orig_calls,-    --                 text "Dep set ="      <+> ppr dep_set,-    --                 text "Calls for me =" <+> ppr calls_for_me]) $-    (uds_without_me, calls_for_me)-  where-    uds_without_me = MkUD { ud_binds = orig_dbs-                          , ud_calls = delDVarEnv orig_calls fn }-    calls_for_me = case lookupDVarEnv orig_calls fn of-                        Nothing -> []-                        Just cis -> filterCalls cis orig_dbs-         -- filterCalls: drop calls that (directly or indirectly)-         -- refer to fn.  See Note [Avoiding loops]-------------------------filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]--- See Note [Avoiding loops]-filterCalls (CIS fn call_bag) dbs-  = filter ok_call (bagToList call_bag)-  where-    dump_set = foldl' go (unitVarSet fn) dbs-      -- This dump-set could also be computed by splitDictBinds-      --   (_,_,dump_set) = splitDictBinds dbs {fn}-      -- But this variant is shorter--    go so_far (db,fvs) | fvs `intersectsVarSet` so_far-                       = extendVarSetList so_far (bindersOf db)-                       | otherwise = so_far--    ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set)-------------------------splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)--- splitDictBinds dbs bndrs returns---   (free_dbs, dump_dbs, dump_set)--- where---   * dump_dbs depends, transitively on bndrs---   * free_dbs does not depend on bndrs---   * dump_set = bndrs `union` bndrs(dump_dbs)-splitDictBinds dbs bndr_set-   = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs-                -- Important that it's foldl' not foldr;-                -- we're accumulating the set of dumped ids in dump_set-   where-    split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)-        | dump_idset `intersectsVarSet` fvs     -- Dump it-        = (free_dbs, dump_dbs `snocBag` db,-           extendVarSetList dump_idset (bindersOf bind))--        | otherwise     -- Don't dump it-        = (free_dbs `snocBag` db, dump_dbs, dump_idset)--------------------------deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails--- Remove calls *mentioning* bs in any way-deleteCallsMentioning bs calls-  = mapDVarEnv (ciSetFilter keep_call) calls-  where-    keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs)--deleteCallsFor :: [Id] -> CallDetails -> CallDetails--- Remove calls *for* bs-deleteCallsFor bs calls = delDVarEnvList calls bs--{--************************************************************************-*                                                                      *-\subsubsection{Boring helper functions}-*                                                                      *-************************************************************************--}--newtype SpecM a = SpecM (State SpecState a) deriving (Functor)--data SpecState = SpecState {-                     spec_uniq_supply :: UniqSupply,-                     spec_module :: Module,-                     spec_dflags :: DynFlags-                 }--instance Applicative SpecM where-    pure x = SpecM $ return x-    (<*>) = ap--instance Monad SpecM where-    SpecM x >>= f = SpecM $ do y <- x-                               case f y of-                                   SpecM z ->-                                       z-#if !MIN_VERSION_base(4,13,0)-    fail = MonadFail.fail-#endif--instance MonadFail.MonadFail SpecM where-   fail str = SpecM $ error str--instance MonadUnique SpecM where-    getUniqueSupplyM-        = SpecM $ do st <- get-                     let (us1, us2) = splitUniqSupply $ spec_uniq_supply st-                     put $ st { spec_uniq_supply = us2 }-                     return us1--    getUniqueM-        = SpecM $ do st <- get-                     let (u,us') = takeUniqFromSupply $ spec_uniq_supply st-                     put $ st { spec_uniq_supply = us' }-                     return u--instance HasDynFlags SpecM where-    getDynFlags = SpecM $ liftM spec_dflags get--instance HasModule SpecM where-    getModule = SpecM $ liftM spec_module get--runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a-runSpecM dflags this_mod (SpecM spec)-    = do us <- getUniqueSupplyM-         let initialState = SpecState {-                                spec_uniq_supply = us,-                                spec_module = this_mod,-                                spec_dflags = dflags-                            }-         return $ evalState spec initialState--mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)-mapAndCombineSM _ []     = return ([], emptyUDs)-mapAndCombineSM f (x:xs) = do (y, uds1) <- f x-                              (ys, uds2) <- mapAndCombineSM f xs-                              return (y:ys, uds1 `plusUDs` uds2)--extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv-extendTvSubstList env tv_binds-  = env { se_subst = GHC.Core.Subst.extendTvSubstList (se_subst env) tv_binds }--substTy :: SpecEnv -> Type -> Type-substTy env ty = GHC.Core.Subst.substTy (se_subst env) ty--substCo :: SpecEnv -> Coercion -> Coercion-substCo env co = GHC.Core.Subst.substCo (se_subst env) co--substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)-substBndr env bs = case GHC.Core.Subst.substBndr (se_subst env) bs of-                      (subst', bs') -> (env { se_subst = subst' }, bs')--substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])-substBndrs env bs = case GHC.Core.Subst.substBndrs (se_subst env) bs of-                      (subst', bs') -> (env { se_subst = subst' }, bs')--cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)--- Clone the binders of the bind; return new bind with the cloned binders--- Return the substitution to use for RHSs, and the one to use for the body-cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs)-  = do { us <- getUniqueSupplyM-       ; let (subst', bndr') = GHC.Core.Subst.cloneIdBndr subst us bndr-             interesting' | interestingDict env rhs-                          = interesting `extendVarSet` bndr'-                          | otherwise = interesting-       ; return (env, env { se_subst = subst', se_interesting = interesting' }-                , NonRec bndr' rhs) }--cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs)-  = do { us <- getUniqueSupplyM-       ; let (subst', bndrs') = GHC.Core.Subst.cloneRecIdBndrs subst us (map fst pairs)-             env' = env { se_subst = subst'-                        , se_interesting = interesting `extendVarSetList`-                                           [ v | (v,r) <- pairs, interestingDict env r ] }-       ; return (env', env', Rec (bndrs' `zip` map snd pairs)) }--newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr--- Make up completely fresh binders for the dictionaries--- Their bindings are going to float outwards-newDictBndr env b = do { uniq <- getUniqueM-                       ; let n   = idName b-                             ty' = substTy env (idType b)-                       ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }--newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id-    -- Give the new Id a similar occurrence name to the old one-newSpecIdSM old_id new_ty join_arity_maybe-  = do  { uniq <- getUniqueM-        ; let name    = idName old_id-              new_occ = mkSpecOcc (nameOccName name)-              new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)-                          `asJoinId_maybe` join_arity_maybe-        ; return new_id }--{--                Old (but interesting) stuff about unboxed bindings-                ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--What should we do when a value is specialised to a *strict* unboxed value?--        map_*_* f (x:xs) = let h = f x-                               t = map f xs-                           in h:t--Could convert let to case:--        map_*_Int# f (x:xs) = case f x of h# ->-                              let t = map f xs-                              in h#:t--This may be undesirable since it forces evaluation here, but the value-may not be used in all branches of the body. In the general case this-transformation is impossible since the mutual recursion in a letrec-cannot be expressed as a case.--There is also a problem with top-level unboxed values, since our-implementation cannot handle unboxed values at the top level.--Solution: Lift the binding of the unboxed value and extract it when it-is used:--        map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#-                                  t = map f xs-                              in case h of-                                 _Lift h# -> h#:t--Now give it to the simplifier and the _Lifting will be optimised away.--The benefit is that we have given the specialised "unboxed" values a-very simple lifted semantics and then leave it up to the simplifier to-optimise it --- knowing that the overheads will be removed in nearly-all cases.--In particular, the value will only be evaluated in the branches of the-program which use it, rather than being forced at the point where the-value is bound. For example:--        filtermap_*_* p f (x:xs)-          = let h = f x-                t = ...-            in case p x of-                True  -> h:t-                False -> t-   ==>-        filtermap_*_Int# p f (x:xs)-          = let h = case (f x) of h# -> _Lift h#-                t = ...-            in case p x of-                True  -> case h of _Lift h#-                           -> h#:t-                False -> t--The binding for h can still be inlined in the one branch and the-_Lifting eliminated.---Question: When won't the _Lifting be eliminated?--Answer: When they at the top-level (where it is necessary) or when-inlining would duplicate work (or possibly code depending on-options). However, the _Lifting will still be eliminated if the-strictness analyser deems the lifted binding strict.--}
− compiler/stranal/CprAnal.hs 
@@ -1,669 +0,0 @@-{-# LANGUAGE CPP #-}---- | Constructed Product Result analysis. Identifies functions that surely--- return heap-allocated records on every code path, so that we can eliminate--- said heap allocation by performing a worker/wrapper split.------ See https://www.microsoft.com/en-us/research/publication/constructed-product-result-analysis-haskell/.--- CPR analysis should happen after strictness analysis.--- See Note [Phase ordering].-module CprAnal ( cprAnalProgram ) where--#include "HsVersions.h"--import GhcPrelude--import WwLib            ( deepSplitProductType_maybe )-import GHC.Driver.Session-import Demand-import Cpr-import GHC.Core-import GHC.Core.Seq-import Outputable-import VarEnv-import BasicTypes-import Data.List-import DataCon-import Id-import IdInfo-import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram )-import TyCon-import Type-import FamInstEnv-import Util-import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) )-import Maybes           ( isJust, isNothing )--{- Note [Constructed Product Result]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The goal of Constructed Product Result analysis is to identify functions that-surely return heap-allocated records on every code path, so that we can-eliminate said heap allocation by performing a worker/wrapper split.--@swap@ below is such a function:--  swap (a, b) = (b, a)--A @case@ on an application of @swap@, like-@case swap (10, 42) of (a, b) -> a + b@ could cancel away-(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then-say that @swap@ has the CPR property.--We can't inline recursive functions, but similar reasoning applies there:--  f x n = case n of-    0 -> (x, 0)-    _ -> f (x+1) (n-1)--Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed-product with the case. So @f@, too, has the CPR property. But we can't really-"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@-might be too big to inline (or even marked NOINLINE). We still want to exploit-the CPR property, and that is exactly what the worker/wrapper transformation-can do for us:--  $wf x n = case n of-    0 -> case (x, 0) of -> (a, b) -> (# a, b #)-    _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #)-  f x n = case $wf x n of (# a, b #) -> (a, b)--where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to:--  $wf x n = case n of-    0 -> (# x, 0 #)-    _ -> $wf (x+1) (n-1)--Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and-eliminate the heap-allocated pair constructor.--Note [Phase ordering]-~~~~~~~~~~~~~~~~~~~~~-We need to perform strictness analysis before CPR analysis, because that might-unbox some arguments, in turn leading to more constructed products.-Ideally, we would want the following pipeline:--1. Strictness-2. worker/wrapper (for strictness)-3. CPR-4. worker/wrapper (for CPR)--Currently, we omit 2. and anticipate the results of worker/wrapper.-See Note [CPR in a DataAlt case alternative] and Note [CPR for strict binders].-An additional w/w pass would simplify things, but probably add slight overhead.-So currently we have--1. Strictness-2. CPR-3. worker/wrapper (for strictness and CPR)--}------- * Analysing programs-----cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram-cprAnalProgram dflags fam_envs binds = do-  let env            = emptyAnalEnv fam_envs-  let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds-  dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $-    dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr-  -- See Note [Stamp out space leaks in demand analysis] in DmdAnal-  seqBinds binds_plus_cpr `seq` return binds_plus_cpr---- Analyse a (group of) top-level binding(s)-cprAnalTopBind :: AnalEnv-               -> CoreBind-               -> (AnalEnv, CoreBind)-cprAnalTopBind env (NonRec id rhs)-  = (extendAnalEnv env id' (idCprInfo id'), NonRec id' rhs')-  where-    (id', rhs') = cprAnalBind TopLevel env id rhs--cprAnalTopBind env (Rec pairs)-  = (env', Rec pairs')-  where-    (env', pairs') = cprFix TopLevel env pairs------- * Analysing expressions------- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from--- "Constructed Product Result Analysis for Haskell"-cprAnal, cprAnal'-  :: AnalEnv-  -> CoreExpr            -- ^ expression to be denoted by a 'CprType'-  -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType'--cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $-                  cprAnal' env e--cprAnal' _ (Lit lit)     = (topCprType, Lit lit)-cprAnal' _ (Type ty)     = (topCprType, Type ty)      -- Doesn't happen, in fact-cprAnal' _ (Coercion co) = (topCprType, Coercion co)--cprAnal' env (Var var)   = (cprTransform env var, Var var)--cprAnal' env (Cast e co)-  = (cpr_ty, Cast e' co)-  where-    (cpr_ty, e') = cprAnal env e--cprAnal' env (Tick t e)-  = (cpr_ty, Tick t e')-  where-    (cpr_ty, e') = cprAnal env e--cprAnal' env (App fun (Type ty))-  = (fun_ty, App fun' (Type ty))-  where-    (fun_ty, fun') = cprAnal env fun--cprAnal' env (App fun arg)-  = (res_ty, App fun' arg')-  where-    (fun_ty, fun') = cprAnal env fun-    -- In contrast to DmdAnal, there is no useful (non-nested) CPR info to be-    -- had by looking into the CprType of arg.-    (_, arg')      = cprAnal env arg-    res_ty         = applyCprTy fun_ty--cprAnal' env (Lam var body)-  | isTyVar var-  , (body_ty, body') <- cprAnal env body-  = (body_ty, Lam var body')-  | otherwise-  = (lam_ty, Lam var body')-  where-    env'             = extendSigsWithLam env var-    (body_ty, body') = cprAnal env' body-    lam_ty           = abstractCprTy body_ty--cprAnal' env (Case scrut case_bndr ty alts)-  = (res_ty, Case scrut' case_bndr ty alts')-  where-    (_, scrut')      = cprAnal env scrut-    -- Regardless whether scrut had the CPR property or not, the case binder-    -- certainly has it. See 'extendEnvForDataAlt'.-    (alt_tys, alts') = mapAndUnzip (cprAnalAlt env scrut case_bndr) alts-    res_ty           = foldl' lubCprType botCprType alt_tys--cprAnal' env (Let (NonRec id rhs) body)-  = (body_ty, Let (NonRec id' rhs') body')-  where-    (id', rhs')      = cprAnalBind NotTopLevel env id rhs-    env'             = extendAnalEnv env id' (idCprInfo id')-    (body_ty, body') = cprAnal env' body--cprAnal' env (Let (Rec pairs) body)-  = body_ty `seq` (body_ty, Let (Rec pairs') body')-  where-    (env', pairs')   = cprFix NotTopLevel env pairs-    (body_ty, body') = cprAnal env' body--cprAnalAlt-  :: AnalEnv-  -> CoreExpr -- ^ scrutinee-  -> Id       -- ^ case binder-  -> Alt Var  -- ^ current alternative-  -> (CprType, Alt Var)-cprAnalAlt env scrut case_bndr (con@(DataAlt dc),bndrs,rhs)-  -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative]-  = (rhs_ty, (con, bndrs, rhs'))-  where-    env_alt        = extendEnvForDataAlt env scrut case_bndr dc bndrs-    (rhs_ty, rhs') = cprAnal env_alt rhs-cprAnalAlt env _ _ (con,bndrs,rhs)-  = (rhs_ty, (con, bndrs, rhs'))-  where-    (rhs_ty, rhs') = cprAnal env rhs------- * CPR transformer-----cprTransform :: AnalEnv         -- ^ The analysis environment-             -> Id              -- ^ The function-             -> CprType         -- ^ The demand type of the function-cprTransform env id-  = -- pprTrace "cprTransform" (vcat [ppr id, ppr sig])-    sig-  where-    sig-      | isGlobalId id                   -- imported function or data con worker-      = getCprSig (idCprInfo id)-      | Just sig <- lookupSigEnv env id -- local let-bound-      = getCprSig sig-      | otherwise-      = topCprType------- * Bindings------- Recursive bindings-cprFix :: TopLevelFlag-       -> AnalEnv                            -- Does not include bindings for this binding-       -> [(Id,CoreExpr)]-       -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info--cprFix top_lvl env orig_pairs-  = loop 1 initial_pairs-  where-    bot_sig = mkCprSig 0 botCpr-    -- See Note [Initialising strictness] in DmdAnal.hs-    initial_pairs | ae_virgin env = [(setIdCprInfo id bot_sig, rhs) | (id, rhs) <- orig_pairs ]-                  | otherwise     = orig_pairs--    -- The fixed-point varies the idCprInfo field of the binders, and terminates if that-    -- annotation does not change any more.-    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])-    loop n pairs-      | found_fixpoint = (final_anal_env, pairs')-      | otherwise      = loop (n+1) pairs'-      where-        found_fixpoint    = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs-        first_round       = n == 1-        pairs'            = step first_round pairs-        final_anal_env    = extendAnalEnvs env (map fst pairs')--    step :: Bool -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]-    step first_round pairs = pairs'-      where-        -- In all but the first iteration, delete the virgin flag-        start_env | first_round = env-                  | otherwise   = nonVirgin env--        start = extendAnalEnvs start_env (map fst pairs)--        (_, pairs') = mapAccumL my_downRhs start pairs--        my_downRhs env (id,rhs)-          = (env', (id', rhs'))-          where-            (id', rhs') = cprAnalBind top_lvl env id rhs-            env'        = extendAnalEnv env id (idCprInfo id')---- | Process the RHS of the binding for a sensible arity, add the CPR signature--- to the Id, and augment the environment with the signature as well.-cprAnalBind-  :: TopLevelFlag-  -> AnalEnv-  -> Id-  -> CoreExpr-  -> (Id, CoreExpr)-cprAnalBind top_lvl env id rhs-  = (id', rhs')-  where-    (rhs_ty, rhs')  = cprAnal env rhs-    -- possibly trim thunk CPR info-    rhs_ty'-      -- See Note [CPR for thunks]-      | stays_thunk = trimCprTy rhs_ty-      -- See Note [CPR for sum types]-      | returns_sum = trimCprTy rhs_ty-      | otherwise   = rhs_ty-    -- See Note [Arity trimming for CPR signatures]-    sig             = mkCprSigForArity (idArity id) rhs_ty'-    id'             = setIdCprInfo id sig--    -- See Note [CPR for thunks]-    stays_thunk = is_thunk && not_strict-    is_thunk    = not (exprIsHNF rhs) && not (isJoinId id)-    not_strict  = not (isStrictDmd (idDemandInfo id))-    -- See Note [CPR for sum types]-    (_, ret_ty) = splitPiTys (idType id)-    not_a_prod  = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty)-    returns_sum = not (isTopLevel top_lvl) && not_a_prod--{- Note [Arity trimming for CPR signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Although it doesn't affect correctness of the analysis per se, we have to trim-CPR signatures to idArity. Here's what might happen if we don't:--  f x = if expensive-          then \y. Box y-          else \z. Box z-  g a b = f a b--The two lambdas will have a CPR type of @1m@ (so construct a product after-applied to one argument). Thus, @f@ will have a CPR signature of @2m@-(constructs a product after applied to two arguments).-But WW will never eta-expand @f@! In this case that would amount to possibly-duplicating @expensive@ work.--(Side note: Even if @f@'s 'idArity' happened to be 2, it would not do so, see-Note [Don't eta expand in w/w].)--So @f@ will not be worker/wrappered. But @g@ also inherited its CPR signature-from @f@'s, so it *will* be WW'd:--  f x = if expensive-          then \y. Box y-          else \z. Box z-  $wg a b = case f a b of Box x -> x-  g a b = Box ($wg a b)--And the case in @g@ can never cancel away, thus we introduced extra reboxing.-Hence we always trim the CPR signature of a binding to idArity.--}--data AnalEnv-  = AE-  { ae_sigs   :: SigEnv-  -- ^ Current approximation of signatures for local ids-  , ae_virgin :: Bool-  -- ^ True only on every first iteration in a fixed-point-  -- iteration. See Note [Initialising strictness] in "DmdAnal"-  , ae_fam_envs :: FamInstEnvs-  -- ^ Needed when expanding type families and synonyms of product types.-  }--type SigEnv = VarEnv CprSig--instance Outputable AnalEnv where-  ppr (AE { ae_sigs = env, ae_virgin = virgin })-    = text "AE" <+> braces (vcat-         [ text "ae_virgin =" <+> ppr virgin-         , text "ae_sigs =" <+> ppr env ])--emptyAnalEnv :: FamInstEnvs -> AnalEnv-emptyAnalEnv fam_envs-  = AE-  { ae_sigs = emptyVarEnv-  , ae_virgin = True-  , ae_fam_envs = fam_envs-  }---- | Extend an environment with the strictness IDs attached to the id-extendAnalEnvs :: AnalEnv -> [Id] -> AnalEnv-extendAnalEnvs env ids-  = env { ae_sigs = sigs' }-  where-    sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ]--extendAnalEnv :: AnalEnv -> Id -> CprSig -> AnalEnv-extendAnalEnv env id sig-  = env { ae_sigs = extendVarEnv (ae_sigs env) id sig }--lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig-lookupSigEnv env id = lookupVarEnv (ae_sigs env) id--nonVirgin :: AnalEnv -> AnalEnv-nonVirgin env = env { ae_virgin = False }--extendSigsWithLam :: AnalEnv -> Id -> AnalEnv--- Extend the AnalEnv when we meet a lambda binder-extendSigsWithLam env id-  | isId id-  , isStrictDmd (idDemandInfo id) -- See Note [CPR for strict binders]-  , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id-  = extendAnalEnv env id (CprSig (conCprType (dataConTag dc)))-  | otherwise-  = env--extendEnvForDataAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv--- See Note [CPR in a DataAlt case alternative]-extendEnvForDataAlt env scrut case_bndr dc bndrs-  = foldl' do_con_arg env' ids_w_strs-  where-    env' = extendAnalEnv env case_bndr (CprSig case_bndr_ty)--    ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc--    tycon          = dataConTyCon dc-    is_product     = isJust (isDataProductTyCon_maybe tycon)-    is_sum         = isJust (isDataSumTyCon_maybe tycon)-    case_bndr_ty-      | is_product || is_sum = conCprType  (dataConTag dc)-      -- Any of the constructors had existentials. This is a little too-      -- conservative (after all, we only care about the particular data con),-      -- but there is no easy way to write is_sum and this won't happen much.-      | otherwise            = topCprType--    -- We could have much deeper CPR info here with Nested CPR, which could-    -- propagate available unboxed things from the scrutinee, getting rid of-    -- the is_var_scrut heuristic. See Note [CPR in a DataAlt case alternative].-    -- Giving strict binders the CPR property only makes sense for products, as-    -- the arguments in Note [CPR for strict binders] don't apply to sums (yet);-    -- we lack WW for strict binders of sum type.-    do_con_arg env (id, str)-       | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str-       , is_var_scrut && is_strict-       , let fam_envs = ae_fam_envs env-       , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id-       = extendAnalEnv env id (CprSig (conCprType (dataConTag dc)))-       | otherwise-       = env--    is_var_scrut = is_var scrut-    is_var (Cast e _) = is_var e-    is_var (Var v)    = isLocalId v-    is_var _          = False--{- Note [Safe abortion in the fixed-point iteration]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Fixed-point iteration may fail to terminate. But we cannot simply give up and-return the environment and code unchanged! We still need to do one additional-round, to ensure that all expressions have been traversed at least once, and any-unsound CPR annotations have been updated.--Note [CPR in a DataAlt case alternative]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In a case alternative, we want to give some of the binders the CPR property.-Specifically-- * The case binder; inside the alternative, the case binder always has-   the CPR property, meaning that a case on it will successfully cancel.-   Example:-        f True  x = case x of y { I# x' -> if x' ==# 3-                                           then y-                                           else I# 8 }-        f False x = I# 3--   By giving 'y' the CPR property, we ensure that 'f' does too, so we get-        f b x = case fw b x of { r -> I# r }-        fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }-        fw False x = 3--   Of course there is the usual risk of re-boxing: we have 'x' available-   boxed and unboxed, but we return the unboxed version for the wrapper to-   box.  If the wrapper doesn't cancel with its caller, we'll end up-   re-boxing something that we did have available in boxed form.-- * Any strict binders with product type, can use Note [CPR for strict binders]-   to anticipate worker/wrappering for strictness info.-   But we can go a little further. Consider--      data T = MkT !Int Int--      f2 (MkT x y) | y>0       = f2 (MkT x (y-1))-                   | otherwise = x--   For $wf2 we are going to unbox the MkT *and*, since it is strict, the-   first argument of the MkT; see Note [Add demands for strict constructors].-   But then we don't want box it up again when returning it!  We want-   'f2' to have the CPR property, so we give 'x' the CPR property.-- * It's a bit delicate because we're brittly anticipating worker/wrapper here.-   If the case above is scrutinising something other than an argument the-   original function, we really don't have the unboxed version available.  E.g-      g v = case foo v of-              MkT x y | y>0       -> ...-                      | otherwise -> x-   Here we don't have the unboxed 'x' available.  Hence the-   is_var_scrut test when making use of the strictness annotation.-   Slightly ad-hoc, because even if the scrutinee *is* a variable it-   might not be a onre of the arguments to the original function, or a-   sub-component thereof.  But it's simple, and nothing terrible-   happens if we get it wrong.  e.g. Trac #10694.--Note [CPR for strict binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a lambda-bound variable is marked demanded with a strict demand, then give it-a CPR signature, anticipating the results of worker/wrapper. Here's a concrete-example ('f1' in test T10482a), assuming h is strict:--  f1 :: Int -> Int-  f1 x = case h x of-          A -> x-          B -> f1 (x-1)-          C -> x+1--If we notice that 'x' is used strictly, we can give it the CPR-property; and hence f1 gets the CPR property too.  It's sound (doesn't-change strictness) to give it the CPR property because by the time 'x'-is returned (case A above), it'll have been evaluated (by the wrapper-of 'h' in the example).--Moreover, if f itself is strict in x, then we'll pass x unboxed to-f1, and so the boxed version *won't* be available; in that case it's-very helpful to give 'x' the CPR property.--Note that--  * We only want to do this for something that definitely-    has product type, else we may get over-optimistic CPR results-    (e.g. from \x -> x!).--  * See Note [CPR examples]--Note [CPR for sum types]-~~~~~~~~~~~~~~~~~~~~~~~~-At the moment we do not do CPR for let-bindings that-   * non-top level-   * bind a sum type-Reason: I found that in some benchmarks we were losing let-no-escapes,-which messed it all up.  Example-   let j = \x. ....-   in case y of-        True  -> j False-        False -> j True-If we w/w this we get-   let j' = \x. ....-   in case y of-        True  -> case j' False of { (# a #) -> Just a }-        False -> case j' True of { (# a #) -> Just a }-Notice that j' is not a let-no-escape any more.--However this means in turn that the *enclosing* function-may be CPR'd (via the returned Justs).  But in the case of-sums, there may be Nothing alternatives; and that messes-up the sum-type CPR.--Conclusion: only do this for products.  It's still not-guaranteed OK for products, but sums definitely lose sometimes.--Note [CPR for thunks]-~~~~~~~~~~~~~~~~~~~~~-If the rhs is a thunk, we usually forget the CPR info, because-it is presumably shared (else it would have been inlined, and-so we'd lose sharing if w/w'd it into a function).  E.g.--        let r = case expensive of-                  (a,b) -> (b,a)-        in ...--If we marked r as having the CPR property, then we'd w/w into--        let $wr = \() -> case expensive of-                            (a,b) -> (# b, a #)-            r = case $wr () of-                  (# b,a #) -> (b,a)-        in ...--But now r is a thunk, which won't be inlined, so we are no further ahead.-But consider--        f x = let r = case expensive of (a,b) -> (b,a)-              in if foo r then r else (x,x)--Does f have the CPR property?  Well, no.--However, if the strictness analyser has figured out (in a previous-iteration) that it's strict, then we DON'T need to forget the CPR info.-Instead we can retain the CPR info and do the thunk-splitting transform-(see WorkWrap.splitThunk).--This made a big difference to PrelBase.modInt, which had something like-        modInt = \ x -> let r = ... -> I# v in-                        ...body strict in r...-r's RHS isn't a value yet; but modInt returns r in various branches, so-if r doesn't have the CPR property then neither does modInt-Another case I found in practice (in Complex.magnitude), looks like this:-                let k = if ... then I# a else I# b-                in ... body strict in k ....-(For this example, it doesn't matter whether k is returned as part of-the overall result; but it does matter that k's RHS has the CPR property.)-Left to itself, the simplifier will make a join point thus:-                let $j k = ...body strict in k...-                if ... then $j (I# a) else $j (I# b)-With thunk-splitting, we get instead-                let $j x = let k = I#x in ...body strict in k...-                in if ... then $j a else $j b-This is much better; there's a good chance the I# won't get allocated.--But what about botCpr? Consider-    lvl = error "boom"-    fac -1 = lvl-    fac 0 = 1-    fac n = n * fac (n-1)-fac won't have the CPR property here when we trim every thunk! But the-assumption is that error cases are rarely entered and we are diverging anyway,-so WW doesn't hurt.--Note [CPR examples]-~~~~~~~~~~~~~~~~~~~~-Here are some examples (stranal/should_compile/T10482a) of the-usefulness of Note [CPR in a DataAlt case alternative].  The main-point: all of these functions can have the CPR property.--    ------- f1 ------------    -- x is used strictly by h, so it'll be available-    -- unboxed before it is returned in the True branch--    f1 :: Int -> Int-    f1 x = case h x x of-            True  -> x-            False -> f1 (x-1)---    ------- f2 ------------    -- x is a strict field of MkT2, so we'll pass it unboxed-    -- to $wf2, so it's available unboxed.  This depends on-    -- the case expression analysing (a subcomponent of) one-    -- of the original arguments to the function, so it's-    -- a bit more delicate.--    data T2 = MkT2 !Int Int--    f2 :: T2 -> Int-    f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))-                  | otherwise = x---    ------- f3 ------------    -- h is strict in x, so x will be unboxed before it-    -- is rerturned in the otherwise case.--    data T3 = MkT3 Int Int--    f1 :: T3 -> Int-    f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))-                  | otherwise = x---    ------- f4 ------------    -- Just like f2, but MkT4 can't unbox its strict-    -- argument automatically, as f2 can--    data family Foo a-    newtype instance Foo Int = Foo Int--    data T4 a = MkT4 !(Foo a) Int--    f4 :: T4 Int -> Int-    f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))-                          | otherwise = v--}
− compiler/stranal/DmdAnal.hs 
@@ -1,1264 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1993-1998---                        ------------------                        A demand analysis-                        -------------------}--{-# LANGUAGE CPP #-}--module DmdAnal ( dmdAnalProgram ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Driver.Session-import WwLib            ( findTypeShape )-import Demand   -- All of it-import GHC.Core-import GHC.Core.Seq     ( seqBinds )-import Outputable-import VarEnv-import BasicTypes-import Data.List        ( mapAccumL )-import DataCon-import Id-import IdInfo-import GHC.Core.Utils-import TyCon-import Type-import Coercion         ( Coercion, coVarsOfCo )-import FamInstEnv-import Util-import Maybes           ( isJust )-import TysWiredIn-import TysPrim          ( realWorldStatePrimTy )-import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) )-import UniqSet--{--************************************************************************-*                                                                      *-\subsection{Top level stuff}-*                                                                      *-************************************************************************--}--dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram-dmdAnalProgram dflags fam_envs binds = do-  let env             = emptyAnalEnv dflags fam_envs-  let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds-  dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $-    dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds-  -- See Note [Stamp out space leaks in demand analysis]-  seqBinds binds_plus_dmds `seq` return binds_plus_dmds---- Analyse a (group of) top-level binding(s)-dmdAnalTopBind :: AnalEnv-               -> CoreBind-               -> (AnalEnv, CoreBind)-dmdAnalTopBind env (NonRec id rhs)-  = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs')-  where-    ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs--dmdAnalTopBind env (Rec pairs)-  = (env', Rec pairs')-  where-    (env', _, pairs')  = dmdFix TopLevel env cleanEvalDmd pairs-                -- We get two iterations automatically-                -- c.f. the NonRec case above--{- Note [Stamp out space leaks in demand analysis]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The demand analysis pass outputs a new copy of the Core program in-which binders have been annotated with demand and strictness-information. It's tiresome to ensure that this information is fully-evaluated everywhere that we produce it, so we just run a single-seqBinds over the output before returning it, to ensure that there are-no references holding on to the input Core program.--This makes a ~30% reduction in peak memory usage when compiling-DynFlags (cf #9675 and #13426).--This is particularly important when we are doing late demand analysis,-since we don't do a seqBinds at any point thereafter. Hence code-generation would hold on to an extra copy of the Core program, via-unforced thunks in demand or strictness information; and it is the-most memory-intensive part of the compilation process, so this added-seqBinds makes a big difference in peak memory usage.--}---{--************************************************************************-*                                                                      *-\subsection{The analyser itself}-*                                                                      *-************************************************************************--Note [Ensure demand is strict]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important not to analyse e with a lazy demand because-a) When we encounter   case s of (a,b) ->-        we demand s with U(d1d2)... but if the overall demand is lazy-        that is wrong, and we'd need to reduce the demand on s,-        which is inconvenient-b) More important, consider-        f (let x = R in x+x), where f is lazy-   We still want to mark x as demanded, because it will be when we-   enter the let.  If we analyse f's arg with a Lazy demand, we'll-   just mark x as Lazy-c) The application rule wouldn't be right either-   Evaluating (f x) in a L demand does *not* cause-   evaluation of f in a C(L) demand!--}---- If e is complicated enough to become a thunk, its contents will be evaluated--- at most once, so oneify it.-dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand-dmdTransformThunkDmd e-  | exprIsTrivial e = id-  | otherwise       = oneifyDmd---- Do not process absent demands--- Otherwise act like in a normal demand analysis--- See ↦* relation in the Cardinality Analysis paper-dmdAnalStar :: AnalEnv-            -> Demand   -- This one takes a *Demand*-            -> CoreExpr -- Should obey the let/app invariant-            -> (BothDmdArg, CoreExpr)-dmdAnalStar env dmd e-  | (dmd_shell, cd) <- toCleanDmd dmd-  , (dmd_ty, e')    <- dmdAnal env cd e-  = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )-    -- The argument 'e' should satisfy the let/app invariant-    -- See Note [Analysing with absent demand] in Demand.hs-    (postProcessDmdType dmd_shell dmd_ty, e')---- Main Demand Analsysis machinery-dmdAnal, dmdAnal' :: AnalEnv-        -> CleanDemand         -- The main one takes a *CleanDemand*-        -> CoreExpr -> (DmdType, CoreExpr)---- The CleanDemand is always strict and not absent---    See Note [Ensure demand is strict]--dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $-                  dmdAnal' env d e--dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)-dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact-dmdAnal' _ _ (Coercion co)-  = (unitDmdType (coercionDmdEnv co), Coercion co)--dmdAnal' env dmd (Var var)-  = (dmdTransform env var dmd, Var var)--dmdAnal' env dmd (Cast e co)-  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)-  where-    (dmd_ty, e') = dmdAnal env dmd e--dmdAnal' env dmd (Tick t e)-  = (dmd_ty, Tick t e')-  where-    (dmd_ty, e') = dmdAnal env dmd e--dmdAnal' env dmd (App fun (Type ty))-  = (fun_ty, App fun' (Type ty))-  where-    (fun_ty, fun') = dmdAnal env dmd fun---- Lots of the other code is there to make this--- beautiful, compositional, application rule :-)-dmdAnal' env dmd (App fun arg)-  = -- This case handles value arguments (type args handled above)-    -- Crucially, coercions /are/ handled here, because they are-    -- value arguments (#10288)-    let-        call_dmd          = mkCallDmd dmd-        (fun_ty, fun')    = dmdAnal env call_dmd fun-        (arg_dmd, res_ty) = splitDmdTy fun_ty-        (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg-    in---    pprTrace "dmdAnal:app" (vcat---         [ text "dmd =" <+> ppr dmd---         , text "expr =" <+> ppr (App fun arg)---         , text "fun dmd_ty =" <+> ppr fun_ty---         , text "arg dmd =" <+> ppr arg_dmd---         , text "arg dmd_ty =" <+> ppr arg_ty---         , text "res dmd_ty =" <+> ppr res_ty---         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])-    (res_ty `bothDmdType` arg_ty, App fun' arg')--dmdAnal' env dmd (Lam var body)-  | isTyVar var-  = let-        (body_ty, body') = dmdAnal env dmd body-    in-    (body_ty, Lam var body')--  | otherwise-  = let (body_dmd, defer_and_use) = peelCallDmd dmd-          -- body_dmd: a demand to analyze the body--        (body_ty, body') = dmdAnal env body_dmd body-        (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var-    in-    (postProcessUnsat defer_and_use lam_ty, Lam var' body')--dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])-  -- Only one alternative with a product constructor-  | let tycon = dataConTyCon dc-  , isJust (isDataProductTyCon_maybe tycon)-  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon-  = let-        env_alt                  = env { ae_rec_tc = rec_tc' }-        (rhs_ty, rhs')           = dmdAnal env_alt dmd rhs-        (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs-        (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr-        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds-        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2-                | otherwise                   = alt_ty2--        -- Compute demand on the scrutinee-        -- See Note [Demand on scrutinee of a product case]-        scrut_dmd          = mkProdDmd id_dmds-        (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut-        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty-        case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd-        bndrs'             = setBndrsDemandInfo bndrs id_dmds-    in---    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut---                                   , text "dmd" <+> ppr dmd---                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')---                                   , text "id_dmds" <+> ppr id_dmds---                                   , text "scrut_dmd" <+> ppr scrut_dmd---                                   , text "scrut_ty" <+> ppr scrut_ty---                                   , text "alt_ty" <+> ppr alt_ty2---                                   , text "res_ty" <+> ppr res_ty ]) $-    (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])--dmdAnal' env dmd (Case scrut case_bndr ty alts)-  = let      -- Case expression with multiple alternatives-        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts-        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut-        (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr-                               -- NB: Base case is botDmdType, for empty case alternatives-                               --     This is a unit for lubDmdType, and the right result-                               --     when there really are no alternatives-        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty-    in---    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut---                                   , text "scrut_ty" <+> ppr scrut_ty---                                   , text "alt_tys" <+> ppr alt_tys---                                   , text "alt_ty" <+> ppr alt_ty---                                   , text "res_ty" <+> ppr res_ty ]) $-    (res_ty, Case scrut' case_bndr' ty alts')---- Let bindings can be processed in two ways:--- Down (RHS before body) or Up (body before RHS).--- The following case handle the up variant.------ It is very simple. For  let x = rhs in body---   * Demand-analyse 'body' in the current environment---   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'---   * Demand-analyse 'rhs' in 'rhs_dmd'------ This is used for a non-recursive local let without manifest lambdas.--- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.-dmdAnal' env dmd (Let (NonRec id rhs) body)-  | useLetUp id-  = (final_ty, Let (NonRec id' rhs') body')-  where-    (body_ty, body')   = dmdAnal env dmd body-    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id-    id'                = setIdDemandInfo id id_dmd--    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs-    final_ty           = body_ty' `bothDmdType` rhs_ty--dmdAnal' env dmd (Let (NonRec id rhs) body)-  = (body_ty2, Let (NonRec id2 rhs') body')-  where-    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs-    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)-    (body_ty, body')     = dmdAnal env1 dmd body-    (body_ty1, id2)      = annotateBndr env body_ty id1-    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]--        -- If the actual demand is better than the vanilla call-        -- demand, you might think that we might do better to re-analyse-        -- the RHS with the stronger demand.-        -- But (a) That seldom happens, because it means that *every* path in-        --         the body of the let has to use that stronger demand-        -- (b) It often happens temporarily in when fixpointing, because-        --     the recursive function at first seems to place a massive demand.-        --     But we don't want to go to extra work when the function will-        --     probably iterate to something less demanding.-        -- In practice, all the times the actual demand on id2 is more than-        -- the vanilla call demand seem to be due to (b).  So we don't-        -- bother to re-analyse the RHS.--dmdAnal' env dmd (Let (Rec pairs) body)-  = let-        (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs-        (body_ty, body')        = dmdAnal env' dmd body-        body_ty1                = deleteFVs body_ty (map fst pairs)-        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]-    in-    body_ty2 `seq`-    (body_ty2,  Let (Rec pairs') body')--io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool--- See Note [IO hack in the demand analyser]-io_hack_reqd scrut con bndrs-  | (bndr:_) <- bndrs-  , con == tupleDataCon Unboxed 2-  , idType bndr `eqType` realWorldStatePrimTy-  , (fun, _) <- collectArgs scrut-  = case fun of-      Var f -> not (isPrimOpId f)-      _     -> True-  | otherwise-  = False--dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)-dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)-  | null bndrs    -- Literals, DEFAULT, and nullary constructors-  , (rhs_ty, rhs') <- dmdAnal env dmd rhs-  = (rhs_ty, (con, [], rhs'))--  | otherwise     -- Non-nullary data constructors-  , (rhs_ty, rhs') <- dmdAnal env dmd rhs-  , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs-  , let case_bndr_dmd = findIdDemand alt_ty case_bndr-        id_dmds       = addCaseBndrDmd case_bndr_dmd dmds-  = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))---{- Note [IO hack in the demand analyser]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's a hack here for I/O operations.  Consider--     case foo x s of { (# s', r #) -> y }--Is this strict in 'y'? Often not! If foo x s performs some observable action-(including raising an exception with raiseIO#, modifying a mutable variable, or-even ending the program normally), then we must not force 'y' (which may fail-to terminate) until we have performed foo x s.--Hackish solution: spot the IO-like situation and add a virtual branch,-as if we had-     case foo x s of-        (# s, r #) -> y-        other      -> return ()-So the 'y' isn't necessarily going to be evaluated--A more complete example (#148, #1592) where this shows up is:-     do { let len = <expensive> ;-        ; when (...) (exitWith ExitSuccess)-        ; print len }--However, consider-  f x s = case getMaskingState# s of-            (# s, r #) ->-          case x of I# x2 -> ...--Here it is terribly sad to make 'f' lazy in 's'.  After all,-getMaskingState# is not going to diverge or throw an exception!  This-situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle-(on an MVar not an Int), and made a material difference.--So if the scrutinee is a primop call, we *don't* apply the-state hack:-  - If it is a simple, terminating one like getMaskingState,-    applying the hack is over-conservative.-  - If the primop is raise# then it returns bottom, so-    the case alternatives are already discarded.-  - If the primop can raise a non-IO exception, like-    divide by zero or seg-fault (eg writing an array-    out of bounds) then we don't mind evaluating 'x' first.--Note [Demand on the scrutinee of a product case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When figuring out the demand on the scrutinee of a product case,-we use the demands of the case alternative, i.e. id_dmds.-But note that these include the demand on the case binder;-see Note [Demand on case-alternative binders] in Demand.hs.-This is crucial. Example:-   f x = case x of y { (a,b) -> k y a }-If we just take scrut_demand = U(L,A), then we won't pass x to the-worker, so the worker will rebuild-     x = (a, absent-error)-and that'll crash.--Note [Aggregated demand for cardinality]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We use different strategies for strictness and usage/cardinality to-"unleash" demands captured on free variables by bindings. Let us-consider the example:--f1 y = let {-# NOINLINE h #-}-           h = y-       in  (h, h)--We are interested in obtaining cardinality demand U1 on |y|, as it is-used only in a thunk, and, therefore, is not going to be updated any-more. Therefore, the demand on |y|, captured and unleashed by usage of-|h| is U1. However, if we unleash this demand every time |h| is used,-and then sum up the effects, the ultimate demand on |y| will be U1 +-U1 = U. In order to avoid it, we *first* collect the aggregate demand-on |h| in the body of let-expression, and only then apply the demand-transformer:--transf[x](U) = {y |-> U1}--so the resulting demand on |y| is U1.--The situation is, however, different for strictness, where this-aggregating approach exhibits worse results because of the nature of-|both| operation for strictness. Consider the example:--f y c =-  let h x = y |seq| x-   in case of-        True  -> h True-        False -> y--It is clear that |f| is strict in |y|, however, the suggested analysis-will infer from the body of |let| that |h| is used lazily (as it is-used in one branch only), therefore lazy demand will be put on its-free variable |y|. Conversely, if the demand on |h| is unleashed right-on the spot, we will get the desired result, namely, that |f| is-strict in |y|.---************************************************************************-*                                                                      *-                    Demand transformer-*                                                                      *-************************************************************************--}--dmdTransform :: AnalEnv         -- The strictness environment-             -> Id              -- The function-             -> CleanDemand     -- The demand on the function-             -> DmdType         -- The demand type of the function in this context-        -- Returned DmdEnv includes the demand on-        -- this function plus demand on its free variables--dmdTransform env var dmd-  | isDataConWorkId var                          -- Data constructor-  = dmdTransformDataConSig (idArity var) (idStrictness var) dmd--  | gopt Opt_DmdTxDictSel (ae_dflags env),-    Just _ <- isClassOpId_maybe var -- Dictionary component selector-  = dmdTransformDictSelSig (idStrictness var) dmd--  | isGlobalId var                               -- Imported function-  , let res = dmdTransformSig (idStrictness var) dmd-  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])-    res--  | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing-  , let fn_ty = dmdTransformSig sig dmd-  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $-    if isTopLevel top_lvl-    then fn_ty   -- Don't record top level things-    else addVarDmd fn_ty var (mkOnceUsedDmd dmd)--  | otherwise                                    -- Local non-letrec-bound thing-  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))--{--************************************************************************-*                                                                      *-\subsection{Bindings}-*                                                                      *-************************************************************************--}---- Recursive bindings-dmdFix :: TopLevelFlag-       -> AnalEnv                            -- Does not include bindings for this binding-       -> CleanDemand-       -> [(Id,CoreExpr)]-       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info--dmdFix top_lvl env let_dmd orig_pairs-  = loop 1 initial_pairs-  where-    bndrs = map fst orig_pairs--    -- See Note [Initialising strictness]-    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]-                  | otherwise     = orig_pairs--    -- If fixed-point iteration does not yield a result we use this instead-    -- See Note [Safe abortion in the fixed-point iteration]-    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])-    abort = (env, lazy_fv', zapped_pairs)-      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)-            -- Note [Lazy and unleashable free variables]-            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'-            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs-            zapped_pairs = zapIdStrictness pairs'--    -- The fixed-point varies the idStrictness field of the binders, and terminates if that-    -- annotation does not change any more.-    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])-    loop n pairs-      | found_fixpoint = (final_anal_env, lazy_fv, pairs')-      | n == 10        = abort-      | otherwise      = loop (n+1) pairs'-      where-        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs-        first_round       = n == 1-        (lazy_fv, pairs') = step first_round pairs-        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')--    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])-    step first_round pairs = (lazy_fv, pairs')-      where-        -- In all but the first iteration, delete the virgin flag-        start_env | first_round = env-                  | otherwise   = nonVirgin env--        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)--        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs-                -- mapAccumL: Use the new signature to do the next pair-                -- The occurrence analyser has arranged them in a good order-                -- so this can significantly reduce the number of iterations needed--        my_downRhs (env, lazy_fv) (id,rhs)-          = ((env', lazy_fv'), (id', rhs'))-          where-            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs-            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1-            env'                  = extendAnalEnv top_lvl env id (idStrictness id')---    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]-    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]--{--Note [Safe abortion in the fixed-point iteration]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Fixed-point iteration may fail to terminate. But we cannot simply give up and-return the environment and code unchanged! We still need to do one additional-round, for two reasons:-- * To get information on used free variables (both lazy and strict!)-   (see Note [Lazy and unleashable free variables])- * To ensure that all expressions have been traversed at least once, and any left-over-   strictness annotations have been updated.--This final iteration does not add the variables to the strictness signature-environment, which effectively assigns them 'nopSig' (see "getStrictness")---}---- Let bindings can be processed in two ways:--- Down (RHS before body) or Up (body before RHS).--- dmdAnalRhsLetDown implements the Down variant:---  * assuming a demand of <L,U>---  * looking at the definition---  * determining a strictness signature------ It is used for toplevel definition, recursive definitions and local--- non-recursive definitions that have manifest lambdas.--- Local non-recursive definitions without a lambda are handled with LetUp.------ This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.-dmdAnalRhsLetDown-  :: Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive-  -> AnalEnv -> CleanDemand-  -> Id -> CoreExpr-  -> (DmdEnv, Id, CoreExpr)--- Process the RHS of the binding, add the strictness signature--- to the Id, and augment the environment with the signature as well.-dmdAnalRhsLetDown rec_flag env let_dmd id rhs-  = (lazy_fv, id', rhs')-  where-    rhs_arity      = idArity id-    rhs_dmd-      -- See Note [Demand analysis for join points]-      -- See Note [Invariants on join points] invariant 2b, in GHC.Core-      --     rhs_arity matches the join arity of the join point-      | isJoinId id-      = mkCallDmds rhs_arity let_dmd-      | otherwise-      -- NB: rhs_arity-      -- See Note [Demand signatures are computed for a threshold demand based on idArity]-      = mkRhsDmd env rhs_arity rhs-    (DmdType rhs_fv rhs_dmds rhs_div, rhs')-                   = dmdAnal env rhs_dmd rhs-    -- TODO: Won't the following line unnecessarily trim down arity for join-    --       points returning a lambda in a C(S) context?-    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div)-    id'            = set_idStrictness env id sig-        -- See Note [NOINLINE and strictness]---    -- See Note [Aggregated demand for cardinality]-    rhs_fv1 = case rec_flag of-                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)-                Nothing -> rhs_fv--    -- See Note [Lazy and unleashable free variables]-    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1-    is_thunk = not (exprIsHNF rhs) && not (isJoinId id)---- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for--- unleashing on the given function's @rhs@, by creating a call demand of--- @rhs_arity@ with a body demand appropriate for possible product types.--- See Note [Product demands for function body].--- For example, a call of the form @mkRhsDmd _ 2 (\x y -> (x, y))@ returns a--- clean usage demand of @C1(C1(U(U,U)))@.-mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand-mkRhsDmd env rhs_arity rhs =-  case peelTsFuns rhs_arity (findTypeShape (ae_fam_envs env) (exprType rhs)) of-    Just (TsProd tss) -> mkCallDmds rhs_arity (cleanEvalProdDmd (length tss))-    _                 -> mkCallDmds rhs_arity cleanEvalDmd---- | If given the let-bound 'Id', 'useLetUp' determines whether we should--- process the binding up (body before rhs) or down (rhs before body).------ We use LetDown if there is a chance to get a useful strictness signature to--- unleash at call sites. LetDown is generally more precise than LetUp if we can--- correctly guess how it will be used in the body, that is, for which incoming--- demand the strictness signature should be computed, which allows us to--- unleash higher-order demands on arguments at call sites. This is mostly the--- case when------   * The binding takes any arguments before performing meaningful work (cf.---     'idArity'), in which case we are interested to see how it uses them.---   * The binding is a join point, hence acting like a function, not a value.---     As a big plus, we know *precisely* how it will be used in the body; since---     it's always tail-called, we can directly unleash the incoming demand of---     the let binding on its RHS when computing a strictness signature. See---     [Demand analysis for join points].------ Thus, if the binding is not a join point and its arity is 0, we have a thunk--- and use LetUp, implying that we have no usable demand signature available--- when we analyse the let body.------ Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free--- vars at most once, regardless of how many times it was forced in the body.--- This makes a real difference wrt. usage demands. The other reason is being--- able to unleash a more precise product demand on its RHS once we know how the--- thunk was used in the let body.------ Characteristic examples, always assuming a single evaluation:------   * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that---     the expression uses @y@ at most once.---   * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that---     @b@ is absent.---   * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that---     the expression uses @y@ strictly, because we have @f@'s demand signature---     available at the call site.---   * @join exit = 2*y in if a then exit else if b then exit else 3*y@ =>---     LetDown. Compared to LetUp, we find out that the expression uses @y@---     strictly, because we can unleash @exit@'s signature at each call site.---   * For a more convincing example with join points, see Note [Demand analysis---     for join points].----useLetUp :: Var -> Bool-useLetUp f = idArity f == 0 && not (isJoinId f)--{- Note [Demand analysis for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   g :: (Int,Int) -> Int-   g (p,q) = p+q--   f :: T -> Int -> Int-   f x p = g (join j y = (p,y)-              in case x of-                   A -> j 3-                   B -> j 4-                   C -> (p,7))--If j was a vanilla function definition, we'd analyse its body with-evalDmd, and think that it was lazy in p.  But for join points we can-do better!  We know that j's body will (if called at all) be evaluated-with the demand that consumes the entire join-binding, in this case-the argument demand from g.  Whizzo!  g evaluates both components of-its argument pair, so p will certainly be evaluated if j is called.--For f to be strict in p, we need /all/ paths to evaluate p; in this-case the C branch does so too, so we are fine.  So, as usual, we need-to transport demands on free variables to the call site(s).  Compare-Note [Lazy and unleashable free variables].--The implementation is easy.  When analysing a join point, we can-analyse its body with the demand from the entire join-binding (written-let_dmd here).--Another win for join points!  #13543.--However, note that the strictness signature for a join point can-look a little puzzling.  E.g.--    (join j x = \y. error "urk")-    (in case v of              )-    (     A -> j 3             )  x-    (     B -> j 4             )-    (     C -> \y. blah        )--The entire thing is in a C(S) context, so j's strictness signature-will be    [A]b-meaning one absent argument, returns bottom.  That seems odd because-there's a \y inside.  But it's right because when consumed in a C(1)-context the RHS of the join point is indeed bottom.--Note [Demand signatures are computed for a threshold demand based on idArity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We compute demand signatures assuming idArity incoming arguments to approximate-behavior for when we have a call site with at least that many arguments. idArity-is /at least/ the number of manifest lambdas, but might be higher for PAPs and-trivial RHS (see Note [Demand analysis for trivial right-hand sides]).--Because idArity of a function varies independently of its cardinality properties-(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode-the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth'-(cf. Note [Understanding DmdType and StrictSig] in Demand). It is unsound to-unleash a demand signature when the incoming number of arguments is less than-that. See Note [What are demand signatures?] for more details on soundness.--Why idArity arguments? Because that's a conservative estimate of how many-arguments we must feed a function before it does anything interesting with them.-Also it elegantly subsumes the trivial RHS and PAP case.--There might be functions for which we might want to analyse for more incoming-arguments than idArity. Example:--  f x =-    if expensive-      then \y -> ... y ...-      else \y -> ... y ...--We'd analyse `f` under a unary call demand C(S), corresponding to idArity-being 1. That's enough to look under the manifest lambda and find out how a-unary call would use `x`, but not enough to look into the lambdas in the if-branches.--On the other hand, if we analysed for call demand C(C(S)), we'd get useful-strictness info for `y` (and more precise info on `x`) and possibly CPR-information, but--  * We would no longer be able to unleash the signature at unary call sites-  * Performing the worker/wrapper split based on this information would be-    implicitly eta-expanding `f`, playing fast and loose with divergence and-    even being unsound in the presence of newtypes, so we refrain from doing so.-    Also see Note [Don't eta expand in w/w] in WorkWrap.--Since we only compute one signature, we do so for arity 1. Computing multiple-signatures for different arities (i.e., polyvariance) would be entirely-possible, if it weren't for the additional runtime and implementation-complexity.--Note [idArity varies independently of dmdTypeDepth]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound-identifier. But that means we would have to zap demand signatures every time we-reset or decrease arity. That's an unnecessary dependency, because--  * The demand signature captures a semantic property that is independent of-    what the binding's current arity is-  * idArity is analysis information itself, thus volatile-  * We already *have* dmdTypeDepth, wo why not just use it to encode the-    threshold for when to unleash the signature-    (cf. Note [Understanding DmdType and StrictSig] in Demand)--Consider the following expression, for example:--    (let go x y = `x` seq ... in go) |> co--`go` might have a strictness signature of `<S><L>`. The simplifier will identify-`go` as a nullary join point through `joinPointBinding_maybe` and float the-coercion into the binding, leading to an arity decrease:--    join go = (\x y -> `x` seq ...) |> co in go--With the CoreLint check, we would have to zap `go`'s perfectly viable strictness-signature.--Note [What are demand signatures?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Demand analysis interprets expressions in the abstract domain of demand-transformers. Given an incoming demand we put an expression under, its abstract-transformer gives us back a demand type denoting how other things (like-arguments and free vars) were used when the expression was evaluated.-Here's an example:--  f x y =-    if x + expensive-      then \z -> z + y * ...-      else \z -> z * ...--The abstract transformer (let's call it F_e) of the if expression (let's call it-e) would transform an incoming head demand <S,HU> into a demand type like-{x-><S,1*U>,y-><L,U>}<L,U>. In pictures:--     Demand ---F_e---> DmdType-     <S,HU>            {x-><S,1*U>,y-><L,U>}<L,U>--Let's assume that the demand transformers we compute for an expression are-correct wrt. to some concrete semantics for Core. How do demand signatures fit-in? They are strange beasts, given that they come with strict rules when to-it's sound to unleash them.--Fortunately, we can formalise the rules with Galois connections. Consider-f's strictness signature, {}<S,1*U><L,U>. It's a single-point approximation of-the actual abstract transformer of f's RHS for arity 2. So, what happens is that-we abstract *once more* from the abstract domain we already are in, replacing-the incoming Demand by a simple lattice with two elements denoting incoming-arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom-element). Here's the diagram:--     A_2 -----f_f----> DmdType-      ^                   |-      | α               γ |-      |                   v-     Demand ---F_f---> DmdType--With-  α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness-  α(_)         =  <2-  γ(ty)        =  ty-and F_f being the abstract transformer of f's RHS and f_f being the abstracted-abstract transformer computable from our demand signature simply by--  f_f(>=2) = {}<S,1*U><L,U>-  f_f(<2)  = postProcessUnsat {}<S,1*U><L,U>--where postProcessUnsat makes a proper top element out of the given demand type.--Note [Demand analysis for trivial right-hand sides]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    foo = plusInt |> co-where plusInt is an arity-2 function with known strictness.  Clearly-we want plusInt's strictness to propagate to foo!  But because it has-no manifest lambdas, it won't do so automatically, and indeed 'co' might-have type (Int->Int->Int) ~ T.--Fortunately, GHC.Core.Arity gives 'foo' arity 2, which is enough for LetDown to-forward plusInt's demand signature, and all is well (see Note [Newtype arity] in-GHC.Core.Arity)! A small example is the test case NewtypeArity.---Note [Product demands for function body]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This example comes from shootout/binary_trees:--    Main.check' = \ b z ds. case z of z' { I# ip ->-                                case ds_d13s of-                                  Main.Nil -> z'-                                  Main.Node s14k s14l s14m ->-                                    Main.check' (not b)-                                      (Main.check' b-                                         (case b {-                                            False -> I# (-# s14h s14k);-                                            True  -> I# (+# s14h s14k)-                                          })-                                         s14l)-                                     s14m   }   }   }--Here we *really* want to unbox z, even though it appears to be used boxed in-the Nil case.  Partly the Nil case is not a hot path.  But more specifically,-the whole function gets the CPR property if we do.--So for the demand on the body of a RHS we use a product demand if it's-a product type.--************************************************************************-*                                                                      *-\subsection{Strictness signatures and types}-*                                                                      *-************************************************************************--}--unitDmdType :: DmdEnv -> DmdType-unitDmdType dmd_env = DmdType dmd_env [] topDiv--coercionDmdEnv :: Coercion -> DmdEnv-coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)-                    -- The VarSet from coVarsOfCo is really a VarEnv Var--addVarDmd :: DmdType -> Var -> Demand -> DmdType-addVarDmd (DmdType fv ds res) var dmd-  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res--addLazyFVs :: DmdType -> DmdEnv -> DmdType-addLazyFVs dmd_ty lazy_fvs-  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs-        -- Using bothDmdType (rather than just both'ing the envs)-        -- is vital.  Consider-        --      let f = \x -> (x,y)-        --      in  error (f 3)-        -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L-        -- demand with the bottom coming up from 'error'-        ---        -- I got a loop in the fixpointer without this, due to an interaction-        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was-        --      letrec f n x-        --          = letrec g y = x `fatbar`-        --                         letrec h z = z + ...g...-        --                         in h (f (n-1) x)-        --      in ...-        -- In the initial iteration for f, f=Bot-        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS-        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it-        -- places on its free variables.  Suppose it places none.  Then the-        --      x `fatbar` ...call to h...-        -- will give a x->V demand for x.  That turns into a L demand for x,-        -- which floats out of the defn for h.  Without the modifyEnv, that-        -- L demand doesn't get both'd with the Bot coming up from the inner-        -- call to f.  So we just get an L demand for x for g.--{--Note [Do not strictify the argument dictionaries of a dfun]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The typechecker can tie recursive knots involving dfuns, so we do the-conservative thing and refrain from strictifying a dfun's argument-dictionaries.--}--setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]-setBndrsDemandInfo (b:bs) (d:ds)-  | isTyVar b = b : setBndrsDemandInfo bs (d:ds)-  | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds-setBndrsDemandInfo [] ds = ASSERT( null ds ) []-setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs)--annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)--- The returned env has the var deleted--- The returned var is annotated with demand info--- according to the result demand of the provided demand type--- No effect on the argument demands-annotateBndr env dmd_ty var-  | isId var  = (dmd_ty', setIdDemandInfo var dmd)-  | otherwise = (dmd_ty, var)-  where-    (dmd_ty', dmd) = findBndrDmd env False dmd_ty var--annotateLamIdBndr :: AnalEnv-                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?-                  -> DmdType    -- Demand type of body-                  -> Id         -- Lambda binder-                  -> (DmdType,  -- Demand type of lambda-                      Id)       -- and binder annotated with demand--annotateLamIdBndr env arg_of_dfun dmd_ty id--- For lambdas we add the demand to the argument demands--- Only called for Ids-  = ASSERT( isId id )-    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $-    (final_ty, setIdDemandInfo id dmd)-  where-      -- Watch out!  See note [Lambda-bound unfoldings]-    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of-                 Nothing  -> main_ty-                 Just unf -> main_ty `bothDmdType` unf_ty-                          where-                             (unf_ty, _) = dmdAnalStar env dmd unf--    main_ty = addDemand dmd dmd_ty'-    (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id--deleteFVs :: DmdType -> [Var] -> DmdType-deleteFVs (DmdType fvs dmds res) bndrs-  = DmdType (delVarEnvList fvs bndrs) dmds res--{--Note [NOINLINE and strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The strictness analyser used to have a HACK which ensured that NOINLNE-things were not strictness-analysed.  The reason was unsafePerformIO.-Left to itself, the strictness analyser would discover this strictness-for unsafePerformIO:-        unsafePerformIO:  C(U(AV))-But then consider this sub-expression-        unsafePerformIO (\s -> let r = f x in-                               case writeIORef v r s of (# s1, _ #) ->-                               (# s1, r #)-The strictness analyser will now find that r is sure to be eval'd,-and may then hoist it out.  This makes tests/lib/should_run/memo002-deadlock.--Solving this by making all NOINLINE things have no strictness info is overkill.-In particular, it's overkill for runST, which is perfectly respectable.-Consider-        f x = runST (return x)-This should be strict in x.--So the new plan is to define unsafePerformIO using the 'lazy' combinator:--        unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)--Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is-magically NON-STRICT, and is inlined after strictness analysis.  So-unsafePerformIO will look non-strict, and that's what we want.--Now we don't need the hack in the strictness analyser.  HOWEVER, this-decision does mean that even a NOINLINE function is not entirely-opaque: some aspect of its implementation leaks out, notably its-strictness.  For example, if you have a function implemented by an-error stub, but which has RULES, you may want it not to be eliminated-in favour of error!--Note [Lazy and unleashable free variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We put the strict and once-used FVs in the DmdType of the Id, so-that at its call sites we unleash demands on its strict fvs.-An example is 'roll' in imaginary/wheel-sieve2-Something like this:-        roll x = letrec-                     go y = if ... then roll (x-1) else x+1-                 in-                 go ms-We want to see that roll is strict in x, which is because-go is called.   So we put the DmdEnv for x in go's DmdType.--Another example:--        f :: Int -> Int -> Int-        f x y = let t = x+1-            h z = if z==0 then t else-                  if z==1 then x+1 else-                  x + h (z-1)-        in h y--Calling h does indeed evaluate x, but we can only see-that if we unleash a demand on x at the call site for t.--Incidentally, here's a place where lambda-lifting h would-lose the cigar --- we couldn't see the joint strictness in t/x--        ON THE OTHER HAND--We don't want to put *all* the fv's from the RHS into the-DmdType. Because-- * it makes the strictness signatures larger, and hence slows down fixpointing--and-- * it is useless information at the call site anyways:-   For lazy, used-many times fv's we will never get any better result than-   that, no matter how good the actual demand on the function at the call site-   is (unless it is always absent, but then the whole binder is useless).--Therefore we exclude lazy multiple-used fv's from the environment in the-DmdType.--But now the signature lies! (Missing variables are assumed to be absent.) To-make up for this, the code that analyses the binding keeps the demand on those-variable separate (usually called "lazy_fv") and adds it to the demand of the-whole binding later.--What if we decide _not_ to store a strictness signature for a binding at all, as-we do when aborting a fixed-point iteration? The we risk losing the information-that the strict variables are being used. In that case, we take all free variables-mentioned in the (unsound) strictness signature, conservatively approximate the-demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".---Note [Lambda-bound unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We allow a lambda-bound variable to carry an unfolding, a facility that is used-exclusively for join points; see Note [Case binders and join points].  If so,-we must be careful to demand-analyse the RHS of the unfolding!  Example-   \x. \y{=Just x}. <body>-Then if <body> uses 'y', then transitively it uses 'x', and we must not-forget that fact, otherwise we might make 'x' absent when it isn't.---************************************************************************-*                                                                      *-\subsection{Strictness signatures}-*                                                                      *-************************************************************************--}--type DFunFlag = Bool  -- indicates if the lambda being considered is in the-                      -- sequence of lambdas at the top of the RHS of a dfun-notArgOfDfun :: DFunFlag-notArgOfDfun = False--data AnalEnv-  = AE { ae_dflags :: DynFlags-       , ae_sigs   :: SigEnv-       , ae_virgin :: Bool    -- True on first iteration only-                              -- See Note [Initialising strictness]-       , ae_rec_tc :: RecTcChecker-       , ae_fam_envs :: FamInstEnvs- }--        -- We use the se_env to tell us whether to-        -- record info about a variable in the DmdEnv-        -- We do so if it's a LocalId, but not top-level-        ---        -- The DmdEnv gives the demand on the free vars of the function-        -- when it is given enough args to satisfy the strictness signature--type SigEnv = VarEnv (StrictSig, TopLevelFlag)--instance Outputable AnalEnv where-  ppr (AE { ae_sigs = env, ae_virgin = virgin })-    = text "AE" <+> braces (vcat-         [ text "ae_virgin =" <+> ppr virgin-         , text "ae_sigs =" <+> ppr env ])--emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv-emptyAnalEnv dflags fam_envs-    = AE { ae_dflags = dflags-         , ae_sigs = emptySigEnv-         , ae_virgin = True-         , ae_rec_tc = initRecTc-         , ae_fam_envs = fam_envs-         }--emptySigEnv :: SigEnv-emptySigEnv = emptyVarEnv---- | Extend an environment with the strictness IDs attached to the id-extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv-extendAnalEnvs top_lvl env vars-  = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }--extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv-extendSigEnvs top_lvl sigs vars-  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]--extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv-extendAnalEnv top_lvl env var sig-  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }--extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv-extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)--lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)-lookupSigEnv env id = lookupVarEnv (ae_sigs env) id--nonVirgin :: AnalEnv -> AnalEnv-nonVirgin env = env { ae_virgin = False }--findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])--- Return the demands on the Ids in the [Var]-findBndrsDmds env dmd_ty bndrs-  = go dmd_ty bndrs-  where-    go dmd_ty []  = (dmd_ty, [])-    go dmd_ty (b:bs)-      | isId b    = let (dmd_ty1, dmds) = go dmd_ty bs-                        (dmd_ty2, dmd)  = findBndrDmd env False dmd_ty1 b-                    in (dmd_ty2, dmd : dmds)-      | otherwise = go dmd_ty bs--findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)--- See Note [Trimming a demand to a type] in Demand.hs-findBndrDmd env arg_of_dfun dmd_ty id-  = (dmd_ty', dmd')-  where-    dmd' = killUsageDemand (ae_dflags env) $-           strictify $-           trimToType starting_dmd (findTypeShape fam_envs id_ty)--    (dmd_ty', starting_dmd) = peelFV dmd_ty id--    id_ty = idType id--    strictify dmd-      | gopt Opt_DictsStrict (ae_dflags env)-             -- We never want to strictify a recursive let. At the moment-             -- annotateBndr is only call for non-recursive lets; if that-             -- changes, we need a RecFlag parameter and another guard here.-      , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]-      = strictifyDictDmd id_ty dmd-      | otherwise-      = dmd--    fam_envs = ae_fam_envs env--set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id-set_idStrictness env id sig-  = setIdStrictness id (killUsageSig (ae_dflags env) sig)--{- Note [Initialising strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See section 9.2 (Finding fixpoints) of the paper.--Our basic plan is to initialise the strictness of each Id in a-recursive group to "bottom", and find a fixpoint from there.  However,-this group B might be inside an *enclosing* recursive group A, in-which case we'll do the entire fixpoint shebang on for each iteration-of A. This can be illustrated by the following example:--Example:--  f [] = []-  f (x:xs) = let g []     = f xs-                 g (y:ys) = y+1 : g ys-              in g (h x)--At each iteration of the fixpoint for f, the analyser has to find a-fixpoint for the enclosed function g. In the meantime, the demand-values for g at each iteration for f are *greater* than those we-encountered in the previous iteration for f. Therefore, we can begin-the fixpoint for g not with the bottom value but rather with the-result of the previous analysis. I.e., when beginning the fixpoint-process for g, we can start from the demand signature computed for g-previously and attached to the binding occurrence of g.--To speed things up, we initialise each iteration of A (the enclosing-one) from the result of the last one, which is neatly recorded in each-binder.  That way we make use of earlier iterations of the fixpoint-algorithm. (Cunning plan.)--But on the *first* iteration we want to *ignore* the current strictness-of the Id, and start from "bottom".  Nowadays the Id can have a current-strictness, because interface files record strictness for nested bindings.-To know when we are in the first iteration, we look at the ae_virgin-field of the AnalEnv.---Note [Final Demand Analyser run]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some of the information that the demand analyser determines is not always-preserved by the simplifier.  For example, the simplifier will happily rewrite-  \y [Demand=1*U] let x = y in x + x-to-  \y [Demand=1*U] y + y-which is quite a lie.--The once-used information is (currently) only used by the code-generator, though.  So:-- * We zap the used-once info in the worker-wrapper;-   see Note [Zapping Used Once info in WorkWrap] in WorkWrap. If it's-   not reliable, it's better not to have it at all.-- * Just before TidyCore, we add a pass of the demand analyser,-      but WITHOUT subsequent worker/wrapper and simplifier,-   right before TidyCore.  See SimplCore.getCoreToDo.--   This way, correct information finds its way into the module interface-   (strictness signatures!) and the code generator (single-entry thunks!)--Note that, in contrast, the single-call information (C1(..)) /can/ be-relied upon, as the simplifier tends to be very careful about not-duplicating actual function calls.--Also see #11731.--}
− compiler/stranal/WorkWrap.hs 
@@ -1,776 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1993-1998--\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}--}--{-# LANGUAGE CPP #-}-module WorkWrap ( wwTopBinds ) where--import GhcPrelude--import GHC.Core.Arity  ( manifestArity )-import GHC.Core-import GHC.Core.Unfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )-import GHC.Core.Utils  ( exprType, exprIsHNF )-import GHC.Core.FVs    ( exprFreeVars )-import Var-import Id-import IdInfo-import Type-import UniqSupply-import BasicTypes-import GHC.Driver.Session-import Demand-import Cpr-import WwLib-import Util-import Outputable-import FamInstEnv-import MonadUtils--#include "HsVersions.h"--{--We take Core bindings whose binders have:--\begin{enumerate}--\item Strictness attached (by the front-end of the strictness-analyser), and / or--\item Constructed Product Result information attached by the CPR-analysis pass.--\end{enumerate}--and we return some ``plain'' bindings which have been-worker/wrapper-ified, meaning:--\begin{enumerate}--\item Functions have been split into workers and wrappers where-appropriate.  If a function has both strictness and CPR properties-then only one worker/wrapper doing both transformations is produced;--\item Binders' @IdInfos@ have been updated to reflect the existence of-these workers/wrappers (this is where we get STRICTNESS and CPR pragma-info for exported values).-\end{enumerate}--}--wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram--wwTopBinds dflags fam_envs us top_binds-  = initUs_ us $ do-    top_binds' <- mapM (wwBind dflags fam_envs) top_binds-    return (concat top_binds')--{--************************************************************************-*                                                                      *-\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}-*                                                                      *-************************************************************************--@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in-turn.  Non-recursive case first, then recursive...--}--wwBind  :: DynFlags-        -> FamInstEnvs-        -> CoreBind-        -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;-                                -- the caller will convert to Expr/Binding,-                                -- as appropriate.--wwBind dflags fam_envs (NonRec binder rhs) = do-    new_rhs <- wwExpr dflags fam_envs rhs-    new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs-    return [NonRec b e | (b,e) <- new_pairs]-      -- Generated bindings must be non-recursive-      -- because the original binding was.--wwBind dflags fam_envs (Rec pairs)-  = return . Rec <$> concatMapM do_one pairs-  where-    do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs-                              tryWW dflags fam_envs Recursive binder new_rhs--{--@wwExpr@ basically just walks the tree, looking for appropriate-annotations that can be used. Remember it is @wwBind@ that does the-matching by looking for strict arguments of the correct type.-@wwExpr@ is a version that just returns the ``Plain'' Tree.--}--wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr--wwExpr _      _ e@(Type {}) = return e-wwExpr _      _ e@(Coercion {}) = return e-wwExpr _      _ e@(Lit  {}) = return e-wwExpr _      _ e@(Var  {}) = return e--wwExpr dflags fam_envs (Lam binder expr)-  = Lam new_binder <$> wwExpr dflags fam_envs expr-  where new_binder | isId binder = zapIdUsedOnceInfo binder-                   | otherwise   = binder-  -- See Note [Zapping Used Once info in WorkWrap]--wwExpr dflags fam_envs (App f a)-  = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a--wwExpr dflags fam_envs (Tick note expr)-  = Tick note <$> wwExpr dflags fam_envs expr--wwExpr dflags fam_envs (Cast expr co) = do-    new_expr <- wwExpr dflags fam_envs expr-    return (Cast new_expr co)--wwExpr dflags fam_envs (Let bind expr)-  = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr--wwExpr dflags fam_envs (Case expr binder ty alts) = do-    new_expr <- wwExpr dflags fam_envs expr-    new_alts <- mapM ww_alt alts-    let new_binder = zapIdUsedOnceInfo binder-      -- See Note [Zapping Used Once info in WorkWrap]-    return (Case new_expr new_binder ty new_alts)-  where-    ww_alt (con, binders, rhs) = do-        new_rhs <- wwExpr dflags fam_envs rhs-        let new_binders = [ if isId b then zapIdUsedOnceInfo b else b-                          | b <- binders ]-           -- See Note [Zapping Used Once info in WorkWrap]-        return (con, new_binders, new_rhs)--{--************************************************************************-*                                                                      *-\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}-*                                                                      *-************************************************************************--@tryWW@ just accumulates arguments, converts strictness info from the-front-end into the proper form, then calls @mkWwBodies@ to do-the business.--The only reason this is monadised is for the unique supply.--Note [Don't w/w INLINE things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very important to refrain from w/w-ing an INLINE function (ie one-with a stable unfolding) because the wrapper will then overwrite the-old stable unfolding with the wrapper code.--Furthermore, if the programmer has marked something as INLINE,-we may lose by w/w'ing it.--If the strictness analyser is run twice, this test also prevents-wrappers (which are INLINEd) from being re-done.  (You can end up with-several liked-named Ids bouncing around at the same time---absolute-mischief.)--Notice that we refrain from w/w'ing an INLINE function even if it is-in a recursive group.  It might not be the loop breaker.  (We could-test for loop-breaker-hood, but I'm not sure that ever matters.)--Note [Worker-wrapper for INLINABLE functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-  {-# INLINABLE f #-}-  f :: Ord a => [a] -> Int -> a-  f x y = ....f....--where f is strict in y, we might get a more efficient loop by w/w'ing-f.  But that would make a new unfolding which would overwrite the old-one! So the function would no longer be INLNABLE, and in particular-will not be specialised at call sites in other modules.--This comes in practice (#6056).--Solution: do the w/w for strictness analysis, but transfer the Stable-unfolding to the *worker*.  So we will get something like this:--  {-# INLINE[0] f #-}-  f :: Ord a => [a] -> Int -> a-  f d x y = case y of I# y' -> fw d x y'--  {-# INLINABLE[0] fw #-}-  fw :: Ord a => [a] -> Int# -> a-  fw d x y' = let y = I# y' in ...f...--How do we "transfer the unfolding"? Easy: by using the old one, wrapped-in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding.--Note [Worker-wrapper for NOINLINE functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to disable worker/wrapper for NOINLINE things, but it turns out-this can cause unnecessary reboxing of values. Consider--  {-# NOINLINE f #-}-  f :: Int -> a-  f x = error (show x)--  g :: Bool -> Bool -> Int -> Int-  g True  True  p = f p-  g False True  p = p + 1-  g b     False p = g b True p--the strictness analysis will discover f and g are strict, but because f-has no wrapper, the worker for g will rebox p. So we get--  $wg x y p# =-    let p = I# p# in  -- Yikes! Reboxing!-    case x of-      False ->-        case y of-          False -> $wg False True p#-          True -> +# p# 1#-      True ->-        case y of-          False -> $wg True True p#-          True -> case f p of { }--  g x y p = case p of (I# p#) -> $wg x y p#--Now, in this case the reboxing will float into the True branch, and so-the allocation will only happen on the error path. But it won't float-inwards if there are multiple branches that call (f p), so the reboxing-will happen on every call of g. Disaster.--Solution: do worker/wrapper even on NOINLINE things; but move the-NOINLINE pragma to the worker.--(See #13143 for a real-world example.)--It is crucial that we do this for *all* NOINLINE functions. #10069-demonstrates what happens when we promise to w/w a (NOINLINE) leaf function, but-fail to deliver:--  data C = C Int# Int#--  {-# NOINLINE c1 #-}-  c1 :: C -> Int#-  c1 (C _ n) = n--  {-# NOINLINE fc #-}-  fc :: C -> Int#-  fc c = 2 *# c1 c--Failing to w/w `c1`, but still w/wing `fc` leads to the following code:--  c1 :: C -> Int#-  c1 (C _ n) = n--  $wfc :: Int# -> Int#-  $wfc n = let c = C 0# n in 2 #* c1 c--  fc :: C -> Int#-  fc (C _ n) = $wfc n--Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place.-This generalises to any function that derives its strictness signature from-its callees, so we have to make sure that when a function announces particular-strictness properties, we have to w/w them accordingly, even if it means-splitting a NOINLINE function.--Note [Worker activation]-~~~~~~~~~~~~~~~~~~~~~~~~-Follows on from Note [Worker-wrapper for INLINABLE functions]--It is *vital* that if the worker gets an INLINABLE pragma (from the-original function), then the worker has the same phase activation as-the wrapper (or later).  That is necessary to allow the wrapper to-inline into the worker's unfolding: see SimplUtils-Note [Simplifying inside stable unfoldings].--If the original is NOINLINE, it's important that the work inherit the-original activation. Consider--  {-# NOINLINE expensive #-}-  expensive x = x + 1--  f y = let z = expensive y in ...--If expensive's worker inherits the wrapper's activation,-we'll get this (because of the compromise in point (2) of-Note [Wrapper activation])--  {-# NOINLINE[0] $wexpensive #-}-  $wexpensive x = x + 1-  {-# INLINE[0] expensive #-}-  expensive x = $wexpensive x--  f y = let z = expensive y in ...--and $wexpensive will be immediately inlined into expensive, followed by-expensive into f. This effectively removes the original NOINLINE!--Otherwise, nothing is lost by giving the worker the same activation as the-wrapper, because the worker won't have any chance of inlining until the-wrapper does; there's no point in giving it an earlier activation.--Note [Don't w/w inline small non-loop-breaker things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general, we refrain from w/w-ing *small* functions, which are not-loop breakers, because they'll inline anyway.  But we must take care:-it may look small now, but get to be big later after other inlining-has happened.  So we take the precaution of adding an INLINE pragma to-any such functions.--I made this change when I observed a big function at the end of-compilation with a useful strictness signature but no w-w.  (It was-small during demand analysis, we refrained from w/w, and then got big-when something was inlined in its rhs.) When I measured it on nofib,-it didn't make much difference; just a few percent improved allocation-on one benchmark (bspt/Euclid.space).  But nothing got worse.--There is an infelicity though.  We may get something like-      f = g val-==>-      g x = case gw x of r -> I# r--      f {- InlineStable, Template = g val -}-      f = case gw x of r -> I# r--The code for f duplicates that for g, without any real benefit. It-won't really be executed, because calls to f will go via the inlining.--Note [Don't w/w join points for CPR]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's no point in exploiting CPR info on a join point. If the whole function-is getting CPR'd, then the case expression around the worker function will get-pushed into the join point by the simplifier, which will have the same effect-that w/w'ing for CPR would have - the result will be returned in an unboxed-tuple.--  f z = let join j x y = (x+1, y+1)-        in case z of A -> j 1 2-                     B -> j 2 3--  =>--  f z = case $wf z of (# a, b #) -> (a, b)-  $wf z = case (let join j x y = (x+1, y+1)-                in case z of A -> j 1 2-                             B -> j 2 3) of (a, b) -> (# a, b #)--  =>--  f z = case $wf z of (# a, b #) -> (a, b)-  $wf z = let join j x y = (# x+1, y+1 #)-          in case z of A -> j 1 2-                       B -> j 2 3--Note that we still want to give @j@ the CPR property, so that @f@ has it. So-CPR *analyse* join points as regular functions, but don't *transform* them.--Doing W/W for returned products on a join point would be tricky anyway, as the-worker could not be a join point because it would not be tail-called. However,-doing the *argument* part of W/W still works for join points, since the wrapper-body will make a tail call:--  f z = let join j x y = x + y-        in ...--  =>--  f z = let join $wj x# y# = x# +# y#-                 j x y = case x of I# x# ->-                         case y of I# y# ->-                         $wj x# y#-        in ...--Note [Wrapper activation]-~~~~~~~~~~~~~~~~~~~~~~~~~-When should the wrapper inlining be active?--1. It must not be active earlier than the current Activation of the-   Id--2. It should be active at some point, despite (1) because of-   Note [Worker-wrapper for NOINLINE functions]--3. For ordinary functions with no pragmas we want to inline the-   wrapper as early as possible (#15056).  Suppose another module-   defines    f x = g x x-   and suppose there is some RULE for (g True True).  Then if we have-   a call (f True), we'd expect to inline 'f' and the RULE will fire.-   But if f is w/w'd (which it might be), we want the inlining to-   occur just as if it hadn't been.--   (This only matters if f's RHS is big enough to w/w, but small-   enough to inline given the call site, but that can happen.)--4. We do not want to inline the wrapper before specialisation.-         module Foo where-           f :: Num a => a -> Int -> a-           f n 0 = n              -- Strict in the Int, hence wrapper-           f n x = f (n+n) (x-1)--           g :: Int -> Int-           g x = f x x            -- Provokes a specialisation for f--         module Bar where-           import Foo--           h :: Int -> Int-           h x = f 3 x--   In module Bar we want to give specialisations a chance to fire-   before inlining f's wrapper.--Reminder: Note [Don't w/w INLINE things], so we don't need to worry-          about INLINE things here.--Conclusion:-  - If the user said NOINLINE[n], respect that-  - If the user said NOINLINE, inline the wrapper as late as-    poss (phase 0). This is a compromise driven by (2) above-  - Otherwise inline wrapper in phase 2.  That allows the-    'gentle' simplification pass to apply specialisation rules--Historical note: At one stage I tried making the wrapper inlining-always-active, and that had a very bad effect on nofib/imaginary/x2n1;-a wrapper was inlined before the specialisation fired.--Note [Wrapper NoUserInline]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-The use an inl_inline of NoUserInline on the wrapper distinguishes-this pragma from one that was given by the user. In particular, CSE-will not happen if there is a user-specified pragma, but should happen-for w/w’ed things (#14186).--}--tryWW   :: DynFlags-        -> FamInstEnvs-        -> RecFlag-        -> Id                           -- The fn binder-        -> CoreExpr                     -- The bound rhs; its innards-                                        --   are already ww'd-        -> UniqSM [(Id, CoreExpr)]      -- either *one* or *two* pairs;-                                        -- if one, then no worker (only-                                        -- the orig "wrapper" lives on);-                                        -- if two, then a worker and a-                                        -- wrapper.-tryWW dflags fam_envs is_rec fn_id rhs-  -- See Note [Worker-wrapper for NOINLINE functions]--  | Just stable_unf <- certainlyWillInline dflags fn_info-  = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]-        -- See Note [Don't w/w INLINE things]-        -- See Note [Don't w/w inline small non-loop-breaker things]--  | is_fun && is_eta_exp-  = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs--  | is_thunk                                   -- See Note [Thunk splitting]-  = splitThunk dflags fam_envs is_rec new_fn_id rhs--  | otherwise-  = return [ (new_fn_id, rhs) ]--  where-    fn_info      = idInfo fn_id-    (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info)--    cpr_ty       = getCprSig (cprInfo fn_info)-    -- Arity of the CPR sig should match idArity when it's not a join point.-    -- See Note [Arity trimming for CPR signatures] in CprAnal-    cpr          = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info-                          , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info))-                   ct_cpr cpr_ty--    new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)-        -- See Note [Zapping DmdEnv after Demand Analyzer] and-        -- See Note [Zapping Used Once info in WorkWrap]--    is_fun     = notNull wrap_dmds || isJoinId fn_id-    -- See Note [Don't eta expand in w/w]-    is_eta_exp = length wrap_dmds == manifestArity rhs-    is_thunk   = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)-                            && not (isUnliftedType (idType fn_id))--{--Note [Zapping DmdEnv after Demand Analyzer]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the worker-wrapper pass we zap the DmdEnv.  Why?- (a) it is never used again- (b) it wastes space- (c) it becomes incorrect as things are cloned, because-     we don't push the substitution into it--Why here?- * Because we don’t want to do it in the Demand Analyzer, as we never know-   there when we are doing the last pass.- * We want them to be still there at the end of DmdAnal, so that-   -ddump-str-anal contains them.- * We don’t want a second pass just for that.- * WorkWrap looks at all bindings anyway.--We also need to do it in TidyCore.tidyLetBndr to clean up after the-final, worker/wrapper-less run of the demand analyser (see-Note [Final Demand Analyser run] in DmdAnal).--Note [Zapping Used Once info in WorkWrap]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the worker-wrapper pass we zap the used once info in demands and in-strictness signatures.--Why?- * The simplifier may happen to transform code in a way that invalidates the-   data (see #11731 for an example).- * It is not used in later passes, up to code generation.--So as the data is useless and possibly wrong, we want to remove it. The most-convenient place to do that is the worker wrapper phase, as it runs after every-run of the demand analyser besides the very last one (which is the one where we-want to _keep_ the info for the code generator).--We do not do it in the demand analyser for the same reasons outlined in-Note [Zapping DmdEnv after Demand Analyzer] above.--Note [Don't eta expand in w/w]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A binding where the manifestArity of the RHS is less than idArity of the binder-means GHC.Core.Arity didn't eta expand that binding. When this happens, it does so-for a reason (see Note [exprArity invariant] in GHC.Core.Arity) and we probably have-a PAP, cast or trivial expression as RHS.--Performing the worker/wrapper split will implicitly eta-expand the binding to-idArity, overriding GHC.Core.Arity's decision. Other than playing fast and loose with-divergence, it's also broken for newtypes:--  f = (\xy.blah) |> co-    where-      co :: (Int -> Int -> Char) ~ T--Then idArity is 2 (despite the type T), and it can have a StrictSig based on a-threshold of 2. But we can't w/w it without a type error.--The situation is less grave for PAPs, but the implicit eta expansion caused a-compiler allocation regression in T15164, where huge recursive instance method-groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the-simplifier, when simply waiting for the PAPs to inline arrived at the same-output program.--Note there is the worry here that such PAPs and trivial RHSs might not *always*-be inlined. That would lead to reboxing, because the analysis tacitly assumes-that we W/W'd for idArity and will propagate analysis information under that-assumption. So far, this doesn't seem to matter in practice.-See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.--}-------------------------splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr-         -> UniqSM [(Id, CoreExpr)]-splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs-  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) do-    -- The arity should match the signature-    stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info-    case stuff of-      Just (work_demands, join_arity, wrap_fn, work_fn) -> do-        work_uniq <- getUniqueM-        let work_rhs = work_fn rhs-            work_act = case fn_inline_spec of  -- See Note [Worker activation]-                          NoInline -> fn_act-                          _        -> wrap_act--            work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"-                                     , inl_inline = fn_inline_spec-                                     , inl_sat    = Nothing-                                     , inl_act    = work_act-                                     , inl_rule   = FunLike }-              -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]-              -- inl_act:    see Note [Worker activation]-              -- inl_rule:   it does not make sense for workers to be constructorlike.--            work_join_arity | isJoinId fn_id = Just join_arity-                            | otherwise      = Nothing-              -- worker is join point iff wrapper is join point-              -- (see Note [Don't w/w join points for CPR])--            work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)-                        `setIdOccInfo` occInfo fn_info-                                -- Copy over occurrence info from parent-                                -- Notably whether it's a loop breaker-                                -- Doesn't matter much, since we will simplify next, but-                                -- seems right-er to do so--                        `setInlinePragma` work_prag--                        `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding-                                -- See Note [Worker-wrapper for INLINABLE functions]--                        `setIdStrictness` mkClosedStrictSig work_demands div-                                -- Even though we may not be at top level,-                                -- it's ok to give it an empty DmdEnv--                        `setIdCprInfo` mkCprSig work_arity work_cpr_info--                        `setIdDemandInfo` worker_demand--                        `setIdArity` work_arity-                                -- Set the arity so that the Core Lint check that the-                                -- arity is consistent with the demand type goes-                                -- through-                        `asJoinId_maybe` work_join_arity--            work_arity = length work_demands--            -- See Note [Demand on the Worker]-            single_call = saturatedByOneShots arity (demandInfo fn_info)-            worker_demand | single_call = mkWorkerDemand work_arity-                          | otherwise   = topDmd--            wrap_rhs  = wrap_fn work_id-            wrap_act  = case fn_act of  -- See Note [Wrapper activation]-                           ActiveAfter {} -> fn_act-                           NeverActive    -> activeDuringFinal-                           _              -> activeAfterInitial-            wrap_prag = InlinePragma { inl_src    = SourceText "{-# INLINE"-                                     , inl_inline = NoUserInline-                                     , inl_sat    = Nothing-                                     , inl_act    = wrap_act-                                     , inl_rule   = rule_match_info }-                -- inl_act:    see Note [Wrapper activation]-                -- inl_inline: see Note [Wrapper NoUserInline]-                -- inl_rule:   RuleMatchInfo is (and must be) unaffected--            wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule dflags wrap_rhs arity-                              `setInlinePragma` wrap_prag-                              `setIdOccInfo`    noOccInfo-                                -- Zap any loop-breaker-ness, to avoid bleating from Lint-                                -- about a loop breaker with an INLINE rule----        return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)]-            -- Worker first, because wrapper mentions it--      Nothing -> return [(fn_id, rhs)]-  where-    rhs_fvs         = exprFreeVars rhs-    fn_inl_prag     = inlinePragInfo fn_info-    fn_inline_spec  = inl_inline fn_inl_prag-    fn_act          = inl_act fn_inl_prag-    rule_match_info = inlinePragmaRuleMatchInfo fn_inl_prag-    fn_unfolding    = unfoldingInfo fn_info-    arity           = arityInfo fn_info-                    -- The arity is set by the simplifier using exprEtaExpandArity-                    -- So it may be more than the number of top-level-visible lambdas--    -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points,-    -- see Note [Don't w/w join points for CPR].-    use_cpr_info  | isJoinId fn_id = topCpr-                  | otherwise      = cpr-    -- Even if we don't w/w join points for CPR, we might still do so for-    -- strictness. In which case a join point worker keeps its original CPR-    -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker-    -- doesn't have the CPR property anymore.-    work_cpr_info | isJoinId fn_id = cpr-                  | otherwise      = topCpr---{--Note [Demand on the worker]-~~~~~~~~~~~~~~~~~~~~~~~~~~~--If the original function is called once, according to its demand info, then-so is the worker. This is important so that the occurrence analyser can-attach OneShot annotations to the worker’s lambda binders.---Example:--  -- Original function-  f [Demand=<L,1*C1(U)>] :: (a,a) -> a-  f = \p -> ...--  -- Wrapper-  f [Demand=<L,1*C1(U)>] :: a -> a -> a-  f = \p -> case p of (a,b) -> $wf a b--  -- Worker-  $wf [Demand=<L,1*C1(C1(U))>] :: Int -> Int-  $wf = \a b -> ...--We need to check whether the original function is called once, with-sufficiently many arguments. This is done using saturatedByOneShots, which-takes the arity of the original function (resp. the wrapper) and the demand on-the original function.--The demand on the worker is then calculated using mkWorkerDemand, and always of-the form [Demand=<L,1*(C1(...(C1(U))))>]---Note [Do not split void functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this rather common form of binding:-        $j = \x:Void# -> ...no use of x...--Since x is not used it'll be marked as absent.  But there is no point-in w/w-ing because we'll simply add (\y:Void#), see WwLib.mkWorerArgs.--If x has a more interesting type (eg Int, or Int#), there *is* a point-in w/w so that we don't pass the argument at all.--Note [Thunk splitting]-~~~~~~~~~~~~~~~~~~~~~~-Suppose x is used strictly (never mind whether it has the CPR-property).--      let-        x* = x-rhs-      in body--splitThunk transforms like this:--      let-        x* = case x-rhs of { I# a -> I# a }-      in body--Now simplifier will transform 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 }--The join point will abstract over a, rather than over (which is-what would have happened before) which is fine.--Notice that x certainly has the CPR property now!--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.--}---- See Note [Thunk splitting]--- splitThunk converts the *non-recursive* binding---      x = e--- into---      x = let x = e---          in case x of---               I# y -> let x = I# y in x }--- See comments above. Is it not beautifully short?--- Moreover, it works just as well when there are--- several binders, and if the binders are lifted--- E.g.     x = e---     -->  x = let x = e in---              case x of (a,b) -> let x = (a,b)  in x--splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]-splitThunk dflags fam_envs is_rec fn_id rhs-  = ASSERT(not (isJoinId fn_id))-    do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id]-       ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]-       ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive-                   return res-                   else return [(fn_id, rhs)] }
− compiler/stranal/WwLib.hs 
@@ -1,1201 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1993-1998--\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}--}--{-# LANGUAGE CPP #-}--module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs-             , deepSplitProductType_maybe, findTypeShape-             , isWorkerSmallEnough- ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Core-import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase )-import Id-import IdInfo           ( JoinArity )-import DataCon-import Demand-import Cpr-import GHC.Core.Make    ( mkAbsentErrorApp, mkCoreUbxTup-                        , mkCoreApp, mkCoreLet )-import MkId             ( voidArgId, voidPrimId )-import TysWiredIn       ( tupleDataCon )-import TysPrim          ( voidPrimTy )-import Literal          ( absentLiteralOf, rubbishLit )-import VarEnv           ( mkInScopeSet )-import VarSet           ( VarSet )-import Type-import Predicate        ( isClassPred )-import GHC.Types.RepType          ( isVoidTy, typePrimRep )-import Coercion-import FamInstEnv-import BasicTypes       ( Boxity(..) )-import TyCon-import UniqSupply-import Unique-import Maybes-import Util-import Outputable-import GHC.Driver.Session-import FastString-import ListSetOps--{--************************************************************************-*                                                                      *-\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}-*                                                                      *-************************************************************************--Here's an example.  The original function is:--\begin{verbatim}-g :: forall a . Int -> [a] -> a--g = \/\ a -> \ x ys ->-        case x of-          0 -> head ys-          _ -> head (tail ys)-\end{verbatim}--From this, we want to produce:-\begin{verbatim}--- wrapper (an unfolding)-g :: forall a . Int -> [a] -> a--g = \/\ a -> \ x ys ->-        case x of-          I# x# -> $wg a x# ys-            -- call the worker; don't forget the type args!---- worker-$wg :: forall a . Int# -> [a] -> a--$wg = \/\ a -> \ x# ys ->-        let-            x = I# x#-        in-            case x of               -- note: body of g moved intact-              0 -> head ys-              _ -> head (tail ys)-\end{verbatim}--Something we have to be careful about:  Here's an example:--\begin{verbatim}--- "f" strictness: U(P)U(P)-f (I# a) (I# b) = a +# b--g = f   -- "g" strictness same as "f"-\end{verbatim}--\tr{f} will get a worker all nice and friendly-like; that's good.-{\em But we don't want a worker for \tr{g}}, even though it has the-same strictness as \tr{f}.  Doing so could break laziness, at best.--Consequently, we insist that the number of strictness-info items is-exactly the same as the number of lambda-bound arguments.  (This is-probably slightly paranoid, but OK in practice.)  If it isn't the-same, we ``revise'' the strictness info, so that we won't propagate-the unusable strictness-info into the interfaces.---************************************************************************-*                                                                      *-\subsection{The worker wrapper core}-*                                                                      *-************************************************************************--@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.--}--type WwResult-  = ([Demand],              -- Demands 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--mkWwBodies :: DynFlags-           -> FamInstEnvs-           -> VarSet         -- Free vars of RHS-                             -- See Note [Freshen WW arguments]-           -> Id             -- The original function-           -> [Demand]       -- Strictness of original function-           -> CprResult      -- Info about function result-           -> UniqSM (Maybe WwResult)---- wrap_fn_args E       = \x y -> E--- work_fn_args E       = E x y---- wrap_fn_str E        = case x of { (a,b) ->---                        case a of { (a1,a2) ->---                        E a1 a2 b y }}--- work_fn_str E        = \a1 a2 b y ->---                        let a = (a1,a2) in---                        let x = (a,b) in---                        E--mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info-  = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)-                -- See Note [Freshen WW arguments]--        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)-             <- mkWWargs empty_subst fun_ty demands-        ; (useful1, work_args, wrap_fn_str, work_fn_str)-             <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args--        -- Do CPR w/w.  See Note [Always do CPR w/w]-        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)-              <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info--        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty-              worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]-              wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var-              worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args--        ; if isWorkerSmallEnough dflags work_args-             && not (too_many_args_for_join_point wrap_args)-             && ((useful1 && not only_one_void_argument) || useful2)-          then return (Just (worker_args_dmds, length work_call_args,-                       wrapper_body, worker_body))-          else return Nothing-        }-        -- We use an INLINE unconditionally, even if the wrapper turns out to be-        -- something trivial like-        --      fw = ...-        --      f = __inline__ (coerce T fw)-        -- The point is to propagate the coerce to f's call sites, so even though-        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent-        -- fw from being inlined into f's RHS-  where-    fun_ty        = idType fun_id-    mb_join_arity = isJoinId_maybe fun_id-    has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)-                          -- See Note [Do not unpack class dictionaries]--    -- Note [Do not split void functions]-    only_one_void_argument-      | [d] <- demands-      , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty-      , isAbsDmd d && isVoidTy arg_ty1-      = True-      | 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-      = WARN(True, text "Unable to worker/wrapper join point with arity " <+>-                     int join_arity <+> text "but" <+>-                     int (length wrap_args) <+> text "args")-        True-      | otherwise-      = False---- See Note [Limit w/w arity]-isWorkerSmallEnough :: DynFlags -> [Var] -> Bool-isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags-    -- We count only Free variables (isId) to skip Type, Kind-    -- variables which have no runtime representation.--{--Note [Always do CPR w/w]-~~~~~~~~~~~~~~~~~~~~~~~~-At one time we refrained from doing CPR w/w for thunks, on the grounds that-we might duplicate work.  But that is already handled by the demand analyser,-which doesn't give the CPR property if w/w might waste work: see-Note [CPR for thunks] in DmdAnal.--And if something *has* been given the CPR property and we don't w/w, it's-a disaster, because then the enclosing function might say it has the CPR-property, but now doesn't and there a cascade of disaster.  A good example-is #5920.--Note [Limit w/w arity]-~~~~~~~~~~~~~~~~~~~~~~~~-Guard against high worker arity as it generates a lot of stack traffic.-A simplified example is #11565#comment:6--Current strategy is very simple: don't perform w/w transformation at all-if the result produces a wrapper with arity higher than -fmax-worker-args=.--It is a bit all or nothing, consider--        f (x,y) (a,b,c,d,e ... , z) = rhs--Currently we will remove all w/w ness entirely. But actually we could-w/w on the (x,y) pair... it's the huge product that is the problem.--Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd-solve f. But we can get a lot of args from deeply-nested products:--        g (a, (b, (c, (d, ...)))) = rhs--This is harder to spot on an arg-by-arg basis. Previously mkWwStr was-given some "fuel" saying how many arguments it could add; when we ran-out of fuel it would stop w/wing.-Still not very clever because it had a left-right bias.--************************************************************************-*                                                                      *-\subsection{Making wrapper args}-*                                                                      *-************************************************************************--During worker-wrapper stuff we may end up with an unlifted thing-which we want to let-bind without losing laziness.  So we-add a void argument.  E.g.--        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z-==>-        fw = /\ a -> \void -> E-        f  = /\ a -> \x y z -> fw realworld--We use the state-token type which generates no code.--}--mkWorkerArgs :: DynFlags -> [Var]-             -> Type    -- Type of body-             -> ([Var], -- Lambda bound args-                 [Var]) -- Args at call site-mkWorkerArgs dflags args res_ty-    | any isId args || not needsAValueLambda-    = (args, args)-    | otherwise-    = (args ++ [voidArgId], args ++ [voidPrimId])-    where-      -- See "Making wrapper args" section above-      needsAValueLambda =-        lifted-        -- We may encounter a levity-polymorphic result, in which case we-        -- conservatively assume that we have laziness that needs preservation.-        -- See #15186.-        || not (gopt Opt_FunToThunk dflags)-           -- see Note [Protecting the last value argument]--      -- Might the result be lifted?-      lifted =-        case isLiftedType_maybe res_ty of-          Just lifted -> lifted-          Nothing     -> True--{--Note [Protecting the last value argument]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the user writes (\_ -> E), they might be intentionally disallowing-the sharing of E. Since absence analysis and worker-wrapper are keen-to remove such unused arguments, we add in a void argument to prevent-the function from becoming a thunk.--The user can avoid adding the void argument with the -ffun-to-thunk-flag. However, this can create sharing, which may be bad in two ways. 1) It can-create a space leak. 2) It can prevent inlining *under a lambda*. If w/w-removes the last argument from a function f, then f now looks like a thunk, and-so f can't be inlined *under a lambda*.--Note [Join points and beta-redexes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Originally, the worker would invoke the original function by calling it with-arguments, thus producing a beta-redex for the simplifier to munch away:--  \x y z -> e => (\x y z -> e) wx wy wz--Now that we have special rules about join points, however, this is Not Good if-the original function is itself a join point, as then it may contain invocations-of other join points:--  join j1 x = ...-  join j2 y = if y == 0 then 0 else j1 y--  =>--  join j1 x = ...-  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy-  join j2 y = case y of I# y# -> jump $wj2 y#--There can't be an intervening lambda between a join point's declaration and its-occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:--  ...-  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y-  ...--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 GraphOps.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.--************************************************************************-*                                                                      *-\subsection{Coercion stuff}-*                                                                      *-************************************************************************--We really want to "look through" coerces.-Reason: I've seen this situation:--        let f = coerce T (\s -> E)-        in \x -> case x of-                    p -> coerce T' f-                    q -> \s -> E2-                    r -> coerce T' f--If only we w/w'd f, we'd get-        let f = coerce T (\s -> fw s)-            fw = \s -> E-        in ...--Now we'll inline f to get--        let fw = \s -> E-        in \x -> case x of-                    p -> fw-                    q -> \s -> E2-                    r -> fw--Now we'll see that fw has arity 1, and will arity expand-the \x to get what we want.--}---- mkWWargs just does eta expansion--- is driven off the function type and arity.--- It chomps bites off foralls, arrows, newtypes--- and keeps repeating that until it's satisfied the supplied arity--mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type-                                --   See Note [Freshen WW arguments]-         -> Type                -- The type of the function-         -> [Demand]     -- Demands and one-shot info for value arguments-         -> UniqSM  ([Var],            -- Wrapper args-                     CoreExpr -> CoreExpr,      -- Wrapper fn-                     CoreExpr -> CoreExpr,      -- Worker fn-                     Type)                      -- Type of wrapper body--mkWWargs subst fun_ty demands-  | null demands-  = return ([], id, id, substTy subst fun_ty)--  | (dmd:demands') <- demands-  , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty-  = do  { uniq <- getUniqueM-        ; let arg_ty' = substTy subst arg_ty-              id = mk_wrap_arg uniq arg_ty' dmd-        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)-              <- mkWWargs subst fun_ty' demands'-        ; return (id : wrap_args,-                  Lam id . wrap_fn_args,-                  apply_or_bind_then work_fn_args (varToCoreExpr id),-                  res_ty) }--  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty-  = do  { uniq <- getUniqueM-        ; let (subst', tv') = cloneTyVarBndr subst tv uniq-                -- See Note [Freshen WW arguments]-        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)-             <- mkWWargs subst' fun_ty' demands-        ; return (tv' : wrap_args,-                  Lam tv' . wrap_fn_args,-                  apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),-                  res_ty) }--  | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty-        -- The newtype case is for when the function has-        -- a newtype after the arrow (rare)-        ---        -- It's also important when we have a function returning (say) a pair-        -- wrapped in a  newtype, at least if CPR analysis can look-        -- through such newtypes, which it probably can since they are-        -- simply coerces.--  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)-            <-  mkWWargs subst rep_ty demands-       ; let co' = substCo subst co-       ; return (wrap_args,-                  \e -> Cast (wrap_fn_args e) (mkSymCo co'),-                  \e -> work_fn_args (Cast e co'),-                  res_ty) }--  | otherwise-  = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand-    return ([], id, id, substTy subst fun_ty)   -- then there should be a function arrow-  where-    -- See Note [Join points and beta-redexes]-    apply_or_bind_then k arg (Lam bndr body)-      = mkCoreLet (NonRec bndr arg) (k body)    -- Important that arg is fresh!-    apply_or_bind_then k arg fun-      = k $ mkCoreApp (text "mkWWargs") fun arg-applyToVars :: [Var] -> CoreExpr -> CoreExpr-applyToVars vars fn = mkVarApps fn vars--mk_wrap_arg :: Unique -> Type -> Demand -> Id-mk_wrap_arg uniq ty dmd-  = mkSysLocalOrCoVar (fsLit "w") uniq ty-       `setIdDemandInfo` dmd--{- Note [Freshen WW arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Wen we do a worker/wrapper split, we must not in-scope names as the arguments-of the worker, else we'll get name capture.  E.g.--   -- y1 is in scope from further out-   f x = ..y1..--If we accidentally choose y1 as a worker argument disaster results:--   fww y1 y2 = let x = (y1,y2) in ...y1...--To avoid this:--  * We use a fresh unique for both type-variable and term-variable binders-    Originally we lacked this freshness for type variables, and that led-    to the very obscure #12562.  (A type variable in the worker shadowed-    an outer term-variable binding.)--  * Because of this cloning we have to substitute in the type/kind of the-    new binders.  That's why we carry the TCvSubst through mkWWargs.--    So we need a decent in-scope set, just in case that type/kind-    itself has foralls.  We get this from the free vars of the RHS of the-    function since those are the only variables that might be captured.-    It's a lazy thunk, which will only be poked if the type/kind has a forall.--    Another tricky case was when f :: forall a. a -> forall a. a->a-    (i.e. with shadowing), and then the worker used the same 'a' twice.--************************************************************************-*                                                                      *-\subsection{Strictness stuff}-*                                                                      *-************************************************************************--}--mkWWstr :: DynFlags-        -> FamInstEnvs-        -> Bool    -- True <=> INLINEABLE pragma on this function defn-                   -- See Note [Do not unpack class dictionaries]-        -> [Var]                                -- Wrapper args; have their demand info on them-                                                --  *Includes type variables*-        -> UniqSM (Bool,                        -- Is this useful-                   [Var],                       -- Worker args-                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call-                                                -- and without its lambdas-                                                -- This fn adds the unboxing--                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,-                                                -- and lacking its lambdas.-                                                -- This fn does the reboxing-mkWWstr dflags fam_envs has_inlineable_prag args-  = go args-  where-    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg--    go []           = return (False, [], nop_fn, nop_fn)-    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg-                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args-                         ; return ( useful1 || useful2-                                  , args1 ++ args2-                                  , wrap_fn1 . wrap_fn2-                                  , work_fn1 . work_fn2) }--{--Note [Unpacking arguments with product and polymorphic demands]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The argument is unpacked in a case if it has a product type and has a-strict *and* used demand put on it. I.e., arguments, with demands such-as the following ones:--   <S,U(U, L)>-   <S(L,S),U>--will be unpacked, but--   <S,U> or <B,U>--will not, because the pieces aren't used. This is quite important otherwise-we end up unpacking massive tuples passed to the bottoming function. Example:--        f :: ((Int,Int) -> String) -> (Int,Int) -> a-        f g pr = error (g pr)--        main = print (f fst (1, error "no"))--Does 'main' print "error 1" or "error no"?  We don't really want 'f'-to unbox its second argument.  This actually happened in GHC's onwn-source code, in Packages.applyPackageFlag, which ended up un-boxing-the enormous DynFlags tuple, and being strict in the-as-yet-un-filled-in pkgState files.--}--------------------------- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)---   *  wrap_fn assumes wrap_arg is in scope,---        brings into scope work_args (via cases)---   * work_fn assumes work_args are in scope, a---        brings into scope wrap_arg (via lets)--- See Note [How to do the worker/wrapper split]-mkWWstr_one :: DynFlags -> FamInstEnvs-            -> Bool    -- True <=> INLINEABLE pragma on this function defn-                       -- See Note [Do not unpack class dictionaries]-            -> Var-            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-mkWWstr_one dflags fam_envs has_inlineable_prag arg-  | isTyVar arg-  = return (False, [arg],  nop_fn, nop_fn)--  | isAbsDmd dmd-  , Just work_fn <- mk_absent_let dflags fam_envs arg-     -- Absent case.  We can't always handle absence for arbitrary-     -- unlifted types, so we need to choose just the cases we can-     -- (that's what mk_absent_let does)-  = return (True, [], nop_fn, work_fn)--  | isStrictDmd dmd-  , Just cs <- splitProdDmd_maybe dmd-      -- See Note [Unpacking arguments with product and polymorphic demands]-  , not (has_inlineable_prag && isClassPred arg_ty)-      -- See Note [Do not unpack class dictionaries]-  , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty-  , cs `equalLength` inst_con_arg_tys-      -- See Note [mkWWstr and unsafeCoerce]-  = unbox_one dflags fam_envs arg cs stuff--  | isSeqDmd dmd   -- For seqDmd, splitProdDmd_maybe will return Nothing, but-                   -- it should behave like <S, U(AAAA)>, for some suitable arity-  , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty-  , let abs_dmds = map (const absDmd) inst_con_arg_tys-  = unbox_one dflags fam_envs arg abs_dmds stuff--  | otherwise   -- Other cases-  = return (False, [arg], nop_fn, nop_fn)--  where-    arg_ty = idType arg-    dmd    = idDemandInfo arg--unbox_one :: DynFlags -> FamInstEnvs -> Var-          -> [Demand]-          -> (DataCon, [Type], [(Type, StrictnessMark)], Coercion)-          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-unbox_one dflags fam_envs arg cs-          (data_con, inst_tys, inst_con_arg_tys, co)-  = do { (uniq1:uniqs) <- getUniquesM-        ; let   -- See Note [Add demands for strict constructors]-                cs'       = addDataConStrictness data_con cs-                unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs'-                unbox_fn  = mkUnpackCase (Var arg) co uniq1-                                         data_con unpk_args-                arg_no_unf = zapStableUnfolding arg-                             -- See Note [Zap unfolding when beta-reducing]-                             -- in Simplify.hs; and see #13890-                rebox_fn   = Let (NonRec arg_no_unf con_app)-                con_app    = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co-         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args-         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }-                           -- Don't pass the arg, rebox instead-  where-    mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd-------------------------nop_fn :: CoreExpr -> CoreExpr-nop_fn body = body--addDataConStrictness :: DataCon -> [Demand] -> [Demand]--- See Note [Add demands for strict constructors]-addDataConStrictness con ds-  = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds )-    zipWith add ds strs-  where-    strs = dataConRepStrictness con-    add dmd str | isMarkedStrict str = strictifyDmd dmd-                | otherwise          = dmd--{- Note [How to do the worker/wrapper split]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The worker-wrapper transformation, mkWWstr_one, takes into account-several possibilities to decide if the function is worthy for-splitting:--1. If an argument is absent, it would be silly to pass it to-   the worker.  Hence the isAbsDmd case.  This case must come-   first because a demand like <S,A> or <B,A> is possible.-   E.g. <B,A> comes from a function like-       f x = error "urk"-   and <S,A> can come from Note [Add demands for strict constructors]--2. If the argument is evaluated strictly, and we can split the-   product demand (splitProdDmd_maybe), then unbox it and w/w its-   pieces.  For example--    f :: (Int, Int) -> Int-    f p = (case p of (a,b) -> a) + 1-  is split to-    f :: (Int, Int) -> Int-    f p = case p of (a,b) -> $wf a--    $wf :: Int -> Int-    $wf a = a + 1--  and-    g :: Bool -> (Int, Int) -> Int-    g c p = case p of (a,b) ->-               if c then a else b-  is split to-   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 the components are not used; that is, the-   usage is just 'Used' rather than 'UProd'. In this case-   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing-   a massive tuple which is barely used.  Example:--        f :: ((Int,Int) -> String) -> (Int,Int) -> a-        f g pr = error (g pr)--        main = print (f fst (1, error "no"))--   Here, f does not take 'pr' apart, and it's stupid to do so.-   Imagine that it had millions of fields. This actually happened-   in GHC itself where the tuple was DynFlags--3. A plain 'seqDmd', which is head-strict with usage UHead, can't-   be split by splitProdDmd_maybe.  But we want it to behave just-   like U(AAAA) for suitable number of absent demands. So we have-   a special case for it, with arity coming from the data constructor.--Note [Worker-wrapper for bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used not to split if the result is bottom.-[Justification:  there's no efficiency to be gained.]--But it's sometimes bad not to make a wrapper.  Consider-        fw = \x# -> let x = I# x# in case e of-                                        p1 -> error_fn x-                                        p2 -> error_fn x-                                        p3 -> the real stuff-The re-boxing code won't go away unless error_fn gets a wrapper too.-[We don't do reboxing now, but in general it's better to pass an-unboxed thing to f, and have it reboxed in the error cases....]--Note [Add demands for strict constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this program (due to Roman):--    data X a = X !a--    foo :: X Int -> Int -> Int-    foo (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, 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--* We leave the demand-analysis alone.  The demand on 'a' in the-  definition of 'foo' is <L, U(U)>; the strictness info is Lazy-  because foo's body may or may not evaluate 'a'; but the usage info-  says that 'a' is unpacked and its content is used.--* During worker/wrapper, if we unpack a strict constructor (as we do-  for 'foo'), we use 'addDataConStrictness' to bump up the strictness on-  the strict arguments of the data constructor.--* That in turn means that, if the usage info supports doing so-  (i.e. splitProdDmd_maybe returns Just), we will unpack that argument-  -- even though the original demand (e.g. on 'a') was lazy.--* What does "bump up the strictness" mean?  Just add a head-strict-  demand to the strictness!  Even for a demand like <L,A> we can-  safely turn it into <S,A>; remember case (1) of-  Note [How to do the worker/wrapper split].--The net effect is that the w/w transformation is more aggressive about-unpacking the strict arguments of a data constructor, when that-eagerness is supported by the usage info.--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--    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 [mkWWstr and unsafeCoerce]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-By using unsafeCoerce, it is possible to make the number of demands fail to-match the number of constructor arguments; this happened in #8037.-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 [Record evaluated-ness in worker/wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--   data T = MkT !Int Int--   f :: T -> T-   f x = e--and f's is strict, and has the CPR property.  The we are going to generate-this w/w split--   f x = case x of-           MkT x1 x2 -> case $wf x1 x2 of-                           (# r1, r2 #) -> MkT r1 r2--   $wfw x1 x2 = let x = MkT x1 x2 in-                case e of-                  MkT r1 r2 -> (# r1, r2 #)--Note that--* In the worker $wf, inside 'e' we can be sure that x1 will be-  evaluated (it came from unpacking the argument MkT.  But that's no-  immediately apparent in $wf--* In the wrapper 'f', which we'll inline at call sites, we can be sure-  that 'r1' has been evaluated (because it came from unpacking the result-  MkT.  But that is not immediately apparent from the wrapper code.--Missing these facts isn't unsound, but it loses possible future-opportunities for optimisation.--Solution: use setCaseBndrEvald when creating- (A) The arg binders x1,x2 in mkWstr_one-         See #13077, test T13077- (B) The result binders r1,r2 in mkWWcpr_help-         See Trace #13077, test T13077a-         And #13027 comment:20, item (4)-to record that the relevant binder is evaluated.---************************************************************************-*                                                                      *-         Type scrutiny that is specific to demand analysis-*                                                                      *-************************************************************************--Note [Do not unpack 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 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 switch-off the unpacking in mkWWstr_one (see the isClassPred test).--Historical note: #14955 describes how I got this fix wrong-the first time.--}--deepSplitProductType_maybe-    :: FamInstEnvs -> Type-    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)--- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)--- then  dc @ tys (args::arg_tys) :: rep_ty---       co :: ty ~ rep_ty--- Why do we return the strictness of the data-con arguments?--- Answer: see Note [Record evaluated-ness in worker/wrapper]-deepSplitProductType_maybe fam_envs ty-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty-                    `orElse` (mkRepReflCo ty, ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , Just con <- isDataProductTyCon_maybe tc-  , let arg_tys = dataConInstArgTys con tc_args-        strict_marks = dataConRepStrictness con-  = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co)-deepSplitProductType_maybe _ _ = Nothing--deepSplitCprType_maybe-    :: FamInstEnvs -> ConTag -> Type-    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)--- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)--- then  dc @ tys (args::arg_tys) :: rep_ty---       co :: ty ~ rep_ty--- Why do we return the strictness of the data-con arguments?--- Answer: see Note [Record evaluated-ness in worker/wrapper]-deepSplitCprType_maybe fam_envs con_tag ty-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty-                    `orElse` (mkRepReflCo ty, ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , isDataTyCon tc-  , let cons = tyConDataCons tc-  , cons `lengthAtLeast` con_tag -- This might not be true if we import the-                                 -- type constructor via a .hs-bool file (#8743)-  , let con = cons `getNth` (con_tag - fIRST_TAG)-        arg_tys = dataConInstArgTys con tc_args-        strict_marks = dataConRepStrictness con-  = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co)-deepSplitCprType_maybe _ _ _ = Nothing--findTypeShape :: FamInstEnvs -> Type -> TypeShape--- Uncover the arrow and product shape of a type--- The data type TypeShape is defined in Demand--- See Note [Trimming a demand to a type] in Demand-findTypeShape fam_envs ty-  | Just (tc, tc_args)  <- splitTyConApp_maybe ty-  , Just con <- isDataProductTyCon_maybe tc-  = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)--  | Just (_, res) <- splitFunTy_maybe ty-  = TsFun (findTypeShape fam_envs res)--  | Just (_, ty') <- splitForAllTy_maybe ty-  = findTypeShape fam_envs ty'--  | Just (_, ty') <- topNormaliseType_maybe fam_envs ty-  = findTypeShape fam_envs ty'--  | otherwise-  = TsUnk--{--************************************************************************-*                                                                      *-\subsection{CPR stuff}-*                                                                      *-************************************************************************---@mkWWcpr@ takes the worker/wrapper pair produced from the strictness-info and adds in the CPR transformation.  The worker returns an-unboxed tuple containing non-CPR components.  The wrapper takes this-tuple and re-produces the correct structured output.--The non-CPR results appear ordered in the unboxed tuple as if by a-left-to-right traversal of the result structure.--}--mkWWcpr :: Bool-        -> FamInstEnvs-        -> Type                              -- function body type-        -> CprResult                         -- CPR analysis results-        -> UniqSM (Bool,                     -- Is w/w'ing useful?-                   CoreExpr -> CoreExpr,     -- New wrapper-                   CoreExpr -> CoreExpr,     -- New worker-                   Type)                     -- Type of worker's body--mkWWcpr opt_CprAnal fam_envs body_ty cpr-    -- CPR explicitly turned off (or in -O0)-  | not opt_CprAnal = return (False, id, id, body_ty)-    -- CPR is turned on by default for -O and O2-  | otherwise-  = case asConCpr cpr of-       Nothing      -> return (False, id, id, body_ty)  -- No CPR info-       Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty-                    -> mkWWcpr_help stuff-                    |  otherwise-                       -- See Note [non-algebraic or open body type warning]-                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )-                       return (False, id, id, body_ty)--mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion)-             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)--mkWWcpr_help (data_con, inst_tys, arg_tys, co)-  | [arg1@(arg_ty1, _)] <- arg_tys-  , isUnliftedType arg_ty1-        -- Special case when there is a single result of unlifted type-        ---        -- Wrapper:     case (..call worker..) of x -> C x-        -- Worker:      case (   ..body..    ) of C x -> x-  = do { (work_uniq : arg_uniq : _) <- getUniquesM-       ; let arg       = mk_ww_local arg_uniq arg1-             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co--       ; return ( True-                , \ wkr_call -> mkDefaultCase wkr_call arg con_app-                , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)-                                -- varToCoreExpr important here: arg can be a coercion-                                -- Lacking this caused #10658-                , arg_ty1 ) }--  | otherwise   -- The general case-        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b-        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)-  = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM-       ; let wrap_wild   = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict)-             args        = zipWith mk_ww_local uniqs arg_tys-             ubx_tup_ty  = exprType ubx_tup_app-             ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)-             con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co-             tup_con     = tupleDataCon Unboxed (length arg_tys)--       ; return (True-                , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild-                                                (DataAlt tup_con) args con_app-                , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app-                , ubx_tup_ty ) }--mkUnpackCase ::  CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr--- (mkUnpackCase e co uniq Con args body)---      returns--- case e |> co of bndr { Con args -> body }--mkUnpackCase (Tick tickish e) co uniq con args body   -- See Note [Profiling and unpacking]-  = Tick tickish (mkUnpackCase e co uniq con args body)-mkUnpackCase scrut co uniq boxing_con unpk_args body-  = mkSingleAltCase casted_scrut bndr-                    (DataAlt boxing_con) unpk_args body-  where-    casted_scrut = scrut `mkCast` co-    bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)--{--Note [non-algebraic or open body type warning]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--There are a few cases where the W/W transformation is told that something-returns a constructor, but the type at hand doesn't really match this. One-real-world example involves unsafeCoerce:-  foo = IO a-  foo = unsafeCoerce c_exit-  foreign import ccall "c_exit" c_exit :: IO ()-Here CPR will tell you that `foo` returns a () constructor for sure, but trying-to create a worker/wrapper for type `a` obviously fails.-(This was a real example until ee8e792  in libraries/base.)--It does not seem feasible to avoid all such cases already in the analyser (and-after all, the analysis is not really wrong), so we simply do nothing here in-mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch-other cases where something went avoidably wrong.--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 [Profiling and unpacking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the original function looked like-        f = \ x -> {-# SCC "foo" #-} E--then we want the CPR'd worker to look like-        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)-and definitely not-        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)--This transform doesn't move work or allocation-from one cost centre to another.--Later [SDM]: presumably this is because we want the simplifier to-eliminate the case, and the scc would get in the way?  I'm ok with-including the case itself in the cost centre, since it is morally-part of the function (post transformation) anyway.---************************************************************************-*                                                                      *-\subsection{Utilities}-*                                                                      *-************************************************************************--Note [Absent errors]-~~~~~~~~~~~~~~~~~~~~-We make a new binding for Ids that are marked absent, thus-   let x = absentError "x :: Int"-The idea is that this binding will never be used; but if it-buggily is used we'll get a runtime error message.--Coping with absence for *unlifted* types is important; see, for-example, #4306 and #15627.  In the UnliftedRep case, we can-use LitRubbish, which we need to apply to the required type.-For the unlifted types of singleton kind like Float#, Addr#, etc. we-also find a suitable literal, using Literal.absentLiteralOf.  We don't-have literals for every primitive type, so the function is partial.--Note: I did try the experiment of using an error thunk for unlifted-things too, relying on the simplifier to drop it as dead code.-But this is fragile-- - It fails when profiling is on, which disables various optimisations-- - It fails when reboxing happens. E.g.-      data T = MkT Int Int#-      f p@(MkT a _) = ...g p....-   where g is /lazy/ in 'p', but only uses the first component.  Then-   'f' is /strict/ in 'p', and only uses the first component.  So we only-   pass that component to the worker for 'f', which reconstructs 'p' to-   pass it to 'g'.  Alas we can't say-       ...f (MkT a (absentError Int# "blah"))...-   bacause `MkT` is strict in its Int# argument, so we get an absentError-   exception when we shouldn't.  Very annoying!--So absentError is only used for lifted types.--}---- | Tries to find a suitable dummy RHS to bind the given absent identifier to.------ If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding--- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be--- found (currently only happens for bindings of 'VecRep' representation).-mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Maybe (CoreExpr -> CoreExpr)-mk_absent_let dflags fam_envs arg-  -- The lifted case: Bind 'absentError'-  -- See Note [Absent errors]-  | not (isUnliftedType arg_ty)-  = Just (Let (NonRec lifted_arg abs_rhs))-  -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@-  -- See Note [Absent errors]-  | [UnliftedRep] <- typePrimRep arg_ty-  = Just (Let (NonRec arg unlifted_rhs))-  -- The monomorphic unlifted cases: Bind to some literal, if possible-  -- See Note [Absent errors]-  | Just tc <- tyConAppTyCon_maybe nty-  , Just lit <- absentLiteralOf tc-  = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co)))-  | nty `eqType` voidPrimTy-  = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co)))-  | otherwise-  = WARN( True, text "No absent value for" <+> ppr arg_ty )-    Nothing -- Can happen for 'State#' and things of 'VecRep'-  where-    lifted_arg   = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr-              -- Note in strictness signature that this is bottoming-              -- (for the sake of the "empty case scrutinee not known to-              -- diverge for sure lint" warning)-    arg_ty       = idType arg-    (co, nty)    = topNormaliseType_maybe fam_envs arg_ty-                   `orElse` (mkRepReflCo arg_ty, arg_ty)-    abs_rhs      = mkAbsentErrorApp arg_ty msg-    msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)-                          (ppr arg <+> ppr (idType arg))-              -- We need to suppress uniques here because otherwise they'd-              -- end up in the generated code as strings. This is bad for-              -- determinism, because with different uniques the strings-              -- will have different lengths and hence different costs for-              -- the inliner leading to different inlining.-              -- See also Note [Unique Determinism] in Unique-    unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty]--mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id--- The StrictnessMark comes form the data constructor and says--- whether this field is strict--- See Note [Record evaluated-ness in worker/wrapper]-mk_ww_local uniq (ty,str)-  = setCaseBndrEvald str $-    mkSysLocalOrCoVar (fsLit "ww") uniq ty
compiler/typecheck/ClsInst.hs view
@@ -19,10 +19,10 @@ import TcTypeable import TcMType import TcEvidence-import Predicate+import GHC.Core.Predicate import GHC.Rename.Env( addUsedGRE )-import RdrName( lookupGRE_FieldLabel )-import InstEnv+import GHC.Types.Name.Reader( lookupGRE_FieldLabel )+import GHC.Core.InstEnv import Inst( instDFunType ) import FamInst( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) @@ -30,15 +30,15 @@ import TysPrim( eqPrimTyCon, eqReprPrimTyCon ) import PrelNames -import Id-import Type+import GHC.Types.Id+import GHC.Core.Type import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr ) -import Name   ( Name, pprDefinedAt )-import VarEnv ( VarEnv )-import DataCon-import TyCon-import Class+import GHC.Types.Name   ( Name, pprDefinedAt )+import GHC.Types.Var.Env ( VarEnv )+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Core.Class import GHC.Driver.Session import Outputable import Util( splitAtList, fstOf3 )@@ -200,7 +200,7 @@      pred = mkClassPred clas tys  match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult-             -- See Note [DFunInstType: instantiating types] in InstEnv+             -- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv match_one so dfun_id mb_inst_tys   = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys)        ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
compiler/typecheck/FamInst.hs view
@@ -16,31 +16,31 @@ import GhcPrelude  import GHC.Driver.Types-import FamInstEnv-import InstEnv( roughMatchTcs )-import Coercion+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv( roughMatchTcs )+import GHC.Core.Coercion import GHC.Core.Lint import TcEvidence import GHC.Iface.Load import TcRnMonad-import SrcLoc-import TyCon+import GHC.Types.SrcLoc as SrcLoc+import GHC.Core.TyCon import TcType-import CoAxiom+import GHC.Core.Coercion.Axiom import GHC.Driver.Session-import Module+import GHC.Types.Module import Outputable import Util-import RdrName-import DataCon ( dataConName )+import GHC.Types.Name.Reader+import GHC.Core.DataCon ( dataConName ) import Maybes-import TyCoRep-import TyCoFVs-import TyCoPpr ( pprWithExplicitKindsWhen )+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen ) import TcMType-import Name+import GHC.Types.Name import Panic-import VarSet+import GHC.Types.Var.Set import FV import Bag( Bag, unionBags, unitBag ) import Control.Monad@@ -183,13 +183,14 @@            -- Note [Linting type synonym applications].            case lintTypes dflags tcvs' (rhs':lhs') of              Nothing       -> pure ()-             Just fail_msg -> pprPanic "Core Lint error" (vcat [ fail_msg-                                                               , ppr fam_tc-                                                               , ppr subst-                                                               , ppr tvs'-                                                               , ppr cvs'-                                                               , ppr lhs'-                                                               , ppr rhs' ])+             Just fail_msg -> pprPanic "Core Lint error in newFamInst" $+                              vcat [ fail_msg+                                   , ppr fam_tc+                                   , ppr subst+                                   , ppr tvs'+                                   , ppr cvs'+                                   , ppr lhs'+                                   , ppr rhs' ]        ; return (FamInst { fi_fam      = tyConName fam_tc                          , fi_flavor   = flavor                          , fi_tcs      = roughMatchTcs lhs@@ -524,7 +525,7 @@   , let rep_tc = dataFamInstRepTyCon rep_fam         co     = mkUnbranchedAxInstCo Representational ax rep_args                                       (mkCoVarCos cvs)-  = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in FamInstEnv+  = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in GHC.Core.FamInstEnv     Just (rep_tc, rep_args, co)    | otherwise@@ -659,7 +660,7 @@ -- Check that the proposed new instance is OK, -- and then add it to the home inst env -- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]--- in FamInstEnv.hs+-- in GHC.Core.FamInstEnv addLocalFamInst :: (FamInstEnv,[FamInst])                 -> FamInst                 -> TcM (FamInstEnv, [FamInst])@@ -719,7 +720,7 @@        ; reportConflictInstErr fam_inst conflicts }  checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM ()-  -- see Note [Verifying injectivity annotation] in FamInstEnv, check 1B1.+  -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv, check 1B1. checkForInjectivityConflicts instEnvs famInst     | isTypeFamilyTyCon tycon   -- as opposed to data family tycon     , Injective inj <- tyConInjectivityInfo tycon@@ -736,7 +737,7 @@ -- this is possible and False if adding this equation would violate injectivity -- annotation. This looks only at the one equation; it does not look for -- interaction between equations. Use checkForInjectivityConflicts for that.--- Does checks (2)-(4) of Note [Verifying injectivity annotation] in FamInstEnv.+-- Does checks (2)-(4) of Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. checkInjectiveEquation :: FamInst -> TcM () checkInjectiveEquation famInst     | isTypeFamilyTyCon tycon@@ -744,7 +745,7 @@     , Injective inj <- tyConInjectivityInfo tycon = do     { dflags <- getDynFlags     ; let axiom = coAxiomSingleBranch fi_ax-          -- see Note [Verifying injectivity annotation] in FamInstEnv+          -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv     ; reportInjectivityErrors dflags fi_ax axiom inj     } @@ -921,7 +922,7 @@                   -> ( TyVarSet                      , Bool   -- True <=> one or more variable is used invisibly                      , Bool ) -- True <=> suggest -XUndecidableInstances--- See Note [Verifying injectivity annotation] in FamInstEnv.+-- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. -- This function implements check (4) described there, further -- described in Note [Coverage condition for injective type families]. -- In theory (and modulo the -XUndecidableInstances wrinkle),
compiler/typecheck/FunDeps.hs view
@@ -21,23 +21,23 @@  import GhcPrelude -import Name-import Var-import Class-import Predicate-import Type+import GHC.Types.Name+import GHC.Types.Var+import GHC.Core.Class+import GHC.Core.Predicate+import GHC.Core.Type import TcType( transSuperClasses )-import CoAxiom( TypeEqn )-import Unify-import InstEnv-import VarSet-import VarEnv-import TyCoFVs-import TyCoPpr( pprWithExplicitKindsWhen )+import GHC.Core.Coercion.Axiom( TypeEqn )+import GHC.Core.Unify+import GHC.Core.InstEnv+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen ) import FV import Outputable import ErrUtils( Validity(..), allValid )-import SrcLoc+import GHC.Types.SrcLoc import Util  import Pair             ( Pair(..) )
compiler/typecheck/Inst.hs view
@@ -40,40 +40,40 @@ import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp ) import {-# SOURCE #-}   TcUnify( unifyType, unifyKind ) -import BasicTypes ( IntegralLit(..), SourceText(..) )+import GHC.Types.Basic ( IntegralLit(..), SourceText(..) ) import FastString import GHC.Hs import TcHsSyn import TcRnMonad import Constraint-import Predicate+import GHC.Core.Predicate import TcOrigin import TcEnv import TcEvidence-import InstEnv+import GHC.Core.InstEnv import TysWiredIn  ( heqDataCon, eqDataCon ) import GHC.Core    ( isOrphan ) import FunDeps import TcMType-import Type-import TyCoRep-import TyCoPpr     ( debugPprType )+import GHC.Core.Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr ( debugPprType ) import TcType import GHC.Driver.Types-import Class( Class )-import MkId( mkDictFunId )+import GHC.Core.Class( Class )+import GHC.Types.Id.Make( mkDictFunId ) import GHC.Core( Expr(..) )  -- For the Coercion constructor-import Id-import Name-import Var      ( EvVar, tyVarName, VarBndr(..) )-import DataCon-import VarEnv+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Var ( EvVar, tyVarName, VarBndr(..) )+import GHC.Core.DataCon+import GHC.Types.Var.Env import PrelNames-import SrcLoc+import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import Util import Outputable-import BasicTypes ( TypeOrKind(..) )+import GHC.Types.Basic ( TypeOrKind(..) ) import qualified GHC.LanguageExtensions as LangExt  import Data.List ( sortBy )@@ -385,7 +385,7 @@ instDFunType :: DFunId -> [DFunInstType]              -> TcM ( [TcType]      -- instantiated argument types                     , TcThetaType ) -- instantiated constraint--- See Note [DFunInstType: instantiating types] in InstEnv+-- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv instDFunType dfun_id dfun_inst_tys   = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys        ; return (inst_tys, substTheta subst dfun_theta) }@@ -454,14 +454,14 @@ tcInstInvisibleTyBinder subst (Anon af ty)   | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty)     -- Equality is the *only* constraint currently handled in types.-    -- See Note [Constraints in kinds] in TyCoRep+    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep   = ASSERT( af == InvisArg )     do { co <- unifyKind Nothing k1 k2        ; arg' <- mk co        ; return (subst, arg') }    | otherwise  -- This should never happen-               -- See TyCoRep Note [Constraints in kinds]+               -- See GHC.Core.TyCo.Rep Note [Constraints in kinds]   = pprPanic "tcInvisibleTyBinder" (ppr ty)  -------------------------------@@ -472,7 +472,7 @@                           , Type  -- t1                           , Type  -- t2                           )--- See Note [Constraints in kinds] in TyCoRep+-- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep get_eq_tys_maybe ty   -- Lifted heterogeneous equality (~~)   | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty@@ -530,7 +530,8 @@     -- tauify the ExpType   = do { res_ty <- expTypeToType res_ty        ; dflags <- getDynFlags-       ; case shortCutLit dflags val res_ty of+       ; let platform = targetPlatform dflags+       ; case shortCutLit platform val res_ty of         -- Do not generate a LitInst for rebindable syntax.         -- Reason: If we do, tcSimplify will call lookupInst, which         --         will call tcSyntaxName, which does unification,
compiler/typecheck/TcAnnotations.hs view
@@ -13,15 +13,15 @@ import GhcPrelude  import {-# SOURCE #-} TcSplice ( runAnnotation )-import Module+import GHC.Types.Module import GHC.Driver.Session import Control.Monad ( when )  import GHC.Hs-import Name-import Annotations+import GHC.Types.Name+import GHC.Types.Annotations import TcRnMonad-import SrcLoc+import GHC.Types.SrcLoc import Outputable import GHC.Driver.Types
compiler/typecheck/TcArrows.hs view
@@ -28,13 +28,13 @@ import TcEnv import TcOrigin import TcEvidence-import Id( mkLocalId )+import GHC.Types.Id( mkLocalId ) import Inst import TysWiredIn-import VarSet+import GHC.Types.Var.Set import TysPrim-import BasicTypes( Arity )-import SrcLoc+import GHC.Types.Basic( Arity )+import GHC.Types.SrcLoc import Outputable import Util
compiler/typecheck/TcBackpack.hs view
@@ -19,16 +19,16 @@  import GhcPrelude -import BasicTypes (defaultFixity, TypeOrKind(..))+import GHC.Types.Basic (defaultFixity, TypeOrKind(..)) import GHC.Driver.Packages import TcRnExports import GHC.Driver.Session import GHC.Hs-import RdrName+import GHC.Types.Name.Reader import TcRnMonad import TcTyDecls-import InstEnv-import FamInstEnv+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv import Inst import GHC.IfaceToCore import TcMType@@ -39,27 +39,27 @@ import GHC.Iface.Load import GHC.Rename.Names import ErrUtils-import Id-import Module-import Name-import NameEnv-import NameSet-import Avail-import SrcLoc+import GHC.Types.Id+import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Avail+import GHC.Types.SrcLoc import GHC.Driver.Types import Outputable-import Type+import GHC.Core.Type import FastString import GHC.Rename.Fixity ( lookupFixityRn ) import Maybes import TcEnv-import Var+import GHC.Types.Var import GHC.Iface.Syntax import PrelNames import qualified Data.Map as Map  import GHC.Driver.Finder-import UniqDSet+import GHC.Types.Unique.DSet import GHC.Types.Name.Shape import TcErrors import TcUnify@@ -230,9 +230,17 @@  -- | Return this list of requirement interfaces that need to be merged -- to form @mod_name@, or @[]@ if this is not a requirement.-requirementMerges :: DynFlags -> ModuleName -> [IndefModule]-requirementMerges dflags mod_name =-    fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))+requirementMerges :: PackageState -> ModuleName -> [IndefModule]+requirementMerges pkgstate mod_name =+    fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))+    where+      -- update ComponentId cached details as they may have changed since the+      -- time the ComponentId was created+      fixupModule (IndefModule iud name) = IndefModule iud' name+         where+            iud' = iud { indefUnitIdComponentId = cid' }+            cid  = indefUnitIdComponentId iud+            cid' = updateComponentId pkgstate cid  -- | For a module @modname@ of type 'HscSource', determine the list -- of extra "imports" of other requirements which should be considered part of@@ -265,7 +273,8 @@             $ moduleFreeHolesPrecise (text "findExtraSigImports")                 (mkModule (IndefiniteUnitId iuid) mod_name)))   where-    reqs = requirementMerges (hsc_dflags hsc_env) modname+    pkgstate = pkgState (hsc_dflags hsc_env)+    reqs = requirementMerges pkgstate modname  findExtraSigImports' _ _ _ = return emptyUniqDSet @@ -528,10 +537,11 @@     let outer_mod = tcg_mod tcg_env         inner_mod = tcg_semantic_mod tcg_env         mod_name = moduleName (tcg_mod tcg_env)+        pkgstate = pkgState dflags      -- STEP 1: Figure out all of the external signature interfaces     -- we are going to merge in.-    let reqs = requirementMerges dflags mod_name+    let reqs = requirementMerges pkgstate mod_name      addErrCtxt (merge_msg mod_name reqs) $ do @@ -560,7 +570,7 @@             let insts = indefUnitIdInsts iuid                 isFromSignaturePackage =                     let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))-                        pkg = getInstalledPackageDetails dflags inst_uid+                        pkg = getInstalledPackageDetails pkgstate inst_uid                     in null (exposedModules pkg)             -- 3(a). Rename the exports according to how the dependency             -- was instantiated.  The resulting export list will be accurate
compiler/typecheck/TcBinds.hs view
@@ -21,7 +21,7 @@ import {-# SOURCE #-} TcExpr  ( tcMonoExpr ) import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) import GHC.Core (Tickish (..))-import CostCentre (mkUserCC, CCFlavour(DeclCC))+import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) import GHC.Driver.Session import FastString import GHC.Hs@@ -35,35 +35,35 @@ import TcHsType import TcPat import TcMType-import FamInstEnv( normaliseType )+import GHC.Core.FamInstEnv( normaliseType ) import FamInst( tcGetFamInstEnvs )-import TyCon+import GHC.Core.TyCon import TcType-import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)+import GHC.Core.Type (mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy) import TysPrim import TysWiredIn( mkBoxedTupleTy )-import Id-import Var-import VarSet-import VarEnv( TidyEnv )-import Module-import Name-import NameSet-import NameEnv-import SrcLoc+import GHC.Types.Id+import GHC.Types.Var as Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env( TidyEnv )+import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.SrcLoc import Bag import ErrUtils import Digraph import Maybes import Util-import BasicTypes+import GHC.Types.Basic import Outputable import PrelNames( ipClassName ) import TcValidity (checkValidType)-import UniqFM-import UniqSet+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set import qualified GHC.LanguageExtensions as LangExt-import ConLike+import GHC.Core.ConLike  import Control.Monad import Data.Foldable (find)@@ -679,7 +679,7 @@             -> LHsBind GhcRn   -- Must be a FunBind             -> TcM (LHsBinds GhcTcId, [TcId]) -- There is just one binding,---   it is a Funbind+--   it is a FunBind --   it has a complete type signature, tcPolyCheck prag_fn             (CompleteSig { sig_bndr  = poly_id
compiler/typecheck/TcCanonical.hs view
@@ -14,31 +14,31 @@ import GhcPrelude  import Constraint-import Predicate+import GHC.Core.Predicate import TcOrigin-import TcUnify( swapOverTyVars, metaTyVarUpdateOK )+import TcUnify( swapOverTyVars, metaTyVarUpdateOK, MetaTyVarUpdateResult(..) ) import TcType-import Type+import GHC.Core.Type import TcFlatten import TcSMonad import TcEvidence import TcEvTerm-import Class-import TyCon-import TyCoRep   -- cleverly decomposes types, good for completeness checking-import Coercion+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep   -- cleverly decomposes types, good for completeness checking+import GHC.Core.Coercion import GHC.Core-import Id( idType, mkTemplateLocals )-import FamInstEnv ( FamInstEnvs )+import GHC.Types.Id( idType, mkTemplateLocals )+import GHC.Core.FamInstEnv ( FamInstEnvs ) import FamInst ( tcTopNormaliseNewTypeTF_maybe )-import Var-import VarEnv( mkInScopeSet )-import VarSet( delVarSetList )-import OccName ( OccName )+import GHC.Types.Var+import GHC.Types.Var.Env( mkInScopeSet )+import GHC.Types.Var.Set( delVarSetList )+import GHC.Types.Name.Occurrence ( OccName ) import Outputable import GHC.Driver.Session( DynFlags )-import NameSet-import RdrName+import GHC.Types.Name.Set+import GHC.Types.Name.Reader import GHC.Hs.Types( HsIPName(..) )  import Pair@@ -48,7 +48,7 @@ import Control.Monad import Data.Maybe ( isJust ) import Data.List  ( zip4 )-import BasicTypes+import GHC.Types.Basic  import Data.Bifunctor ( bimap ) import Data.Foldable ( traverse_ )@@ -95,7 +95,7 @@       EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)                                   canEqNC    ev eq_rel ty1 ty2       IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr pred)-                                  canIrred ev+                                  canIrred OtherCIS ev       ForAllPred tvs theta p -> do traceTcS "canEvNC:forall" (ppr pred)                                    canForAllNC ev tvs theta p   where@@ -104,7 +104,7 @@ canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))   = canForAll ev pend_sc -canonicalize (CIrredCan { cc_ev = ev })+canonicalize (CIrredCan { cc_ev = ev, cc_status = status })   | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev)   = -- For insolubles (all of which are equalities, do /not/ flatten the arguments     -- In #14350 doing so led entire-unnecessary and ridiculously large@@ -114,7 +114,7 @@     canEqNC ev eq_rel ty1 ty2    | otherwise-  = canIrred ev+  = canIrred status ev  canonicalize (CDictCan { cc_ev = ev, cc_class  = cls                        , cc_tyargs = xis, cc_pend_sc = pend_sc })@@ -694,7 +694,7 @@ which looks for primitive equalities specially in the quantified constraints. -See also Note [Evidence for quantified constraints] in Predicate.+See also Note [Evidence for quantified constraints] in GHC.Core.Predicate.   ************************************************************************@@ -704,9 +704,9 @@ ************************************************************************ -} -canIrred :: CtEvidence -> TcS (StopOrContinue Ct)+canIrred :: CtIrredStatus -> CtEvidence -> TcS (StopOrContinue Ct) -- Precondition: ty not a tuple and no other evidence form-canIrred ev+canIrred status ev   = do { let pred = ctEvPred ev        ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)        ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred@@ -716,7 +716,7 @@            ClassPred cls tys     -> canClassNC new_ev cls tys            EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2            _                     -> continueWith $-                                    mkIrredCt new_ev } }+                                    mkIrredCt status new_ev } }  canHole :: CtEvidence -> OccName -> HoleSort -> TcS (StopOrContinue Ct) canHole ev occ hole_sort@@ -852,13 +852,16 @@        ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs        ; given_ev_vars <- mapM newEvVar (substTheta subst theta) -       ; (w_id, ev_binds)-             <- checkConstraintsTcS skol_info skol_tvs given_ev_vars $+       ; (lvl, (w_id, wanteds))+             <- pushLevelNoWorkList (ppr skol_info) $                 do { wanted_ev <- newWantedEvVarNC loc $                                   substTy subst pred                    ; return ( ctEvEvId wanted_ev                             , unitBag (mkNonCanonical wanted_ev)) } +      ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs+                                       given_ev_vars wanteds+       ; setWantedEvTerm dest $         EvFun { et_tvs = skol_tvs, et_given = given_ev_vars               , et_binds = ev_binds, et_body = w_id }@@ -981,6 +984,7 @@  -- When working with ReprEq, unwrap newtypes. -- See Note [Unwrap newtypes first]+-- This must be above the TyVarTy case, in order to guarantee (TyEq:N) can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2   | ReprEq <- eq_rel   , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1@@ -992,8 +996,10 @@  -- Then, get rid of casts can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2+  | not (isTyVarTy ty2)  -- See (3) in Note [Equalities with incompatible kinds]   = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _+  | not (isTyVarTy ty1)  -- See (3) in Note [Equalities with incompatible kinds]   = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1  -- NB: pattern match on True: we want only flat types sent to canEqTyVar.@@ -1048,8 +1054,8 @@ can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2   = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)        ; case eq_rel of -- See Note [Unsolved equalities]-            ReprEq -> continueWith (mkIrredCt ev)-            NomEq  -> continueWith (mkInsolubleCt ev) }+            ReprEq -> continueWith (mkIrredCt OtherCIS ev)+            NomEq  -> continueWith (mkIrredCt InsolubleCIS ev) }           -- No need to call canEqFailure/canEqHardFailure because they           -- flatten, and the types involved here are already flat @@ -1118,8 +1124,9 @@              empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1) -      ; all_co <- checkTvConstraintsTcS skol_info skol_tvs $-                  go skol_tvs empty_subst2 bndrs2+      ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $+                                    go skol_tvs empty_subst2 bndrs2+      ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds        ; setWantedEq orig_dest all_co       ; stopWith ev "Deferred polytype equality" } }@@ -1474,7 +1481,7 @@   -- See Note [Skolem abstract data] (at tyConSkolem)   | tyConSkolem tc1 || tyConSkolem tc2   = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)-       ; continueWith (mkIrredCt ev) }+       ; continueWith (mkIrredCt OtherCIS ev) }    -- Fail straight away for better error messages   -- See Note [Use canEqFailure in canDecomposableTyConApp]@@ -1648,7 +1655,7 @@ It all comes from the fact that newtypes aren't necessarily injective w.r.t. representational equality. -Furthermore, as explained in Note [NthCo and newtypes] in TyCoRep, we can't use+Furthermore, as explained in Note [NthCo and newtypes] in GHC.Core.TyCo.Rep, we can't use NthCo on representational coercions over newtypes. NthCo comes into play only when decomposing givens. @@ -1748,7 +1755,7 @@        ; traceTcS "canEqFailure with ReprEq" $          vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]        ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2-       ; continueWith (mkIrredCt new_ev) }+       ; continueWith (mkIrredCt OtherCIS new_ev) }  -- | Call when canonicalizing an equality fails with utterly no hope. canEqHardFailure :: CtEvidence@@ -1758,7 +1765,7 @@   = do { (s1, co1) <- flatten FM_SubstOnly ev ty1        ; (s2, co2) <- flatten FM_SubstOnly ev ty2        ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2-       ; continueWith (mkInsolubleCt new_ev) }+       ; continueWith (mkIrredCt InsolubleCIS new_ev) }  {- Note [Decomposing TyConApps]@@ -1944,118 +1951,61 @@   | k1 `tcEqType` k2   = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2 -  -- So the LHS and RHS don't have equal kinds-  -- Note [Flattening] in TcFlatten gives us (F2), which says that-  -- flattening is always homogeneous (doesn't change kinds). But-  -- perhaps by flattening the kinds of the two sides of the equality-  -- at hand makes them equal. So let's try that.   | otherwise-  = do { (flat_k1, k1_co) <- flattenKind loc flav k1  -- k1_co :: flat_k1 ~N kind(xi1)-       ; (flat_k2, k2_co) <- flattenKind loc flav k2  -- k2_co :: flat_k2 ~N kind(xi2)-       ; traceTcS "canEqTyVar tried flattening kinds"-                  (vcat [ sep [ parens (ppr tv1 <+> dcolon <+> ppr k1)-                              , text "~"-                              , parens (ppr xi2 <+> dcolon <+> ppr k2) ]-                        , ppr flat_k1-                        , ppr k1_co-                        , ppr flat_k2-                        , ppr k2_co ])--         -- We know the LHS is a tyvar. So let's dump all the coercions on the RHS-         -- If flat_k1 == flat_k2, let's dump all the coercions on the RHS and-         -- then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence-         -- (as an optimization, so that we don't have to flatten the kinds again)-         -- and then emit a kind equality in canEqTyVarHetero.-         -- See Note [Equalities with incompatible kinds]--       ; let role = eqRelRole eq_rel-       ; if flat_k1 `tcEqType` flat_k2-         then do { let rhs_kind_co = mkTcSymCo k2_co `mkTcTransCo` k1_co-                         -- :: kind(xi2) ~N kind(xi1)--                       new_rhs     = xi2 `mkCastTy` rhs_kind_co-                       ps_rhs      = ps_xi2 `mkCastTy` rhs_kind_co-                       rhs_co      = mkTcGReflLeftCo role xi2 rhs_kind_co--                 ; new_ev <- rewriteEqEvidence ev swapped xi1 new_rhs-                                               (mkTcReflCo role xi1) rhs_co-                       -- NB: rewriteEqEvidence executes a swap, if any, so we're-                       -- NotSwapped now.-                 ; canEqTyVarHomo new_ev eq_rel NotSwapped tv1 ps_xi1 new_rhs ps_rhs }-         else-    do { let sym_k1_co = mkTcSymCo k1_co  -- :: kind(xi1) ~N flat_k1-             sym_k2_co = mkTcSymCo k2_co  -- :: kind(xi2) ~N flat_k2--             new_lhs = xi1 `mkCastTy` sym_k1_co  -- :: flat_k1-             new_rhs = xi2 `mkCastTy` sym_k2_co  -- :: flat_k2-             ps_rhs  = ps_xi2 `mkCastTy` sym_k2_co--             lhs_co = mkTcGReflLeftCo role xi1 sym_k1_co-             rhs_co = mkTcGReflLeftCo role xi2 sym_k2_co-               -- lhs_co :: (xi1 |> sym k1_co) ~ xi1-               -- rhs_co :: (xi2 |> sym k2_co) ~ xi2+  = canEqTyVarHetero ev eq_rel swapped tv1 ps_xi1 k1 xi2 ps_xi2 k2 -       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co-         -- no longer swapped, due to rewriteEqEvidence-       ; canEqTyVarHetero new_ev eq_rel tv1 sym_k1_co flat_k1 ps_xi1-                                        new_rhs flat_k2 ps_rhs } }   where-    xi1 = mkTyVarTy tv1-     k1 = tyVarKind tv1     k2 = tcTypeKind xi2 -    loc  = ctEvLoc ev-    flav = ctEvFlavour ev--canEqTyVarHetero :: CtEvidence   -- :: (tv1 |> co1 :: ki1) ~ (xi2 :: ki2)-                 -> EqRel-                 -> TcTyVar -> TcCoercionN -> TcKind  -- tv1 |> co1 :: ki1-                 -> TcType            -- pretty tv1 (*without* the coercion)-                 -> TcType -> TcKind  -- xi2 :: ki2-                 -> TcType            -- pretty xi2+canEqTyVarHetero :: CtEvidence         -- :: (tv1 :: ki1) ~ (xi2 :: ki2)+                 -> EqRel -> SwapFlag+                 -> TcTyVar -> TcType  -- tv1, pretty tv1+                 -> TcKind             -- ki1+                 -> TcType -> TcType   -- xi2, pretty xi2 :: ki2+                 -> TcKind             -- ki2                  -> TcS (StopOrContinue Ct)-canEqTyVarHetero ev eq_rel tv1 co1 ki1 ps_tv1 xi2 ki2 ps_xi2+canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2   -- See Note [Equalities with incompatible kinds]-  | CtGiven { ctev_evar = evar } <- ev-    -- unswapped: tm :: (lhs :: ki1) ~ (rhs :: ki2)-    -- swapped  : tm :: (rhs :: ki2) ~ (lhs :: ki1)-  = do { let kind_co = mkTcKindCo (mkTcCoVarCo evar)-       ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)-       ; let  -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)   (whether swapped or not)+  = do { kind_co <- emit_kind_co   -- :: ki2 ~N ki1++       ; let  -- kind_co :: (ki2 :: *) ~N (ki1 :: *)   (whether swapped or not)               -- co1     :: kind(tv1) ~N ki1-              -- homo_co :: ki2 ~N kind(tv1)-             homo_co = mkTcSymCo (ctEvCoercion kind_ev) `mkTcTransCo` mkTcSymCo co1-             rhs'    = mkCastTy xi2 homo_co     -- :: kind(tv1)-             ps_rhs' = mkCastTy ps_xi2 homo_co  -- :: kind(tv1)-             rhs_co  = mkTcGReflLeftCo role xi2 homo_co-               -- rhs_co :: (xi2 |> homo_co :: kind(tv1)) ~ xi2+             rhs'    = xi2    `mkCastTy` kind_co   -- :: ki1+             ps_rhs' = ps_xi2 `mkCastTy` kind_co   -- :: ki1+             rhs_co  = mkTcGReflLeftCo role xi2 kind_co+               -- rhs_co :: (xi2 |> kind_co) ~ xi2 -             lhs'   = mkTyVarTy tv1       -- :: kind(tv1)-             lhs_co = mkTcGReflRightCo role lhs' co1-               -- lhs_co :: (tv1 :: kind(tv1)) ~ (tv1 |> co1 :: ki1)+             lhs'   = mkTyVarTy tv1  -- same as old lhs+             lhs_co = mkTcReflCo role lhs' -       ; traceTcS "Hetero equality gives rise to given kind equality"-           (ppr kind_ev <+> dcolon <+> ppr kind_pty)-       ; emitWorkNC [kind_ev]-       ; type_ev <- rewriteEqEvidence ev NotSwapped lhs' rhs' lhs_co rhs_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' rhs' lhs_co rhs_co++          -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more        ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' }+  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) } -  -- See Note [Equalities with incompatible kinds]-  | otherwise   -- Wanted and Derived-                -- NB: all kind equalities are Nominal-  = do { emitNewDerivedEq kind_loc Nominal ki1 ki2-             -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)-       ; traceTcS "Hetero equality gives rise to derived kind equality" $-           ppr ev-       ; continueWith (mkIrredCt ev) }+      | otherwise+      = unifyWanted kind_loc Nominal ki2 ki1 -  where-    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2-    kind_loc = mkKindLoc (mkTyVarTy tv1 `mkCastTy` co1) xi2 loc+    loc      = ctev_loc ev+    role     = eqRelRole eq_rel+    kind_loc = mkKindLoc (mkTyVarTy tv1) xi2 loc+    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1 -    loc  = ctev_loc ev-    role = eqRelRole eq_rel+    maybe_sym = case swapped of+          IsSwapped  -> id         -- if the input is swapped, then we already+                                   -- will have k2 ~ k1+          NotSwapped -> mkTcSymCo  -- guaranteed that tcTypeKind lhs == tcTypeKind rhs canEqTyVarHomo :: CtEvidence@@ -2070,14 +2020,10 @@   = canEqReflexive ev eq_rel (mkTyVarTy tv1)     -- we don't need to check co because it must be reflexive +    -- this guarantees (TyEq:TV)   | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2   , swapOverTyVars tv1 tv2   = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)-         -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten-         -- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True }-         -- Flatten the RHS less vigorously, to avoid gratuitous flattening-         -- True <=> xi2 should not itself be a type-function application-        ; let role    = eqRelRole eq_rel              sym_co2 = mkTcSymCo co2              ty1     = mkTyVarTy tv1@@ -2108,11 +2054,17 @@ -- LHS is an inert type variable, -- and RHS is fully rewritten, but with type synonyms -- preserved as much as possible+-- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K)+-- the "flat" requirement guarantees (TyEq:AFF)+-- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqTyVarHomo canEqTyVar2 dflags ev eq_rel swapped tv1 rhs-  | Just rhs' <- metaTyVarUpdateOK dflags tv1 rhs  -- No occurs check+    -- this next line checks also for coercion holes; see+    -- Note [Equalities with incompatible kinds]+  | MTVU_OK rhs' <- mtvu  -- No occurs check      -- Must do the occurs check even on tyvar/tyvar      -- equalities, in case have  x ~ (y :: ..x...)      -- #12593+     -- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H)   = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2        ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1                                 , cc_rhs = rhs', cc_eq_rel = eq_rel }) }@@ -2121,20 +2073,30 @@                -- We must not use it for further rewriting!   = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs)        ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2-       ; if isInsolubleOccursCheck eq_rel tv1 rhs-         then continueWith (mkInsolubleCt new_ev)+       ; let status | isInsolubleOccursCheck eq_rel tv1 rhs+                    = InsolubleCIS              -- If we have a ~ [a], it is not canonical, and in particular              -- we don't want to rewrite existing inerts with it, otherwise              -- we'd risk divergence in the constraint solver -         else continueWith (mkIrredCt new_ev) }+                    | MTVU_HoleBlocker <- mtvu+                    = BlockedCIS+             -- This is the case detailed in+             -- Note [Equalities with incompatible kinds]++                    | otherwise+                    = OtherCIS              -- A representational equality with an occurs-check problem isn't              -- insoluble! For example:              --   a ~R b a              -- We might learn that b is the newtype Id.              -- But, the occurs-check certainly prevents the equality from being              -- canonical, and we might loop if we were to use it in rewriting.++       ; continueWith (mkIrredCt status new_ev) }   where+    mtvu = metaTyVarUpdateOK dflags tv1 rhs+     role = eqRelRole eq_rel      lhs = mkTyVarTy tv1@@ -2158,58 +2120,93 @@    (tv :: k1) ~ (rhs :: k2) -where k1 and k2 differ? This Note explores this treacherous area.+where k1 and k2 differ? Easy: we create a coercion that relates k1 and+k2 and use this to cast. To wit, from -We must proceed differently here depending on whether we have a Wanted-or a Given. Consider this:+  [X] (tv :: k1) ~ (rhs :: k2) - [W] w :: (alpha :: k) ~ (Int :: Type)+we go to -where k is a skolem. One possible way forward is this:+  [noDerived X] co :: k2 ~ k1+  [X]           (tv :: k1) ~ ((rhs |> co) :: k1) - [W] co :: k ~ Type- [W] w :: (alpha :: k) ~ (Int |> sym co :: k)+where -The next step will be to unify+  noDerived G = G+  noDerived _ = W -  alpha := Int |> sym co+Wrinkles: -Now, consider what error we'll report if we can't solve the "co"-wanted. Its CtOrigin is the w wanted... which now reads (after zonking)-Int ~ Int. The user thus sees that GHC can't solve Int ~ Int, which-is embarrassing. See #11198 for more tales of destruction.+ (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. -The reason for this odd behavior is much the same as-Note [Wanteds do not rewrite Wanteds] in Constraint: note that the-new `co` is a Wanted.+ (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 to not rewrite Wanteds]+     in Constraint. The problem is about poor error messages. See #11198 for+     tales of destruction. -The solution is then not to use `co` to "rewrite" -- that is, cast -- `w`, but-instead to keep `w` heterogeneous and irreducible. Given that we're not using-`co`, there is no reason to collect evidence for it, so `co` is born a-Derived, with a CtOrigin of KindEqOrigin. When the Derived is solved (by-unification), the original wanted (`w`) will get kicked out. We thus get+     So, we have an invariant on CTyEqCan (TyEq:H) that the RHS does not have+     any coercion holes. This is checked in metaTyVarUpdateOK. We also+     must be sure to kick out any constraints that mention coercion holes+     when those holes get filled in. -[D] _ :: k ~ Type-[W] w :: (alpha :: k) ~ (Int :: Type)+     (2a) We don't want to do this for CoercionHoles that witness+          CFunEqCans (that are produced by the flattener), as these will disappear+          once we unflatten. So we remember in the CoercionHole structure+          whether the presence of the hole should block substitution or not.+          A bit gross, this. -Note that the Wanted is unchanged and will be irreducible. This all happens-in canEqTyVarHetero.+     (2b) We must now absolutely make sure to kick out any constraints that+          mention a newly-filled-in coercion hole. This is done in+          kickOutAfterFillingCoercionHole. -Note that, if we had [G] co1 :: k ~ Type available, then we never get-to canEqTyVarHetero: canEqTyVar tries flattening the kinds first. If-we have [G] co1 :: k ~ Type, then flattening the kind of alpha would-rewrite k to Type, and we would end up in canEqTyVarHomo.+ (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the+     algorithm detailed here, producing [W] co :: k2 ~ k1, and adding+     [W] (a :: k1) ~ ((rhs |> co) :: k1) to the irreducibles. Some time+     later, we solve co, and fill in co's coercion hole. This kicks out+     the irreducible as described in (2b).+     But now, during canonicalization, we see the cast+     and remove it, in canEqCast. By the time we get into canEqTyVar, the equality+     is heterogeneous again, and the process repeats. -Successive canonicalizations of the same Wanted may produce-duplicate Deriveds. Similar duplications can happen with fundeps, and there-seems to be no easy way to avoid. I expect this case to be rare.+     To avoid this, we don't strip casts off a type if the other type+     in the equality is a tyvar. And this is an improvement regardless:+     because tyvars can, generally, unify with casted types, there's no+     reason to go through the work of stripping off the cast when the+     cast appears opposite a tyvar. This is implemented in the cast case+     of can_eq_nc'. -For Givens, this problem (the Wanteds-rewriting-Wanteds action of-a kind coercion) doesn't bite, so a heterogeneous Given gives-rise to a Given kind equality. No Deriveds here. We thus homogenise-the Given (see the "homo_co" in the Given case in canEqTyVarHetero) and-carry on with a homogeneous equality constraint.+ (4) Reporting an error for a constraint that is blocked only because+     of wrinkle (2) 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 CtIrredStatus 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+the heterogeneous equality as irreducible. But this new approach is much+more direct. And it doesn't produce duplicate Deriveds (as the old one did).+ Note [Type synonyms and canonicalization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We treat type synonym applications as xi types, that is, they do not@@ -2372,7 +2369,6 @@                                         --              or orhs ~ olhs (swapped)                   -> SwapFlag                   -> TcType -> TcType   -- New predicate  nlhs ~ nrhs-                                        -- Should be zonked, because we use tcTypeKind on nlhs/nrhs                   -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs                   -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs                   -> TcS CtEvidence     -- Of type nlhs ~ nrhs@@ -2407,16 +2403,21 @@        ; 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)-       ; let co = maybeSym swapped $-                  mkSymCo lhs_co-                  `mkTransCo` hole_co-                  `mkTransCo` rhs_co-       ; setWantedEq dest co-       ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])-       ; return new_ev }+  = case dest of+      HoleDest hole ->+        do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) 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)+           ; let co = maybeSym swapped $+                      mkSymCo lhs_co+                      `mkTransCo` hole_co+                      `mkTransCo` rhs_co+           ; setWantedEq dest co+           ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])+           ; return new_ev }++      _ -> panic "rewriteEqEvidence"  #if __GLASGOW_HASKELL__ <= 810   | otherwise
compiler/typecheck/TcClassDcl.hs view
@@ -32,29 +32,29 @@ import TcUnify import TcHsType import TcMType-import Type     ( piResultTys )-import Predicate+import GHC.Core.Type     ( piResultTys )+import GHC.Core.Predicate import TcOrigin import TcType import TcRnMonad import GHC.Driver.Phases (HscSource(..)) import BuildTyCl( TcMethInfo )-import Class-import Coercion ( pprCoAxiom )+import GHC.Core.Class+import GHC.Core.Coercion ( pprCoAxiom ) import GHC.Driver.Session import FamInst-import FamInstEnv-import Id-import Name-import NameEnv-import NameSet-import Var-import VarEnv+import GHC.Core.FamInstEnv+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Var+import GHC.Types.Var.Env import Outputable-import SrcLoc-import TyCon+import GHC.Types.SrcLoc+import GHC.Core.TyCon import Maybes-import BasicTypes+import GHC.Types.Basic import Bag import FastString import BooleanFormula@@ -284,7 +284,7 @@                                         , sig_loc   = getLoc (hsSigType hs_ty) }         ; (ev_binds, (tc_bind, _))-               <- checkConstraints (TyConSkol ClassFlavour (getName clas)) tyvars [this_dict] $+               <- checkConstraints skol_info tyvars [this_dict] $                   tcPolyCheck no_prag_fn local_dm_sig                               (L bind_loc lm_bind) @@ -305,6 +305,7 @@    | otherwise = pprPanic "tcDefMeth" (ppr sel_id)   where+    skol_info = TyConSkol ClassFlavour (getName clas)     sel_name = idName sel_id     no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;                                 -- they are all for meth_id
compiler/typecheck/TcDefaults.hs view
@@ -11,7 +11,7 @@ import GhcPrelude  import GHC.Hs-import Class+import GHC.Core.Class import TcRnMonad import TcEnv import TcHsType@@ -20,7 +20,7 @@ import TcValidity import TcType import PrelNames-import SrcLoc+import GHC.Types.SrcLoc import Outputable import FastString import qualified GHC.LanguageExtensions as LangExt
compiler/typecheck/TcDeriv.hs view
@@ -24,7 +24,7 @@ import TcRnMonad import FamInst import TcOrigin-import Predicate+import GHC.Core.Predicate import TcDerivInfer import TcDerivUtils import TcValidity( allDistinctTyVars )@@ -32,36 +32,35 @@ import TcEnv import TcGenDeriv                       -- Deriv stuff import TcValidity( checkValidInstHead )-import InstEnv+import GHC.Core.InstEnv import Inst-import FamInstEnv+import GHC.Core.FamInstEnv import TcHsType-import TyCoRep-import TyCoPpr    ( pprTyVars )+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr ( pprTyVars )  import GHC.Rename.Names  ( extendGlobalRdrEnvRn ) import GHC.Rename.Binds import GHC.Rename.Env-import GHC.Rename.Utils  ( bindLocalNamesFV ) import GHC.Rename.Source ( addTcgDUs )-import Avail+import GHC.Types.Avail -import Unify( tcUnifyTy )-import Class-import Type+import GHC.Core.Unify( tcUnifyTy )+import GHC.Core.Class+import GHC.Core.Type import ErrUtils-import DataCon+import GHC.Core.DataCon import Maybes-import RdrName-import Name-import NameSet-import TyCon+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.Name.Set as NameSet+import GHC.Core.TyCon import TcType-import Var-import VarEnv-import VarSet+import GHC.Types.Var as Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set import PrelNames-import SrcLoc+import GHC.Types.SrcLoc import Util import Outputable import FastString@@ -315,12 +314,11 @@                             , ib_pragmas = sigs                             , ib_extensions = exts -- Only for type-checking                             , ib_derived = sa } })-        =  ASSERT( null sigs )-           bindLocalNamesFV tyvars $-           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []+        =  do { (rn_binds, rn_sigs, fvs) <- rnMethodBinds False (is_cls_nm inst)+                                                          tyvars binds sigs               ; let binds' = InstBindings { ib_binds = rn_binds                                           , ib_tyvars = tyvars-                                          , ib_pragmas = []+                                          , ib_pragmas = rn_sigs                                           , ib_extensions = exts                                           , ib_derived = sa }               ; return (inst_info { iBinds = binds' }, fvs) }@@ -888,7 +886,7 @@       TyCon   -- The family TyCon       [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)               -- No shorter in length than the tyConTyVars of the family TyCon-              -- How could it be longer? See [Arity of data families] in FamInstEnv+              -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv  Notice that the arg tys might not be the same as the family tycon arity (= length tyConTyVars).@@ -1314,7 +1312,7 @@       return x = MkT [x]       ... etc ... -See Note [Eta reduction for data families] in FamInstEnv+See Note [Eta reduction for data families] in GHC.Core.FamInstEnv  %************************************************************************ %*                                                                      *@@ -1846,7 +1844,7 @@ genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism                  , ds_tys = tys, ds_cls = clas, ds_loc = loc                  , ds_standalone_wildcard = wildcard })-  = do (meth_binds, deriv_stuff, unusedNames)+  = do (meth_binds, meth_sigs, deriv_stuff, unusedNames)          <- set_span_and_ctxt $             genDerivStuff mechanism loc clas tys tvs        let mk_inst_info theta = set_span_and_ctxt $ do@@ -1858,7 +1856,7 @@                        , iBinds  = InstBindings                                      { ib_binds = meth_binds                                      , ib_tyvars = map Var.varName tvs-                                     , ib_pragmas = []+                                     , ib_pragmas = meth_sigs                                      , ib_extensions = extensions                                      , ib_derived = True } }        return (mk_inst_info, deriv_stuff, unusedNames)@@ -1866,9 +1864,14 @@     extensions :: [LangExt.Extension]     extensions       | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism-        -- Both these flags are needed for higher-rank uses of coerce-        -- See Note [Newtype-deriving instances] in TcGenDeriv-      = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]+      = [+          -- Both these flags are needed for higher-rank uses of coerce...+          LangExt.ImpredicativeTypes, LangExt.RankNTypes+          -- ...and this flag is needed to support the instance signatures+          -- that bring type variables into scope.+          -- See Note [Newtype-deriving instances] in TcGenDeriv+        , LangExt.InstanceSigs+        ]       | otherwise       = [] @@ -2035,7 +2038,7 @@  genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class               -> [Type] -> [TyVar]-              -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])+              -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]) genDerivStuff mechanism loc clas inst_tys tyvars   = case mechanism of       -- See Note [Bindings for Generalised Newtype Deriving]@@ -2045,7 +2048,8 @@       -- Try a stock deriver       DerivSpecStock { dsm_stock_dit    = DerivInstTys{dit_rep_tc = rep_tc}                      , dsm_stock_gen_fn = gen_fn }-        -> gen_fn loc rep_tc inst_tys+        -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys+              pure (binds, [], faminsts, field_names)        -- Try DeriveAnyClass       DerivSpecAnyClass -> do@@ -2059,7 +2063,7 @@                  , ppr "genDerivStuff: bad derived class" <+> ppr clas )           mapM (tcATDefault loc mini_subst emptyNameSet)                (classATItems clas)-        return ( emptyBag -- No method bindings are needed...+        return ( emptyBag, [] -- No method bindings are needed...                , listToBag (map DerivFamInst (concat tyfam_insts))                -- ...but we may need to generate binding for associated type                -- family default instances.@@ -2071,8 +2075,8 @@         -> gen_newtype_or_via via_ty   where     gen_newtype_or_via ty = do-      (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty-      return (binds, faminsts, [])+      (binds, sigs, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty+      return (binds, sigs, faminsts, [])  {- Note [Bindings for Generalised Newtype Deriving]
compiler/typecheck/TcDerivInfer.hs view
@@ -16,9 +16,9 @@ import GhcPrelude  import Bag-import BasicTypes-import Class-import DataCon+import GHC.Types.Basic+import GHC.Core.Class+import GHC.Core.DataCon import ErrUtils import Inst import Outputable@@ -33,19 +33,19 @@ import TcRnMonad import TcOrigin import Constraint-import Predicate+import GHC.Core.Predicate import TcType-import TyCon-import TyCoPpr (pprTyVars)-import Type+import GHC.Core.TyCon+import GHC.Core.TyCo.Ppr (pprTyVars)+import GHC.Core.Type import TcSimplify import TcValidity (validDerivPred) import TcUnify (buildImplicationFor, checkConstraints) import TysWiredIn (typeToTypeKind)-import Unify (tcUnifyTy)+import GHC.Core.Unify (tcUnifyTy) import Util-import Var-import VarSet+import GHC.Types.Var+import GHC.Types.Var.Set  import Control.Monad import Control.Monad.Trans.Class  (lift)
compiler/typecheck/TcDerivUtils.hs view
@@ -26,21 +26,21 @@ import GhcPrelude  import Bag-import BasicTypes-import Class-import DataCon+import GHC.Types.Basic+import GHC.Core.Class+import GHC.Core.DataCon import GHC.Driver.Session import ErrUtils import GHC.Driver.Types (lookupFixity, mi_fix) import GHC.Hs import Inst-import InstEnv-import GHC.Iface.Load (loadInterfaceForName)-import Module         (getModule)-import Name+import GHC.Core.InstEnv+import GHC.Iface.Load   (loadInterfaceForName)+import GHC.Types.Module (getModule)+import GHC.Types.Name import Outputable import PrelNames-import SrcLoc+import GHC.Types.SrcLoc import TcGenDeriv import TcGenFunctor import TcGenGenerics@@ -48,11 +48,11 @@ import TcRnMonad import TcType import THNames (liftClassKey)-import TyCon-import TyCoPpr (pprSourceTyCon)-import Type+import GHC.Core.TyCon+import GHC.Core.TyCo.Ppr (pprSourceTyCon)+import GHC.Core.Type import Util-import VarSet+import GHC.Types.Var.Set  import Control.Monad.Trans.Reader import Data.Maybe@@ -912,7 +912,7 @@     why = sep [ quotes (pprSourceTyCon rep_tc) <+>                   text "must be an enumeration type"               , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]-                  -- See Note [Enumeration types] in TyCon+                  -- See Note [Enumeration types] in GHC.Core.TyCon  cond_isProduct :: Condition cond_isProduct _ _ rep_tc@@ -968,7 +968,7 @@                       , ft_fun = \x y -> if allowFunctions then x `andValid` y                                                            else NotValid (badCon con functions)                       , ft_tup = \_ xs  -> allValid xs-                      , ft_ty_app = \_ x   -> x+                      , ft_ty_app = \_ _ x -> x                       , ft_bad_app = NotValid (badCon con wrong_arg)                       , ft_forall = \_ x   -> x }
compiler/typecheck/TcEnv.hs view
@@ -81,26 +81,26 @@ import GHC.Iface.Load import PrelNames import TysWiredIn-import Id-import Var-import RdrName-import InstEnv-import DataCon ( DataCon )-import PatSyn  ( PatSyn )-import ConLike-import TyCon-import Type-import CoAxiom-import Class-import Name-import NameSet-import NameEnv-import VarEnv+import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Name.Reader+import GHC.Core.InstEnv+import GHC.Core.DataCon ( DataCon )+import GHC.Core.PatSyn  ( PatSyn )+import GHC.Core.ConLike+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.Coercion.Axiom+import GHC.Core.Class+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Var.Env import GHC.Driver.Types import GHC.Driver.Session-import SrcLoc-import BasicTypes hiding( SuccessFlag(..) )-import Module+import GHC.Types.SrcLoc+import GHC.Types.Basic hiding( SuccessFlag(..) )+import GHC.Types.Module import Outputable import Encoding import FastString@@ -456,6 +456,9 @@                 Just (ATcId { tct_id = id }) ->  id                 _ -> pprPanic "tcLookupLocalIds" (ppr name) +-- inferInitialKind has made a suitably-shaped kind for the type or class+-- Look it up in the local environment. This is used only for tycons+-- that we're currently type-checking, so we're sure to find a TcTyCon. tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon tcLookupTcTyCon name = do     thing <- tcLookup name@@ -952,7 +955,8 @@    = hang (pprInstanceHdr (iSpec info) <+> text "where")         2 (details (iBinds info))   where-    details (InstBindings { ib_binds = b }) = pprLHsBinds b+    details (InstBindings { ib_pragmas = p, ib_binds = b }) =+      pprDeclList (pprLHsBindsForUser b p)  simpleInstInfoClsTy :: InstInfo a -> (Class, Type) simpleInstInfoClsTy info = case instanceHead (iSpec info) of
compiler/typecheck/TcEnv.hs-boot view
@@ -1,7 +1,7 @@ module TcEnv where  import TcRnTypes( TcM )-import VarEnv( TidyEnv )+import GHC.Types.Var.Env( TidyEnv )  -- Annoyingly, there's a recursion between tcInitTidyEnv -- (which does zonking and hence needs TcMType) and
compiler/typecheck/TcErrors.hs view
@@ -20,48 +20,48 @@ import TcRnTypes import TcRnMonad import Constraint-import Predicate+import GHC.Core.Predicate import TcMType import TcUnify( occCheckForErrors, MetaTyVarUpdateResult(..) ) import TcEnv( tcInitTidyEnv ) import TcType import TcOrigin import GHC.Rename.Unbound ( unknownNameSuggestions )-import Type-import TyCoRep-import TyCoPpr          ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE )-import Unify            ( tcMatchTys )-import Module+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr  ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE )+import GHC.Core.Unify     ( tcMatchTys )+import GHC.Types.Module import FamInst-import FamInstEnv       ( flattenTys )+import GHC.Core.FamInstEnv ( flattenTys ) import Inst-import InstEnv-import TyCon-import Class-import DataCon+import GHC.Core.InstEnv+import GHC.Core.TyCon+import GHC.Core.Class+import GHC.Core.DataCon import TcEvidence import TcEvTerm import GHC.Hs.Binds ( PatSynBind(..) )-import Name-import RdrName ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual )+import GHC.Types.Name+import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual ) import PrelNames ( typeableClassName )-import Id-import Var-import VarSet-import VarEnv-import NameSet+import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Name.Set import Bag import ErrUtils         ( ErrMsg, errDoc, pprLocErrMsg )-import BasicTypes-import ConLike          ( ConLike(..))+import GHC.Types.Basic+import GHC.Core.ConLike ( ConLike(..)) import Util import FastString import Outputable-import SrcLoc+import GHC.Types.SrcLoc import GHC.Driver.Session import ListSetOps       ( equivClasses ) import Maybes-import Pair import qualified GHC.LanguageExtensions as LangExt import FV ( fvVarList, unionFV ) @@ -210,10 +210,9 @@        ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)         ; wanted <- zonkWC wanted   -- Zonk to reveal all information-       ; env0 <- tcInitTidyEnv             -- If we are deferring we are going to need /all/ evidence around,             -- including the evidence produced by unflattening (zonkWC)-       ; let tidy_env = tidyFreeTyCoVars env0 free_tvs+       ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs              free_tvs = tyCoVarsOfWCList wanted         ; traceTc "reportUnsolved (after zonking):" $@@ -550,7 +549,7 @@             -- See Note [Do not report derived but soluble errors]       ; mapBagM_ (reportImplic ctxt2) implics }-            -- NB ctxt1: don't suppress inner insolubles if there's only a+            -- 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)  where@@ -563,29 +562,36 @@     -- (see TcRnTypes.insolubleCt) is caught here, otherwise     -- we might suppress its error message, and proceed on past     -- type checking to get a Lint error later-    report1 = [ ("Out of scope", is_out_of_scope,    True,  mkHoleReporter tidy_cts)-              , ("Holes",        is_hole,            False, mkHoleReporter tidy_cts)-              , ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)+    report1 = [ ("Out of scope", unblocked is_out_of_scope,    True,  mkHoleReporter tidy_cts)+              , ("Holes",        unblocked is_hole,            False, mkHoleReporter tidy_cts)+              , ("custom_error", unblocked is_user_type_error, True,  mkUserTypeErrorReporter)                , given_eq_spec-              , ("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)+              , ("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)                    -- 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 TcCanonical-              , ("Homo eqs",      is_homo_equality, True,  mkGroupReporter mkEqErr)-              , ("Other eqs",     is_equality,      False, mkGroupReporter mkEqErr) ]+              , ("Homo eqs",      unblocked is_homo_equality, True,  mkGroupReporter mkEqErr)+              , ("Other eqs",     unblocked is_equality,      True,  mkGroupReporter mkEqErr)+              , ("Blocked eqs",   is_equality,           False, mkSuppressReporter mkBlockedEqErr)]      -- report2: we suppress these if there are insolubles elsewhere in the tree     report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)               , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)               , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ] +    -- also checks to make sure the constraint isn't BlockedCIS+    -- See TcCanonical Note [Equalities with incompatible kinds], (4)+    unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool+    unblocked _ (CIrredCan { cc_status = BlockedCIS }) _ = False+    unblocked checker ct pred = checker ct pred+     -- rigid_nom_eq, rigid_nom_tv_eq,     is_hole, is_dict,       is_equality, is_ip, is_irred :: Ct -> Pred -> Bool@@ -797,6 +803,11 @@ 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 ErrMsg) -> Reporter+mkSuppressReporter mk_err ctxt cts+  = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)+ eq_lhs_type :: Ct -> Ct -> Bool eq_lhs_type ct1 ct2   = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of@@ -807,8 +818,7 @@ cmp_loc :: Ct -> Ct -> Ordering cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2) -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt-            -> [Ct] -> TcM ()+reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter reportGroup mk_err ctxt cts =   ASSERT( not (null cts))   do { err <- mk_err ctxt cts@@ -825,6 +835,14 @@          -- but that's hard to know for sure, and if we don't          -- abort, we need bindings for all (e.g. #12156) +-- like reportGroup, but does not actually report messages. It still adds+-- -fdefer-type-errors bindings, though.+suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter+suppressGroup mk_err ctxt cts+ = do { err <- mk_err ctxt cts+      ; traceTc "Suppressing errors for" (ppr cts)+      ; mapM_ (addDeferredBinding ctxt err) cts }+ maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM () -- Unlike maybeReportError, these "hole" errors are -- /not/ suppressed by cec_suppress.  We want to see them!@@ -1440,10 +1458,10 @@              -> Maybe SwapFlag   -- Nothing <=> not sure              -> TcType -> TcType -> TcM ErrMsg mkEqErr_help dflags ctxt report ct oriented ty1 ty2-  | Just (tv1, co1) <- tcGetCastedTyVar_maybe ty1-  = mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2-  | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2-  = mkTyVarEqErr dflags ctxt report ct swapped  tv2 co2 ty1+  | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1+  = mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2+  | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2+  = mkTyVarEqErr dflags ctxt report ct swapped  tv2 ty1   | otherwise   = reportEqErr ctxt report ct oriented ty1 ty2   where@@ -1460,13 +1478,13 @@  mkTyVarEqErr, mkTyVarEqErr'   :: DynFlags -> ReportErrCtxt -> Report -> Ct-             -> Maybe SwapFlag -> TcTyVar -> TcCoercionN -> TcType -> TcM ErrMsg+             -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg -- tv1 and ty2 are already tidied-mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2-  = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr co1 $$ ppr ty2)-       ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 }+mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2+  = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)+       ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 } -mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2+mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2   | not insoluble_occurs_check   -- See Note [Occurs check wins]   , isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would                             -- be oriented the other way round;@@ -1515,23 +1533,6 @@        -- to be helpful since this is just an unimplemented feature.        ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } } -   -- check for heterogeneous equality next; see Note [Equalities with incompatible kinds]-   -- in TcCanonical-  | not (k1 `tcEqType` k2)-  = do { let main_msg = addArising (ctOrigin ct) $-                        vcat [ hang (text "Kind mismatch: cannot unify" <+>-                                     parens (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)) <+>-                                     text "with:")-                                  2 (sep [ppr ty2, dcolon, ppr k2])-                             , text "Their kinds differ." ]-             cast_msg-               | isTcReflexiveCo co1 = empty-               | otherwise           = text "NB:" <+> ppr tv1 <+>-                                       text "was casted to have kind" <+>-                                       quotes (ppr k1)--       ; mkErrorMsgFromCt ctxt ct (mconcat [important main_msg, important cast_msg, report]) }-   -- 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@@ -1597,9 +1598,6 @@         -- Consider an ambiguous top-level constraint (a ~ F a)         -- Not an occurs check, because F is a type function.   where-    Pair _ k1 = tcCoercionKind co1-    k2        = tcTypeKind ty2-     ty1 = mkTyVarTy tv1     occ_check_expand       = occCheckForErrors dflags tv1 ty2     insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2@@ -1682,6 +1680,24 @@                 2 (sep [ text "bound by" <+> ppr skol_info                        , text "at" <+> ppr (tcl_loc (ic_env implic)) ]) +-- These are for the "blocked" equalities, as described in TcCanonical+-- Note [Equalities with incompatible kinds], wrinkle (2). There should+-- 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 ErrMsg+mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report+  where+    report = important msg+    msg = vcat [ hang (text "Cannot use equality for substitution:")+                   2 (ppr (ctPred ct))+               , text "Doing so would be ill-kinded." ]+          -- This is a terrible message. Perhaps worse, if the user+          -- has -fprint-explicit-kinds on, they will see that the two+          -- sides have the same kind, as there is an invisible cast.+          -- I really don't know how to do better.+mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints"+ {- Note [Suppress redundant givens during error reporting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1725,9 +1741,9 @@ extraTyVarEqInfo ctxt tv1 ty2   = extraTyVarInfo ctxt tv1 $$ ty_extra ty2   where-    ty_extra ty = case tcGetTyVar_maybe ty of-                    Just tv -> extraTyVarInfo ctxt tv-                    Nothing -> empty+    ty_extra ty = case tcGetCastedTyVar_maybe ty of+                    Just (tv, _) -> extraTyVarInfo ctxt tv+                    Nothing      -> empty  extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc extraTyVarInfo ctxt tv@@ -2735,10 +2751,7 @@        | otherwise -- "The type variable 't0' is ambiguous"       = text "The" <+> what <+> text "variable" <> plural tkvs-        <+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous"--    is_or_are [_] = text "is"-    is_or_are _   = text "are"+        <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous"  pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc pprSkols ctxt tvs
compiler/typecheck/TcEvTerm.hs view
@@ -7,18 +7,18 @@ import GhcPrelude  import FastString-import Type+import GHC.Core.Type import GHC.Core import GHC.Core.Make-import Literal ( Literal(..) )+import GHC.Types.Literal ( Literal(..) ) import TcEvidence import GHC.Driver.Types import GHC.Driver.Session-import Name-import Module+import GHC.Types.Name+import GHC.Types.Module import GHC.Core.Utils import PrelNames-import SrcLoc+import GHC.Types.SrcLoc  -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime]@@ -37,16 +37,17 @@ -- See Note [Overview of implicit CallStacks] in TcEvidence.hs evCallStack cs = do   df            <- getDynFlags+  let platform = targetPlatform df   m             <- getModule   srcLocDataCon <- lookupDataCon srcLocDataConName   let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>                sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)                         , mkStringExprFS (moduleNameFS $ moduleName m)                         , mkStringExprFS (srcSpanFile l)-                        , return $ mkIntExprInt df (srcSpanStartLine l)-                        , return $ mkIntExprInt df (srcSpanStartCol l)-                        , return $ mkIntExprInt df (srcSpanEndLine l)-                        , return $ mkIntExprInt df (srcSpanEndCol l)+                        , return $ mkIntExprInt platform (srcSpanStartLine l)+                        , return $ mkIntExprInt platform (srcSpanStartCol l)+                        , return $ mkIntExprInt platform (srcSpanEndLine l)+                        , return $ mkIntExprInt platform (srcSpanEndCol l)                         ]    emptyCS <- Var <$> lookupId emptyCallStackName
compiler/typecheck/TcExpr.hs view
@@ -17,6 +17,7 @@                 tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,                 tcCheckId,                 addExprErrCtxt,+                addAmbiguousNameErr,                 getFixedTyVars ) where  #include "HsVersions.h"@@ -31,13 +32,13 @@ import TcHsSyn import TcRnMonad import TcUnify-import BasicTypes+import GHC.Types.Basic import Inst import TcBinds          ( chooseInferredQuantifiers, tcLocalBinds ) import TcSigs           ( tcUserTypeSig, tcInstSig ) import TcSimplify       ( simplifyInfer, InferMode(..) ) import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )-import FamInstEnv       ( FamInstEnvs )+import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Rename.Env   ( addUsedGRE ) import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) import TcEnv@@ -49,37 +50,37 @@ import TcMType import TcOrigin import TcType-import Id-import IdInfo-import ConLike-import DataCon-import PatSyn-import Name-import NameEnv-import NameSet-import RdrName-import TyCon-import TyCoRep-import TyCoPpr-import TyCoSubst (substTyWithInScope)-import Type+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.PatSyn+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Name.Reader+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCo.Subst (substTyWithInScope)+import GHC.Core.Type import TcEvidence-import VarSet+import GHC.Types.Var.Set import TysWiredIn import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) import PrelNames import GHC.Driver.Session-import SrcLoc+import GHC.Types.SrcLoc import Util-import VarEnv  ( emptyTidyEnv, mkInScopeSet )+import GHC.Types.Var.Env  ( emptyTidyEnv, mkInScopeSet ) import ListSetOps import Maybes import Outputable import FastString import Control.Monad-import Class(classTyCon)-import UniqSet ( nonDetEltsUniqSet )+import GHC.Core.Class(classTyCon)+import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt  import Data.Function@@ -445,7 +446,7 @@        ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty                            -- Unboxed tuples have RuntimeRep vars, which we                            -- don't care about here-                           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+                           -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon        ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys                                        Boxed   -> arg_tys        ; tup_args1 <- tcTupArgs tup_args arg_tys'@@ -1313,7 +1314,7 @@ GHCs we had an ASSERT that Required could not occur here.  The ice is thin; c.f. Note [No Required TyCoBinder in terms]-in TyCoRep.+in GHC.Core.TyCo.Rep.  Note [VTA for out-of-scope functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2193,10 +2194,16 @@ -- occurrence" error, then give up. ambiguousSelector :: Located RdrName -> TcM a ambiguousSelector (L _ rdr)+  = do { addAmbiguousNameErr rdr+       ; failM }++-- | This name really is ambiguous, so add a suitable "ambiguous+-- occurrence" error, then continue+addAmbiguousNameErr :: RdrName -> TcM ()+addAmbiguousNameErr rdr   = do { env <- getGlobalRdrEnv        ; let gres = lookupGRE_RdrName rdr env-       ; setErrCtxt [] $ addNameClashErrRn rdr gres-       ; failM }+       ; setErrCtxt [] $ addNameClashErrRn rdr gres}  -- Disambiguate the fields in a record update. -- See Note [Disambiguating record fields]@@ -2224,7 +2231,7 @@     isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of                         Unambiguous sel_name _ -> Just (x, sel_name)                         Ambiguous{}            -> Nothing-                        XAmbiguousFieldOcc{}   -> Nothing+                        XAmbiguousFieldOcc nec -> noExtCon nec      -- Look up the possible parents and selector GREs for each field     getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
compiler/typecheck/TcExpr.hs-boot view
@@ -1,5 +1,5 @@ module TcExpr where-import Name+import GHC.Types.Name import GHC.Hs    ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc ) import TcType   ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) import TcRnTypes( TcM )
compiler/typecheck/TcFlatten.hs view
@@ -15,21 +15,21 @@ import GhcPrelude  import TcRnTypes-import TyCoPpr       ( pprTyVar )+import GHC.Core.TyCo.Ppr ( pprTyVar ) import Constraint-import Predicate+import GHC.Core.Predicate import TcType-import Type+import GHC.Core.Type import TcEvidence-import TyCon-import TyCoRep   -- performs delicate algorithm on types-import Coercion-import Var-import VarSet-import VarEnv+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep   -- performs delicate algorithm on types+import GHC.Core.Coercion+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env import Outputable import TcSMonad as TcS-import BasicTypes( SwapFlag(..) )+import GHC.Types.Basic( SwapFlag(..) )  import Util import Bag@@ -104,9 +104,6 @@                        then xis1 /= xis2   i.e. at most one CFunEqCan with a particular LHS -* Function applications can occur in the RHS of a CTyEqCan.  No reason-  not allow this, and it reduces the amount of flattening that must occur.- * Flattening a type (F xis):     - If we are flattening in a Wanted/Derived constraint       then create new [W] x : F xis ~ fmv@@ -943,7 +940,7 @@ Note [flatten_exact_fam_app_fully performance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in TyCoRep for more information about GRefl and #15192 for the current state.+The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the current state.  The explicit pattern match in homogenise_result helps with T9872a, b, c. @@ -1801,7 +1798,7 @@                         --     bump the unification count; it is "improvement"                         -- Note [Unflattening can force the solver to iterate]       = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct )-           -- CTyEqCan invariant should ensure this is true+           -- CTyEqCan invariant (TyEq:K) should ensure this is true         do { is_filled <- isFilledMetaTyVar tv            ; elim <- case is_filled of                False -> do { traceTcS "unflatten_eq 2" (ppr ct)
compiler/typecheck/TcForeign.hs view
@@ -43,22 +43,22 @@ import TcEnv  import FamInst-import FamInstEnv-import Coercion-import Type-import ForeignCall+import GHC.Core.FamInstEnv+import GHC.Core.Coercion+import GHC.Core.Type+import GHC.Types.ForeignCall import ErrUtils-import Id-import Name-import RdrName-import DataCon-import TyCon+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Core.DataCon+import GHC.Core.TyCon import TcType import PrelNames import GHC.Driver.Session import Outputable import GHC.Platform-import SrcLoc+import GHC.Types.SrcLoc import Bag import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt@@ -151,7 +151,7 @@          | isNewTyCon tc         -- Expand newtypes         , Just rec_nts' <- checkRecTc rec_nts tc-                   -- See Note [Expanding newtypes] in TyCon.hs+                   -- See Note [Expanding newtypes] in GHC.Core.TyCon                    -- We can't just use isRecursiveTyCon; sometimes recursion is ok:                    --     newtype T = T (Ptr T)                    --   Here, we don't reject the type for being recursive.
compiler/typecheck/TcGenDeriv.hs view
@@ -43,37 +43,37 @@  import TcRnMonad import GHC.Hs-import RdrName-import BasicTypes-import DataCon-import Name+import GHC.Types.Name.Reader+import GHC.Types.Basic+import GHC.Core.DataCon+import GHC.Types.Name import Fingerprint import Encoding  import GHC.Driver.Session import PrelInfo import FamInst-import FamInstEnv+import GHC.Core.FamInstEnv import PrelNames import THNames-import MkId ( coerceId )+import GHC.Types.Id.Make ( coerceId ) import PrimOp-import SrcLoc-import TyCon+import GHC.Types.SrcLoc+import GHC.Core.TyCon import TcEnv import TcType import TcValidity ( checkValidCoAxBranch )-import CoAxiom    ( coAxiomSingleBranch )+import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) import TysPrim import TysWiredIn-import Type-import Class-import VarSet-import VarEnv+import GHC.Core.Type+import GHC.Core.Class+import GHC.Types.Var.Set+import GHC.Types.Var.Env import Util-import Var+import GHC.Types.Var import Outputable-import Lexeme+import GHC.Utils.Lexeme import FastString import Pair import Bag@@ -1610,9 +1610,10 @@   newtype T x = MkT <rep-ty>    instance C a <rep-ty> => C a (T x) where-    op = coerce @ (a -> [<rep-ty>] -> c -> Int)-                @ (a -> [T x]      -> c -> Int)-                op :: forall c. a -> [T x] -> c -> Int+    op :: forall c. a -> [T x] -> c -> Int+    op = coerce @(a -> [<rep-ty>] -> c -> Int)+                @(a -> [T x]      -> c -> Int)+                op  In addition to the type applications, we also have an explicit type signature on the entire RHS. This brings the method-bound variable@@ -1632,16 +1633,17 @@    class C a where op :: a -> forall b. b -> b    newtype T x = MkT <rep-ty>    instance C <rep-ty> => C (T x) where-     op = coerce @ (<rep-ty> -> forall b. b -> b)-                 @ (T x      -> forall b. b -> b)-                op :: T x -> forall b. b -> b+     op :: T x -> forall b. b -> b+     op = coerce @(<rep-ty> -> forall b. b -> b)+                 @(T x      -> forall b. b -> b)+                op  The use of type applications is crucial here. If we had tried using only explicit type signatures, like so:     instance C <rep-ty> => C (T x) where+     op :: T x -> forall b. b -> b      op = coerce (op :: <rep-ty> -> forall b. b -> b)-                     :: T x      -> forall b. b -> b  Then GHC will attempt to deeply skolemize the two type signatures, which will wreak havoc with the Coercible solver. Therefore, we instead use type@@ -1721,23 +1723,26 @@ But this isn't the death knell for combining QuantifiedConstraints with GND. On the contrary, if we generate GND bindings in a slightly different way, then we can avoid this situation altogether. Instead of applying `coerce` to two-polymorphic types, we instead let an explicit type signature do the polymorphic+polymorphic types, we instead let an instance signature do the polymorphic instantiation, and omit the `forall`s in the type applications. More concretely, we generate the following code instead:    instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>       C (T m) where+    join :: forall a. T m (T m a) -> T m a     join = coerce @(  m   (m a) ->   m a)                   @(T m (T m a) -> T m a)-                  join :: forall a. T m (T m a) -> T m a+                  join -Now the visible type arguments are both monotypes, so we need do any of this-funny quantified constraint instantiation business.+Now the visible type arguments are both monotypes, so we don't need any of this+funny quantified constraint instantiation business. While this particular+example no longer uses impredicative instantiation, we still need to enable+ImpredicativeTypes to typecheck GND-generated code for class methods with+higher-rank types. See Note [Newtype-deriving instances].  You might think that that second @(T m (T m a) -> T m a) argument is redundant-in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type-signature, but in fact leaving it off will break this example (from the-T15290d test case):+in the presence of the instance signature, but in fact leaving it off will+break this example (from the T15290d test case):    class C a where     c :: Int -> forall b. b -> a@@ -1745,14 +1750,15 @@   instance C Int    instance C Age where+    c :: Int -> forall b. b -> Age     c = coerce @(Int -> forall b. b -> Int)-               c :: Int -> forall b. b -> Age+               c -That is because the explicit type signature deeply skolemizes the forall-bound+That is because the instance signature deeply skolemizes the forall-bound `b`, which wreaks havoc with the `Coercible` solver. An additional visible type argument of @(Int -> forall b. b -> Age) is enough to prevent this. -Be aware that the use of an explicit type signature doesn't /solve/ this+Be aware that the use of an instance signature doesn't /solve/ this problem; it just makes it less likely to occur. For example, if a class has a truly higher-rank type like so: @@ -1775,8 +1781,8 @@ A naïve attempt and generating a C T instance would be:    instance C T where+    f :: String     f = coerce @String @String f-          :: String  This isn't going to typecheck, however, since GHC doesn't know what to instantiate the type variable `a` with in the call to `f` in the method body.@@ -1784,8 +1790,8 @@ ambiguity here, we explicitly instantiate `a` like so:    instance C T where+    f :: String     f = coerce @String @String (f @())-          :: String  All better now. -}@@ -1797,32 +1803,58 @@                              -- newtype itself)                   -> [Type]  -- instance head parameters (incl. newtype)                   -> Type    -- the representation type-                  -> TcM (LHsBinds GhcPs, BagDerivStuff)+                  -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff) -- See Note [Newtype-deriving instances] gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty   = do let ats = classATs cls+           (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)        atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )                     mapM mk_atf_inst ats-       return ( listToBag $ map mk_bind (classMethods cls)+       return ( listToBag binds+              , sigs               , listToBag $ map DerivFamInst atf_insts )   where-    mk_bind :: Id -> LHsBind GhcPs-    mk_bind meth_id-      = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch-                                          (mkPrefixFunRhs (L loc meth_RDR))-                                          [] rhs_expr]+    -- For each class method, generate its derived binding and instance+    -- signature. Using the first example from+    -- Note [Newtype-deriving instances]:+    --+    --   class C a b where+    --     op :: forall c. a -> [b] -> c -> Int+    --+    --   newtype T x = MkT <rep-ty>+    --+    -- Then we would generate <derived-op-impl> below:+    --+    --   instance C a <rep-ty> => C a (T x) where+    --     <derived-op-impl>+    mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs)+    mk_bind_and_sig meth_id+      = ( -- The derived binding, e.g.,+          --+          --   op = coerce @(a -> [<rep-ty>] -> c -> Int)+          --               @(a -> [T x]      -> c -> Int)+          --               op+          mkRdrFunBind loc_meth_RDR [mkSimpleMatch+                                        (mkPrefixFunRhs loc_meth_RDR)+                                        [] rhs_expr]+        , -- The derived instance signature, e.g.,+          --+          --   op :: forall c. a -> [T x] -> c -> Int+          L loc $ ClassOpSig noExtField False [loc_meth_RDR]+                $ mkLHsSigType $ typeToLHsType to_ty+        )       where         Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id         (_, _, from_tau) = tcSplitSigmaTy from_ty         (_, _, to_tau)   = tcSplitSigmaTy to_ty          meth_RDR = getRdrName meth_id+        loc_meth_RDR = L loc meth_RDR          rhs_expr = nlHsVar (getRdrName coerceId)                                       `nlHsAppType`     from_tau                                       `nlHsAppType`     to_tau                                       `nlHsApp`         meth_app-                                      `nlExprWithTySig` to_ty          -- The class method, applied to all of the class instance types         -- (including the representation type) to avoid potential ambiguity.
compiler/typecheck/TcGenFunctor.hs view
@@ -6,6 +6,7 @@ (equivalent to the code in TcGenDeriv, for other classes) -} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}@@ -18,26 +19,28 @@         gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds     ) where +#include "HsVersions.h"+ import GhcPrelude  import Bag-import DataCon+import GHC.Core.DataCon import FastString import GHC.Hs-import Panic+import Outputable import PrelNames-import RdrName-import SrcLoc+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc import State import TcGenDeriv import TcType-import TyCon-import TyCoRep-import Type+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.Type import Util-import Var-import VarSet-import MkId (coerceId)+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Id.Make (coerceId) import TysWiredIn (true_RDR, false_RDR)  import Data.Maybe (catMaybes, isJust)@@ -83,50 +86,66 @@          - functions  More formally, we write the derivation of fmap code over type variable-'a for type 'b as ($fmap 'a 'b).  In this general notation the derived+'a for type 'b as ($fmap 'a 'b x).  In this general notation the derived instance for T is:    instance Functor T where       fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)       fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1) -  $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a-  $(fmap 'a 'a)          =  f-  $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)-  $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2-  $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))+  $(fmap 'a 'b x)          = x     -- when b does not contain a+  $(fmap 'a 'a x)          = f x+  $(fmap 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2))+  $(fmap 'a '(T b1 a) x)   = fmap f x -- when a only occurs directly as the last argument of T+  $(fmap 'a '(T b1 b2) x)  = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2+  $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y)))  For functions, the type parameter 'a can occur in a contravariant position, which means we need to derive a function like:    cofmap :: (a -> b) -> (f b -> f a) -This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:+This is pretty much the same as $fmap, only without the $(cofmap 'a 'a x) and+$(cofmap 'a '(T b1 a) x) cases: -  $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a-  $(cofmap 'a 'a)          =  error "type variable in contravariant position"-  $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)-  $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)-  $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2-  $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))+  $(cofmap 'a 'b x)          = x     -- when b does not contain a+  $(cofmap 'a 'a x)          = error "type variable in contravariant position"+  $(cofmap 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)+  $(cofmap 'a '(T b1 a) x)   = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T+  $(cofmap 'a '(T b1 b2) x)  = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2+  $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y))) -Note that the code produced by $(fmap _ _) is always a higher order function,-with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern-matching on the type, this means create a lambda function (see the (,) case above).-The resulting code for fmap can look a bit weird, for example:+Note that the code produced by $(fmap _ _ _) is always a higher order function,+with type `(a -> b) -> (g a -> g b)` for some g. -  data X a = X (a,Int)-  -- generated instance-  instance Functor X where-      fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x+Note that there are two distinct cases in $fmap (and $cofmap) that match on an+application of some type constructor T (where T is not a tuple type+constructor): -The optimizer should be able to simplify this code by simple inlining.+  $(fmap 'a '(T b1 a) x)  = fmap f x -- when a only occurs directly as the last argument of T+  $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 -An older version of the deriving code tried to avoid these applied-lambda functions by producing a meta level function. But the function to-be mapped, `f`, is a function on the code level, not on the meta level,-so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.-It is better to produce too many lambdas than to eta expand, see ticket #7436.+While the latter case technically subsumes the former case, it is important to+give special treatment to the former case to avoid unnecessary eta expansion.+See Note [Avoid unnecessary eta expansion in derived fmap implementations].++We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for+an explanation of why this is important. Just like $fmap/$cofmap above, there+is a similar algorithm for generating `p <$ x` (for some constant `p`):++  $(replace 'a 'b x)          = x      -- when b does not contain a+  $(replace 'a 'a x)          = p+  $(replace 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2))+  $(replace 'a '(T b1 a) x)   = p <$ x -- when a only occurs directly as the last argument of T+  $(replace 'a '(T b1 b2) x)  = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2+  $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y)))++  $(coreplace 'a 'b x)          = x      -- when b does not contain a+  $(coreplace 'a 'a x)          = error "type variable in contravariant position"+  $(coreplace 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2))+  $(coreplace 'a '(T b1 a) x)   = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T+  $(coreplace 'a '(T b1 b2) x)  = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2+  $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) -}  gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)@@ -154,30 +173,34 @@     fmap_match_ctxt = mkPrefixFunRhs fmap_name      fmap_eqn con = flip evalState bs_RDRs $-                     match_for_con fmap_match_ctxt [f_Pat] con =<< parts+                     match_for_con fmap_match_ctxt [f_Pat] con parts       where-        parts = sequence $ foldDataConArgs ft_fmap con+        parts = foldDataConArgs ft_fmap con      fmap_eqns = map fmap_eqn data_cons -    ft_fmap :: FFoldType (State [RdrName] (LHsExpr GhcPs))-    ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x-                   -- fmap f = \x -> x-                 , ft_var  = return f_Expr-                   -- fmap f = f-                 , ft_fun  = \g h -> do-                     gg <- g-                     hh <- h-                     mkSimpleLam2 $ \x b -> return $-                       nlHsApp hh (nlHsApp x (nlHsApp gg b))-                   -- fmap f = \x b -> h (x (g b))-                 , ft_tup = \t gs -> do-                     gg <- sequence gs-                     mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg-                   -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)-                 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g-                   -- fmap f = fmap g-                 , ft_forall = \_ g -> g+    ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))+    ft_fmap = FT { ft_triv = \x -> pure x+                   -- fmap f x = x+                 , ft_var  = \x -> pure $ nlHsApp f_Expr x+                   -- fmap f x = f x+                 , ft_fun  = \g h x -> mkSimpleLam $ \b -> do+                     gg <- g b+                     h $ nlHsApp x gg+                   -- fmap f x = \b -> h (x (g b))+                 , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt)+                   -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)+                 , ft_ty_app = \_ arg_ty g x ->+                     -- If the argument type is a bare occurrence of the+                     -- data type's last type variable, then we can generate+                     -- more efficient code.+                     -- See Note [Avoid unnecessary eta expansion in derived fmap implementations]+                     if tcIsTyVarTy arg_ty+                       then pure $ nlHsApps fmap_RDR [f_Expr,x]+                       else do gg <- mkSimpleLam g+                               pure $ nlHsApps fmap_RDR [gg,x]+                   -- fmap f x = fmap g x+                 , ft_forall = \_ g x -> g x                  , ft_bad_app = panic "in other argument in ft_fmap"                  , ft_co_var = panic "contravariant in ft_fmap" } @@ -189,54 +212,158 @@     replace_match_ctxt = mkPrefixFunRhs replace_name      replace_eqn con = flip evalState bs_RDRs $-        match_for_con replace_match_ctxt [z_Pat] con =<< parts+        match_for_con replace_match_ctxt [z_Pat] con parts       where-        parts = traverse (fmap replace) $ foldDataConArgs ft_replace con+        parts = foldDataConArgs ft_replace con      replace_eqns = map replace_eqn data_cons -    ft_replace :: FFoldType (State [RdrName] Replacer)-    ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x-                   -- (p <$) = \x -> x-                 , ft_var  = fmap Immediate $ mkSimpleLam $ \_ -> return z_Expr-                   -- (p <$) = const p-                 , ft_fun  = \g h -> do-                     gg <- replace <$> g-                     hh <- replace <$> h-                     fmap Nested $ mkSimpleLam2 $ \x b -> return $-                       nlHsApp hh (nlHsApp x (nlHsApp gg b))-                   -- (<$) p = \x b -> h (x (g b))-                 , ft_tup = \t gs -> do-                     gg <- traverse (fmap replace) gs-                     fmap Nested . mkSimpleLam $-                          mkSimpleTupleCase (match_for_con CaseAlt) t gg-                   -- (p <$) = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)-                 , ft_ty_app = \_ gm -> do-                       g <- gm-                       case g of-                         Nested g' -> pure . Nested $-                                          nlHsApp fmap_Expr $ g'-                         Immediate _ -> pure . Nested $-                                          nlHsApp replace_Expr z_Expr-                   -- (p <$) = fmap (p <$)-                 , ft_forall = \_ g -> g+    ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))+    ft_replace = FT { ft_triv = \x -> pure x+                   -- p <$ x = x+                 , ft_var  = \_ -> pure z_Expr+                   -- p <$ _ = p+                 , ft_fun  = \g h x -> mkSimpleLam $ \b -> do+                     gg <- g b+                     h $ nlHsApp x gg+                   -- p <$ x = \b -> h (x (g b))+                 , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt)+                   -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)+                 , ft_ty_app = \_ arg_ty g x ->+                       -- If the argument type is a bare occurrence of the+                       -- data type's last type variable, then we can generate+                       -- more efficient code.+                       -- See [Deriving <$]+                       if tcIsTyVarTy arg_ty+                         then pure $ nlHsApps replace_RDR [z_Expr,x]+                         else do gg <- mkSimpleLam g+                                 pure $ nlHsApps fmap_RDR [gg,x]+                   -- p <$ x = fmap (p <$) x+                 , ft_forall = \_ g x -> g x                  , ft_bad_app = panic "in other argument in ft_replace"                  , ft_co_var = panic "contravariant in ft_replace" }      -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...-    match_for_con :: HsMatchContext GhcPs-                  -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs]-                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))+    match_for_con :: Monad m+                  => HsMatchContext GhcPs+                  -> [LPat GhcPs] -> DataCon+                  -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]+                  -> m (LMatch GhcPs (LHsExpr GhcPs))     match_for_con ctxt = mkSimpleConMatch ctxt $-        \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..+        \con_name xsM -> do xs <- sequence xsM+                            pure $ nlHsApps con_name xs  -- Con x1 x2 .. --- See Note [Deriving <$]-data Replacer = Immediate {replace :: LHsExpr GhcPs}-              | Nested {replace :: LHsExpr GhcPs}+{-+Note [Avoid unnecessary eta expansion in derived fmap implementations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the sake of simplicity, the algorithm that derived implementations of+fmap used to have a single case that dealt with applications of some type+constructor T (where T is not a tuple type constructor): -{- Note [Deriving <$]-   ~~~~~~~~~~~~~~~~~~+  $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 +This generated less than optimal code in certain situations, however. Consider+this example:++  data List a = Nil | Cons a (List a) deriving Functor++This would generate the following Functor instance:++  instance Functor List where+    fmap f Nil = Nil+    fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs)++The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application+of `f`. What's worse, this eta expansion actually degrades performance! To see+why, we can trace an invocation of fmap on a small List:++  fmap id     $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil++  Cons (id 0) $ fmap (\y -> id y)+              $ Cons 0 $ Cons 0 $ Cons 0 Nil++  Cons (id 0) $ Cons ((\y -> id y) 0)+              $ fmap (\y' -> (\y -> id y) y')+              $ Cons 0 $ Cons 0 Nil++  Cons (id 0) $ Cons ((\y -> id y) 0)+              $ Cons ((\y' -> (\y -> id y) y') 0)+              $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'')+              $ Cons 0 Nil++  Cons (id 0) $ Cons ((\y -> id y) 0)+              $ Cons ((\y' -> (\y -> id y) y') 0)+              $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0)+              $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''')+              $ Nil++  Cons (id 0) $ Cons ((\y -> id y) 0)+              $ Cons ((\y' -> (\y -> id y) y') 0)+              $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0)+              $ Nil++Notice how the number of lambdas—and hence, the number of closures—one+needs to evaluate grows very quickly. In general, a List with N cons cells will+require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is+what caused the performance issues observed in #7436.++But hold on a second: shouldn't GHC's optimizer be able to eta reduce+`\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not+the case. In general, eta reduction can change the semantics of a program. For+instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so+happens that the fmap implementation above would have the same semantics+regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is+not yet smart enough to realize this (see #17881).++To avoid this quadratic blowup, we add a special case to $fmap that applies+`fmap f` directly:++  $(fmap 'a '(T b1 a) x)  = fmap f x -- when a only occurs directly as the last argument of T+  $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2++With this modified algorithm, the derived Functor List instance becomes:++  instance Functor List where+    fmap f Nil = Nil+    fmap f (Cons x xs) = Cons (f x) (fmap f xs)++No lambdas in sight, just the way we like it.++This special case does not prevent all sources quadratic closure buildup,+however. In this example:++  data PolyList a = PLNil | PLCons a (PolyList (PolyList a))+    deriving Functor++We would derive the following code:++  instance Functor PolyList where+    fmap f PLNil = PLNil+    fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs)++The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way+as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced+to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are+recursively invoking fmap with a different argument (fmap f). Since we end up+paying the price of building a closure either way, we do not extend the special+case in $fmap any further, since it wouldn't buy us anything.++The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by+inspecting the argument type. If the argument type is a bare type variable,+then we can conclude the type variable /must/ be the same as the data type's+last type parameter. We know that this must be the case since there is an+invariant that the argument type in ft_ty_app will always contain the last+type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so+if the argument type is a bare variable, then that must be exactly the last+type parameter.++Note that the ft_ty_app case of ft_replace (which derives implementations of+(<$)) also inspects the argument type to generate more efficient code.+See Note [Deriving <$].++Note [Deriving <$]+~~~~~~~~~~~~~~~~~~+ We derive the definition of <$. Allowing this to take the default definition can lead to memory leaks: mapping over a structure with a constant function can fill the result structure with trivial thunks that retain the values from the@@ -298,9 +425,15 @@  x <$ Nes q = Nes (fmap (x <$) q) -We use the Replacer type to tag whether the expression derived for applying-<$ to the last type variable was the ft_var case (immediate) or one of the-others (letting ft_forall pass through as usual).+We inspect the argument type in ft_ty_app+(see Note [FFoldType and functorLikeTraverse]) to distinguish between these+two cases. If the argument type is a bare type variable, then we know that it+must be the same variable as the data type's last type parameter.+This is very similar to a trick that derived fmap implementations+use in their own ft_ty_app case.+See Note [Avoid unnecessary eta expansion in derived fmap implementations],+which explains why checking if the argument type is a bare variable is+the right thing to do.  We could, but do not, give tuples special treatment to improve efficiency in some cases. Suppose we have@@ -342,9 +475,12 @@         , ft_fun     :: a -> a -> a           -- ^ Function type         , ft_tup     :: TyCon -> [a] -> a-          -- ^ Tuple type-        , ft_ty_app  :: Type -> a -> a-          -- ^ Type app, variable only in last argument+          -- ^ Tuple type. The @[a]@ is the result of folding over the+          --   arguments of the tuple.+        , ft_ty_app  :: Type -> Type -> a -> a+          -- ^ Type app, variable only in last argument. The two 'Type's are+          --   the function and argument parts of @fun_ty arg_ty@,+          --   respectively.         , ft_bad_app :: a           -- ^ Type app, variable other than in last argument         , ft_forall  :: TcTyVar -> a -> a@@ -375,7 +511,7 @@        where (xr,xc) = go (not co) x              (yr,yc) = go co       y     go co (AppTy    x y) | xc = (caseWrongArg,   True)-                         | yc = (caseTyApp x yr, True)+                         | yc = (caseTyApp x y yr, True)         where (_, xc) = go co x               (yr,yc) = go co y     go co ty@(TyConApp con args)@@ -384,8 +520,8 @@        -- and at least one xr is True        | isTupleTyCon con = (caseTuple con xrs, True)        | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty-       | Just (fun_ty, _) <- splitAppTy_maybe ty         -- T (..no var..) ty-                          = (caseTyApp fun_ty (last xrs), True)+       | Just (fun_ty, arg_ty) <- splitAppTy_maybe ty    -- T (..no var..) ty+                          = (caseTyApp fun_ty arg_ty (last xrs), True)        | otherwise        = (caseWrongArg, True)   -- Non-decomposable (eg type function)        where          -- When folding over an unboxed tuple, we must explicitly drop the@@ -409,7 +545,7 @@             , ft_var = []             , ft_fun = (++)             , ft_tup = \_ xs -> concat xs-            , ft_ty_app = (:)+            , ft_ty_app = \t _ ts -> t:ts             , ft_bad_app = panic "in other argument in deepSubtypesContaining"             , ft_co_var = panic "contravariant in deepSubtypesContaining"             , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })@@ -464,10 +600,10 @@ -- and its arguments, applying an expression (from @insides@) to each of the -- respective arguments of @con@. mkSimpleConMatch :: Monad m => HsMatchContext GhcPs-                 -> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))+                 -> (RdrName -> [a] -> m (LHsExpr GhcPs))                  -> [LPat GhcPs]                  -> DataCon-                 -> [LHsExpr GhcPs]+                 -> [LHsExpr GhcPs -> a]                  -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch ctxt fold extra_pats con insides = do     let con_name = getRdrName con@@ -477,7 +613,7 @@           then bare_pat           else nlParPat bare_pat     rhs <- fold con_name-                (zipWith (\i v -> i `nlHsApp` nlHsVar v) insides vars_needed)+                (zipWith (\i v -> i $ nlHsVar v) insides vars_needed)     return $ mkMatch ctxt (extra_pats ++ [pat]) rhs                      (noLoc emptyLocalBinds) @@ -730,7 +866,7 @@                  mkSimpleTupleCase (match_foldr z) t gg x                return (Just lam)              -- foldr f = (\x z -> case x of ...)-           , ft_ty_app  = \_ g -> do+           , ft_ty_app  = \_ _ g -> do                gg <- g                mapM (\gg' -> mkSimpleLam2 $ \x z -> return $                  nlHsApps foldable_foldr_RDR [gg',z,x]) gg@@ -740,11 +876,12 @@            , ft_fun     = panic "function in ft_foldr"            , ft_bad_app = panic "in other argument in ft_foldr" } -    match_foldr :: LHsExpr GhcPs+    match_foldr :: Monad m+                => LHsExpr GhcPs                 -> [LPat GhcPs]                 -> DataCon                 -> [Maybe (LHsExpr GhcPs)]-                -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))+                -> m (LMatch GhcPs (LHsExpr GhcPs))     match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)       where         -- g1 v1 (g2 v2 (.. z))@@ -763,17 +900,18 @@                lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg                return (Just lam)              -- foldMap f = \x -> case x of (..,)-           , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g+           , ft_ty_app = \_ _ g -> fmap (nlHsApp foldMap_Expr) <$> g              -- foldMap f = foldMap g            , ft_forall = \_ g -> g            , ft_co_var = panic "contravariant in ft_foldMap"            , ft_fun = panic "function in ft_foldMap"            , ft_bad_app = panic "in other argument in ft_foldMap" } -    match_foldMap :: [LPat GhcPs]+    match_foldMap :: Monad m+                  => [LPat GhcPs]                   -> DataCon                   -> [Maybe (LHsExpr GhcPs)]-                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))+                  -> m (LMatch GhcPs (LHsExpr GhcPs))     match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)       where         -- mappend v1 (mappend v2 ..)@@ -799,7 +937,7 @@                  Just ggg ->                    NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg)              -- null = \x -> case x of (..,)-           , ft_ty_app = \_ g -> flip fmap g $ \nestedResult ->+           , ft_ty_app = \_ _ g -> flip fmap g $ \nestedResult ->                               case nestedResult of                                 -- If e definitely contains the parameter,                                 -- then we can test if (G e) contains it by@@ -818,10 +956,11 @@            , ft_fun = panic "function in ft_null"            , ft_bad_app = panic "in other argument in ft_null" } -    match_null :: [LPat GhcPs]-                  -> DataCon-                  -> [Maybe (LHsExpr GhcPs)]-                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))+    match_null :: Monad m+               => [LPat GhcPs]+               -> DataCon+               -> [Maybe (LHsExpr GhcPs)]+               -> m (LMatch GhcPs (LHsExpr GhcPs))     match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs)       where         -- v1 && v2 && ..@@ -920,7 +1059,7 @@                return (Just lam)              -- traverse f = \x -> case x of (a1,a2,..) ->              --                           liftA2 (,,) (g1 a1) (g2 a2) <*> ..-           , ft_ty_app  = \_ g -> fmap (nlHsApp traverse_Expr) <$> g+           , ft_ty_app  = \_ _ g -> fmap (nlHsApp traverse_Expr) <$> g              -- traverse f = traverse g            , ft_forall  = \_ g -> g            , ft_co_var  = panic "contravariant in ft_trav"@@ -929,10 +1068,11 @@      -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)     --                    (g2 a2) <*> ...-    match_for_con :: [LPat GhcPs]+    match_for_con :: Monad m+                  => [LPat GhcPs]                   -> DataCon                   -> [Maybe (LHsExpr GhcPs)]-                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))+                  -> m (LMatch GhcPs (LHsExpr GhcPs))     match_for_con = mkSimpleConMatch2 CaseAlt $                                              \con xs -> return (mkApCon con xs)       where@@ -946,13 +1086,11 @@  ----------------------------------------------------------------------- -f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr,+f_Expr, z_Expr, mempty_Expr, foldMap_Expr,     traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,     all_Expr, null_Expr :: LHsExpr GhcPs f_Expr        = nlHsVar f_RDR z_Expr        = nlHsVar z_RDR-fmap_Expr     = nlHsVar fmap_RDR-replace_Expr  = nlHsVar replace_RDR mempty_Expr   = nlHsVar mempty_RDR foldMap_Expr  = nlHsVar foldMap_RDR traverse_Expr = nlHsVar traverse_RDR@@ -1093,11 +1231,20 @@  * ft_ty_app:  A type is being applied to the last type parameter, where the               applied type does not mention the last type parameter (if it-              did, it would fall under ft_bad_app). The Type argument to-              ft_ty_app represents the applied type.+              did, it would fall under ft_bad_app) and the argument type+              mentions the last type parameter (if it did not, it would fall+              under ft_triv). The first two Type arguments to+              ft_ty_app represent the applied type and argument type,+              respectively. +              Currently, only DeriveFunctor makes use of the argument type.+              It inspects the argument type so that it can generate more+              efficient implementations of fmap+              (see Note [Avoid unnecessary eta expansion in derived fmap implementations])+              and (<$) (see Note [Deriving <$]) in certain cases.+               Note that functions, tuples, and foralls are distinct cases-              and take precedence of ft_ty_app. (For example, (Int -> a) would+              and take precedence over ft_ty_app. (For example, (Int -> a) would               fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).               Examples: Maybe a, Either b a
compiler/typecheck/TcGenGenerics.hs view
@@ -19,20 +19,20 @@ import GhcPrelude  import GHC.Hs-import Type+import GHC.Core.Type import TcType import TcGenDeriv import TcGenFunctor-import DataCon-import TyCon-import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) import FamInst-import Module           ( moduleName, moduleNameFS+import GHC.Types.Module ( moduleName, moduleNameFS                         , moduleUnitId, unitIdFS, getModule ) import GHC.Iface.Env    ( newGlobalBinder )-import Name      hiding ( varName )-import RdrName-import BasicTypes+import GHC.Types.Name hiding ( varName )+import GHC.Types.Name.Reader+import GHC.Types.Basic import TysPrim import TysWiredIn import PrelNames@@ -40,10 +40,10 @@ import TcRnMonad import GHC.Driver.Types import ErrUtils( Validity(..), andValid )-import SrcLoc+import GHC.Types.SrcLoc import Bag-import VarEnv-import VarSet (elemVarSet)+import GHC.Types.Var.Env+import GHC.Types.Var.Set (elemVarSet) import Outputable import FastString import Util@@ -279,7 +279,7 @@        -- (ty arg), where head of ty is neither (->) nor a tuple constructor and       -- the parameter of interest does not occur in ty-      , ft_ty_app = \_ arg -> arg+      , ft_ty_app = \_ _ arg -> arg        , ft_bad_app = bmbad con wrong_arg       , ft_forall  = \_ body -> body -- polytypes are handled elsewhere
compiler/typecheck/TcHoleErrors.hs view
@@ -24,16 +24,16 @@ import TcMType import TcEvidence import TcType-import Type-import DataCon-import Name-import RdrName ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts )+import GHC.Core.Type+import GHC.Core.DataCon+import GHC.Types.Name+import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts ) import PrelNames ( gHC_ERR )-import Id-import VarSet-import VarEnv+import GHC.Types.Id+import GHC.Types.Var.Set+import GHC.Types.Var.Env import Bag-import ConLike          ( ConLike(..) )+import GHC.Core.ConLike ( ConLike(..) ) import Util import TcEnv (tcLookup) import Outputable
compiler/typecheck/TcHoleErrors.hs-boot view
@@ -7,7 +7,7 @@ import TcRnTypes  ( TcM ) import Constraint ( Ct, Implication ) import Outputable ( SDoc )-import VarEnv     ( TidyEnv )+import GHC.Types.Var.Env ( TidyEnv )  findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct                   -> TcM (TidyEnv, SDoc)
compiler/typecheck/TcHsSyn.hs view
@@ -51,9 +51,9 @@ import GhcPrelude  import GHC.Hs-import Id-import IdInfo-import Predicate+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core.Predicate import TcRnMonad import PrelNames import BuildTyCl ( TcMethInfo, MethInfo )@@ -61,28 +61,27 @@ import TcMType import TcEnv   ( tcLookupGlobalOnly ) import TcEvidence-import TyCoPpr ( pprTyVar )+import GHC.Core.TyCo.Ppr ( pprTyVar ) import TysPrim-import TyCon+import GHC.Core.TyCon import TysWiredIn-import Type-import Coercion-import ConLike-import DataCon+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.ConLike+import GHC.Core.DataCon import GHC.Driver.Types-import Name-import NameEnv-import Var-import VarEnv-import GHC.Driver.Session-import Literal-import BasicTypes+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Platform+import GHC.Types.Basic import Maybes-import SrcLoc+import GHC.Types.SrcLoc import Bag import Outputable import Util-import UniqFM+import GHC.Types.Unique.FM import GHC.Core  import {-# SOURCE #-} TcSplice (runTopSplice)@@ -146,12 +145,12 @@  -- Overloaded literals. Here mainly because it uses isIntTy etc -shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)-shortCutLit dflags (HsIntegral int@(IL src neg i)) ty-  | isIntTy ty  && inIntRange  dflags i = Just (HsLit noExtField (HsInt noExtField int))-  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))+shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)+shortCutLit platform (HsIntegral int@(IL src neg i)) ty+  | isIntTy ty  && platformInIntRange  platform i = Just (HsLit noExtField (HsInt noExtField int))+  | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i))   | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty))-  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty+  | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty         -- The 'otherwise' case is important         -- Consider (3 :: Float).  Syntactically it looks like an IntLit,         -- so we'll call shortCutIntLit, but of course it's a float@@ -273,7 +272,7 @@   See Note [Zonking the LHS of a RULE]  * RuntimeUnkFlexi: is a special case for the GHCi debugger.-  It's a way to have a variable that is not a mutuable+  It's a way to have a variable that is not a mutable   unification variable, but doesn't have a binding site   either. -}@@ -553,13 +552,12 @@                        , pat_ext = NPatBindTc fvs new_ty }) }  zonk_bind env (VarBind { var_ext = x-                       , var_id = var, var_rhs = expr, var_inline = inl })+                       , var_id = var, var_rhs = expr })   = do { new_var  <- zonkIdBndr env var        ; new_expr <- zonkLExpr env expr        ; return (VarBind { var_ext = x                          , var_id = new_var-                         , var_rhs = new_expr-                         , var_inline = inl }) }+                         , var_rhs = new_expr }) }  zonk_bind env bind@(FunBind { fun_id = L loc var                             , fun_matches = ms@@ -798,8 +796,7 @@ zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =   runTopSplice s >>= zonkExpr env -zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen-                           return (HsSpliceE x s)+zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e)  zonkExpr env (OpApp fixity e1 op e2)   = do new_e1 <- zonkLExpr env e1@@ -1866,17 +1863,14 @@ zonkTcTypeToType :: TcType -> TcM Type zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty -zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type-zonkTcTypeToTypeX = mapType zonk_tycomapper- zonkTcTypesToTypes :: [TcType] -> TcM [Type] zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys +zonkTcTypeToTypeX   :: ZonkEnv -> TcType   -> TcM Type zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]-zonkTcTypesToTypesX env tys = mapM (zonkTcTypeToTypeX env) tys--zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion-zonkCoToCo = mapCoercion zonk_tycomapper+zonkCoToCo          :: ZonkEnv -> Coercion -> TcM Coercion+(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _)+  = mapTyCoX zonk_tycomapper  zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec)
compiler/typecheck/TcHsType.hs view
@@ -32,7 +32,7 @@         ContextKind(..),                  -- Type checking type and class decls-        kcLookupTcTyCon, bindTyClTyVars,+        bindTyClTyVars,         etaExpandAlgTyCon, tcbVisibilities,            -- tyvars@@ -54,7 +54,6 @@         typeLevelMode, kindLevelMode,          kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone,-        checkExpectedKind_pp,          -- Sort-checking kinds         tcLHsKindSig, checkDataKindSig, DataSort(..),@@ -74,7 +73,7 @@ import GHC.Hs import TcRnMonad import TcOrigin-import Predicate+import GHC.Core.Predicate import Constraint import TcEvidence import TcEnv@@ -84,32 +83,32 @@ import GHC.IfaceToCore import TcSimplify import TcHsSyn-import TyCoRep-import TyCoPpr+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr import TcErrors ( reportAllUnsolved ) import TcType import Inst   ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder )-import Type+import GHC.Core.Type import TysPrim-import RdrName( lookupLocalRdrOcc )-import Var-import VarSet-import TyCon-import ConLike-import DataCon-import Class-import Name--- import NameSet-import VarEnv+import GHC.Types.Name.Reader( lookupLocalRdrOcc )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Core.TyCon+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.Class+import GHC.Types.Name+-- import GHC.Types.Name.Set+import GHC.Types.Var.Env import TysWiredIn-import BasicTypes-import SrcLoc+import GHC.Types.Basic+import GHC.Types.SrcLoc import Constants ( mAX_CTUPLE_SIZE ) import ErrUtils( MsgDoc )-import Unique-import UniqSet+import GHC.Types.Unique+import GHC.Types.Unique.Set import Util-import UniqSupply+import GHC.Types.Unique.Supply import Outputable import FastString import PrelNames hiding ( wildCardName )@@ -196,19 +195,31 @@ tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)  kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()-kcClassSigType skol_info names sig_ty-  = discardResult $-    tcClassSigType skol_info names sig_ty-  -- tcClassSigType does a fair amount of extra work that we don't need,-  -- such as ordering quantified variables. But we absolutely do need-  -- to push the level when checking method types and solve local equalities,-  -- and so it seems easier just to call tcClassSigType than selectively-  -- extract the lines of code from tc_hs_sig_type that we really need.-  -- If we don't push the level, we get #16517, where GHC accepts-  --   class C a where-  --     meth :: forall k. Proxy (a :: k) -> ()-  -- Note that k is local to meth -- this is hogwash.+-- This is a special form of tcClassSigType that is used during the+-- kind-checking phase to infer the kind of class variables. Cf. tc_hs_sig_type.+-- Importantly, this does *not* kind-generalize. Consider+--   class SC f where+--     meth :: forall a (x :: f a). Proxy x -> ()+-- When instantiating Proxy with kappa, we must unify kappa := f a. But we're+-- still working out the kind of f, and thus f a will have a coercion in it.+-- Coercions block unification (Note [Equalities with incompatible kinds] in+-- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll+-- end up promoting kappa to the top level (because kind-generalization is+-- normally done right before adding a binding to the context), and then we+-- can't set kappa := f a, because a is local.+kcClassSigType skol_info names (HsIB { hsib_ext  = sig_vars+                                     , hsib_body = hs_ty })+  = addSigCtxt (funsSigCtxt names) hs_ty $+    do { (tc_lvl, (wanted, (spec_tkvs, _)))+           <- pushTcLevelM                           $+              solveLocalEqualitiesX "kcClassSigType" $+              bindImplicitTKBndrs_Skol sig_vars      $+              tc_lhs_type typeLevelMode hs_ty liftedTypeKind +       ; emitResidualTvConstraint skol_info Nothing spec_tkvs+                                  tc_lvl wanted }+kcClassSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec+ tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking tcClassSigType skol_info names sig_ty@@ -400,7 +411,7 @@                setXOptM LangExt.PartialTypeSignatures $                -- See Note [Wildcards in visible type application]                tcNamedWildCardBinders sig_wcs $ \ _ ->-               tcCheckLHsType hs_ty kind+               tcCheckLHsType hs_ty (TheKind kind)        -- We do not kind-generalize type applications: we just        -- instantiate with exactly what the user says.        -- See Note [No generalization in type application]@@ -466,10 +477,11 @@ tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind  -- Like tcHsType, but takes an expected kind-tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM TcType+tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType tcCheckLHsType hs_ty exp_kind   = addTypeCtxt hs_ty $-    tc_lhs_type typeLevelMode hs_ty exp_kind+    do { ek <- newExpectedKind exp_kind+       ; tc_lhs_type typeLevelMode hs_ty ek }  tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind) -- Called from outside: set the context@@ -969,7 +981,7 @@     UnboxedTuple ->       let tycon    = tupleTyCon Unboxed arity           tau_reps = map kindRep tau_kinds-          -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon+          -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon           arg_tys  = tau_reps ++ tau_tys           res_kind = unboxedTupleKind tau_reps in       check_expected_kind (mkTyConApp tycon arg_tys) res_kind@@ -1431,27 +1443,18 @@                   -> TcKind             -- ^ the expected kind                   -> TcM TcType -- Just a convenience wrapper to save calls to 'ppr'-checkExpectedKind hs_ty ty act exp-  = checkExpectedKind_pp (ppr hs_ty) ty act exp--checkExpectedKind_pp :: HasDebugCallStack-                     => SDoc               -- ^ The thing we are checking-                     -> TcType             -- ^ type we're checking-                     -> TcKind             -- ^ the known kind of that type-                     -> TcKind             -- ^ the expected kind-                     -> TcM TcType-checkExpectedKind_pp pp_hs_ty ty act_kind exp_kind+checkExpectedKind hs_ty ty act_kind exp_kind   = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)         ; (new_args, act_kind') <- tcInstInvisibleTyBinders n_to_inst act_kind         ; let origin = TypeEqOrigin { uo_actual   = act_kind'                                    , uo_expected = exp_kind-                                   , uo_thing    = Just pp_hs_ty+                                   , uo_thing    = Just (ppr hs_ty)                                    , uo_visible  = True } -- the hs_ty is visible         ; traceTc "checkExpectedKindX" $-         vcat [ pp_hs_ty+         vcat [ ppr hs_ty               , text "act_kind':" <+> ppr act_kind'               , text "exp_kind:" <+> ppr exp_kind ] @@ -1473,7 +1476,6 @@       n_act_invis_bndrs = invisibleTyBndrCount act_kind       n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs - --------------------------- tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] tcHsMbContext Nothing    = return []@@ -1541,7 +1543,7 @@      -- We cannot promote a data constructor with a context that contains     -- constraints other than equalities, so error if we find one.-    -- See Note [Constraints in kinds] in TyCoRep+    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep     dc_theta_illegal_constraint :: ThetaType -> Maybe PredType     dc_theta_illegal_constraint = find (not . isEqPred) @@ -2467,7 +2469,7 @@   * The use of tcImplicitQTKBndrs   * The tcLookupLocal_maybe code in kc_hs_tv -See Note [Associated type tyvar names] in Class and+See Note [Associated type tyvar names] in GHC.Core.Class and     Note [TyVar binders for associated decls] in GHC.Hs.Decls  We must do the same for family instance decls, where the in-scope@@ -2748,28 +2750,18 @@ --------------------------------------  bindTyClTyVars :: Name-               -> ([TyConBinder] -> Kind -> TcM a) -> TcM a+               -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a -- ^ Used for the type variables of a type or class decl -- in the "kind checking" and "type checking" pass, -- but not in the initial-kind run. bindTyClTyVars tycon_name thing_inside-  = do { tycon <- kcLookupTcTyCon tycon_name+  = do { tycon <- tcLookupTcTyCon tycon_name        ; let scoped_prs = tcTyConScopedTyVars tycon              res_kind   = tyConResKind tycon              binders    = tyConBinders tycon        ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs)        ; tcExtendNameTyVarEnv scoped_prs $-         thing_inside binders res_kind }---- inferInitialKind has made a suitably-shaped kind for the type or class--- Look it up in the local environment. This is used only for tycons--- that we're currently type-checking, so we're sure to find a TcTyCon.-kcLookupTcTyCon :: Name -> TcM TcTyCon-kcLookupTcTyCon nm-  = do { tc_ty_thing <- tcLookup nm-       ; return $ case tc_ty_thing of-           ATcTyCon tc -> tc-           _           -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) }+         thing_inside tycon binders res_kind }   {- *********************************************************************@@ -2919,7 +2911,7 @@  ----------------------------------- etaExpandAlgTyCon :: [TyConBinder]-                  -> Kind+                  -> Kind   -- must be zonked                   -> TcM ([TyConBinder], Kind) -- GADT decls can have a (perhaps partial) kind signature --      e.g.  data T a :: * -> * -> * where ...@@ -2929,6 +2921,7 @@ -- Never emits constraints. -- It's a little trickier than you might think: see -- Note [TyConBinders for the result kind signature of a data type]+-- See Note [Datatype return kinds] in TcTyClsDecls etaExpandAlgTyCon tc_bndrs kind   = do  { loc     <- getSrcSpanM         ; uniqs   <- newUniqueSupply@@ -2997,6 +2990,8 @@ -- 1. @TYPE r@ (for some @r@), or -- -- 2. @k@ (where @k@ is a bare kind variable; see #12369)+--+-- See also Note [Datatype return kinds] in TcTyClsDecls checkDataKindSig :: DataSort -> Kind -> TcM () checkDataKindSig data_sort kind = do   dflags <- getDynFlags@@ -3005,11 +3000,11 @@     pp_dec :: SDoc     pp_dec = text $       case data_sort of-        DataDeclSort     DataType -> "data type"-        DataDeclSort     NewType  -> "newtype"-        DataInstanceSort DataType -> "data instance"-        DataInstanceSort NewType  -> "newtype instance"-        DataFamilySort            -> "data family"+        DataDeclSort     DataType -> "Data type"+        DataDeclSort     NewType  -> "Newtype"+        DataInstanceSort DataType -> "Data instance"+        DataInstanceSort NewType  -> "Newtype instance"+        DataFamilySort            -> "Data family"      is_newtype :: Bool     is_newtype =@@ -3052,8 +3047,8 @@      err_msg :: DynFlags -> SDoc     err_msg dflags =-      sep [ (sep [ text "Kind signature on" <+> pp_dec <+>-                   text "declaration has non-" <>+      sep [ (sep [ pp_dec <+>+                   text "has non-" <>                    (if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind)                  , (if is_data_family then text "and non-variable" else empty) <+>                    text "return kind" <+> quotes (ppr kind) ])
compiler/typecheck/TcInstDcls.hs view
@@ -37,9 +37,9 @@ import BuildTyCl import Inst import ClsInst( AssocInstInfo(..), isNotAssociated )-import InstEnv+import GHC.Core.InstEnv import FamInst-import FamInstEnv+import GHC.Core.FamInstEnv import TcDeriv import TcEnv import TcHsType@@ -47,27 +47,27 @@ import GHC.Core        ( Expr(..), mkApps, mkVarApps, mkLams ) import GHC.Core.Make   ( nO_METHOD_BINDING_ERROR_ID ) import GHC.Core.Unfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )-import Type+import GHC.Core.Type import TcEvidence-import TyCon-import CoAxiom-import DataCon-import ConLike-import Class-import Var-import VarEnv-import VarSet+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.Class+import GHC.Types.Var as Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set import Bag-import BasicTypes+import GHC.Types.Basic import GHC.Driver.Session import ErrUtils import FastString-import Id+import GHC.Types.Id import ListSetOps-import Name-import NameSet+import GHC.Types.Name+import GHC.Types.Name.Set import Outputable-import SrcLoc+import GHC.Types.SrcLoc import Util import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import qualified GHC.LanguageExtensions as LangExt@@ -163,7 +163,7 @@   loop-breaker because df_i isn't), op1_i will ironically never be   inlined.  But this is OK: the recursion breaking happens by way of   a RULE (the magic ClassOp rule above), and RULES work inside InlineRule-  unfoldings. See Note [RULEs enabled in InitialPhase] in SimplUtils+  unfoldings. See Note [RULEs enabled in InitialPhase] in GHC.Core.Op.Simplify.Utils  Note [ClassOp/DFun selection] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -195,7 +195,7 @@   * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that    extracts the right piece iff its argument satisfies-   exprIsConApp_maybe.  This is done in MkId mkDictSelId+   exprIsConApp_maybe.  This is done in GHC.Types.Id.Make.mkDictSelId   * We make 'df' CONLIKE, so that shared uses still match; eg       let d = df d1 d2@@ -311,7 +311,7 @@ When type-checking the C [a] instance, we need a C [a] dictionary (for the call of op2).  If we look up in the instance environment, we find an overlap.  And in *general* the right thing is to complain (see Note-[Overlapping instances] in InstEnv).  But in *this* case it's wrong to+[Overlapping instances] in GHC.Core.InstEnv).  But in *this* case it's wrong to complain, because we just want to delegate to the op2 of this same instance. @@ -660,7 +660,7 @@        ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)        ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons           -- Do /not/ check that the number of patterns = tyConArity fam_tc-          -- See [Arity of data families] in FamInstEnv+          -- See [Arity of data families] in GHC.Core.FamInstEnv        ; (qtvs, pats, res_kind, stupid_theta)              <- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs                                     fixity hs_ctxt hs_pats m_ksig hs_cons@@ -684,10 +684,12 @@        -- kind `TYPE r`, for some `r`. If UnliftedNewtypes is not enabled, we        -- go one step further and ensure that it has kind `TYPE 'LiftedRep`.        ---       -- See also Note [Arity of data families] in FamInstEnv+       -- See also Note [Arity of data families] in GHC.Core.FamInstEnv        -- NB: we can do this after eta-reducing the axiom, because if        --     we did it before the "extra" tvs from etaExpandAlgTyCon        --     would always be eta-reduced+       --+       -- See also Note [Datatype return kinds] in TcTyClsDecls        ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind        ; checkDataKindSig (DataInstanceSort new_or_data) final_res_kind        ; let extra_pats  = map (mkTyVarTy . binderVar) extra_tcbs@@ -725,7 +727,7 @@                     parent = DataFamInstTyCon axiom fam_tc all_pats                        -- NB: Use the full ty_binders from the pats. See bullet toward-                      -- the end of Note [Data type families] in TyCon+                      -- the end of Note [Data type families] in GHC.Core.TyCon                     rep_tc   = mkAlgTyCon rep_tc_name                                           ty_binders final_res_kind                                           (map (const Nominal) ty_binders)@@ -759,7 +761,7 @@        ; return (fam_inst, m_deriv_info) }   where     eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])-    -- See Note [Eta reduction for data families] in FamInstEnv+    -- See Note [Eta reduction for data families] in GHC.Core.FamInstEnv     -- Splits the incoming patterns into two: the [TyVar]     -- are the patterns that can be eta-reduced away.     -- e.g.     T [a] Int a d c   ==>  (T [a] Int a, [d,c])@@ -797,7 +799,7 @@ -- Here the "header" is the bit before the "where" tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity                     hs_ctxt hs_pats m_ksig hs_cons new_or_data-  = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty)))+  = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, lhs_applied_kind)))             <- pushTcLevelM_                                $                solveEqualities                              $                bindImplicitTKBndrs_Q_Skol imp_vars          $@@ -815,9 +817,18 @@                   -- Add constraints from the data constructors                   ; kcConDecls new_or_data res_kind hs_cons -                  ; lhs_ty <- checkExpectedKind_pp pp_lhs lhs_ty lhs_kind res_kind-                  ; return (stupid_theta, lhs_ty) }+                  -- See Note [Datatype return kinds] in TcTyClsDecls, point (7).+                  ; (lhs_extra_args, lhs_applied_kind)+                      <- tcInstInvisibleTyBinders (invisibleTyBndrCount lhs_kind)+                                                  lhs_kind+                  ; let lhs_applied_ty = lhs_ty `mkTcAppTys` lhs_extra_args+                        hs_lhs         = nlHsTyConApp fixity (getName fam_tc) hs_pats+                  ; _ <- unifyKind (Just (unLoc hs_lhs)) lhs_applied_kind res_kind +                  ; return ( stupid_theta+                           , lhs_applied_ty+                           , lhs_applied_kind ) }+        -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts]        -- This code (and the stuff immediately above) is very similar        -- to that in tcTyFamInstEqnGuts.  Maybe we should abstract the@@ -829,10 +840,10 @@        ; qtvs <- quantifyTyVars dvs         -- Zonk the patterns etc into the Type world-       ; (ze, qtvs)   <- zonkTyBndrs qtvs-              -- See Note [Unifying data family kinds] about the discardCast-       ; lhs_ty       <- zonkTcTypeToTypeX ze (discardCast lhs_ty)-       ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta+       ; (ze, qtvs)       <- zonkTyBndrs qtvs+       ; lhs_ty           <- zonkTcTypeToTypeX ze lhs_ty+       ; stupid_theta     <- zonkTcTypesToTypesX ze stupid_theta+       ; lhs_applied_kind <- zonkTcTypeToTypeX ze lhs_applied_kind         -- Check that type patterns match the class instance head        -- The call to splitTyConApp_maybe here is just an inlining of@@ -840,12 +851,10 @@        ; pats <- case splitTyConApp_maybe lhs_ty of            Just (_, pats) -> pure pats            Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty)-       ; return (qtvs, pats, typeKind lhs_ty, stupid_theta) }-          -- See Note [Unifying data family kinds] about why we need typeKind here+       ; return (qtvs, pats, lhs_applied_kind, stupid_theta) }   where     fam_name  = tyConName fam_tc     data_ctxt = DataKindCtxt fam_name-    pp_lhs    = pprHsFamInstLHS fam_name mb_bndrs hs_pats fixity hs_ctxt     exp_bndrs = mb_bndrs `orElse` []      -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls, wrinkle (2).@@ -863,7 +872,11 @@            ; lvl <- getTcLevel            ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs              -- Perhaps surprisingly, we don't need the skolemised tvs themselves-           ; return (substTy subst inner_kind) }+           ; let final_kind = substTy subst inner_kind+           ; checkDataKindSig (DataInstanceSort new_or_data) $+               snd $ tcSplitPiTys final_kind+             -- See Note [Datatype return kinds], end of point (4)+           ; return final_kind }  {- Note [Result kind signature for a data family instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -874,36 +887,6 @@ Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise Examples in indexed-types/should_compile/T12369 -Note [Unifying data family kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we kind-check a newtype instance with -XUnliftedNewtypes, we must-unify the kind of the data family with any declared kind in the instance-declaration. For example:--  data Color = Red | Blue-  type family Interpret (x :: Color) :: RuntimeRep where-    Interpret 'Red = 'IntRep-    Interpret 'Blue = 'WordRep-  data family Foo (x :: Color) :: TYPE (Interpret x)-  newtype instance Foo 'Red :: TYPE IntRep where-    FooRedC :: Int# -> Foo 'Red--We end up unifying `TYPE (Interpret 'Red)` (the kind of Foo, instantiated-with 'Red) and `TYPE IntRep` (the declared kind of the instance). This-unification succeeds, resulting in a coercion. The big question: what to-do with this coercion? Answer: nothing! A kind annotation on a newtype instance-is always redundant (except, perhaps, in that it helps guide unification). We-have a definitive kind for the data family from the data family declaration,-and so we learn nothing really new from the kind signature on an instance.-We still must perform this unification (done in the call to checkExpectedKind-toward the beginning of tcDataFamInstHeader), but the result is unhelpful. If there-is a cast, it will wrap the lhs_ty, and so we just drop it before splitting the-lhs_ty to reveal the underlying patterns. Because of the potential of dropping-a cast like this, we just use typeKind in the result instead of propagating res_kind-from above.--This Note is wrinkle (3) in Note [Implementation of UnliftedNewtypes] in TcTyClsDecls.- Note [Eta-reduction for data families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -933,10 +916,11 @@   eta-reduced type variables last.  * Although we eta-reduce the axiom, we eta-/expand/ the representation-  tycon Drep.  The kind of D says it takses four arguments, but the-  data instance header only supplies three.  But the AlgTyCOn for Drep+  tycon Drep.  The kind of D says it takes four arguments, but the+  data instance header only supplies three.  But the AlgTyCon for Drep   itself must have enough TyConBinders so that its result kind is Type.-  So, with etaExpandAlgTyCon we make up some extra TyConBinders+  So, with etaExpandAlgTyCon we make up some extra TyConBinders.+  See point (3) in Note [Datatype return kinds] in TcTyClsDecls.  * The result kind in the instance might be a polykind, like this:      data family DP a :: forall k. k -> *
compiler/typecheck/TcInteract.hs view
@@ -11,35 +11,36 @@ #include "HsVersions.h"  import GhcPrelude-import BasicTypes ( SwapFlag(..), isSwapped,-                    infinity, IntWithInf, intGtLimit )+import GHC.Types.Basic ( SwapFlag(..), isSwapped,+                         infinity, IntWithInf, intGtLimit ) import TcCanonical import TcFlatten import TcUnify( canSolveByUnification )-import VarSet-import Type-import InstEnv( DFunInstType )-import CoAxiom( sfInteractTop, sfInteractInert )+import GHC.Types.Var.Set+import GHC.Core.Type as Type+import GHC.Core.Coercion        ( BlockSubstFlag(..) )+import GHC.Core.InstEnv         ( DFunInstType )+import GHC.Core.Coercion.Axiom  ( sfInteractTop, sfInteractInert ) -import Var+import GHC.Types.Var import TcType import PrelNames ( coercibleTyConKey,                    heqTyConKey, eqTyConKey, ipClassKey )-import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )-import Class-import TyCon+import GHC.Core.Coercion.Axiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )+import GHC.Core.Class+import GHC.Core.TyCon import FunDeps import FamInst import ClsInst( InstanceWhat(..), safeOverlap )-import FamInstEnv-import Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )+import GHC.Core.FamInstEnv+import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )  import TcEvidence import Outputable  import TcRnTypes import Constraint-import Predicate+import GHC.Core.Predicate import TcOrigin import TcSMonad import Bag@@ -47,13 +48,13 @@  import GHC.Core import Data.List( partition, deleteFirstsBy )-import SrcLoc-import VarEnv+import GHC.Types.SrcLoc+import GHC.Types.Var.Env  import Control.Monad import Maybes( isJust ) import Pair (Pair(..))-import Unique( hasKey )+import GHC.Types.Unique( hasKey ) import GHC.Driver.Session import Util import qualified GHC.LanguageExtensions as LangExt@@ -687,8 +688,9 @@ -- mean that (ty1 ~ ty2) interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_insol = insoluble })-  | insoluble  -- For insolubles, don't allow the constraint to be dropped+interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_status = status })+  | InsolubleCIS <- status+               -- 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]@@ -1461,7 +1463,7 @@ applications, but that would require new evidence forms, and an extension to FC, so we don't do that right now (Dec 14). -See also Note [Injective type families] in TyCon+See also Note [Injective type families] in GHC.Core.TyCon   Note [Cache-caused loops]@@ -1639,9 +1641,9 @@ --        workItem = the new Given constraint -- -- NB: No need for an occurs check here, because solveByUnification always---     arises from a CTyEqCan, a *canonical* constraint.  Its invariants---     say that in (a ~ xi), the type variable a does not appear in xi.---     See TcRnTypes.Ct invariants.+--     arises from a CTyEqCan, a *canonical* constraint.  Its invariant (TyEq:OC)+--     says that in (a ~ xi), the type variable a does not appear in xi.+--     See Constraint.Ct invariants. -- -- Post: tv is unified (by side effect) with xi; --       we often write tv := xi@@ -1880,7 +1882,7 @@ kind is not Constraint, such as (forall a. F a ~# b)  See- * Note [Evidence for quantified constraints] in Predicate+ * Note [Evidence for quantified constraints] in GHC.Core.Predicate  * Note [Equality superclasses in quantified constraints]    in TcCanonical @@ -2102,7 +2104,8 @@                                        `mkTcTransCo` ctEvCoercion old_ev) )             Wanted {} ->-             do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal+             -- See TcCanonical Note [Equalities with incompatible kinds] about NoBlockSubst+             do { (new_ev, new_co) <- newWantedEq_SI NoBlockSubst WDeriv deeper_loc Nominal                                         (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)                 ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co                 ; return new_ev }@@ -2634,7 +2637,7 @@ BUT that wanted also unifies with the top-level Eq [a] instance, and Eq (Maybe a) etc.  We want the local instance to "win", otherwise we can't solve the wanted at all.  So we mark it as Incohherent.-According to Note [Rules for instance lookup] in InstEnv, that'll+According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll make it win even if there are other instances that unify.  Moreover this is not a hack!  The evidence for this local instance
compiler/typecheck/TcMType.hs view
@@ -97,38 +97,38 @@ -- friends: import GhcPrelude -import TyCoRep-import TyCoPpr+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr import TcType-import Type-import TyCon-import Coercion-import Class-import Var-import Predicate+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Core.Coercion+import GHC.Core.Class+import GHC.Types.Var+import GHC.Core.Predicate import TcOrigin  -- others: import TcRnMonad        -- TcType, amongst others import Constraint import TcEvidence-import Id-import Name-import VarSet+import GHC.Types.Id as Id+import GHC.Types.Name+import GHC.Types.Var.Set import TysWiredIn import TysPrim-import VarEnv-import NameEnv+import GHC.Types.Var.Env+import GHC.Types.Name.Env import PrelNames import Util import Outputable import FastString import Bag import Pair-import UniqSet+import GHC.Types.Unique.Set import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt-import BasicTypes ( TypeOrKind(..) )+import GHC.Types.Basic ( TypeOrKind(..) )  import Control.Monad import Maybes@@ -184,7 +184,7 @@ -- Deals with both equality and non-equality predicates newWanted orig t_or_k pty   = do loc <- getCtLocM orig t_or_k-       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole pty+       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole YesBlockSubst pty                                 else EvVarDest <$> newEvVar pty        return $ CtWanted { ctev_dest = d                          , ctev_pred = pty@@ -211,8 +211,8 @@  cloneWanted :: Ct -> TcM Ct cloneWanted ct-  | ev@(CtWanted { ctev_dest = HoleDest {}, ctev_pred = pty }) <- ctEvidence ct-  = do { co_hole <- newCoercionHole pty+  | ev@(CtWanted { ctev_dest = HoleDest old_hole, ctev_pred = pty }) <- ctEvidence ct+  = do { co_hole <- newCoercionHole (ch_blocker old_hole) pty        ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }   | otherwise   = return ct@@ -262,7 +262,7 @@ -- | Emits a new equality constraint emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion emitWantedEq origin t_or_k role ty1 ty2-  = do { hole <- newCoercionHole pty+  = do { hole <- newCoercionHole YesBlockSubst pty        ; loc <- getCtLocM origin (Just t_or_k)        ; emitSimple $ mkNonCanonical $          CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole@@ -323,12 +323,16 @@ ************************************************************************ -} -newCoercionHole :: TcPredType -> TcM CoercionHole-newCoercionHole pred_ty+newCoercionHole :: BlockSubstFlag  -- should the presence of this hole block substitution?+                                   -- See sub-wrinkle in TcCanonical+                                   -- Note [Equalities with incompatible kinds]+                -> TcPredType -> TcM CoercionHole+newCoercionHole blocker pred_ty   = do { co_var <- newEvVar pred_ty-       ; traceTc "New coercion hole:" (ppr co_var)+       ; traceTc "New coercion hole:" (ppr co_var <+> ppr blocker)        ; ref <- newMutVar Nothing-       ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }+       ; return $ CoercionHole { ch_co_var = co_var, ch_blocker = blocker+                               , ch_ref = ref } }  -- | Put a value in a coercion hole fillCoercionHole :: CoercionHole -> Coercion -> TcM ()@@ -1106,7 +1110,7 @@    To achieve that we use deterministic sets of variables that can be   converted to lists in a deterministic order. For more information-  about deterministic sets see Note [Deterministic UniqFM] in UniqDFM.+  about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM.  * Order: as well as being deterministic, we use an   accumulating-parameter style for candidateQTyVarsOfType so that we@@ -1432,7 +1436,7 @@  Note [Recurring into kinds for candidateQTyVars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-First, read Note [Closing over free variable kinds] in TyCoFVs, paying+First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying attention to the end of the Note about using an empty bound set when traversing a variable's kind. @@ -1449,7 +1453,7 @@ use different Uniques for different variables. (In contrast, the Core functions work on the output of optimizations, which may introduce shadowing.) Without shadowing, the problem studied by-Note [Closing over free variable kinds] in TyCoFVs cannot happen.+Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen.  Why it is necessary: Wiping the bound set would be just plain wrong here. Consider@@ -1460,7 +1464,7 @@ never be able to fill in `hole`, but we don't want to go off the rails just because we have an insoluble coercion hole.) So: why is it wrong to wipe the bound variables here but right in Core? Because the final statement-in Note [Closing over free variable kinds] in TyCoFVs is wrong: not+in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not every variable is either free or bound. A variable can be a hole, too! The reasoning in that Note then breaks down. @@ -1545,7 +1549,7 @@ to be later converted to a list in a deterministic order.  For more information about deterministic sets see-Note [Deterministic UniqFM] in UniqDFM.+Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -}  quantifyTyVars@@ -1974,9 +1978,6 @@ zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv)                         ; return (setTyVarKind tv kind') } -zonkTcTypes :: [TcType] -> TcM [TcType]-zonkTcTypes tys = mapM zonkTcType tys- {- ************************************************************************ *                                                                      *@@ -2023,9 +2024,8 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~ zonkCt tries to maintain the canonical form of a Ct.  For example,   - a CDictCan should stay a CDictCan;-  - a CTyEqCan should stay a CTyEqCan (if the LHS stays as a variable.).   - a CHoleCan should stay a CHoleCan-  - a CIrredCan should stay a CIrredCan with its cc_insol flag intact+  - a CIrredCan should stay a CIrredCan with its cc_status flag intact  Why?, for example: - For CDictCan, the @TcSimplify.expandSuperClasses@ step, which runs after the@@ -2038,6 +2038,11 @@  - For CIrredCan we want to see if a constraint is insoluble with insolubleWC +On the other hand, we change CTyEqCan to CNonCanonical, because of all of+CTyEqCan's invariants, which can break during zonking. Besides, the constraint+will be canonicalised again, so there is little benefit in keeping the+CTyEqCan structure.+ NB: we do not expect to see any CFunEqCans, because zonkCt is only called on unflattened constraints. @@ -2048,6 +2053,7 @@ -}  zonkCt :: Ct -> TcM Ct+-- See Note [zonkCt behaviour] zonkCt ct@(CHoleCan { cc_ev = ev })   = do { ev' <- zonkCtEvidence ev        ; return $ ct { cc_ev = ev' } }@@ -2059,12 +2065,8 @@  zonkCt (CTyEqCan { cc_ev = ev })   = mkNonCanonical <$> zonkCtEvidence ev-  -- CTyEqCan has some delicate invariants that may be violated by-  -- zonking (documented with the Ct type) , so we don't want to create-  -- a CTyEqCan here. Besides, this will be canonicalized again anyway,-  -- so there is very little benefit in keeping the CTyEqCan constructor. -zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_insol flag+zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag   = do { ev' <- zonkCtEvidence ev        ; return (ct { cc_ev = ev' }) } @@ -2110,14 +2112,15 @@  -} --- zonkId is used *during* typechecking just to zonk the Id's type-zonkId :: TcId -> TcM TcId-zonkId id-  = do { ty' <- zonkTcType (idType id)-       ; return (Id.setIdType id ty') }+-- For unbound, mutable tyvars, zonkType uses the function given to it+-- For tyvars bound at a for-all, zonkType zonks them to an immutable+--      type variable and zonks the kind too+zonkTcType  :: TcType -> TcM TcType+zonkTcTypes :: [TcType] -> TcM [TcType]+zonkCo      :: Coercion -> TcM Coercion -zonkCoVar :: CoVar -> TcM CoVar-zonkCoVar = zonkId+(zonkTcType, zonkTcTypes, zonkCo, _)+  = mapTyCo zonkTcTypeMapper  -- | A suitable TyCoMapper for zonking a type during type-checking, -- before all metavars are filled in.@@ -2147,16 +2150,6 @@  | otherwise        = do { tck' <- zonkTcType (tyConKind tc)                          ; return (setTcTyConKind tc tck') } --- For unbound, mutable tyvars, zonkType uses the function given to it--- For tyvars bound at a for-all, zonkType zonks them to an immutable---      type variable and zonks the kind too-zonkTcType :: TcType -> TcM TcType-zonkTcType = mapType zonkTcTypeMapper ()---- | "Zonk" a coercion -- really, just zonk any types in the coercion-zonkCo :: Coercion -> TcM Coercion-zonkCo = mapCoercion zonkTcTypeMapper ()- zonkTcTyVar :: TcTyVar -> TcM TcType -- Simply look through all Flexis zonkTcTyVar tv@@ -2197,6 +2190,15 @@     do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv                          ; return (nm, tv') } +-- zonkId is used *during* typechecking just to zonk the Id's type+zonkId :: TcId -> TcM TcId+zonkId id+  = do { ty' <- zonkTcType (idType id)+       ; return (Id.setIdType id ty') }++zonkCoVar :: CoVar -> TcM CoVar+zonkCoVar = zonkId+ {- Note [Sharing in zonking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have@@ -2267,12 +2269,8 @@ ---------------- tidyCt :: TidyEnv -> Ct -> Ct -- Used only in error reporting--- Also converts it to non-canonical tidyCt env ct-  = case ct of-     CHoleCan { cc_ev = ev }-       -> ct { cc_ev = tidy_ev env ev }-     _ -> mkNonCanonical (tidy_ev env (ctEvidence ct))+  = ct { cc_ev = tidy_ev env (ctEvidence ct) }   where     tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence      -- NB: we do not tidy the ctev_evar field because we don't
compiler/typecheck/TcMatches.hs view
@@ -27,7 +27,7 @@ import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho                               , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) -import BasicTypes (LexicalFixity(..))+import GHC.Types.Basic (LexicalFixity(..)) import GHC.Hs import TcRnMonad import TcEnv@@ -37,15 +37,15 @@ import TcBinds import TcUnify import TcOrigin-import Name+import GHC.Types.Name import TysWiredIn-import Id-import TyCon+import GHC.Types.Id+import GHC.Core.TyCon import TysPrim import TcEvidence import Outputable import Util-import SrcLoc+import GHC.Types.SrcLoc  -- Create chunkified tuple tybes for monad comprehensions import GHC.Core.Make
compiler/typecheck/TcMatches.hs-boot view
@@ -1,10 +1,10 @@ module TcMatches where-import GHC.Hs   ( GRHSs, MatchGroup, LHsExpr )-import TcEvidence( HsWrapper )-import Name     ( Name )-import TcType   ( ExpSigmaType, TcRhoType )-import TcRnTypes( TcM )-import SrcLoc   ( Located )+import GHC.Hs           ( GRHSs, MatchGroup, LHsExpr )+import TcEvidence       ( HsWrapper )+import GHC.Types.Name   ( Name )+import TcType           ( ExpSigmaType, TcRhoType )+import TcRnTypes        ( TcM )+import GHC.Types.SrcLoc ( Located ) import GHC.Hs.Extension ( GhcRn, GhcTcId )  tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)
compiler/typecheck/TcPat.hs view
@@ -28,29 +28,29 @@ import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags ) import TcRnMonad import Inst-import Id-import Var-import Name-import RdrName+import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Name.Reader import TcEnv import TcMType import TcValidity( arityErr )-import TyCoPpr ( pprTyVars )+import GHC.Core.TyCo.Ppr ( pprTyVars ) import TcType import TcUnify import TcHsType import TysWiredIn import TcEvidence import TcOrigin-import TyCon-import DataCon-import PatSyn-import ConLike+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Core.PatSyn+import GHC.Core.ConLike import PrelNames-import BasicTypes hiding (SuccessFlag(..))+import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Driver.Session-import SrcLoc-import VarSet+import GHC.Types.SrcLoc+import GHC.Types.Var.Set import Util import Outputable import qualified GHC.LanguageExtensions as LangExt@@ -455,7 +455,7 @@         ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)                                                penv pat_ty                      -- Unboxed tuples have RuntimeRep vars, which we discard:-                     -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+                     -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon         ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys                                            Boxed   -> arg_tys         ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys)@@ -674,7 +674,7 @@    case x :: Map (Int, c) w of MapPair m -> ... -As explained by [Wrappers for data instance tycons] in MkIds.hs, the+As explained by [Wrappers for data instance tycons] in GHC.Types.Id.Make, the worker/wrapper types for MapPair are    $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
compiler/typecheck/TcPatSyn.hs view
@@ -20,39 +20,39 @@  import GHC.Hs import TcPat-import Type( tidyTyCoVarBinders, tidyTypes, tidyType )+import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) import TcRnMonad import TcSigs( emptyPragEnv, completeSigFromId ) import TcEnv import TcMType import TcHsSyn import TysPrim-import Name-import SrcLoc-import PatSyn-import NameSet+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Core.PatSyn+import GHC.Types.Name.Set import Panic import Outputable import FastString-import Var-import VarEnv( emptyTidyEnv, mkInScopeSet )-import Id-import IdInfo( RecSelParent(..), setLevityInfoWithType )+import GHC.Types.Var+import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet )+import GHC.Types.Id+import GHC.Types.Id.Info( RecSelParent(..), setLevityInfoWithType ) import TcBinds-import BasicTypes+import GHC.Types.Basic import TcSimplify import TcUnify-import Predicate+import GHC.Core.Predicate import TysWiredIn import TcType import TcEvidence import TcOrigin import BuildTyCl-import VarSet-import MkId+import GHC.Types.Var.Set+import GHC.Types.Id.Make import TcTyDecls-import ConLike-import FieldLabel+import GHC.Core.ConLike+import GHC.Types.FieldLabel import Bag import Util import ErrUtils@@ -303,7 +303,7 @@   $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a  and that is bad because (a ~# Maybe b) is not a predicate type-(see Note [Types for coercions, predicates, and evidence] in TyCoRep+(see Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep and is not implicitly instantiated.  So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and@@ -400,7 +400,7 @@                   -- satisfy the substitution invariant. There's no need to                   -- add 'ex_tvs' as they are already in the domain of the                   -- substitution.-                  -- See also Note [The substitution invariant] in TyCoSubst.+                  -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.               ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'               ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys               ; return (ex_tvs', prov_dicts, args') }@@ -686,7 +686,7 @@                 -> ([LHsExpr GhcTcId], [TcType])                 -> TcType                 -> TcM ((Id, Bool), LHsBinds GhcTc)--- See Note [Matchers and builders for pattern synonyms] in PatSyn+-- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn tcPatSynMatcher (L loc name) lpat                 (univ_tvs, req_theta, req_ev_binds, req_dicts)                 (ex_tvs, ex_tys, prov_theta, prov_dicts)@@ -714,7 +714,7 @@        ; let matcher_tau   = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty              matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau              matcher_id    = mkExportedVanillaId matcher_name matcher_sigma-                             -- See Note [Exported LocalIds] in Id+                             -- See Note [Exported LocalIds] in GHC.Types.Id               inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys              cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args@@ -803,7 +803,7 @@                               mkVisFunTys arg_tys $                               pat_ty              builder_id     = mkExportedVanillaId builder_name builder_sigma-              -- See Note [Exported LocalIds] in Id+              -- See Note [Exported LocalIds] in GHC.Types.Id               builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id @@ -812,7 +812,7 @@  tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn                     -> TcM (LHsBinds GhcTc)--- See Note [Matchers and builders for pattern synonyms] in PatSyn+-- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn tcPatSynBuilderBind (PSB { psb_id = L loc name                          , psb_def = lpat                          , psb_dir = dir@@ -988,7 +988,7 @@     go1 p@(AsPat {})                         = notInvertible p     go1 p@(ViewPat {})                       = notInvertible p     go1 p@(NPlusKPat {})                     = notInvertible p-    go1 p@(XPat {})                          = notInvertible p+    go1   (XPat nec)                         = noExtCon nec     go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p     go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p     go1 p@(SplicePat _ (HsQuasiQuote {}))    = notInvertible p
compiler/typecheck/TcPluginM.hs view
@@ -60,7 +60,7 @@ import qualified GHC.Iface.Env as IfaceEnv import qualified GHC.Driver.Finder as Finder -import FamInstEnv ( FamInstEnv )+import GHC.Core.FamInstEnv ( FamInstEnv ) import TcRnMonad  ( TcGblEnv, TcLclEnv, TcPluginM                   , unsafeTcPluginTcM, getEvBindsTcPluginM                   , liftIO, traceTc )@@ -69,20 +69,21 @@ import TcEnv      ( TcTyThing ) import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)                   , EvExpr, EvBind, mkGivenEvBind )-import Var        ( EvVar )+import GHC.Types.Var        ( EvVar ) -import Module-import Name-import TyCon-import DataCon-import Class+import GHC.Types.Module+import GHC.Types.Name+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Core.Class import GHC.Driver.Types import Outputable-import Type-import Id-import InstEnv+import GHC.Core.Type+import GHC.Core.Coercion   ( BlockSubstFlag(..) )+import GHC.Types.Id+import GHC.Core.InstEnv import FastString-import Unique+import GHC.Types.Unique   -- | Perform some IO, typically to interact with an external tool.@@ -179,7 +180,7 @@  -- | Create a fresh coercion hole. newCoercionHole :: PredType -> TcPluginM CoercionHole-newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole+newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole YesBlockSubst  -- | Bind an evidence variable.  This must not be invoked from -- 'tcPluginInit' or 'tcPluginStop', or it will panic.
compiler/typecheck/TcRnDriver.hs view
@@ -68,10 +68,10 @@ import GHC.Hs import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) import GHC.Iface.Type   ( ShowForAllFlag(..) )-import PatSyn( pprPatSynType )+import GHC.Core.PatSyn( pprPatSynType ) import PrelNames import PrelInfo-import RdrName+import GHC.Types.Name.Reader import TcHsSyn import TcExpr import TcRnMonad@@ -83,12 +83,13 @@ import GHC.Core.Ppr.TyThing ( pprTyThingInContext ) import GHC.Core.FVs         ( orphNamesOfFamInst ) import FamInst-import InstEnv-import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons-                 , famInstEnvElts, extendFamInstEnvList, normaliseType )+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv+   ( FamInst, pprFamInst, famInstsRepTyCons+   , famInstEnvElts, extendFamInstEnvList, normaliseType ) import TcAnnotations import TcBinds-import GHC.Iface.Utils  ( coAxiomToIfaceDecl )+import GHC.Iface.Make   ( coAxiomToIfaceDecl ) import HeaderInfo       ( mkPrelImports ) import TcDefaults import TcEnv@@ -107,28 +108,28 @@ import GHC.Rename.Env import GHC.Rename.Source import ErrUtils-import Id-import IdInfo( IdDetails(..) )-import VarEnv-import Module-import UniqFM-import Name-import NameEnv-import NameSet-import Avail-import TyCon-import SrcLoc+import GHC.Types.Id as Id+import GHC.Types.Id.Info( IdDetails(..) )+import GHC.Types.Var.Env+import GHC.Types.Module+import GHC.Types.Unique.FM+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Avail+import GHC.Core.TyCon+import GHC.Types.SrcLoc import GHC.Driver.Types import ListSetOps import Outputable-import ConLike-import DataCon-import Type-import Class-import BasicTypes hiding( SuccessFlag(..) )-import CoAxiom-import Annotations-import Data.List ( sortBy, sort )+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Core.Class+import GHC.Types.Basic hiding( SuccessFlag(..) )+import GHC.Core.Coercion.Axiom+import GHC.Types.Annotations+import Data.List ( find, sortBy, sort ) import Data.Ord import FastString import Maybes@@ -267,17 +268,13 @@                ; tcg_env <- if isHsBootOrSig hsc_src                             then tcRnHsBootDecls hsc_src local_decls                             else {-# SCC "tcRnSrcDecls" #-}-                                 tcRnSrcDecls explicit_mod_hdr local_decls+                                 tcRnSrcDecls explicit_mod_hdr local_decls export_ies                ; setGblEnv tcg_env                  $ do { -- Process the export list                         traceRn "rn4a: before exports" empty                       ; tcg_env <- tcRnExports explicit_mod_hdr export_ies                                      tcg_env                       ; traceRn "rn4b: after exports" empty-                      ; -- When a module header is specified,-                        -- check that the main module exports a main function.-                        -- (must be after tcRnExports)-                        when explicit_mod_hdr $ checkMainExported tcg_env                       ; -- Compare hi-boot iface (if any) with the real thing                         -- Must be done after processing the exports                         tcg_env <- checkHiBootIface tcg_env boot_info@@ -399,8 +396,9 @@  tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all              -> [LHsDecl GhcPs]               -- Declarations+             -> Maybe (Located [LIE GhcPs])              -> TcM TcGblEnv-tcRnSrcDecls explicit_mod_hdr decls+tcRnSrcDecls explicit_mod_hdr decls export_ies  = do { -- Do all the declarations       ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls @@ -409,7 +407,7 @@         -- NB: always set envs *before* captureTopConstraints       ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $                                captureTopConstraints $-                               checkMain explicit_mod_hdr+                               checkMain explicit_mod_hdr export_ies        ; setEnvs (tcg_env, tcl_env) $ do { @@ -1718,29 +1716,69 @@ -}  checkMain :: Bool  -- False => no 'module M(..) where' header at all+          -> Maybe (Located [LIE GhcPs])  -- Export specs of Main module           -> TcM TcGblEnv--- If we are in module Main, check that 'main' is defined.-checkMain explicit_mod_hdr+-- If we are in module Main, check that 'main' is defined and exported.+checkMain explicit_mod_hdr export_ies  = do   { dflags  <- getDynFlags         ; tcg_env <- getGblEnv-        ; check_main dflags tcg_env explicit_mod_hdr }+        ; check_main dflags tcg_env explicit_mod_hdr export_ies } -check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv-check_main dflags tcg_env explicit_mod_hdr+check_main :: DynFlags -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs])+           -> TcM TcGblEnv+check_main dflags tcg_env explicit_mod_hdr export_ies  | mod /= main_mod  = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>    return tcg_env   | otherwise- = do   { mb_main <- lookupGlobalOccRn_maybe main_fn-                -- Check that 'main' is in scope-                -- It might be imported from another module!-        ; case mb_main of {-             Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)-                           ; complain_no_main-                           ; return tcg_env } ;-             Just main_name -> do+   -- Compare the list of main functions in scope with those+   --   specified in the export list.+ = do mains_all <- lookupInfoOccRn main_fn+                    -- get all 'main' functions in scope+                    -- They may also be imported from other modules!+      case exportedMains of -- check the main(s) specified in the export list+        [ ] -> do+          -- The module has no main functions in the export spec, so we must give+          -- some kind of error message. The tricky part is giving an error message+          -- that accurately characterizes what the problem is.+          -- See Note [Main module without a main function in the export spec]+          traceTc "checkMain no main module exported" ppr_mod_mainfn+          complain_no_main+          -- In order to reduce the number of potential error messages, we check+          -- to see if there are any main functions defined (but not exported)...+          case getSomeMain mains_all of+            Nothing -> return tcg_env+              -- ...if there are no such main functions, there is nothing we can do...+            Just some_main -> use_as_main some_main+                -- ...if there is such a main function, then communicate this to the+                -- typechecker. This can prevent a spurious "Ambiguous type variable"+                -- error message in certain cases, as described in+                -- Note [Main module without a main function in the export spec].+        _ -> do    -- The module has one or more main functions in the export spec+          let mains = filterInsMains exportedMains mains_all+          case mains of+            [] -> do  --+              traceTc "checkMain fail" ppr_mod_mainfn+              complain_no_main+              return tcg_env+            [main_name] -> use_as_main main_name+            _ -> do           -- multiple main functions are exported+              addAmbiguousNameErr main_fn          -- issue error msg+              return tcg_env+  where+    mod         = tcg_mod tcg_env+    main_mod    = mainModIs dflags+    main_mod_nm = moduleName main_mod+    main_fn     = getMainFun dflags+    occ_main_fn = occName main_fn+    interactive = ghcLink dflags == LinkInMemory+    exportedMains = selExportMains export_ies+    ppr_mod_mainfn = ppr main_mod <+> ppr main_fn +    -- There is a single exported 'main' function.+    use_as_main :: Name -> TcM TcGblEnv+    use_as_main main_name = do         { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)         ; let loc       = srcLocSpan (getSrcLoc main_name)         ; ioTyCon <- tcLookupTyCon ioTyConName@@ -1778,13 +1816,7 @@                                         `plusDU` usesOnly (unitFV main_name)                         -- Record the use of 'main', so that we don't                         -- complain about it being defined but not used-                 })-    }}}-  where-    mod         = tcg_mod tcg_env-    main_mod    = mainModIs dflags-    main_fn     = getMainFun dflags-    interactive = ghcLink dflags == LinkInMemory+        })}      complain_no_main = unless (interactive && not explicit_mod_hdr)                               (addErrTc noMainMsg)                  -- #12906@@ -1794,9 +1826,56 @@      mainCtxt  = text "When checking the type of the" <+> pp_main_fn     noMainMsg = text "The" <+> pp_main_fn-                <+> text "is not defined in module" <+> quotes (ppr main_mod)+                <+> text "is not" <+> text defOrExp <+> text "module"+                <+> quotes (ppr main_mod)+    defOrExp  = if null exportedMains then "exported by" else "defined in"+     pp_main_fn = ppMainFn main_fn +    -- Select the main functions from the export list.+    -- Only the module name is needed, the function name is fixed.+    selExportMains :: Maybe (Located [LIE GhcPs]) -> [ModuleName]    -- #16453+    selExportMains Nothing = [main_mod_nm]+        -- no main specified, but there is a header.+    selExportMains (Just exps) = fmap fst $+        filter (\(_,n) -> n == occ_main_fn ) texp+      where+        ies = fmap unLoc $ unLoc exps+        texp = mapMaybe transExportIE ies++    -- Filter all main functions in scope that match the export specs+    filterInsMains :: [ModuleName] -> [Name] -> [Name]               -- #16453+    filterInsMains export_mains inscope_mains =+      [mod | mod <- inscope_mains,+          (moduleName . nameModule) mod `elem` export_mains]++    -- Transform an export_ie to a (ModuleName, OccName) pair.+    -- 'IEVar' constructors contain exported values (functions), eg '(Main.main)'+    -- 'IEModuleContents' constructors contain fully exported modules, eg '(Main)'+    -- All other 'IE...' constructors are not used and transformed to Nothing.+    transExportIE :: IE GhcPs -> Maybe (ModuleName, OccName)         -- #16453+    transExportIE (IEVar _  var) = isQual_maybe $+         upqual $ ieWrappedName $ unLoc var+       where+         -- A module name is always needed, so qualify 'UnQual' rdr names.+         upqual (Unqual occ) = Qual main_mod_nm occ+         upqual rdr = rdr+    transExportIE (IEModuleContents _ mod) = Just (unLoc mod, occ_main_fn)+    transExportIE _ = Nothing++    -- Get a main function that is in scope.+    -- See Note [Main module without a main function in the export spec]+    getSomeMain :: [Name] -> Maybe Name                            -- #16453+    getSomeMain all_mains = case all_mains of+        []  -> Nothing                -- No main function in scope+        [m] -> Just m                 -- Just one main function in scope+        _   -> case mbMainOfMain of+          Nothing -> listToMaybe all_mains -- Take the first main function in scope or Nothing+          _       -> mbMainOfMain          -- Take the Main module's main function or Nothing+      where+        mbMainOfMain = find (\n -> (moduleName . nameModule) n == main_mod_nm )+                          all_mains         -- the main function of the Main module+ -- | Get the unqualified name of the function to use as the \"main\" for the main module. -- Either returns the default name or the one configured on the command line with -main-is getMainFun :: DynFlags -> RdrName@@ -1804,19 +1883,6 @@                       Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))                       Nothing -> main_RDR_Unqual --- If we are in module Main, check that 'main' is exported.-checkMainExported :: TcGblEnv -> TcM ()-checkMainExported tcg_env-  = case tcg_main tcg_env of-      Nothing -> return () -- not the main module-      Just main_name ->-         do { dflags <- getDynFlags-            ; let main_mod = mainModIs dflags-            ; checkTc (main_name `elem`-                           concatMap availNames (tcg_exports tcg_env)) $-                text "The" <+> ppMainFn (nameRdrName main_name) <+>-                text "is not exported by module" <+> quotes (ppr main_mod) }- ppMainFn :: RdrName -> SDoc ppMainFn main_fn   | rdrNameOcc main_fn == mainOcc@@ -1837,10 +1903,57 @@ ":Main".)  This is unusual: it's a LocalId whose Name has a Module from another-module. Tiresomely, we must filter it out again in GHC.Iface.Utils, less we+module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we get two defns for 'main' in the interface file!  +Note [Main module without a main function in the export spec]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Giving accurate error messages for a Main module that does not export a main+function is surprisingly tricky. To see why, consider a module in a file+`Foo.hs` that has no `main` function in the explicit export specs of the module+header:++    module Main () where+    foo = return ()++This does not export a main function and therefore should be rejected, per+chapter 5 of the Haskell Report 2010:++   A Haskell program is a collection of modules, one of which, by convention,+   must be called Main and must export the value main. The value of the+   program is the value of the identifier main in module Main, which must be+   a computation of type IO τ for some type τ.++In fact, when you compile the program above using `ghc Foo.hs`, you will+actually get *two* errors:++ - The IO action ‘main’ is not defined in module ‘Main’++ - Ambiguous type variable ‘m0’ arising from a use of ‘return’+   prevents the constraint ‘(Monad m0)’ from being solved.++The first error is self-explanatory, while the second error message occurs+due to the monomorphism restriction.++Now consider what would happen if the program above were compiled with+`ghc -main-is foo Foo`. The has the effect of `foo` being designated as the+main function. The program will still be rejected since it does not export+`foo` (and therefore does not export its main function), but there is one+important difference: `foo` will be checked against the type `IO τ`. As a+result, we would *not* expect the monomorphism restriction error message+to occur, since the typechecker should have no trouble figuring out the type+of `foo`. In other words, we should only throw the former error message,+not the latter.++The implementation uses the function `getSomeMain` to find a potential main+function that is defined but not exported. If one is found, it is passed to+`use_as_main` to inform the typechecker that the main function should be of+type `IO τ`. See also the `T414` and `T17171a` test cases for similar examples+of programs whose error messages are influenced by the situation described in+this Note.++ ********************************************************* *                                                       *                 GHCi stuff@@ -2573,7 +2686,7 @@            -> IO (Messages, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls   = runTcInteractive hsc_env $-    tcRnSrcDecls False local_decls+    tcRnSrcDecls False local_decls Nothing  externaliseAndTidyId :: Module -> Id -> TcM Id externaliseAndTidyId this_mod id
compiler/typecheck/TcRnDriver.hs-boot view
@@ -1,10 +1,10 @@ module TcRnDriver where  import GhcPrelude-import Type (TyThing)+import GHC.Core.Type(TyThing) import TcRnTypes (TcM) import Outputable (SDoc)-import Name (Name)+import GHC.Types.Name (Name)  checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)                -> TyThing -> TyThing -> TcM ()
compiler/typecheck/TcRnExports.hs view
@@ -11,7 +11,7 @@  import GHC.Hs import PrelNames-import RdrName+import GHC.Types.Name.Reader import TcRnMonad import TcEnv import TcType@@ -19,22 +19,22 @@ import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) import ErrUtils-import Id-import IdInfo-import Module-import Name-import NameEnv-import NameSet-import Avail-import TyCon-import SrcLoc+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Avail+import GHC.Core.TyCon+import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Types import Outputable-import ConLike-import DataCon-import PatSyn+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.PatSyn import Maybes-import UniqSet+import GHC.Types.Unique.Set import Util (capitalise) import FastString (fsLit) @@ -681,7 +681,7 @@   where     -- Each Name specified by 'ie', paired with the OccName used to     -- refer to it in the GlobalRdrEnv-    -- (see Note [Representing fields in AvailInfo] in Avail).+    -- (see Note [Representing fields in AvailInfo] in GHC.Types.Avail).     --     -- We check for export clashes using the selector Name, but need     -- the field label OccName for presenting error messages.
compiler/typecheck/TcRnMonad.hs view
@@ -153,34 +153,34 @@  import GHC.Hs hiding (LIE) import GHC.Driver.Types-import Module-import RdrName-import Name-import Type+import GHC.Types.Module+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Core.Type  import TcType-import InstEnv-import FamInstEnv+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv import PrelNames -import Id-import VarSet-import VarEnv+import GHC.Types.Id+import GHC.Types.Var.Set+import GHC.Types.Var.Env import ErrUtils-import SrcLoc-import NameEnv-import NameSet+import GHC.Types.SrcLoc+import GHC.Types.Name.Env+import GHC.Types.Name.Set import Bag import Outputable-import UniqSupply+import GHC.Types.Unique.Supply import GHC.Driver.Session import FastString import Panic import Util-import Annotations-import BasicTypes( TopLevelFlag, TypeOrKind(..) )+import GHC.Types.Annotations+import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) import Maybes-import CostCentreState+import GHC.Types.CostCentre.State  import qualified GHC.LanguageExtensions as LangExt
compiler/typecheck/TcRules.hs view
@@ -18,7 +18,7 @@ import TcRnMonad import TcSimplify import Constraint-import Predicate+import GHC.Core.Predicate import TcOrigin import TcMType import TcType@@ -27,13 +27,13 @@ import TcEnv import TcUnify( buildImplicationFor ) import TcEvidence( mkTcCoVarCo )-import Type-import TyCon( isTypeFamilyTyCon )-import Id-import Var( EvVar )-import VarSet-import BasicTypes       ( RuleName )-import SrcLoc+import GHC.Core.Type+import GHC.Core.TyCon( isTypeFamilyTyCon )+import GHC.Types.Id+import GHC.Types.Var( EvVar )+import GHC.Types.Var.Set+import GHC.Types.Basic ( RuleName )+import GHC.Types.SrcLoc import Outputable import FastString import Bag@@ -60,6 +60,43 @@ Bringing type variables into scope naturally bumps the TcLevel. Thus, we type check the term-level binders in a bumped level, and we must accordingly bump the level whenever these binders are in scope.++Note [Re-quantify type variables in rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example from #17710:++  foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b+  foo x = Proxy+  {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-}++Written out in more detail, the "foo" rewrite rule looks like this:++  forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0++Where b0 is a unification variable. Where should b0 be quantified? We have to+quantify it after k, since (b0 :: k). But generalization usually puts inferred+type variables (such as b0) at the /front/ of the telescope! This creates a+conflict.++One option is to simply throw an error, per the principles of+Note [Naughty quantification candidates] in TcMType. This is what would happen+if we were generalising over a normal type signature. On the other hand, the+types in a rewrite rule aren't quite "normal", since the notions of specified+and inferred type variables aren't applicable.++A more permissive design (and the design that GHC uses) is to simply requantify+all of the type variables. That is, we would end up with this:++  forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b++It's a bit strange putting the generalized variable `b` after the user-written+variables `k` and `a`. But again, the notion of specificity is not relevant to+rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not+only makes "foo" typecheck, but it also makes the implementation simpler.++See also Note [Generalising in tcTyFamInstEqnGuts] in TcTyClsDecls, which+explains a very similar design when generalising over a type family instance+equation. -}  tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId]@@ -89,8 +126,8 @@        ; (tc_lvl, stuff) <- pushTcLevelM $                             generateRuleConstraints ty_bndrs tm_bndrs lhs rhs -       ; let (tv_bndrs, id_bndrs, lhs', lhs_wanted-                                , rhs', rhs_wanted, rule_ty) = stuff+       ; let (id_bndrs, lhs', lhs_wanted+                      , rhs', rhs_wanted, rule_ty) = stuff         ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname                                   , ppr lhs_wanted@@ -113,14 +150,13 @@        -- during zonking (see TcHsSyn.zonkRule)         ; let tpl_ids = lhs_evs ++ id_bndrs-       ; forall_tkvs <- candidateQTyVarsOfTypes $-                        map (mkSpecForAllTys tv_bndrs) $  -- don't quantify over lexical tyvars-                        rule_ty : map idType tpl_ids++       -- See Note [Re-quantify type variables in rules]+       ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)        ; qtkvs <- quantifyTyVars forall_tkvs        ; traceTc "tcRule" (vcat [ pprFullRuleName rname                                 , ppr forall_tkvs                                 , ppr qtkvs-                                , ppr tv_bndrs                                 , ppr rule_ty                                 , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]                   ])@@ -130,11 +166,10 @@        -- For the LHS constraints we must solve the remaining constraints        -- (a) so that we report insoluble ones        -- (b) so that we bind any soluble ones-       ; let all_qtkvs = qtkvs ++ tv_bndrs-             skol_info = RuleSkol name-       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs+       ; let skol_info = RuleSkol name+       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs                                          lhs_evs residual_lhs_wanted-       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs+       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs                                          lhs_evs rhs_wanted         ; emitImplications (lhs_implic `unionBags` rhs_implic)@@ -143,15 +178,14 @@                          , rd_act = act                          , rd_tyvs = ty_bndrs -- preserved for ppr-ing                          , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc)-                                         (all_qtkvs ++ tpl_ids)+                                         (qtkvs ++ tpl_ids)                          , rd_lhs  = mkHsDictLet lhs_binds lhs'                          , rd_rhs  = mkHsDictLet rhs_binds rhs' } } tcRule (XRuleDecl nec) = noExtCon nec  generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]                         -> LHsExpr GhcRn -> LHsExpr GhcRn-                        -> TcM ( [TyVar]-                               , [TcId]+                        -> TcM ( [TcId]                                , LHsExpr GhcTc, WantedConstraints                                , LHsExpr GhcTc, WantedConstraints                                , TcType )@@ -170,7 +204,7 @@        ; (rhs',            rhs_wanted) <- captureConstraints $                                           tcMonoExpr rhs (mkCheckExpType rule_ty)        ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted-       ; return (tv_bndrs, id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }+       ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }  -- See Note [TcLevel in type checking rules] tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
compiler/typecheck/TcSMonad.hs view
@@ -9,17 +9,17 @@     WorkList(..), isEmptyWorkList, emptyWorkList,     extendWorkListNonEq, extendWorkListCt,     extendWorkListCts, extendWorkListEq, extendWorkListFunEq,-    appendWorkList, extendWorkListImplic,+    appendWorkList,     selectNextWorkItem,     workListSize, workListWantedCount,-    getWorkList, updWorkListTcS,+    getWorkList, updWorkListTcS, pushLevelNoWorkList,      -- The TcS monad     TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,     failTcS, warnTcS, addErrTcS,     runTcSEqualities,     nestTcS, nestImplicTcS, setEvBindsTcS,-    checkConstraintsTcS, checkTvConstraintsTcS,+    emitImplicationTcS, emitTvImplicationTcS,      runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,     matchGlobalInst, TcM.ClsInstResult(..),@@ -132,9 +132,9 @@ import GHC.Driver.Types  import qualified Inst as TcM-import InstEnv+import GHC.Core.InstEnv import FamInst-import FamInstEnv+import GHC.Core.FamInstEnv  import qualified TcRnMonad as TcM import qualified TcMType as TcM@@ -144,47 +144,46 @@ import ClsInst( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) import TcType import GHC.Driver.Session-import Type-import Coercion-import Unify+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.Unify  import ErrUtils import TcEvidence-import Class-import TyCon+import GHC.Core.Class+import GHC.Core.TyCon import TcErrors   ( solverDepthErrorTcS ) -import Name-import Module ( HasModule, getModule )-import RdrName ( GlobalRdrEnv, GlobalRdrElt )+import GHC.Types.Name+import GHC.Types.Module ( HasModule, getModule )+import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) import qualified GHC.Rename.Env as TcM-import Var-import VarEnv-import VarSet+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set import Outputable import Bag-import UniqSupply+import GHC.Types.Unique.Supply import Util import TcRnTypes import TcOrigin import Constraint-import Predicate+import GHC.Core.Predicate -import Unique-import UniqFM-import UniqDFM+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM import Maybes  import GHC.Core.Map import Control.Monad-import qualified Control.Monad.Fail as MonadFail import MonadUtils import Data.IORef import Data.List ( partition, mapAccumL )  #if defined(DEBUG) import Digraph-import UniqSet+import GHC.Types.Unique.Set #endif  {-@@ -300,8 +299,8 @@   = count isWantedCt eqs + count is_wanted rest   where     is_wanted ct-     | CIrredCan { cc_ev = ev, cc_insol = insol } <- ct-     = not insol && isWanted ev+     | CIrredCan { cc_status = InsolubleCIS } <- ct+     = False      | otherwise      = isWantedCt ct @@ -319,8 +318,8 @@ extendWorkListDeriveds evs wl   = extendWorkListCts (map mkNonCanonical evs) wl -extendWorkListImplic :: Bag Implication -> WorkList -> WorkList-extendWorkListImplic implics wl = wl { wl_implics = implics `unionBags` wl_implics wl }+extendWorkListImplic :: Implication -> WorkList -> WorkList+extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }  extendWorkListCt :: Ct -> WorkList -> WorkList -- Agnostic@@ -767,6 +766,7 @@     eg a wanted cannot rewrite a given)    * CTyEqCan equalities: see Note [inert_eqs: the inert equalities]+    Also see documentation in Constraint.Ct for a list of invariants  Note [EqualCtList invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -919,8 +919,8 @@   with S(fw,_).  * T3 is guaranteed by a simple occurs-check on the work item.-  This is done during canonicalisation, in canEqTyVar;-  (invariant: a CTyEqCan never has an occurs check).+  This is done during canonicalisation, in canEqTyVar; invariant+  (TyEq:OC) of CTyEqCan.  * (K1-3) are the "kick-out" criteria.  (As stated, they are really the   "keep" criteria.) If the current inert S contains a triple that does@@ -1639,12 +1639,14 @@         , inert_count = bumpUnsolvedCount ev (inert_count ics) }  add_item ics@(IC { inert_irreds = irreds, inert_count = count })-         item@(CIrredCan { cc_ev = ev, cc_insol = insoluble })+         item@(CIrredCan { cc_ev = ev, cc_status = status })   = ics { inert_irreds = irreds `Bag.snocBag` item-        , inert_count  = if insoluble-                         then count  -- inert_count does not include insolubles-                         else bumpUnsolvedCount ev count }+        , inert_count  = case status of+                           InsolubleCIS -> count+                           _            -> bumpUnsolvedCount ev count }+                              -- inert_count does not include insolubles + add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })   = ics { inert_dicts = addDict (inert_dicts ics) cls tys item         , inert_count = bumpUnsolvedCount ev (inert_count ics) }@@ -1821,6 +1823,42 @@        ; setInertCans ics2        ; return n_kicked } +-- See Wrinkle (2b) in Note [Equalities with incompatible kinds] in TcCanonical+kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()+kickOutAfterFillingCoercionHole hole+  = do { ics <- getInertCans+       ; let (kicked_out, ics') = kick_out ics+             n_kicked           = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)+            ; csTraceTcS $+              hang (text "Kick out, hole =" <+> ppr hole)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; setInertCans ics' }+  where+    kick_out :: InertCans -> (WorkList, InertCans)+    kick_out ics@(IC { inert_irreds = irreds })+      = let (to_kick, to_keep) = partitionBag kick_ct irreds++            kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList+            ics'       = ics { inert_irreds = to_keep }+        in+        (kicked_out, ics')++    kick_ct :: Ct -> Bool+    -- This is not particularly efficient. Ways to do better:+    --  1) Have a custom function that looks for a coercion hole and returns a Bool+    --  2) Keep co-hole-blocked constraints in a separate part of the inert set,+    --     keyed by their co-hole. (Is it possible for more than one co-hole to be+    --     in a constraint? I doubt it.)+    kick_ct (CIrredCan { cc_ev = ev, cc_status = BlockedCIS })+      = coHoleCoVar hole `elemVarSet` tyCoVarsOfType (ctEvPred ev)+    kick_ct _other = False+ {- Note [kickOutRewritable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also Note [inert_eqs: the inert equalities].@@ -2660,12 +2698,9 @@   (<*>) = ap  instance Monad TcS where-#if !MIN_VERSION_base(4,13,0)-  fail = MonadFail.fail-#endif   m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs) -instance MonadFail.MonadFail TcS where+instance MonadFail TcS where   fail err  = TcS (\_ -> fail err)  instance MonadUnique TcS where@@ -2905,85 +2940,48 @@         ; return res } -checkTvConstraintsTcS :: SkolemInfo-                      -> [TcTyVar]        -- Skolems-                      -> TcS (result, Cts)-                      -> TcS result--- Just like TcUnify.checkTvConstraints, but---   - In the TcS monnad---   - The thing-inside should not put things in the work-list---     Instead, it returns the Wanted constraints it needs---   - No 'givens', and no TcEvBinds; this is type-level constraints only-checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside)-  = TcS $ \ tcs_env ->-    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $-                         ppr skol_info $$ ppr skol_tvs-                         -- This panic checks that the thing-inside-                         -- does not emit any work-list constraints-             new_tcs_env = tcs_env { tcs_worklist = wl_panic }+emitImplicationTcS :: TcLevel -> SkolemInfo+                   -> [TcTyVar]        -- Skolems+                   -> [EvVar]          -- Givens+                   -> Cts              -- Wanteds+                   -> TcS TcEvBinds+-- Add an implication to the TcS monad work-list+emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds+  = do { let wc = emptyWC { wc_simple = wanteds }+       ; imp <- wrapTcS $+                do { ev_binds_var <- TcM.newTcEvBinds+                   ; imp <- TcM.newImplication+                   ; return (imp { ic_tclvl  = new_tclvl+                                 , ic_skols  = skol_tvs+                                 , ic_given  = givens+                                 , ic_wanted = wc+                                 , ic_binds  = ev_binds_var+                                 , ic_info   = skol_info }) } -       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $-                                        thing_inside new_tcs_env+       ; emitImplication imp+       ; return (TcEvBinds (ic_binds imp)) } -       ; unless (null wanteds) $-         do { ev_binds_var <- TcM.newNoTcEvBinds-            ; imp <- TcM.newImplication-            ; let wc = emptyWC { wc_simple = wanteds }-                  imp' = imp { ic_tclvl  = new_tclvl-                             , ic_skols  = skol_tvs-                             , ic_wanted = wc-                             , ic_binds  = ev_binds_var-                             , ic_info   = skol_info }+emitTvImplicationTcS :: TcLevel -> SkolemInfo+                     -> [TcTyVar]        -- Skolems+                     -> Cts              -- Wanteds+                     -> TcS ()+-- Just like emitImplicationTcS but no givens and no bindings+emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds+  = do { let wc = emptyWC { wc_simple = wanteds }+       ; imp <- wrapTcS $+                do { ev_binds_var <- TcM.newNoTcEvBinds+                   ; imp <- TcM.newImplication+                   ; return (imp { ic_tclvl  = new_tclvl+                                 , ic_skols  = skol_tvs+                                 , ic_wanted = wc+                                 , ic_binds  = ev_binds_var+                                 , ic_info   = skol_info }) } -           -- Add the implication to the work-list-           ; TcM.updTcRef (tcs_worklist tcs_env)-                          (extendWorkListImplic (unitBag imp')) }+       ; emitImplication imp } -      ; return res } -checkConstraintsTcS :: SkolemInfo-                    -> [TcTyVar]        -- Skolems-                    -> [EvVar]          -- Givens-                    -> TcS (result, Cts)-                    -> TcS (result, TcEvBinds)--- Just like checkConstraintsTcS, but---   - In the TcS monnad---   - The thing-inside should not put things in the work-list---     Instead, it returns the Wanted constraints it needs---   - I did not bother to put in the fast-path for---     empty-skols/empty-givens, or for empty-wanteds, because---     this function is used only for "quantified constraints" in---     with both tests are pretty much guaranteed to fail-checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside)-  = TcS $ \ tcs_env ->-    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $-                         ppr skol_info $$ ppr skol_tvs-                         -- This panic checks that the thing-inside-                         -- does not emit any work-list constraints-             new_tcs_env = tcs_env { tcs_worklist = wl_panic }--       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $-                                        thing_inside new_tcs_env--       ; ev_binds_var <- TcM.newTcEvBinds-       ; imp <- TcM.newImplication-       ; let wc = emptyWC { wc_simple = wanteds }-             imp' = imp { ic_tclvl  = new_tclvl-                        , ic_skols  = skol_tvs-                        , ic_given  = given-                        , ic_wanted = wc-                        , ic_binds  = ev_binds_var-                        , ic_info   = skol_info }--           -- Add the implication to the work-list-       ; TcM.updTcRef (tcs_worklist tcs_env)-                      (extendWorkListImplic (unitBag imp'))--       ; return (res, TcEvBinds ev_binds_var) }--{--Note [Propagate the solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Propagate the solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's really quite important that nestTcS does not discard the solved dictionaries from the thing_inside. Consider@@ -3017,6 +3015,23 @@        ; wl_curr <- readTcRef wl_var        ; return (wl_implics wl_curr) } +pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)+-- Push the level and run thing_inside+-- However, thing_inside should not generate any work items+#if defined(DEBUG)+pushLevelNoWorkList err_doc (TcS thing_inside)+  = TcS (\env -> TcM.pushTcLevelM $+                 thing_inside (env { tcs_worklist = wl_panic })+        )+  where+    wl_panic  = pprPanic "TcSMonad.buildImplication" err_doc+                         -- This panic checks that the thing-inside+                         -- does not emit any work-list constraints+#else+pushLevelNoWorkList _ (TcS thing_inside)+  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check+#endif+ updWorkListTcS :: (WorkList -> WorkList) -> TcS () updWorkListTcS f   = do { wl_var <- getTcSWorkListRef@@ -3035,6 +3050,10 @@   = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))        ; updWorkListTcS (extendWorkListCts cts) } +emitImplication :: Implication -> TcS ()+emitImplication implic+  = updWorkListTcS (extendWorkListImplic implic)+ newTcRef :: a -> TcS (TcRef a) newTcRef x = wrapTcS (TcM.newTcRef x) @@ -3216,7 +3235,10 @@       | otherwise  -- Generate a [WD] for both Wanted and Derived                    -- See Note [No Derived CFunEqCans]       = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty)-           ; (ev, hole_co) <- newWantedEq loc Nominal fam_ty (mkTyVarTy fmv)+              -- See (2a) in TcCanonical+              -- Note [Equalities with incompatible kinds]+           ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc Nominal+                                             fam_ty (mkTyVarTy fmv)            ; return (ev, hole_co, fmv) }  ----------------------------@@ -3402,7 +3424,7 @@ setWantedEq :: TcEvDest -> Coercion -> TcS () setWantedEq (HoleDest hole) co   = do { useVars (coVarsOfCo co)-       ; wrapTcS $ TcM.fillCoercionHole hole co }+       ; fillCoercionHole hole co } setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)  -- | Good for both equalities and non-equalities@@ -3410,12 +3432,12 @@ setWantedEvTerm (HoleDest hole) tm   | Just co <- evTermCoercion_maybe tm   = do { useVars (coVarsOfCo co)-       ; wrapTcS $ TcM.fillCoercionHole hole co }+       ; fillCoercionHole hole co }   | otherwise   = -- See Note [Yukky eq_sel for a HoleDest]     do { let co_var = coHoleCoVar hole        ; setEvBind (mkWantedEvBind co_var tm)-       ; wrapTcS $ TcM.fillCoercionHole hole (mkTcCoVarCo co_var) }+       ; fillCoercionHole hole (mkTcCoVarCo co_var) }  setWantedEvTerm (EvVarDest ev_id) tm   = setEvBind (mkWantedEvBind ev_id tm)@@ -3439,6 +3461,11 @@ Yuk! -} +fillCoercionHole :: CoercionHole -> Coercion -> TcS ()+fillCoercionHole hole co+  = do { wrapTcS $ TcM.fillCoercionHole hole co+       ; kickOutAfterFillingCoercionHole hole }+ setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () setEvBindIfWanted ev tm   = case ev of@@ -3484,13 +3511,13 @@ -- | Make a new equality CtEvidence newWantedEq :: CtLoc -> Role -> TcType -> TcType             -> TcS (CtEvidence, Coercion)-newWantedEq = newWantedEq_SI WDeriv+newWantedEq = newWantedEq_SI YesBlockSubst WDeriv -newWantedEq_SI :: ShadowInfo -> CtLoc -> Role+newWantedEq_SI :: BlockSubstFlag -> ShadowInfo -> CtLoc -> Role                -> TcType -> TcType                -> TcS (CtEvidence, Coercion)-newWantedEq_SI si loc role ty1 ty2-  = do { hole <- wrapTcS $ TcM.newCoercionHole pty+newWantedEq_SI blocker si loc role ty1 ty2+  = do { hole <- wrapTcS $ TcM.newCoercionHole blocker pty        ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)        ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole                            , ctev_nosh = si@@ -3536,7 +3563,7 @@ newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew newWanted_SI si loc pty   | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2+  = Fresh . fst <$> newWantedEq_SI YesBlockSubst si loc role ty1 ty2   | otherwise   = newWantedEvVar_SI si loc pty
compiler/typecheck/TcSigs.hs view
@@ -39,18 +39,18 @@ import Inst( topInstantiate ) import TcEnv( tcLookupId ) import TcEvidence( HsWrapper, (<.>) )-import Type( mkTyVarBinders )+import GHC.Core.Type ( mkTyVarBinders )  import GHC.Driver.Session-import Var      ( TyVar, tyVarKind )-import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )+import GHC.Types.Var ( TyVar, tyVarKind )+import GHC.Types.Id  ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import PrelNames( mkUnboundName )-import BasicTypes-import Module( getModule )-import Name-import NameEnv+import GHC.Types.Basic+import GHC.Types.Module( getModule )+import GHC.Types.Name+import GHC.Types.Name.Env import Outputable-import SrcLoc+import GHC.Types.SrcLoc import Util( singleton ) import Maybes( orElse ) import Data.Maybe( mapMaybe )@@ -291,7 +291,7 @@       HsTyLit{} -> True       HsTyVar{} -> True       HsStarTy{} -> True-      XHsType{} -> True      -- Core type, which does not have any wildcard+      XHsType (NHsCoreTy{}) -> True      -- Core type, which does not have any wildcard      gos = all go
compiler/typecheck/TcSimplify.hs view
@@ -29,12 +29,12 @@ import GhcPrelude  import Bag-import Class         ( Class, classKey, classTyCon )+import GHC.Core.Class ( Class, classKey, classTyCon ) import GHC.Driver.Session-import Id            ( idType, mkLocalId )+import GHC.Types.Id   ( idType, mkLocalId ) import Inst import ListSetOps-import Name+import GHC.Types.Name import Outputable import PrelInfo import PrelNames@@ -46,18 +46,18 @@ import TcRnMonad as TcM import TcSMonad  as TcS import Constraint-import Predicate+import GHC.Core.Predicate import TcOrigin import TcType-import Type-import TysWiredIn    ( liftedRepTy )-import Unify         ( tcMatchTyKi )+import GHC.Core.Type+import TysWiredIn     ( liftedRepTy )+import GHC.Core.Unify ( tcMatchTyKi ) import Util-import Var-import VarSet-import UniqSet-import BasicTypes    ( IntWithInf, intGtLimit )-import ErrUtils      ( emptyMessages )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Unique.Set+import GHC.Types.Basic    ( IntWithInf, intGtLimit )+import ErrUtils           ( emptyMessages ) import qualified GHC.LanguageExtensions as LangExt  import Control.Monad@@ -1708,7 +1708,7 @@   where     -- TcLevels must be strictly increasing (see (ImplicInv) in     -- Note [TcLevel and untouchable type variables] in TcType),-    -- and in fact I thinkthey should always increase one level at a time.+    -- and in fact I think they should always increase one level at a time.      -- Though sensible, this check causes lots of testsuite failures. It is     -- remaining commented out for now.@@ -2432,7 +2432,6 @@     is_float_eq_candidate ct       | pred <- ctPred ct       , EqPred NomEq ty1 ty2 <- classifyPredType pred-      , tcTypeKind ty1 `tcEqType` tcTypeKind ty2       = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of           (Just tv1, _) -> float_tv_eq_candidate tv1 ty2           (_, Just tv2) -> float_tv_eq_candidate tv2 ty1@@ -2478,19 +2477,6 @@    * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar.  In that      case, floating out won't help either, and it may affect grouping      of error messages.--* Homogeneous (both sides have the same kind). Why only homogeneous?-  Because heterogeneous equalities have derived kind equalities.-  See Note [Equalities with incompatible kinds] in TcCanonical.-  If we float out a hetero equality, then it will spit out the same-  derived kind equality again, which might create duplicate error-  messages.--  Instead, we do float out the kind equality (if it's worth floating-  out, as above). If/when we solve it, we'll be able to rewrite the-  original hetero equality to be homogeneous, and then perhaps make-  progress / float it out. The duplicate error message was spotted in-  typecheck/should_fail/T7368.  * Nominal.  No point in floating (alpha ~R# ty), because we do not   unify representational equalities even if alpha is touchable.
compiler/typecheck/TcSplice.hs view
@@ -38,20 +38,20 @@ import GhcPrelude  import GHC.Hs-import Annotations+import GHC.Types.Annotations import GHC.Driver.Finder-import Name+import GHC.Types.Name import TcRnMonad import TcType  import Outputable import TcExpr-import SrcLoc+import GHC.Types.SrcLoc import THNames import TcUnify import TcEnv import TcOrigin-import Coercion( etaExpandCoAxBranch )+import GHC.Core.Coercion( etaExpandCoAxBranch ) import FileCleanup ( newTempName, TempFileLifetime(..) )  import Control.Monad@@ -64,7 +64,7 @@         -- These imports are the reason that TcSplice         -- is very high up the module hierarchy import GHC.Rename.Splice( traceSplice, SpliceInfo(..))-import RdrName+import GHC.Types.Name.Reader import GHC.Driver.Types import GHC.ThToHs import GHC.Rename.Expr@@ -74,48 +74,48 @@ import GHC.Rename.Types import TcHsSyn import TcSimplify-import Type-import NameSet+import GHC.Core.Type as Type+import GHC.Types.Name.Set import TcMType import TcHsType import GHC.IfaceToCore-import TyCoRep+import GHC.Core.TyCo.Rep as TyCoRep import FamInst-import FamInstEnv-import InstEnv+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv as InstEnv import Inst-import NameEnv+import GHC.Types.Name.Env import PrelNames import TysWiredIn-import OccName+import GHC.Types.Name.Occurrence as OccName import GHC.Driver.Hooks-import Var-import Module+import GHC.Types.Var+import GHC.Types.Module import GHC.Iface.Load-import Class-import TyCon-import CoAxiom-import PatSyn-import ConLike-import DataCon+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.PatSyn+import GHC.Core.ConLike+import GHC.Core.DataCon as DataCon import TcEvidence-import Id-import IdInfo+import GHC.Types.Id+import GHC.Types.Id.Info import GHC.HsToCore.Expr import GHC.HsToCore.Monad import GHC.Serialized import ErrUtils import Util-import Unique-import VarSet+import GHC.Types.Unique+import GHC.Types.Var.Set import Data.List        ( find ) import Data.Maybe import FastString-import BasicTypes hiding( SuccessFlag(..) )+import GHC.Types.Basic as BasicTypes hiding( SuccessFlag(..) ) import Maybes( MaybeErr(..) ) import GHC.Driver.Session import Panic-import Lexeme+import GHC.Utils.Lexeme import qualified EnumSet import GHC.Driver.Plugins import Bag@@ -776,9 +776,9 @@ convertAnnotationWrapper fhv = do   interp <- tcGetInterp   case interp of-    ExternalInterp _ -> Right <$> runTH THAnnWrapper fhv+    ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv #if defined(HAVE_INTERNAL_INTERPRETER)-    InternalInterp   -> do+    InternalInterp    -> do       annotation_wrapper <- liftIO $ wormhole InternalInterp fhv       return $ Right $         case unsafeCoerce annotation_wrapper of@@ -821,7 +821,7 @@       runQuasi $ sequence_ qs #endif -    ExternalInterp iserv -> withIServ_ iserv $ \i -> do+    ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> do       tcg <- getGblEnv       th_state <- readTcRef (tcg_th_remote_state tcg)       case th_state of@@ -1215,11 +1215,11 @@ finishTH = do   hsc_env <- getTopEnv   case hsc_interp hsc_env of-    Nothing                 -> pure ()+    Nothing                  -> pure () #if defined(HAVE_INTERNAL_INTERPRETER)-    Just InternalInterp     -> pure ()+    Just InternalInterp      -> pure () #endif-    Just (ExternalInterp _) -> do+    Just (ExternalInterp {}) -> do       tcg <- getGblEnv       writeTcRef (tcg_th_remote_state tcg) Nothing @@ -1248,11 +1248,11 @@       return r #endif -    ExternalInterp iserv ->+    ExternalInterp conf iserv ->       -- Run it on the server.  For an overview of how TH works with       -- Remote GHCi, see Note [Remote Template Haskell] in       -- libraries/ghci/GHCi/TH.hs.-      withIServ_ iserv $ \i -> do+      withIServ_ conf iserv $ \i -> do         rstate <- getTHState i         loc <- TH.qLocation         liftIO $@@ -1977,7 +1977,7 @@  We can fix this ambiguity by reifying the instances' explicit return kinds. We should only do this if necessary (see-Note [When does a tycon application need an explicit kind signature?] in Type),+Note [When does a tycon application need an explicit kind signature?] in GHC.Core.Type), but more importantly, we *only* do this if either of the following are true:  1. The data family instance has no constructors.@@ -2046,7 +2046,7 @@       DataFamilyInst rep_tc ->         do { let -- eta-expand lhs types, because sometimes data/newtype                  -- instances are eta-reduced; See #9692-                 -- See Note [Eta reduction for data families] in FamInstEnv+                 -- See Note [Eta reduction for data families] in GHC.Core.FamInstEnv                  (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch                  fam'     = reifyName fam                  dataCons = tyConDataCons rep_tc@@ -2175,7 +2175,7 @@     r_tc | isUnboxedSumTyCon tc           = TH.UnboxedSumT (arity `div` 2)          | isUnboxedTupleTyCon tc         = TH.UnboxedTupleT (arity `div` 2)          | isPromotedTupleTyCon tc        = TH.PromotedTupleT (arity `div` 2)-             -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+             -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon          | isTupleTyCon tc                = if isPromotedDataCon tc                                             then TH.PromotedTupleT arity                                             else TH.TupleT arity@@ -2192,7 +2192,7 @@          | otherwise                      = TH.ConT (reifyName tc)      -- See Note [When does a tycon application need an explicit kind-    -- signature?] in TyCoRep+    -- signature?] in GHC.Core.TyCo.Rep     maybe_sig_t th_type       | tyConAppNeedsKindSig           False -- We don't reify types using visible kind applications, so
compiler/typecheck/TcSplice.hs-boot view
@@ -4,11 +4,11 @@ module TcSplice where  import GhcPrelude-import Name+import GHC.Types.Name import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) import TcRnTypes( TcM , SpliceType ) import TcType   ( ExpRhoType )-import Annotations ( Annotation, CoreAnnTarget )+import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) import GHC.Hs.Extension ( GhcTcId, GhcRn, GhcPs, GhcTc )  import GHC.Hs     ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,
compiler/typecheck/TcTyClsDecls.hs view
@@ -39,7 +39,7 @@ import TcClassDcl import {-# SOURCE #-} TcInstDcls( tcInstDecls1 ) import TcDeriv (DerivInfo(..))-import TcUnify ( unifyKind )+import TcUnify ( checkTvConstraints ) import TcHsType import ClsInst( AssocInstInfo(..) ) import TcMType@@ -47,34 +47,34 @@ import TcType import GHC.Rename.Env( lookupConstructorFields ) import FamInst-import FamInstEnv-import Coercion+import GHC.Core.FamInstEnv+import GHC.Core.Coercion import TcOrigin-import Type-import TyCoRep   -- for checkValidRoles-import TyCoPpr( pprTyVars, pprWithExplicitKindsWhen )-import Class-import CoAxiom-import TyCon-import DataCon-import Id-import Var-import VarEnv-import VarSet-import Module-import Name-import NameSet-import NameEnv+import GHC.Core.Type+import GHC.Core.TyCo.Rep   -- for checkValidRoles+import GHC.Core.TyCo.Ppr( pprTyVars, pprWithExplicitKindsWhen )+import GHC.Core.Class+import GHC.Core.Coercion.Axiom+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Module+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env import Outputable import Maybes-import Unify+import GHC.Core.Unify import Util-import SrcLoc+import GHC.Types.SrcLoc import ListSetOps import GHC.Driver.Session-import Unique-import ConLike( ConLike(..) )-import BasicTypes+import GHC.Types.Unique+import GHC.Core.ConLike( ConLike(..) )+import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt  import Control.Monad@@ -830,7 +830,8 @@       | otherwise       = updateVarType swizzle_ty v -    swizzle_ty ty = runIdentity (mapType swizzleMapper () ty)+    (map_type, _, _, _) = mapTyCo swizzleMapper+    swizzle_ty ty = runIdentity (map_type ty)   generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon@@ -841,7 +842,7 @@     do { -- Step 1: Separate Specified from Required variables          -- NB: spec_req_tvs = spec_tvs ++ req_tvs          --     And req_tvs is 1-1 with tyConTyVars-         --     See Note [Scoped tyvars in a TcTyCon] in TyCon+         --     See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon        ; let spec_req_tvs        = map snd scoped_prs              n_spec              = length spec_req_tvs - tyConArity tc              (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs@@ -931,7 +932,7 @@ around even between minor released. By forbidding visible type application, we ensure users aren't caught unawares. -Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.+Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.  The question for this Note is this:    given a TyClDecl, how are its quantified type variables classified?@@ -1068,7 +1069,7 @@     - Have complete fresh Names; see TcMType       Note [Unification variables need fresh Names] -  Assign initial monomorophic kinds to S, T+  Assign initial monomorphic kinds to S, T           T :: kk1 -> * -> kk2 -> *           S :: kk3 -> * -> kk4 -> * @@ -1098,7 +1099,7 @@ * Step 4.  Extend the type environment with a TcTyCon for S and T, now   with their utterly-final polymorphic kinds (needed for recursive   occurrences of S, T).  Now typecheck the declarations, and build the-  final AlgTyCOn for S and T resp.+  final AlgTyCon for S and T resp.  The first three steps are in kcTyClGroup; the fourth is in tcTyClDecls.@@ -1323,7 +1324,7 @@         ; tc <- kcDeclHeader strategy name flav ktvs $                 case m_sig of                   Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig-                  Nothing -> dataDeclDefaultResultKind new_or_data+                  Nothing -> return $ dataDeclDefaultResultKind new_or_data         ; return [tc] }  getInitialKind InitialKindInfer (FamDecl { tcdFam = decl })@@ -1438,13 +1439,10 @@ -}  -- See Note [Data declaration default result kind]-dataDeclDefaultResultKind :: NewOrData -> TcM ContextKind-dataDeclDefaultResultKind new_or_data = do-  -- See Note [Implementation of UnliftedNewtypes]-  unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes-  return $ case new_or_data of-    NewType | unlifted_newtypes -> OpenKind-    _ -> TheKind liftedTypeKind+dataDeclDefaultResultKind :: NewOrData -> ContextKind+dataDeclDefaultResultKind NewType  = OpenKind+  -- See Note [Implementation of UnliftedNewtypes], point <Error Messages>.+dataDeclDefaultResultKind DataType = TheKind liftedTypeKind  {- Note [Data declaration default result kind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1465,13 +1463,14 @@   data D4 :: Type -> Type where     MkD4 :: ... -> D4 param -However, there's a twist: when -XUnliftedNewtypes are enabled, we must relax-the assumed result kind to (TYPE r) for newtypes:+However, there's a twist: for newtypes, we must relax+the assumed result kind to (TYPE r):    newtype D5 where     MkD5 :: Int# -> D5 -dataDeclDefaultResultKind takes care to produce the appropriate result kind.+See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note+<Error Messages>. -}  ---------------------------------@@ -1503,7 +1502,7 @@   -- Called only for declarations without a signature (no CUSKs or SAKs here) kcLTyClDecl (L loc decl)   = setSrcSpan loc $-    do { tycon <- kcLookupTcTyCon tc_name+    do { tycon <- tcLookupTcTyCon tc_name        ; traceTc "kcTyClDecl {" (ppr tc_name)        ; addVDQNote tycon $   -- See Note [Inferring visible dependent quantification]          addErrCtxt (tcMkDeclCtxt decl) $@@ -1536,20 +1535,20 @@   | HsDataDefn { dd_ctxt = ctxt                , dd_cons = cons                , dd_ND = new_or_data } <- defn-  = bindTyClTyVars name $ \ _ _ ->+  = bindTyClTyVars name $ \ _ _ _ ->     do { _ <- tcHsContext ctxt        ; kcConDecls new_or_data (tyConResKind tyCon) cons        }  kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon-  = bindTyClTyVars name $ \ _ res_kind ->-    discardResult $ tcCheckLHsType rhs res_kind+  = bindTyClTyVars name $ \ _ _ res_kind ->+    discardResult $ tcCheckLHsType rhs (TheKind res_kind)         -- NB: check against the result kind that we allocated         -- in inferInitialKinds.  kcTyClDecl (ClassDecl { tcdLName = L _ name                       , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon-  = bindTyClTyVars name $ \ _ _ ->+  = bindTyClTyVars name $ \ _ _ _ ->     do  { _ <- tcHsContext ctxt         ; mapM_ (wrapLocM_ kc_sig) sigs }   where@@ -1570,38 +1569,15 @@  ------------------- --- | Unify the kind of the first type provided with the newtype's kind, if--- -XUnliftedNewtypes is enabled and the NewOrData indicates Newtype. If there--- is more than one type provided, do nothing: the newtype is in error, and this--- will be caught in validity checking (which will give a better error than we can--- here.)-unifyNewtypeKind :: DynFlags-                 -> NewOrData-                 -> [LHsType GhcRn]   -- user-written argument types, should be just 1-                 -> [TcType]          -- type-checked argument types, should be just 1-                 -> TcKind            -- expected kind of newtype-                 -> TcM [TcType]      -- casted argument types (should be just 1)-                                      --  result = orig_arg |> kind_co-                                      -- where kind_co :: orig_arg_ki ~N expected_ki-unifyNewtypeKind dflags NewType [hs_ty] [tc_ty] ki-  | xopt LangExt.UnliftedNewtypes dflags-  = do { traceTc "unifyNewtypeKind" (ppr hs_ty $$ ppr tc_ty $$ ppr ki)-       ; co <- unifyKind (Just (unLoc hs_ty)) (typeKind tc_ty) ki-       ; return [tc_ty `mkCastTy` co] }-  -- See comments above: just do nothing here-unifyNewtypeKind _ _ _ arg_tys _ = return arg_tys- -- Type check the types of the arguments to a data constructor. -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments. kcConArgTys :: NewOrData -> Kind -> [LHsType GhcRn] -> TcM () kcConArgTys new_or_data res_kind arg_tys = do-  { arg_tc_tys <- mapM (tcHsOpenType . getBangType) arg_tys+  { let exp_kind = getArgExpKind new_or_data res_kind+  ; mapM_ (flip tcCheckLHsType exp_kind . getBangType) arg_tys     -- See Note [Implementation of UnliftedNewtypes], STEP 2-  ; dflags <- getDynFlags-  ; discardResult $-      unifyNewtypeKind dflags new_or_data arg_tys arg_tc_tys res_kind   }  kcConDecls :: NewOrData@@ -1841,20 +1817,20 @@ proposal.  STEP 1: Getting the initial kind, as done by inferInitialKind. We have-two sub-cases (assuming we have a newtype and -XUnliftedNewtypes is enabled):+two sub-cases: -* With a CUSK: no change in kind-checking; the tycon is given the kind+* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind   the user writes, whatever it may be. -* Without a CUSK: If there is no kind signature, the tycon is given-  a kind `TYPE r`, for a fresh unification variable `r`.+* Without a SAK/CUSK: If there is no kind signature, the tycon is given+  a kind `TYPE r`, for a fresh unification variable `r`. We do this even+  when -XUnliftedNewtypes is not on; see <Error Messages>, below.  STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs. The key function here is kcConDecl, which looks at an individual constructor-declaration. In the unlifted-newtypes case (i.e., -XUnliftedNewtypes and,-indeed, we are processing a newtype), we call unifyNewtypeKind, which is a-thin wrapper around unifyKind, unifying the kind of the one argument and the-result kind of the newtype tycon.+declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes+is enabled; see <Error Messages>, below), we generate a correct ContextKind+for the checking argument types: see getArgExpKind.  Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is enabled (we use r0 to denote a unification variable):@@ -1877,10 +1853,11 @@ in kcTyClDecl.  STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function-here is tcConDecl. Once again, we must call unifyNewtypeKind, for two reasons:+here is tcConDecl. Once again, we must use getArgExpKind to ensure that the+representation type's kind matches that of the newtype, for two reasons:    A. It is possible that a GADT has a CUSK. (Note that this is *not*-     possible for H98 types. Recall that CUSK types don't go through+     possible for H98 types.) Recall that CUSK types don't go through      kcTyClDecl, so we might not have done this kind check.   B. We need to produce the coercion to put on the argument type      if the kinds are different (for both H98 and GADT).@@ -1896,11 +1873,32 @@ We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the newtype kind, which is the principal correctness condition for newtypes.-This call to unifyNewtypeKind is what produces that coercion. +Wrinkle: Consider (#17021, typecheck/should_fail/T17021)++    type family Id (x :: a) :: a where+      Id x = x++    newtype T :: TYPE (Id LiftedRep) where+      MkT :: Int -> T++  In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T, never Int -> (T |>+  TYPE axId); otherwise, the result type of the constructor wouldn't match the+  datatype. However, type-checking the HsType T might reasonably result in+  (T |> hole). We thus must ensure that this cast is dropped, forcing the+  type-checker to add one to the Int instead.++  Why is it always safe to drop the cast? This result type is type-checked by+  tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is+  important that even after dropping the cast, the type's kind has the form+  TYPE r. This is guaranteed by restrictions on the kinds of datatypes.+  For example, a declaration like `newtype T :: Id Type` is rejected: a+  newtype's final kind always has the form TYPE r, just as we want.+ Note that this is possible in the H98 case only for a data family, because the H98 syntax doesn't permit a kind signature on the newtype itself. +There are also some changes for deailng with families:  1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if    UnliftedNewtypes is on. This allows us to write things like:@@ -1922,7 +1920,7 @@    we use that kind signature.  3. A data family and its newtype instance may be declared with slightly-   different kinds. See Note [Unifying data family kinds] in TcInstDcls.+   different kinds. See point 7 in Note [Datatype return kinds].  There's also a change in the renamer: @@ -1935,6 +1933,36 @@ For completeness, it was also necessary to make coerce work on unlifted types, resolving #13595. +<Error Messages>: It's tempting to think that the expected kind for a newtype+constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type.+But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is+an example:++  newtype A = MkA Int#++If we expect the argument to MkA to have kind Type, then we get a kind-mismatch+error. The problem is that there is no way to connect this mismatch error to+-XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow+the A to type-check, but then find the problem when doing validity checking (and+where we get make a suitable error message). One potential worry is++  {-# LANGUAGE PolyKinds #-}+  newtype B a = MkB a++This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just+as we would like. Another potential problem comes in a case like++  -- no UnliftedNewtypes++  data family D :: k+  newtype instance D = MkD Any++Here, we want inference to tell us that k should be instantiated to Type in+the instance. With the approach described here (checking for Type only in+the validity checker), that will not happen. But I cannot think of a non-contrived+example that will notice this lack of inference, so it seems better to improve+error messages than be able to infer this instantiation.+ -}  tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])@@ -2017,7 +2045,7 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs   = fixM $ \ clas ->     -- We need the knot because 'clas' is passed into tcClassATs-    bindTyClTyVars class_name $ \ binders res_kind ->+    bindTyClTyVars class_name $ \ _ binders res_kind ->     do { checkClassKindSig res_kind        ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)        ; let tycon_name = class_name        -- We use the same name@@ -2026,6 +2054,9 @@        ; (ctxt, fds, sig_stuff, at_stuff)             <- pushTcLevelM_   $                solveEqualities $+               checkTvConstraints skol_info (binderVars binders) $+               -- The checkTvConstraints is needed bring into scope the+               -- skolems bound by the class decl header (#17841)                do { ctxt <- tcHsContext hs_ctxt                   ; fds  <- mapM (addLocM tc_fundep) fundeps                   ; sig_stuff <- tcClassSigs class_name sigs meths@@ -2058,6 +2089,7 @@                                 ppr fds)        ; return clas }   where+    skol_info = TyConSkol ClassFlavour class_name     tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;                                 ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;                                 ; return (tvs1', tvs2') }@@ -2280,6 +2312,177 @@ it won't contain any tycons. Accordingly, the patterns used in the substitution won't actually be knot-tied, even though we're in the knot. This is too delicate for my taste, but it works.++Note [Datatype return kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several poorly lit corners around datatype/newtype return kinds.+This Note explains these. Within this note, always understand "instance"+to mean data or newtype instance, and understand "family" to mean data+family. No type families or classes here. Some examples:++data    T a :: <kind> where ...   -- See Point 4+newtype T a :: <kind> where ...   -- See Point 5++data family T a :: <kind>          -- See Point 6++data    instance T [a] :: <kind> where ...   -- See Point 4+newtype instance T [a] :: <kind> where ...   -- See Point 5++1. Where this applies: Only GADT syntax for data/newtype/instance declarations+   can have declared return kinds. This Note does not apply to Haskell98+   syntax.++2. Where these kinds come from: Return kinds are processed through several+   different code paths:++     data/newtypes: The return kind is part of the TyCon kind, gotten either+     by checkInitialKind (standalone kind signature / CUSK) or+     inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is+     then passed to tcDataDefn.++     families: The return kind is either written in a standalone signature+     or extracted from a family declaration in getInitialKind.+     If a family declaration is missing a result kind, it is assumed to be+     Type. This assumption is in getInitialKind for CUSKs or+     get_fam_decl_initial_kind for non-signature & non-CUSK cases.++     instances: The data family already has a known kind. The return kind+     of an instance is then calculated by applying the data family tycon+     to the patterns provided, as computed by the typeKind lhs_ty in the+     end of tcDataFamInstHeader. In the case of an instance written in GADT+     syntax, there are potentially *two* return kinds: the one computed from+     applying the data family tycon to the patterns, and the one given by+     the user. This second kind is checked by the tc_kind_sig function within+     tcDataFamInstHeader.++3. Eta-expansion: Any forall-bound variables and function arguments in a result kind+   become parameters to the type. That is, when we say++     data T a :: Type -> Type where ...++   we really mean for T to have two parameters. The second parameter+   is produced by processing the return kind in etaExpandAlgTyCon,+   called in tcDataDefn for data/newtypes and in tcDataFamInstDecl+   for instances. This is true for data families as well, though their+   arity only matters for pretty-printing.++   See also Note [TyConBinders for the result kind signatures of a data type]+   in TcHsType.++4. Datatype return kind restriction: A data/data-instance return kind must end+   in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By+   "end in", we mean we strip any foralls and function arguments off before+   checking: this remaining part of the type is returned from+   etaExpandAlgTyCon. Note that we do *not* do type family reduction here.+   Examples:++     data T1 :: Type                          -- good+     data T2 :: Bool -> Type                  -- good+     data T3 :: Bool -> forall k. Type        -- strange, but still accepted+     data T4 :: forall k. k -> Type           -- good+     data T5 :: Bool                          -- bad+     data T6 :: Type -> Bool                  -- bad++     type Arrow = (->)+     data T7 :: Arrow Bool Type               -- good++     type family ARROW where+       ARROW = (->)+     data T8 :: ARROW Bool Type               -- bad++     type Star = Type+     data T9 :: Bool -> Star                  -- good++     type family F a where+       F Int  = Bool+       F Bool = Type+     data T10 :: Bool -> F Bool               -- bad++   This check is done in checkDataKindSig. For data declarations, this+   call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl.++   However, because data instances in GADT syntax can have two return kinds (see+   point (2) above), we must check both return kinds. The user-written return+   kind is checked in tc_kind_sig within tcDataFamInstHeader. Examples:++     data family D (a :: Nat) :: k     -- good (see Point 6)++     data instance D 1 :: Type         -- good+     data instance D 2 :: F Bool       -- bad++5. Newtype return kind restriction: If -XUnliftedNewtypes is on, then+   a newtype/newtype-instance return kind must end in TYPE xyz, for some+   xyz (after type synonym expansion). The "xyz" may include type families,+   but the TYPE part must be visible with expanding type families (only synonyms).+   This kind is unified with the kind of the representation type (the type+   of the one argument to the one constructor). See also steps (2) and (3)+   of Note [Implementation of UnliftedNewtypes].++   If -XUnliftedNewtypes is not on, then newtypes are treated just like datatypes.++   The checks are done in the same places as for datatypes.+   Examples (assume -XUnliftedNewtypes):++     newtype N1 :: Type                       -- good+     newtype N2 :: Bool -> Type               -- good+     newtype N3 :: forall r. Bool -> TYPE r   -- good++     type family F (t :: Type) :: RuntimeRep+     newtype N4 :: forall t -> TYPE (F t)     -- good++     type family STAR where+       STAR = Type+     newtype N5 :: Bool -> STAR               -- bad++6. Family return kind restrictions: The return kind of a data family must+   be either TYPE xyz (for some xyz) or a kind variable. The idea is that+   instances may specialise the kind variable to fit one of the restrictions+   above. This is checked by the call to checkDataKindSig in tcFamDecl1.+   Examples:++     data family D1 :: Type              -- good+     data family D2 :: Bool -> Type      -- good+     data family D3 k :: k               -- good+     data family D4 :: forall k -> k     -- good+     data family D5 :: forall k. k -> k  -- good+     data family D6 :: forall r. TYPE r  -- good+     data family D7 :: Bool -> STAR      -- bad (see STAR from point 5)++7. Two return kinds for instances: If an instance has two return kinds,+   one from the family declaration and one from the instance declaration+   (see point (2) above), they are unified. More accurately, we make sure+   that the kind of the applied data family is a subkind of the user-written+   kind. TcHsType.checkExpectedKind normally does this check for types, but+   that's overkill for our needs here. Instead, we just instantiate any+   invisible binders in the (instantiated) kind of the data family+   (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders+   and then unify the resulting kind with the kind written by the user.+   This unification naturally produces a coercion, which we can drop, as+   the kind annotation on the instance is redundant (except perhaps for+   effects of unification).++   Example:++      data Color = Red | Blue+      type family Interpret (x :: Color) :: RuntimeRep where+        Interpret 'Red = 'IntRep+        Interpret 'Blue = 'WordRep+      data family Foo (x :: Color) :: TYPE (Interpret x)+      newtype instance Foo 'Red :: TYPE IntRep where+        FooRedC :: Int# -> Foo 'Red++   Here we get that Foo 'Red :: TYPE (Interpret Red) and we have to+   unify the kind with TYPE IntRep.++   Example requiring subkinding:++      data family D :: forall k. k+      data instance D :: Type               -- forall k. k   <:  Type+      data instance D :: Type -> Type       -- forall k. k   <:  Type -> Type+        -- NB: these do not overlap++   This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes].+ -}  {- *********************************************************************@@ -2294,7 +2497,7 @@                               , fdResultSig = L _ sig                               , fdInjectivityAnn = inj })   | DataFamily <- fam_info-  = bindTyClTyVars tc_name $ \ binders res_kind -> do+  = bindTyClTyVars tc_name $ \ _ binders res_kind -> do   { traceTc "data family:" (ppr tc_name)   ; checkFamFlag tc_name @@ -2308,6 +2511,7 @@   --   data family D a :: forall k. Type -> k   -- When UnliftedNewtypes is enabled, we loosen this restriction   -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1).+  -- See also Note [Datatype return kinds]   ; let (_, final_res_kind) = splitPiTys res_kind   ; checkDataKindSig DataFamilySort final_res_kind   ; tc_rep_name <- newTyConRepName tc_name@@ -2320,7 +2524,7 @@   ; return tycon }    | OpenTypeFamily <- fam_info-  = bindTyClTyVars tc_name $ \ binders res_kind -> do+  = bindTyClTyVars tc_name $ \ _ binders res_kind -> do   { traceTc "open type family:" (ppr tc_name)   ; checkFamFlag tc_name   ; inj' <- tcInjectivity binders inj@@ -2337,7 +2541,7 @@          -- the variables in the header scope only over the injectivity          -- declaration but this is not involved here        ; (inj', binders, res_kind)-            <- bindTyClTyVars tc_name $ \ binders res_kind ->+            <- bindTyClTyVars tc_name $ \ _ binders res_kind ->                do { inj' <- tcInjectivity binders inj                   ; return (inj', binders, res_kind) } @@ -2435,12 +2639,12 @@ tcTySynRhs :: RolesInfo -> Name            -> LHsType GhcRn -> TcM TyCon tcTySynRhs roles_info tc_name hs_ty-  = bindTyClTyVars tc_name $ \ binders res_kind ->+  = bindTyClTyVars tc_name $ \ _ binders res_kind ->     do { env <- getLclEnv        ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))        ; rhs_ty <- pushTcLevelM_   $                    solveEqualities $-                   tcCheckLHsType hs_ty res_kind+                   tcCheckLHsType hs_ty (TheKind res_kind)        ; rhs_ty <- zonkTcTypeToType rhs_ty        ; let roles = roles_info tc_name              tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty@@ -2456,13 +2660,17 @@                                                -- via inferInitialKinds                        , dd_cons = cons                        , dd_derivs = derivs })-  = bindTyClTyVars tc_name $ \ tycon_binders res_kind ->+  = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind ->+       -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need+       -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'+       --        -- The TyCon tyvars must scope over        --    - the stupid theta (dd_ctxt)        --    - for H98 constructors only, the ConDecl        -- But it does no harm to bring them into scope        -- over GADT ConDecls as well; and it's awkward not to     do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons+         -- see Note [Datatype return kinds]        ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind         ; tcg_env <- getGblEnv@@ -2499,9 +2707,6 @@                                   stupid_theta tc_rhs                                   (VanillaAlgTyCon tc_rep_nm)                                   gadt_syntax) }-       ; tctc <- tcLookupTcTyCon tc_name-            -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need-            -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'        ; let deriv_info = DerivInfo { di_rep_tc = tycon                                     , di_scoped_tvs = tcTyConScopedTyVars tctc                                     , di_clauses = unLoc derivs@@ -2561,7 +2766,7 @@          bindImplicitTKBndrs_Q_Tv imp_vars $          bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $          do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats-            ; tcCheckLHsType hs_rhs_ty res_kind }+            ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) }              -- Why "_Tv" here?  Consider (#14066              --  type family Bar x y where              --      Bar (x :: a) (y :: b) = Int@@ -2608,7 +2813,7 @@                                       hs_pats hs_rhs_ty        -- Don't print results they may be knot-tied        -- (tcFamInstEqnGuts zonks to Type)-       ; return (mkCoAxBranch qtvs [] [] pats rhs_ty+       ; return (mkCoAxBranch qtvs [] [] fam_tc pats rhs_ty                               (map (const Nominal) qtvs)                               loc) } @@ -2634,7 +2839,7 @@  After checking (F :: forall k. k) (with no visible patterns), we still need to instantiate the k. With data family instances, this problem can be even-more intricate, due to Note [Arity of data families] in FamInstEnv. See+more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See indexed-types/should_compile/T12369 for an example.  So, the kind-checker must return the new skolems and args (that is, Type@@ -2669,6 +2874,9 @@     candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs)  Simple, neat, but a little non-obvious!++See also Note [Re-quantify type variables in rules] in TcRules, which explains+a very similar design when generalising over the type of a rewrite rule. -}  --------------------------@@ -2695,7 +2903,7 @@                        -- Ensure that the instance is consistent with its                        -- parent class (#16008)                      ; addConsistencyConstraints mb_clsinfo lhs_ty-                     ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind+                     ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind)                      ; return (lhs_ty, rhs_ty) }         -- See Note [Generalising in tcTyFamInstEqnGuts]@@ -2940,15 +3148,11 @@               solveEqualities                           $               bindExplicitTKBndrs_Skol explicit_tkv_nms $               do { ctxt <- tcHsMbContext hs_ctxt-                 ; btys <- tcConArgs hs_args+                 ; let exp_kind = getArgExpKind new_or_data res_kind+                 ; btys <- tcConArgs exp_kind hs_args                  ; field_lbls <- lookupConstructorFields (unLoc name)                  ; let (arg_tys, stricts) = unzip btys-                 ; dflags <- getDynFlags-                 ; final_arg_tys <--                     unifyNewtypeKind dflags new_or_data-                                      (hsConDeclArgTys hs_args)-                                      arg_tys res_kind-                 ; return (ctxt, final_arg_tys, field_lbls, stricts)+                 ; return (ctxt, arg_tys, field_lbls, stricts)                  }           -- exp_tvs have explicit, user-written binding sites@@ -2985,7 +3189,7 @@            ex_tvs    = qkvs ++ user_qtvs            -- For H98 datatypes, the user-written tyvar binders are precisely            -- the universals followed by the existentials.-           -- See Note [DataCon user type variable binders] in DataCon.+           -- See Note [DataCon user type variable binders] in GHC.Core.DataCon.            user_tvbs = univ_tvbs ++ ex_tvbs            buildOneDataCon (L _ name) = do              { is_infix <- tcConIsInfixH98 name hs_args@@ -3024,17 +3228,20 @@               bindImplicitTKBndrs_Skol implicit_tkv_nms $               bindExplicitTKBndrs_Skol explicit_tkv_nms $               do { ctxt <- tcHsMbContext cxt-                 ; btys <- tcConArgs hs_args+                 ; casted_res_ty <- tcHsOpenType hs_res_ty+                 ; res_ty <- if not debugIsOn then return $ discardCast casted_res_ty+                             else case splitCastTy_maybe casted_res_ty of+                               Just (ty, _) -> do unlifted_nts <- xoptM LangExt.UnliftedNewtypes+                                                  MASSERT( unlifted_nts )+                                                  MASSERT( new_or_data == NewType )+                                                  return ty+                               _ -> return casted_res_ty+                   -- See Note [Datatype return kinds]+                 ; let exp_kind = getArgExpKind new_or_data (typeKind res_ty)+                 ; btys <- tcConArgs exp_kind hs_args                  ; let (arg_tys, stricts) = unzip btys-                 ; res_ty <- tcHsOpenType hs_res_ty-                   -- See Note [Implementation of UnliftedNewtypes]-                 ; dflags <- getDynFlags-                 ; final_arg_tys <--                     unifyNewtypeKind dflags new_or_data-                                      (hsConDeclArgTys hs_args)-                                      arg_tys (typeKind res_ty)                  ; field_lbls <- lookupConstructorFields name-                 ; return (ctxt, final_arg_tys, res_ty, field_lbls, stricts)+                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)                  }        ; imp_tvs <- zonkAndScopedSort imp_tvs        ; let user_tvs = imp_tvs ++ exp_tvs@@ -3059,7 +3266,7 @@               -- Compute the user-written tyvar binders. These have the same              -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order.-             -- See Note [DataCon user type variable binders] in DataCon.+             -- See Note [DataCon user type variable binders] in GHC.Core.DataCon.              tkv_bndrs      = mkTyVarBinders Inferred  tkvs'              user_tv_bndrs  = mkTyVarBinders Specified user_tvs'              all_user_bndrs = tkv_bndrs ++ user_tv_bndrs@@ -3094,6 +3301,16 @@   = noExtCon nec tcConDecl _ _ _ _ _ _ (XConDecl nec) = noExtCon nec +-- | Produce an "expected kind" for the arguments of a data/newtype.+-- If the declaration is indeed for a newtype,+-- then this expected kind will be the kind provided. Otherwise,+-- it is OpenKind for datatypes and liftedTypeKind.+-- Why do we not check for -XUnliftedNewtypes? See point <Error Messages>+-- in Note [Implementation of UnliftedNewtypes]+getArgExpKind :: NewOrData -> Kind -> ContextKind+getArgExpKind NewType res_ki = TheKind res_ki+getArgExpKind DataType _     = OpenKind+ tcConIsInfixH98 :: Name              -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])              -> TcM Bool@@ -3116,16 +3333,19 @@                         ; return (con `elemNameEnv` fix_env) }                | otherwise -> return False -tcConArgs :: HsConDeclDetails GhcRn+tcConArgs :: ContextKind  -- expected kind of arguments+                          -- always OpenKind for datatypes, but unlifted newtypes+                          -- might have a specific kind+          -> HsConDeclDetails GhcRn           -> TcM [(TcType, HsSrcBang)]-tcConArgs (PrefixCon btys)-  = mapM tcConArg btys-tcConArgs (InfixCon bty1 bty2)-  = do { bty1' <- tcConArg bty1-       ; bty2' <- tcConArg bty2+tcConArgs exp_kind (PrefixCon btys)+  = mapM (tcConArg exp_kind) btys+tcConArgs exp_kind (InfixCon bty1 bty2)+  = do { bty1' <- tcConArg exp_kind bty1+       ; bty2' <- tcConArg exp_kind bty2        ; return [bty1', bty2'] }-tcConArgs (RecCon fields)-  = mapM tcConArg btys+tcConArgs exp_kind (RecCon fields)+  = mapM (tcConArg exp_kind) btys   where     -- We need a one-to-one mapping from field_names to btys     combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f))@@ -3135,13 +3355,12 @@     (_,btys) = unzip exploded  -tcConArg :: LHsType GhcRn -> TcM (TcType, HsSrcBang)-tcConArg bty+tcConArg :: ContextKind  -- expected kind for args; always OpenKind for datatypes,+                         -- but might be an unlifted type with UnliftedNewtypes+         -> LHsType GhcRn -> TcM (TcType, HsSrcBang)+tcConArg exp_kind bty   = do  { traceTc "tcConArg 1" (ppr bty)-        ; arg_ty <- tcHsOpenType (getBangType bty)-             -- Newtypes can't have unboxed types, but we check-             -- that in checkValidDataCon; this tcConArg stuff-             -- doesn't happen for GADT-style declarations+        ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind         ; traceTc "tcConArg 2" (ppr bty)         ; return (arg_ty, getBangStrictness bty) } @@ -3227,7 +3446,7 @@         -- Existentials are the leftover type vars: [x,y]         -- The user-written type variables are what is listed in the forall:         --   [x, y, z] (all specified). We must rejig these as well.-        --   See Note [DataCon user type variable binders] in DataCon.+        --   See Note [DataCon user type variable binders] in GHC.Core.DataCon.         -- So we return ( [a,b,z], [x,y]         --              , [], [x,y,z]         --              , [a~(x,y),b~z], <arg-subst> )@@ -3240,7 +3459,7 @@         -- gives us exactly what we need to rejig the user-written tyvars,         -- since the dcUserTyVarBinders invariant guarantees that the         -- substitution has *all* the tyvars in its domain.-        -- See Note [DataCon user type variable binders] in DataCon.+        -- See Note [DataCon user type variable binders] in GHC.Core.DataCon.         subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst)         substed_inferred_tvs  = subst_user_tvs dc_inferred_tvs         substed_specified_tvs = subst_user_tvs dc_specified_tvs@@ -3773,9 +3992,6 @@           -- Reason: it's really the argument of an equality constraint         ; checkValidMonoType orig_res_ty -          -- Check all argument types for validity-        ; checkValidType ctxt (dataConUserType con)-           -- If we are dealing with a newtype, we allow levity polymorphism           -- regardless of whether or not UnliftedNewtypes is enabled. A           -- later check in checkNewDataCon handles this, producing a@@ -3783,9 +3999,16 @@         ; unless (isNewTyCon tc)             (mapM_ (checkForLevPoly empty) (dataConOrigArgTys con)) -          -- Extra checks for newtype data constructors+          -- Extra checks for newtype data constructors. Importantly, these+          -- checks /must/ come before the call to checkValidType below. This+          -- is because checkValidType invokes the constraint solver, and+          -- invoking the solver on an ill formed newtype constructor can+          -- confuse GHC to the point of panicking. See #17955 for an example.         ; when (isNewTyCon tc) (checkNewDataCon con) +          -- Check all argument types for validity+        ; checkValidType ctxt (dataConUserType con)+           -- Check that existentials are allowed if they are used         ; checkTc (existential_ok || isVanillaDataCon con)                   (badExistential con)@@ -3796,7 +4019,7 @@         ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]            -- Check the dcUserTyVarBinders invariant-          -- See Note [DataCon user type variable binders] in DataCon+          -- See Note [DataCon user type variable binders] in GHC.Core.DataCon           -- checked here because we sometimes build invalid DataCons before           -- erroring above here         ; when debugIsOn $
compiler/typecheck/TcTyDecls.hs view
@@ -36,37 +36,37 @@ import TcRnMonad import TcEnv import TcBinds( tcValBinds )-import TyCoRep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )+import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) import TcType-import Predicate+import GHC.Core.Predicate import TysWiredIn( unitTy ) import GHC.Core.Make( rEC_SEL_ERROR_ID ) import GHC.Hs-import Class-import Type+import GHC.Core.Class+import GHC.Core.Type import GHC.Driver.Types-import TyCon-import ConLike-import DataCon-import Name-import NameEnv-import NameSet hiding (unitFV)-import RdrName ( mkVarUnqual )-import Id-import IdInfo-import VarEnv-import VarSet-import Coercion ( ltRole )-import BasicTypes-import SrcLoc-import Unique ( mkBuiltinUnique )+import GHC.Core.TyCon+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set hiding (unitFV)+import GHC.Types.Name.Reader ( mkVarUnqual )+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Core.Coercion ( ltRole )+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Unique ( mkBuiltinUnique ) import Outputable import Util import Maybes import Bag import FastString import FV-import Module+import GHC.Types.Module  import Control.Monad
compiler/typecheck/TcTypeNats.hs view
@@ -23,15 +23,15 @@  import GhcPrelude -import Type+import GHC.Core.Type import Pair-import TcType     ( TcType, tcEqType )-import TyCon      ( TyCon, FamTyConFlav(..), mkFamilyTyCon-                  , Injectivity(..) )-import Coercion   ( Role(..) )+import TcType            ( TcType, tcEqType )+import GHC.Core.TyCon    ( TyCon, FamTyConFlav(..), mkFamilyTyCon+                         , Injectivity(..) )+import GHC.Core.Coercion ( Role(..) ) import Constraint ( Xi )-import CoAxiom    ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )-import Name       ( Name, BuiltInSyntax(..) )+import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )+import GHC.Types.Name          ( Name, BuiltInSyntax(..) ) import TysWiredIn import TysPrim    ( mkTemplateAnonTyConBinders ) import PrelNames  ( gHC_TYPELITS
compiler/typecheck/TcTypeable.hs view
@@ -13,10 +13,11 @@ #include "HsVersions.h"  import GhcPrelude+import GHC.Platform -import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )+import GHC.Types.Basic ( Boxity(..), neverInlinePragma, SourceText(..) ) import GHC.Iface.Env( newGlobalBinder )-import TyCoRep( Type(..), TyLit(..) )+import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) import TcEnv import TcEvidence ( mkWpTyApps ) import TcRnMonad@@ -27,16 +28,16 @@ import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon                   , vecCountTyCon, vecElemTyCon                   , nilDataCon, consDataCon )-import Name-import Id-import Type-import TyCon-import DataCon-import Module+import GHC.Types.Name+import GHC.Types.Id+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Types.Module import GHC.Hs import GHC.Driver.Session import Bag-import Var ( VarBndr(..) )+import GHC.Types.Var ( VarBndr(..) ) import GHC.Core.Map import Constants import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)@@ -76,7 +77,7 @@    recipe for computing the kind of an instantiation of the tycon (see    Note [Representing TyCon kinds: KindRep] later in this file for details). -   We define (in TyCon)+   We define (in GHC.Core.TyCon)          type TyConRepName = Name @@ -354,7 +355,7 @@     ]  data TypeableStuff-    = Stuff { dflags         :: DynFlags+    = Stuff { platform       :: Platform        -- ^ Target platform             , trTyConDataCon :: DataCon         -- ^ of @TyCon@             , trNameLit      :: FastString -> LHsExpr GhcTc                                                 -- ^ To construct @TrName@s@@ -373,7 +374,7 @@ -- | Collect various tidbits which we'll need to generate TyCon representations. collect_stuff :: TcM TypeableStuff collect_stuff = do-    dflags <- getDynFlags+    platform               <- targetPlatform <$> getDynFlags     trTyConDataCon         <- tcLookupDataCon trTyConDataConName     kindRepTyCon           <- tcLookupTyCon   kindRepTyConName     kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName@@ -619,8 +620,8 @@                    -> LHsExpr GhcTc mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep   =           nlHsDataCon trTyConDataCon-    `nlHsApp` nlHsLit (word64 dflags high)-    `nlHsApp` nlHsLit (word64 dflags low)+    `nlHsApp` nlHsLit (word64 platform high)+    `nlHsApp` nlHsLit (word64 platform low)     `nlHsApp` mod_rep_expr todo     `nlHsApp` trNameLit (mkFastString tycon_str)     `nlHsApp` nlHsLit (int n_kind_vars)@@ -641,10 +642,10 @@     int :: Int -> HsLit GhcTc     int n = HsIntPrim (SourceText $ show n) (toInteger n) -word64 :: DynFlags -> Word64 -> HsLit GhcTc-word64 dflags n-  | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)-  | otherwise             = HsWordPrim   NoSourceText (toInteger n)+word64 :: Platform -> Word64 -> HsLit GhcTc+word64 platform n = case platformWordSize platform of+   PW4 -> HsWord64Prim NoSourceText (toInteger n)+   PW8 -> HsWordPrim   NoSourceText (toInteger n)  {- Note [Representing TyCon kinds: KindRep]
compiler/typecheck/TcUnify.hs view
@@ -44,28 +44,28 @@ import GhcPrelude  import GHC.Hs-import TyCoRep-import TyCoPpr( debugPprType )+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr( debugPprType ) import TcMType import TcRnMonad import TcType-import Type-import Coercion+import GHC.Core.Type+import GHC.Core.Coercion import TcEvidence import Constraint-import Predicate+import GHC.Core.Predicate import TcOrigin-import Name( isSystemName )+import GHC.Types.Name( isSystemName ) import Inst-import TyCon+import GHC.Core.TyCon import TysWiredIn import TysPrim( tYPE )-import Var-import VarSet-import VarEnv+import GHC.Types.Var as Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env import ErrUtils import GHC.Driver.Session-import BasicTypes+import GHC.Types.Basic import Bag import Util import qualified GHC.LanguageExtensions as LangExt@@ -1195,18 +1195,14 @@                  ; return (emptyTcEvBinds, res) } }  checkTvConstraints :: SkolemInfo-                   -> Maybe SDoc  -- User-written telescope, if present-                   -> TcM ([TcTyVar], result)-                   -> TcM ([TcTyVar], result)--checkTvConstraints skol_info m_telescope thing_inside-  = do { (tclvl, wanted, (skol_tvs, result))-             <- pushLevelAndCaptureConstraints thing_inside--       ; emitResidualTvConstraint skol_info m_telescope-                                  skol_tvs tclvl wanted+                   -> [TcTyVar]          -- Skolem tyvars+                   -> TcM result+                   -> TcM result -       ; return (skol_tvs, result) }+checkTvConstraints skol_info skol_tvs thing_inside+  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside+       ; emitResidualTvConstraint skol_info Nothing skol_tvs tclvl wanted+       ; return result }  emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar]                          -> TcLevel -> WantedConstraints -> TcM ()@@ -1697,7 +1693,7 @@   where     go dflags cur_lvl       | canSolveByUnification cur_lvl tv1 ty2-      , Just ty2' <- metaTyVarUpdateOK dflags tv1 ty2+      , MTVU_OK ty2' <- metaTyVarUpdateOK dflags tv1 ty2       = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1)            ; traceTc "uUnfilledVar2 ok" $              vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)@@ -1766,7 +1762,7 @@ {- Note [TyVar/TyVar orientation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)?-This is a surprisingly tricky question!+This is a surprisingly tricky question! This is invariant (TyEq:TV).  The question is answered by swapOverTyVars, which is use   - in the eager unifier, in TcUnify.uUnfilledVar1@@ -2182,7 +2178,9 @@  data MetaTyVarUpdateResult a   = MTVU_OK a-  | MTVU_Bad     -- Forall, predicate, or type family+  | MTVU_Bad          -- Forall, predicate, or type family+  | MTVU_HoleBlocker  -- Blocking coercion hole+        -- See Note [Equalities with incompatible kinds] in TcCanonical   | MTVU_Occurs     deriving (Functor) @@ -2191,10 +2189,17 @@       (<*>) = ap  instance Monad MetaTyVarUpdateResult where-  MTVU_OK x    >>= k = k x-  MTVU_Bad     >>= _ = MTVU_Bad-  MTVU_Occurs  >>= _ = MTVU_Occurs+  MTVU_OK x        >>= k = k x+  MTVU_Bad         >>= _ = MTVU_Bad+  MTVU_HoleBlocker >>= _ = MTVU_HoleBlocker+  MTVU_Occurs      >>= _ = MTVU_Occurs +instance Outputable a => Outputable (MetaTyVarUpdateResult a) where+  ppr (MTVU_OK a)      = text "MTVU_OK" <+> ppr a+  ppr MTVU_Bad         = text "MTVU_Bad"+  ppr MTVU_HoleBlocker = text "MTVU_HoleBlocker"+  ppr MTVU_Occurs      = text "MTVU_Occurs"+ occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult () -- Just for error-message generation; so we return MetaTyVarUpdateResult -- so the caller can report the right kind of error@@ -2203,22 +2208,25 @@ --   b) there is a forall in the type (unless we have -XImpredicativeTypes) occCheckForErrors dflags tv ty   = case preCheck dflags True tv ty of-      MTVU_OK _   -> MTVU_OK ()-      MTVU_Bad    -> MTVU_Bad-      MTVU_Occurs -> case occCheckExpand [tv] ty of-                       Nothing -> MTVU_Occurs-                       Just _  -> MTVU_OK ()+      MTVU_OK _        -> MTVU_OK ()+      MTVU_Bad         -> MTVU_Bad+      MTVU_HoleBlocker -> MTVU_HoleBlocker+      MTVU_Occurs      -> case occCheckExpand [tv] ty of+                            Nothing -> MTVU_Occurs+                            Just _  -> MTVU_OK ()  ---------------- metaTyVarUpdateOK :: DynFlags                   -> TcTyVar             -- tv :: k1                   -> TcType              -- ty :: k2-                  -> Maybe TcType        -- possibly-expanded ty+                  -> MetaTyVarUpdateResult TcType        -- possibly-expanded ty -- (metaTyVarUpdateOK tv ty) -- We are about to update the meta-tyvar tv with ty -- Check (a) that tv doesn't occur in ty (occurs check) --       (b) that ty does not have any foralls --           (in the impredicative case), or type functions+--       (c) that ty does not have any blocking coercion holes+--           See Note [Equalities with incompatible kinds] in TcCanonical -- -- We have two possible outcomes: -- (1) Return the type to update the type variable with,@@ -2241,20 +2249,24 @@   = case preCheck dflags False tv ty of          -- False <=> type families not ok          -- See Note [Prevent unification with type families]-      MTVU_OK _   -> Just ty-      MTVU_Bad    -> Nothing  -- forall, predicate, or type function-      MTVU_Occurs -> occCheckExpand [tv] ty+      MTVU_OK _        -> MTVU_OK ty+      MTVU_Bad         -> MTVU_Bad          -- forall, predicate, type function+      MTVU_HoleBlocker -> MTVU_HoleBlocker  -- coercion hole+      MTVU_Occurs      -> case occCheckExpand [tv] ty of+                            Just expanded_ty -> MTVU_OK expanded_ty+                            Nothing          -> MTVU_Occurs  preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult () -- A quick check for --   (a) a forall type (unless -XImpredicativeTypes) --   (b) a predicate type (unless -XImpredicativeTypes) --   (c) a type family---   (d) an occurrence of the type variable (occurs check)+--   (d) a blocking coercion hole+--   (e) an occurrence of the type variable (occurs check) -- -- For (a), (b), and (c) we check only the top level of the type, NOT--- inside the kinds of variables it mentions.  But for (c) we do--- look in the kinds of course.+-- inside the kinds of variables it mentions.  For (d) we look deeply+-- in coercions, and for (e) we do look in the kinds of course.  preCheck dflags ty_fam_ok tv ty   = fast_check ty@@ -2296,10 +2308,13 @@     fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs                      | otherwise                        = ok -     -- For coercions, we are only doing an occurs check here;      -- no bother about impredicativity in coercions, as they're      -- inferred-    fast_check_co co | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs+    fast_check_co co | not (gopt Opt_DeferTypeErrors dflags)+                     , badCoercionHoleCo co            = MTVU_HoleBlocker+        -- Wrinkle (4b) in TcCanonical Note [Equalities with incompatible kinds]++                     | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs                      | otherwise                       = ok      bad_tc :: TyCon -> Bool
compiler/typecheck/TcValidity.hs view
@@ -30,19 +30,19 @@ import TcUnify    ( tcSubType_NC ) import TcSimplify ( simplifyAmbiguityCheck ) import ClsInst    ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) )-import TyCoFVs-import TyCoRep-import TyCoPpr+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr import TcType hiding ( sizeType, sizeTypes ) import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName ) import PrelNames-import Type-import Unify      ( tcMatchTyX_BM, BindFlag(..) )-import Coercion-import CoAxiom-import Class-import TyCon-import Predicate+import GHC.Core.Type+import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) )+import GHC.Core.Coercion+import GHC.Core.Coercion.Axiom+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Core.Predicate import TcOrigin  -- others:@@ -52,21 +52,21 @@ import TcRnMonad        -- TcType, amongst others import TcEnv       ( tcInitTidyEnv, tcInitOpenTidyEnv ) import FunDeps-import FamInstEnv  ( isDominatedBy, injectiveBranches,-                     InjectivityCheckResult(..) )+import GHC.Core.FamInstEnv+   ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) import FamInst-import Name-import VarEnv-import VarSet-import Var         ( VarBndr(..), mkTyVar )+import GHC.Types.Name+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Var     ( VarBndr(..), mkTyVar ) import FV import ErrUtils import GHC.Driver.Session import Util import ListSetOps-import SrcLoc+import GHC.Types.SrcLoc import Outputable-import Unique      ( mkAlphaTyVarUnique )+import GHC.Types.Unique      ( mkAlphaTyVarUnique ) import Bag         ( emptyBag ) import qualified GHC.LanguageExtensions as LangExt @@ -891,7 +891,7 @@   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 Type+    -- See Note [Phantom type variables in kinds] in GHC.Core.Type     Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind     Just _  -> pure ()   where@@ -943,7 +943,7 @@   | allConstraintsAllowed (ve_ctxt ve) = return ()   | otherwise   = -- We are in a kind, where we allow only equality predicates-    -- See Note [Constraints in kinds] in TyCoRep, and #16263+    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and #16263     checkTcM (all isEqPred theta) $     constraintTyErr (ve_tidy_env ve) ty @@ -2031,7 +2031,7 @@      -- Injectivity check: check whether a new (CoAxBranch) can extend      -- already checked equations without violating injectivity      -- annotation supplied by the user.-     -- See Note [Verifying injectivity annotation] in FamInstEnv+     -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv     check_injectivity prev_branches cur_branch       | Injective inj <- injectivity       = do { dflags <- getDynFlags@@ -2046,7 +2046,7 @@     gather_conflicts inj prev_branches cur_branch (acc, n) branch                -- n is 0-based index of branch in prev_branches       = case injectiveBranches inj cur_branch branch of-           -- Case 1B2 in Note [Verifying injectivity annotation] in FamInstEnv+           -- Case 1B2 in Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv           InjectivityUnified ax1 ax2             | ax1 `isDominatedBy` (replace_br prev_branches n ax2)                 -> (acc, n + 1)@@ -2669,7 +2669,7 @@  Note that we only perform this check for type families, and not for data families. This is because it is perfectly acceptable to oversaturate data-family instance equations: see Note [Arity of data families] in FamInstEnv.+family instance equations: see Note [Arity of data families] in GHC.Core.FamInstEnv.  ************************************************************************ *                                                                      *
compiler/utils/AsmUtils.hs view
@@ -12,9 +12,10 @@ import Outputable  -- | Generate a section type (e.g. @\@progbits@). See #13937.-sectionType :: String -- ^ section type-            -> SDoc   -- ^ pretty assembler fragment-sectionType ty = sdocWithPlatform $ \platform ->+sectionType :: Platform -- ^ Target platform+            -> String   -- ^ section type+            -> SDoc     -- ^ pretty assembler fragment+sectionType platform ty =     case platformArch platform of       ArchARM{} -> char '%' <> text ty       _         -> char '@' <> text ty
compiler/utils/GraphBase.hs view
@@ -14,8 +14,8 @@  import GhcPrelude -import UniqSet-import UniqFM+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM   -- | A fn to check if a node is trivially colorable
compiler/utils/GraphColor.hs view
@@ -20,9 +20,9 @@ import GraphOps import GraphPpr -import Unique-import UniqFM-import UniqSet+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set import Outputable  import Data.Maybe
compiler/utils/GraphOps.hs view
@@ -25,9 +25,9 @@ import GraphBase  import Outputable-import Unique-import UniqSet-import UniqFM+import GHC.Types.Unique+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM  import Data.List        hiding (union) import Data.Maybe
compiler/utils/GraphPpr.hs view
@@ -12,9 +12,9 @@ import GraphBase  import Outputable-import Unique-import UniqSet-import UniqFM+import GHC.Types.Unique+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM  import Data.List (mapAccumL) import Data.Maybe
compiler/utils/UnVarGraph.hs view
@@ -30,12 +30,12 @@  import GhcPrelude -import Id-import VarEnv-import UniqFM+import GHC.Types.Id+import GHC.Types.Var.Env+import GHC.Types.Unique.FM import Outputable import Bag-import Unique+import GHC.Types.Unique  import qualified Data.IntSet as S
− compiler/utils/UniqMap.hs 
@@ -1,206 +0,0 @@-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# OPTIONS_GHC -Wall #-}---- Like 'UniqFM', these are maps for keys which are Uniquable.--- Unlike 'UniqFM', these maps also remember their keys, which--- makes them a much better drop in replacement for 'Data.Map.Map'.------ Key preservation is right-biased.-module UniqMap (-    UniqMap,-    emptyUniqMap,-    isNullUniqMap,-    unitUniqMap,-    listToUniqMap,-    listToUniqMap_C,-    addToUniqMap,-    addListToUniqMap,-    addToUniqMap_C,-    addToUniqMap_Acc,-    alterUniqMap,-    addListToUniqMap_C,-    adjustUniqMap,-    delFromUniqMap,-    delListFromUniqMap,-    plusUniqMap,-    plusUniqMap_C,-    plusMaybeUniqMap_C,-    plusUniqMapList,-    minusUniqMap,-    intersectUniqMap,-    disjointUniqMap,-    mapUniqMap,-    filterUniqMap,-    partitionUniqMap,-    sizeUniqMap,-    elemUniqMap,-    lookupUniqMap,-    lookupWithDefaultUniqMap,-    anyUniqMap,-    allUniqMap,-    -- Non-deterministic functions omitted-) where--import GhcPrelude--import UniqFM--import Unique-import Outputable--import Data.Semigroup as Semi ( Semigroup(..) )-import Data.Coerce-import Data.Maybe-import Data.Data---- | Maps indexed by 'Uniquable' keys-newtype UniqMap k a = UniqMap (UniqFM (k, a))-    deriving (Data, Eq, Functor)-type role UniqMap nominal representational--instance Semigroup (UniqMap k a) where-  (<>) = plusUniqMap--instance Monoid (UniqMap k a) where-    mempty = emptyUniqMap-    mappend = (Semi.<>)--instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where-    ppr (UniqMap m) =-        brackets $ fsep $ punctuate comma $-        [ ppr k <+> text "->" <+> ppr v-        | (k, v) <- eltsUFM m ]--liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a)-liftC f (_, v) (k', v') = (k', f v v')--emptyUniqMap :: UniqMap k a-emptyUniqMap = UniqMap emptyUFM--isNullUniqMap :: UniqMap k a -> Bool-isNullUniqMap (UniqMap m) = isNullUFM m--unitUniqMap :: Uniquable k => k -> a -> UniqMap k a-unitUniqMap k v = UniqMap (unitUFM k (k, v))--listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a-listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs])--listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a-listToUniqMap_C f kvs = UniqMap $-    listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs]--addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a-addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v)--addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a-addListToUniqMap (UniqMap m) kvs = UniqMap $-    addListToUFM m [(k,(k,v)) | (k,v) <- kvs]--addToUniqMap_C :: Uniquable k-               => (a -> a -> a)-               -> UniqMap k a-               -> k-               -> a-               -> UniqMap k a-addToUniqMap_C f (UniqMap m) k v = UniqMap $-    addToUFM_C (liftC f) m k (k, v)--addToUniqMap_Acc :: Uniquable k-                 => (b -> a -> a)-                 -> (b -> a)-                 -> UniqMap k a-                 -> k-                 -> b-                 -> UniqMap k a-addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $-    addToUFM_Acc (\b (k, v) -> (k, exi b v))-                 (\b -> (k0, new b))-                 m k0 v0--alterUniqMap :: Uniquable k-             => (Maybe a -> Maybe a)-             -> UniqMap k a-             -> k-             -> UniqMap k a-alterUniqMap f (UniqMap m) k = UniqMap $-    alterUFM (fmap (k,) . f . fmap snd) m k--addListToUniqMap_C-    :: Uniquable k-    => (a -> a -> a)-    -> UniqMap k a-    -> [(k, a)]-    -> UniqMap k a-addListToUniqMap_C f (UniqMap m) kvs = UniqMap $-    addListToUFM_C (liftC f) m-        [(k,(k,v)) | (k,v) <- kvs]--adjustUniqMap-    :: Uniquable k-    => (a -> a)-    -> UniqMap k a-    -> k-    -> UniqMap k a-adjustUniqMap f (UniqMap m) k = UniqMap $-    adjustUFM (\(_,v) -> (k,f v)) m k--delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a-delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k--delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a-delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks--plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a-plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2--plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a-plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $-    plusUFM_C (liftC f) m1 m2--plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a-plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $-    plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2--plusUniqMapList :: [UniqMap k a] -> UniqMap k a-plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs)--minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a-minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2--intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a-intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2--disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool-disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2--mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b-mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance--filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a-filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m--partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a)-partitionUniqMap f (UniqMap m) =-    coerce $ partitionUFM (f . snd) m--sizeUniqMap :: UniqMap k a -> Int-sizeUniqMap (UniqMap m) = sizeUFM m--elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool-elemUniqMap k (UniqMap m) = elemUFM k m--lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a-lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k)--lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a-lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k))--anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool-anyUniqMap f (UniqMap m) = anyUFM (f . snd) m--allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool-allUniqMap f (UniqMap m) = allUFM (f . snd) m
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20200301+version: 0.20200401 license: BSD3 license-file: LICENSE category: Development@@ -82,7 +82,7 @@         transformers == 0.5.*,         process >= 1 && < 1.7,         hpc == 0.6.*,-        ghc-lib-parser == 0.20200301+        ghc-lib-parser == 0.20200401     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:         BangPatterns@@ -121,13 +121,9 @@         ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build         libraries/template-haskell-        compiler/specialise-        compiler/profiling-        compiler/simplCore         compiler/typecheck         libraries/ghc-boot         compiler/prelude-        compiler/stranal         compiler/iface         compiler/utils         libraries/ghci@@ -137,47 +133,31 @@     autogen-modules:         Paths_ghc_lib     reexported-modules:-        Annotations,         ApiAnnotation,-        Avail,         Bag,-        BasicTypes,         BinFingerprint,         Binary,         BooleanFormula,         BufWrite,-        Class,         CliOption,-        CoAxiom,-        Coercion,-        ConLike,         Config,         Constants,         Constraint,-        CoreMonad,-        CostCentre,-        CostCentreState,-        Cpr,         Ctype,-        DataCon,-        Demand,         Digraph,         Encoding,         EnumSet,         ErrUtils,         Exception,         FV,-        FamInstEnv,         FastFunctions,         FastMutInt,         FastString,         FastStringEnv,-        FieldLabel,         FileCleanup,         FileSettings,         Fingerprint,         FiniteMap,-        ForeignCall,         GHC.BaseDir,         GHC.ByteCode.Types,         GHC.Cmm,@@ -194,21 +174,43 @@         GHC.Cmm.Type,         GHC.Core,         GHC.Core.Arity,+        GHC.Core.Class,+        GHC.Core.Coercion,+        GHC.Core.Coercion.Axiom,+        GHC.Core.Coercion.Opt,+        GHC.Core.ConLike,+        GHC.Core.DataCon,         GHC.Core.FVs,+        GHC.Core.FamInstEnv,+        GHC.Core.InstEnv,         GHC.Core.Make,         GHC.Core.Map,+        GHC.Core.Op.ConstantFold,+        GHC.Core.Op.Monad,+        GHC.Core.Op.OccurAnal,         GHC.Core.Op.Tidy,+        GHC.Core.PatSyn,         GHC.Core.Ppr,+        GHC.Core.Predicate,         GHC.Core.Rules,         GHC.Core.Seq,         GHC.Core.SimpleOpt,         GHC.Core.Stats,         GHC.Core.Subst,+        GHC.Core.TyCo.FVs,+        GHC.Core.TyCo.Ppr,+        GHC.Core.TyCo.Rep,+        GHC.Core.TyCo.Subst,+        GHC.Core.TyCo.Tidy,+        GHC.Core.TyCon,+        GHC.Core.Type,         GHC.Core.Unfold,+        GHC.Core.Unify,         GHC.Core.Utils,         GHC.CoreToIface,         GHC.Driver.Backpack.Syntax,         GHC.Driver.CmdLine,+        GHC.Driver.Flags,         GHC.Driver.Hooks,         GHC.Driver.Monad,         GHC.Driver.Packages,@@ -217,6 +219,7 @@         GHC.Driver.Plugins,         GHC.Driver.Session,         GHC.Driver.Types,+        GHC.Driver.Ways,         GHC.Exts.Heap,         GHC.Exts.Heap.ClosureTypes,         GHC.Exts.Heap.Closures,@@ -265,8 +268,39 @@         GHC.Runtime.Linker.Types,         GHC.Serialized,         GHC.Stg.Syntax,+        GHC.Types.Annotations,+        GHC.Types.Avail,+        GHC.Types.Basic,+        GHC.Types.CostCentre,+        GHC.Types.CostCentre.State,+        GHC.Types.Cpr,+        GHC.Types.Demand,+        GHC.Types.FieldLabel,+        GHC.Types.ForeignCall,+        GHC.Types.Id,+        GHC.Types.Id.Info,+        GHC.Types.Id.Make,+        GHC.Types.Literal,+        GHC.Types.Module,+        GHC.Types.Name,+        GHC.Types.Name.Cache,+        GHC.Types.Name.Env,+        GHC.Types.Name.Occurrence,+        GHC.Types.Name.Reader,+        GHC.Types.Name.Set,         GHC.Types.RepType,+        GHC.Types.SrcLoc,+        GHC.Types.Unique,+        GHC.Types.Unique.DFM,+        GHC.Types.Unique.DSet,+        GHC.Types.Unique.FM,+        GHC.Types.Unique.Set,+        GHC.Types.Unique.Supply,+        GHC.Types.Var,+        GHC.Types.Var.Env,+        GHC.Types.Var.Set,         GHC.UniqueSubdir,+        GHC.Utils.Lexeme,         GHC.Version,         GHCi.BreakArray,         GHCi.FFI,@@ -278,9 +312,6 @@         HaddockUtils,         HeaderInfo,         IOEnv,-        Id,-        IdInfo,-        InstEnv,         Json,         KnownUniques,         Language.Haskell.TH,@@ -291,40 +322,24 @@         Language.Haskell.TH.Ppr,         Language.Haskell.TH.PprLib,         Language.Haskell.TH.Syntax,-        Lexeme,         Lexer,         ListSetOps,-        Literal,         Maybes,-        MkId,-        Module,         MonadUtils,-        Name,-        NameCache,-        NameEnv,-        NameSet,-        OccName,-        OccurAnal,-        OptCoercion,         OrdList,         Outputable,         Pair,         Panic,         Parser,-        PatSyn,         PlainPanic,         PlatformConstants,         PprColour,-        Predicate,         PrelNames,-        PrelRules,         Pretty,         PrimOp,         RdrHsSyn,-        RdrName,         Settings,         SizedSeq,-        SrcLoc,         Stream,         StringBuffer,         SysTools.BaseDir,@@ -336,43 +351,19 @@         TcType,         ToolSettings,         TrieMap,-        TyCoFVs,-        TyCoPpr,-        TyCoRep,-        TyCoSubst,-        TyCoTidy,-        TyCon,-        Type,         TysPrim,         TysWiredIn,-        Unify,-        UniqDFM,-        UniqDSet,-        UniqFM,-        UniqSet,-        UniqSupply,-        Unique,         UnitInfo,-        Util,-        Var,-        VarEnv,-        VarSet+        Util     exposed-modules:         Paths_ghc_lib         Ar         AsmUtils         BuildTyCl-        CSE-        CallArity         ClsInst-        CprAnal-        DmdAnal         Elf-        Exitify         FamInst         FlagChecker-        FloatIn-        FloatOut         FunDeps         GHC         GHC.ByteCode.Asm@@ -407,6 +398,7 @@         GHC.CmmToAsm.CFG         GHC.CmmToAsm.CFG.Dominators         GHC.CmmToAsm.CPrim+        GHC.CmmToAsm.Config         GHC.CmmToAsm.Dwarf         GHC.CmmToAsm.Dwarf.Constants         GHC.CmmToAsm.Dwarf.Types@@ -475,6 +467,25 @@         GHC.CmmToLlvm.Ppr         GHC.CmmToLlvm.Regs         GHC.Core.Lint+        GHC.Core.Op.CSE+        GHC.Core.Op.CallArity+        GHC.Core.Op.CprAnal+        GHC.Core.Op.DmdAnal+        GHC.Core.Op.Exitify+        GHC.Core.Op.FloatIn+        GHC.Core.Op.FloatOut+        GHC.Core.Op.LiberateCase+        GHC.Core.Op.SetLevels+        GHC.Core.Op.Simplify+        GHC.Core.Op.Simplify.Driver+        GHC.Core.Op.Simplify.Env+        GHC.Core.Op.Simplify.Monad+        GHC.Core.Op.Simplify.Utils+        GHC.Core.Op.SpecConstr+        GHC.Core.Op.Specialise+        GHC.Core.Op.StaticArgs+        GHC.Core.Op.WorkWrap+        GHC.Core.Op.WorkWrap.Lib         GHC.Core.Ppr.TyThing         GHC.CoreToByteCode         GHC.CoreToStg@@ -516,9 +527,10 @@         GHC.Iface.Ext.Types         GHC.Iface.Ext.Utils         GHC.Iface.Load+        GHC.Iface.Make+        GHC.Iface.Recomp         GHC.Iface.Rename         GHC.Iface.Tidy-        GHC.Iface.Utils         GHC.IfaceToCore         GHC.Llvm         GHC.Llvm.MetaData@@ -593,18 +605,7 @@         HscStats         Inst         Language.Haskell.TH.Quote-        LiberateCase         PrelInfo-        ProfInit-        SAT-        SetLevels-        SimplCore-        SimplEnv-        SimplMonad-        SimplUtils-        Simplify-        SpecConstr-        Specialise         State         StaticPtrTable         SysTools@@ -658,7 +659,4 @@         TcUnify         TcValidity         UnVarGraph-        UniqMap         UpdateCafInfos-        WorkWrap-        WwLib
ghc-lib/stage0/lib/GHCConstantsHaskellExports.hs view
@@ -111,7 +111,6 @@     rESERVED_STACK_WORDS,     aP_STACK_SPLIM,     wORD_SIZE,-    dOUBLE_SIZE,     cINT_SIZE,     cLONG_SIZE,     cLONG_LONG_SIZE,
ghc-lib/stage0/lib/GHCConstantsHaskellType.hs view
@@ -118,7 +118,6 @@       pc_RESERVED_STACK_WORDS :: Int,       pc_AP_STACK_SPLIM :: Int,       pc_WORD_SIZE :: Int,-      pc_DOUBLE_SIZE :: Int,       pc_CINT_SIZE :: Int,       pc_CLONG_SIZE :: Int,       pc_CLONG_LONG_SIZE :: Int,
ghc-lib/stage0/lib/GHCConstantsHaskellWrappers.hs view
@@ -224,8 +224,6 @@ aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (platformConstants dflags) wORD_SIZE :: DynFlags -> Int wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags)-dOUBLE_SIZE :: DynFlags -> Int-dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (platformConstants dflags) cINT_SIZE :: DynFlags -> Int cINT_SIZE dflags = pc_CINT_SIZE (platformConstants dflags) cLONG_SIZE :: DynFlags -> Int
ghc-lib/stage0/lib/ghcversion.h view
@@ -6,7 +6,7 @@ #endif  #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200229+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200331  #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/platformConstants view
@@ -118,7 +118,6 @@       pc_RESERVED_STACK_WORDS = 21,       pc_AP_STACK_SPLIM = 1024,       pc_WORD_SIZE = 8,-      pc_DOUBLE_SIZE = 8,       pc_CINT_SIZE = 4,       pc_CLONG_SIZE = 8,       pc_CLONG_LONG_SIZE = 8,
includes/MachDeps.h view
@@ -32,9 +32,7 @@  *  * To get target's values it is preferred to use runtime target  * configuration from 'targetPlatform :: DynFlags -> Platform'- * record. A few wrappers are already defined and used throughout GHC:- *    wORD_SIZE :: DynFlags -> Int- *    wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags)+ * record.  *  * Hence we hide these macros from GHC_STAGE=1  */
libraries/ghci/GHCi/InfoTable.hsc view
@@ -13,27 +13,23 @@     mkConInfoTable   ) where -import Prelude -- See note [Why do we import Prelude here?]+import Prelude hiding (fail) -- See note [Why do we import Prelude here?]+ import Foreign import Foreign.C import GHC.Ptr import GHC.Exts import GHC.Exts.Heap import Data.ByteString (ByteString)+import Control.Monad.Fail import qualified Data.ByteString as BS -ghciTablesNextToCode :: Bool-#if defined(TABLES_NEXT_TO_CODE)-ghciTablesNextToCode = True-#else-ghciTablesNextToCode = False-#endif- -- NOTE: Must return a pointer acceptable for use in the header of a closure. -- If tables_next_to_code is enabled, then it must point the the 'code' field. -- Otherwise, it should point to the start of the StgInfoTable. mkConInfoTable-   :: Int     -- ptr words+   :: Bool    -- TABLES_NEXT_TO_CODE+   -> Int     -- ptr words    -> Int     -- non-ptr words    -> Int     -- constr tag    -> Int     -- pointer tag@@ -42,23 +38,23 @@       -- resulting info table is allocated with allocateExec(), and       -- should be freed with freeExec(). -mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc =-  castFunPtrToPtr <$> newExecConItbl itbl con_desc-  where-     entry_addr = interpConstrEntry !! ptrtag-     code' = mkJumpToAddr entry_addr+mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do+  let entry_addr = interpConstrEntry !! ptrtag+  code' <- if tables_next_to_code+    then Just <$> mkJumpToAddr entry_addr+    else pure Nothing+  let      itbl  = StgInfoTable {-                 entry = if ghciTablesNextToCode+                 entry = if tables_next_to_code                          then Nothing                          else Just entry_addr,                  ptrs  = fromIntegral ptr_words,                  nptrs = fromIntegral nonptr_words,                  tipe  = CONSTR,                  srtlen = fromIntegral tag,-                 code  = if ghciTablesNextToCode-                         then Just code'-                         else Nothing+                 code  = code'               }+  castFunPtrToPtr <$> newExecConItbl tables_next_to_code itbl con_desc   -- -----------------------------------------------------------------------------@@ -77,41 +73,48 @@           | ArchPPC64           | ArchPPC64LE           | ArchS390X-          | ArchUnknown  deriving Show -platform :: Arch-platform =+mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes+mkJumpToAddr ptr = do+  arch <- case mArch of+    Just a -> pure a+    Nothing ->+      -- This code must not be called. You either need to add your+      -- architecture as a distinct case to 'Arch' and 'mArch', or use+      -- non-TABLES_NEXT_TO_CODE mode.+      fail "mkJumpToAddr: Unknown obscure arch is not supported with TABLES_NEXT_TO_CODE"+  pure $ mkJumpToAddr' arch ptr++-- | 'Just' if it's a known OS, or 'Nothing' otherwise.+mArch :: Maybe Arch+mArch = #if defined(sparc_HOST_ARCH)-       ArchSPARC+       Just ArchSPARC #elif defined(powerpc_HOST_ARCH)-       ArchPPC+       Just ArchPPC #elif defined(i386_HOST_ARCH)-       ArchX86+       Just ArchX86 #elif defined(x86_64_HOST_ARCH)-       ArchX86_64+       Just ArchX86_64 #elif defined(alpha_HOST_ARCH)-       ArchAlpha+       Just ArchAlpha #elif defined(arm_HOST_ARCH)-       ArchARM+       Just ArchARM #elif defined(aarch64_HOST_ARCH)-       ArchARM64+       Just ArchARM64 #elif defined(powerpc64_HOST_ARCH)-       ArchPPC64+       Just ArchPPC64 #elif defined(powerpc64le_HOST_ARCH)-       ArchPPC64LE+       Just ArchPPC64LE #elif defined(s390x_HOST_ARCH)-       ArchS390X+       Just ArchS390X #else-#    if defined(TABLES_NEXT_TO_CODE)-#        error Unimplemented architecture-#    else-       ArchUnknown-#    endif+       Nothing #endif -mkJumpToAddr :: EntryFunPtr -> ItblCodes-mkJumpToAddr a = case platform of+mkJumpToAddr' :: Arch -> EntryFunPtr -> ItblCodes+mkJumpToAddr' platform a = case platform of     ArchSPARC ->         -- After some consideration, we'll try this, where         -- 0x55555555 stands in for the address to jump to.@@ -285,11 +288,6 @@                   0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,                   0x07, 0xF1 ] -    -- This code must not be called. You either need to-    -- add your architecture as a distinct case or-    -- use non-TABLES_NEXT_TO_CODE mode-    ArchUnknown -> error "mkJumpToAddr: ArchUnknown is unsupported"- byte0 :: (Integral w) => w -> Word8 byte0 w = fromIntegral w @@ -333,38 +331,40 @@   pokeConItbl-  :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable+  :: Bool -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable   -> IO ()-pokeConItbl wr_ptr _ex_ptr itbl = do-#if defined(TABLES_NEXT_TO_CODE)-  -- Write the offset to the con_desc from the end of the standard InfoTable-  -- at the first byte.-  let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)-  (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset-#else-  -- Write the con_desc address after the end of the info table.-  -- Use itblSize because CPP will not pick up PROFILING when calculating-  -- the offset.-  pokeByteOff wr_ptr itblSize (conDesc itbl)-#endif+pokeConItbl tables_next_to_code wr_ptr _ex_ptr itbl = do+  if tables_next_to_code+    then do+      -- Write the offset to the con_desc from the end of the standard InfoTable+      -- at the first byte.+      let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)+      (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset+    else do+      -- Write the con_desc address after the end of the info table.+      -- Use itblSize because CPP will not pick up PROFILING when calculating+      -- the offset.+      pokeByteOff wr_ptr itblSize (conDesc itbl)   pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl) -sizeOfEntryCode :: Int-sizeOfEntryCode-  | not ghciTablesNextToCode = 0-  | otherwise =-     case mkJumpToAddr undefined of+sizeOfEntryCode :: MonadFail m => Bool -> m Int+sizeOfEntryCode tables_next_to_code+  | not tables_next_to_code = pure 0+  | otherwise = do+     code' <- mkJumpToAddr undefined+     pure $ case code' of        Left  xs -> sizeOf (head xs) * length xs        Right xs -> sizeOf (head xs) * length xs  -- Note: Must return proper pointer for use in a closure-newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ())-newExecConItbl obj con_desc+newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())+newExecConItbl tables_next_to_code obj con_desc    = alloca $ \pcode -> do+        sz0 <- sizeOfEntryCode tables_next_to_code         let lcon_desc = BS.length con_desc + 1{- null terminator -}             -- SCARY             -- This size represents the number of bytes in an StgConInfoTable.-            sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode)+            sz = fromIntegral $ conInfoTableSizeB + sz0                -- Note: we need to allocate the conDesc string next to the info                -- table, because on a 64-bit platform we reference this string                -- with a 32-bit offset relative to the info table, so if we@@ -373,17 +373,15 @@         ex_ptr <- peek pcode         let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz                                     , infoTable = obj }-        pokeConItbl wr_ptr ex_ptr cinfo+        pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo         BS.useAsCStringLen con_desc $ \(src, len) ->             copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len         let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)         poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)         _flushExec sz ex_ptr -- Cache flush (if needed)-#if defined(TABLES_NEXT_TO_CODE)-        return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))-#else-        return (castPtrToFunPtr ex_ptr)-#endif+        pure $ if tables_next_to_code+          then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB+          else castPtrToFunPtr ex_ptr  foreign import ccall unsafe "allocateExec"   _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
libraries/ghci/GHCi/Run.hs view
@@ -89,13 +89,14 @@   MallocStrings bss -> mapM mkString0 bss   PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res   FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)-  MkConInfoTable ptrs nptrs tag ptrtag desc ->-    toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc+  MkConInfoTable tc ptrs nptrs tag ptrtag desc ->+    toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc   StartTH -> startTH   GetClosure ref -> do     clos <- getClosureData =<< localRef ref     mapM (\(Box x) -> mkRemoteRef (HValue x)) clos-  Seq ref -> tryEval (void $ evaluate =<< localRef ref)+  Seq ref -> doSeq ref+  ResumeSeq ref -> resumeSeq ref   _other -> error "GHCi.Run.run"  evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])@@ -129,6 +130,37 @@   tryEval $ do     r <- (unsafeCoerce io :: String -> IO String) str     evaluate (force r)++-- | Process the Seq message to force a value.                       #2950+-- If during this processing a breakpoint is hit, return+-- an EvalBreak value in the EvalStatus to the UI process,+-- otherwise return an EvalComplete.+-- The UI process has more and therefore also can show more+-- information about the breakpoint than the current iserv+-- process.+doSeq :: RemoteRef a -> IO (EvalStatus ())+doSeq ref = do+    sandboxIO evalOptsSeq $ do+      _ <- (void $ evaluate =<< localRef ref)+      return ()++-- | Process a ResumeSeq message. Continue the :force processing     #2950+-- after a breakpoint.+resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())+resumeSeq hvref = do+    ResumeContext{..} <- localRef hvref+    withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar $+      mask_ $ do+        putMVar resumeBreakMVar () -- this awakens the stopped thread...+        redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar++evalOptsSeq :: EvalOpts+evalOptsSeq = EvalOpts+              { useSandboxThread = True+              , singleStep = False+              , breakOnException = False+              , breakOnError = False+              }  -- When running a computation, we redirect ^C exceptions to the running -- thread.  ToDo: we might want a way to continue even if the target
libraries/ghci/GHCi/TH.hs view
@@ -97,7 +97,6 @@ import GHC.Serialized  import Control.Exception-import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO (..)) import Data.Binary import Data.Binary.Put@@ -144,11 +143,8 @@     do (m', s')  <- runGHCiQ m s        (a,  s'') <- runGHCiQ (f m') s'        return (a, s'')-#if !MIN_VERSION_base(4,13,0)-  fail = Fail.fail-#endif -instance Fail.MonadFail GHCiQ where+instance MonadFail GHCiQ where   fail err  = GHCiQ $ \s -> throwIO (GHCiQException s err)  getState :: GHCiQ QState