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

diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
new file mode 100644
index 0000000000..fb6017eabf
--- /dev/null
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -0,0 +1,415 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+Taken quite directly from the Peyton Jones/Lester paper.
+
+\begin{code}
+module CoreFVs (
+	exprFreeVars,	-- CoreExpr -> VarSet	-- Find all locally-defined free Ids or tyvars
+	exprsFreeVars,	-- [CoreExpr] -> VarSet
+
+	exprSomeFreeVars, exprsSomeFreeVars,
+	exprFreeNames, exprsFreeNames,
+
+	idRuleVars, idFreeVars, idFreeTyVars, 
+	ruleRhsFreeVars, rulesRhsFreeVars,
+	ruleLhsFreeNames, ruleLhsFreeIds, 
+
+	CoreExprWithFVs,	-- = AnnExpr Id VarSet
+	CoreBindWithFVs,	-- = AnnBind Id VarSet
+	freeVars,		-- CoreExpr -> CoreExprWithFVs
+	freeVarsOf		-- CoreExprWithFVs -> IdSet
+    ) where
+
+#include "HsVersions.h"
+
+import CoreSyn
+import Id		( Id, idType, idSpecialisation, isLocalId )
+import IdInfo		( specInfoFreeVars )
+import NameSet
+import UniqFM		( delFromUFM )
+import Name		( isExternalName )
+import VarSet
+import Var		( Var, isId, isLocalVar, varName )
+import Type		( tyVarsOfType )
+import TcType		( tyClsNamesOfType )
+import Util		( mapAndUnzip )
+import Outputable
+\end{code}
+
+
+%************************************************************************
+%*									*
+\section{Finding the free variables of an expression}
+%*									*
+%************************************************************************
+
+This function simply finds the free variables of an expression.
+So far as type variables are concerned, it only finds tyvars that are
+
+	* free in type arguments, 
+	* free in the type of a binder,
+
+but not those that are free in the type of variable occurrence.
+
+\begin{code}
+exprFreeVars :: CoreExpr -> VarSet	-- Find all locally-defined free Ids or tyvars
+exprFreeVars = exprSomeFreeVars isLocalVar
+
+exprsFreeVars :: [CoreExpr] -> VarSet
+exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
+
+exprSomeFreeVars :: InterestingVarFun 	-- Says which Vars are interesting
+		 -> CoreExpr
+		 -> VarSet
+exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
+
+exprsSomeFreeVars :: InterestingVarFun 	-- Says which Vars are interesting
+		  -> [CoreExpr]
+		  -> VarSet
+exprsSomeFreeVars fv_cand = foldr (unionVarSet . exprSomeFreeVars fv_cand) emptyVarSet
+
+type InterestingVarFun = Var -> Bool	-- True <=> interesting
+\end{code}
+
+
+\begin{code}
+type FV = InterestingVarFun 
+	-> VarSet		-- In scope
+	-> VarSet		-- Free vars
+
+union :: FV -> FV -> FV
+union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
+
+noVars :: FV
+noVars fv_cand in_scope = emptyVarSet
+
+--	Comment about obselete code
+-- We used to gather the free variables the RULES at a variable occurrence
+-- with the following cryptic comment:
+--     "At a variable occurrence, add in any free variables of its rule rhss
+--     Curiously, we gather the Id's free *type* variables from its binding
+--     site, but its free *rule-rhs* variables from its usage sites.  This
+--     is a little weird.  The reason is that the former is more efficient,
+--     but the latter is more fine grained, and a makes a difference when
+--     a variable mentions itself one of its own rule RHSs"
+-- Not only is this "weird", but it's also pretty bad because it can make
+-- a function seem more recursive than it is.  Suppose
+--	f  = ...g...
+--	g  = ...
+--         RULE g x = ...f...
+-- Then f is not mentioned in its own RHS, and needn't be a loop breaker
+-- (though g may be).  But if we collect the rule fvs from g's occurrence,
+-- it looks as if f mentions itself.  (This bites in the eftInt/eftIntFB
+-- code in GHC.Enum.)
+-- 
+-- Anyway, it seems plain wrong.  The RULE is like an extra RHS for the
+-- function, so its free variables belong at the definition site.
+--
+-- Deleted code looked like
+--     foldVarSet add_rule_var var_itself_set (idRuleVars var)
+--     add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
+--			    | otherwise			   = set
+-- 	SLPJ Feb06
+
+oneVar :: Id -> FV
+oneVar var fv_cand in_scope
+  = ASSERT( isId var ) 
+    if keep_it fv_cand in_scope var 
+    then unitVarSet var
+    else emptyVarSet
+
+someVars :: VarSet -> FV
+someVars vars fv_cand in_scope
+  = filterVarSet (keep_it fv_cand in_scope) vars
+
+keep_it fv_cand in_scope var
+  | var `elemVarSet` in_scope = False
+  | fv_cand var		      = True
+  | otherwise		      = False
+
+
+addBndr :: CoreBndr -> FV -> FV
+addBndr bndr fv fv_cand in_scope
+  | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope
+  | otherwise = inside_fvs
+  where
+    inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr) 
+
+addBndrs :: [CoreBndr] -> FV -> FV
+addBndrs bndrs fv = foldr addBndr fv bndrs
+\end{code}
+
+
+\begin{code}
+expr_fvs :: CoreExpr -> FV
+
+expr_fvs (Type ty) 	 = someVars (tyVarsOfType ty)
+expr_fvs (Var var) 	 = oneVar var
+expr_fvs (Lit lit)	 = noVars
+expr_fvs (Note _ expr)   = expr_fvs expr
+expr_fvs (App fun arg)   = expr_fvs fun `union` expr_fvs arg
+expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
+
+expr_fvs (Case scrut bndr ty alts)
+  = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr  
+      (foldr (union . alt_fvs) noVars alts)
+  where
+    alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
+
+expr_fvs (Let (NonRec bndr rhs) body)
+  = rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body)
+
+expr_fvs (Let (Rec pairs) body)
+  = addBndrs (map fst pairs) 
+	     (foldr (union . rhs_fvs) (expr_fvs body) pairs)
+
+---------
+rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (idRuleVars bndr)
+	-- Treat any RULES as extra RHSs of the binding
+
+---------
+exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
+\end{code}
+
+
+%************************************************************************
+%*									*
+\section{Free names}
+%*									*
+%************************************************************************
+
+exprFreeNames finds the free *external* *names* of an expression, notably
+including the names of type constructors (which of course do not show
+up in exprFreeVars).  Similarly ruleLhsFreeNames.  The latter is used
+when deciding whether a rule is an orphan.  In particular, suppose that
+T is defined in this module; we want to avoid declaring that a rule like
+	fromIntegral T = fromIntegral_T
+is an orphan.  Of course it isn't, an declaring it an orphan would
+make the whole module an orphan module, which is bad.
+
+There's no need to delete local binders, because they will all
+be *internal* names.
+
+\begin{code}
+ruleLhsFreeNames :: CoreRule -> NameSet
+ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
+ruleLhsFreeNames (Rule { ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args })
+  = addOneToNameSet (exprsFreeNames tpl_args) fn
+
+exprFreeNames :: CoreExpr -> NameSet
+-- Find the free *external* names of an expression
+exprFreeNames e
+  = go e
+  where
+    go (Var v) 
+      | isExternalName n    = unitNameSet n
+      | otherwise	    = emptyNameSet
+      where n = varName v
+    go (Lit _) 	   	    = emptyNameSet
+    go (Type ty)   	    = tyClsNamesOfType ty	-- Don't need free tyvars
+    go (App e1 e2) 	    = go e1 `unionNameSets` go e2
+    go (Lam v e)   	    = go e `delFromNameSet` varName v
+    go (Note n e)  	    = go e   
+    go (Let (NonRec b r) e) = go e `unionNameSets` go r
+    go (Let (Rec prs) e)    = exprsFreeNames (map snd prs) `unionNameSets` go e
+    go (Case e b ty as)     = go e `unionNameSets` tyClsNamesOfType ty 
+                              `unionNameSets` unionManyNameSets (map go_alt as)
+
+    go_alt (_,_,r) = go r
+
+exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
+\end{code}
+
+%************************************************************************
+%*									*
+\section[freevars-everywhere]{Attaching free variables to every sub-expression}
+%*									*
+%************************************************************************
+
+
+\begin{code}
+ruleRhsFreeVars :: CoreRule -> VarSet
+ruleRhsFreeVars (BuiltinRule {}) = noFVs
+ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
+  = delFromUFM fvs fn
+	-- Hack alert!
+	-- Don't include the Id in its own rhs free-var set.
+	-- Otherwise the occurrence analyser makes bindings recursive
+	-- that shoudn't be.  E.g.
+	--	RULE:  f (f x y) z  ==>  f x (f y z)
+  where
+    fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
+
+rulesRhsFreeVars :: [CoreRule] -> VarSet
+rulesRhsFreeVars rules
+  = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules
+
+ruleLhsFreeIds :: CoreRule -> VarSet
+-- This finds all locally-defined free Ids on the LHS of the rule
+ruleLhsFreeIds (BuiltinRule {}) = noFVs
+ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
+  = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
+\end{code}
+
+
+%************************************************************************
+%*									*
+\section[freevars-everywhere]{Attaching free variables to every sub-expression}
+%*									*
+%************************************************************************
+
+The free variable pass annotates every node in the expression with its
+NON-GLOBAL free variables and type variables.
+
+\begin{code}
+type CoreBindWithFVs = AnnBind Id VarSet
+type CoreExprWithFVs = AnnExpr Id VarSet
+	-- Every node annotated with its free variables,
+	-- both Ids and TyVars
+
+freeVarsOf :: CoreExprWithFVs -> IdSet
+freeVarsOf (free_vars, _) = free_vars
+
+noFVs    = emptyVarSet
+aFreeVar = unitVarSet
+unionFVs = unionVarSet
+
+delBindersFV :: [Var] -> VarSet -> VarSet
+delBindersFV bs fvs = foldr delBinderFV fvs bs
+
+delBinderFV :: Var -> VarSet -> VarSet
+-- This way round, so we can do it multiple times using foldr
+
+-- (b `delBinderFV` s) removes the binder b from the free variable set s,
+-- but *adds* to s
+--	(a) the free variables of b's type
+--	(b) the idSpecVars of b
+--
+-- This is really important for some lambdas:
+-- 	In (\x::a -> x) the only mention of "a" is in the binder.
+--
+-- Also in
+--	let x::a = b in ...
+-- we should really note that "a" is free in this expression.
+-- It'll be pinned inside the /\a by the binding for b, but
+-- it seems cleaner to make sure that a is in the free-var set 
+-- when it is mentioned.
+--
+-- This also shows up in recursive bindings.  Consider:
+--	/\a -> letrec x::a = x in E
+-- Now, there are no explicit free type variables in the RHS of x,
+-- but nevertheless "a" is free in its definition.  So we add in
+-- the free tyvars of the types of the binders, and include these in the
+-- free vars of the group, attached to the top level of each RHS.
+--
+-- This actually happened in the defn of errorIO in IOBase.lhs:
+--	errorIO (ST io) = case (errorIO# io) of
+--	    		    _ -> bottom
+--			  where
+--			    bottom = bottom -- Never evaluated
+
+delBinderFV b s | isId b    = (s `delVarSet` b) `unionFVs` idFreeVars b
+	        | otherwise = s `delVarSet` b
+
+idFreeVars :: Id -> VarSet
+idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
+
+idFreeTyVars :: Id -> TyVarSet
+-- Only local Ids conjured up locally, can have free type variables.
+-- (During type checking top-level Ids can have free tyvars)
+idFreeTyVars id = tyVarsOfType (idType id)
+--  | isLocalId id = tyVarsOfType (idType id)
+--  | otherwise    = emptyVarSet
+
+idRuleVars ::Id -> VarSet
+idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Free variables (and types)}
+%*									*
+%************************************************************************
+
+\begin{code}
+freeVars :: CoreExpr -> CoreExprWithFVs
+
+freeVars (Var v)
+  = (fvs, AnnVar v)
+  where
+	-- ToDo: insert motivating example for why we *need*
+	-- to include the idSpecVars in the FV list.
+	--	Actually [June 98] I don't think it's necessary
+	-- fvs = fvs_v `unionVarSet` idSpecVars v
+
+    fvs | isLocalVar v = aFreeVar v
+	| otherwise    = noFVs
+
+freeVars (Lit lit) = (noFVs, AnnLit lit)
+freeVars (Lam b body)
+  = (b `delBinderFV` freeVarsOf body', AnnLam b body')
+  where
+    body' = freeVars body
+
+freeVars (App fun arg)
+  = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2)
+  where
+    fun2 = freeVars fun
+    arg2 = freeVars arg
+
+freeVars (Case scrut bndr ty alts)
+-- gaw 2004
+  = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty,
+     AnnCase scrut2 bndr ty alts2)
+  where
+    scrut2 = freeVars scrut
+
+    (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
+    alts_fvs 		= foldr1 unionFVs alts_fvs_s
+
+    fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
+			     (con, args, rhs2))
+		    	  where
+			     rhs2 = freeVars rhs
+
+freeVars (Let (NonRec binder rhs) body)
+  = (freeVarsOf rhs2 `unionFVs` body_fvs,
+     AnnLet (AnnNonRec binder rhs2) body2)
+  where
+    rhs2     = freeVars rhs
+    body2    = freeVars body
+    body_fvs = binder `delBinderFV` freeVarsOf body2
+
+freeVars (Let (Rec binds) body)
+  = (foldl delVarSet group_fvs binders,
+	-- The "delBinderFV" part may have added one of the binders
+	-- via the idSpecVars part, so we must delete it again
+     AnnLet (AnnRec (binders `zip` rhss2)) body2)
+  where
+    (binders, rhss) = unzip binds
+
+    rhss2     = map freeVars rhss
+    all_fvs   = foldr (unionFVs . fst) body_fvs rhss2
+    group_fvs = delBindersFV binders all_fvs
+
+    body2     = freeVars body
+    body_fvs  = freeVarsOf body2
+
+freeVars (Note (Coerce to_ty from_ty) expr)
+  = (freeVarsOf expr2 `unionFVs` tfvs1 `unionFVs` tfvs2,
+     AnnNote (Coerce to_ty from_ty) expr2)
+  where
+    expr2  = freeVars expr
+    tfvs1  = tyVarsOfType from_ty
+    tfvs2  = tyVarsOfType to_ty
+
+freeVars (Note other_note expr)
+  = (freeVarsOf expr2, AnnNote other_note expr2)
+  where
+    expr2 = freeVars expr
+
+freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
+\end{code}
+