X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fghci%2FCmLink.lhs;h=3ec42dd77c89cf7a88a35b2abd16e0de84f8039f;hb=0075a4cd7eb75a28b4978255e696a9a583172355;hp=8bcb3a1fa5378488ca879c8882c0f3835d83441c;hpb=85dfd24027b448265b4cb956ca3c1f7628440cdf;p=ghc-hetmet.git

diff --git a/ghc/compiler/ghci/CmLink.lhs b/ghc/compiler/ghci/CmLink.lhs
index 8bcb3a1..3ec42dd 100644
--- a/ghc/compiler/ghci/CmLink.lhs
+++ b/ghc/compiler/ghci/CmLink.lhs
@@ -1,60 +1,128 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-2000
+% (c) The University of Glasgow, 2000
 %
 \section[CmLink]{Linker for GHCI}
 
 \begin{code}
-module CmLink ( Linkable(..), 
+module CmLink ( Linkable(..),  Unlinked(..),
 		filterModuleLinkables, 
 		modname_of_linkable, is_package_linkable,
 		LinkResult(..),
-                HValue,
                 link, 
-                PLS{-abstractly!-}, emptyPLS )
-		  
+                PersistentLinkerState{-abstractly!-}, emptyPLS )
 where
 
-import CmStaticInfo	( PCI )
-import CmFind		( Path, PkgName )
+import StgInterp	( linkIModules, ClosureEnv, ItblEnv )
+import Linker		( loadObj, resolveObjs )
+import CmStaticInfo	( PackageConfigInfo )
+import Module		( ModuleName, PackageName )
+import InterpSyn	( UnlinkedIBind, HValue, binder )
 import Module		( Module )
 import Outputable	( SDoc )
-import FiniteMap	( FiniteMap, emptyFM )
-import RdrName		( RdrName )
-import Digraph		( SCC )
-import Addr		( Addr )
+import FiniteMap	( emptyFM )
+import Digraph		( SCC(..), flattenSCC )
+import Outputable
 import Panic		( panic )
 
 #include "HsVersions.h"
-
 \end{code}
 
 \begin{code}
-data PLS 
-   = MkPLS {
-        source_symtab :: FiniteMap RdrName HValue,
-        object_symtab :: FiniteMap String Addr
-     }
-
-data HValue = HValue -- fix this ... just temporary?
+data PersistentLinkerState 
+   = PersistentLinkerState {
+	-- Current global mapping from RdrNames to closure addresses
+        closure_env :: ClosureEnv,
 
+	-- the current global mapping from RdrNames of DataCons to 
+	-- info table addresses.
+	-- When a new Unlinked is linked into the running image, or an existing
+	-- module in the image is replaced, the itbl_env must be updated
+	-- appropriately.
+        itbl_env    :: ItblEnv
 
-link :: PCI -> [SCC Linkable] -> PLS -> IO LinkResult
-link pci linkabless pls
-   = return (error "link:unimp")
+	-- notionally here, but really lives in the C part of the linker:
+	--            object_symtab :: FiniteMap String Addr
+     }
 
 data LinkResult 
-   = LinkOK   PLS
-   | LinkErrs PLS [SDoc]
+   = LinkOK   PersistentLinkerState
+   | LinkErrs PersistentLinkerState [SDoc]
 
 data Unlinked
-   = DotO Path
-   | DotA Path
-   | DotDLL Path
-   -- | Trees [StgTree RdrName]
+   = DotO FilePath
+   | DotA FilePath
+   | DotDLL FilePath
+   | Trees [UnlinkedIBind] ItblEnv  -- bunch of interpretable bindings, +
+				    -- a mapping from DataCons to their itbls
+
+instance Outputable Unlinked where
+   ppr (DotO path)   = text "DotO" <+> text path
+   ppr (DotA path)   = text "DotA" <+> text path
+   ppr (DotDLL path) = text "DotDLL" <+> text path
+   ppr (Trees binds _) = text "Trees" <+> ppr (map binder binds)
+
+
+isObject (DotO _) = True
+isObject (DotA _) = True
+isObject (DotDLL _) = True
+isObject _ = False
+
+isInterpretable (Trees _ _) = True
+isInterpretable _ = False
 
 data Linkable
-   = LM {-should be:Module-} String{- == ModName-} [Unlinked]
-   | LP PkgName
+   = LM ModuleName [Unlinked]
+   | LP PackageName
+
+instance Outputable Linkable where
+   ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds
+   ppr (LP package_nm)       = text "LinkableP" <+> ptext package_nm
+
+emptyPLS :: IO PersistentLinkerState
+emptyPLS = return (PersistentLinkerState { closure_env = emptyFM, 
+                                           itbl_env    = emptyFM })
+\end{code}
+
+\begin{code}
+link :: PackageConfigInfo 
+     -> [SCC Linkable] 
+     -> PersistentLinkerState 
+     -> IO LinkResult
+
+#ifndef GHCI_NOTYET
+--link = panic "CmLink.link: not implemented"
+link pci groups pls1
+   = do putStrLn "Hello from the Linker!"
+        putStrLn (showSDoc (vcat (map ppLinkableSCC groups)))
+        putStrLn "Bye-bye from the Linker!"
+        return (LinkOK pls1)
+
+ppLinkableSCC :: SCC Linkable -> SDoc
+ppLinkableSCC = ppr . flattenSCC
+
+#else
+
+
+link pci [] pls = return (LinkOK pls)
+link pci (groupSCC:groups) pls = do
+   let group = flattenSCC groupSCC
+   -- the group is either all objects or all interpretable, for now
+   if all isObject group
+	then do mapM loadObj [ file | DotO file <- group ]
+	        resolveObjs
+		link pci groups pls
+    else if all isInterpretable group
+	then do (new_closure_env, new_itbl_env) <-
+		   linkIModules	(closure_env pls)
+				(itbl_env pls)
+				[ trees | Trees trees <- group ]
+	        link pci groups (PersistentLinkerState{
+				   closure_env=new_closure_env,
+				   itbl_env=new_itbl_env})
+    else
+	return (LinkErrs pls (ptext SLIT("linker: group must contain all objects or all interpreted modules")))
+#endif
+
 
 modname_of_linkable (LM nm _) = nm
 modname_of_linkable (LP _)    = panic "modname_of_linkable: package"
@@ -62,7 +130,7 @@ modname_of_linkable (LP _)    = panic "modname_of_linkable: package"
 is_package_linkable (LP _)   = True
 is_package_linkable (LM _ _) = False
 
-filterModuleLinkables :: (String{- ==ModName-} -> Bool) 
+filterModuleLinkables :: (ModuleName -> Bool) 
                       -> [Linkable] 
                       -> [Linkable]
 filterModuleLinkables p [] = []
@@ -73,8 +141,4 @@ filterModuleLinkables p (li:lis)
      where
         dump   = filterModuleLinkables p lis
         retain = li : dump
-
-emptyPLS :: IO PLS
-emptyPLS = return (MkPLS { source_symtab = emptyFM, 
-                           object_symtab = emptyFM })
 \end{code}