Remove ndpFlatten
authorRoman Leshchinskiy <rl@cse.unsw.edu.au>
Sun, 9 Mar 2008 22:59:14 +0000 (22:59 +0000)
committerRoman Leshchinskiy <rl@cse.unsw.edu.au>
Sun, 9 Mar 2008 22:59:14 +0000 (22:59 +0000)
This patch removes the ndpFlatten directory and the -fflatten static flag.
This code has never worked and has now been superceded by vectorisation.

compiler/Makefile
compiler/basicTypes/Unique.lhs
compiler/main/HscMain.lhs
compiler/main/StaticFlags.hs
compiler/ndpFlatten/FlattenInfo.hs [deleted file]
compiler/ndpFlatten/FlattenMonad.hs [deleted file]
compiler/ndpFlatten/Flattening.hs [deleted file]
compiler/ndpFlatten/NDPCoreUtils.hs [deleted file]
compiler/ndpFlatten/PArrAnal.hs [deleted file]
compiler/ndpFlatten/TODO [deleted file]
compiler/package.conf.in

index c7d4169..7cd21c6 100644 (file)
@@ -433,7 +433,7 @@ SRC_HC_OPTS += -Istage$(stage)
 ALL_DIRS = \
   utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \
   vectorise specialise simplCore stranal stgSyn simplStg codeGen main \
-  profiling parser cprAnalysis ndpFlatten iface cmm
+  profiling parser cprAnalysis iface cmm
 
 # Make sure we include Config.hs even if it doesn't exist yet...
 ALL_SRCS += $(CONFIG_HS)
index 4028786..5190702 100644 (file)
@@ -286,7 +286,6 @@ Allocation of unique supply characters:
        d       desugarer
        f       AbsC flattener
        g       SimplStg
-       l       ndpFlatten
        n       Native codegen
        r       Hsc name cache
        s       simplifier
index 1b7df1b..93ce6ad 100644 (file)
@@ -40,7 +40,6 @@ import ByteCodeGen    ( byteCodeGen, coreExprToBCOs )
 import Linker          ( HValue, linkExpr )
 import CoreTidy                ( tidyExpr )
 import CorePrep                ( corePrepExpr )
-import Flattening      ( flattenExpr )
 import Desugar          ( deSugarExpr )
 import SimplCore        ( simplifyExpr )
 import TcRnDriver      ( tcRnStmt, tcRnExpr, tcRnType ) 
@@ -961,11 +960,8 @@ compileExpr hsc_env srcspan ds_expr
   = do { let { dflags  = hsc_dflags hsc_env ;
                lint_on = dopt Opt_DoCoreLinting dflags }
              
-               -- Flatten it
-       ; flat_expr <- flattenExpr hsc_env ds_expr
-
                -- Simplify it
-       ; simpl_expr <- simplifyExpr dflags flat_expr
+       ; simpl_expr <- simplifyExpr dflags ds_expr
 
                -- Tidy it (temporary, until coreSat does cloning)
        ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
index 043df54..bf0e822 100644 (file)
@@ -44,7 +44,6 @@ module StaticFlags (
        opt_IrrefutableTuples,
        opt_Parallel,
        opt_RuntimeTypes,
-       opt_Flatten,
 
        -- optimisation opts
        opt_NoMethodSharing, 
@@ -301,7 +300,6 @@ opt_Hpc                             = lookUp FSLIT("-fhpc")
 opt_DictsStrict                        = lookUp  FSLIT("-fdicts-strict")
 opt_IrrefutableTuples          = lookUp  FSLIT("-firrefutable-tuples")
 opt_Parallel                   = lookUp  FSLIT("-fparallel")
-opt_Flatten                    = lookUp  FSLIT("-fflatten")
 
 -- optimisation opts
 opt_SpecInlineJoinPoints       = lookUp  FSLIT("-fspec-inline-join-points")
@@ -367,7 +365,6 @@ isStaticFlag f =
        "fspec-inline-join-points",
        "firrefutable-tuples",
        "fparallel",
-       "fflatten",
        "fgransim",
        "fno-hi-version-check",
        "dno-black-holing",
@@ -604,7 +601,7 @@ way_details =
 
     (WayNDP, Way  "ndp" False "Nested data parallelism"
        [ "-fparr"
-       , "-fflatten"]),
+       , "-fvectorise"]),
 
     (WayUser_a,  Way  "a"  False "User way 'a'"  ["$WAY_a_REAL_OPTS"]),        
     (WayUser_b,  Way  "b"  False "User way 'b'"  ["$WAY_b_REAL_OPTS"]),        
diff --git a/compiler/ndpFlatten/FlattenInfo.hs b/compiler/ndpFlatten/FlattenInfo.hs
deleted file mode 100644 (file)
index 928b5df..0000000
+++ /dev/null
@@ -1,42 +0,0 @@
---  $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
deleted file mode 100644 (file)
index 245e88d..0000000
+++ /dev/null
@@ -1,461 +0,0 @@
---  $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.
---
-
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-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(..),
-                    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 DynFlags            (DynFlags)
-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 :: DynFlags
-                   -> ExternalPackageState
-                   -> HomePackageTable 
-                   -> UniqSupply 
-                   -> FlattenState
-initialFlattenState dflags eps hpt us = 
-  FlattenState {
-    us      = us,
-    env      = lookup,
-    ctxtVar  = Nothing,
-    ctxtEnv  = emptyVarEnv,
-    usedVars = emptyVarSet
-  }
-  where
-    lookup n = 
-      case lookupType dflags 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 (hsc_dflags hsc_env) 
-                                               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
deleted file mode 100644 (file)
index 220c571..0000000
+++ /dev/null
@@ -1,812 +0,0 @@
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
---  $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, isDefault,
-                    isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
-import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
-                    liftVar, liftConst, intersectWithContext, mk'fst,
-                    mk'mapP, mk'bpermuteDftP, mk'indexOfP,mk'eq,mk'neq) 
-
--- GHC
-import TcType      ( tcIsForAllTy, tcView )
-import TypeRep     ( Type(..) )
-import Coercion     ( coercionKind )
-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(..), HscEnv(..), hscEPS )
-import CoreFVs     (exprFreeVars)
-import CoreSyn     (Expr(..), Bind(..), Alt, AltCon(..),
-                    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
-
--- 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 (Cast expr co) =
-  do
-    (lexpr, t) <- lift expr
-    let lco = liftTy co
-    let (t1, t2) = coercionKind lco
-    return ((Cast expr lco), t2)
-
-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
deleted file mode 100644 (file)
index b3eee9a..0000000
+++ /dev/null
@@ -1,182 +0,0 @@
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
---  $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 (Cast e co) = Cast (substIdEnv env e) co
-substIdEnv env e@(Type t) = e
diff --git a/compiler/ndpFlatten/PArrAnal.hs b/compiler/ndpFlatten/PArrAnal.hs
deleted file mode 100644 (file)
index e4c0dc7..0000000
+++ /dev/null
@@ -1,214 +0,0 @@
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
---  $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
-
--- not quite sure this is right
-arrUsage (Cast expr co) =
-  arrUsage expr 
-
-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
deleted file mode 100644 (file)
index e596609..0000000
+++ /dev/null
@@ -1,202 +0,0 @@
-                  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.] 
index 2342e14..e4cbaec 100644 (file)
@@ -94,9 +94,6 @@ exposed-modules:
        FieldLabel
        Finder
        FiniteMap
-       FlattenInfo
-       FlattenMonad
-       Flattening
        FloatIn
        FloatOut
        ForeignCall
@@ -150,7 +147,6 @@ exposed-modules:
        MkIface
        Module
        NCGMonad
-       NDPCoreUtils
        Name
        NameEnv
        NameSet
@@ -294,7 +290,6 @@ import-dirs:   FPTOOLS_TOP_ABS"/compiler/stage"STAGE"/utils",
               FPTOOLS_TOP_ABS"/compiler/stage"STAGE"/profiling",
               FPTOOLS_TOP_ABS"/compiler/stage"STAGE"/parser",
               FPTOOLS_TOP_ABS"/compiler/stage"STAGE"/cprAnalysis",
-              FPTOOLS_TOP_ABS"/compiler/stage"STAGE"/ndpFlatten",
               FPTOOLS_TOP_ABS"/compiler/stage"STAGE"/iface",
               FPTOOLS_TOP_ABS"/compiler/stage"STAGE"/cmm",
               FPTOOLS_TOP_ABS"/compiler/stage"STAGE"/nativeGen"