From: simonmar <unknown>
Date: Fri, 6 Oct 2000 15:48:30 +0000 (+0000)
Subject: [project @ 2000-10-06 15:48:30 by simonmar]
X-Git-Tag: Approximately_9120_patches~3671
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8c70d86f755d94abae1a5fcf1ac31c28401e7cde;p=ghc-hetmet.git

[project @ 2000-10-06 15:48:30 by simonmar]
- Add Linker.lhs, an interface to the underlying RTS object linker
- Split off the interpreter's abstract syntax into InterpSyn.lhs
- Some minor updates to the compilation manager stuff.
---

diff --git a/ghc/compiler/ghci/CmCompile.lhs b/ghc/compiler/ghci/CmCompile.lhs
index 6382911..cbfecf0 100644
--- a/ghc/compiler/ghci/CmCompile.lhs
+++ b/ghc/compiler/ghci/CmCompile.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-2000
+% (c) The University of Glasgow, 2000
 %
 \section[CmCompile]{Compiler for GHCI}
 
diff --git a/ghc/compiler/ghci/CmFind.lhs b/ghc/compiler/ghci/CmFind.lhs
index 5f15254..c3d94eb 100644
--- a/ghc/compiler/ghci/CmFind.lhs
+++ b/ghc/compiler/ghci/CmFind.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-2000
+% (c) The University of Glasgow, 2000
 %
 \section[CmFind]{Module finder for GHCI}
 
diff --git a/ghc/compiler/ghci/CmLink.lhs b/ghc/compiler/ghci/CmLink.lhs
index 8bcb3a1..1a41571 100644
--- a/ghc/compiler/ghci/CmLink.lhs
+++ b/ghc/compiler/ghci/CmLink.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-2000
+% (c) The University of Glasgow, 2000
 %
 \section[CmLink]{Linker for GHCI}
 
@@ -8,40 +8,37 @@ module CmLink ( Linkable(..),
 		filterModuleLinkables, 
 		modname_of_linkable, is_package_linkable,
 		LinkResult(..),
-                HValue,
                 link, 
                 PLS{-abstractly!-}, emptyPLS )
-		  
 where
 
+import StgInterp	( linkIModules, ClosureEnv, ItblEnv )
+import Linker
+
 import CmStaticInfo	( PCI )
 import CmFind		( Path, PkgName )
+import InterpSyn	( UnlinkedIBind, HValue )
 import Module		( Module )
 import Outputable	( SDoc )
 import FiniteMap	( FiniteMap, emptyFM )
 import RdrName		( RdrName )
 import Digraph		( SCC )
 import Addr		( Addr )
+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
+        closure_env :: ClosureEnv,
+        itbl_env    :: ItblEnv
+	-- notionally here, but really lives in the C part of the linker:
+	--            object_symtab :: FiniteMap String Addr
      }
 
-data HValue = HValue -- fix this ... just temporary?
-
-
-link :: PCI -> [SCC Linkable] -> PLS -> IO LinkResult
-link pci linkabless pls
-   = return (error "link:unimp")
-
 data LinkResult 
    = LinkOK   PLS
    | LinkErrs PLS [SDoc]
@@ -50,12 +47,49 @@ data Unlinked
    = DotO Path
    | DotA Path
    | DotDLL Path
-   -- | Trees [StgTree RdrName]
+   | Trees [UnlinkedIBind]	-- bunch of interpretable bindings
+
+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
 
+emptyPLS :: IO PLS
+emptyPLS = return (MkPLS { closure_env = emptyFM, 
+                           itbl_env    = emptyFM })
+\end{code}
+
+\begin{code}
+link :: PCI -> [SCC Linkable] -> PLS -> IO LinkResult
+
+#ifndef GHCI_NOTYET
+link = panic "CmLink.link: not implemented"
+#else
+link pci [] pls = return (LinkOK pls)
+link pci (group:groups) pls = do
+   -- 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 MkPLS{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"
 
@@ -73,8 +107,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}
diff --git a/ghc/compiler/ghci/CmStaticInfo.lhs b/ghc/compiler/ghci/CmStaticInfo.lhs
index 329f0ba..db73aa7 100644
--- a/ghc/compiler/ghci/CmStaticInfo.lhs
+++ b/ghc/compiler/ghci/CmStaticInfo.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-2000
+% (c) The University of Glasgow, 2000
 %
 \section[CmStaticInfo]{Session-static info for the Compilation Manager}
 
diff --git a/ghc/compiler/ghci/CmSummarise.lhs b/ghc/compiler/ghci/CmSummarise.lhs
index 7ef80a9..524090f 100644
--- a/ghc/compiler/ghci/CmSummarise.lhs
+++ b/ghc/compiler/ghci/CmSummarise.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-2000
+% (c) The University of Glasgow, 2000
 %
 \section[CmSummarise]{Module summariser for GHCI}
 
@@ -141,4 +141,4 @@ clean s
         runcomment []           = []
         runcomment ('-':'}':cs) = keep cs
         runcomment (c:cs)       = runcomment cs
-\end{code}
\ No newline at end of file
+\end{code}
diff --git a/ghc/compiler/ghci/CompManager.lhs b/ghc/compiler/ghci/CompManager.lhs
index 406e3c7..f78d037 100644
--- a/ghc/compiler/ghci/CompManager.lhs
+++ b/ghc/compiler/ghci/CompManager.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1993-2000
+% (c) The University of Glasgow, 2000
 %
 \section[CompManager]{The Compilation Manager}
 
@@ -25,12 +25,11 @@ import CmFind 		( Finder, newFinder,
 import CmSummarise 	( summarise, ModSummary(..), 
 			  mi_name, ms_get_imports )
 import CmCompile 	( PCS, emptyPCS, HST, HIT, CompResult(..) )
-import CmLink 		( PLS, emptyPLS, HValue, Linkable, 
+import CmLink 		( PLS, emptyPLS, Linkable, 
 			  link, LinkResult(..), 
 			  filterModuleLinkables, modname_of_linkable,
 			  is_package_linkable )
-
-
+import InterpSyn	( HValue )
 
 cmInit :: FLAGS 
        -> PCI
diff --git a/ghc/compiler/ghci/InterpSyn.lhs b/ghc/compiler/ghci/InterpSyn.lhs
new file mode 100644
index 0000000..5349021
--- /dev/null
+++ b/ghc/compiler/ghci/InterpSyn.lhs
@@ -0,0 +1,283 @@
+%
+% (c) The University of Glasgow 2000
+%
+\section[InterpSyn]{Abstract syntax for interpretable trees}
+
+\begin{code}
+module InterpSyn {- Todo: ( ... ) -} where
+
+#include "HsVersions.h"
+
+import Id
+import RdrName
+import PrimOp
+import Outputable
+
+import PrelAddr -- tmp
+import PrelGHC  -- tmp
+
+-----------------------------------------------------------------------------
+-- The interpretable expression type
+
+data HValue = HValue  -- dummy type, actually a pointer to some Real Code.
+
+data IBind con var = IBind Id (IExpr con var)
+
+binder (IBind v e) = v
+bindee (IBind v e) = e
+
+data AltAlg  con var = AltAlg  Int{-tagNo-} [(Id,Rep)] (IExpr con var)
+data AltPrim con var = AltPrim (Lit con var) (IExpr con var)
+
+-- HACK ALERT!  A Lit may *only* be one of LitI, LitL, LitF, LitD
+type Lit con var = IExpr con var
+
+data Rep 
+  = RepI 
+  | RepP
+  | RepF
+  | RepD
+  -- we're assuming that Char# is sufficiently compatible with Int# that
+  -- we only need one rep for both.
+
+  {- Not yet:
+  | RepI8
+  | RepI64
+  -}
+  deriving Eq
+
+
+
+-- index???OffClosure needs to traverse indirection nodes.
+
+-- You can always tell the representation of an IExpr by examining
+-- its root node.
+data IExpr con var
+   = CaseAlgP  Id (IExpr con var) [AltAlg  con var] (Maybe (IExpr con var))
+   | CaseAlgI  Id (IExpr con var) [AltAlg  con var] (Maybe (IExpr con var))
+
+   | CasePrimP Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
+   | CasePrimI Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
+
+   -- saturated constructor apps; args are in heap order.
+   -- The Addrs are the info table pointers.  Descriptors refer to the
+   -- arg reps; all constructor applications return pointer rep.
+   | ConApp    con
+   | ConAppI   con (IExpr con var)
+   | ConAppP   con (IExpr con var)
+   | ConAppPP  con (IExpr con var) (IExpr con var)
+   | ConAppPPP con (IExpr con var) (IExpr con var) (IExpr con var)
+
+   | PrimOpI PrimOp [(IExpr con var)]
+   | PrimOpP PrimOp [(IExpr con var)]
+
+   | NonRecP (IBind con var) (IExpr con var)
+   | RecP    [IBind con var] (IExpr con var)
+
+   | NonRecI (IBind con var) (IExpr con var)
+   | RecI    [IBind con var] (IExpr con var)
+
+   | LitI   Int#
+   | LitF   Float#
+   | LitD   Double#
+   | LitS   FAST_STRING
+
+   {- not yet:
+   | LitB   Int8#
+   | LitL   Int64#
+   -}
+
+   | Native var	  -- pointer to a Real Closure
+
+   | VarP   Id
+   | VarI   Id
+   | VarF   Id
+   | VarD   Id
+
+	-- LamXY indicates a function of reps X -> Y
+	-- ie var rep = X, result rep = Y
+	-- NOTE: repOf (LamXY _ _) = RepI regardless of X and Y
+	--
+   | LamPP  Id (IExpr con var)
+   | LamPI  Id (IExpr con var)
+   | LamPF  Id (IExpr con var)
+   | LamPD  Id (IExpr con var)
+   | LamIP  Id (IExpr con var)
+   | LamII  Id (IExpr con var)
+   | LamIF  Id (IExpr con var)
+   | LamID  Id (IExpr con var)
+   | LamFP  Id (IExpr con var)
+   | LamFI  Id (IExpr con var)
+   | LamFF  Id (IExpr con var)
+   | LamFD  Id (IExpr con var)
+   | LamDP  Id (IExpr con var)
+   | LamDI  Id (IExpr con var)
+   | LamDF  Id (IExpr con var)
+   | LamDD  Id (IExpr con var)
+
+	-- AppXY means apply a fn (always of Ptr rep) to 
+	-- an arg of rep X giving result of Rep Y
+	-- therefore: repOf (AppXY _ _) = RepY
+   | AppPP  (IExpr con var) (IExpr con var)
+   | AppPI  (IExpr con var) (IExpr con var)
+   | AppPF  (IExpr con var) (IExpr con var)
+   | AppPD  (IExpr con var) (IExpr con var)
+   | AppIP  (IExpr con var) (IExpr con var)
+   | AppII  (IExpr con var) (IExpr con var)
+   | AppIF  (IExpr con var) (IExpr con var)
+   | AppID  (IExpr con var) (IExpr con var)
+   | AppFP  (IExpr con var) (IExpr con var)
+   | AppFI  (IExpr con var) (IExpr con var)
+   | AppFF  (IExpr con var) (IExpr con var)
+   | AppFD  (IExpr con var) (IExpr con var)
+   | AppDP  (IExpr con var) (IExpr con var)
+   | AppDI  (IExpr con var) (IExpr con var)
+   | AppDF  (IExpr con var) (IExpr con var)
+   | AppDD  (IExpr con var) (IExpr con var)
+
+
+showExprTag :: IExpr c v -> String
+showExprTag expr
+   = case expr of
+        CaseAlgP  _ _ _ _ -> "CaseAlgP"
+        CasePrimP _ _ _ _ -> "CasePrimP"
+        CaseAlgI  _ _ _ _ -> "CaseAlgI"
+        CasePrimI _ _ _ _ -> "CasePrimI"
+        ConApp _          -> "ConApp"
+        ConAppI _ _       -> "ConAppI"
+        ConAppP _ _       -> "ConAppP"
+        ConAppPP _ _ _    -> "ConAppPP"
+        ConAppPPP _ _ _ _ -> "ConAppPPP"
+        PrimOpI _ _       -> "PrimOpI"
+        NonRecP _ _       -> "NonRecP"
+        RecP _ _          -> "RecP"
+        NonRecI _ _       -> "NonRecI"
+        RecI _ _          -> "RecI"
+        LitI _            -> "LitI"
+        LitS _            -> "LitS"
+        Native _          -> "Native"
+        VarP _            -> "VarP"
+        VarI _            -> "VarI"
+        LamPP _ _         -> "LamPP"
+        LamPI _ _         -> "LamPI"
+        LamIP _ _         -> "LamIP"
+        LamII _ _         -> "LamII"
+        AppPP _ _         -> "AppPP"
+        AppPI _ _         -> "AppPI"
+        AppIP _ _         -> "AppIP"
+        AppII _ _         -> "AppII"
+        other             -> "(showExprTag:unhandled case)"
+
+-----------------------------------------------------------------------------
+-- Instantiations of the IExpr type
+
+type UnlinkedIExpr = IExpr RdrName RdrName
+type LinkedIExpr   = IExpr Addr    HValue
+
+type UnlinkedIBind = IBind RdrName RdrName
+type LinkedIBind   = IBind Addr    HValue
+
+type UnlinkedAltAlg  = AltAlg  RdrName RdrName
+type LinkedAltAlg    = AltAlg  Addr HValue
+
+type UnlinkedAltPrim = AltPrim RdrName RdrName
+type LinkedAltPrim = AltPrim Addr HValue
+
+-----------------------------------------------------------------------------
+-- Pretty printing
+
+instance Outputable HValue where
+   ppr x = text (show (A# (unsafeCoerce# x :: Addr#)))
+        -- ptext SLIT("<O>")  -- unidentified lurking object
+
+pprIBind :: (Outputable var, Outputable con) => IBind con var -> SDoc
+pprIBind (IBind v e) = ppr v <+> char '=' <+> pprIExpr e
+
+pprAltAlg (AltAlg tag vars rhs)
+   = text "Tag_" <> int tag <+> hsep (map ppr vars)
+     <+> text "->" <+> pprIExpr rhs
+
+pprAltPrim (AltPrim tag rhs)
+   = pprIExpr tag <+> text "->" <+> pprIExpr rhs
+
+instance Outputable Rep where
+   ppr RepI = text "I"
+   ppr RepP = text "P"
+
+instance Outputable Addr where
+   ppr addr = text (show addr)
+
+pprDefault Nothing = text "NO_DEFAULT"
+pprDefault (Just e) = text "DEFAULT ->" $$ nest 2 (pprIExpr e)
+
+pprIExpr :: (Outputable var, Outputable con) => IExpr con var -> SDoc
+pprIExpr (expr:: IExpr con var)
+   = case expr of
+        PrimOpI op args -> doPrimOp 'I' op args
+        PrimOpP op args -> doPrimOp 'P' op args
+
+        VarI v    -> ppr v
+        VarP v    -> ppr v
+        LitI i#   -> int (I# i#) <> char '#'
+        LitS s    -> char '"' <> ptext s <> char '"'
+
+        LamPP v e -> doLam "PP" v e
+        LamPI v e -> doLam "PI" v e
+        LamIP v e -> doLam "IP" v e
+        LamII v e -> doLam "II" v e
+
+        AppPP f a -> doApp "PP" f a
+        AppPI f a -> doApp "PI" f a
+        AppIP f a -> doApp "IP" f a
+        AppII f a -> doApp "II" f a
+
+	Native v  -> ptext SLIT("Native") <+> ppr v
+
+        CasePrimI b sc alts def -> doCasePrim 'I' b sc alts def
+        CasePrimP b sc alts def -> doCasePrim 'P' b sc alts def
+
+        CaseAlgI b sc alts def -> doCaseAlg 'I' b sc alts def
+        CaseAlgP b sc alts def -> doCaseAlg 'P' b sc alts def
+
+        NonRecP bind body -> doNonRec 'P' bind body
+	NonRecI bind body -> doNonRec 'I' bind body
+
+        ConApp    i          -> doConApp "" i ([] :: [IExpr con var])
+        ConAppI   i a1       -> doConApp "" i [a1]
+        ConAppP   i a1       -> doConApp "" i [a1]
+        ConAppPP  i a1 a2    -> doConApp "" i [a1,a2]
+        ConAppPPP i a1 a2 a3 -> doConApp "" i [a1,a2,a3]
+
+        other     -> text "pprIExpr: unimplemented tag:" 
+                     <+> text (showExprTag other)
+     where
+        doConApp repstr itbl args
+           = text "Con" <> text repstr
+             <+> char '[' <> hsep (map pprIExpr args) <> char ']'
+
+        doPrimOp repchar op args
+           = char repchar <> ppr op <+> char '[' <> hsep (map pprIExpr args) <> char ']'
+
+        doNonRec repchr bind body
+           = vcat [text "let" <> char repchr <+> pprIBind bind, text "in", pprIExpr body]
+
+        doCasePrim repchr b sc alts def
+           = sep [text "CasePrim" <> char repchr 
+                     <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
+                  nest 2 (vcat (map pprAltPrim alts) $$ pprDefault def),
+                  char '}'
+                 ]
+
+        doCaseAlg repchr b sc alts def
+           = sep [text "CaseAlg" <> char repchr 
+                     <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
+                  nest 2 (vcat (map pprAltAlg alts) $$ pprDefault def),
+                  char '}'
+                 ]
+
+        doApp repstr f a
+           = text "(@" <> text repstr <+> pprIExpr f <+> pprIExpr a <> char ')'
+        doLam repstr v e 
+           = (char '\\' <> text repstr <+> ppr v <+> text "->") $$ pprIExpr e
+
+\end{code}
diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs
new file mode 100644
index 0000000..ab1552a
--- /dev/null
+++ b/ghc/compiler/ghci/Linker.lhs
@@ -0,0 +1,90 @@
+%
+% (c) The University of Glasgow, 2000
+%
+\section[Linker]{The In-Memory Object File Linker}
+
+\begin{code}
+{-# OPTIONS -#include "Linker.h" #-}
+module Linker ( 
+#ifdef GHCI
+   loadObj,      -- :: String -> IO ()
+   unloadObj,    -- :: String -> IO ()
+   lookupSymbol, -- :: String -> IO (Maybe Addr)
+   resolveObjs,  -- :: IO ()
+   linkPrelude -- tmp
+#endif
+  )  where
+
+import IO
+import Exception
+import Addr
+import PrelByteArr
+import PrelPack (packString)
+
+#ifdef GHCI
+linkPrelude = do
+  hPutStr stderr "Loading HSstd_cbits.o..."
+  loadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/cbits/HSstd_cbits.o"
+  hPutStr stderr "done.\n"
+  hPutStr stderr "Resolving..."
+  resolveObjs
+  hPutStr stderr "done.\n"
+  hPutStr stderr "Loading HSstd.o..."
+  loadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/HSstd.o"
+  hPutStr stderr "done.\n"
+  hPutStr stderr "Resolving..."
+  resolveObjs
+  hPutStr stderr "done.\n"
+{-
+  hPutStr stderr "Unloading HSstd.o..."
+  unloadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/HSstd.o"
+  hPutStr stderr "done.\n"
+  unloadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/cbits/HSstd_cbits.o"
+  hPutStr stderr "done.\n"
+-}
+
+-- ---------------------------------------------------------------------------
+-- RTS Linker Interface
+-- ---------------------------------------------------------------------------
+
+lookupSymbol str = do
+   addr <- c_lookupSymbol (packString str)
+   if addr == nullAddr
+	then return Nothing
+	else return (Just addr)
+
+loadObj str = do
+   r <- c_loadObj (packString str)
+   if (r == 0)
+	then error "loadObj: failed"
+	else return ()
+
+unloadObj str = do
+   r <- c_unloadObj (packString str)
+   if (r == 0)
+	then error "unloadObj: failed"
+	else return ()
+
+resolveObjs = do
+   r <- c_resolveObjs
+   if (r == 0)
+	then error "resolveObjs: failed"
+	else return ()
+
+
+type PackedString = ByteArray Int
+
+foreign import "lookupSymbol" unsafe
+   c_lookupSymbol :: PackedString -> IO Addr
+
+foreign import "loadObj" unsafe
+   c_loadObj :: PackedString -> IO Int
+
+foreign import "unloadObj" unsafe
+   c_unloadObj :: PackedString -> IO Int
+
+foreign import "resolveObjs" unsafe
+   c_resolveObjs :: IO Int
+
+#endif /* GHCI */
+\end{code}