-- $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 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(..), 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 Debug.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 (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 ) -- 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"