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

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
new file mode 100644
index 0000000000..45dc113cc1
--- /dev/null
+++ b/compiler/deSugar/Desugar.lhs
@@ -0,0 +1,298 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[Desugar]{@deSugar@: the main function}
+
+\begin{code}
+module Desugar ( deSugar, deSugarExpr ) where
+
+#include "HsVersions.h"
+
+import DynFlags		( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
+import StaticFlags	( opt_SccProfilingOn )
+import DriverPhases	( isHsBoot )
+import HscTypes		( ModGuts(..), HscEnv(..), 
+			  Dependencies(..), ForeignStubs(..), TypeEnv, IsBootInterface )
+import HsSyn		( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl )
+import TcRnTypes	( TcGblEnv(..), ImportAvails(..) )
+import MkIface		( mkUsageInfo )
+import Id		( Id, setIdExported, idName )
+import Name		( Name, isExternalName, nameIsLocalOrFrom, nameOccName )
+import CoreSyn
+import PprCore		( pprRules, pprCoreExpr )
+import DsMonad
+import DsExpr		( dsLExpr )
+import DsBinds		( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) )
+import DsForeign	( dsForeigns )
+import DsExpr		()	-- Forces DsExpr to be compiled; DsBinds only
+				-- depends on DsExpr.hi-boot.
+import Module		( Module, moduleEnvElts, delModuleEnv, moduleFS )
+import RdrName	 	( GlobalRdrEnv )
+import NameSet
+import VarSet
+import Bag		( Bag, isEmptyBag, emptyBag )
+import Rules		( roughTopNames )
+import CoreLint		( showPass, endPass )
+import CoreFVs		( ruleRhsFreeVars, exprsFreeNames )
+import Packages	  	( PackageState(thPackageId), PackageIdH(..) )
+import ErrUtils		( doIfSet, dumpIfSet_dyn, printBagOfWarnings, 
+			  errorsFound, WarnMsg )
+import ListSetOps	( insertList )
+import Outputable
+import UniqSupply	( mkSplitUniqSupply )
+import SrcLoc		( Located(..) )
+import DATA_IOREF	( readIORef )
+import Maybes		( catMaybes )
+import FastString
+import Util		( sortLe )
+\end{code}
+
+%************************************************************************
+%*									*
+%* 		The main function: deSugar
+%*									*
+%************************************************************************
+
+\begin{code}
+deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts)
+-- Can modify PCS by faulting in more declarations
+
+deSugar hsc_env 
+        tcg_env@(TcGblEnv { tcg_mod       = mod,
+			    tcg_src	  = hsc_src,
+		    	    tcg_type_env  = type_env,
+		    	    tcg_imports   = imports,
+			    tcg_home_mods  = home_mods,
+		    	    tcg_exports   = exports,
+		    	    tcg_dus	  = dus, 
+		    	    tcg_inst_uses = dfun_uses_var,
+			    tcg_th_used   = th_var,
+			    tcg_keep	  = keep_var,
+		    	    tcg_rdr_env   = rdr_env,
+		    	    tcg_fix_env   = fix_env,
+	    	    	    tcg_deprecs   = deprecs,
+			    tcg_binds     = binds,
+			    tcg_fords     = fords,
+			    tcg_rules     = rules,
+		    	    tcg_insts     = insts })
+  = do	{ showPass dflags "Desugar"
+
+	-- Desugar the program
+	; ((all_prs, ds_rules, ds_fords), warns) 
+		<- case ghcMode (hsc_dflags hsc_env) of
+	             JustTypecheck -> return (([], [], NoStubs), emptyBag)
+	             _             -> initDs hsc_env mod rdr_env type_env $ do
+		                        { core_prs <- dsTopLHsBinds auto_scc binds
+		                        ; (ds_fords, foreign_prs) <- dsForeigns fords
+		                        ; let all_prs = foreign_prs ++ core_prs
+		                              local_bndrs = mkVarSet (map fst all_prs)
+		                        ; ds_rules <- mappM (dsRule mod local_bndrs) rules
+		                        ; return (all_prs, catMaybes ds_rules, ds_fords)
+		                        }
+
+	-- If warnings are considered errors, leave.
+	; if errorsFound dflags (warns, emptyBag)
+	   then return (warns, Nothing)
+	   else do
+
+	{ 	-- Add export flags to bindings
+	  keep_alive <- readIORef keep_var
+	; let final_prs = addExportFlags ghci_mode exports keep_alive 
+				   	 all_prs ds_rules
+	      ds_binds  = [Rec final_prs]
+	-- Notice that we put the whole lot in a big Rec, even the foreign binds
+	-- When compiling PrelFloat, which defines data Float = F# Float#
+	-- we want F# to be in scope in the foreign marshalling code!
+	-- You might think it doesn't matter, but the simplifier brings all top-level
+	-- things into the in-scope set before simplifying; so we get no unfolding for F#!
+
+	-- Lint result if necessary
+	; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
+
+	-- Dump output
+	; doIfSet (dopt Opt_D_dump_ds dflags) 
+		  (printDump (ppr_ds_rules ds_rules))
+
+	; dfun_uses <- readIORef dfun_uses_var		-- What dfuns are used
+	; th_used   <- readIORef th_var			-- Whether TH is used
+	; let used_names = allUses dus `unionNameSets` dfun_uses
+	      thPackage = thPackageId (pkgState dflags)
+	      pkgs | ExtPackage th_id <- thPackage, th_used
+		   = insertList th_id  (imp_dep_pkgs imports)
+	      	   | otherwise
+		   = imp_dep_pkgs imports
+
+	      dep_mods = moduleEnvElts (delModuleEnv (imp_dep_mods imports) mod)
+		-- M.hi-boot can be in the imp_dep_mods, but we must remove
+		-- it before recording the modules on which this one depends!
+		-- (We want to retain M.hi-boot in imp_dep_mods so that 
+		--  loadHiBootInterface can see if M's direct imports depend 
+		--  on M.hi-boot, and hence that we should do the hi-boot consistency 
+		--  check.)
+
+	      dir_imp_mods = imp_mods imports
+
+	; usages <- mkUsageInfo hsc_env home_mods dir_imp_mods dep_mods used_names
+
+	; let 
+		-- Modules don't compare lexicographically usually, 
+		-- but we want them to do so here.
+	     le_mod :: Module -> Module -> Bool	 
+	     le_mod m1 m2 = moduleFS m1 <= moduleFS m2
+	     le_dep_mod :: (Module, IsBootInterface) -> (Module, IsBootInterface) -> Bool	 
+	     le_dep_mod (m1,_) (m2,_) = m1 `le_mod` m2
+
+	     deps = Deps { dep_mods  = sortLe le_dep_mod dep_mods,
+			   dep_pkgs  = sortLe (<=)   pkgs,	
+			   dep_orphs = sortLe le_mod (imp_orphs imports) }
+		-- sort to get into canonical order
+
+	     mod_guts = ModGuts {	
+		mg_module   = mod,
+		mg_boot	    = isHsBoot hsc_src,
+		mg_exports  = exports,
+		mg_deps	    = deps,
+		mg_home_mods = home_mods,
+		mg_usages   = usages,
+		mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
+	        mg_rdr_env  = rdr_env,
+		mg_fix_env  = fix_env,
+		mg_deprecs  = deprecs,
+		mg_types    = type_env,
+		mg_insts    = insts,
+	        mg_rules    = ds_rules,
+		mg_binds    = ds_binds,
+		mg_foreign  = ds_fords }
+	
+        ; return (warns, Just mod_guts)
+	}}
+
+  where
+    dflags       = hsc_dflags hsc_env
+    ghci_mode    = ghcMode (hsc_dflags hsc_env)
+    auto_scc | opt_SccProfilingOn = TopLevel
+	     | otherwise          = NoSccs
+
+deSugarExpr :: HscEnv
+	    -> Module -> GlobalRdrEnv -> TypeEnv 
+ 	    -> LHsExpr Id
+	    -> IO CoreExpr
+deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
+  = do	{ showPass dflags "Desugar"
+	; us <- mkSplitUniqSupply 'd'
+
+	-- Do desugaring
+	; (core_expr, ds_warns) <- initDs hsc_env this_mod rdr_env type_env $
+				   dsLExpr tc_expr
+
+	-- Display any warnings 
+	-- Note: if -Werror is used, we don't signal an error here.
+        ; doIfSet (not (isEmptyBag ds_warns))
+		  (printBagOfWarnings dflags ds_warns)
+
+	-- Dump output
+	; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
+
+        ; return core_expr
+	}
+  where
+    dflags       = hsc_dflags hsc_env
+
+
+--		addExportFlags
+-- Set the no-discard flag if either 
+--	a) the Id is exported
+--	b) it's mentioned in the RHS of an orphan rule
+--	c) it's in the keep-alive set
+--
+-- It means that the binding won't be discarded EVEN if the binding
+-- ends up being trivial (v = w) -- the simplifier would usually just 
+-- substitute w for v throughout, but we don't apply the substitution to
+-- the rules (maybe we should?), so this substitution would make the rule
+-- bogus.
+
+-- You might wonder why exported Ids aren't already marked as such;
+-- it's just because the type checker is rather busy already and
+-- I didn't want to pass in yet another mapping.
+
+addExportFlags ghci_mode exports keep_alive prs rules
+  = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
+  where
+    add_export bndr
+	| dont_discard bndr = setIdExported bndr
+	| otherwise	    = bndr
+
+    orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
+			        | rule <- rules, 
+				  not (isLocalRule rule) ]
+	-- A non-local rule keeps alive the free vars of its right-hand side. 
+	-- (A "non-local" is one whose head function is not locally defined.)
+	-- Local rules are (later, after gentle simplification) 
+	-- attached to the Id, and that keeps the rhs free vars alive.
+
+    dont_discard bndr = is_exported name
+		     || name `elemNameSet` keep_alive
+		     || bndr `elemVarSet` orph_rhs_fvs 
+		     where
+			name = idName bndr
+
+    	-- In interactive mode, we don't want to discard any top-level
+    	-- entities at all (eg. do not inline them away during
+    	-- simplification), and retain them all in the TypeEnv so they are
+    	-- available from the command line.
+	--
+	-- isExternalName separates the user-defined top-level names from those
+	-- introduced by the type checker.
+    is_exported :: Name -> Bool
+    is_exported | ghci_mode == Interactive = isExternalName
+		| otherwise 		   = (`elemNameSet` exports)
+
+ppr_ds_rules [] = empty
+ppr_ds_rules rules
+  = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
+    pprRules rules
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+%* 		Desugaring transformation rules
+%*									*
+%************************************************************************
+
+\begin{code}
+dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
+dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
+  = putSrcSpanDs loc $ 
+    do	{ let bndrs     = [var | RuleBndr (L _ var) <- vars]
+	; lhs'  <- dsLExpr lhs
+	; rhs'  <- dsLExpr rhs
+
+	; case decomposeRuleLhs bndrs lhs' of {
+		Nothing -> do { dsWarn msg; return Nothing } ;
+		Just (bndrs', fn_id, args) -> do
+	
+	-- Substitute the dict bindings eagerly,
+	-- and take the body apart into a (f args) form
+	{ let local_rule = nameIsLocalOrFrom mod fn_name
+		-- NB we can't use isLocalId in the orphan test, 
+		-- because isLocalId isn't true of class methods
+	      fn_name   = idName fn_id
+	      lhs_names = fn_name : nameSetToList (exprsFreeNames args)
+		-- No need to delete bndrs, because
+		-- exprsFreeNames finds only External names
+	      orph = case filter (nameIsLocalOrFrom mod) lhs_names of
+			(n:ns) -> Just (nameOccName n)
+			[]     -> Nothing
+
+	      rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
+			    ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs', 
+			    ru_rough = roughTopNames args, 
+			    ru_local = local_rule, ru_orph = orph }
+	; return (Just rule)
+	} } }
+  where
+    msg = hang (ptext SLIT("RULE left-hand side too complicated to desugar; ignored"))
+	     2 (ppr lhs)
+\end{code}