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, 423 insertions, 0 deletions

diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
new file mode 100644
index 0000000000..2c90a7dc6e
--- /dev/null
+++ b/compiler/prelude/ForeignCall.lhs
@@ -0,0 +1,423 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Foreign]{Foreign calls}
+
+\begin{code}
+module ForeignCall (
+	ForeignCall(..),
+	Safety(..), playSafe, playThreadSafe,
+
+	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
+	CCallSpec(..), 
+	CCallTarget(..), isDynamicTarget,
+	CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
+
+	DNCallSpec(..), DNKind(..), DNType(..),
+	withDNTypes
+    ) where
+
+#include "HsVersions.h"
+
+import FastString	( FastString, unpackFS )
+import Char		( isAlphaNum )
+import Binary
+import Outputable
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsubsection{Data types}
+%*									*
+%************************************************************************
+
+\begin{code}
+data ForeignCall
+  = CCall	CCallSpec
+  | DNCall	DNCallSpec
+  deriving( Eq )		-- We compare them when seeing if an interface
+				-- has changed (for versioning purposes)
+  {-! derive: Binary !-}
+
+-- We may need more clues to distinguish foreign calls
+-- but this simple printer will do for now
+instance Outputable ForeignCall where
+  ppr (CCall cc)  = ppr cc		
+  ppr (DNCall dn) = ppr dn
+\end{code}
+
+  
+\begin{code}
+data Safety
+  = PlaySafe		-- Might invoke Haskell GC, or do a call back, or
+			-- switch threads, etc.  So make sure things are
+			-- tidy before the call
+	Bool            -- => True, external function is also re-entrant.
+			--    [if supported, RTS arranges for the external call
+			--    to be executed by a separate OS thread, i.e.,
+			--    _concurrently_ to the execution of other Haskell threads.]
+
+  | PlayRisky		-- None of the above can happen; the call will return
+			-- without interacting with the runtime system at all
+  deriving( Eq, Show )
+	-- Show used just for Show Lex.Token, I think
+  {-! derive: Binary !-}
+
+instance Outputable Safety where
+  ppr (PlaySafe False) = ptext SLIT("safe")
+  ppr (PlaySafe True)  = ptext SLIT("threadsafe")
+  ppr PlayRisky = ptext SLIT("unsafe")
+
+playSafe :: Safety -> Bool
+playSafe PlaySafe{} = True
+playSafe PlayRisky  = False
+
+playThreadSafe :: Safety -> Bool
+playThreadSafe (PlaySafe x) = x
+playThreadSafe _ = False
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsubsection{Calling C}
+%*									*
+%************************************************************************
+
+\begin{code}
+data CExportSpec
+  = CExportStatic		-- foreign export ccall foo :: ty
+	CLabelString		-- C Name of exported function
+	CCallConv
+  {-! derive: Binary !-}
+
+data CCallSpec
+  =  CCallSpec	CCallTarget	-- What to call
+		CCallConv	-- Calling convention to use.
+		Safety
+  deriving( Eq )
+  {-! derive: Binary !-}
+\end{code}
+
+The call target:
+
+\begin{code}
+data CCallTarget
+  = StaticTarget  CLabelString  -- An "unboxed" ccall# to `fn'.
+  | DynamicTarget 		-- First argument (an Addr#) is the function pointer
+  deriving( Eq )
+  {-! derive: Binary !-}
+
+isDynamicTarget :: CCallTarget -> Bool
+isDynamicTarget DynamicTarget = True
+isDynamicTarget other	      = False
+\end{code}
+
+
+Stuff to do with calling convention:
+
+ccall:		Caller allocates parameters, *and* deallocates them.
+
+stdcall: 	Caller allocates parameters, callee deallocates.
+		Function name has @N after it, where N is number of arg bytes
+		e.g.  _Foo@8
+
+ToDo: The stdcall calling convention is x86 (win32) specific,
+so perhaps we should emit a warning if it's being used on other
+platforms.
+
+\begin{code}
+data CCallConv = CCallConv | StdCallConv
+  deriving (Eq)
+  {-! derive: Binary !-}
+
+instance Outputable CCallConv where
+  ppr StdCallConv = ptext SLIT("stdcall")
+  ppr CCallConv   = ptext SLIT("ccall")
+
+defaultCCallConv :: CCallConv
+defaultCCallConv = CCallConv
+
+ccallConvToInt :: CCallConv -> Int
+ccallConvToInt StdCallConv = 0
+ccallConvToInt CCallConv   = 1
+\end{code}
+
+Generate the gcc attribute corresponding to the given
+calling convention (used by PprAbsC):
+
+\begin{code}
+ccallConvAttribute :: CCallConv -> String
+ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
+ccallConvAttribute CCallConv   = ""
+\end{code}
+
+\begin{code}
+type CLabelString = FastString		-- A C label, completely unencoded
+
+pprCLabelString :: CLabelString -> SDoc
+pprCLabelString lbl = ftext lbl
+
+isCLabelString :: CLabelString -> Bool	-- Checks to see if this is a valid C label
+isCLabelString lbl 
+  = all ok (unpackFS lbl)
+  where
+    ok c = isAlphaNum c || c == '_' || c == '.'
+	-- The '.' appears in e.g. "foo.so" in the 
+	-- module part of a ExtName.  Maybe it should be separate
+\end{code}
+
+
+Printing into C files:
+
+\begin{code}
+instance Outputable CExportSpec where
+  ppr (CExportStatic str _) = pprCLabelString str
+
+instance Outputable CCallSpec where
+  ppr (CCallSpec fun cconv safety)
+    = hcat [ ifPprDebug callconv, ppr_fun fun ]
+    where
+      callconv = text "{-" <> ppr cconv <> text "-}"
+
+      gc_suf | playSafe safety = text "_GC"
+	     | otherwise       = empty
+
+      ppr_fun DynamicTarget     = text "__dyn_ccall" <> gc_suf <+> text "\"\""
+      ppr_fun (StaticTarget fn) = text "__ccall"     <> gc_suf <+> pprCLabelString fn
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsubsection{.NET interop}
+%*									*
+%************************************************************************
+
+\begin{code}
+data DNCallSpec = 
+	DNCallSpec Bool       -- True => static method/field
+		   DNKind     -- what type of access
+		   String     -- assembly
+		   String     -- fully qualified method/field name.
+		   [DNType]   -- argument types.
+		   DNType     -- result type.
+    deriving ( Eq )
+  {-! derive: Binary !-}
+
+data DNKind
+  = DNMethod
+  | DNField
+  | DNConstructor
+    deriving ( Eq )
+  {-! derive: Binary !-}
+
+data DNType
+  = DNByte
+  | DNBool
+  | DNChar
+  | DNDouble
+  | DNFloat
+  | DNInt
+  | DNInt8
+  | DNInt16
+  | DNInt32
+  | DNInt64
+  | DNWord8
+  | DNWord16
+  | DNWord32
+  | DNWord64
+  | DNPtr
+  | DNUnit
+  | DNObject
+  | DNString
+    deriving ( Eq )
+  {-! derive: Binary !-}
+
+withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
+withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
+  = DNCallSpec isStatic k assem nm argTys resTy
+
+instance Outputable DNCallSpec where
+  ppr (DNCallSpec isStatic kind ass nm _ _ ) 
+    = char '"' <> 
+       (if isStatic then text "static" else empty) <+>
+       (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
+       (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
+       text nm <> 
+      char '"'
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+\subsubsection{Misc}
+%*									*
+%************************************************************************
+
+\begin{code}
+{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
+instance Binary ForeignCall where
+    put_ bh (CCall aa) = do
+	    putByte bh 0
+	    put_ bh aa
+    put_ bh (DNCall ab) = do
+	    putByte bh 1
+	    put_ bh ab
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> do aa <- get bh
+		      return (CCall aa)
+	      _ -> do ab <- get bh
+		      return (DNCall ab)
+
+instance Binary Safety where
+    put_ bh (PlaySafe aa) = do
+	    putByte bh 0
+	    put_ bh aa
+    put_ bh PlayRisky = do
+	    putByte bh 1
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> do aa <- get bh
+		      return (PlaySafe aa)
+	      _ -> do return PlayRisky
+
+instance Binary CExportSpec where
+    put_ bh (CExportStatic aa ab) = do
+	    put_ bh aa
+	    put_ bh ab
+    get bh = do
+	  aa <- get bh
+	  ab <- get bh
+	  return (CExportStatic aa ab)
+
+instance Binary CCallSpec where
+    put_ bh (CCallSpec aa ab ac) = do
+	    put_ bh aa
+	    put_ bh ab
+	    put_ bh ac
+    get bh = do
+	  aa <- get bh
+	  ab <- get bh
+	  ac <- get bh
+	  return (CCallSpec aa ab ac)
+
+instance Binary CCallTarget where
+    put_ bh (StaticTarget aa) = do
+	    putByte bh 0
+	    put_ bh aa
+    put_ bh DynamicTarget = do
+	    putByte bh 1
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> do aa <- get bh
+		      return (StaticTarget aa)
+	      _ -> do return DynamicTarget
+
+instance Binary CCallConv where
+    put_ bh CCallConv = do
+	    putByte bh 0
+    put_ bh StdCallConv = do
+	    putByte bh 1
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> do return CCallConv
+	      _ -> do return StdCallConv
+
+instance Binary DNCallSpec where
+    put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
+            put_ bh isStatic
+	    put_ bh kind
+	    put_ bh ass
+	    put_ bh nm
+    get bh = do
+          isStatic <- get bh
+	  kind     <- get bh
+	  ass      <- get bh
+	  nm       <- get bh
+	  return (DNCallSpec isStatic kind ass nm [] undefined)
+
+instance Binary DNKind where
+    put_ bh DNMethod = do
+	    putByte bh 0
+    put_ bh DNField = do
+	    putByte bh 1
+    put_ bh DNConstructor = do
+	    putByte bh 2
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> do return DNMethod
+	      1 -> do return DNField
+	      _ -> do return DNConstructor
+
+instance Binary DNType where
+    put_ bh DNByte = do
+	    putByte bh 0
+    put_ bh DNBool = do
+	    putByte bh 1
+    put_ bh DNChar = do
+	    putByte bh 2
+    put_ bh DNDouble = do
+	    putByte bh 3
+    put_ bh DNFloat = do
+	    putByte bh 4
+    put_ bh DNInt = do
+	    putByte bh 5
+    put_ bh DNInt8 = do
+	    putByte bh 6
+    put_ bh DNInt16 = do
+	    putByte bh 7
+    put_ bh DNInt32 = do
+	    putByte bh 8
+    put_ bh DNInt64 = do
+	    putByte bh 9
+    put_ bh DNWord8 = do
+	    putByte bh 10
+    put_ bh DNWord16 = do
+	    putByte bh 11
+    put_ bh DNWord32 = do
+	    putByte bh 12
+    put_ bh DNWord64 = do
+	    putByte bh 13
+    put_ bh DNPtr = do
+	    putByte bh 14
+    put_ bh DNUnit = do
+	    putByte bh 15
+    put_ bh DNObject = do
+	    putByte bh 16
+    put_ bh DNString = do
+	    putByte bh 17
+
+    get bh = do
+	    h <- getByte bh
+	    case h of
+	      0 -> return DNByte
+	      1 -> return DNBool
+	      2 -> return DNChar
+  	      3 -> return DNDouble
+  	      4 -> return DNFloat
+  	      5 -> return DNInt
+  	      6 -> return DNInt8
+  	      7 -> return DNInt16
+  	      8 -> return DNInt32
+	      9 -> return DNInt64
+	      10 -> return DNWord8
+	      11 -> return DNWord16
+	      12 -> return DNWord32
+	      13 -> return DNWord64
+	      14 -> return DNPtr
+	      15 -> return DNUnit
+	      16 -> return DNObject
+	      17 -> return DNString
+
+--  Imported from other files :-
+
+\end{code}