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.

6 files changed, 1881 insertions, 0 deletions

diff --git a/compiler/ndpFlatten/FlattenInfo.hs b/compiler/ndpFlatten/FlattenInfo.hs
new file mode 100644
index 0000000000..f759242455
--- /dev/null
+++ b/compiler/ndpFlatten/FlattenInfo.hs
@@ -0,0 +1,43 @@
+--  $Id$
+--
+--  Copyright (c) 2002 Manuel M T Chakravarty & Gabriele Keller
+--
+--  Information for modules outside of the flattening module collection.
+--
+--- DESCRIPTION ---------------------------------------------------------------
+--
+--  This module contains information that is needed, and thus imported, by
+--  modules that are otherwise independent of flattening and may in fact be
+--  directly or indirectly imported by some of the flattening-related
+--  modules.  This is to avoid cyclic module dependencies.
+-- 
+--- DOCU ----------------------------------------------------------------------
+--
+--  Language: Haskell 98
+--
+--- TODO ----------------------------------------------------------------------
+--
+
+module FlattenInfo (
+  namesNeededForFlattening
+) where
+
+import StaticFlags (opt_Flatten)
+import NameSet     (FreeVars, emptyFVs, mkFVs)
+import PrelNames   (fstName, andName, orName, lengthPName, replicatePName,
+		    mapPName, bpermutePName, bpermuteDftPName, indexOfPName)
+
+
+-- this is a list of names that need to be available if flattening is
+-- performed (EXPORTED)
+--
+--  * needs to be kept in sync with the names used in Core generation in
+--   `FlattenMonad' and `NDPCoreUtils'
+--
+namesNeededForFlattening :: FreeVars
+namesNeededForFlattening
+  | not opt_Flatten = emptyFVs		-- none without -fflatten
+  | otherwise
+  = mkFVs [fstName, andName, orName, lengthPName, replicatePName, mapPName,
+	   bpermutePName, bpermuteDftPName, indexOfPName]
+    -- stuff from PrelGHC doesn't have to go here
diff --git a/compiler/ndpFlatten/FlattenMonad.hs b/compiler/ndpFlatten/FlattenMonad.hs
new file mode 100644
index 0000000000..45405088fc
--- /dev/null
+++ b/compiler/ndpFlatten/FlattenMonad.hs
@@ -0,0 +1,451 @@
+--  $Id$
+--
+--  Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller
+--
+--  Monad maintaining parallel contexts and substitutions for flattening.
+--
+--- DESCRIPTION ---------------------------------------------------------------
+--
+--  The flattening transformation needs to perform a fair amount of plumbing.
+--  It needs to mainatin a set of variables, called the parallel context for
+--  lifting, variable substitutions in case alternatives, and so on.
+--  Moreover, we need to manage uniques to create new variables.  The monad
+--  defined in this module takes care of maintaining this state.
+-- 
+--- DOCU ----------------------------------------------------------------------
+--
+--  Language: Haskell 98
+--
+--  * a parallel context is a set of variables that get vectorised during a
+--    lifting transformations (ie, their type changes from `t' to `[:t:]')
+--
+--  * all vectorised variables in a parallel context have the same size; we
+--    call this also the size of the parallel context
+--
+--  * we represent contexts by maps that give the lifted version of a variable
+--    (remember that in GHC, variables contain type information that changes
+--    during lifting)
+--
+--- TODO ----------------------------------------------------------------------
+--
+--  * Assumptions currently made that should (if they turn out to be true) be
+--    documented in The Commentary:
+--
+--    - Local bindings can be copied without any need to alpha-rename bound
+--      variables (or their uniques).  Such renaming is only necessary when
+--      bindings in a recursive group are replicated; implying that this is
+--      required in the case of top-level bindings).  (Note: The CoreTidy path
+--      generates global uniques before code generation.)
+--
+--  * One FIXME left to resolve.
+--
+
+module FlattenMonad (
+
+  -- monad definition
+  --
+  Flatten, runFlatten,
+
+  -- variable generation
+  --
+  newVar, mkBind,
+  
+  -- context management & query operations
+  --
+  extendContext, packContext, liftVar, liftConst, intersectWithContext,
+
+  -- construction of prelude functions
+  --
+  mk'fst, mk'eq, mk'neq, mk'and, mk'or, mk'lengthP, mk'replicateP, mk'mapP,
+  mk'bpermuteP, mk'bpermuteDftP, mk'indexOfP
+) where
+
+-- standard
+import Monad	    (mplus)
+
+-- GHC
+import Panic        (panic)
+import Outputable   (Outputable(ppr), pprPanic)
+import UniqSupply   (UniqSupply, splitUniqSupply, uniqFromSupply)
+import Var          (Var, idType)
+import Id	    (Id, mkSysLocal)
+import Name	    (Name)
+import VarSet       (VarSet, emptyVarSet, extendVarSet, varSetElems )
+import VarEnv       (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv,
+		     elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList)
+import Type	    (Type, tyConAppTyCon)
+import HscTypes	    (HomePackageTable,
+		     ExternalPackageState(eps_PTE), HscEnv(hsc_HPT),
+		     TyThing(..), lookupType)
+import PrelNames    ( fstName, andName, orName,
+		     lengthPName, replicatePName, mapPName, bpermutePName,
+		     bpermuteDftPName, indexOfPName)
+import TysPrim      ( charPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon )
+import PrimOp	    ( PrimOp(..) )
+import PrelInfo	    ( primOpId )
+import CoreSyn      (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps)
+import CoreUtils    (exprType)
+import FastString   (FastString)
+
+-- friends
+import NDPCoreUtils (parrElemTy)
+
+
+-- definition of the monad
+-- -----------------------
+
+-- state maintained by the flattening monad
+--
+data FlattenState = FlattenState {
+
+		      -- our source for uniques
+		      --
+		      us       :: UniqSupply,
+
+		      -- environment containing all known names (including all
+		      -- Prelude functions)
+		      --
+		      env      :: Name -> Id,
+
+		      -- this variable determines the parallel context; if
+		      -- `Nothing', we are in pure vectorisation mode, no
+		      -- lifting going on
+		      --
+		      ctxtVar  :: Maybe Var,
+
+		      -- environment that maps each variable that is
+		      -- vectorised in the current parallel context to the
+		      -- vectorised version of that variable
+		      --
+		      ctxtEnv :: VarEnv Var,
+
+		      -- those variables from the *domain* of `ctxtEnv' that
+		      -- have been used since the last context restriction (cf.
+		      -- `restrictContext') 
+		      --
+		      usedVars :: VarSet
+		    }
+
+-- initial value of the flattening state
+--
+initialFlattenState :: ExternalPackageState
+		    -> HomePackageTable 
+		    -> UniqSupply 
+		    -> FlattenState
+initialFlattenState eps hpt us = 
+  FlattenState {
+    us	     = us,
+    env      = lookup,
+    ctxtVar  = Nothing,
+    ctxtEnv  = emptyVarEnv,
+    usedVars = emptyVarSet
+  }
+  where
+    lookup n = 
+      case lookupType hpt (eps_PTE eps) n of
+        Just (AnId v) -> v 
+	_             -> pprPanic "FlattenMonad: unknown name:" (ppr n)
+
+-- the monad representation (EXPORTED ABSTRACTLY)
+--
+newtype Flatten a = Flatten {
+		      unFlatten :: (FlattenState -> (a, FlattenState))
+		    }
+
+instance Monad Flatten where
+  return x = Flatten $ \s -> (x, s)
+  m >>= n  = Flatten $ \s -> let 
+			       (r, s') = unFlatten m s
+			     in
+			     unFlatten (n r) s'
+
+-- execute the given flattening computation (EXPORTED)
+--
+runFlatten :: HscEnv
+	   -> ExternalPackageState
+	   -> UniqSupply 
+	   -> Flatten a 
+	   -> a    
+runFlatten hsc_env eps us m 
+  = fst $ unFlatten m (initialFlattenState eps (hsc_HPT hsc_env) us)
+
+
+-- variable generation
+-- -------------------
+
+-- generate a new local variable whose name is based on the given lexeme and
+-- whose type is as specified in the second argument (EXPORTED)
+--
+newVar           :: FastString -> Type -> Flatten Var
+newVar lexeme ty  = Flatten $ \state ->
+  let
+    (us1, us2) = splitUniqSupply (us state)
+    state'     = state {us = us2}
+  in
+  (mkSysLocal lexeme (uniqFromSupply us1) ty, state')
+
+-- generate a non-recursive binding using a new binder whose name is derived
+-- from the given lexeme (EXPORTED)
+--
+mkBind          :: FastString -> CoreExpr -> Flatten (CoreBndr, CoreBind)
+mkBind lexeme e  =
+  do
+    v <- newVar lexeme (exprType e)
+    return (v, NonRec v e)
+
+
+-- context management
+-- ------------------
+
+-- extend the parallel context by the given set of variables (EXPORTED)
+--
+--  * if there is no parallel context at the moment, the first element of the
+--   variable list will be used to determine the new parallel context
+--
+--  * the second argument is executed in the current context extended with the
+--   given variables
+--
+--  * the variables must already have been lifted by transforming their type,
+--   but they *must* have retained their original name (or, at least, their
+--   unique); this is needed so that they match the original variable in
+--   variable environments
+--
+--  * any trace of the given set of variables has to be removed from the state
+--   at the end of this operation
+--
+extendContext      :: [Var] -> Flatten a -> Flatten a
+extendContext [] m  = m
+extendContext vs m  = Flatten $ \state -> 
+  let 
+    extState       = state {
+		       ctxtVar = ctxtVar state `mplus` Just (head vs),
+		       ctxtEnv = ctxtEnv state `plusVarEnv` zipVarEnv vs vs
+		     }
+    (r, extState') = unFlatten m extState
+    resState       = extState' { -- remove `vs' from the result state
+		       ctxtVar  = ctxtVar state,
+		       ctxtEnv  = ctxtEnv state,
+		       usedVars = usedVars extState' `delVarEnvList` vs
+		     }
+  in
+  (r, resState)
+
+-- execute the second argument in a restricted context (EXPORTED)
+--
+--  * all variables in the current parallel context are packed according to
+--   the permutation vector associated with the variable passed as the first
+--   argument (ie, all elements of vectorised context variables that are
+--   invalid in the restricted context are dropped)
+--
+--  * the returned list of core binders contains the operations that perform
+--   the restriction on all variables in the parallel context that *do* occur
+--   during the execution of the second argument (ie, `liftVar' is executed at
+--   least once on any such variable)
+--
+packContext        :: Var -> Flatten a -> Flatten (a, [CoreBind])
+packContext perm m  = Flatten $ \state ->
+  let
+    -- FIXME: To set the packed environment to the unpacked on is a hack of
+    --   which I am not sure yet (a) whether it works and (b) whether it's
+    --   really worth it.  The one advantages is that, we can use a var set,
+    --   after all, instead of a var environment.
+    --
+    --	 The idea is the following: If we have to pack a variable `x', we
+    --	 generate `let{-NonRec-} x = bpermuteP perm x in ...'.  As this is a
+    --	 non-recursive binding, the lhs `x' overshadows the rhs `x' in the
+    --	 body of the let.
+    --
+    --   NB: If we leave it like this, `mkCoreBind' can be simplified.
+    packedCtxtEnv     = ctxtEnv state
+    packedState       = state {
+	                  ctxtVar  = fmap
+				       (lookupVarEnv_NF packedCtxtEnv)
+				       (ctxtVar state),
+		          ctxtEnv  = packedCtxtEnv, 
+		          usedVars = emptyVarSet
+		        }
+    (r, packedState') = unFlatten m packedState
+    resState	      = state {    -- revert to the unpacked context
+			  ctxtVar  = ctxtVar state,
+			  ctxtEnv  = ctxtEnv state
+		        }
+    bndrs	      = map mkCoreBind . varSetElems . usedVars $ packedState'
+
+    -- generate a binding for the packed variant of a context variable
+    --
+    mkCoreBind var    = let
+			  rhs = fst $ unFlatten (mk'bpermuteP (idType var) 
+							      (Var perm) 
+							      (Var var)
+						) state
+			in
+			NonRec (lookupVarEnv_NF packedCtxtEnv var) $ rhs
+		          
+  in
+  ((r, bndrs), resState)
+
+-- lift a single variable in the current context (EXPORTED)
+--
+--  * if the variable does not occur in the context, it's value is vectorised to
+--   match the size of the current context
+--
+--  * otherwise, the variable is replaced by whatever the context environment
+--   maps it to (this may either be simply the lifted version of the original
+--   variable or a packed variant of that variable)
+--
+--  * the monad keeps track of all lifted variables that occur in the parallel
+--   context, so that `packContext' can determine the correct set of core
+--   bindings
+--
+liftVar     :: Var -> Flatten CoreExpr
+liftVar var  = Flatten $ \s ->
+  let 
+    v          = ctxtVarErr s
+    v'elemType = parrElemTy . idType $ v
+    len        = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s
+    replicated = fst $ unFlatten (mk'replicateP (idType var) len (Var var)) s
+  in case lookupVarEnv (ctxtEnv s) var of
+    Just liftedVar -> (Var liftedVar, 
+		       s {usedVars = usedVars s `extendVarSet` var})
+    Nothing        -> (replicated, s)
+
+-- lift a constant expression in the current context (EXPORTED)
+--
+--  * the value of the constant expression is vectorised to match the current
+--   parallel context
+--
+liftConst   :: CoreExpr -> Flatten CoreExpr
+liftConst e  = Flatten $ \s ->
+  let
+     v          = ctxtVarErr s
+     v'elemType = parrElemTy . idType $ v
+     len        = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s
+  in 
+  (fst $ unFlatten (mk'replicateP (exprType e) len e ) s, s)
+
+-- pick those variables of the given set that occur (if albeit in lifted form)
+-- in the current parallel context (EXPORTED)
+--
+--  * the variables returned are from the given set and *not* the corresponding
+--   context variables
+--
+intersectWithContext    :: VarSet -> Flatten [Var]
+intersectWithContext vs  = Flatten $ \s ->
+  let
+    vs' = filter (`elemVarEnv` ctxtEnv s) (varSetElems vs)
+  in
+  (vs', s)
+
+
+-- construct applications of prelude functions
+-- -------------------------------------------
+
+-- NB: keep all the used names listed in `FlattenInfo.namesNeededForFlattening'
+
+-- generate an application of `fst' (EXPORTED)
+--
+mk'fst           :: Type -> Type -> CoreExpr -> Flatten CoreExpr
+mk'fst ty1 ty2 a  = mkFunApp fstName [Type ty1, Type ty2, a]
+
+-- generate an application of `&&' (EXPORTED)
+--
+mk'and       :: CoreExpr -> CoreExpr -> Flatten CoreExpr
+mk'and a1 a2  = mkFunApp andName [a1, a2]
+
+-- generate an application of `||' (EXPORTED)
+--
+mk'or       :: CoreExpr -> CoreExpr -> Flatten CoreExpr
+mk'or a1 a2  = mkFunApp orName [a1, a2]
+
+-- generate an application of `==' where the arguments may only be literals
+-- that may occur in a Core case expression (i.e., `Char', `Int', `Float', and
+-- `Double') (EXPORTED)
+--
+mk'eq          :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
+mk'eq ty a1 a2  = return (mkApps (Var eqName) [a1, a2])
+		  where
+		    tc = tyConAppTyCon ty
+		    --
+		    eqName | tc == charPrimTyCon   = primOpId CharEqOp
+			   | tc == intPrimTyCon    = primOpId IntEqOp
+			   | tc == floatPrimTyCon  = primOpId FloatEqOp
+			   | tc == doublePrimTyCon = primOpId DoubleEqOp
+			   | otherwise 		         =
+			     pprPanic "FlattenMonad.mk'eq: " (ppr ty)
+
+-- generate an application of `==' where the arguments may only be literals
+-- that may occur in a Core case expression (i.e., `Char', `Int', `Float', and
+-- `Double') (EXPORTED)
+--
+mk'neq          :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
+mk'neq ty a1 a2  = return (mkApps (Var neqName) [a1, a2])
+		   where
+		     tc = tyConAppTyCon ty
+		     --
+		     neqName {-  | name == charPrimTyConName   = neqCharName -}
+			     | tc == intPrimTyCon	      = primOpId IntNeOp
+			     {-  | name == floatPrimTyConName  = neqFloatName -}
+			     {-  | name == doublePrimTyConName = neqDoubleName -}
+			     | otherwise		   =
+			       pprPanic "FlattenMonad.mk'neq: " (ppr ty)
+
+-- generate an application of `lengthP' (EXPORTED)
+--
+mk'lengthP      :: Type -> CoreExpr -> Flatten CoreExpr
+mk'lengthP ty a  = mkFunApp lengthPName [Type ty, a]
+
+-- generate an application of `replicateP' (EXPORTED)
+--
+mk'replicateP          :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
+mk'replicateP ty a1 a2  = mkFunApp replicatePName [Type ty, a1, a2]
+
+-- generate an application of `replicateP' (EXPORTED)
+--
+mk'mapP :: Type -> Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
+mk'mapP ty1 ty2 a1 a2  = mkFunApp mapPName [Type ty1, Type ty2, a1, a2]
+
+-- generate an application of `bpermuteP' (EXPORTED)
+--
+mk'bpermuteP          :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
+mk'bpermuteP ty a1 a2  = mkFunApp bpermutePName [Type ty, a1, a2]
+
+-- generate an application of `bpermuteDftP' (EXPORTED)
+--
+mk'bpermuteDftP :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> Flatten CoreExpr
+mk'bpermuteDftP ty a1 a2 a3 = mkFunApp bpermuteDftPName [Type ty, a1, a2, a3]
+
+-- generate an application of `indexOfP' (EXPORTED)
+--
+mk'indexOfP          :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
+mk'indexOfP ty a1 a2  = mkFunApp indexOfPName [Type ty, a1, a2]
+
+
+-- auxilliary functions
+-- --------------------
+
+-- obtain the context variable, aborting if it is not available (as this
+-- signals an internal error in the usage of the `Flatten' monad)
+--
+ctxtVarErr   :: FlattenState -> Var
+ctxtVarErr s  = case ctxtVar s of
+		  Nothing -> panic "FlattenMonad.ctxtVarErr: No context variable available!"
+		  Just v  -> v
+
+-- given the name of a known function and a set of arguments (needs to include
+-- all needed type arguments), build a Core expression that applies the named
+-- function to those arguments
+--
+mkFunApp           :: Name -> [CoreExpr] -> Flatten CoreExpr
+mkFunApp name args  =
+  do
+    fun <- lookupName name
+    return $ mkApps (Var fun) args
+
+-- get the `Id' of a known `Name'
+--
+--  * this can be the `Name' of any function that's visible on the toplevel of
+--   the current compilation unit
+--
+lookupName      :: Name -> Flatten Id
+lookupName name  = Flatten $ \s ->
+  (env s name, s)
diff --git a/compiler/ndpFlatten/Flattening.hs b/compiler/ndpFlatten/Flattening.hs
new file mode 100644
index 0000000000..18daaa6323
--- /dev/null
+++ b/compiler/ndpFlatten/Flattening.hs
@@ -0,0 +1,808 @@
+--  $Id$
+--
+--  Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller
+--  
+--  Vectorisation and lifting
+--
+--- DESCRIPTION ---------------------------------------------------------------
+--
+--  This module implements the vectorisation and function lifting
+--  transformations of the flattening transformation.
+-- 
+--- DOCU ----------------------------------------------------------------------
+--
+--  Language: Haskell 98 with C preprocessor
+--
+--  Types: 
+--    the transformation on types has five purposes:
+--
+--        1) for each type definition, derive the lifted version of this type
+--             liftTypeef
+--        2) change the type annotations of functions & variables acc. to rep.
+--             flattenType
+--        3) derive the type of a lifted function
+--             liftType
+--        4) sumtypes:
+--             this is the most fuzzy and complicated part. For each lifted
+--             sumtype we need to generate function to access and combine the
+--             component arrays
+--
+--   NOTE: the type information of variables and data constructors is *not*
+--          changed to reflect it's representation. This has to be solved 
+--          somehow (???, FIXME)  using type indexed types
+--
+--   Vectorisation:
+--    is very naive at the moment. One of the most striking inefficiencies is
+--    application vect (app e1 e2) -> app (fst (vect e1) (vect e2)) if e1 is a
+--    lambda abstraction. The vectorisation produces a pair consisting of the
+--    original and the lifted function, but the lifted version is discarded.
+--    I'm also not sure how much of this would be thrown out by the simplifier
+--    eventually
+--
+--        *) vectorise
+--
+--  Conventions:
+--
+--- TODO ----------------------------------------------------------------------
+--
+--   * look closer into the definition of type definition (TypeThing or so)
+--
+
+module Flattening (
+  flatten, flattenExpr, 
+) where 
+
+#include "HsVersions.h"
+
+-- friends
+import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault,
+		     isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
+import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
+		     liftVar, liftConst, intersectWithContext, mk'fst,
+		     mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP,
+		     mk'indexOfP,mk'eq,mk'neq) 
+
+-- GHC
+import TcType	    ( tcIsForAllTy, tcView )
+import TypeRep	    ( Type(..) )
+import StaticFlags  (opt_Flatten)
+import Panic        (panic)
+import ErrUtils     (dumpIfSet_dyn)
+import UniqSupply   (mkSplitUniqSupply)
+import DynFlags  (DynFlag(..))
+import Literal      (Literal, literalType)
+import Var	    (Var(..), idType, isTyVar)
+import Id	    (setIdType)
+import DataCon	    (DataCon, dataConTag)
+import HscTypes	    ( ModGuts(..), ModGuts, HscEnv(..), hscEPS )
+import CoreFVs	    (exprFreeVars)
+import CoreSyn	    (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
+		     CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
+		     mkApps, mkIntLitInt)  
+import PprCore      (pprCoreExpr)
+import CoreLint	    (showPass, endPass)
+
+import CoreUtils    (exprType, applyTypeToArg, mkPiType)
+import VarEnv       (zipVarEnv)
+import TysWiredIn   (mkTupleTy)
+import BasicTypes   (Boxity(..))
+import Outputable
+import FastString
+
+
+-- FIXME: fro debugging - remove this
+import TRACE    (trace)
+
+-- standard
+import Monad        (liftM, foldM)
+
+-- toplevel transformation
+-- -----------------------
+
+-- entry point to the flattening transformation for the compiler driver when
+-- compiling a complete module (EXPORTED) 
+--
+flatten :: HscEnv
+	-> ModGuts
+	-> IO ModGuts
+flatten hsc_env mod_impl@(ModGuts {mg_binds = binds}) 
+  | not opt_Flatten = return mod_impl -- skip without -fflatten
+  | otherwise       =
+  do
+    let dflags = hsc_dflags hsc_env
+
+    eps <- hscEPS hsc_env
+    us <- mkSplitUniqSupply 'l'		-- 'l' as in fLattening
+    --
+    -- announce vectorisation
+    --
+    showPass dflags "Flattening [first phase: vectorisation]"
+    --
+    -- vectorise all toplevel bindings
+    --
+    let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds
+    --
+    -- and dump the result if requested
+    --
+    endPass dflags "Flattening [first phase: vectorisation]" 
+	    Opt_D_dump_vect binds'
+    return $ mod_impl {mg_binds = binds'}
+
+-- entry point to the flattening transformation for the compiler driver when
+-- compiling a single expression in interactive mode (EXPORTED) 
+--
+flattenExpr :: HscEnv
+	    -> CoreExpr			-- the expression to be flattened
+	    -> IO CoreExpr
+flattenExpr hsc_env expr
+  | not opt_Flatten = return expr       -- skip without -fflatten
+  | otherwise       =
+  do
+    let dflags = hsc_dflags hsc_env
+    eps <- hscEPS hsc_env
+
+    us <- mkSplitUniqSupply 'l'		-- 'l' as in fLattening
+    --
+    -- announce vectorisation
+    --
+    showPass dflags "Flattening [first phase: vectorisation]"
+    --
+    -- vectorise the expression
+    --
+    let expr' = fst . runFlatten hsc_env eps us $ vectorise expr
+    --
+    -- and dump the result if requested
+    --
+    dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression"
+		  (pprCoreExpr expr')
+    return expr'
+
+
+-- vectorisation of bindings and expressions
+-- -----------------------------------------
+
+
+vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind]
+vectoriseTopLevelBinds binds =
+  do
+    vbinds <- mapM vectoriseBind binds
+    return (adjustTypeBinds vbinds)
+
+adjustTypeBinds:: [CoreBind] -> [CoreBind]
+adjustTypeBinds vbinds =
+    let 
+       ids = concat (map extIds vbinds)
+       idEnv =  zipVarEnv ids ids
+     in map (substIdEnvBind idEnv) vbinds
+  where 
+    -- FIXME replace by 'bindersOf'
+    extIds (NonRec b expr) = [b]
+    extIds (Rec      bnds) = map fst bnds
+    substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr)
+    substIdEnvBind idEnv (Rec bnds)      
+       = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds) 
+
+-- vectorise a single core binder
+--
+vectoriseBind	              :: CoreBind -> Flatten CoreBind
+vectoriseBind (NonRec b expr)  = 
+  liftM (NonRec b) $ liftM fst $ vectorise expr
+vectoriseBind (Rec bindings)   = 
+  liftM Rec        $ mapM vectoriseOne bindings
+  where
+    vectoriseOne (b, expr) = 
+      do
+	(vexpr, ty) <- vectorise expr
+	return (setIdType b ty, vexpr)
+
+
+-- Searches for function definitions and creates a lifted version for 
+-- each function.
+-- We have only two interesting cases:
+-- 1) function application  (ex1) (ex2)
+--      vectorise both subexpressions. The function will end up becoming a
+--      pair (orig. fun, lifted fun), choose first component (in many cases,
+--      this is pretty inefficient, since the lifted version is generated
+--      although it is clear that it won't be used
+-- 
+-- 2) lambda abstraction
+--      any function has to exist in two forms: it's original form and it's 
+--      lifted form. Therefore, every lambda abstraction is transformed into
+--      a pair of functions: the original function and its lifted variant
+-- 
+--
+--  FIXME: currently, I use 'exprType' all over the place - this is terribly
+--  inefficient. It should be suffiecient to change 'vectorise' and 'lift' to
+--  return the type of the result expression as well.
+--
+vectorise:: CoreExpr -> Flatten (CoreExpr, Type)
+vectorise (Var id)  =  
+  do 
+    let varTy  = idType id
+    let vecTy  = vectoriseTy varTy
+    return (Var (setIdType id vecTy), vecTy)
+
+vectorise (Lit lit) =  
+  return ((Lit lit), literalType lit) 
+
+
+vectorise e@(App expr t@(Type _)) = 
+  do 
+    (vexpr, vexprTy) <- vectorise expr
+    return ((App vexpr t), applyTypeToArg vexprTy t) 
+
+vectorise  (App (Lam b expr) arg) =
+  do
+    (varg, argTy)    <- vectorise arg
+    (vexpr, vexprTy) <- vectorise expr
+    let vb            = setIdType b argTy
+    return ((App (Lam vb  vexpr) varg), 
+            applyTypeToArg (mkPiType vb vexprTy) varg)
+
+-- if vexpr expects a type as first argument
+-- application stays just as it is
+--
+vectorise (App expr arg) =          
+  do 
+    (vexpr, vexprTy) <-  vectorise expr
+    (varg,  vargTy)  <-  vectorise arg
+
+    if (tcIsForAllTy vexprTy)
+      then do
+        let resTy =  applyTypeToArg vexprTy varg
+        return (App vexpr varg, resTy)
+      else do 
+        let [t1, t2] = tupleTyArgs  vexprTy
+        vexpr'      <-  mk'fst t1 t2 vexpr
+        let resTy    = applyTypeToArg t1 varg   
+        return  ((App vexpr' varg), resTy)  -- apply the first component of
+                                            -- the vectorized function
+
+vectorise  e@(Lam b expr)
+  | isTyVar b
+  =  do
+        (vexpr, vexprTy) <- vectorise expr          -- don't vectorise 'b'!
+        return ((Lam b vexpr), mkPiType b vexprTy)
+  | otherwise =
+     do          
+       (vexpr, vexprTy)  <- vectorise expr
+       let vb             = setIdType b (vectoriseTy (idType b))
+       let ve             =  Lam  vb  vexpr 
+       (lexpr, lexprTy)  <- lift e
+       let veTy = mkPiType vb vexprTy  
+       return $ (mkTuple [veTy, lexprTy] [ve, lexpr], 
+                 mkTupleTy Boxed 2 [veTy, lexprTy])
+
+vectorise (Let bind body) = 
+  do    
+    vbind            <- vectoriseBind bind
+    (vbody, vbodyTy) <- vectorise body
+    return ((Let vbind vbody), vbodyTy)
+
+vectorise (Case expr b ty alts) =
+  do 
+    (vexpr, vexprTy) <- vectorise expr
+    valts <- mapM vectorise' alts
+    let res_ty = snd (head valts)
+    return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)
+  where vectorise' (con, bs, expr) = 
+          do 
+            (vexpr, vexprTy) <- vectorise expr
+            return ((con, bs, vexpr), vexprTy)  -- FIXME: change type of con
+                                                --   and bs
+
+
+
+vectorise (Note note expr) = 
+ do 
+   (vexpr, vexprTy) <- vectorise expr        -- FIXME: is this ok or does it
+   return ((Note note vexpr), vexprTy)       --   change the validity of note?
+
+vectorise e@(Type t) = 
+  return (e, t)                              -- FIXME: panic instead of 't'???
+
+
+{-
+myShowTy (TyVarTy _) = "TyVar "
+myShowTy (AppTy t1 t2) = 
+  "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
+myShowTy (TyConApp _ t) =
+  "TyConApp TC (" ++ (myShowTy t) ++ ")"
+-}
+
+vectoriseTy :: Type -> Type 
+vectoriseTy ty | Just ty' <- tcView ty = vectoriseTy ty'
+	-- Look through notes and synonyms
+	-- NB: This will discard notes and synonyms, of course
+	-- ToDo: retain somehow?
+vectoriseTy t@(TyVarTy v)      =  t
+vectoriseTy t@(AppTy t1 t2)    = 
+  AppTy (vectoriseTy t1) (vectoriseTy t2)
+vectoriseTy t@(TyConApp tc ts) = 
+  TyConApp tc (map vectoriseTy ts)
+vectoriseTy t@(FunTy t1 t2)    = 
+  mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)), 
+                     (liftTy t)]
+vectoriseTy  t@(ForAllTy v ty)  = 
+  ForAllTy v (vectoriseTy  ty)
+vectoriseTy  t =  t
+
+
+-- liftTy: wrap the type in an array but be careful with function types
+--    on the *top level* (is this sufficient???)
+
+liftTy:: Type -> Type
+liftTy ty | Just ty' <- tcView ty = liftTy ty'
+liftTy (FunTy t1 t2)   = FunTy (liftTy t1) (liftTy t2)
+liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
+liftTy  t              = mkPArrTy t
+
+
+--  lifting:
+-- ----------
+--  * liftType
+--  * lift
+
+
+-- liftBinderType: Converts a  type 'a' stored in the binder to the
+-- representation of '[:a:]' will therefore call liftType
+--  
+--  lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
+--  but I'm not entirely sure about some fields (e.g., strictness info)
+liftBinderType:: CoreBndr ->  Flatten CoreBndr
+liftBinderType bndr = return $  setIdType bndr (liftTy (idType bndr))
+
+-- lift: lifts an expression (a -> [:a:])
+-- If the expression is a simple expression, it is treated like a constant
+-- expression. 
+-- If the body of a lambda expression is a simple expression, it is
+-- transformed into a mapP
+lift:: CoreExpr -> Flatten (CoreExpr, Type)
+lift cExpr@(Var id)    = 
+  do
+    lVar@(Var lId) <- liftVar id
+    return (lVar, idType lId)
+
+lift cExpr@(Lit lit)   = 
+  do
+    lLit  <- liftConst cExpr
+    return (lLit, exprType lLit)   
+                                   
+
+lift (Lam b expr)
+  | isSimpleExpr expr      =  liftSimpleFun b expr
+  | isTyVar b = 
+    do
+      (lexpr, lexprTy) <- lift expr  -- don't lift b!
+      return (Lam b lexpr, mkPiType b lexprTy)
+  | otherwise =
+    do
+      lb               <- liftBinderType b
+      (lexpr, lexprTy) <- extendContext [lb] (lift expr)
+      return ((Lam lb lexpr) , mkPiType lb lexprTy)
+
+lift (App expr1 expr2) = 
+  do
+    (lexpr1, lexpr1Ty) <- lift expr1
+    (lexpr2, _)        <- lift expr2
+    return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2)
+
+
+lift (Let (NonRec b expr1) expr2) 
+  |isSimpleExpr expr2 =
+    do  			
+      (lexpr1, _)        <- lift expr1
+      (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2
+      let (t1, t2) = funTyArgs lexpr2Ty
+      liftM (\x -> (x, liftTy t2)) $  mk'mapP t1 t2 lexpr2 lexpr1 
+
+  | otherwise =
+    do 
+      (lexpr1, _)        <- lift expr1
+      lb                 <- liftBinderType b
+      (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1)
+      return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty)
+
+lift (Let (Rec binds) expr2) =
+  do
+    let (bndVars, exprs)  = unzip binds
+    lBndVars           <- mapM liftBinderType bndVars 
+    lexprs             <- extendContext bndVars (mapM lift exprs)
+    (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2)
+    return ((Let (Rec (zip  lBndVars (map fst lexprs))) lexpr2), lexpr2Ty)
+
+-- FIXME: 
+-- Assumption: alternatives can either be literals or data construtors.
+--             Due to type restrictions, I don't think it is possible 
+--             that they are mixed.
+--             The handling of literals and data constructors is completely
+--             different
+--
+--
+-- let b = expr in alts
+--
+-- I think I read somewhere that the default case (if present) is stored
+-- in the head of the list. Assume for now this is true, have to check
+--
+-- (1) literals
+-- (2) data constructors
+--
+-- FIXME: optimisation: first, filter out all simple expression and 
+--   loop (mapP & filter) over all the corresponding values in a single
+--   traversal:
+							     
+--    (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr])
+--                                       simple alts     reg alts
+--    (2) if simpleAlts = [] then (just as before)
+--        if regAlts    = [] then (the whole thing is just a loop)
+--        otherwise (a) compute index vector for simpleAlts (for def permute
+--                      later on
+--                  (b) 
+-- gaw 2004 FIX? 
+lift cExpr@(Case expr b _ alts)  =
+  do  
+    (lExpr, _) <- lift expr
+    lb    <- liftBinderType  b     -- lift alt-expression
+    lalts <- if isLit alts 
+                then extendContext [lb] (liftCaseLit b alts)
+                else extendContext [lb] (liftCaseDataCon b alts)
+    letWrapper lExpr b lalts
+
+lift (Note (Coerce t1 t2) expr) =
+  do  
+    (lexpr, t) <- lift expr
+    let lt1 = liftTy t1
+    return ((Note (Coerce lt1 (liftTy t2)) lexpr), lt1)
+
+lift (Note note expr) =
+  do 
+    (lexpr, t) <- lift expr
+    return ((Note note lexpr), t)
+
+lift e@(Type t) = return (e, t)
+
+
+-- auxilliary functions for lifting of case statements 
+--
+
+liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] -> 
+       Flatten (([CoreBind], [CoreBind], [CoreBind]))
+liftCaseDataCon b [] =
+  return ([], [], [])
+liftCaseDataCon b alls@(alt:alts)
+  | isDefault alt  =
+    do
+      (i,  e,  defAltBndrs) <- liftCaseDataConDefault b alt alts 
+      (is, es, altBndrs)    <- liftCaseDataCon' b alts 
+      return (i:is, e:es, defAltBndrs ++ altBndrs)
+  | otherwise =
+    liftCaseDataCon' b alls
+
+liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->  
+    Flatten ([CoreBind], [CoreBind], [CoreBind])
+liftCaseDataCon' _ [] =
+  do
+    return ([], [], []) 
+
+
+liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
+  do
+    (permBnd, exprBnd, packBnd)    <-  liftSingleDataCon b dcon bnds expr   
+    (permBnds, exprBnds, packBnds) <-  liftCaseDataCon' b alts 
+    return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
+
+
+-- FIXME: is is really necessary to return the binding to the permutation
+-- array in the data constructor case, as the representation already 
+-- contains the extended flag vector
+liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
+  Flatten (CoreBind, CoreBind, [CoreBind])
+liftSingleDataCon b dcon bnds expr =
+  do 
+    let dconId           = dataConTag dcon
+    indexExpr           <- mkIndexOfExprDCon (idType b)  b dconId
+    (bb, bbind)         <- mkBind FSLIT("is") indexExpr
+    lbnds               <- mapM liftBinderType bnds
+    ((lExpr, _), bnds') <- packContext  bb (extendContext lbnds (lift expr))
+    (_, vbind)          <- mkBind FSLIT("r") lExpr
+    return (bbind, vbind, bnds')
+
+-- FIXME: clean this up. the datacon and the literal case are so
+--   similar that it would be easy to use the same function here
+--   instead of duplicating all the code.
+--
+liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) ->  [Alt CoreBndr] 
+  ->  Flatten (CoreBind, CoreBind, [CoreBind])
+liftCaseDataConDefault b (_, _, def) alts =
+  do
+    let dconIds        = map (\(DataAlt d, _, _) -> dataConTag d) alts
+    indexExpr         <- mkIndexOfExprDConDft (idType b) b dconIds
+    (bb, bbind)       <- mkBind FSLIT("is") indexExpr
+    ((lDef, _), bnds) <- packContext  bb (lift def)     
+    (_, vbind)        <- mkBind FSLIT("r") lDef
+    return (bbind, vbind, bnds)
+
+-- liftCaseLit: checks if we have a default case and handles it 
+-- if necessary
+liftCaseLit:: CoreBndr -> [Alt CoreBndr] -> 
+       Flatten ([CoreBind], [CoreBind], [CoreBind])
+liftCaseLit b [] =
+    return ([], [], [])    --FIXME: a case with no cases at all???
+liftCaseLit b alls@(alt:alts)
+  | isDefault alt  =
+    do
+        (i,  e,  defAltBndrs) <- liftCaseLitDefault b alt alts 
+        (is, es, altBndrs)    <- liftCaseLit' b alts 
+        return (i:is, e:es, defAltBndrs ++ altBndrs)
+  | otherwise = 
+    do 
+      liftCaseLit' b alls 
+
+-- liftCaseLitDefault: looks at all the other alternatives which 
+--    contain a literal and filters all those elements from the 
+--    array which do not match any of the literals in the other
+--    alternatives.
+liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) ->  [Alt CoreBndr] 
+  ->  Flatten (CoreBind, CoreBind, [CoreBind])
+liftCaseLitDefault b (_, _, def) alts =
+  do
+    let lits           = map (\(LitAlt l, _, _) -> l) alts
+    indexExpr         <- mkIndexOfExprDft (idType b) b lits
+    (bb, bbind)       <- mkBind FSLIT("is") indexExpr
+    ((lDef, _), bnds) <- packContext  bb (lift def)     
+    (_, vbind)        <- mkBind FSLIT("r") lDef
+    return (bbind, vbind, bnds)
+
+-- FIXME: 
+--  Assumption: in case of Lit, the list of binders of the alt is empty.
+--
+-- returns 
+--   a list of all vars bound to the expr in the body of the alternative
+--   a list of (var, expr) pairs, where var has to be bound to expr
+--   by letWrapper
+liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->  
+    Flatten ([CoreBind], [CoreBind], [CoreBind])						       
+liftCaseLit' _ [] =
+  do
+    return ([], [], [])
+liftCaseLit' b ((LitAlt lit, [], expr):alts) =
+  do
+    (permBnd, exprBnd, packBnd)    <-  liftSingleCaseLit b lit expr 
+    (permBnds, exprBnds, packBnds) <-  liftCaseLit' b alts 
+    return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
+
+-- lift a single alternative of the form: case  b of lit -> expr. 
+--    
+--   It returns the bindings:
+--   (a) let b' = indexOfP (mapP (\x -> x == lit) b)
+--
+--   (b) lift expr in the packed context. Returns lexpr and the
+--       list of binds (bnds) that describe the packed arrays
+--
+--   (c) create new var v' to bind lexpr to
+--
+--   (d) return (b' = indexOf...., v' = lexpr, bnds)
+liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr  -> 
+  Flatten (CoreBind, CoreBind, [CoreBind])
+liftSingleCaseLit b lit expr =
+ do 
+   indexExpr          <- mkIndexOfExpr (idType b) b lit -- (a)
+   (bb, bbind)        <- mkBind FSLIT("is") indexExpr
+   ((lExpr, t), bnds) <- packContext  bb (lift expr)     -- (b)         
+   (_, vbind)         <- mkBind FSLIT("r") lExpr
+   return (bbind, vbind, bnds)
+
+-- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
+-- 
+-- let b = lExpr in
+--  let index_bnd_1 in
+--    let packbnd_11 in
+--      ... packbnd_1m in 
+--         let exprbnd_1 in        ....
+--      ...
+--          let nvar = replicate dummy (length <current context>)
+--               nvar1 = bpermuteDftP index_bnd_1 ...
+--
+--   in bpermuteDftP index_bnd_n nvar_(n-1)
+--
+letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
+  Flatten (CoreExpr, Type)
+letWrapper lExpr b (indBnds, exprBnds, pckBnds)  =
+  do 
+    (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
+    let resExpr      = getExprOfBind (head defBpBnds)
+    return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
+
+-- dftbpBinders: return the list of binders necessary to construct the overall
+--   result from the subresults computed in the different branches of the case
+--   statement. The binding which contains the final result is in the *head*
+--   of the result list.
+-- 
+-- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
+--
+-- let def = replicate (length of context) undefined
+--     d1  = bpermuteDftP dft e1 i1
+--     .....
+--
+dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
+dftbpBinders indexBnds exprBnds =
+  do
+    let expr = getExprOfBind (head exprBnds)
+    defVecExpr     <- createDftArrayBind expr
+    ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
+    return ((b:bnds),t)
+  where
+    dftbpBinders' :: [CoreBind] 
+		  -> [CoreBind] 
+		  -> CoreBind 
+		  -> Flatten ((CoreBind, [CoreBind]), Type)
+    dftbpBinders' [] [] cBnd =
+      return ((cBnd, []), panic "dftbpBinders: undefined type")
+    dftbpBinders' (i:is) (e:es) cBind =
+      do
+	let iVar = getVarOfBind i
+	let eVar = getVarOfBind e
+	let cVar = getVarOfBind cBind
+        let ty   = idType eVar
+	newBnd  <- mkDftBackpermute ty iVar eVar cVar
+	((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
+	return ((fBnd, (newBnd:restBnds)), liftTy ty)
+
+    dftbpBinders'  _ _ _ = 
+      panic "Flattening.dftbpBinders: index and expression binder lists have different length!"
+
+getExprOfBind:: CoreBind -> CoreExpr
+getExprOfBind (NonRec _ expr) = expr
+
+getVarOfBind:: CoreBind -> Var
+getVarOfBind (NonRec b _) = b
+
+
+
+-- Optimised Transformation
+-- =========================
+--
+
+-- liftSimpleFun
+--   if variables x_1 to x_i occur in the context *and* free in expr
+--   then 
+--   (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn)
+--
+liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type)
+liftSimpleFun b expr =
+  do
+    bndVars <- collectBoundVars expr
+    let bndVars'     = b:bndVars
+        bndVarsTuple = mkTuple (map idType bndVars') (map Var bndVars')
+	lamExpr      = mkLams (b:bndVars) expr     -- FIXME: should be tuple
+                                                   -- here 
+    let (t1, t2)     = funTyArgs . exprType $ lamExpr
+    mapExpr         <-  mk'mapP t1 t2 lamExpr bndVarsTuple
+    let lexpr        = mkApps mapExpr [bndVarsTuple]
+    return (lexpr, undefined)                      -- FIXME!!!!!
+
+
+collectBoundVars:: CoreExpr -> Flatten [CoreBndr]
+collectBoundVars  expr = 
+  intersectWithContext (exprFreeVars expr)
+
+
+-- auxilliary routines
+-- -------------------
+
+-- mkIndexOfExpr b lit ->
+--   indexOf (mapP (\x -> x == lit) b) b
+--
+mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
+mkIndexOfExpr  idType b lit =
+  do 
+    eqExpr        <- mk'eq idType (Var b) (Lit lit)
+    let lambdaExpr = (Lam b eqExpr)
+    mk'indexOfP idType  lambdaExpr (Var b)
+
+-- there is FlattenMonad.mk'indexOfP as well as
+-- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
+
+-- for case-distinction over data constructors:
+-- let b = expr in 
+--   case b of
+--      dcon args -> ....
+-- dconId = dataConTag dcon 
+-- the call "mkIndexOfExprDCon b dconId" computes the core expression for
+-- indexOfP (\x -> x == dconId) b)
+--
+mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr
+mkIndexOfExprDCon  idType b dId = 
+  do 
+    let intExpr    = mkIntLitInt dId
+    eqExpr        <- mk'eq  idType (Var b) intExpr
+    let lambdaExpr = (Lam b intExpr)
+    mk'indexOfP idType lambdaExpr (Var b) 
+
+  
+
+-- there is FlattenMonad.mk'indexOfP as well as
+-- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
+
+-- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the
+-- default case. "dconIds" is a list of all the data constructor idents which 
+-- are covered by the other cases.
+-- indexOfP (\x -> x != dconId_1 && ....) b)
+--
+mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
+mkIndexOfExprDConDft idType b dId  = 
+  do 
+    let intExprs   = map mkIntLitInt dId
+    bExpr         <- foldM (mk'neq idType) (head intExprs) (tail intExprs)
+    let lambdaExpr = (Lam b bExpr)
+    mk'indexOfP idType (Var b) bExpr
+  
+
+-- mkIndexOfExprDef b [lit1, lit2,...] ->
+--   indexOf (\x -> not (x == lit1 || x == lit2 ....) b
+mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
+mkIndexOfExprDft idType b lits = 
+  do 
+    let litExprs   = map (\l-> Lit l)  lits
+    bExpr         <- foldM (mk'neq idType) (head litExprs) (tail litExprs)
+    let lambdaExpr = (Lam b bExpr)
+    mk'indexOfP idType bExpr (Var b) 
+
+
+-- create a back-permute binder
+--
+--  * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
+--   Core binding of the form
+--
+--     x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
+--
+--   where `x' is a new local variable
+--
+mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind
+mkDftBackpermute ty idx src dft = 
+  do
+    rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft)
+    liftM snd $ mkBind FSLIT("dbp") rhs
+
+-- create a dummy array with elements of the given type, which can be used as
+-- default array for the combination of the subresults of the lifted case
+-- expression
+--
+createDftArrayBind    :: CoreExpr -> Flatten CoreBind
+createDftArrayBind e  =
+  panic "Flattening.createDftArrayBind: not implemented yet"
+{-
+  do
+    let ty = parrElemTy . exprType $ expr
+    len <- mk'lengthP e
+    rhs <- mk'replicateP ty len err??
+    lift snd $ mkBind FSLIT("dft") rhs
+FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde
+  beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen
+  generischen Wert f"ur jeden beliebigen Typ zu erfinden.
+-}
+
+
+
+
+-- show functions (the pretty print functions sometimes don't 
+-- show it the way I want....
+
+-- shows just the structure
+showCoreExpr (Var _ )    = "Var "
+showCoreExpr (Lit _) = "Lit "
+showCoreExpr (App e1 e2) = 
+  "(App \n  " ++ (showCoreExpr e1) ++ "\n  " ++ (showCoreExpr e2) ++ ") "
+showCoreExpr (Lam b e)   =
+  "Lam b " ++ (showCoreExpr e)
+showCoreExpr (Let bnds expr) =
+  "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr)
+  where showBinds (NonRec b e) = showBind (b,e)
+        showBinds (Rec bnds)   = concat (map showBind bnds)
+        showBind (b,e) = "  b = " ++ (showCoreExpr e)++ "\n"
+-- gaw 2004 FIX?
+showCoreExpr (Case ex b ty alts) =
+  "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
+  where showAlts _ = ""  
+showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
+showCoreExpr (Type t) = "Type"
diff --git a/compiler/ndpFlatten/NDPCoreUtils.hs b/compiler/ndpFlatten/NDPCoreUtils.hs
new file mode 100644
index 0000000000..6e6b94f175
--- /dev/null
+++ b/compiler/ndpFlatten/NDPCoreUtils.hs
@@ -0,0 +1,174 @@
+--  $Id$
+--
+--  Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller
+--
+--  Auxiliary routines for NDP-related Core transformations.
+--
+--- DESCRIPTION ---------------------------------------------------------------
+--
+--  This module exports all functions to access and alter the `Type' data 
+--  structure from modules `Type' and `CoreExpr' from `CoreSyn'.  As it is part
+--  of the NDP flattening component, the functions provide access to all the
+--  fields that are important for the flattening and lifting transformation.
+-- 
+--- DOCU ----------------------------------------------------------------------
+--
+--  Language: Haskell 98
+--
+--- TODO ----------------------------------------------------------------------
+--
+
+module NDPCoreUtils (
+
+  -- type inspection functions
+  --
+  tupleTyArgs,		-- :: Type -> [Type]
+  funTyArgs,		-- :: Type -> (Type, Type)
+  parrElemTy,		-- :: Type -> Type
+
+  -- Core generation functions
+  --
+  mkTuple,		-- :: [Type] -> [CoreExpr] -> CoreExpr
+  mkInt,		-- :: CoreExpr -> CoreExpr
+
+  -- query functions
+  --
+  isDefault,            -- :: CoreAlt -> Bool
+  isLit,		-- :: [CoreAlt] -> Bool
+  isSimpleExpr,		-- :: CoreExpr -> Bool
+
+  -- re-exported functions
+  --
+  mkPArrTy,		-- :: Type -> Type
+  boolTy,		-- :: Type
+  
+  -- substitution
+  -- 
+  substIdEnv
+) where
+
+-- GHC
+import Panic      (panic)
+import Outputable (Outputable(ppr), pprPanic)
+import BasicTypes (Boxity(..))
+import Type       (Type, splitTyConApp_maybe, splitFunTy)
+import TyCon      (isTupleTyCon)
+import TysWiredIn (parrTyCon, unitDataConId, tupleCon, intDataCon, mkPArrTy,
+		   boolTy) 
+import CoreSyn    (CoreExpr, CoreAlt, Expr(..), AltCon(..),
+		   Bind(..), mkConApp)
+import PprCore	  ( {- instances -} )
+import Var        (Id)
+import VarEnv     (IdEnv, delVarEnv, delVarEnvList, lookupVarEnv)
+
+-- friends: don't import any to avoid cyclic imports
+-- 
+
+
+-- type inspection functions
+-- -------------------------
+
+-- determines the argument types of a tuple type (EXPORTED)
+--
+tupleTyArgs    :: Type -> [Type]
+tupleTyArgs ty  =
+  case splitTyConApp_maybe ty of
+    Just (tyCon, argTys) | isTupleTyCon tyCon -> argTys
+    _					      -> 
+      pprPanic "NDPCoreUtils.tupleTyArgs: wrong type: " (ppr ty)
+
+-- determines the argument and result type of a function type (EXPORTED)
+--
+funTyArgs :: Type -> (Type, Type)
+funTyArgs  = splitFunTy
+
+-- for a type of the form `[:t:]', yield `t' (EXPORTED)
+--
+--  * if the type has any other form, a fatal error occurs
+--
+parrElemTy    :: Type -> Type
+parrElemTy ty  = 
+  case splitTyConApp_maybe ty of
+    Just (tyCon, [argTy]) | tyCon == parrTyCon -> argTy
+    _							     -> 
+      pprPanic "NDPCoreUtils.parrElemTy: wrong type: " (ppr ty)
+
+
+-- Core generation functions
+-- -------------------------
+
+-- make a tuple construction expression from a list of argument types and
+-- argument values (EXPORTED)
+--
+--  * the two lists need to be of the same length
+--
+mkTuple                                  :: [Type] -> [CoreExpr] -> CoreExpr
+mkTuple []  []                            = Var unitDataConId
+mkTuple [_] [e]                           = e
+mkTuple ts  es  | length ts == length es  = 
+  mkConApp (tupleCon Boxed (length es)) (map Type ts ++ es)
+mkTuple _   _                             =
+  panic "NDPCoreUtils.mkTuple: mismatch between number of types and exprs!"
+
+-- make a boxed integer from an unboxed one (EXPORTED)
+--
+mkInt   :: CoreExpr -> CoreExpr
+mkInt e  = mkConApp intDataCon [e]
+
+
+-- query functions
+-- ---------------
+
+-- checks whether a given case alternative is a default alternative (EXPORTED)
+--
+isDefault                 :: CoreAlt -> Bool
+isDefault (DEFAULT, _, _)  = True
+isDefault _                = False
+
+-- check whether a list of case alternatives in belongs to a case over a
+-- literal type (EXPORTED) 
+--
+isLit			      :: [CoreAlt] -> Bool
+isLit ((DEFAULT, _, _ ):alts)  = isLit alts
+isLit ((LitAlt _, _, _):_   )  = True
+isLit _                        = False
+
+-- FIXME: this function should get a more expressive name and maybe also a
+--	  more detailed return type (depends on how the analysis goes)
+isSimpleExpr:: CoreExpr -> Bool
+isSimpleExpr _ =
+  -- FIXME
+  False
+
+
+--  Substitution
+--  -------------
+
+substIdEnv:: IdEnv Id -> CoreExpr -> CoreExpr
+substIdEnv env e@(Lit _) = e
+substIdEnv env e@(Var id)  =
+  case (lookupVarEnv env id) of
+    Just v -> (Var v)
+    _      -> e
+substIdEnv env (App e arg) =
+  App (substIdEnv env e) (substIdEnv env arg)
+substIdEnv env (Lam b expr) =
+  Lam b (substIdEnv (delVarEnv env b) expr)
+substIdEnv env (Let (NonRec b expr1) expr2) =
+  Let (NonRec b (substIdEnv env expr1)) 
+         (substIdEnv (delVarEnv env b) expr2)
+substIdEnv env (Let (Rec bnds) expr) = 
+   let 
+     newEnv  = delVarEnvList env (map fst bnds)
+     newExpr = substIdEnv newEnv expr 
+     substBnd (b,e) = (b, substIdEnv newEnv e)      
+   in Let (Rec (map substBnd bnds)) newExpr
+substIdEnv env (Case expr b ty alts) =
+   Case (substIdEnv newEnv expr) b ty (map substAlt alts)
+   where
+     newEnv = delVarEnv env b
+     substAlt (c, bnds, expr) =
+       (c, bnds, substIdEnv (delVarEnvList env bnds) expr)
+substIdEnv env (Note n expr) =
+  Note n (substIdEnv env expr)
+substIdEnv env e@(Type t) = e
diff --git a/compiler/ndpFlatten/PArrAnal.hs b/compiler/ndpFlatten/PArrAnal.hs
new file mode 100644
index 0000000000..2db56221b2
--- /dev/null
+++ b/compiler/ndpFlatten/PArrAnal.hs
@@ -0,0 +1,203 @@
+--  $Id$
+--
+--  Copyright (c) 2002 Manuel M T Chakravarty & Gabriele Keller
+--  
+--  Analysis phase for an optimised flattening transformation
+--
+--- DESCRIPTION ---------------------------------------------------------------
+--
+--  This module implements an analysis phase that identifies Core expressions
+--  that need not be transformed during flattening.  The expressions when
+--  executed in a parallel context are implemented as an iteration over the
+--  original scalar computation, instead of vectorising the computation.  This
+--  usually improves efficiency by increasing locality and also reduces code
+--  size. 
+--
+--- DOCU ----------------------------------------------------------------------
+--
+--  Language: Haskell 98 with C preprocessor
+--
+-- Analyse the expression and annotate each simple subexpression accordingly. 
+--
+--  The result of the analysis is stored in a new field in IdInfo (has yet to
+--  be extended)
+--
+--  A simple expression is any expression which is not a function, not of
+--  recursive type and does not contain a value of PArray type. Polymorphic
+--  variables are simple expressions even though they might be instantiated to
+--  a parray value or function.
+--
+--- TODO ----------------------------------------------------------------------
+--
+
+module PArrAnal (
+  markScalarExprs	-- :: [CoreBind] -> [CoreBind]
+) where
+
+import Panic   (panic)
+import Outputable (pprPanic, ppr)
+import CoreSyn (CoreBind)
+
+import TypeRep      (Type(..))
+import Var (Var(..),Id)
+import Literal      (Literal)
+import CoreSyn (Expr(..),CoreExpr,Bind(..))
+import PprCore ( {- instances -} )
+-- 
+
+data ArrayUsage = Prim | NonPrim | Array 
+                | PolyExpr (Id -> Maybe (ArrayUsage -> ArrayUsage))
+                | PolyFun (ArrayUsage -> ArrayUsage)
+
+         
+arrUsage:: CoreExpr -> ArrayUsage
+arrUsage (Var id)  = varArrayUsage id
+arrUsage (Lit lit) = litArrayUsage lit
+arrUsage (App expr1 expr2) =
+  let
+    arr1 = arrUsage expr1
+    arr2 = arrUsage expr2
+  in 
+  case (arr1, arr2) of   
+    (_,        Array)  -> Array
+    (PolyFun f, _)     -> f arr2
+    (_, _)             -> arr1
+
+arrUsage (Lam b expr) =
+  bindType (b, expr)
+
+arrUsage (Let (NonRec b expr1) expr2) =
+  arrUsage (App (Lam b expr2) expr1)
+
+arrUsage (Let (Rec bnds) expr) =
+  let 
+    t1 = foldr combineArrayUsage Prim (map bindType bnds)
+    t2 = arrUsage expr
+  in if isArrayUsage t1 then Array else t2
+
+arrUsage (Case expr b _ alts) = 
+  let 
+    t1 = arrUsage expr
+    t2 = scanType (map (arrUsage . (\ (_,_,x) -> x)) alts)
+  in scanType [t1, t2]
+
+arrUsage (Note n expr) =
+  arrUsage expr
+
+arrUsage (Type t) =
+  typeArrayUsage  t
+
+bindType (b, expr) =
+  let
+    bT    = varArrayUsage b
+    exprT = arrUsage expr
+  in case (bT, exprT) of
+       (Array, _) -> Array
+       _          -> exprT
+
+scanType:: [ArrayUsage] -> ArrayUsage
+scanType [t]        = t
+scanType (Array:ts) = Array
+scanType (_:ts)     = scanType ts
+  
+
+
+-- the code expression represents a built-in function which generates
+-- an array
+isArrayGen:: CoreExpr -> Bool
+isArrayGen _ = 
+  panic "PArrAnal: isArrayGen: not yet implemented"
+
+isArrayCon:: CoreExpr -> Bool
+isArrayCon _ = 
+  panic "PArrAnal: isArrayCon: not yet implemented"
+
+markScalarExprs:: [CoreBind] -> [CoreBind]
+markScalarExprs _ =
+  panic "PArrAnal.markScalarExprs: not implemented yet"
+
+
+varArrayUsage:: Id -> ArrayUsage
+varArrayUsage =
+  panic "PArrAnal.varArrayUsage: not yet implented"
+
+litArrayUsage:: Literal -> ArrayUsage
+litArrayUsage =
+  panic "PArrAnal.litArrayUsage: not yet implented"
+
+
+typeArrayUsage:: Type -> ArrayUsage
+typeArrayUsage (TyVarTy tvar) = 
+  PolyExpr (tIdFun tvar)
+typeArrayUsage (AppTy _ _) =
+   panic "PArrAnal.typeArrayUsage: AppTy case not yet implemented"
+typeArrayUsage (TyConApp tc tcargs) =
+  let
+    tcargsAU = map typeArrayUsage tcargs
+    tcCombine  = foldr combineArrayUsage Prim tcargsAU
+  in auCon tcCombine
+typeArrayUsage t@(PredTy _) =
+  pprPanic "PArrAnal.typeArrayUsage: encountered 'PredType - shouldn't be here!"
+           (ppr t)                 
+ 
+
+combineArrayUsage:: ArrayUsage -> ArrayUsage -> ArrayUsage 
+combineArrayUsage Array _  = Array 
+combineArrayUsage _ Array  = Array 
+combineArrayUsage (PolyExpr f1) (PolyExpr f2) =
+  PolyExpr f'   
+  where 
+    f' var = 
+      let
+        f1lookup = f1 var
+        f2lookup = f2 var
+       in 
+       case (f1lookup, f2lookup) of
+         (Nothing, _) -> f2lookup
+         (_, Nothing) -> f1lookup
+         (Just f1', Just f2') -> Just ( \e -> (combineArrayUsage (f1' e) (f2' e)))
+combineArrayUsage (PolyFun f) (PolyExpr g) = 
+        panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++
+               " constructor - should not (?) happen\n")
+combineArrayUsage (PolyExpr g) (PolyFun f)  = 
+        panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++
+               " constructor - should not (?) happen\n")
+combineArrayUsage NonPrim _ = NonPrim
+combineArrayUsage _ NonPrim = NonPrim
+combineArrayUsage Prim Prim = Prim
+
+
+isArrayUsage:: ArrayUsage -> Bool
+isArrayUsage Array = True
+isArrayUsage _     = False
+
+--  Functions to serve as arguments for PolyExpr
+--  ---------------------------------------------
+
+tIdFun:: Var -> Var -> Maybe (ArrayUsage -> ArrayUsage) 
+tIdFun t tcomp =
+  if t == tcomp then
+     Just auId
+  else
+     Nothing  
+
+-- Functions to serve as argument for PolyFun
+-- -------------------------------------------
+
+auId:: ArrayUsage -> ArrayUsage 
+auId = id
+
+auCon:: ArrayUsage -> ArrayUsage
+auCon Prim = NonPrim
+auCon (PolyExpr f) = PolyExpr f'
+  where f' v  = case f v of
+                   Nothing -> Nothing
+                   Just g  -> Just  ( \e -> (auCon (g e)))
+auCon (PolyFun f)  = PolyFun (auCon . f)
+auCon _    = Array
+
+-- traversal of Core expressions
+-- -----------------------------
+
+-- FIXME: implement
+
diff --git a/compiler/ndpFlatten/TODO b/compiler/ndpFlatten/TODO
new file mode 100644
index 0000000000..e596609205
--- /dev/null
+++ b/compiler/ndpFlatten/TODO
@@ -0,0 +1,202 @@
+	           TODO List for Flattening Support in GHC	     -*-text-*-
+		   =======================================
+
+Middle-End Related
+~~~~~~~~~~~~~~~~~~
+
+Flattening Transformation
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+* Complete and test
+
+* Complete the analysis
+
+* Type transformation: The idea solution would probably be if we can add some
+  generic machinery, so that we can define all the rules for handling the type
+  and value transformations in a library.  (The PrelPArr for WayNDP.)
+
+
+Library Related
+~~~~~~~~~~~~~~~
+
+* Problem with re-exporting PrelPArr from Prelude is that it would also be
+  visible when -pparr is not given.  There should be a mechanism to implicitly
+  import more than one module (like PERVASIVE modules in M3)
+
+* We need a PrelPArr-like library for when flattening is used, too.  In fact,
+  we need some library routines that are on the level of merely vectorised
+  code (eg, for the dummy default vectors), and then, all the `PArrays' stuff
+  implementing fast unboxed arrays and fusion.
+
+* Enum is a problem.  Ideally, we would like `enumFromToP' and
+  `enumFromThenToP' to be members of `Enum'.  On the other hand, we really do
+  not want to change `Enum'.  The solution for the moment is to define
+
+    enumFromTo x y       = mapP toEnum [:fromEnum x .. fromEnum y:]
+    enumFromThenTo x y z = mapP toEnum [:fromEnum x, fromEnum y .. fromEnum z:]
+
+  like the Haskell Report does for the list versions.  This is hopefully
+  efficient enough as array fusion should fold the two traversals into one.
+  [DONE]
+
+
+DOCU that should go into the Commentary
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The type constructor [::]
+-------------------------
+
+The array type constructor [::] is quite similar to [] (list constructor) in
+that GHC has to know about it (in TysWiredIn); however, there are some
+differences:
+
+* [::] is an abstract type, whereas [] is not
+
+* if flattening is switched on, all occurences of the type are actually
+  removed by appropriate program transformations.
+
+The module PrelPArr that actually implements nested parallel arrays.  [::] is
+eliminated only if in addition to array support, flattening is activated.  It
+is just an option rather than the only method to implement those arrays.
+
+  Flags: -fparr	      -- syntactic support for parallel arrays (via `PrelPArr')
+			 * Dynamic hsc option; can be reversed with -fno-parr
+	 -fflatten    -- flattening transformation
+			 * Static hsc option
+	 -ndp	      -- this a way option, which implies -fparr and -fflatten
+			 (way options are handled by the driver and are not
+			 directly seen by hsc)
+	 -ddump-vect  -- dump Core after vectorisation
+		         * Dynamic hsc option
+
+* PrelPArr implements array variants of the Prelude list functions plus some
+  extra functions (also, some list functions (eg, those generating infinite
+  lists) have been left out.
+
+* prelude/PrelNames has been extended with all the names from PrelPArr that
+  need to be known inside the compiler
+
+* The variable GhcSupportsPArr, which can be set in build.mk decides whether
+  `PrelPArr' is to be compiled or not.  (We probably need to supress compiling
+  PrelPArr in WayNDP, or rather replace it with a different PrelPArr.)
+
+* Say something about `TysWiredIn.parrTyCon' as soon as we know how it
+  actually works... 
+
+Parser and AST Notes:
+- Parser and AST is quite straight forward.  Essentially, the list cases
+  duplicated with a name containing `PArr' or `parr' and modified to fit the
+  slightly different semantics (ie, finite length, strict).
+- The value and pattern `[::]' is an empty explicit parallel array (ie,
+  something of the form `ExplicitPArr ty []' in the AST).  This is in contrast
+  to lists, which use the nil-constructor instead.  In the case of parallel
+  arrays, using a constructor would be rather awkward, as it is not a
+  constructor-based type.
+- Thus, array patterns have the general form `[:p1, p2, ..., pn:]', where n >=
+  0.  Thus, two array patterns overlap iff they have the same length.
+- The type constructor for parallel is internally represented as a
+  `TyCon.AlgTyCon' with a wired in definition in `TysWiredIn'.  
+
+Desugarer Notes:
+- Desugaring of patterns involving parallel arrays:
+  * In Match.tidy1, we use fake array constructors; ie, any pattern `[:p1, ...,
+    pn:]' is replaces by the expression `MkPArr<n> p1 ... pn', where
+    `MkPArr<n>' is the n-ary array constructor.  These constructors are fake,
+    because they are never used to actually represent array values; in fact,
+    they are removed again before pattern compilation is finished.  However,
+    the use of these fake constructors implies that we need not modify large
+    parts of the machinery of the pattern matching compiler, as array patterns
+    are handled like any other constructor pattern.
+  * Check.simplify_pat introduces the same fake constructors as Match.tidy1
+    and removed again by Check.make_con.
+  * In DsUtils.mkCoAlgCaseMatchResult, we catch the case of array patterns and
+    generate code as the following example illustrates, where the LHS is the
+    code that would be produced if array construtors would really exist:
+
+      case v of pa {
+	MkPArr1 x1       -> e1
+	MkPArr2 x2 x3 x4 -> e2
+	DFT	         -> e3
+      }
+
+    =>
+
+      case lengthP v of
+        Int# i# -> 
+	  case i# of l {
+	    1   -> let x1 = v!:0                       in e1
+	    3   -> let x2 = v!:0; x2 = v!:1; x3 = v!:2 in e2
+	    DFT ->					      e3
+	  }
+  * The desugaring of array comprehensions is in `DsListComp', but follows
+    rules that are different from that for translating list comprehensions.
+    Denotationally, it boils down to the same, but the operational
+    requirements for an efficient implementation of array comprehensions are
+    rather different.
+
+    [:e | qss:] = <<[:e | qss:]>> () [:():]
+
+    <<[:e' |           :]>> pa ea = mapP (\pa -> e') ea
+    <<[:e' | b     , qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
+    <<[:e' | p <- e, qs:]>> pa ea = 
+      let ef = filterP (\x -> case x of {p -> True; _ -> False}) e
+      in
+      <<[:e' | qs:]>> (pa, p) (crossP ea ef)
+    <<[:e' | let ds, qs:]>> pa ea = 
+      <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) 
+		      (mapP (\v@pa -> (v, let ds in (x_1, ..., x_n))) ea)
+    where
+      {x_1, ..., x_n} = DV (ds)		-- Defined Variables
+    <<[:e' | qs | qss:]>>   pa ea = 
+      <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) 
+		       (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
+    where
+      {x_1, ..., x_n} = DV (qs)
+
+    Moreover, we have
+
+      crossP       :: [:a:] -> [:b:] -> [:(a, b):]
+      crossP a1 a2  = let
+			len1 = lengthP a1
+			len2 = lengthP a2
+			x1   = concatP $ mapP (replicateP len2) a1
+			x2   = concatP $ replicateP len1 a2
+		      in
+		      zipP x1 x2
+
+    For a more efficient implementation of `crossP', see `PrelPArr'.
+
+    Optimisations: 
+    - In the `p <- e' rule, if `pa = ()', drop it and simplify the `crossP ea
+      e' to `e'.
+    - We assume that fusion will optimise sequences of array processing
+      combinators.
+    - Do we want to have the following function?
+
+        mapFilterP :: (a -> Maybe b) -> [:a:] -> [:b:]
+
+      Even with fusion `(mapP (\p -> e) . filterP (\p -> b))' may still result
+      in redundant pattern matching operations.  (Let's wait with this until
+      we have seen what the Simplifier does to the generated code.)
+
+Flattening Notes:
+* The story about getting access to all the names like "fst" etc that we need
+  to generate during flattening is quite involved.  To have a reasonable
+  chance to get at the stuff, we need to put flattening inbetween the
+  desugarer and the simplifier as an extra pass in HscMain.hscMain.  After
+  that point, the persistent compiler state is zapped (for heap space
+  reduction reasons, I guess) and nothing remains of the imported interfaces
+  in one shot mode.
+
+  Moreover, to get the Ids that we need into the type environment, we need to
+  force the renamer to include them.  This is done in
+  RnEnv.getImplicitModuleFVs, which computes all implicitly imported names.
+  We let it add the names from FlattenInfo.namesNeededForFlattening.
+
+  Given all these arrangements, FlattenMonad can obtain the needed Ids from
+  the persistent compiler state without much further hassle.
+
+  [It might be worthwhile to document in the non-Flattening part of the
+  Commentary that the persistent compiler state is zapped after desugaring and
+  how the free variables determined by the renamer imply which names are
+  imported.]