1 files changed, 72 insertions, 53 deletions

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