--- /dev/null
+-- $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"
projects / ghc-hetmet.git / blobdiff