diff options
Diffstat (limited to 'compiler/GHC/StgToJS/UnitUtils.hs')
-rw-r--r-- | compiler/GHC/StgToJS/UnitUtils.hs | 85 |
1 files changed, 83 insertions, 2 deletions
diff --git a/compiler/GHC/StgToJS/UnitUtils.hs b/compiler/GHC/StgToJS/UnitUtils.hs index 61886f43f0..75c3c616d5 100644 --- a/compiler/GHC/StgToJS/UnitUtils.hs +++ b/compiler/GHC/StgToJS/UnitUtils.hs @@ -4,13 +4,22 @@ module GHC.StgToJS.UnitUtils ( unitModuleString , moduleGlobalSymbol , moduleExportsSymbol - ) -where + , getPackageName + , encodeModule + , ghcjsPrimUnit + , ghcjsThUnit + ) where import GHC.Data.ShortText as ST import GHC.Unit.Module +import GHC.Unit.Info +import GHC.Unit.State +import GHC.Unit.Env +import GHC.Unit.Home import GHC.Utils.Encoding +import GHC.Driver.Env.Types +import GHC.Driver.Session import GHC.Prelude @@ -36,3 +45,75 @@ moduleExportsSymbol m = mconcat , ST.pack (zEncodeString $ unitModuleString m) , "_<exports>" ] + +-- FIXME: Use FastString +encodeModule :: HscEnv -> Module -> String +encodeModule env k + | isGhcjsPrimUnit env (moduleUnitId k) = "ghcjs-prim" + | isGhcjsThUnit env (moduleUnitId k) = "ghcjs-th" + | otherwise = unitModuleString k + +{- + some packages are wired into GHCJS, but not GHC + make sure we don't version them in the output + since the RTS uses thins from them +-} + +-- FIXME: Jeff (2022,03): I've swapped DynFlags for HscEnv to gain access to the +-- UnitState for these checks. Unsure if this is a great idea or even workable. +-- In either case it will proliferate DynFlags throughout the Linker. So the fix +-- should be to add flags to the Linker config so we do not need to carry HscEnv +-- or DynFlags around. +isGhcjsPrimUnit :: HscEnv -> UnitId -> Bool +isGhcjsPrimUnit env pkgKey + = pn == "ghcjs-prim" || -- FIXME: Jeff (2022,03): use UnitID only instead of + -- a hacky String comparison, same for + -- @isGhcjsThUnit@ + (GHC.Prelude.null pn && pkgKey == home_uid && + elem "-DBOOTING_PACKAGE=ghcjs-prim" (opt_P $ hsc_dflags env)) + where + pn = unitIdString . ue_current_unit $ hsc_unit_env env + -- FIXME: Jeff (2022,03): remove call to unsafe. Only using this because I + -- am unsure when exactly the home unit for the GhcJS prims gets + -- instantiated + home_uid = homeUnitId . ue_unsafeHomeUnit $ hsc_unit_env env + +isGhcjsThUnit :: HscEnv -> UnitId -> Bool +isGhcjsThUnit env pkgKey + = pn == "ghcjs-th" || + (GHC.Prelude.null pn && pkgKey == home_uid && + elem "-DBOOTING_PACKAGE=ghcjs-th" (opt_P $ hsc_dflags env)) + where + home_uid = homeUnitId . ue_unsafeHomeUnit $ hsc_unit_env env + pn = unitIdString . ue_current_unit $ hsc_unit_env env + +-- FIXME: Jeff (2022,03): These return a UnitId, but I think they should be +-- @RealUnit (Definite UnitId). Per the description of @GenUnit@ in +-- Ghc.Unit.Types: a RealUnit is a UnitId that is closed or fully instantiated. +-- These should be fully instantiated, and Definite. See Note [Wired-in units] +-- in GHC.Unit.Types for a similar scenario for the NCG +ghcjsPrimUnit :: UnitState -> UnitId +ghcjsPrimUnit env = + case prims of + ((_,k):_) -> k + _ -> error "Package `ghcjs-prim' is required to link executables" + where + prims = filter ((=="ghcjs-prim").fst) + (searchModule env (mkModuleName "GHCJS.Prim")) + +ghcjsThUnit :: UnitState -> UnitId +ghcjsThUnit env = + case prims of + ((_,k):_) -> k + _ -> error "Package `ghcjs-th' is required to link executables" + where + prims = filter ((=="ghcjs-th").fst) + (searchModule env (mkModuleName "GHCJS.Prim.TH.Eval")) + +searchModule :: UnitState -> ModuleName -> [(String, UnitId)] +searchModule env = + fmap ((\k -> (getPackageName env k, k)) . moduleUnitId . fst) + . lookupModuleInAllUnits env + +getPackageName :: UnitState -> UnitId -> String +getPackageName u_st = maybe "" unitPackageNameString . lookupUnitId u_st |