-- | Code generation for the Static Pointer Table
--
-- (c) 2014 I/O Tweag
--
-- Each module that uses 'static' keyword declares an initialization function of
-- the form hs_spt_init_<module>() which is emitted into the _stub.c file and
-- annotated with __attribute__((constructor)) so that it gets executed at
-- startup time.
--
-- The function's purpose is to call hs_spt_insert to insert the static
-- pointers of this module in the hashtable of the RTS, and it looks something
-- like this:
--
-- > static void hs_hpc_init_Main(void) __attribute__((constructor));
-- > static void hs_hpc_init_Main(void) {
-- >
-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
-- >   extern StgPtr Main_r2wb_closure;
-- >   hs_spt_insert(k0, &Main_r2wb_closure);
-- >
-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
-- >   extern StgPtr Main_r2wc_closure;
-- >   hs_spt_insert(k1, &Main_r2wc_closure);
-- >
-- > }
--
-- where the constants are fingerprints produced from the static forms.
--
-- 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.
--
-- There is also a finalization function for the time when the module is
-- unloaded.
--
-- > static void hs_hpc_fini_Main(void) __attribute__((destructor));
-- > static void hs_hpc_fini_Main(void) {
-- >
-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
-- >   hs_spt_remove(k0);
-- >
-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
-- >   hs_spt_remove(k1);
-- >
-- > }
--

{-# LANGUAGE ViewPatterns, TupleSections #-}
module StaticPtrTable
    ( sptCreateStaticBinds
    , sptModuleInitCode
    ) where

{- Note [Grand plan for static forms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Static forms go through the compilation phases as follows.
Here is a running example:

   f x = let k = map toUpper
         in ...(static k)...

* The renamer looks for out-of-scope names in the body of the static
  form, as always. If all names are in scope, the free variables of the
  body are stored in AST at the location of the static form.

* The typechecker verifies that all free variables occurring in the
  static form are floatable to top level (see Note [Meaning of
  IdBindingInfo] in TcRnTypes).  In our example, 'k' is floatable.
  Even though it is bound in a nested let, we are fine.

* The desugarer replaces the static form with an application of the
  function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
  base).  So we get

   f x = let k = map toUpper
         in ...fromStaticPtr (makeStatic location k)...

* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'
  to the top level. Thus the FloatOut pass is always executed, even when
  optimizations are disabled.  So we get

   k = map toUpper
   static_ptr = makeStatic location k
   f x = ...fromStaticPtr static_ptr...

  The FloatOut pass is careful to produce an /exported/ Id for a floated
  'makeStatic' call, so the binding is not removed or inlined by the
  simplifier.
  E.g. the code for `f` above might look like

    static_ptr = makeStatic location k
    f x = ...(case static_ptr of ...)...

  which might be simplified to

    f x = ...(case makeStatic location k of ...)...

  BUT the top-level binding for static_ptr must remain, so that it can be
  collected to populate the Static Pointer Table.

  Making the binding exported also has a necessary effect during the
  CoreTidy pass.

* The CoreTidy pass replaces all bindings of the form

  b = /\ ... -> makeStatic location value

  with

  b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value

  where a distinct key is generated for each binding.

* If we are compiling to object code we insert a C stub (generated by
  sptModuleInitCode) into the final object which runs when the module is loaded,
  inserting the static forms defined by the module into the RTS's static pointer
  table.

* If we are compiling for the byte-code interpreter, we instead explicitly add
  the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter
  process' SPT table using the addSptEntry interpreter message. This happens
  in upsweep after we have compiled the module (see GhcMake.upsweep').
-}

import GhcPrelude

import CLabel
import CoreSyn
import CoreUtils (collectMakeStaticArgs)
import DataCon
import DynFlags
import HscTypes
import Id
import MkCore (mkStringExprFSWith)
import Module
import Name
import Outputable
import Platform
import PrelNames
import TcEnv (lookupGlobal)
import Type

import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
import Data.List
import Data.Maybe
import GHC.Fingerprint
import qualified GHC.LanguageExtensions as LangExt

-- | Replaces all bindings of the form
--
-- > b = /\ ... -> makeStatic location value
--
--  with
--
-- > b = /\ ... ->
-- >   StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
--
--  where a distinct key is generated for each binding.
--
-- It also yields the C stub that inserts these bindings into the static
-- pointer table.
sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
                     -> IO ([SptEntry], CoreProgram)
sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram -> IO ([SptEntry], CoreProgram)
sptCreateStaticBinds hsc_env :: HscEnv
hsc_env this_mod :: Module
this_mod binds :: CoreProgram
binds
    | Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.StaticPointers DynFlags
dflags) =
      ([SptEntry], CoreProgram) -> IO ([SptEntry], CoreProgram)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CoreProgram
binds)
    | Bool
otherwise = do
      -- Make sure the required interface files are loaded.
      TyThing
_ <- HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
unpackCStringName
      (fps :: [SptEntry]
fps, binds' :: CoreProgram
binds') <- StateT Int IO ([SptEntry], CoreProgram)
-> Int -> IO ([SptEntry], CoreProgram)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ([SptEntry]
-> CoreProgram
-> CoreProgram
-> StateT Int IO ([SptEntry], CoreProgram)
go [] [] CoreProgram
binds) 0
      ([SptEntry], CoreProgram) -> IO ([SptEntry], CoreProgram)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SptEntry]
fps, CoreProgram
binds')
  where
    go :: [SptEntry]
-> CoreProgram
-> CoreProgram
-> StateT Int IO ([SptEntry], CoreProgram)
go fps :: [SptEntry]
fps bs :: CoreProgram
bs xs :: CoreProgram
xs = case CoreProgram
xs of
      []        -> ([SptEntry], CoreProgram)
-> StateT Int IO ([SptEntry], CoreProgram)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SptEntry] -> [SptEntry]
forall a. [a] -> [a]
reverse [SptEntry]
fps, CoreProgram -> CoreProgram
forall a. [a] -> [a]
reverse CoreProgram
bs)
      bnd :: CoreBind
bnd : xs' :: CoreProgram
xs' -> do
        (fps' :: [SptEntry]
fps', bnd' :: CoreBind
bnd') <- CoreBind -> StateT Int IO ([SptEntry], CoreBind)
replaceStaticBind CoreBind
bnd
        [SptEntry]
-> CoreProgram
-> CoreProgram
-> StateT Int IO ([SptEntry], CoreProgram)
go ([SptEntry] -> [SptEntry]
forall a. [a] -> [a]
reverse [SptEntry]
fps' [SptEntry] -> [SptEntry] -> [SptEntry]
forall a. [a] -> [a] -> [a]
++ [SptEntry]
fps) (CoreBind
bnd' CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
bs) CoreProgram
xs'

    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

    -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
    --
    -- The 'Int' state is used to produce a different key for each binding.
    replaceStaticBind :: CoreBind
                      -> StateT Int IO ([SptEntry], CoreBind)
    replaceStaticBind :: CoreBind -> StateT Int IO ([SptEntry], CoreBind)
replaceStaticBind (NonRec b :: CoreBndr
b e :: Expr CoreBndr
e) = do (mfp :: Maybe SptEntry
mfp, (b' :: CoreBndr
b', e' :: Expr CoreBndr
e')) <- CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
replaceStatic CoreBndr
b Expr CoreBndr
e
                                        ([SptEntry], CoreBind) -> StateT Int IO ([SptEntry], CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SptEntry -> [SptEntry]
forall a. Maybe a -> [a]
maybeToList Maybe SptEntry
mfp, CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b' Expr CoreBndr
e')
    replaceStaticBind (Rec rbs :: [(CoreBndr, Expr CoreBndr)]
rbs) = do
      (mfps :: [Maybe SptEntry]
mfps, rbs' :: [(CoreBndr, Expr CoreBndr)]
rbs') <- [(Maybe SptEntry, (CoreBndr, Expr CoreBndr))]
-> ([Maybe SptEntry], [(CoreBndr, Expr CoreBndr)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe SptEntry, (CoreBndr, Expr CoreBndr))]
 -> ([Maybe SptEntry], [(CoreBndr, Expr CoreBndr)]))
-> StateT Int IO [(Maybe SptEntry, (CoreBndr, Expr CoreBndr))]
-> StateT Int IO ([Maybe SptEntry], [(CoreBndr, Expr CoreBndr)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CoreBndr, Expr CoreBndr)
 -> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr)))
-> [(CoreBndr, Expr CoreBndr)]
-> StateT Int IO [(Maybe SptEntry, (CoreBndr, Expr CoreBndr))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((CoreBndr
 -> Expr CoreBndr
 -> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr)))
-> (CoreBndr, Expr CoreBndr)
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
replaceStatic) [(CoreBndr, Expr CoreBndr)]
rbs
      ([SptEntry], CoreBind) -> StateT Int IO ([SptEntry], CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe SptEntry] -> [SptEntry]
forall a. [Maybe a] -> [a]
catMaybes [Maybe SptEntry]
mfps, [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, Expr CoreBndr)]
rbs')

    replaceStatic :: Id -> CoreExpr
                  -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
    replaceStatic :: CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
replaceStatic b :: CoreBndr
b e :: Expr CoreBndr
e@(Expr CoreBndr -> ([CoreBndr], Expr CoreBndr)
collectTyBinders -> (tvs :: [CoreBndr]
tvs, e0 :: Expr CoreBndr
e0)) =
      case Expr CoreBndr
-> Maybe (Expr CoreBndr, Type, Expr CoreBndr, Expr CoreBndr)
collectMakeStaticArgs Expr CoreBndr
e0 of
        Nothing      -> (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SptEntry
forall a. Maybe a
Nothing, (CoreBndr
b, Expr CoreBndr
e))
        Just (_, t :: Type
t, info :: Expr CoreBndr
info, arg :: Expr CoreBndr
arg) -> do
          (fp :: Fingerprint
fp, e' :: Expr CoreBndr
e') <- Type
-> Expr CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Fingerprint, Expr CoreBndr)
mkStaticBind Type
t Expr CoreBndr
info Expr CoreBndr
arg
          (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
forall (m :: * -> *) a. Monad m => a -> m a
return (SptEntry -> Maybe SptEntry
forall a. a -> Maybe a
Just (CoreBndr -> Fingerprint -> SptEntry
SptEntry CoreBndr
b Fingerprint
fp), (CoreBndr
b, (CoreBndr -> Expr CoreBndr -> Expr CoreBndr)
-> Expr CoreBndr -> [CoreBndr] -> Expr CoreBndr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam Expr CoreBndr
e' [CoreBndr]
tvs))

    mkStaticBind :: Type -> CoreExpr -> CoreExpr
                 -> StateT Int IO (Fingerprint, CoreExpr)
    mkStaticBind :: Type
-> Expr CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Fingerprint, Expr CoreBndr)
mkStaticBind t :: Type
t srcLoc :: Expr CoreBndr
srcLoc e :: Expr CoreBndr
e = do
      Int
i <- StateT Int IO Int
forall (m :: * -> *) s. Monad m => StateT s m s
get
      Int -> StateT Int IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
      DataCon
staticPtrInfoDataCon <-
        IO DataCon -> StateT Int IO DataCon
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO DataCon -> StateT Int IO DataCon)
-> IO DataCon -> StateT Int IO DataCon
forall a b. (a -> b) -> a -> b
$ Name -> IO DataCon
lookupDataConHscEnv Name
staticPtrInfoDataConName
      let fp :: Fingerprint
fp@(Fingerprint w0 :: Word64
w0 w1 :: Word64
w1) = Int -> Fingerprint
mkStaticPtrFingerprint Int
i
      Expr CoreBndr
info <- DataCon -> [Expr CoreBndr] -> Expr CoreBndr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
staticPtrInfoDataCon ([Expr CoreBndr] -> Expr CoreBndr)
-> ([Expr CoreBndr] -> [Expr CoreBndr])
-> [Expr CoreBndr]
-> Expr CoreBndr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ([Expr CoreBndr] -> [Expr CoreBndr] -> [Expr CoreBndr]
forall a. [a] -> [a] -> [a]
++[Expr CoreBndr
srcLoc]) ([Expr CoreBndr] -> Expr CoreBndr)
-> StateT Int IO [Expr CoreBndr] -> StateT Int IO (Expr CoreBndr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (FastString -> StateT Int IO (Expr CoreBndr))
-> [FastString] -> StateT Int IO [Expr CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Name -> StateT Int IO CoreBndr)
-> FastString -> StateT Int IO (Expr CoreBndr)
forall (m :: * -> *).
Monad m =>
(Name -> m CoreBndr) -> FastString -> m (Expr CoreBndr)
mkStringExprFSWith (IO CoreBndr -> StateT Int IO CoreBndr
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO CoreBndr -> StateT Int IO CoreBndr)
-> (Name -> IO CoreBndr) -> Name -> StateT Int IO CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IO CoreBndr
lookupIdHscEnv))
                 [ UnitId -> FastString
unitIdFS (UnitId -> FastString) -> UnitId -> FastString
forall a b. (a -> b) -> a -> b
$ Module -> UnitId
moduleUnitId Module
this_mod
                 , ModuleName -> FastString
moduleNameFS (ModuleName -> FastString) -> ModuleName -> FastString
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
moduleName Module
this_mod
                 ]

      -- The module interface of GHC.StaticPtr should be loaded at least
      -- when looking up 'fromStatic' during type-checking.
      DataCon
staticPtrDataCon <- IO DataCon -> StateT Int IO DataCon
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO DataCon -> StateT Int IO DataCon)
-> IO DataCon -> StateT Int IO DataCon
forall a b. (a -> b) -> a -> b
$ Name -> IO DataCon
lookupDataConHscEnv Name
staticPtrDataConName
      (Fingerprint, Expr CoreBndr)
-> StateT Int IO (Fingerprint, Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint
fp, DataCon -> [Expr CoreBndr] -> Expr CoreBndr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
staticPtrDataCon
                               [ Type -> Expr CoreBndr
forall b. Type -> Expr b
Type Type
t
                               , DynFlags -> Word64 -> Expr CoreBndr
forall b. DynFlags -> Word64 -> Expr b
mkWord64LitWordRep DynFlags
dflags Word64
w0
                               , DynFlags -> Word64 -> Expr CoreBndr
forall b. DynFlags -> Word64 -> Expr b
mkWord64LitWordRep DynFlags
dflags Word64
w1
                               , Expr CoreBndr
info
                               , Expr CoreBndr
e ])

    mkStaticPtrFingerprint :: Int -> Fingerprint
    mkStaticPtrFingerprint :: Int -> Fingerprint
mkStaticPtrFingerprint n :: Int
n = String -> Fingerprint
fingerprintString (String -> Fingerprint) -> String -> Fingerprint
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ":"
        [ UnitId -> String
unitIdString (UnitId -> String) -> UnitId -> String
forall a b. (a -> b) -> a -> b
$ Module -> UnitId
moduleUnitId Module
this_mod
        , ModuleName -> String
moduleNameString (ModuleName -> String) -> ModuleName -> String
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
moduleName Module
this_mod
        , Int -> String
forall a. Show a => a -> String
show Int
n
        ]

    -- Choose either 'Word64#' or 'Word#' to represent the arguments of the
    -- 'Fingerprint' data constructor.
    mkWord64LitWordRep :: DynFlags -> Word64 -> Expr b
mkWord64LitWordRep dflags :: DynFlags
dflags
      | Platform -> Int
platformWordSize (DynFlags -> Platform
targetPlatform DynFlags
dflags) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 8 = Word64 -> Expr b
forall b. Word64 -> Expr b
mkWord64LitWord64
      | Bool
otherwise = DynFlags -> Integer -> Expr b
forall b. DynFlags -> Integer -> Expr b
mkWordLit DynFlags
dflags (Integer -> Expr b) -> (Word64 -> Integer) -> Word64 -> Expr b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger

    lookupIdHscEnv :: Name -> IO Id
    lookupIdHscEnv :: Name -> IO CoreBndr
lookupIdHscEnv n :: Name
n = HscEnv -> Name -> IO (Maybe TyThing)
lookupTypeHscEnv HscEnv
hsc_env Name
n IO (Maybe TyThing) -> (Maybe TyThing -> IO CoreBndr) -> IO CoreBndr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                         IO CoreBndr
-> (TyThing -> IO CoreBndr) -> Maybe TyThing -> IO CoreBndr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> IO CoreBndr
forall a a. Outputable a => a -> a
getError Name
n) (CoreBndr -> IO CoreBndr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> IO CoreBndr)
-> (TyThing -> CoreBndr) -> TyThing -> IO CoreBndr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyThing -> CoreBndr
tyThingId)

    lookupDataConHscEnv :: Name -> IO DataCon
    lookupDataConHscEnv :: Name -> IO DataCon
lookupDataConHscEnv n :: Name
n = HscEnv -> Name -> IO (Maybe TyThing)
lookupTypeHscEnv HscEnv
hsc_env Name
n IO (Maybe TyThing) -> (Maybe TyThing -> IO DataCon) -> IO DataCon
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                              IO DataCon
-> (TyThing -> IO DataCon) -> Maybe TyThing -> IO DataCon
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> IO DataCon
forall a a. Outputable a => a -> a
getError Name
n) (DataCon -> IO DataCon
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon -> IO DataCon)
-> (TyThing -> DataCon) -> TyThing -> IO DataCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyThing -> DataCon
tyThingDataCon)

    getError :: a -> a
getError n :: a
n = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic "sptCreateStaticBinds.get: not found" (SDoc -> a) -> SDoc -> a
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text "Couldn't find" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
n

-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
-- of @module@ into the static pointer table.
--
-- @fps@ is a list associating each binding corresponding to a static entry with
-- its fingerprint.
sptModuleInitCode :: Module -> [SptEntry] -> SDoc
sptModuleInitCode :: Module -> [SptEntry] -> SDoc
sptModuleInitCode _ [] = SDoc
Outputable.empty
sptModuleInitCode this_mod :: Module
this_mod entries :: [SptEntry]
entries = [SDoc] -> SDoc
vcat
    [ String -> SDoc
text "static void hs_spt_init_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
           SDoc -> SDoc -> SDoc
<> String -> SDoc
text "(void) __attribute__((constructor));"
    , String -> SDoc
text "static void hs_spt_init_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod SDoc -> SDoc -> SDoc
<> String -> SDoc
text "(void)"
    , SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
        [  String -> SDoc
text "static StgWord64 k" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<> String -> SDoc
text "[2] = "
           SDoc -> SDoc -> SDoc
<> Fingerprint -> SDoc
pprFingerprint Fingerprint
fp SDoc -> SDoc -> SDoc
<> SDoc
semi
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "extern StgPtr "
           SDoc -> SDoc -> SDoc
<> (CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CLabel -> SDoc) -> CLabel -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> CafInfo -> CLabel
mkClosureLabel (CoreBndr -> Name
idName CoreBndr
n) (CoreBndr -> CafInfo
idCafInfo CoreBndr
n)) SDoc -> SDoc -> SDoc
<> SDoc
semi
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "hs_spt_insert" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens
             ([SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
                [ Char -> SDoc
char 'k' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i
                , Char -> SDoc
char '&' SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> CafInfo -> CLabel
mkClosureLabel (CoreBndr -> Name
idName CoreBndr
n) (CoreBndr -> CafInfo
idCafInfo CoreBndr
n))
                ]
             )
        SDoc -> SDoc -> SDoc
<> SDoc
semi
        |  (i :: Int
i, SptEntry n :: CoreBndr
n fp :: Fingerprint
fp) <- [Int] -> [SptEntry] -> [(Int, SptEntry)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [SptEntry]
entries
        ]
    , String -> SDoc
text "static void hs_spt_fini_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
           SDoc -> SDoc -> SDoc
<> String -> SDoc
text "(void) __attribute__((destructor));"
    , String -> SDoc
text "static void hs_spt_fini_" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod SDoc -> SDoc -> SDoc
<> String -> SDoc
text "(void)"
    , SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
        [  String -> SDoc
text "StgWord64 k" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<> String -> SDoc
text "[2] = "
           SDoc -> SDoc -> SDoc
<> Fingerprint -> SDoc
pprFingerprint Fingerprint
fp SDoc -> SDoc -> SDoc
<> SDoc
semi
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "hs_spt_remove" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (Char -> SDoc
char 'k' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i) SDoc -> SDoc -> SDoc
<> SDoc
semi
        | (i :: Int
i, (SptEntry _ fp :: Fingerprint
fp)) <- [Int] -> [SptEntry] -> [(Int, SptEntry)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [SptEntry]
entries
        ]
    ]
  where
    pprFingerprint :: Fingerprint -> SDoc
    pprFingerprint :: Fingerprint -> SDoc
pprFingerprint (Fingerprint w1 :: Word64
w1 w2 :: Word64
w2) =
      SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
                 [ Integer -> SDoc
integer (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w1) SDoc -> SDoc -> SDoc
<> String -> SDoc
text "ULL"
                 , Integer -> SDoc
integer (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w2) SDoc -> SDoc -> SDoc
<> String -> SDoc
text "ULL"
                 ]