Reorganisation of the source tree

Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.

The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level.  The build system now makes no
pretense at being multi-project, it is just the GHC build system.

No doubt this will break many things, and there will be a period of
instability while we fix the dependencies.  A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.

1 files changed, 268 insertions, 0 deletions

diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs
new file mode 100644
index 0000000000..875f1d6331
--- /dev/null
+++ b/compiler/ghci/ByteCodeLink.lhs
@@ -0,0 +1,268 @@
+%
+% (c) The University of Glasgow 2000
+%
+\section[ByteCodeLink]{Bytecode assembler and linker}
+
+\begin{code}
+
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
+module ByteCodeLink ( 
+	HValue, 
+	ClosureEnv, emptyClosureEnv, extendClosureEnv,
+	linkBCO, lookupStaticPtr
+  ) where
+
+#include "HsVersions.h"
+
+import ByteCodeItbls	( ItblEnv, ItblPtr )
+import ByteCodeAsm	( UnlinkedBCO(..), BCOPtr(..), sizeSS, ssElts )
+import ObjLink		( lookupSymbol )
+
+import Name		( Name,  nameModule, nameOccName, isExternalName )
+import NameEnv
+import OccName		( occNameFS )
+import PrimOp		( PrimOp, primOpOcc )
+import Module		( moduleFS )
+import FastString	( FastString(..), unpackFS, zEncodeFS )
+import Outputable
+import Panic            ( GhcException(..) )
+
+-- Standard libraries
+import GHC.Word		( Word(..) )
+
+import Data.Array.IArray ( listArray )
+import Data.Array.Base
+import GHC.Arr		( STArray(..) )
+
+import Control.Exception ( throwDyn )
+import Control.Monad	( zipWithM )
+import Control.Monad.ST ( stToIO )
+
+import GHC.Exts		( BCO#, newBCO#, unsafeCoerce#, Int#,
+			  ByteArray#, Array#, addrToHValue#, mkApUpd0# )
+
+import GHC.Arr		( Array(..) )
+import GHC.IOBase	( IO(..) )
+import GHC.Ptr		( Ptr(..) )
+import GHC.Base		( writeArray#, RealWorld, Int(..) )
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Linking interpretables into something we can run}
+%*									*
+%************************************************************************
+
+\begin{code}
+type ClosureEnv = NameEnv (Name, HValue)
+newtype HValue = HValue (forall a . a)
+
+emptyClosureEnv = emptyNameEnv
+
+extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
+extendClosureEnv cl_env pairs
+  = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Linking interpretables into something we can run}
+%*									*
+%************************************************************************
+
+\begin{code}
+{- 
+data BCO# = BCO# ByteArray# 		-- instrs   :: Array Word16#
+                 ByteArray# 		-- literals :: Array Word32#
+                 PtrArray# 		-- ptrs     :: Array HValue
+                 ByteArray#		-- itbls    :: Array Addr#
+-}
+
+linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
+linkBCO ie ce ul_bco
+   = do BCO bco# <- linkBCO' ie ce ul_bco
+	-- SDM: Why do we need mkApUpd0 here?  I *think* it's because
+	-- otherwise top-level interpreted CAFs don't get updated 
+ 	-- after evaluation.   A top-level BCO will evaluate itself and
+	-- return its value when entered, but it won't update itself.
+	-- Wrapping the BCO in an AP_UPD thunk will take care of the
+	-- update for us.
+	--
+	-- Update: the above is true, but now we also have extra invariants:
+	--   (a) An AP thunk *must* point directly to a BCO
+	--   (b) A zero-arity BCO *must* be wrapped in an AP thunk
+	--   (c) An AP is always fully saturated, so we *can't* wrap
+	--       non-zero arity BCOs in an AP thunk.
+	-- 
+	if (unlinkedBCOArity ul_bco > 0) 
+	   then return (unsafeCoerce# bco#)
+	   else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }
+
+
+linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
+linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS itblsSS)
+   -- Raises an IO exception on failure
+   = do let literals = ssElts literalsSS
+	    ptrs     = ssElts ptrsSS
+	    itbls    = ssElts itblsSS
+
+        linked_itbls    <- mapM (lookupIE ie) itbls
+        linked_literals <- mapM lookupLiteral literals
+
+        let n_literals = sizeSS literalsSS
+            n_ptrs     = sizeSS ptrsSS
+            n_itbls    = sizeSS itblsSS
+
+	ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
+
+        let 
+            ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
+
+            itbls_arr = listArray (0, n_itbls-1) linked_itbls
+                        :: UArray Int ItblPtr
+            itbls_barr = case itbls_arr of UArray lo hi barr -> barr
+
+            literals_arr = listArray (0, n_literals-1) linked_literals
+                           :: UArray Int Word
+            literals_barr = case literals_arr of UArray lo hi barr -> barr
+
+	    (I# arity#)  = arity
+
+        newBCO insns_barr literals_barr ptrs_parr itbls_barr arity# bitmap
+
+
+-- we recursively link any sub-BCOs while making the ptrs array
+mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
+mkPtrsArray ie ce n_ptrs ptrs = do
+  marr <- newArray_ (0, n_ptrs-1)
+  let 
+    fill (BCOPtrName n)     i = do
+	ptr <- lookupName ce n
+	unsafeWrite marr i ptr
+    fill (BCOPtrPrimOp op)  i = do
+ 	ptr <- lookupPrimOp op
+	unsafeWrite marr i ptr
+    fill (BCOPtrBCO ul_bco) i = do
+	BCO bco# <- linkBCO' ie ce ul_bco
+	writeArrayBCO marr i bco#
+  zipWithM fill ptrs [0..]
+  unsafeFreeze marr
+
+newtype IOArray i e = IOArray (STArray RealWorld i e)
+
+instance HasBounds IOArray where
+    bounds (IOArray marr) = bounds marr
+
+instance MArray IOArray e IO where
+    newArray lu init = stToIO $ do
+        marr <- newArray lu init; return (IOArray marr)
+    newArray_ lu = stToIO $ do
+        marr <- newArray_ lu; return (IOArray marr)
+    unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
+    unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
+
+-- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
+writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
+writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
+  case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
+  (# s#, () #) }
+
+data BCO = BCO BCO#
+
+newBCO :: ByteArray# -> ByteArray# -> Array# a
+	 -> ByteArray# -> Int# -> ByteArray# -> IO BCO
+newBCO instrs lits ptrs itbls arity bitmap
+   = IO $ \s -> case newBCO# instrs lits ptrs itbls arity bitmap s of 
+		  (# s1, bco #) -> (# s1, BCO bco #)
+
+
+lookupLiteral :: Either Word FastString -> IO Word
+lookupLiteral (Left lit)  = return lit
+lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym
+			       return (W# (unsafeCoerce# addr)) 
+     -- Can't be bothered to find the official way to convert Addr# to Word#;
+     -- the FFI/Foreign designers make it too damn difficult
+     -- Hence we apply the Blunt Instrument, which works correctly
+     -- on all reasonable architectures anyway
+
+lookupStaticPtr :: FastString -> IO (Ptr ())
+lookupStaticPtr addr_of_label_string 
+   = do let label_to_find = unpackFS addr_of_label_string
+        m <- lookupSymbol label_to_find 
+        case m of
+           Just ptr -> return ptr
+           Nothing  -> linkFail "ByteCodeLink: can't find label" 
+                                label_to_find
+
+lookupPrimOp :: PrimOp -> IO HValue
+lookupPrimOp primop
+   = do let sym_to_find = primopToCLabel primop "closure"
+        m <- lookupSymbol sym_to_find
+        case m of
+           Just (Ptr addr) -> case addrToHValue# addr of
+                                 (# hval #) -> return hval
+           Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
+
+lookupName :: ClosureEnv -> Name -> IO HValue
+lookupName ce nm
+   = case lookupNameEnv ce nm of
+        Just (_,aa) -> return aa
+        Nothing 
+           -> ASSERT2(isExternalName nm, ppr nm)
+	      do let sym_to_find = nameToCLabel nm "closure"
+                 m <- lookupSymbol sym_to_find
+                 case m of
+                    Just (Ptr addr) -> case addrToHValue# addr of
+                                          (# hval #) -> return hval
+                    Nothing         -> linkFail "ByteCodeLink.lookupCE" sym_to_find
+
+lookupIE :: ItblEnv -> Name -> IO (Ptr a)
+lookupIE ie con_nm 
+   = case lookupNameEnv ie con_nm of
+        Just (_, Ptr a) -> return (Ptr a)
+        Nothing
+           -> do -- try looking up in the object files.
+                 let sym_to_find1 = nameToCLabel con_nm "con_info"
+                 m <- lookupSymbol 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 sym_to_find2
+                             case n of
+                                Just addr -> return addr
+                                Nothing   -> linkFail "ByteCodeLink.lookupIE" 
+                                                (sym_to_find1 ++ " or " ++ sym_to_find2)
+
+linkFail :: String -> String -> IO a
+linkFail who what
+   = throwDyn (ProgramError $
+        unlines [ ""
+	        , "During interactive linking, GHCi couldn't find the following symbol:"
+		, ' ' : ' ' : what 
+		, "This may be due to you not asking GHCi to load extra object files,"
+		, "archives or DLLs needed by your current session.  Restart GHCi, specifying"
+		, "the missing library using the -L/path/to/object/dir and -lmissinglibname"
+		, "flags, or simply by naming the relevant files on the GHCi command line."
+		, "Alternatively, this link failure might indicate a bug in GHCi."
+		, "If you suspect the latter, please send a bug report to:"
+		, "  glasgow-haskell-bugs@haskell.org"
+		])
+
+-- HACKS!!!  ToDo: cleaner
+nameToCLabel :: Name -> String{-suffix-} -> String
+nameToCLabel n suffix
+   = unpackFS (zEncodeFS (moduleFS (nameModule n)))
+     ++ '_': unpackFS (zEncodeFS (occNameFS (nameOccName n))) ++ '_':suffix
+
+primopToCLabel :: PrimOp -> String{-suffix-} -> String
+primopToCLabel primop suffix
+   = let str = "GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
+     in --trace ("primopToCLabel: " ++ str)
+        str
+\end{code}
+