Move loader state into Interp

The loader state was stored into HscEnv. As we need to have two
interpreters and one loader state per interpreter in #14335, it's
natural to make the loader state a field of the Interp type.

As a side effect, many functions now only require a Interp parameter
instead of HscEnv. Sadly we can't fully free GHC.Linker.Loader of HscEnv
yet because the loader is initialised lazily from the HscEnv the first
time it is used. This is left as future work.

HscEnv may not contain an Interp value (i.e. hsc_interp :: Maybe Interp).
So a side effect of the previous side effect is that callers of the
modified functions now have to provide an Interp. It is satisfying as it
pushes upstream the handling of the case where HscEnv doesn't contain an
Interpreter. It is better than raising a panic (less partial functions,
"parse, don't validate", etc.).

3 files changed, 105 insertions, 81 deletions

diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
index c58328f57c..30f2c2b633 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -19,9 +19,6 @@ module GHC.ByteCode.Asm (
 
 import GHC.Prelude
 
-import GHC.Driver.Env
-import GHC.Driver.Session
-
 import GHC.ByteCode.Instr
 import GHC.ByteCode.InfoTable
 import GHC.ByteCode.Types
@@ -45,6 +42,7 @@ import GHC.Data.SizedSeq
 
 import GHC.StgToCmm.Layout     ( ArgRep(..) )
 import GHC.Platform
+import GHC.Platform.Profile
 
 import Control.Monad
 import Control.Monad.ST ( runST )
@@ -96,13 +94,19 @@ bcoFreeNames bco
 
 -- Top level assembler fn.
 assembleBCOs
-  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]
+  :: Interp
+  -> Profile
+  -> [ProtoBCO Name]
+  -> [TyCon]
+  -> [RemotePtr ()]
   -> Maybe ModBreaks
   -> IO CompiledByteCode
-assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
-  itblenv <- mkITbls hsc_env tycons
-  bcos    <- mapM (assembleBCO (targetPlatform (hsc_dflags hsc_env))) proto_bcos
-  (bcos',ptrs) <- mallocStrings hsc_env bcos
+assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
+  -- TODO: the profile should be bundled with the interpreter: the rts ways are
+  -- fixed for an interpreter
+  itblenv <- mkITbls interp profile tycons
+  bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos
+  (bcos',ptrs) <- mallocStrings interp bcos
   return CompiledByteCode
     { bc_bcos = bcos'
     , bc_itbls =  itblenv
@@ -118,10 +122,10 @@ assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
 --  b) For -fexternal-interpreter It's more efficient to malloc the strings
 --     as a single batch message, especially when compiling in parallel.
 --
-mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
-mallocStrings hsc_env ulbcos = do
+mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
+mallocStrings interp ulbcos = do
   let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
-  ptrs <- iservCmd hsc_env (MallocStrings bytestrings)
+  ptrs <- interpCmd interp (MallocStrings bytestrings)
   return (evalState (mapM splice ulbcos) ptrs, ptrs)
  where
   splice bco@UnlinkedBCO{..} = do
@@ -154,10 +158,12 @@ mallocStrings hsc_env ulbcos = do
   collectPtr _ = return ()
 
 
-assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
-assembleOneBCO hsc_env pbco = do
-  ubco <- assembleBCO (targetPlatform (hsc_dflags hsc_env)) pbco
-  ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]
+assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
+assembleOneBCO interp profile pbco = do
+  -- TODO: the profile should be bundled with the interpreter: the rts ways are
+  -- fixed for an interpreter
+  ubco <- assembleBCO (profilePlatform profile) pbco
+  ([ubco'], _ptrs) <- mallocStrings interp [ubco]
   return ubco'
 
 assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs
index 594a68c12b..dbd816d7d0 100644
--- a/compiler/GHC/ByteCode/InfoTable.hs
+++ b/compiler/GHC/ByteCode/InfoTable.hs
@@ -13,7 +13,6 @@ module GHC.ByteCode.InfoTable ( mkITbls ) where
 import GHC.Prelude
 
 import GHC.Driver.Session
-import GHC.Driver.Env
 
 import GHC.Platform
 import GHC.Platform.Profile
@@ -40,30 +39,30 @@ import GHC.Utils.Panic
 -}
 
 -- Make info tables for the data decls in this module
-mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv
-mkITbls hsc_env tcs =
+mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv
+mkITbls interp profile tcs =
   foldr plusNameEnv emptyNameEnv <$>
-    mapM (mkITbl hsc_env) (filter isDataTyCon tcs)
+    mapM mkITbl (filter isDataTyCon tcs)
  where
-  mkITbl :: HscEnv -> TyCon -> IO ItblEnv
-  mkITbl hsc_env tc
+  mkITbl :: TyCon -> IO ItblEnv
+  mkITbl tc
     | dcs `lengthIs` n -- paranoia; this is an assertion.
-    = make_constr_itbls hsc_env dcs
+    = make_constr_itbls interp profile dcs
        where
           dcs = tyConDataCons tc
           n   = tyConFamilySize tc
-  mkITbl _ _ = panic "mkITbl"
+  mkITbl _ = panic "mkITbl"
 
 mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
 mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
 
 -- Assumes constructors are numbered from zero, not one
-make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
-make_constr_itbls hsc_env cons =
+make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv
+make_constr_itbls interp profile cons =
+  -- TODO: the profile should be bundled with the interpreter: the rts ways are
+  -- fixed for an interpreter
   mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
  where
-  profile = targetProfile (hsc_dflags hsc_env)
-
   mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
   mk_itbl dcon conNo = do
      let rep_args = [ NonVoid prim_rep
@@ -85,6 +84,6 @@ make_constr_itbls hsc_env cons =
          constants = platformConstants platform
          tables_next_to_code = platformTablesNextToCode platform
 
-     r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really
+     r <- interpCmd interp (MkConInfoTable tables_next_to_code ptrs' nptrs_really
                               conNo (tagForCon platform dcon) descr)
      return (getName dcon, ItblPtr r)
diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs
index 5c58d319ef..50bef7972e 100644
--- a/compiler/GHC/ByteCode/Linker.hs
+++ b/compiler/GHC/ByteCode/Linker.hs
@@ -8,19 +8,22 @@
 --
 
 -- | Bytecode assembler and linker
-module GHC.ByteCode.Linker (
-        ClosureEnv, emptyClosureEnv, extendClosureEnv,
-        linkBCO, lookupStaticPtr,
-        lookupIE,
-        nameToCLabel, linkFail
-  ) where
+module GHC.ByteCode.Linker
+  ( ClosureEnv
+  , emptyClosureEnv
+  , extendClosureEnv
+  , linkBCO
+  , lookupStaticPtr
+  , lookupIE
+  , nameToCLabel
+  , linkFail
+  )
+where
 
 #include "HsVersions.h"
 
 import GHC.Prelude
 
-import GHC.Driver.Env
-
 import GHC.Runtime.Interpreter
 import GHC.ByteCode.Types
 import GHCi.RemoteTypes
@@ -65,88 +68,104 @@ extendClosureEnv cl_env pairs
 -}
 
 linkBCO
-  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
+  :: Interp
+  -> ItblEnv
+  -> ClosureEnv
+  -> NameEnv Int
+  -> RemoteRef BreakArray
   -> UnlinkedBCO
   -> IO ResolvedBCO
-linkBCO hsc_env ie ce bco_ix breakarray
+linkBCO interp ie ce bco_ix breakarray
            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
   -- fromIntegral Word -> Word64 should be a no op if Word is Word64
   -- otherwise it will result in a cast to longlong on 32bit systems.
-  lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0)
-  ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)
+  lits <- mapM (fmap fromIntegral . lookupLiteral interp ie) (ssElts lits0)
+  ptrs <- mapM (resolvePtr interp ie ce bco_ix breakarray) (ssElts ptrs0)
   return (ResolvedBCO isLittleEndian arity insns bitmap
               (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
               (addListToSS emptySS ptrs))
 
-lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
-lookupLiteral _ _ (BCONPtrWord lit) = return lit
-lookupLiteral hsc_env _ (BCONPtrLbl  sym) = do
-  Ptr a# <- lookupStaticPtr hsc_env sym
-  return (W# (int2Word# (addr2Int# a#)))
-lookupLiteral hsc_env ie (BCONPtrItbl nm)  = do
-  Ptr a# <- lookupIE hsc_env ie nm
-  return (W# (int2Word# (addr2Int# a#)))
-lookupLiteral _ _ (BCONPtrStr _) =
-  -- should be eliminated during assembleBCOs
-  panic "lookupLiteral: BCONPtrStr"
-
-lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
-lookupStaticPtr hsc_env addr_of_label_string = do
-  m <- lookupSymbol hsc_env addr_of_label_string
+lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word
+lookupLiteral interp ie ptr = case ptr of
+  BCONPtrWord lit -> return lit
+  BCONPtrLbl  sym -> do
+    Ptr a# <- lookupStaticPtr interp sym
+    return (W# (int2Word# (addr2Int# a#)))
+  BCONPtrItbl nm -> do
+    Ptr a# <- lookupIE interp ie nm
+    return (W# (int2Word# (addr2Int# a#)))
+  BCONPtrStr _ ->
+    -- should be eliminated during assembleBCOs
+    panic "lookupLiteral: BCONPtrStr"
+
+lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
+lookupStaticPtr interp addr_of_label_string = do
+  m <- lookupSymbol interp addr_of_label_string
   case m of
     Just ptr -> return ptr
     Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"
                   (unpackFS addr_of_label_string)
 
-lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
-lookupIE hsc_env ie con_nm =
+lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
+lookupIE interp ie con_nm =
   case lookupNameEnv ie con_nm of
     Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
     Nothing -> do -- try looking up in the object files.
        let sym_to_find1 = nameToCLabel con_nm "con_info"
-       m <- lookupSymbol hsc_env sym_to_find1
+       m <- lookupSymbol interp sym_to_find1
        case m of
           Just addr -> return addr
           Nothing
              -> do -- perhaps a nullary constructor?
                    let sym_to_find2 = nameToCLabel con_nm "static_info"
-                   n <- lookupSymbol hsc_env sym_to_find2
+                   n <- lookupSymbol interp sym_to_find2
                    case n of
                       Just addr -> return addr
                       Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"
                                       (unpackFS sym_to_find1 ++ " or " ++
                                        unpackFS sym_to_find2)
 
-lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())
-lookupPrimOp hsc_env primop = do
+lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
+lookupPrimOp interp primop = do
   let sym_to_find = primopToCLabel primop "closure"
-  m <- lookupSymbol hsc_env (mkFastString sym_to_find)
+  m <- lookupSymbol interp (mkFastString sym_to_find)
   case m of
     Just p -> return (toRemotePtr p)
     Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
 
 resolvePtr
-  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
+  :: Interp
+  -> ItblEnv
+  -> ClosureEnv
+  -> NameEnv Int
+  -> RemoteRef BreakArray
   -> BCOPtr
   -> IO ResolvedBCOPtr
-resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)
-  | Just ix <- lookupNameEnv bco_ix nm =
-    return (ResolvedBCORef ix) -- ref to another BCO in this group
-  | Just (_, rhv) <- lookupNameEnv ce nm =
-    return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
-  | otherwise =
-    ASSERT2(isExternalName nm, ppr nm)
-    do let sym_to_find = nameToCLabel nm "closure"
-       m <- lookupSymbol hsc_env sym_to_find
-       case m of
-         Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
-         Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
-resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =
-  ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
-resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
-  ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco
-resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =
-  return (ResolvedBCOPtrBreakArray breakarray)
+resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of
+  BCOPtrName nm
+    | Just ix <- lookupNameEnv bco_ix nm
+    -> return (ResolvedBCORef ix) -- ref to another BCO in this group
+
+    | Just (_, rhv) <- lookupNameEnv ce nm
+    -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
+
+    | otherwise
+    -> ASSERT2(isExternalName nm, ppr nm)
+       do
+          let sym_to_find = nameToCLabel nm "closure"
+          m <- lookupSymbol interp sym_to_find
+          case m of
+            Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
+            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
+
+  BCOPtrPrimOp op
+    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op
+
+  BCOPtrBCO bco
+    -> ResolvedBCOPtrBCO <$> linkBCO interp ie ce bco_ix breakarray bco
+
+  BCOPtrBreakArray
+    -> return (ResolvedBCOPtrBreakArray breakarray)
 
 linkFail :: String -> String -> IO a
 linkFail who what