+      CmmSwitch arg ids -> genSwitch arg ids bid

+Note [Jump tables]

+~~~~~~~~~~~~~~~~~~

+The x86 backend has a virtual JMP_TBL instruction which payload can be used to

+generate both the jump instruction and the jump table contents. `genSwitch` is

+responsible for generating these JMP_TBL instructions.

+

+Depending on `-fPIC` flag and on the architecture, we generate the following

+jump table variants:

+

+  | Variant |  Arch  | Table's contents                       | Reference to the table |

+  |---------|--------|----------------------------------------|------------------------|

+  |     PIC |  Both  | Relative offset: target_lbl - base_lbl | PIC                    |

+  | Non-PIC | 64-bit | Absolute: target_lbl                   | Non-PIC (rip-relative) |

+  | Non-PIC | 32-bit | Absolute: target_lbl                   | Non-PIC (absolute)     |

+

+For the PIC variant, we store relative entries (`target_lbl - base_lbl`) in the

+jump table. Using absolute entries with PIC would require target_lbl symbols to

+be resolved at link time, hence to be global labels (currently they are local

+labels).

+

+We use the block_id of the code containing the jump as `base_lbl`. It ensures

+that target_lbl and base_lbl are close enough to each others, avoiding

+overflows.

+

+Historical note: in the past we used the table label `table_lbl` as base_lbl. It

+allowed the jumping code to only compute one global address (table_lbl) both to

+read the table and to compute the target address. However:

+ * the table could be too far from the jump and on Windows which only

+   has 32-bit relative relocations (IMAGE_REL_AMD64_REL64 doesn't exist),

+   `dest_lbl - table_lbl` overflowed (see #24016)

+

+ * Mac OS X/x86-64 linker was unable to handle `.quad L1 - L0`

+   relocations if L0 wasn't preceded by a non-anonymous label in its

+   section (which was the case with table_lbl). Hence we used to put the

+   jump table in the .text section in this case.

+

+

+-}

+

+-- | Generate a JMP_TBL instruction

+--

+-- See Note [Jump tables]

+genSwitch :: CmmExpr -> SwitchTargets -> BlockId -> NatM InstrBlock

+genSwitch expr targets bid = do

+

+      (offset, blockIds) = switchTargetsToTable targets

+      ids = map (fmap DestBlockId) blockIds

+

+      is32bit = target32Bit platform

+      fmt = archWordFormat is32bit

+

+  table_lbl <- getNewLabelNat

+  let bid_lbl = blockLbl bid

+  let table_section = Section ReadOnlyData table_lbl

+

+  -- see Note [Jump tables] for a description of the following 3 variants.

+  if

+    | ncgPIC config -> do

+      -- PIC support: store relative offsets in the jump table to allow the code

+      -- to be relocated without updating the table. The table itself and the

+      -- block label used to make the relative labels absolute are read in a PIC

+      -- way (via cmmMakeDynamicReference).

+      (reg,e_code) <- getNonClobberedReg indexExpr -- getNonClobberedReg because it needs to survive across t_code and j_code

+      (tableReg,t_code) <- getNonClobberedReg =<< cmmMakeDynamicReference config DataReference table_lbl

+      (targetReg,j_code) <- getSomeReg =<< cmmMakeDynamicReference config DataReference bid_lbl

+      pure $ e_code `appOL` t_code `appOL` j_code `appOL` toOL

+            [ ADD fmt (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)))

+                      (OpReg targetReg)

+            , JMP_TBL (OpReg targetReg) ids table_section table_lbl (Just bid_lbl)

+            ]

+

+    | not is32bit -> do

+      -- 64-bit non-PIC code

+      (reg,e_code) <- getSomeReg indexExpr

+      tableReg <- getNewRegNat (intFormat (platformWordWidth platform))

+      targetReg <- getNewRegNat (intFormat (platformWordWidth platform))

+      pure $ e_code `appOL` toOL

+            [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl table_lbl))) (OpReg tableReg)

+            , MOV fmt (OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)))

+                      (OpReg targetReg)

+            , JMP_TBL (OpReg targetReg) ids table_section table_lbl Nothing

+            ]

+

+    | otherwise -> do

+      -- 32-bit non-PIC code is a straightforward jump to &table[entry].

+      (reg,e_code) <- getSomeReg indexExpr

+      pure $ e_code `appOL` unitOL

+            ( JMP_TBL (OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl table_lbl)))

+                      ids table_section table_lbl Nothing

+            )

+generateJumpTableForInstr config = \case

+  JMP_TBL _ ids section table_lbl mrel_lbl ->

+    let getBlockId (DestBlockId id) = id

+        getBlockId _ = panic "Non-Label target in Jump Table"

+        block_ids = map (fmap getBlockId) ids

+

+        jumpTable = case mrel_lbl of

+          Nothing      -> map mk_absolute block_ids           -- absolute entries

+          Just rel_lbl -> map (mk_relative rel_lbl) block_ids -- offsets relative to rel_lbl

+

+        mk_absolute = \case

+          Nothing      -> CmmStaticLit (CmmInt 0 (ncgWordWidth config))

+          Just blockid -> CmmStaticLit (CmmLabel (blockLbl blockid))

+

+        mk_relative rel_lbl = \case

+          Nothing      -> CmmStaticLit (CmmInt 0 (ncgWordWidth config))

+          Just blockid -> CmmStaticLit (CmmLabelDiffOff (blockLbl blockid) rel_lbl 0 (ncgWordWidth config))

+

+    in Just (CmmData section (mkAlignment 1, CmmStaticsRaw table_lbl jumpTable))

+

+  _ -> Nothing

+                      !(Maybe CLabel) -- Label used to compute relative offsets. Otherwise we store absolute addresses.

+    JMP_TBL op _ _ _ _  -> mkRU (use_R addrFmt op []) []

+    JMP_TBL op ids s tl jl -> JMP_TBL (patchOp op) ids s tl jl

+    JXX _ target            -> bid == target

+    JMP_TBL _ targets _ _ _ -> all isTargetBid targets

+    _                       -> False

+        JXX _ id            -> [id]

+        JMP_TBL _ ids _ _ _ -> [id | Just (DestBlockId id) <- ids]

+        _                   -> []

+        JMP_TBL op ids section table_lbl rel_lbl

+          -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section table_lbl rel_lbl

+    shortcutJump' fn _ (JMP_TBL addr blocks section table_lbl rel_lbl) =

+        in  JMP_TBL addr blocks' section table_lbl rel_lbl

+   JMP_TBL op _ _ _ _

+    :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)

+pushCoercionIntoLambda in_scope x e co

+          in_scope' = in_scope `extendInScopeSet` x'

+            extendIdSubst (setInScope emptySubst in_scope')

+    -- See Note [Eliminate casts in function position]

+    do_beta env e@(Lam b _) as@(CastIt out_co:rest)

+      -- Optimise the inner lambda to make it an 'OutExpr', which makes it

+      -- possible to call 'pushCoercionIntoLambda' with the 'OutCoercion' 'co'.

+      -- This is kind of horrible, as for nested casted lambdas with a big body,

+      -- we will repeatedly optimise the body (once for each binder). However,

+      -- we need to do this to avoid mixing 'InExpr' and 'OutExpr', or two

+      -- 'InExpr' with different environments (getting this wrong caused #26588 & #26589.)

+      , Lam out_b out_body <- simple_app env e []

+      , Just (b', body') <- pushCoercionIntoLambda (soeInScope env) out_b out_body out_co

+        -- soeZapSubst: we've already optimised everything (the lambda and 'rest') by now.

+representation-polymorphism invariants). See Note [Eliminate casts in function position].

+

+[Alternative approach] (GHC ticket #26608)

+

+  We could instead, in the typechecker, emit a special form (a new constructor

+  of XXExprGhcTc) for instantiations of representation-polymorphic unlifted

+  newtypes (whether applied to a value argument or not):

+

+    UnliftedNT :: DataCon -> [Type] -> Coercion -> XXExprGhcTc

+

+  where "UnliftedNT nt_con [ty1, ...] co" represents the expression:

+

+    ( nt_con @ty1 ... ) |> co

+

+  The desugarer would then turn these AST nodes into appropriate Core, doing

+  what the simple optimiser does today:

+    - inline the compulsory unfolding of the newtype constructor

+    - apply it to its type arguments and beta reduce

+    - push the coercion into the resulting lambda

+

+  This would have several advantages:

+    - the desugarer would never produce "invalid" Core that needs to be

+      tidied up by the simple optimiser,

+    - the ugly and inefficient implementation described in

+      Note [Eliminate casts in function position] could be removed.

+Due to the current implementation strategy for representation-polymorphic

+unlifted newtypes, as described in Note [Desugaring unlifted newtypes], we rely

+on the simple optimiser to push coercions into lambdas, such as in the following

+example:

+  type family R a where { R Int = IntRep }

+  type F :: forall a -> TYPE (R a)

+  type family F a where { F Int = Int# }

+Now, an instantiated occurrence of 'MkN', such as 'MkN @Int' (whether applied

+to a value argument or not) will lead, after inlining the compulsory unfolding

+of 'MkN', to a lambda fo the form:

+  ( \ ( x :: F Int ) -> body ) |> co

+    where

+      co :: ( F Int -> res ) ~# ( Int# -> res )

+The problem is that we now have a lambda abstraction whose binder does not have a

+fixed RuntimeRep in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.

+However, if we use 'pushCoercionIntoLambda', we end up with:

+  ( \ ( x' :: Int# ) -> body' )

+which satisfies the representation-polymorphism invariants of

+Note [Representation polymorphism invariants] in GHC.Core.

+In conclusion:

+  1. The simple optimiser must push casts into lambdas.

+  2. It must also deal with a situation such as (MkN @Int) |> co, where we first

+     inline the compulsory unfolding of N. This means the simple optimiser must

+     "peel off" the casts and optimise the inner expression first, to determine

+     whether it is a lambda abstraction or not.

+This is regrettably delicate. If we could make sure the typechecker/desugarer

+did not produce these bad lambdas in the first place (as described in

+[Alternative approach] in Note [Desugaring unlifted newtypes]), we could

+get rid of this ugly logic.

+    , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co

+    , ([1,2],   Opt_PolymorphicSpecialisation)  -- Now on by default (#23559)

+   , Opt_PolymorphicSpecialisation

+       , [Scaled _ orig_arg_ty] <- dataConOrigArgTys dc

+       , not $ typeHasFixedRuntimeRep orig_arg_ty

+  g4 ::  Int -> forall x. (Show x, Eq x) => x -> x

+not necessarily all) of them can be the class parameters. Each class

+    Generate position-independent code (PIC). This code can be put into shared

+    libraries and is sometimes required by operating systems, e.g. systems using

+    Address Space Layout Randomization (ASLR).

+    executable. To link the final executable use :ghc-flag:`-pie`.

+    :default: on

+    flushEventLog(NULL);

+    // N.B. Don't flush if shutting down: this was done in

+    // finishCapEventLogging and the capabilities have already been freed.

+    // This can also race against the shutdown if the flush is triggered by the

+    // ticker thread. (#26573)

+    if (getSchedState() == SCHED_SHUTTING_DOWN) {

+      return;

+    }

+

+    Task *task = newBoundTask();

+    exitMyTask();

+    // dll_name might be deallocated, we need to copy it to have a stable reference to the contents

+    // See #26613

+    size_t size = wcslen(dll_name) + 1;

+    pathchar* dll_name_copy = stgMallocBytes(size * sizeof(pathchar), "addLoadedDll");

+    wcsncpy(dll_name_copy, dll_name, size);

+    insertHashTable_(cache->hash, (StgWord) dll_name_copy, instance, hash_path);

+module Main (main) where

+

+data Command

+  = Command1

+  | Command2

+  | Command3

+  | Command4

+  | Command5

+  | Command6 -- Commenting this line works with -fPIC, uncommenting leads to a crash.

+

+main :: IO ()

+main = do

+  let x = case cmd of

+           Command1 -> 1 :: Int

+           Command2 -> 2

+           Command3 -> 3

+           Command4 -> 4

+           Command5 -> 5

+           Command6 -> 6

+  putStrLn (show x)

+

+{-# NOINLINE cmd #-}

+cmd :: Command

+cmd = Command6

+6

+test('T24016', normal, compile_and_run, ['-O1 -fPIC'])

+test('numeric_version_eventlog_flush',

+     [ignore_stdout, req_ghc_with_threaded_rts],

+     run_command,

+     ['{compiler} --numeric-version +RTS -l --eventlog-flush-interval=1 -RTS'])

+

+module T26588 ( getOptionSettingFromText ) where

+

+import           Control.Applicative ( Const(..) )

+import           Data.Map (Map)

+import qualified Data.Map.Strict as Map

+

+------------------------------------------------------------------------

+-- ConfigState

+

+data ConfigLeaf

+data ConfigTrie = ConfigTrie !(Maybe ConfigLeaf) !ConfigMap

+

+type ConfigMap = Map Int ConfigTrie

+

+freshLeaf :: [Int] -> ConfigLeaf -> ConfigTrie

+freshLeaf [] l     = ConfigTrie (Just l) mempty

+freshLeaf (a:as) l = ConfigTrie Nothing (Map.singleton a (freshLeaf as l))

+

+adjustConfigTrie :: Functor t => [Int] -> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf)) -> Maybe (ConfigTrie) -> t (Maybe ConfigTrie)

+adjustConfigTrie     as f Nothing                 = fmap (freshLeaf as) <$> f Nothing

+adjustConfigTrie (a:as) f (Just (ConfigTrie x m)) = Just . ConfigTrie x <$> adjustConfigMap a as f m

+adjustConfigTrie     [] f (Just (ConfigTrie x m)) = g <$> f x

+  where g Nothing | Map.null m = Nothing

+        g x' = Just (ConfigTrie x' m)

+

+adjustConfigMap :: Functor t => Int -> [Int] -> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf)) -> ConfigMap -> t ConfigMap

+adjustConfigMap a as f = Map.alterF (adjustConfigTrie as f) a

+