summaryrefslogtreecommitdiff
path: root/compiler/GHC/StgToJS/UnitUtils.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/StgToJS/UnitUtils.hs')
-rw-r--r--compiler/GHC/StgToJS/UnitUtils.hs85
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