X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FndpFlatten%2FFlattening.hs;fp=compiler%2FndpFlatten%2FFlattening.hs;h=18daaa632395071d485396e8d28cc7749e9ed9c8;hp=0000000000000000000000000000000000000000;hb=0065d5ab628975892cea1ec7303f968c3338cbe1;hpb=28a464a75e14cece5db40f2765a29348273ff2d2 diff --git a/compiler/ndpFlatten/Flattening.hs b/compiler/ndpFlatten/Flattening.hs new file mode 100644 index 0000000..18daaa6 --- /dev/null +++ b/compiler/ndpFlatten/Flattening.hs @@ -0,0 +1,808 @@ +-- $Id$ +-- +-- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- +-- Vectorisation and lifting +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module implements the vectorisation and function lifting +-- transformations of the flattening transformation. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 with C preprocessor +-- +-- Types: +-- the transformation on types has five purposes: +-- +-- 1) for each type definition, derive the lifted version of this type +-- liftTypeef +-- 2) change the type annotations of functions & variables acc. to rep. +-- flattenType +-- 3) derive the type of a lifted function +-- liftType +-- 4) sumtypes: +-- this is the most fuzzy and complicated part. For each lifted +-- sumtype we need to generate function to access and combine the +-- component arrays +-- +-- NOTE: the type information of variables and data constructors is *not* +-- changed to reflect it's representation. This has to be solved +-- somehow (???, FIXME) using type indexed types +-- +-- Vectorisation: +-- is very naive at the moment. One of the most striking inefficiencies is +-- application vect (app e1 e2) -> app (fst (vect e1) (vect e2)) if e1 is a +-- lambda abstraction. The vectorisation produces a pair consisting of the +-- original and the lifted function, but the lifted version is discarded. +-- I'm also not sure how much of this would be thrown out by the simplifier +-- eventually +-- +-- *) vectorise +-- +-- Conventions: +-- +--- TODO ---------------------------------------------------------------------- +-- +-- * look closer into the definition of type definition (TypeThing or so) +-- + +module Flattening ( + flatten, flattenExpr, +) where + +#include "HsVersions.h" + +-- friends +import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault, + isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv) +import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext, + liftVar, liftConst, intersectWithContext, mk'fst, + mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP, + mk'indexOfP,mk'eq,mk'neq) + +-- GHC +import TcType ( tcIsForAllTy, tcView ) +import TypeRep ( Type(..) ) +import StaticFlags (opt_Flatten) +import Panic (panic) +import ErrUtils (dumpIfSet_dyn) +import UniqSupply (mkSplitUniqSupply) +import DynFlags (DynFlag(..)) +import Literal (Literal, literalType) +import Var (Var(..), idType, isTyVar) +import Id (setIdType) +import DataCon (DataCon, dataConTag) +import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), hscEPS ) +import CoreFVs (exprFreeVars) +import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..), + CoreBndr, CoreExpr, CoreBind, mkLams, mkLets, + mkApps, mkIntLitInt) +import PprCore (pprCoreExpr) +import CoreLint (showPass, endPass) + +import CoreUtils (exprType, applyTypeToArg, mkPiType) +import VarEnv (zipVarEnv) +import TysWiredIn (mkTupleTy) +import BasicTypes (Boxity(..)) +import Outputable +import FastString + + +-- FIXME: fro debugging - remove this +import TRACE (trace) + +-- standard +import Monad (liftM, foldM) + +-- toplevel transformation +-- ----------------------- + +-- entry point to the flattening transformation for the compiler driver when +-- compiling a complete module (EXPORTED) +-- +flatten :: HscEnv + -> ModGuts + -> IO ModGuts +flatten hsc_env mod_impl@(ModGuts {mg_binds = binds}) + | not opt_Flatten = return mod_impl -- skip without -fflatten + | otherwise = + do + let dflags = hsc_dflags hsc_env + + eps <- hscEPS hsc_env + us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening + -- + -- announce vectorisation + -- + showPass dflags "Flattening [first phase: vectorisation]" + -- + -- vectorise all toplevel bindings + -- + let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds + -- + -- and dump the result if requested + -- + endPass dflags "Flattening [first phase: vectorisation]" + Opt_D_dump_vect binds' + return $ mod_impl {mg_binds = binds'} + +-- entry point to the flattening transformation for the compiler driver when +-- compiling a single expression in interactive mode (EXPORTED) +-- +flattenExpr :: HscEnv + -> CoreExpr -- the expression to be flattened + -> IO CoreExpr +flattenExpr hsc_env expr + | not opt_Flatten = return expr -- skip without -fflatten + | otherwise = + do + let dflags = hsc_dflags hsc_env + eps <- hscEPS hsc_env + + us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening + -- + -- announce vectorisation + -- + showPass dflags "Flattening [first phase: vectorisation]" + -- + -- vectorise the expression + -- + let expr' = fst . runFlatten hsc_env eps us $ vectorise expr + -- + -- and dump the result if requested + -- + dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression" + (pprCoreExpr expr') + return expr' + + +-- vectorisation of bindings and expressions +-- ----------------------------------------- + + +vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind] +vectoriseTopLevelBinds binds = + do + vbinds <- mapM vectoriseBind binds + return (adjustTypeBinds vbinds) + +adjustTypeBinds:: [CoreBind] -> [CoreBind] +adjustTypeBinds vbinds = + let + ids = concat (map extIds vbinds) + idEnv = zipVarEnv ids ids + in map (substIdEnvBind idEnv) vbinds + where + -- FIXME replace by 'bindersOf' + extIds (NonRec b expr) = [b] + extIds (Rec bnds) = map fst bnds + substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr) + substIdEnvBind idEnv (Rec bnds) + = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds) + +-- vectorise a single core binder +-- +vectoriseBind :: CoreBind -> Flatten CoreBind +vectoriseBind (NonRec b expr) = + liftM (NonRec b) $ liftM fst $ vectorise expr +vectoriseBind (Rec bindings) = + liftM Rec $ mapM vectoriseOne bindings + where + vectoriseOne (b, expr) = + do + (vexpr, ty) <- vectorise expr + return (setIdType b ty, vexpr) + + +-- Searches for function definitions and creates a lifted version for +-- each function. +-- We have only two interesting cases: +-- 1) function application (ex1) (ex2) +-- vectorise both subexpressions. The function will end up becoming a +-- pair (orig. fun, lifted fun), choose first component (in many cases, +-- this is pretty inefficient, since the lifted version is generated +-- although it is clear that it won't be used +-- +-- 2) lambda abstraction +-- any function has to exist in two forms: it's original form and it's +-- lifted form. Therefore, every lambda abstraction is transformed into +-- a pair of functions: the original function and its lifted variant +-- +-- +-- FIXME: currently, I use 'exprType' all over the place - this is terribly +-- inefficient. It should be suffiecient to change 'vectorise' and 'lift' to +-- return the type of the result expression as well. +-- +vectorise:: CoreExpr -> Flatten (CoreExpr, Type) +vectorise (Var id) = + do + let varTy = idType id + let vecTy = vectoriseTy varTy + return (Var (setIdType id vecTy), vecTy) + +vectorise (Lit lit) = + return ((Lit lit), literalType lit) + + +vectorise e@(App expr t@(Type _)) = + do + (vexpr, vexprTy) <- vectorise expr + return ((App vexpr t), applyTypeToArg vexprTy t) + +vectorise (App (Lam b expr) arg) = + do + (varg, argTy) <- vectorise arg + (vexpr, vexprTy) <- vectorise expr + let vb = setIdType b argTy + return ((App (Lam vb vexpr) varg), + applyTypeToArg (mkPiType vb vexprTy) varg) + +-- if vexpr expects a type as first argument +-- application stays just as it is +-- +vectorise (App expr arg) = + do + (vexpr, vexprTy) <- vectorise expr + (varg, vargTy) <- vectorise arg + + if (tcIsForAllTy vexprTy) + then do + let resTy = applyTypeToArg vexprTy varg + return (App vexpr varg, resTy) + else do + let [t1, t2] = tupleTyArgs vexprTy + vexpr' <- mk'fst t1 t2 vexpr + let resTy = applyTypeToArg t1 varg + return ((App vexpr' varg), resTy) -- apply the first component of + -- the vectorized function + +vectorise e@(Lam b expr) + | isTyVar b + = do + (vexpr, vexprTy) <- vectorise expr -- don't vectorise 'b'! + return ((Lam b vexpr), mkPiType b vexprTy) + | otherwise = + do + (vexpr, vexprTy) <- vectorise expr + let vb = setIdType b (vectoriseTy (idType b)) + let ve = Lam vb vexpr + (lexpr, lexprTy) <- lift e + let veTy = mkPiType vb vexprTy + return $ (mkTuple [veTy, lexprTy] [ve, lexpr], + mkTupleTy Boxed 2 [veTy, lexprTy]) + +vectorise (Let bind body) = + do + vbind <- vectoriseBind bind + (vbody, vbodyTy) <- vectorise body + return ((Let vbind vbody), vbodyTy) + +vectorise (Case expr b ty alts) = + do + (vexpr, vexprTy) <- vectorise expr + valts <- mapM vectorise' alts + let res_ty = snd (head valts) + return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty) + where vectorise' (con, bs, expr) = + do + (vexpr, vexprTy) <- vectorise expr + return ((con, bs, vexpr), vexprTy) -- FIXME: change type of con + -- and bs + + + +vectorise (Note note expr) = + do + (vexpr, vexprTy) <- vectorise expr -- FIXME: is this ok or does it + return ((Note note vexpr), vexprTy) -- change the validity of note? + +vectorise e@(Type t) = + return (e, t) -- FIXME: panic instead of 't'??? + + +{- +myShowTy (TyVarTy _) = "TyVar " +myShowTy (AppTy t1 t2) = + "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")" +myShowTy (TyConApp _ t) = + "TyConApp TC (" ++ (myShowTy t) ++ ")" +-} + +vectoriseTy :: Type -> Type +vectoriseTy ty | Just ty' <- tcView ty = vectoriseTy ty' + -- Look through notes and synonyms + -- NB: This will discard notes and synonyms, of course + -- ToDo: retain somehow? +vectoriseTy t@(TyVarTy v) = t +vectoriseTy t@(AppTy t1 t2) = + AppTy (vectoriseTy t1) (vectoriseTy t2) +vectoriseTy t@(TyConApp tc ts) = + TyConApp tc (map vectoriseTy ts) +vectoriseTy t@(FunTy t1 t2) = + mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)), + (liftTy t)] +vectoriseTy t@(ForAllTy v ty) = + ForAllTy v (vectoriseTy ty) +vectoriseTy t = t + + +-- liftTy: wrap the type in an array but be careful with function types +-- on the *top level* (is this sufficient???) + +liftTy:: Type -> Type +liftTy ty | Just ty' <- tcView ty = liftTy ty' +liftTy (FunTy t1 t2) = FunTy (liftTy t1) (liftTy t2) +liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t) +liftTy t = mkPArrTy t + + +-- lifting: +-- ---------- +-- * liftType +-- * lift + + +-- liftBinderType: Converts a type 'a' stored in the binder to the +-- representation of '[:a:]' will therefore call liftType +-- +-- lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok, +-- but I'm not entirely sure about some fields (e.g., strictness info) +liftBinderType:: CoreBndr -> Flatten CoreBndr +liftBinderType bndr = return $ setIdType bndr (liftTy (idType bndr)) + +-- lift: lifts an expression (a -> [:a:]) +-- If the expression is a simple expression, it is treated like a constant +-- expression. +-- If the body of a lambda expression is a simple expression, it is +-- transformed into a mapP +lift:: CoreExpr -> Flatten (CoreExpr, Type) +lift cExpr@(Var id) = + do + lVar@(Var lId) <- liftVar id + return (lVar, idType lId) + +lift cExpr@(Lit lit) = + do + lLit <- liftConst cExpr + return (lLit, exprType lLit) + + +lift (Lam b expr) + | isSimpleExpr expr = liftSimpleFun b expr + | isTyVar b = + do + (lexpr, lexprTy) <- lift expr -- don't lift b! + return (Lam b lexpr, mkPiType b lexprTy) + | otherwise = + do + lb <- liftBinderType b + (lexpr, lexprTy) <- extendContext [lb] (lift expr) + return ((Lam lb lexpr) , mkPiType lb lexprTy) + +lift (App expr1 expr2) = + do + (lexpr1, lexpr1Ty) <- lift expr1 + (lexpr2, _) <- lift expr2 + return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2) + + +lift (Let (NonRec b expr1) expr2) + |isSimpleExpr expr2 = + do + (lexpr1, _) <- lift expr1 + (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2 + let (t1, t2) = funTyArgs lexpr2Ty + liftM (\x -> (x, liftTy t2)) $ mk'mapP t1 t2 lexpr2 lexpr1 + + | otherwise = + do + (lexpr1, _) <- lift expr1 + lb <- liftBinderType b + (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1) + return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty) + +lift (Let (Rec binds) expr2) = + do + let (bndVars, exprs) = unzip binds + lBndVars <- mapM liftBinderType bndVars + lexprs <- extendContext bndVars (mapM lift exprs) + (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2) + return ((Let (Rec (zip lBndVars (map fst lexprs))) lexpr2), lexpr2Ty) + +-- FIXME: +-- Assumption: alternatives can either be literals or data construtors. +-- Due to type restrictions, I don't think it is possible +-- that they are mixed. +-- The handling of literals and data constructors is completely +-- different +-- +-- +-- let b = expr in alts +-- +-- I think I read somewhere that the default case (if present) is stored +-- in the head of the list. Assume for now this is true, have to check +-- +-- (1) literals +-- (2) data constructors +-- +-- FIXME: optimisation: first, filter out all simple expression and +-- loop (mapP & filter) over all the corresponding values in a single +-- traversal: + +-- (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr]) +-- simple alts reg alts +-- (2) if simpleAlts = [] then (just as before) +-- if regAlts = [] then (the whole thing is just a loop) +-- otherwise (a) compute index vector for simpleAlts (for def permute +-- later on +-- (b) +-- gaw 2004 FIX? +lift cExpr@(Case expr b _ alts) = + do + (lExpr, _) <- lift expr + lb <- liftBinderType b -- lift alt-expression + lalts <- if isLit alts + then extendContext [lb] (liftCaseLit b alts) + else extendContext [lb] (liftCaseDataCon b alts) + letWrapper lExpr b lalts + +lift (Note (Coerce t1 t2) expr) = + do + (lexpr, t) <- lift expr + let lt1 = liftTy t1 + return ((Note (Coerce lt1 (liftTy t2)) lexpr), lt1) + +lift (Note note expr) = + do + (lexpr, t) <- lift expr + return ((Note note lexpr), t) + +lift e@(Type t) = return (e, t) + + +-- auxilliary functions for lifting of case statements +-- + +liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] -> + Flatten (([CoreBind], [CoreBind], [CoreBind])) +liftCaseDataCon b [] = + return ([], [], []) +liftCaseDataCon b alls@(alt:alts) + | isDefault alt = + do + (i, e, defAltBndrs) <- liftCaseDataConDefault b alt alts + (is, es, altBndrs) <- liftCaseDataCon' b alts + return (i:is, e:es, defAltBndrs ++ altBndrs) + | otherwise = + liftCaseDataCon' b alls + +liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] -> + Flatten ([CoreBind], [CoreBind], [CoreBind]) +liftCaseDataCon' _ [] = + do + return ([], [], []) + + +liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) = + do + (permBnd, exprBnd, packBnd) <- liftSingleDataCon b dcon bnds expr + (permBnds, exprBnds, packBnds) <- liftCaseDataCon' b alts + return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds) + + +-- FIXME: is is really necessary to return the binding to the permutation +-- array in the data constructor case, as the representation already +-- contains the extended flag vector +liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr -> + Flatten (CoreBind, CoreBind, [CoreBind]) +liftSingleDataCon b dcon bnds expr = + do + let dconId = dataConTag dcon + indexExpr <- mkIndexOfExprDCon (idType b) b dconId + (bb, bbind) <- mkBind FSLIT("is") indexExpr + lbnds <- mapM liftBinderType bnds + ((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr)) + (_, vbind) <- mkBind FSLIT("r") lExpr + return (bbind, vbind, bnds') + +-- FIXME: clean this up. the datacon and the literal case are so +-- similar that it would be easy to use the same function here +-- instead of duplicating all the code. +-- +liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr] + -> Flatten (CoreBind, CoreBind, [CoreBind]) +liftCaseDataConDefault b (_, _, def) alts = + do + let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts + indexExpr <- mkIndexOfExprDConDft (idType b) b dconIds + (bb, bbind) <- mkBind FSLIT("is") indexExpr + ((lDef, _), bnds) <- packContext bb (lift def) + (_, vbind) <- mkBind FSLIT("r") lDef + return (bbind, vbind, bnds) + +-- liftCaseLit: checks if we have a default case and handles it +-- if necessary +liftCaseLit:: CoreBndr -> [Alt CoreBndr] -> + Flatten ([CoreBind], [CoreBind], [CoreBind]) +liftCaseLit b [] = + return ([], [], []) --FIXME: a case with no cases at all??? +liftCaseLit b alls@(alt:alts) + | isDefault alt = + do + (i, e, defAltBndrs) <- liftCaseLitDefault b alt alts + (is, es, altBndrs) <- liftCaseLit' b alts + return (i:is, e:es, defAltBndrs ++ altBndrs) + | otherwise = + do + liftCaseLit' b alls + +-- liftCaseLitDefault: looks at all the other alternatives which +-- contain a literal and filters all those elements from the +-- array which do not match any of the literals in the other +-- alternatives. +liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr] + -> Flatten (CoreBind, CoreBind, [CoreBind]) +liftCaseLitDefault b (_, _, def) alts = + do + let lits = map (\(LitAlt l, _, _) -> l) alts + indexExpr <- mkIndexOfExprDft (idType b) b lits + (bb, bbind) <- mkBind FSLIT("is") indexExpr + ((lDef, _), bnds) <- packContext bb (lift def) + (_, vbind) <- mkBind FSLIT("r") lDef + return (bbind, vbind, bnds) + +-- FIXME: +-- Assumption: in case of Lit, the list of binders of the alt is empty. +-- +-- returns +-- a list of all vars bound to the expr in the body of the alternative +-- a list of (var, expr) pairs, where var has to be bound to expr +-- by letWrapper +liftCaseLit':: CoreBndr -> [Alt CoreBndr] -> + Flatten ([CoreBind], [CoreBind], [CoreBind]) +liftCaseLit' _ [] = + do + return ([], [], []) +liftCaseLit' b ((LitAlt lit, [], expr):alts) = + do + (permBnd, exprBnd, packBnd) <- liftSingleCaseLit b lit expr + (permBnds, exprBnds, packBnds) <- liftCaseLit' b alts + return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds) + +-- lift a single alternative of the form: case b of lit -> expr. +-- +-- It returns the bindings: +-- (a) let b' = indexOfP (mapP (\x -> x == lit) b) +-- +-- (b) lift expr in the packed context. Returns lexpr and the +-- list of binds (bnds) that describe the packed arrays +-- +-- (c) create new var v' to bind lexpr to +-- +-- (d) return (b' = indexOf...., v' = lexpr, bnds) +liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr -> + Flatten (CoreBind, CoreBind, [CoreBind]) +liftSingleCaseLit b lit expr = + do + indexExpr <- mkIndexOfExpr (idType b) b lit -- (a) + (bb, bbind) <- mkBind FSLIT("is") indexExpr + ((lExpr, t), bnds) <- packContext bb (lift expr) -- (b) + (_, vbind) <- mkBind FSLIT("r") lExpr + return (bbind, vbind, bnds) + +-- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij]) +-- +-- let b = lExpr in +-- let index_bnd_1 in +-- let packbnd_11 in +-- ... packbnd_1m in +-- let exprbnd_1 in .... +-- ... +-- let nvar = replicate dummy (length ) +-- 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"