diff options
Diffstat (limited to 'ghc/compiler/ndpFlatten/Flattening.hs')
| -rw-r--r-- | ghc/compiler/ndpFlatten/Flattening.hs | 808 |
1 files changed, 0 insertions, 808 deletions
diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs deleted file mode 100644 index 18daaa6323..0000000000 --- a/ghc/compiler/ndpFlatten/Flattening.hs +++ /dev/null @@ -1,808 +0,0 @@ --- $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" |