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

diff --git a/compiler/cprAnalysis/CprAnalyse.lhs b/compiler/cprAnalysis/CprAnalyse.lhs
new file mode 100644
index 0000000000..dad6ccbaee
--- /dev/null
+++ b/compiler/cprAnalysis/CprAnalyse.lhs
@@ -0,0 +1,315 @@
+\section[CprAnalyse]{Identify functions that always return a
+constructed product result}
+
+\begin{code}
+#ifndef OLD_STRICTNESS
+module CprAnalyse ( ) where
+
+#else
+
+module CprAnalyse ( cprAnalyse ) where
+
+#include "HsVersions.h"
+
+import DynFlags	( DynFlags, DynFlag(..) )
+import CoreLint		( showPass, endPass )
+import CoreSyn
+import CoreUtils	( exprIsHNF )
+import Id               ( Id, setIdCprInfo, idCprInfo, idArity,
+			  isBottomingId, idDemandInfo, isImplicitId )
+import IdInfo           ( CprInfo(..) )
+import Demand		( isStrict )
+import VarEnv
+import Util		( nTimes, mapAccumL )
+import Outputable
+
+import Maybe
+\end{code}
+
+This module performs an analysis of a set of Core Bindings for the
+Constructed Product Result (CPR) transformation.
+
+It detects functions that always explicitly (manifestly?) construct a
+result value with a product type.  A product type is a type which has
+only one constructor. For example, tuples and boxed primitive values
+have product type.
+
+We must also ensure that the function's body starts with sufficient
+manifest lambdas otherwise loss of sharing can occur.  See the comment
+in @StrictAnal.lhs@.
+
+The transformation of bindings to worker/wrapper pairs is done by the
+worker-wrapper pass.  The worker-wrapper pass splits bindings on the
+basis of both strictness and CPR info.  If an id has both then it can
+combine the transformations so that only one pair is produced.
+
+The analysis here detects nested CPR information.  For example, if a
+function returns a constructed pair, the first element of which is a
+constructed int, then the analysis will detect nested CPR information
+for the int as well.  Unfortunately, the current transformations can't
+take advantage of the nested CPR information.  They have (broken now,
+I think) code which will flatten out nested CPR components and rebuild
+them in the wrapper, but enabling this would lose laziness.  It is
+possible to make use of the nested info: if we knew that a caller was
+strict in that position then we could create a specialized version of
+the function which flattened/reconstructed that position.
+
+It is not known whether this optimisation would be worthwhile.
+
+So we generate and carry round nested CPR information, but before
+using this info to guide the creation of workers and wrappers we map
+all components of a CPRInfo to NoCprInfo.
+
+
+Data types
+~~~~~~~~~~
+
+Within this module Id's CPR information is represented by
+``AbsVal''. When adding this information to the Id's pragma info field 
+we convert the ``Absval'' to a ``CprInfo'' value.   
+
+Abstract domains consist of a `no information' value (Top), a function
+value (Fun) which when applied to an argument returns a new AbsVal
+(note the argument is not used in any way), , for product types, a
+corresponding length tuple (Tuple) of abstract values.  And finally,
+Bot.  Bot is not a proper abstract value but a generic bottom is
+useful for calculating fixpoints and representing divergent
+computations.  Note that we equate Bot and Fun^n Bot (n > 0), and
+likewise for Top.  This saves a lot of delving in types to keep
+everything exactly correct.
+
+Since functions abstract to constant functions we could just
+represent them by the abstract value of their result.  However,  it
+turns out (I know - I tried!) that this requires a lot of type
+manipulation and the code is more straightforward if we represent
+functions by an abstract constant function. 
+
+\begin{code}
+data AbsVal = Top                -- Not a constructed product
+
+	    | Fun AbsVal         -- A function that takes an argument 
+				 -- and gives AbsVal as result. 
+
+            | Tuple 		 -- A constructed product of values
+
+            | Bot                -- Bot'tom included for convenience
+                                 -- we could use appropriate Tuple Vals
+     deriving (Eq,Show)
+
+-- For pretty debugging
+instance Outputable AbsVal where
+  ppr Top    	= ptext SLIT("Top")
+  ppr (Fun r)	= ptext SLIT("Fun->") <> (parens.ppr) r
+  ppr Tuple     = ptext SLIT("Tuple ")
+  ppr Bot       = ptext SLIT("Bot")
+
+
+-- lub takes the lowest upper bound of two abstract values, standard.
+lub :: AbsVal -> AbsVal -> AbsVal
+lub Bot a = a
+lub a Bot = a
+lub Top a = Top
+lub a Top = Top
+lub Tuple Tuple 	= Tuple
+lub (Fun l) (Fun r)     = Fun (lub l r)
+lub l r = panic "CPR Analysis tried to take the lub of a function and a tuple"
+
+
+\end{code}
+
+The environment maps Ids to their abstract CPR value.
+
+\begin{code}
+
+type CPREnv = VarEnv AbsVal
+
+initCPREnv = emptyVarEnv
+
+\end{code}
+
+Programs
+~~~~~~~~
+
+Take a list of core bindings and return a new list with CPR function
+ids decorated with their CprInfo pragmas.
+
+\begin{code}
+
+cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind]
+cprAnalyse dflags binds
+  = do {
+	showPass dflags "Constructed Product analysis" ;
+	let { binds_plus_cpr = do_prog binds } ;
+	endPass dflags "Constructed Product analysis" 
+	 	Opt_D_dump_cpranal binds_plus_cpr
+    }
+  where
+    do_prog :: [CoreBind] -> [CoreBind]
+    do_prog binds = snd $ mapAccumL cprAnalBind initCPREnv binds
+\end{code}
+
+The cprAnal functions take binds/expressions and an environment which 
+gives CPR info for visible ids and returns a new bind/expression
+with ids decorated with their CPR info.
+ 
+\begin{code}
+-- Return environment extended with info from this binding 
+cprAnalBind :: CPREnv -> CoreBind -> (CPREnv, CoreBind)
+cprAnalBind rho (NonRec b e) 
+  | isImplicitId b	-- Don't touch the CPR info on constructors, selectors etc
+  = (rho, NonRec b e)	
+  | otherwise
+  = (extendVarEnv rho b absval, NonRec b' e')
+  where
+    (e', absval) = cprAnalExpr rho e
+    b' = addIdCprInfo b e' absval
+
+cprAnalBind rho (Rec prs)
+  = (final_rho, Rec (map do_pr prs))
+  where
+    do_pr (b,e) = (b', e') 
+		where
+		  b'           = addIdCprInfo b e' absval
+		  (e', absval) = cprAnalExpr final_rho e
+
+	-- When analyzing mutually recursive bindings the iterations to find
+	-- a fixpoint is bounded by the number of bindings in the group.
+	-- for simplicity we just iterate that number of times.      
+    final_rho = nTimes (length prs) do_one_pass init_rho
+    init_rho  = rho `extendVarEnvList` [(b,Bot) | (b,e) <- prs]
+
+    do_one_pass :: CPREnv -> CPREnv
+    do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalExpr rho e)))
+			    rho prs
+
+
+cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal)
+
+-- If Id will always diverge when given sufficient arguments then
+-- we can just set its abs val to Bot.  Any other CPR info
+-- from other paths will then dominate,  which is what we want.
+-- Check in rho,  if not there it must be imported, so check 
+-- the var's idinfo. 
+cprAnalExpr rho e@(Var v) 
+    | isBottomingId v = (e, Bot)
+    | otherwise       = (e, case lookupVarEnv rho v of
+                             Just a_val -> a_val
+			     Nothing    -> getCprAbsVal v)
+
+-- Literals are unboxed
+cprAnalExpr rho (Lit l) = (Lit l, Top)
+
+-- For apps we don't care about the argument's abs val.  This
+-- app will return a constructed product if the function does. We strip
+-- a Fun from the functions abs val, unless the argument is a type argument 
+-- or it is already Top or Bot.
+cprAnalExpr rho (App fun arg@(Type _))
+    = (App fun_cpr arg, fun_res)  
+    where 
+      (fun_cpr, fun_res)  = cprAnalExpr rho fun 
+
+cprAnalExpr rho (App fun arg) 
+    = (App fun_cpr arg_cpr, res_res)
+    where 
+      (fun_cpr, fun_res)  = cprAnalExpr rho fun 
+      (arg_cpr, _)        = cprAnalExpr rho arg
+      res_res		  = case fun_res of
+				Fun res_res -> res_res
+				Top 	    -> Top
+				Bot	    -> Bot
+				Tuple	    -> WARN( True, ppr (App fun arg) ) Top
+						-- This really should not happen!
+
+
+-- Map arguments to Top (we aren't constructing them)
+-- Return the abstract value of the body, since functions 
+-- are represented by the CPR value of their result, and 
+-- add a Fun for this lambda..
+cprAnalExpr rho (Lam b body) | isTyVar b = (Lam b body_cpr, body_aval)
+                             | otherwise = (Lam b body_cpr, Fun body_aval)
+      where 
+      (body_cpr, body_aval) = cprAnalExpr (extendVarEnv rho b Top) body
+
+cprAnalExpr rho (Let bind body)
+    = (Let bind' body', body_aval)
+    where 
+      (rho', bind') = cprAnalBind rho bind
+      (body', body_aval) = cprAnalExpr rho' body
+
+cprAnalExpr rho (Case scrut bndr alts)
+    = (Case scrut_cpr bndr alts_cpr, alts_aval)
+      where 
+      (scrut_cpr, scrut_aval) = cprAnalExpr rho scrut
+      (alts_cpr, alts_aval) = cprAnalCaseAlts (extendVarEnv rho bndr scrut_aval) alts
+
+cprAnalExpr rho (Note n exp) 
+    = (Note n exp_cpr, expr_aval)
+      where
+      (exp_cpr, expr_aval) = cprAnalExpr rho exp
+
+cprAnalExpr rho (Type t) 
+    = (Type t, Top)
+
+cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
+cprAnalCaseAlts rho alts
+    = foldr anal_alt ([], Bot) alts
+      where 
+      anal_alt :: CoreAlt -> ([CoreAlt], AbsVal) -> ([CoreAlt], AbsVal)
+      anal_alt (con, binds, exp)  (done, aval)
+	  = ((con,binds,exp_cpr) : done, exp_aval `lub` aval)
+	    where (exp_cpr, exp_aval) = cprAnalExpr rho' exp
+		  rho' = rho `extendVarEnvList` (zip binds (repeat Top))
+
+
+addIdCprInfo :: Id -> CoreExpr -> AbsVal -> Id
+addIdCprInfo bndr rhs absval
+  | useful_info && ok_to_add = setIdCprInfo bndr cpr_info
+  | otherwise		     = bndr
+  where
+    cpr_info    = absToCprInfo absval
+    useful_info = case cpr_info of { ReturnsCPR -> True; NoCPRInfo -> False }
+		
+    ok_to_add = case absval of
+                  Fun _ -> idArity bndr >= n_fun_tys absval
+		      -- Enough visible lambdas
+
+		  Tuple  -> exprIsHNF rhs || isStrict (idDemandInfo bndr)
+			-- If the rhs is a value, and returns a constructed product,
+			-- it will be inlined at usage sites, so we give it a Tuple absval
+			-- If it isn't a value, we won't inline it (code/work dup worries), so
+			-- we discard its absval.
+			-- 
+			-- Also, if the strictness analyser has figured out that it's strict,
+			-- the let-to-case transformation will happen, so again it's good.
+			-- (CPR analysis runs before the simplifier has had a chance to do
+			--  the let-to-case transform.)
+			-- This made a big difference to PrelBase.modInt, which had something like
+			--	modInt = \ x -> let r = ... -> I# v in
+		 	--			...body strict in r...
+			-- r's RHS isn't a value yet; but modInt returns r in various branches, so
+			-- if r doesn't have the CPR property then neither does modInt
+
+		  _ -> False
+
+    n_fun_tys :: AbsVal -> Int
+    n_fun_tys (Fun av) = 1 + n_fun_tys av
+    n_fun_tys other    = 0
+
+
+absToCprInfo :: AbsVal -> CprInfo
+absToCprInfo Tuple   = ReturnsCPR
+absToCprInfo (Fun r) = absToCprInfo r
+absToCprInfo _       = NoCPRInfo
+
+
+-- Cpr Info doesn't store the number of arguments a function has,  so the caller
+-- must take care to add the appropriate number of Funs.
+getCprAbsVal v = case idCprInfo v of
+			NoCPRInfo -> Top
+			ReturnsCPR -> nTimes arity Fun Tuple
+	       where
+		 arity = idArity v
+	-- Imported (non-nullary) constructors will have the CPR property
+	-- in their IdInfo, so no need to look at their unfolding
+#endif /* OLD_STRICTNESS */
+\end{code}