never executed always true always false
    1 {-# LANGUAGE ViewPatterns  #-}
    2 
    3 -- | Code generation for the Static Pointer Table
    4 --
    5 -- (c) 2014 I/O Tweag
    6 --
    7 -- Each module that uses 'static' keyword declares an initialization function of
    8 -- the form hs_spt_init_\<module>() which is emitted into the _stub.c file and
    9 -- annotated with __attribute__((constructor)) so that it gets executed at
   10 -- startup time.
   11 --
   12 -- The function's purpose is to call hs_spt_insert to insert the static
   13 -- pointers of this module in the hashtable of the RTS, and it looks something
   14 -- like this:
   15 --
   16 -- > static void hs_hpc_init_Main(void) __attribute__((constructor));
   17 -- > static void hs_hpc_init_Main(void) {
   18 -- >
   19 -- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
   20 -- >   extern StgPtr Main_r2wb_closure;
   21 -- >   hs_spt_insert(k0, &Main_r2wb_closure);
   22 -- >
   23 -- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
   24 -- >   extern StgPtr Main_r2wc_closure;
   25 -- >   hs_spt_insert(k1, &Main_r2wc_closure);
   26 -- >
   27 -- > }
   28 --
   29 -- where the constants are fingerprints produced from the static forms.
   30 --
   31 -- The linker must find the definitions matching the @extern StgPtr <name>@
   32 -- declarations. For this to work, the identifiers of static pointers need to be
   33 -- exported. This is done in 'GHC.Core.Opt.SetLevels.newLvlVar'.
   34 --
   35 -- There is also a finalization function for the time when the module is
   36 -- unloaded.
   37 --
   38 -- > static void hs_hpc_fini_Main(void) __attribute__((destructor));
   39 -- > static void hs_hpc_fini_Main(void) {
   40 -- >
   41 -- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
   42 -- >   hs_spt_remove(k0);
   43 -- >
   44 -- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
   45 -- >   hs_spt_remove(k1);
   46 -- >
   47 -- > }
   48 --
   49 
   50 module GHC.Iface.Tidy.StaticPtrTable
   51     ( sptCreateStaticBinds
   52     , sptModuleInitCode
   53     ) where
   54 
   55 {- Note [Grand plan for static forms]
   56 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   57 Static forms go through the compilation phases as follows.
   58 Here is a running example:
   59 
   60    f x = let k = map toUpper
   61          in ...(static k)...
   62 
   63 * The renamer looks for out-of-scope names in the body of the static
   64   form, as always. If all names are in scope, the free variables of the
   65   body are stored in AST at the location of the static form.
   66 
   67 * The typechecker verifies that all free variables occurring in the
   68   static form are floatable to top level (see Note [Meaning of
   69   IdBindingInfo] in GHC.Tc.Types).  In our example, 'k' is floatable.
   70   Even though it is bound in a nested let, we are fine.
   71 
   72 * The desugarer replaces the static form with an application of the
   73   function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
   74   base).  So we get
   75 
   76    f x = let k = map toUpper
   77          in ...fromStaticPtr (makeStatic location k)...
   78 
   79 * The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'
   80   to the top level. Thus the FloatOut pass is always executed, even when
   81   optimizations are disabled.  So we get
   82 
   83    k = map toUpper
   84    static_ptr = makeStatic location k
   85    f x = ...fromStaticPtr static_ptr...
   86 
   87   The FloatOut pass is careful to produce an /exported/ Id for a floated
   88   'makeStatic' call, so the binding is not removed or inlined by the
   89   simplifier.
   90   E.g. the code for `f` above might look like
   91 
   92     static_ptr = makeStatic location k
   93     f x = ...(case static_ptr of ...)...
   94 
   95   which might be simplified to
   96 
   97     f x = ...(case makeStatic location k of ...)...
   98 
   99   BUT the top-level binding for static_ptr must remain, so that it can be
  100   collected to populate the Static Pointer Table.
  101 
  102   Making the binding exported also has a necessary effect during the
  103   CoreTidy pass.
  104 
  105 * The CoreTidy pass replaces all bindings of the form
  106 
  107   b = /\ ... -> makeStatic location value
  108 
  109   with
  110 
  111   b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
  112 
  113   where a distinct key is generated for each binding.
  114 
  115 * If we are compiling to object code we insert a C stub (generated by
  116   sptModuleInitCode) into the final object which runs when the module is loaded,
  117   inserting the static forms defined by the module into the RTS's static pointer
  118   table.
  119 
  120 * If we are compiling for the byte-code interpreter, we instead explicitly add
  121   the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter
  122   process' SPT table using the addSptEntry interpreter message. This happens
  123   in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep').
  124 -}
  125 
  126 import GHC.Prelude
  127 import GHC.Platform
  128 
  129 import GHC.Driver.Session
  130 import GHC.Driver.Env
  131 
  132 import GHC.Core
  133 import GHC.Core.Utils (collectMakeStaticArgs)
  134 import GHC.Core.DataCon
  135 import GHC.Core.Make (mkStringExprFSWith)
  136 import GHC.Core.Type
  137 
  138 import GHC.Cmm.CLabel
  139 
  140 import GHC.Unit.Module
  141 import GHC.Utils.Outputable as Outputable
  142 import GHC.Utils.Panic
  143 import GHC.Builtin.Names
  144 import GHC.Tc.Utils.Env (lookupGlobal)
  145 
  146 import GHC.Linker.Types
  147 
  148 import GHC.Types.Name
  149 import GHC.Types.Id
  150 import GHC.Types.TyThing
  151 import GHC.Types.ForeignStubs
  152 
  153 import Control.Monad.Trans.Class (lift)
  154 import Control.Monad.Trans.State.Strict
  155 import Data.List (intercalate)
  156 import Data.Maybe
  157 import GHC.Fingerprint
  158 import qualified GHC.LanguageExtensions as LangExt
  159 
  160 -- | Replaces all bindings of the form
  161 --
  162 -- > b = /\ ... -> makeStatic location value
  163 --
  164 --  with
  165 --
  166 -- > b = /\ ... ->
  167 -- >   StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
  168 --
  169 --  where a distinct key is generated for each binding.
  170 --
  171 -- It also yields the C stub that inserts these bindings into the static
  172 -- pointer table.
  173 sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
  174                      -> IO ([SptEntry], CoreProgram)
  175 sptCreateStaticBinds hsc_env this_mod binds
  176     | not (xopt LangExt.StaticPointers dflags) =
  177       return ([], binds)
  178     | otherwise = do
  179       -- Make sure the required interface files are loaded.
  180       _ <- lookupGlobal hsc_env unpackCStringName
  181       (fps, binds') <- evalStateT (go [] [] binds) 0
  182       return (fps, binds')
  183   where
  184     go fps bs xs = case xs of
  185       []        -> return (reverse fps, reverse bs)
  186       bnd : xs' -> do
  187         (fps', bnd') <- replaceStaticBind bnd
  188         go (reverse fps' ++ fps) (bnd' : bs) xs'
  189 
  190     dflags = hsc_dflags hsc_env
  191     platform = targetPlatform dflags
  192 
  193     -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
  194     --
  195     -- The 'Int' state is used to produce a different key for each binding.
  196     replaceStaticBind :: CoreBind
  197                       -> StateT Int IO ([SptEntry], CoreBind)
  198     replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
  199                                         return (maybeToList mfp, NonRec b' e')
  200     replaceStaticBind (Rec rbs) = do
  201       (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
  202       return (catMaybes mfps, Rec rbs')
  203 
  204     replaceStatic :: Id -> CoreExpr
  205                   -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
  206     replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
  207       case collectMakeStaticArgs e0 of
  208         Nothing      -> return (Nothing, (b, e))
  209         Just (_, t, info, arg) -> do
  210           (fp, e') <- mkStaticBind t info arg
  211           return (Just (SptEntry b fp), (b, foldr Lam e' tvs))
  212 
  213     mkStaticBind :: Type -> CoreExpr -> CoreExpr
  214                  -> StateT Int IO (Fingerprint, CoreExpr)
  215     mkStaticBind t srcLoc e = do
  216       i <- get
  217       put (i + 1)
  218       staticPtrInfoDataCon <-
  219         lift $ lookupDataConHscEnv staticPtrInfoDataConName
  220       let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
  221       info <- mkConApp staticPtrInfoDataCon <$>
  222             (++[srcLoc]) <$>
  223             mapM (mkStringExprFSWith (lift . lookupIdHscEnv))
  224                  [ unitFS $ moduleUnit this_mod
  225                  , moduleNameFS $ moduleName this_mod
  226                  ]
  227 
  228       -- The module interface of GHC.StaticPtr should be loaded at least
  229       -- when looking up 'fromStatic' during type-checking.
  230       staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName
  231       return (fp, mkConApp staticPtrDataCon
  232                                [ Type t
  233                                , mkWord64LitWordRep platform w0
  234                                , mkWord64LitWordRep platform w1
  235                                , info
  236                                , e ])
  237 
  238     mkStaticPtrFingerprint :: Int -> Fingerprint
  239     mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
  240         [ unitString $ moduleUnit this_mod
  241         , moduleNameString $ moduleName this_mod
  242         , show n
  243         ]
  244 
  245     -- Choose either 'Word64#' or 'Word#' to represent the arguments of the
  246     -- 'Fingerprint' data constructor.
  247     mkWord64LitWordRep platform =
  248       case platformWordSize platform of
  249         PW4 -> mkWord64LitWord64
  250         PW8 -> mkWordLit platform . toInteger
  251 
  252     lookupIdHscEnv :: Name -> IO Id
  253     lookupIdHscEnv n = lookupType hsc_env n >>=
  254                          maybe (getError n) (return . tyThingId)
  255 
  256     lookupDataConHscEnv :: Name -> IO DataCon
  257     lookupDataConHscEnv n = lookupType hsc_env n >>=
  258                               maybe (getError n) (return . tyThingDataCon)
  259 
  260     getError n = pprPanic "sptCreateStaticBinds.get: not found" $
  261       text "Couldn't find" <+> ppr n
  262 
  263 -- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
  264 -- of @module@ into the static pointer table.
  265 --
  266 -- @fps@ is a list associating each binding corresponding to a static entry with
  267 -- its fingerprint.
  268 sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub
  269 sptModuleInitCode _        _        [] = mempty
  270 sptModuleInitCode platform this_mod entries = CStub $ vcat
  271     [ text "static void hs_spt_init_" <> ppr this_mod
  272            <> text "(void) __attribute__((constructor));"
  273     , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
  274     , braces $ vcat $
  275         [  text "static StgWord64 k" <> int i <> text "[2] = "
  276            <> pprFingerprint fp <> semi
  277         $$ text "extern StgPtr "
  278            <> (pdoc platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
  279         $$ text "hs_spt_insert" <> parens
  280              (hcat $ punctuate comma
  281                 [ char 'k' <> int i
  282                 , char '&' <> pdoc platform (mkClosureLabel (idName n) (idCafInfo n))
  283                 ]
  284              )
  285         <> semi
  286         |  (i, SptEntry n fp) <- zip [0..] entries
  287         ]
  288     , text "static void hs_spt_fini_" <> ppr this_mod
  289            <> text "(void) __attribute__((destructor));"
  290     , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
  291     , braces $ vcat $
  292         [  text "StgWord64 k" <> int i <> text "[2] = "
  293            <> pprFingerprint fp <> semi
  294         $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
  295         | (i, (SptEntry _ fp)) <- zip [0..] entries
  296         ]
  297     ]
  298   where
  299     pprFingerprint :: Fingerprint -> SDoc
  300     pprFingerprint (Fingerprint w1 w2) =
  301       braces $ hcat $ punctuate comma
  302                  [ integer (fromIntegral w1) <> text "ULL"
  303                  , integer (fromIntegral w2) <> text "ULL"
  304                  ]