{-# LANGUAGE ViewPatterns #-}

-- | 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 'GHC.Core.Opt.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);
-- >
-- > }
--

module GHC.Iface.Tidy.StaticPtrTable
  ( sptCreateStaticBinds
  , sptModuleInitCode
  , StaticPtrOpts (..)
  )
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 GHC.Tc.Types).  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 GHC.Driver.Make.upsweep').
-}

import GHC.Prelude
import GHC.Platform

import GHC.Core
import GHC.Core.Utils (collectMakeStaticArgs)
import GHC.Core.DataCon
import GHC.Core.Make (mkStringExprFSWith,MkStringIds(..))
import GHC.Core.Type

import GHC.Cmm.CLabel

import GHC.Unit.Module
import GHC.Utils.Outputable as Outputable

import GHC.Linker.Types

import GHC.Types.Id
import GHC.Types.ForeignStubs
import GHC.Data.Maybe

import Control.Monad.Trans.State.Strict
import Data.List (intercalate)
import GHC.Fingerprint

data StaticPtrOpts = StaticPtrOpts
  { StaticPtrOpts -> Platform
opt_platform                :: !Platform    -- ^ Target platform
  , StaticPtrOpts -> Bool
opt_gen_cstub               :: !Bool        -- ^ Generate CStub or not
  , StaticPtrOpts -> MkStringIds
opt_mk_string               :: !MkStringIds -- ^ Ids for `unpackCString[Utf8]#`
  , StaticPtrOpts -> DataCon
opt_static_ptr_info_datacon :: !DataCon          -- ^ `StaticPtrInfo` datacon
  , StaticPtrOpts -> DataCon
opt_static_ptr_datacon      :: !DataCon          -- ^ `StaticPtr` datacon
  }

-- | 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 :: StaticPtrOpts -> Module -> CoreProgram -> IO ([SptEntry], Maybe CStub, CoreProgram)
sptCreateStaticBinds :: StaticPtrOpts
-> Module
-> CoreProgram
-> IO ([SptEntry], Maybe CStub, CoreProgram)
sptCreateStaticBinds StaticPtrOpts
opts Module
this_mod CoreProgram
binds = do
      ([SptEntry]
fps, CoreProgram
binds') <- 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) Int
0
      let cstub :: Maybe CStub
cstub
            | StaticPtrOpts -> Bool
opt_gen_cstub StaticPtrOpts
opts = forall a. a -> Maybe a
Just (Platform -> Module -> [SptEntry] -> CStub
sptModuleInitCode (StaticPtrOpts -> Platform
opt_platform StaticPtrOpts
opts) Module
this_mod [SptEntry]
fps)
            | Bool
otherwise          = forall a. Maybe a
Nothing
      forall (m :: * -> *) a. Monad m => a -> m a
return ([SptEntry]
fps, Maybe CStub
cstub, CoreProgram
binds')
  where
    go :: [SptEntry]
-> CoreProgram
-> CoreProgram
-> StateT Int IO ([SptEntry], CoreProgram)
go [SptEntry]
fps CoreProgram
bs CoreProgram
xs = case CoreProgram
xs of
      []        -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [SptEntry]
fps, forall a. [a] -> [a]
reverse CoreProgram
bs)
      CoreBind
bnd : CoreProgram
xs' -> do
        ([SptEntry]
fps', CoreBind
bnd') <- CoreBind -> StateT Int IO ([SptEntry], CoreBind)
replaceStaticBind CoreBind
bnd
        [SptEntry]
-> CoreProgram
-> CoreProgram
-> StateT Int IO ([SptEntry], CoreProgram)
go (forall a. [a] -> [a]
reverse [SptEntry]
fps' forall a. [a] -> [a] -> [a]
++ [SptEntry]
fps) (CoreBind
bnd' forall a. a -> [a] -> [a]
: CoreProgram
bs) CoreProgram
xs'

    -- 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 CoreBndr
b Expr CoreBndr
e) = do (Maybe SptEntry
mfp, (CoreBndr
b', Expr CoreBndr
e')) <- CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
replaceStatic CoreBndr
b Expr CoreBndr
e
                                        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a -> [a]
maybeToList Maybe SptEntry
mfp, forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b' Expr CoreBndr
e')
    replaceStaticBind (Rec [(CoreBndr, Expr CoreBndr)]
rbs) = do
      ([Maybe SptEntry]
mfps, [(CoreBndr, Expr CoreBndr)]
rbs') <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [Maybe a] -> [a]
catMaybes [Maybe SptEntry]
mfps, 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 CoreBndr
b e :: Expr CoreBndr
e@(Expr CoreBndr -> ([CoreBndr], Expr CoreBndr)
collectTyBinders -> ([CoreBndr]
tvs, Expr CoreBndr
e0)) =
      case Expr CoreBndr
-> Maybe (Expr CoreBndr, Type, Expr CoreBndr, Expr CoreBndr)
collectMakeStaticArgs Expr CoreBndr
e0 of
        Maybe (Expr CoreBndr, Type, Expr CoreBndr, Expr CoreBndr)
Nothing      -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, (CoreBndr
b, Expr CoreBndr
e))
        Just (Expr CoreBndr
_, Type
t, Expr CoreBndr
info, Expr CoreBndr
arg) -> do
          (Fingerprint
fp, Expr CoreBndr
e') <- Type
-> Expr CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Fingerprint, Expr CoreBndr)
mkStaticBind Type
t Expr CoreBndr
info Expr CoreBndr
arg
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (CoreBndr -> Fingerprint -> SptEntry
SptEntry CoreBndr
b Fingerprint
fp), (CoreBndr
b, forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 Type
t Expr CoreBndr
srcLoc Expr CoreBndr
e = do
      Int
i <- forall (m :: * -> *) s. Monad m => StateT s m s
get
      forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int
i forall a. Num a => a -> a -> a
+ Int
1)
      let staticPtrInfoDataCon :: DataCon
staticPtrInfoDataCon = StaticPtrOpts -> DataCon
opt_static_ptr_info_datacon StaticPtrOpts
opts
      let fp :: Fingerprint
fp@(Fingerprint Word64
w0 Word64
w1) = Int -> Fingerprint
mkStaticPtrFingerprint Int
i
      let mk_string_fs :: FastString -> Expr CoreBndr
mk_string_fs = MkStringIds -> FastString -> Expr CoreBndr
mkStringExprFSWith (StaticPtrOpts -> MkStringIds
opt_mk_string StaticPtrOpts
opts)
      let info :: Expr CoreBndr
info = forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
staticPtrInfoDataCon
                  [ FastString -> Expr CoreBndr
mk_string_fs forall a b. (a -> b) -> a -> b
$ forall u. IsUnitId u => u -> FastString
unitFS forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit Module
this_mod
                  , FastString -> Expr CoreBndr
mk_string_fs forall a b. (a -> b) -> a -> b
$ ModuleName -> FastString
moduleNameFS forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod
                  , Expr CoreBndr
srcLoc
                  ]

      let staticPtrDataCon :: DataCon
staticPtrDataCon = StaticPtrOpts -> DataCon
opt_static_ptr_datacon StaticPtrOpts
opts
      forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint
fp, forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
staticPtrDataCon
                               [ forall b. Type -> Expr b
Type Type
t
                               , forall b. Word64 -> Expr b
mkWord64LitWord64 Word64
w0
                               , forall b. Word64 -> Expr b
mkWord64LitWord64 Word64
w1
                               , Expr CoreBndr
info
                               , Expr CoreBndr
e ])

    mkStaticPtrFingerprint :: Int -> Fingerprint
    mkStaticPtrFingerprint :: Int -> Fingerprint
mkStaticPtrFingerprint Int
n = String -> Fingerprint
fingerprintString forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
":"
        [ forall u. IsUnitId u => u -> String
unitString forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit Module
this_mod
        , ModuleName -> String
moduleNameString forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod
        , forall a. Show a => a -> String
show Int
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 :: Platform -> Module -> [SptEntry] -> CStub
sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub
sptModuleInitCode Platform
_        Module
_        [] = forall a. Monoid a => a
mempty
sptModuleInitCode Platform
platform Module
this_mod [SptEntry]
entries =
    Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub Platform
platform CLabel
init_fn_nm SDoc
empty SDoc
init_fn_body forall a. Monoid a => a -> a -> a
`mappend`
    Platform -> CLabel -> SDoc -> SDoc -> CStub
finalizerCStub Platform
platform CLabel
fini_fn_nm SDoc
empty SDoc
fini_fn_body
  where
    init_fn_nm :: CLabel
init_fn_nm = Module -> String -> CLabel
mkInitializerStubLabel Module
this_mod String
"spt"
    init_fn_body :: SDoc
init_fn_body = [SDoc] -> SDoc
vcat
        [  String -> SDoc
text String
"static StgWord64 k" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"[2] = "
           SDoc -> SDoc -> SDoc
<> Fingerprint -> SDoc
pprFingerprint Fingerprint
fp SDoc -> SDoc -> SDoc
<> SDoc
semi
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"extern StgPtr "
           SDoc -> SDoc -> SDoc
<> (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform 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 String
"hs_spt_insert" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens
             ([SDoc] -> SDoc
hcat forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
                [ Char -> SDoc
char Char
'k' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i
                , Char -> SDoc
char Char
'&' SDoc -> SDoc -> SDoc
<> forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform (Name -> CafInfo -> CLabel
mkClosureLabel (CoreBndr -> Name
idName CoreBndr
n) (CoreBndr -> CafInfo
idCafInfo CoreBndr
n))
                ]
             )
        SDoc -> SDoc -> SDoc
<> SDoc
semi
        |  (Int
i, SptEntry CoreBndr
n Fingerprint
fp) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [SptEntry]
entries
        ]

    fini_fn_nm :: CLabel
fini_fn_nm = Module -> String -> CLabel
mkFinalizerStubLabel Module
this_mod String
"spt"
    fini_fn_body :: SDoc
fini_fn_body = [SDoc] -> SDoc
vcat
        [  String -> SDoc
text String
"StgWord64 k" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"[2] = "
           SDoc -> SDoc -> SDoc
<> Fingerprint -> SDoc
pprFingerprint Fingerprint
fp SDoc -> SDoc -> SDoc
<> SDoc
semi
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"hs_spt_remove" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (Char -> SDoc
char Char
'k' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i) SDoc -> SDoc -> SDoc
<> SDoc
semi
        | (Int
i, (SptEntry CoreBndr
_ Fingerprint
fp)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [SptEntry]
entries
        ]

    pprFingerprint :: Fingerprint -> SDoc
    pprFingerprint :: Fingerprint -> SDoc
pprFingerprint (Fingerprint Word64
w1 Word64
w2) =
      SDoc -> SDoc
braces forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hcat forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
                 [ Integer -> SDoc
integer (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w1) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"ULL"
                 , Integer -> SDoc
integer (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w2) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"ULL"
                 ]