-                                        mkInScopeSetBndrs binds

-                                      --    mkInScopeSetList $

-                                      --  bindersOfBinds binds

-      = do { -- debugTraceMsg (text "specImport {" <+> ppr cis)

-           ; -- debugTraceMsg (text "specImport }" <+> ppr cis)

-  = return (env, [], [])  -- 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

-  = return (env, [], [])

-  = do { tryWarnMissingSpecs dflags callers fn good_calls

-       ; let (free_uds, dump_dbs, float_all) = dumpBindUDs [fn4] body_uds1

-             can_float_this_one = exprIsTopLevelBindable rhs (idType fn)

-             -- exprIsTopLevelBindable: see Note [Care with unlifted bindings]

-       ; if float_all && can_float_this_one then

-       ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs1 uds3

-    in_scope  = Core.substInScopeSet subst

-    not_in_scope :: InterestingVarFun

-    not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope)

-

-             -- Find qvars, the type variables to add to the binders for the rule

-             -- Namely those free in `ty` that aren't in scope

-             -- See (MP2) in Note [Specialising polymorphic dictionaries]

-           ; let poly_qvars = scopedSort $ fvVarList $ specArgsFVs not_in_scope call_args

-                 subst'     = subst `Core.extendSubstInScopeList` poly_qvars

-                              -- Maybe we should clone the poly_qvars telescope?

-

-             -- Any free Ids will have caused the call to be dropped

-           ; massertPpr (all isTyCoVar poly_qvars)

-                        (ppr fn $$ ppr all_call_args $$ ppr poly_qvars)

-

-           ; (useful, subst'', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args)

-                 <- specHeader subst' rhs_bndrs all_call_args

-           ; let all_rule_bndrs = poly_qvars ++ rule_bndrs

-                 env' = env { se_subst = subst'' }

-                 already_covered = alreadyCovered env' all_rule_bndrs fn

-{-         ; pprTrace "spec_call" (vcat

-                [ text "fun:       "  <+> ppr fn

-                , text "call info: "  <+> ppr _ci

-                , text "useful:    "  <+> ppr useful

-                , text "already_covered:"  <+> ppr already_covered

-                , text "poly_qvars: " <+> ppr poly_qvars

-                , text "useful:    "  <+> ppr useful

-                , text "all_rule_bndrs:"  <+> ppr all_rule_bndrs

-                , text "rule_lhs_args:"  <+> ppr rule_lhs_args

-                , text "spec_bndrs:" <+> ppr spec_bndrs

-                , text "dx_binds:"   <+> ppr dx_binds

-                , text "spec_args: "  <+> ppr spec_args

-                , text "rhs_bndrs"    <+> ppr rhs_bndrs

-                , text "rhs_body"     <+> ppr rhs_body

-                , text "subst''" <+> ppr subst'' ]) $

-             return ()

--}

-{-         ; pprTrace "spec_call2" (vcat

-                 [ text "fun:" <+> ppr fn

-                 , text "rhs_body':" <+> ppr rhs_body' ]) $

-             return ()

--}

-

-                 (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds

-                 (rhs_uds2, outer_dumped_dbs) = dumpUDs poly_qvars (dx_binds `consDictBinds` rhs_uds1)

-                 -- dx_binds comes from the arguments to the call, and so can mention

-                 -- poly_qvars but no other local binders

-                 spec_rhs = mkLams poly_qvars               $

-                            wrapDictBindsE outer_dumped_dbs $

-                            mkLams spec_rhs_bndrs           $

-                 rule_rhs_args = poly_qvars ++ spec_bndrs

-                                    herald fn all_rule_bndrs rule_lhs_args

-           ; -- pprTrace "spec_call: rule" _rule_trace_doc

-             return ( spec_rule            : rules_acc

-  = do { let subst1 = Core.extendTvSubst subst bndr ty

-       ; (useful, subst2, rule_bs, rule_args, spec_bs, dx, spec_args)

-             <- specHeader subst1 bndrs args

-       ; pure ( useful, subst2

-              , rule_bs,     Type ty : rule_args

-              , spec_bs, dx, Type ty : spec_args ) }

-  = -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $

-    = text "CI" <> braces (sep (map ppr key))

--- Used at a lambda or case binder; just dump anything mentioning the binder

-                 --    [ text "bndrs" <+> ppr bndrs

-                 --    , text "uds" <+> ppr uds

-                 --    , text "free_uds" <+> ppr free_uds

-                 --    , text "dump-dbs" <+> ppr dump_dbs ]) $

-    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, OrdList DictBind, Bool)

--- 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 $$ ppr float_all) $

-    (free_uds, dump_dbs, float_all)

-    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }

-    free_calls = deleteCallsFor bndrs orig_calls

-    float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls

-               replicate (length theta) topDmd ++ map mk_dmd arg_ibangs

-               -- the strictness signature (#14290).

-import System.IO.Unsafe         ( unsafeInterleaveIO )

-  w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix)

-putWord16 h w = putPrim h 2 (\op -> do

-  pokeElemOff op 0 (fromIntegral (w `shiftR` 8))

-  pokeElemOff op 1 (fromIntegral (w .&. 0xFF))

-  )

-getWord16 h = getPrim h 2 (\op -> do

-  w0 <- fromIntegral <$> peekElemOff op 0

-  w1 <- fromIntegral <$> peekElemOff op 1

-  return $! w0 `shiftL` 8 .|. w1

-  )

-putWord32 h w = putPrim h 4 (\op -> do

-  pokeElemOff op 0 (fromIntegral (w `shiftR` 24))

-  pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))

-  pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF))

-  pokeElemOff op 3 (fromIntegral (w .&. 0xFF))

-  )

-getWord32 h = getPrim h 4 (\op -> do

-  w0 <- fromIntegral <$> peekElemOff op 0

-  w1 <- fromIntegral <$> peekElemOff op 1

-  w2 <- fromIntegral <$> peekElemOff op 2

-  w3 <- fromIntegral <$> peekElemOff op 3

-

-  return $! (w0 `shiftL` 24) .|.

-            (w1 `shiftL` 16) .|.

-            (w2 `shiftL` 8)  .|.

-            w3

-  )

-putWord64 h w = putPrim h 8 (\op -> do

-  pokeElemOff op 0 (fromIntegral (w `shiftR` 56))

-  pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))

-  pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF))

-  pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF))

-  pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF))

-  pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF))

-  pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF))

-  pokeElemOff op 7 (fromIntegral (w .&. 0xFF))

-  )

-getWord64 h = getPrim h 8 (\op -> do

-  w0 <- fromIntegral <$> peekElemOff op 0

-  w1 <- fromIntegral <$> peekElemOff op 1

-  w2 <- fromIntegral <$> peekElemOff op 2

-  w3 <- fromIntegral <$> peekElemOff op 3

-  w4 <- fromIntegral <$> peekElemOff op 4

-  w5 <- fromIntegral <$> peekElemOff op 5

-  w6 <- fromIntegral <$> peekElemOff op 6

-  w7 <- fromIntegral <$> peekElemOff op 7

-

-  return $! (w0 `shiftL` 56) .|.

-            (w1 `shiftL` 48) .|.

-            (w2 `shiftL` 40) .|.

-            (w3 `shiftL` 32) .|.

-            (w4 `shiftL` 24) .|.

-            (w5 `shiftL` 16) .|.

-            (w6 `shiftL` 8)  .|.

-            w7

-  )

-threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ())

-      m <- Sync.newTVarIO False

-        Sync.atomically $ Sync.writeTVar m True

-      let waitAction = do b <- Sync.readTVar m

-threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ())

-      m <- Sync.newTVarIO False

-        Sync.atomically $ Sync.writeTVar m True

-      let waitAction = do b <- Sync.readTVar m

-        -- * TVars

-        , STM(..)

-        , atomically

-        , retry

-        , orElse

-        , throwSTM

-        , catchSTM

-        , TVar(..)

-        , newTVar

-        , newTVarIO

-        , readTVar

-        , readTVarIO

-        , writeTVar

-        , unsafeIOToSTM

-

------------------------------------------------------------------------------

--- Transactional heap operations

------------------------------------------------------------------------------

-

--- TVars are shared memory locations which support atomic memory

--- transactions.

-

--- |A monad supporting atomic memory transactions.

-newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))

-

-unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))

-unSTM (STM a) = a

-

--- | @since base-4.3.0.0

-instance  Functor STM where

-   fmap f x = x >>= (pure . f)

-

--- | @since base-4.8.0.0

-instance Applicative STM where

-  {-# INLINE pure #-}

-  {-# INLINE (*>) #-}

-  {-# INLINE liftA2 #-}

-  pure x = returnSTM x

-  (<*>) = ap

-  liftA2 = liftM2

-  m *> k = thenSTM m k

-

--- | @since base-4.3.0.0

-instance  Monad STM  where

-    {-# INLINE (>>=)  #-}

-    m >>= k     = bindSTM m k

-    (>>) = (*>)

-

--- | @since base-4.17.0.0

-instance Semigroup a => Semigroup (STM a) where

-    (<>) = liftA2 (<>)

-

--- | @since base-4.17.0.0

-instance Monoid a => Monoid (STM a) where

-    mempty = pure mempty

-

-bindSTM :: STM a -> (a -> STM b) -> STM b

-bindSTM (STM m) k = STM ( \s ->

-  case m s of

-    (# new_s, a #) -> unSTM (k a) new_s

-  )

-

-thenSTM :: STM a -> STM b -> STM b

-thenSTM (STM m) k = STM ( \s ->

-  case m s of

-    (# new_s, _ #) -> unSTM k new_s

-  )

-

-returnSTM :: a -> STM a

-returnSTM x = STM (\s -> (# s, x #))

-

--- | Takes the first non-'retry'ing 'STM' action.

---

--- @since base-4.8.0.0

-instance Alternative STM where

-  empty = retry

-  (<|>) = orElse

-

--- | Takes the first non-'retry'ing 'STM' action.

---

--- @since base-4.3.0.0

-instance MonadPlus STM

-

--- | Unsafely performs IO in the STM monad.  Beware: this is a highly

--- dangerous thing to do.

---

---   * The STM implementation will often run transactions multiple

---     times, so you need to be prepared for this if your IO has any

---     side effects.

---

---   * The STM implementation will abort transactions that are known to

---     be invalid and need to be restarted.  This may happen in the middle

---     of `unsafeIOToSTM`, so make sure you don't acquire any resources

---     that need releasing (exception handlers are ignored when aborting

---     the transaction).  That includes doing any IO using Handles, for

---     example.  Getting this wrong will probably lead to random deadlocks.

---

---   * The transaction may have seen an inconsistent view of memory when

---     the IO runs.  Invariants that you expect to be true throughout

---     your program may not be true inside a transaction, due to the

---     way transactions are implemented.  Normally this wouldn't be visible

---     to the programmer, but using `unsafeIOToSTM` can expose it.

---

-unsafeIOToSTM :: IO a -> STM a

-unsafeIOToSTM (IO m) = STM m

-

--- | Perform a series of STM actions atomically.

---

--- Using 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'

--- subverts some of guarantees that STM provides. It makes it possible to