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.

3 files changed, 433 insertions, 0 deletions

diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs
new file mode 100644
index 0000000000..cd118d7092
--- /dev/null
+++ b/compiler/simplStg/SRT.lhs
@@ -0,0 +1,165 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+
+Run through the STG code and compute the Static Reference Table for
+each let-binding.  At the same time, we figure out which top-level
+bindings have no CAF references, and record the fact in their IdInfo.
+
+\begin{code}
+module SRT( computeSRTs ) where
+
+#include "HsVersions.h"
+
+import StgSyn
+import Id        	( Id )
+import VarSet
+import VarEnv
+import Util		( sortLe )
+import Maybes		( orElse )
+import Maybes		( expectJust )
+import Bitmap		( intsToBitmap )
+
+#ifdef DEBUG
+import Outputable
+#endif
+
+import List
+
+import Util
+import Outputable
+\end{code}
+
+\begin{code}
+computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])]
+  -- The incoming bindingd are filled with SRTEntries in their SRT slots
+  -- the outgoing ones have NoSRT/SRT values instead
+
+computeSRTs binds = srtTopBinds emptyVarEnv binds
+
+-- --------------------------------------------------------------------------
+-- Top-level Bindings
+
+srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
+
+srtTopBinds env [] = []
+srtTopBinds env (StgNonRec b rhs : binds) = 
+  (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
+  where
+    (rhs', srt) = srtTopRhs b rhs
+    env' = maybeExtendEnv env b rhs
+    srt' = applyEnvList env srt
+srtTopBinds env (StgRec bs : binds) = 
+  (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds
+  where
+    (rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ]
+    bndrs = map fst bs
+    srts' = map (applyEnvList env) srts
+
+-- Shorting out indirections in SRTs:  if a binding has an SRT with a single
+-- element in it, we just inline it with that element everywhere it occurs
+-- in other SRTs.
+--
+-- This is in a way a generalisation of the CafInfo.  CafInfo says
+-- whether a top-level binding has *zero* CAF references, allowing us
+-- to omit it from SRTs.  Here, we pick up bindings with *one* CAF
+-- reference, and inline its SRT everywhere it occurs.  We could pass
+-- this information across module boundaries too, but we currently
+-- don't.
+
+maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _)
+  | [one] <- varSetElems cafs
+  = extendVarEnv env bndr (applyEnv env one)
+maybeExtendEnv env bndr _ = env
+
+applyEnvList :: IdEnv Id -> [Id] -> [Id]
+applyEnvList env = map (applyEnv env)
+
+applyEnv env id = lookupVarEnv env id `orElse` id
+
+-- ----  Top-level right hand sides:
+
+srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id])
+
+srtTopRhs binder rhs@(StgRhsCon _ _ _) = (rhs, [])
+srtTopRhs binder rhs@(StgRhsClosure _ _ _ _  (SRTEntries cafs) _ _)
+  = (srtRhs table rhs, elems)
+  where
+	elems = varSetElems cafs
+        table = mkVarEnv (zip elems [0..])
+
+-- ---- Binds:
+
+srtBind :: IdEnv Int -> StgBinding -> StgBinding
+
+srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs)
+srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
+
+-- ---- Right Hand Sides:
+
+srtRhs :: IdEnv Int -> StgRhs -> StgRhs
+
+srtRhs table e@(StgRhsCon cc con args) = e
+srtRhs table (StgRhsClosure cc bi free_vars u srt args body)
+  = StgRhsClosure cc bi free_vars u (constructSRT table srt) args 
+	$! (srtExpr table body)
+
+-- ---------------------------------------------------------------------------
+-- Expressions
+
+srtExpr :: IdEnv Int -> StgExpr -> StgExpr
+
+srtExpr table e@(StgApp f args) 	= e
+srtExpr table e@(StgLit l)      	= e
+srtExpr table e@(StgConApp con args)    = e
+srtExpr table e@(StgOpApp op args ty)   = e
+
+srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
+
+srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts)
+ = StgCase expr' live1 live2 uniq srt' alt_type alts'
+ where
+   expr' = srtExpr table scrut
+   srt'  = constructSRT table srt
+   alts' = map (srtAlt table) alts
+
+srtExpr table (StgLet bind body)
+  = srtBind table bind =: \ bind' ->
+    srtExpr table body		   =: \ body' ->
+    StgLet bind' body'
+     
+srtExpr table (StgLetNoEscape live1 live2 bind body)
+  = srtBind table bind =: \ bind' ->
+    srtExpr table body		   =: \ body' ->
+    StgLetNoEscape live1 live2 bind' body'
+
+#ifdef DEBUG
+srtExpr table expr = pprPanic "srtExpr" (ppr expr)
+#endif
+
+srtAlt :: IdEnv Int -> StgAlt -> StgAlt
+srtAlt table (con,args,used,rhs)
+  = (,,,) con args used $! srtExpr table rhs
+
+-----------------------------------------------------------------------------
+-- Construct an SRT bitmap.
+
+constructSRT :: IdEnv Int -> SRT -> SRT
+constructSRT table (SRTEntries entries)
+ | isEmptyVarSet entries = NoSRT
+ | otherwise  = SRT offset len bitmap
+  where
+    ints = map (expectJust "constructSRT" . lookupVarEnv table) 
+		(varSetElems entries)
+    sorted_ints = sortLe (<=) ints
+    offset = head sorted_ints
+    bitmap_entries = map (subtract offset) sorted_ints
+    len = last bitmap_entries + 1
+    bitmap = intsToBitmap len bitmap_entries
+
+-- ---------------------------------------------------------------------------
+-- Misc stuff
+
+a =: k  = k a
+
+\end{code}
diff --git a/compiler/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs
new file mode 100644
index 0000000000..e87877cb4c
--- /dev/null
+++ b/compiler/simplStg/SimplStg.lhs
@@ -0,0 +1,96 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+\section[SimplStg]{Driver for simplifying @STG@ programs}
+
+\begin{code}
+module SimplStg ( stg2stg ) where
+
+#include "HsVersions.h"
+
+import StgSyn
+
+import CostCentre       ( CollectedCCs )
+import SCCfinal		( stgMassageForProfiling )
+import StgLint		( lintStgBindings )
+import StgStats	        ( showStgStats )
+import SRT		( computeSRTs )
+
+import Packages		( HomeModules )
+import DynFlags		( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
+			  getStgToDo )
+import Id		( Id )
+import Module		( Module )
+import ErrUtils		( doIfSet_dyn, dumpIfSet_dyn, showPass )
+import UniqSupply	( mkSplitUniqSupply, splitUniqSupply )
+import Outputable
+\end{code}
+
+\begin{code}
+stg2stg :: DynFlags		     -- includes spec of what stg-to-stg passes to do
+	-> HomeModules
+	-> Module		     -- module name (profiling only)
+	-> [StgBinding]		     -- input...
+	-> IO ( [(StgBinding,[(Id,[Id])])]  -- output program...
+	      , CollectedCCs)        -- cost centre information (declared and used)
+
+stg2stg dflags pkg_deps module_name binds
+  = do	{ showPass dflags "Stg2Stg"
+	; us <- mkSplitUniqSupply 'g'
+
+	; doIfSet_dyn dflags Opt_D_verbose_stg2stg 
+		      (printDump (text "VERBOSE STG-TO-STG:"))
+
+	; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
+
+		-- Do the main business!
+	; (processed_binds, _, cost_centres) 
+		<- foldl_mn do_stg_pass (binds', us', ccs) (getStgToDo dflags)
+
+	; let srt_binds = computeSRTs processed_binds
+
+	; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" 
+	     		(pprStgBindingsWithSRTs srt_binds)
+
+	; return (srt_binds, cost_centres)
+   }
+
+  where
+    stg_linter = if dopt Opt_DoStgLinting dflags
+		 then lintStgBindings
+		 else ( \ whodunnit binds -> binds )
+
+    -------------------------------------------
+    do_stg_pass (binds, us, ccs) to_do
+      =	let
+	    (us1, us2) = splitUniqSupply us
+	in
+	case to_do of
+	  D_stg_stats ->
+	     trace (showStgStats binds)
+	     end_pass us2 "StgStats" ccs binds
+
+	  StgDoMassageForProfiling ->
+	     {-# SCC "ProfMassage" #-}
+	     let
+		 (collected_CCs, binds3)
+		   = stgMassageForProfiling pkg_deps module_name us1 binds
+	     in
+	     end_pass us2 "ProfMassage" collected_CCs binds3
+
+    end_pass us2 what ccs binds2
+      = do -- report verbosely, if required
+	   dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
+	      (vcat (map ppr binds2))
+	   let linted_binds = stg_linter what binds2
+	   return (linted_binds, us2, ccs)
+	    -- return: processed binds
+	    -- 	       UniqueSupply for the next guy to use
+	    --	       cost-centres to be declared/registered (specialised)
+	    --	       add to description of what's happened (reverse order)
+
+-- here so it can be inlined...
+foldl_mn f z []     = return z
+foldl_mn f z (x:xs) = f z x	>>= \ zz ->
+		     foldl_mn f zz xs
+\end{code}
diff --git a/compiler/simplStg/StgStats.lhs b/compiler/simplStg/StgStats.lhs
new file mode 100644
index 0000000000..a91873971c
--- /dev/null
+++ b/compiler/simplStg/StgStats.lhs
@@ -0,0 +1,172 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[StgStats]{Gathers statistical information about programs}
+
+
+The program gather statistics about
+\begin{enumerate}
+\item number of boxed cases
+\item number of unboxed cases
+\item number of let-no-escapes
+\item number of non-updatable lets
+\item number of updatable lets
+\item number of applications
+\item number of primitive applications
+\item number of closures (does not include lets bound to constructors)
+\item number of free variables in closures
+%\item number of top-level functions
+%\item number of top-level CAFs
+\item number of constructors
+\end{enumerate}
+
+\begin{code}
+module StgStats ( showStgStats ) where
+
+#include "HsVersions.h"
+
+import StgSyn
+
+import FiniteMap	( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap )
+import Id (Id)
+\end{code}
+
+\begin{code}
+data CounterType
+  = Literals
+  | Applications
+  | ConstructorApps
+  | PrimitiveApps
+  | LetNoEscapes
+  | StgCases
+  | FreeVariables
+  | ConstructorBinds Bool{-True<=>top-level-}
+  | ReEntrantBinds   Bool{-ditto-}
+  | SingleEntryBinds Bool{-ditto-}
+  | UpdatableBinds   Bool{-ditto-}
+  deriving (Eq, Ord)
+
+type Count	= Int
+type StatEnv	= FiniteMap CounterType Count
+\end{code}
+
+\begin{code}
+emptySE	:: StatEnv
+emptySE	= emptyFM
+
+combineSE :: StatEnv -> StatEnv -> StatEnv
+combineSE = plusFM_C (+)
+
+combineSEs :: [StatEnv] -> StatEnv
+combineSEs = foldr combineSE emptySE
+
+countOne :: CounterType -> StatEnv
+countOne c = unitFM c 1
+
+countN :: CounterType -> Int -> StatEnv
+countN = unitFM
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Top-level list of bindings (a ``program'')}
+%*									*
+%************************************************************************
+
+\begin{code}
+showStgStats :: [StgBinding] -> String
+
+showStgStats prog
+  = "STG Statistics:\n\n"
+    ++ concat (map showc (fmToList (gatherStgStats prog)))
+  where
+    showc (x,n) = (showString (s x) . shows n) "\n"
+
+    s Literals		      = "Literals                   "
+    s Applications	      = "Applications               "
+    s ConstructorApps	      = "ConstructorApps            "
+    s PrimitiveApps	      = "PrimitiveApps              "
+    s LetNoEscapes	      = "LetNoEscapes               "
+    s StgCases		      = "StgCases                   "
+    s FreeVariables	      = "FreeVariables              "
+    s (ConstructorBinds True) = "ConstructorBinds_Top       "
+    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "
+    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "
+    s (UpdatableBinds True)   = "UpdatableBinds_Top         "
+    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "
+    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "
+    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
+    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "
+
+gatherStgStats :: [StgBinding] -> StatEnv
+
+gatherStgStats binds
+  = combineSEs (map (statBinding True{-top-level-}) binds)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Bindings}
+%*									*
+%************************************************************************
+
+\begin{code}
+statBinding :: Bool -- True <=> top-level; False <=> nested
+	    -> StgBinding
+	    -> StatEnv
+
+statBinding top (StgNonRec b rhs)
+  = statRhs top (b, rhs)
+
+statBinding top (StgRec pairs)
+  = combineSEs (map (statRhs top) pairs)
+
+statRhs :: Bool -> (Id, StgRhs) -> StatEnv
+
+statRhs top (b, StgRhsCon cc con args)
+  = countOne (ConstructorBinds top)
+
+statRhs top (b, StgRhsClosure cc bi fv u _srt args body)
+  = statExpr body			`combineSE`
+    countN FreeVariables (length fv)	`combineSE`
+    countOne (
+      case u of
+	ReEntrant   -> ReEntrantBinds   top
+	Updatable   -> UpdatableBinds   top
+	SingleEntry -> SingleEntryBinds top
+    )
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Expressions}
+%*									*
+%************************************************************************
+
+\begin{code}
+statExpr :: StgExpr -> StatEnv
+
+statExpr (StgApp _ _)	  = countOne Applications
+statExpr (StgLit _)	  = countOne Literals
+statExpr (StgConApp _ _)  = countOne ConstructorApps
+statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
+statExpr (StgSCC l e) 	  = statExpr e
+
+statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
+  = statBinding False{-not top-level-} binds	`combineSE`
+    statExpr body				`combineSE`
+    countOne LetNoEscapes
+
+statExpr (StgLet binds body)
+  = statBinding False{-not top-level-} binds	`combineSE`
+    statExpr body
+
+statExpr (StgCase expr lve lva bndr srt alt_type alts)
+  = statExpr expr	`combineSE`
+    stat_alts alts	`combineSE`
+    countOne StgCases
+  where
+    stat_alts alts
+	= combineSEs (map statExpr [ e | (_,_,_,e) <- alts ])
+\end{code}
+