[project @ 2000-12-15 17:09:49 by sewardj]

Conversion of unlinked BCOs to linked BCOs.

ghc/compiler/ghci/ByteCodeGen.lhs

@@ -4,7 +4,7 @@
 \section[ByteCodeGen]{Generate bytecode from Core}
 
 \begin{code}
-module ByteCodeGen ( byteCodeGen, assembleBCO ) where
+module ByteCodeGen ( byteCodeGen, linkIModules ) where
 
 #include "HsVersions.h"
 
@@ -25,30 +25,35 @@ import DataCon		( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
 			  dataConRepArgTys )
 import TyCon		( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
 import Class		( Class, classTyCon )
-import Util		( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
+import Util		( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem, global )
 import Var		( isTyVar )
 import VarSet		( VarSet, varSetElems )
 import PrimRep		( getPrimRepSize, isFollowableRep )
 import Constants	( wORD_SIZE )
 import CmdLineOpts	( DynFlags, DynFlag(..) )
 import ErrUtils		( showPass, dumpIfSet_dyn )
-import UniqSet		( emptyUniqSet )
 import ClosureInfo	( mkVirtHeapOffsets )
 
 import List		( intersperse )
 import Monad		( foldM )
 import ST		( runST )
-import MArray		( MArray(..), IOArray, IOUArray, HasBounds(..),
+import MArray		( MArray(..), IOArray, IOUArray, HasBounds(..), freeze, 
+		          mapArray,
 			  castSTUArray, readWord32Array,
 			  newFloatArray, writeFloatArray,
 			  newDoubleArray,  writeDoubleArray,
 			  newIntArray, writeIntArray,
 			  newAddrArray, writeAddrArray )
-import Foreign		( Storable(..), Word8, Word16, Word32, Ptr, 
+import Foreign		( Storable(..), Word8, Word16, Word32, Ptr(..), 
 			  malloc, castPtr, plusPtr )
 import Addr		( Addr, addrToInt, nullAddr )
 import Bits		( Bits(..), shiftR )
---import CTypes		( )
+
+import PrelGHC		( BCO#, newBCO#, unsafeCoerce#, ByteArray#, Array# )
+import IOExts		( IORef, readIORef, writeIORef, fixIO )
+import ArrayBase	
+import PrelArr		( Array(..) )
+import PrelIOBase	( IO(..) )
 \end{code}
 
 Entry point.
@@ -78,15 +83,21 @@ byteCodeGen dflags binds local_tycons local_classes
 
         return (bcos, itblenv)
         
--- TEMPORARY !
-data UnlinkedBCO 
-   = UnlinkedBCO (IOUArray Int Word16)	-- insns
-                 (IOUArray Int Word32)	-- literals
-                 (IOArray Int Name)	-- ptrs
-                 (IOArray Int Name)	-- itbl refs
+
+data UnlinkedBCO
+   = UnlinkedBCO Name
+                 Int (IOUArray Int Word16)	-- insns
+                 Int (IOUArray Int Word32)	-- literals
+                 Int (IOArray Int Name)		-- ptrs
+                 Int (IOArray Int Name)		-- itbl refs
+
+nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _ _ _ _ _) = nm
 
 -- needs a proper home
 type ItblEnv    = FiniteMap Name (Ptr StgInfoTable)
+type ClosureEnv = FiniteMap Name HValue
+data HValue = HValue  -- dummy type, actually a pointer to some Real Code.
+
 \end{code}
 
 
@@ -785,11 +796,15 @@ assembleBCO (ProtoBCO nm instrs origin)
 
          -- unwrap the expandable arrays
          let final_insns = stuffXIOU insns
-             final_nptrs = stuffXIOU lits
+             final_lits  = stuffXIOU lits
              final_ptrs  = stuffXIO  ptrs
              final_itbls = stuffXIO  itbls
 
-         return (UnlinkedBCO final_insns final_nptrs final_ptrs final_itbls)
+         return (UnlinkedBCO nm
+                             (usedXIOU insns) final_insns 
+                             (usedXIOU lits)  final_lits 
+                             (usedXIO  ptrs)  final_ptrs 
+                             (usedXIO  itbls) final_itbls)
 
 
 -- instrs nonptrs ptrs itbls
@@ -1085,6 +1100,161 @@ addToXIOArray (XIOArray n_arr arr) x
 
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Linking interpretables into something we can run}
+%*									*
+%************************************************************************
+
+\begin{code}
+
+{- 
+data UnlinkedBCO
+   = UnlinkedBCO Int (IOUArray Int Word16)	-- #insns insns
+                 Int (IOUArray Int Word32)	-- #literals literals
+                 Int (IOArray Int Name)		-- #ptrs ptrs
+                 Int (IOArray Int Name)		-- #itblrefs itblrefs
+
+data BCO# = BCO# ByteArray# 		-- instrs   :: array Word16#
+                 ByteArray# 		-- literals :: array Word32#
+                 PtrArray# 		-- ptrs     :: Array HValue
+                 ByteArray#		-- itbls    :: Array Addr#
+-}
+
+data LinkedBCO = LinkedBCO BCO#
+
+
+
+GLOBAL_VAR(v_cafTable, [], [HValue])
+
+addCAF :: HValue -> IO ()
+addCAF x = do xs <- readIORef v_cafTable; writeIORef v_cafTable (x:xs)
+
+linkIModules :: ItblEnv    -- incoming global itbl env; returned updated
+	     -> ClosureEnv -- incoming global closure env; returned updated
+	     -> [([UnlinkedBCO], ItblEnv)]
+	     -> IO ([HValue], ItblEnv, ClosureEnv)
+linkIModules gie gce mods = do
+  let (bcoss, ies) = unzip mods
+      bcos = concat bcoss
+      top_level_binders = map nameOfUnlinkedBCO bcos
+      final_gie = foldr plusFM gie ies
+  
+  (new_bcos, new_gce) <-
+    fixIO (\ ~(new_bcos, new_gce) -> do
+
+      new_bcos <- linkBCOs final_gie new_gce bcos
+
+      let new_gce = addListToFM gce (zip top_level_binders new_bcos)
+
+      return (new_bcos, new_gce))
+
+  return (new_bcos, final_gie, new_gce)
+
+
+
+linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO] 
+         -> IO [HValue]   -- IO [BCO#] really
+linkBCOs ie ce binds = mapM (linkBCO ie ce) binds
+
+linkBCO ie ce (UnlinkedBCO nm 
+                           n_insns insns n_literals literals 
+                           n_ptrs ptrs n_itbls itbls)
+   = do linked_ptrs <- mapArray (lookupCE ce) ptrs
+        linked_itbls <- mapArray (lookupIE ie) itbls
+
+        ptrs_froz <- freeze linked_ptrs
+        let ptrs_parr = case ptrs_froz of Array lo hi parr -> parr
+
+        insns_froz <- freeze insns
+        let insns_barr = case insns_froz of UArray lo hi barr -> barr
+
+        literals_froz <- freeze literals
+        let literals_barr = case literals_froz of UArray lo hi barr -> barr
+
+        itbls_froz <- freeze linked_itbls
+        let itbls_barr = case itbls_froz of UArray lo hi barr -> barr
+
+        BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr
+     
+        return (unsafeCoerce# bco#)
+
+data BCO = BCO BCO#
+
+newBCO :: ByteArray# -> ByteArray# -> Array# a -> ByteArray# -> IO BCO
+newBCO a b c d = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
+
+
+lookupCE :: ClosureEnv -> Name -> HValue
+lookupCE ce nm 
+   = case lookupFM ce nm of
+        Just aa -> unsafeCoerce# aa
+        Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)
+
+lookupIE :: ItblEnv -> Name -> Addr
+lookupIE ie nm 
+   = case lookupFM ie nm of
+        Just (Ptr a) -> a
+        Nothing      -> pprPanic "ByteCodeGen.lookupIE" (ppr nm)
+
+
+
+{-
+lookupCon ie con = 
+  case lookupFM ie con of
+    Just (Ptr addr) -> return addr
+    Nothing   -> do
+	-- try looking up in the object files.
+        m <- lookupSymbol (nameToCLabel con "con_info")
+	case m of
+	    Just addr -> return addr
+  	    Nothing   -> pprPanic "linkIExpr" (ppr con)
+
+-- nullary constructors don't have normal _con_info tables.
+lookupNullaryCon ie con =
+  case lookupFM ie con of
+    Just (Ptr addr) -> return (ConApp addr)
+    Nothing -> do
+	-- try looking up in the object files.
+	m <- lookupSymbol (nameToCLabel con "closure")
+	case m of
+	    Just (A# addr) -> return (Native (unsafeCoerce# addr))
+	    Nothing   -> pprPanic "lookupNullaryCon" (ppr con)
+
+
+lookupNative ce var =
+  unsafeInterleaveIO (do
+      case lookupFM ce var of
+    	Just e  -> return (Native e)
+    	Nothing -> do
+    	    -- try looking up in the object files.
+    	    let lbl = (nameToCLabel var "closure")
+    	    m <- lookupSymbol lbl
+    	    case m of
+    		Just (A# addr)
+		    -> do addCAF (unsafeCoerce# addr)
+			  return (Native (unsafeCoerce# addr))
+    		Nothing   -> pprPanic "linkIExpr" (ppr var)
+  )
+
+-- some VarI/VarP refer to top-level interpreted functions; we change
+-- them into Natives here.
+lookupVar ce f v =
+  unsafeInterleaveIO (
+	case lookupFM ce (getName v) of
+	    Nothing -> return (f v)
+	    Just e  -> return (Native e)
+  )
+
+-- HACK!!!  ToDo: cleaner
+nameToCLabel :: Name -> String{-suffix-} -> String
+nameToCLabel n suffix =
+  _UNPK_(moduleNameFS (rdrNameModule rn)) 
+  ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
+  where rn = toRdrName n
+-}
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection{Manufacturing of info tables for DataCons}