diff options
Diffstat (limited to 'compiler/ndpFlatten')
| -rw-r--r-- | compiler/ndpFlatten/FlattenInfo.hs | 43 | ||||
| -rw-r--r-- | compiler/ndpFlatten/FlattenMonad.hs | 451 | ||||
| -rw-r--r-- | compiler/ndpFlatten/Flattening.hs | 808 | ||||
| -rw-r--r-- | compiler/ndpFlatten/NDPCoreUtils.hs | 174 | ||||
| -rw-r--r-- | compiler/ndpFlatten/PArrAnal.hs | 203 | ||||
| -rw-r--r-- | compiler/ndpFlatten/TODO | 202 |
6 files changed, 1881 insertions, 0 deletions
diff --git a/compiler/ndpFlatten/FlattenInfo.hs b/compiler/ndpFlatten/FlattenInfo.hs new file mode 100644 index 0000000000..f759242455 --- /dev/null +++ b/compiler/ndpFlatten/FlattenInfo.hs @@ -0,0 +1,43 @@ +-- $Id$ +-- +-- Copyright (c) 2002 Manuel M T Chakravarty & Gabriele Keller +-- +-- Information for modules outside of the flattening module collection. +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module contains information that is needed, and thus imported, by +-- modules that are otherwise independent of flattening and may in fact be +-- directly or indirectly imported by some of the flattening-related +-- modules. This is to avoid cyclic module dependencies. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- +--- TODO ---------------------------------------------------------------------- +-- + +module FlattenInfo ( + namesNeededForFlattening +) where + +import StaticFlags (opt_Flatten) +import NameSet (FreeVars, emptyFVs, mkFVs) +import PrelNames (fstName, andName, orName, lengthPName, replicatePName, + mapPName, bpermutePName, bpermuteDftPName, indexOfPName) + + +-- this is a list of names that need to be available if flattening is +-- performed (EXPORTED) +-- +-- * needs to be kept in sync with the names used in Core generation in +-- `FlattenMonad' and `NDPCoreUtils' +-- +namesNeededForFlattening :: FreeVars +namesNeededForFlattening + | not opt_Flatten = emptyFVs -- none without -fflatten + | otherwise + = mkFVs [fstName, andName, orName, lengthPName, replicatePName, mapPName, + bpermutePName, bpermuteDftPName, indexOfPName] + -- stuff from PrelGHC doesn't have to go here diff --git a/compiler/ndpFlatten/FlattenMonad.hs b/compiler/ndpFlatten/FlattenMonad.hs new file mode 100644 index 0000000000..45405088fc --- /dev/null +++ b/compiler/ndpFlatten/FlattenMonad.hs @@ -0,0 +1,451 @@ +-- $Id$ +-- +-- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- +-- Monad maintaining parallel contexts and substitutions for flattening. +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- The flattening transformation needs to perform a fair amount of plumbing. +-- It needs to mainatin a set of variables, called the parallel context for +-- lifting, variable substitutions in case alternatives, and so on. +-- Moreover, we need to manage uniques to create new variables. The monad +-- defined in this module takes care of maintaining this state. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- +-- * a parallel context is a set of variables that get vectorised during a +-- lifting transformations (ie, their type changes from `t' to `[:t:]') +-- +-- * all vectorised variables in a parallel context have the same size; we +-- call this also the size of the parallel context +-- +-- * we represent contexts by maps that give the lifted version of a variable +-- (remember that in GHC, variables contain type information that changes +-- during lifting) +-- +--- TODO ---------------------------------------------------------------------- +-- +-- * Assumptions currently made that should (if they turn out to be true) be +-- documented in The Commentary: +-- +-- - Local bindings can be copied without any need to alpha-rename bound +-- variables (or their uniques). Such renaming is only necessary when +-- bindings in a recursive group are replicated; implying that this is +-- required in the case of top-level bindings). (Note: The CoreTidy path +-- generates global uniques before code generation.) +-- +-- * One FIXME left to resolve. +-- + +module FlattenMonad ( + + -- monad definition + -- + Flatten, runFlatten, + + -- variable generation + -- + newVar, mkBind, + + -- context management & query operations + -- + extendContext, packContext, liftVar, liftConst, intersectWithContext, + + -- construction of prelude functions + -- + mk'fst, mk'eq, mk'neq, mk'and, mk'or, mk'lengthP, mk'replicateP, mk'mapP, + mk'bpermuteP, mk'bpermuteDftP, mk'indexOfP +) where + +-- standard +import Monad (mplus) + +-- GHC +import Panic (panic) +import Outputable (Outputable(ppr), pprPanic) +import UniqSupply (UniqSupply, splitUniqSupply, uniqFromSupply) +import Var (Var, idType) +import Id (Id, mkSysLocal) +import Name (Name) +import VarSet (VarSet, emptyVarSet, extendVarSet, varSetElems ) +import VarEnv (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv, + elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList) +import Type (Type, tyConAppTyCon) +import HscTypes (HomePackageTable, + ExternalPackageState(eps_PTE), HscEnv(hsc_HPT), + TyThing(..), lookupType) +import PrelNames ( fstName, andName, orName, + lengthPName, replicatePName, mapPName, bpermutePName, + bpermuteDftPName, indexOfPName) +import TysPrim ( charPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) +import PrimOp ( PrimOp(..) ) +import PrelInfo ( primOpId ) +import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps) +import CoreUtils (exprType) +import FastString (FastString) + +-- friends +import NDPCoreUtils (parrElemTy) + + +-- definition of the monad +-- ----------------------- + +-- state maintained by the flattening monad +-- +data FlattenState = FlattenState { + + -- our source for uniques + -- + us :: UniqSupply, + + -- environment containing all known names (including all + -- Prelude functions) + -- + env :: Name -> Id, + + -- this variable determines the parallel context; if + -- `Nothing', we are in pure vectorisation mode, no + -- lifting going on + -- + ctxtVar :: Maybe Var, + + -- environment that maps each variable that is + -- vectorised in the current parallel context to the + -- vectorised version of that variable + -- + ctxtEnv :: VarEnv Var, + + -- those variables from the *domain* of `ctxtEnv' that + -- have been used since the last context restriction (cf. + -- `restrictContext') + -- + usedVars :: VarSet + } + +-- initial value of the flattening state +-- +initialFlattenState :: ExternalPackageState + -> HomePackageTable + -> UniqSupply + -> FlattenState +initialFlattenState eps hpt us = + FlattenState { + us = us, + env = lookup, + ctxtVar = Nothing, + ctxtEnv = emptyVarEnv, + usedVars = emptyVarSet + } + where + lookup n = + case lookupType hpt (eps_PTE eps) n of + Just (AnId v) -> v + _ -> pprPanic "FlattenMonad: unknown name:" (ppr n) + +-- the monad representation (EXPORTED ABSTRACTLY) +-- +newtype Flatten a = Flatten { + unFlatten :: (FlattenState -> (a, FlattenState)) + } + +instance Monad Flatten where + return x = Flatten $ \s -> (x, s) + m >>= n = Flatten $ \s -> let + (r, s') = unFlatten m s + in + unFlatten (n r) s' + +-- execute the given flattening computation (EXPORTED) +-- +runFlatten :: HscEnv + -> ExternalPackageState + -> UniqSupply + -> Flatten a + -> a +runFlatten hsc_env eps us m + = fst $ unFlatten m (initialFlattenState eps (hsc_HPT hsc_env) us) + + +-- variable generation +-- ------------------- + +-- generate a new local variable whose name is based on the given lexeme and +-- whose type is as specified in the second argument (EXPORTED) +-- +newVar :: FastString -> Type -> Flatten Var +newVar lexeme ty = Flatten $ \state -> + let + (us1, us2) = splitUniqSupply (us state) + state' = state {us = us2} + in + (mkSysLocal lexeme (uniqFromSupply us1) ty, state') + +-- generate a non-recursive binding using a new binder whose name is derived +-- from the given lexeme (EXPORTED) +-- +mkBind :: FastString -> CoreExpr -> Flatten (CoreBndr, CoreBind) +mkBind lexeme e = + do + v <- newVar lexeme (exprType e) + return (v, NonRec v e) + + +-- context management +-- ------------------ + +-- extend the parallel context by the given set of variables (EXPORTED) +-- +-- * if there is no parallel context at the moment, the first element of the +-- variable list will be used to determine the new parallel context +-- +-- * the second argument is executed in the current context extended with the +-- given variables +-- +-- * the variables must already have been lifted by transforming their type, +-- but they *must* have retained their original name (or, at least, their +-- unique); this is needed so that they match the original variable in +-- variable environments +-- +-- * any trace of the given set of variables has to be removed from the state +-- at the end of this operation +-- +extendContext :: [Var] -> Flatten a -> Flatten a +extendContext [] m = m +extendContext vs m = Flatten $ \state -> + let + extState = state { + ctxtVar = ctxtVar state `mplus` Just (head vs), + ctxtEnv = ctxtEnv state `plusVarEnv` zipVarEnv vs vs + } + (r, extState') = unFlatten m extState + resState = extState' { -- remove `vs' from the result state + ctxtVar = ctxtVar state, + ctxtEnv = ctxtEnv state, + usedVars = usedVars extState' `delVarEnvList` vs + } + in + (r, resState) + +-- execute the second argument in a restricted context (EXPORTED) +-- +-- * all variables in the current parallel context are packed according to +-- the permutation vector associated with the variable passed as the first +-- argument (ie, all elements of vectorised context variables that are +-- invalid in the restricted context are dropped) +-- +-- * the returned list of core binders contains the operations that perform +-- the restriction on all variables in the parallel context that *do* occur +-- during the execution of the second argument (ie, `liftVar' is executed at +-- least once on any such variable) +-- +packContext :: Var -> Flatten a -> Flatten (a, [CoreBind]) +packContext perm m = Flatten $ \state -> + let + -- FIXME: To set the packed environment to the unpacked on is a hack of + -- which I am not sure yet (a) whether it works and (b) whether it's + -- really worth it. The one advantages is that, we can use a var set, + -- after all, instead of a var environment. + -- + -- The idea is the following: If we have to pack a variable `x', we + -- generate `let{-NonRec-} x = bpermuteP perm x in ...'. As this is a + -- non-recursive binding, the lhs `x' overshadows the rhs `x' in the + -- body of the let. + -- + -- NB: If we leave it like this, `mkCoreBind' can be simplified. + packedCtxtEnv = ctxtEnv state + packedState = state { + ctxtVar = fmap + (lookupVarEnv_NF packedCtxtEnv) + (ctxtVar state), + ctxtEnv = packedCtxtEnv, + usedVars = emptyVarSet + } + (r, packedState') = unFlatten m packedState + resState = state { -- revert to the unpacked context + ctxtVar = ctxtVar state, + ctxtEnv = ctxtEnv state + } + bndrs = map mkCoreBind . varSetElems . usedVars $ packedState' + + -- generate a binding for the packed variant of a context variable + -- + mkCoreBind var = let + rhs = fst $ unFlatten (mk'bpermuteP (idType var) + (Var perm) + (Var var) + ) state + in + NonRec (lookupVarEnv_NF packedCtxtEnv var) $ rhs + + in + ((r, bndrs), resState) + +-- lift a single variable in the current context (EXPORTED) +-- +-- * if the variable does not occur in the context, it's value is vectorised to +-- match the size of the current context +-- +-- * otherwise, the variable is replaced by whatever the context environment +-- maps it to (this may either be simply the lifted version of the original +-- variable or a packed variant of that variable) +-- +-- * the monad keeps track of all lifted variables that occur in the parallel +-- context, so that `packContext' can determine the correct set of core +-- bindings +-- +liftVar :: Var -> Flatten CoreExpr +liftVar var = Flatten $ \s -> + let + v = ctxtVarErr s + v'elemType = parrElemTy . idType $ v + len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s + replicated = fst $ unFlatten (mk'replicateP (idType var) len (Var var)) s + in case lookupVarEnv (ctxtEnv s) var of + Just liftedVar -> (Var liftedVar, + s {usedVars = usedVars s `extendVarSet` var}) + Nothing -> (replicated, s) + +-- lift a constant expression in the current context (EXPORTED) +-- +-- * the value of the constant expression is vectorised to match the current +-- parallel context +-- +liftConst :: CoreExpr -> Flatten CoreExpr +liftConst e = Flatten $ \s -> + let + v = ctxtVarErr s + v'elemType = parrElemTy . idType $ v + len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s + in + (fst $ unFlatten (mk'replicateP (exprType e) len e ) s, s) + +-- pick those variables of the given set that occur (if albeit in lifted form) +-- in the current parallel context (EXPORTED) +-- +-- * the variables returned are from the given set and *not* the corresponding +-- context variables +-- +intersectWithContext :: VarSet -> Flatten [Var] +intersectWithContext vs = Flatten $ \s -> + let + vs' = filter (`elemVarEnv` ctxtEnv s) (varSetElems vs) + in + (vs', s) + + +-- construct applications of prelude functions +-- ------------------------------------------- + +-- NB: keep all the used names listed in `FlattenInfo.namesNeededForFlattening' + +-- generate an application of `fst' (EXPORTED) +-- +mk'fst :: Type -> Type -> CoreExpr -> Flatten CoreExpr +mk'fst ty1 ty2 a = mkFunApp fstName [Type ty1, Type ty2, a] + +-- generate an application of `&&' (EXPORTED) +-- +mk'and :: CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'and a1 a2 = mkFunApp andName [a1, a2] + +-- generate an application of `||' (EXPORTED) +-- +mk'or :: CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'or a1 a2 = mkFunApp orName [a1, a2] + +-- generate an application of `==' where the arguments may only be literals +-- that may occur in a Core case expression (i.e., `Char', `Int', `Float', and +-- `Double') (EXPORTED) +-- +mk'eq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'eq ty a1 a2 = return (mkApps (Var eqName) [a1, a2]) + where + tc = tyConAppTyCon ty + -- + eqName | tc == charPrimTyCon = primOpId CharEqOp + | tc == intPrimTyCon = primOpId IntEqOp + | tc == floatPrimTyCon = primOpId FloatEqOp + | tc == doublePrimTyCon = primOpId DoubleEqOp + | otherwise = + pprPanic "FlattenMonad.mk'eq: " (ppr ty) + +-- generate an application of `==' where the arguments may only be literals +-- that may occur in a Core case expression (i.e., `Char', `Int', `Float', and +-- `Double') (EXPORTED) +-- +mk'neq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'neq ty a1 a2 = return (mkApps (Var neqName) [a1, a2]) + where + tc = tyConAppTyCon ty + -- + neqName {- | name == charPrimTyConName = neqCharName -} + | tc == intPrimTyCon = primOpId IntNeOp + {- | name == floatPrimTyConName = neqFloatName -} + {- | name == doublePrimTyConName = neqDoubleName -} + | otherwise = + pprPanic "FlattenMonad.mk'neq: " (ppr ty) + +-- generate an application of `lengthP' (EXPORTED) +-- +mk'lengthP :: Type -> CoreExpr -> Flatten CoreExpr +mk'lengthP ty a = mkFunApp lengthPName [Type ty, a] + +-- generate an application of `replicateP' (EXPORTED) +-- +mk'replicateP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'replicateP ty a1 a2 = mkFunApp replicatePName [Type ty, a1, a2] + +-- generate an application of `replicateP' (EXPORTED) +-- +mk'mapP :: Type -> Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'mapP ty1 ty2 a1 a2 = mkFunApp mapPName [Type ty1, Type ty2, a1, a2] + +-- generate an application of `bpermuteP' (EXPORTED) +-- +mk'bpermuteP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'bpermuteP ty a1 a2 = mkFunApp bpermutePName [Type ty, a1, a2] + +-- generate an application of `bpermuteDftP' (EXPORTED) +-- +mk'bpermuteDftP :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'bpermuteDftP ty a1 a2 a3 = mkFunApp bpermuteDftPName [Type ty, a1, a2, a3] + +-- generate an application of `indexOfP' (EXPORTED) +-- +mk'indexOfP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'indexOfP ty a1 a2 = mkFunApp indexOfPName [Type ty, a1, a2] + + +-- auxilliary functions +-- -------------------- + +-- obtain the context variable, aborting if it is not available (as this +-- signals an internal error in the usage of the `Flatten' monad) +-- +ctxtVarErr :: FlattenState -> Var +ctxtVarErr s = case ctxtVar s of + Nothing -> panic "FlattenMonad.ctxtVarErr: No context variable available!" + Just v -> v + +-- given the name of a known function and a set of arguments (needs to include +-- all needed type arguments), build a Core expression that applies the named +-- function to those arguments +-- +mkFunApp :: Name -> [CoreExpr] -> Flatten CoreExpr +mkFunApp name args = + do + fun <- lookupName name + return $ mkApps (Var fun) args + +-- get the `Id' of a known `Name' +-- +-- * this can be the `Name' of any function that's visible on the toplevel of +-- the current compilation unit +-- +lookupName :: Name -> Flatten Id +lookupName name = Flatten $ \s -> + (env s name, s) diff --git a/compiler/ndpFlatten/Flattening.hs b/compiler/ndpFlatten/Flattening.hs new file mode 100644 index 0000000000..18daaa6323 --- /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 <current context>) +-- nvar1 = bpermuteDftP index_bnd_1 ... +-- +-- in bpermuteDftP index_bnd_n nvar_(n-1) +-- +letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) -> + Flatten (CoreExpr, Type) +letWrapper lExpr b (indBnds, exprBnds, pckBnds) = + do + (defBpBnds, ty) <- dftbpBinders indBnds exprBnds + let resExpr = getExprOfBind (head defBpBnds) + return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty) + +-- dftbpBinders: return the list of binders necessary to construct the overall +-- result from the subresults computed in the different branches of the case +-- statement. The binding which contains the final result is in the *head* +-- of the result list. +-- +-- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...] +-- +-- let def = replicate (length of context) undefined +-- d1 = bpermuteDftP dft e1 i1 +-- ..... +-- +dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type) +dftbpBinders indexBnds exprBnds = + do + let expr = getExprOfBind (head exprBnds) + defVecExpr <- createDftArrayBind expr + ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr + return ((b:bnds),t) + where + dftbpBinders' :: [CoreBind] + -> [CoreBind] + -> CoreBind + -> Flatten ((CoreBind, [CoreBind]), Type) + dftbpBinders' [] [] cBnd = + return ((cBnd, []), panic "dftbpBinders: undefined type") + dftbpBinders' (i:is) (e:es) cBind = + do + let iVar = getVarOfBind i + let eVar = getVarOfBind e + let cVar = getVarOfBind cBind + let ty = idType eVar + newBnd <- mkDftBackpermute ty iVar eVar cVar + ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd + return ((fBnd, (newBnd:restBnds)), liftTy ty) + + dftbpBinders' _ _ _ = + panic "Flattening.dftbpBinders: index and expression binder lists have different length!" + +getExprOfBind:: CoreBind -> CoreExpr +getExprOfBind (NonRec _ expr) = expr + +getVarOfBind:: CoreBind -> Var +getVarOfBind (NonRec b _) = b + + + +-- Optimised Transformation +-- ========================= +-- + +-- liftSimpleFun +-- if variables x_1 to x_i occur in the context *and* free in expr +-- then +-- (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn) +-- +liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type) +liftSimpleFun b expr = + do + bndVars <- collectBoundVars expr + let bndVars' = b:bndVars + bndVarsTuple = mkTuple (map idType bndVars') (map Var bndVars') + lamExpr = mkLams (b:bndVars) expr -- FIXME: should be tuple + -- here + let (t1, t2) = funTyArgs . exprType $ lamExpr + mapExpr <- mk'mapP t1 t2 lamExpr bndVarsTuple + let lexpr = mkApps mapExpr [bndVarsTuple] + return (lexpr, undefined) -- FIXME!!!!! + + +collectBoundVars:: CoreExpr -> Flatten [CoreBndr] +collectBoundVars expr = + intersectWithContext (exprFreeVars expr) + + +-- auxilliary routines +-- ------------------- + +-- mkIndexOfExpr b lit -> +-- indexOf (mapP (\x -> x == lit) b) b +-- +mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr +mkIndexOfExpr idType b lit = + do + eqExpr <- mk'eq idType (Var b) (Lit lit) + let lambdaExpr = (Lam b eqExpr) + mk'indexOfP idType lambdaExpr (Var b) + +-- there is FlattenMonad.mk'indexOfP as well as +-- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here + +-- for case-distinction over data constructors: +-- let b = expr in +-- case b of +-- dcon args -> .... +-- dconId = dataConTag dcon +-- the call "mkIndexOfExprDCon b dconId" computes the core expression for +-- indexOfP (\x -> x == dconId) b) +-- +mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr +mkIndexOfExprDCon idType b dId = + do + let intExpr = mkIntLitInt dId + eqExpr <- mk'eq idType (Var b) intExpr + let lambdaExpr = (Lam b intExpr) + mk'indexOfP idType lambdaExpr (Var b) + + + +-- there is FlattenMonad.mk'indexOfP as well as +-- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here + +-- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the +-- default case. "dconIds" is a list of all the data constructor idents which +-- are covered by the other cases. +-- indexOfP (\x -> x != dconId_1 && ....) b) +-- +mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr +mkIndexOfExprDConDft idType b dId = + do + let intExprs = map mkIntLitInt dId + bExpr <- foldM (mk'neq idType) (head intExprs) (tail intExprs) + let lambdaExpr = (Lam b bExpr) + mk'indexOfP idType (Var b) bExpr + + +-- mkIndexOfExprDef b [lit1, lit2,...] -> +-- indexOf (\x -> not (x == lit1 || x == lit2 ....) b +mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr +mkIndexOfExprDft idType b lits = + do + let litExprs = map (\l-> Lit l) lits + bExpr <- foldM (mk'neq idType) (head litExprs) (tail litExprs) + let lambdaExpr = (Lam b bExpr) + mk'indexOfP idType bExpr (Var b) + + +-- create a back-permute binder +-- +-- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a +-- Core binding of the form +-- +-- x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar +-- +-- where `x' is a new local variable +-- +mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind +mkDftBackpermute ty idx src dft = + do + rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft) + liftM snd $ mkBind FSLIT("dbp") rhs + +-- create a dummy array with elements of the given type, which can be used as +-- default array for the combination of the subresults of the lifted case +-- expression +-- +createDftArrayBind :: CoreExpr -> Flatten CoreBind +createDftArrayBind e = + panic "Flattening.createDftArrayBind: not implemented yet" +{- + do + let ty = parrElemTy . exprType $ expr + len <- mk'lengthP e + rhs <- mk'replicateP ty len err?? + lift snd $ mkBind FSLIT("dft") rhs +FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde + beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen + generischen Wert f"ur jeden beliebigen Typ zu erfinden. +-} + + + + +-- show functions (the pretty print functions sometimes don't +-- show it the way I want.... + +-- shows just the structure +showCoreExpr (Var _ ) = "Var " +showCoreExpr (Lit _) = "Lit " +showCoreExpr (App e1 e2) = + "(App \n " ++ (showCoreExpr e1) ++ "\n " ++ (showCoreExpr e2) ++ ") " +showCoreExpr (Lam b e) = + "Lam b " ++ (showCoreExpr e) +showCoreExpr (Let bnds expr) = + "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr) + where showBinds (NonRec b e) = showBind (b,e) + showBinds (Rec bnds) = concat (map showBind bnds) + showBind (b,e) = " b = " ++ (showCoreExpr e)++ "\n" +-- gaw 2004 FIX? +showCoreExpr (Case ex b ty alts) = + "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts) + where showAlts _ = "" +showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex) +showCoreExpr (Type t) = "Type" diff --git a/compiler/ndpFlatten/NDPCoreUtils.hs b/compiler/ndpFlatten/NDPCoreUtils.hs new file mode 100644 index 0000000000..6e6b94f175 --- /dev/null +++ b/compiler/ndpFlatten/NDPCoreUtils.hs @@ -0,0 +1,174 @@ +-- $Id$ +-- +-- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- +-- Auxiliary routines for NDP-related Core transformations. +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module exports all functions to access and alter the `Type' data +-- structure from modules `Type' and `CoreExpr' from `CoreSyn'. As it is part +-- of the NDP flattening component, the functions provide access to all the +-- fields that are important for the flattening and lifting transformation. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- +--- TODO ---------------------------------------------------------------------- +-- + +module NDPCoreUtils ( + + -- type inspection functions + -- + tupleTyArgs, -- :: Type -> [Type] + funTyArgs, -- :: Type -> (Type, Type) + parrElemTy, -- :: Type -> Type + + -- Core generation functions + -- + mkTuple, -- :: [Type] -> [CoreExpr] -> CoreExpr + mkInt, -- :: CoreExpr -> CoreExpr + + -- query functions + -- + isDefault, -- :: CoreAlt -> Bool + isLit, -- :: [CoreAlt] -> Bool + isSimpleExpr, -- :: CoreExpr -> Bool + + -- re-exported functions + -- + mkPArrTy, -- :: Type -> Type + boolTy, -- :: Type + + -- substitution + -- + substIdEnv +) where + +-- GHC +import Panic (panic) +import Outputable (Outputable(ppr), pprPanic) +import BasicTypes (Boxity(..)) +import Type (Type, splitTyConApp_maybe, splitFunTy) +import TyCon (isTupleTyCon) +import TysWiredIn (parrTyCon, unitDataConId, tupleCon, intDataCon, mkPArrTy, + boolTy) +import CoreSyn (CoreExpr, CoreAlt, Expr(..), AltCon(..), + Bind(..), mkConApp) +import PprCore ( {- instances -} ) +import Var (Id) +import VarEnv (IdEnv, delVarEnv, delVarEnvList, lookupVarEnv) + +-- friends: don't import any to avoid cyclic imports +-- + + +-- type inspection functions +-- ------------------------- + +-- determines the argument types of a tuple type (EXPORTED) +-- +tupleTyArgs :: Type -> [Type] +tupleTyArgs ty = + case splitTyConApp_maybe ty of + Just (tyCon, argTys) | isTupleTyCon tyCon -> argTys + _ -> + pprPanic "NDPCoreUtils.tupleTyArgs: wrong type: " (ppr ty) + +-- determines the argument and result type of a function type (EXPORTED) +-- +funTyArgs :: Type -> (Type, Type) +funTyArgs = splitFunTy + +-- for a type of the form `[:t:]', yield `t' (EXPORTED) +-- +-- * if the type has any other form, a fatal error occurs +-- +parrElemTy :: Type -> Type +parrElemTy ty = + case splitTyConApp_maybe ty of + Just (tyCon, [argTy]) | tyCon == parrTyCon -> argTy + _ -> + pprPanic "NDPCoreUtils.parrElemTy: wrong type: " (ppr ty) + + +-- Core generation functions +-- ------------------------- + +-- make a tuple construction expression from a list of argument types and +-- argument values (EXPORTED) +-- +-- * the two lists need to be of the same length +-- +mkTuple :: [Type] -> [CoreExpr] -> CoreExpr +mkTuple [] [] = Var unitDataConId +mkTuple [_] [e] = e +mkTuple ts es | length ts == length es = + mkConApp (tupleCon Boxed (length es)) (map Type ts ++ es) +mkTuple _ _ = + panic "NDPCoreUtils.mkTuple: mismatch between number of types and exprs!" + +-- make a boxed integer from an unboxed one (EXPORTED) +-- +mkInt :: CoreExpr -> CoreExpr +mkInt e = mkConApp intDataCon [e] + + +-- query functions +-- --------------- + +-- checks whether a given case alternative is a default alternative (EXPORTED) +-- +isDefault :: CoreAlt -> Bool +isDefault (DEFAULT, _, _) = True +isDefault _ = False + +-- check whether a list of case alternatives in belongs to a case over a +-- literal type (EXPORTED) +-- +isLit :: [CoreAlt] -> Bool +isLit ((DEFAULT, _, _ ):alts) = isLit alts +isLit ((LitAlt _, _, _):_ ) = True +isLit _ = False + +-- FIXME: this function should get a more expressive name and maybe also a +-- more detailed return type (depends on how the analysis goes) +isSimpleExpr:: CoreExpr -> Bool +isSimpleExpr _ = + -- FIXME + False + + +-- Substitution +-- ------------- + +substIdEnv:: IdEnv Id -> CoreExpr -> CoreExpr +substIdEnv env e@(Lit _) = e +substIdEnv env e@(Var id) = + case (lookupVarEnv env id) of + Just v -> (Var v) + _ -> e +substIdEnv env (App e arg) = + App (substIdEnv env e) (substIdEnv env arg) +substIdEnv env (Lam b expr) = + Lam b (substIdEnv (delVarEnv env b) expr) +substIdEnv env (Let (NonRec b expr1) expr2) = + Let (NonRec b (substIdEnv env expr1)) + (substIdEnv (delVarEnv env b) expr2) +substIdEnv env (Let (Rec bnds) expr) = + let + newEnv = delVarEnvList env (map fst bnds) + newExpr = substIdEnv newEnv expr + substBnd (b,e) = (b, substIdEnv newEnv e) + in Let (Rec (map substBnd bnds)) newExpr +substIdEnv env (Case expr b ty alts) = + Case (substIdEnv newEnv expr) b ty (map substAlt alts) + where + newEnv = delVarEnv env b + substAlt (c, bnds, expr) = + (c, bnds, substIdEnv (delVarEnvList env bnds) expr) +substIdEnv env (Note n expr) = + Note n (substIdEnv env expr) +substIdEnv env e@(Type t) = e diff --git a/compiler/ndpFlatten/PArrAnal.hs b/compiler/ndpFlatten/PArrAnal.hs new file mode 100644 index 0000000000..2db56221b2 --- /dev/null +++ b/compiler/ndpFlatten/PArrAnal.hs @@ -0,0 +1,203 @@ +-- $Id$ +-- +-- Copyright (c) 2002 Manuel M T Chakravarty & Gabriele Keller +-- +-- Analysis phase for an optimised flattening transformation +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module implements an analysis phase that identifies Core expressions +-- that need not be transformed during flattening. The expressions when +-- executed in a parallel context are implemented as an iteration over the +-- original scalar computation, instead of vectorising the computation. This +-- usually improves efficiency by increasing locality and also reduces code +-- size. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 with C preprocessor +-- +-- Analyse the expression and annotate each simple subexpression accordingly. +-- +-- The result of the analysis is stored in a new field in IdInfo (has yet to +-- be extended) +-- +-- A simple expression is any expression which is not a function, not of +-- recursive type and does not contain a value of PArray type. Polymorphic +-- variables are simple expressions even though they might be instantiated to +-- a parray value or function. +-- +--- TODO ---------------------------------------------------------------------- +-- + +module PArrAnal ( + markScalarExprs -- :: [CoreBind] -> [CoreBind] +) where + +import Panic (panic) +import Outputable (pprPanic, ppr) +import CoreSyn (CoreBind) + +import TypeRep (Type(..)) +import Var (Var(..),Id) +import Literal (Literal) +import CoreSyn (Expr(..),CoreExpr,Bind(..)) +import PprCore ( {- instances -} ) +-- + +data ArrayUsage = Prim | NonPrim | Array + | PolyExpr (Id -> Maybe (ArrayUsage -> ArrayUsage)) + | PolyFun (ArrayUsage -> ArrayUsage) + + +arrUsage:: CoreExpr -> ArrayUsage +arrUsage (Var id) = varArrayUsage id +arrUsage (Lit lit) = litArrayUsage lit +arrUsage (App expr1 expr2) = + let + arr1 = arrUsage expr1 + arr2 = arrUsage expr2 + in + case (arr1, arr2) of + (_, Array) -> Array + (PolyFun f, _) -> f arr2 + (_, _) -> arr1 + +arrUsage (Lam b expr) = + bindType (b, expr) + +arrUsage (Let (NonRec b expr1) expr2) = + arrUsage (App (Lam b expr2) expr1) + +arrUsage (Let (Rec bnds) expr) = + let + t1 = foldr combineArrayUsage Prim (map bindType bnds) + t2 = arrUsage expr + in if isArrayUsage t1 then Array else t2 + +arrUsage (Case expr b _ alts) = + let + t1 = arrUsage expr + t2 = scanType (map (arrUsage . (\ (_,_,x) -> x)) alts) + in scanType [t1, t2] + +arrUsage (Note n expr) = + arrUsage expr + +arrUsage (Type t) = + typeArrayUsage t + +bindType (b, expr) = + let + bT = varArrayUsage b + exprT = arrUsage expr + in case (bT, exprT) of + (Array, _) -> Array + _ -> exprT + +scanType:: [ArrayUsage] -> ArrayUsage +scanType [t] = t +scanType (Array:ts) = Array +scanType (_:ts) = scanType ts + + + +-- the code expression represents a built-in function which generates +-- an array +isArrayGen:: CoreExpr -> Bool +isArrayGen _ = + panic "PArrAnal: isArrayGen: not yet implemented" + +isArrayCon:: CoreExpr -> Bool +isArrayCon _ = + panic "PArrAnal: isArrayCon: not yet implemented" + +markScalarExprs:: [CoreBind] -> [CoreBind] +markScalarExprs _ = + panic "PArrAnal.markScalarExprs: not implemented yet" + + +varArrayUsage:: Id -> ArrayUsage +varArrayUsage = + panic "PArrAnal.varArrayUsage: not yet implented" + +litArrayUsage:: Literal -> ArrayUsage +litArrayUsage = + panic "PArrAnal.litArrayUsage: not yet implented" + + +typeArrayUsage:: Type -> ArrayUsage +typeArrayUsage (TyVarTy tvar) = + PolyExpr (tIdFun tvar) +typeArrayUsage (AppTy _ _) = + panic "PArrAnal.typeArrayUsage: AppTy case not yet implemented" +typeArrayUsage (TyConApp tc tcargs) = + let + tcargsAU = map typeArrayUsage tcargs + tcCombine = foldr combineArrayUsage Prim tcargsAU + in auCon tcCombine +typeArrayUsage t@(PredTy _) = + pprPanic "PArrAnal.typeArrayUsage: encountered 'PredType - shouldn't be here!" + (ppr t) + + +combineArrayUsage:: ArrayUsage -> ArrayUsage -> ArrayUsage +combineArrayUsage Array _ = Array +combineArrayUsage _ Array = Array +combineArrayUsage (PolyExpr f1) (PolyExpr f2) = + PolyExpr f' + where + f' var = + let + f1lookup = f1 var + f2lookup = f2 var + in + case (f1lookup, f2lookup) of + (Nothing, _) -> f2lookup + (_, Nothing) -> f1lookup + (Just f1', Just f2') -> Just ( \e -> (combineArrayUsage (f1' e) (f2' e))) +combineArrayUsage (PolyFun f) (PolyExpr g) = + panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++ + " constructor - should not (?) happen\n") +combineArrayUsage (PolyExpr g) (PolyFun f) = + panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++ + " constructor - should not (?) happen\n") +combineArrayUsage NonPrim _ = NonPrim +combineArrayUsage _ NonPrim = NonPrim +combineArrayUsage Prim Prim = Prim + + +isArrayUsage:: ArrayUsage -> Bool +isArrayUsage Array = True +isArrayUsage _ = False + +-- Functions to serve as arguments for PolyExpr +-- --------------------------------------------- + +tIdFun:: Var -> Var -> Maybe (ArrayUsage -> ArrayUsage) +tIdFun t tcomp = + if t == tcomp then + Just auId + else + Nothing + +-- Functions to serve as argument for PolyFun +-- ------------------------------------------- + +auId:: ArrayUsage -> ArrayUsage +auId = id + +auCon:: ArrayUsage -> ArrayUsage +auCon Prim = NonPrim +auCon (PolyExpr f) = PolyExpr f' + where f' v = case f v of + Nothing -> Nothing + Just g -> Just ( \e -> (auCon (g e))) +auCon (PolyFun f) = PolyFun (auCon . f) +auCon _ = Array + +-- traversal of Core expressions +-- ----------------------------- + +-- FIXME: implement + diff --git a/compiler/ndpFlatten/TODO b/compiler/ndpFlatten/TODO new file mode 100644 index 0000000000..e596609205 --- /dev/null +++ b/compiler/ndpFlatten/TODO @@ -0,0 +1,202 @@ + TODO List for Flattening Support in GHC -*-text-*- + ======================================= + +Middle-End Related +~~~~~~~~~~~~~~~~~~ + +Flattening Transformation +~~~~~~~~~~~~~~~~~~~~~~~~~ + +* Complete and test + +* Complete the analysis + +* Type transformation: The idea solution would probably be if we can add some + generic machinery, so that we can define all the rules for handling the type + and value transformations in a library. (The PrelPArr for WayNDP.) + + +Library Related +~~~~~~~~~~~~~~~ + +* Problem with re-exporting PrelPArr from Prelude is that it would also be + visible when -pparr is not given. There should be a mechanism to implicitly + import more than one module (like PERVASIVE modules in M3) + +* We need a PrelPArr-like library for when flattening is used, too. In fact, + we need some library routines that are on the level of merely vectorised + code (eg, for the dummy default vectors), and then, all the `PArrays' stuff + implementing fast unboxed arrays and fusion. + +* Enum is a problem. Ideally, we would like `enumFromToP' and + `enumFromThenToP' to be members of `Enum'. On the other hand, we really do + not want to change `Enum'. The solution for the moment is to define + + enumFromTo x y = mapP toEnum [:fromEnum x .. fromEnum y:] + enumFromThenTo x y z = mapP toEnum [:fromEnum x, fromEnum y .. fromEnum z:] + + like the Haskell Report does for the list versions. This is hopefully + efficient enough as array fusion should fold the two traversals into one. + [DONE] + + +DOCU that should go into the Commentary +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The type constructor [::] +------------------------- + +The array type constructor [::] is quite similar to [] (list constructor) in +that GHC has to know about it (in TysWiredIn); however, there are some +differences: + +* [::] is an abstract type, whereas [] is not + +* if flattening is switched on, all occurences of the type are actually + removed by appropriate program transformations. + +The module PrelPArr that actually implements nested parallel arrays. [::] is +eliminated only if in addition to array support, flattening is activated. It +is just an option rather than the only method to implement those arrays. + + Flags: -fparr -- syntactic support for parallel arrays (via `PrelPArr') + * Dynamic hsc option; can be reversed with -fno-parr + -fflatten -- flattening transformation + * Static hsc option + -ndp -- this a way option, which implies -fparr and -fflatten + (way options are handled by the driver and are not + directly seen by hsc) + -ddump-vect -- dump Core after vectorisation + * Dynamic hsc option + +* PrelPArr implements array variants of the Prelude list functions plus some + extra functions (also, some list functions (eg, those generating infinite + lists) have been left out. + +* prelude/PrelNames has been extended with all the names from PrelPArr that + need to be known inside the compiler + +* The variable GhcSupportsPArr, which can be set in build.mk decides whether + `PrelPArr' is to be compiled or not. (We probably need to supress compiling + PrelPArr in WayNDP, or rather replace it with a different PrelPArr.) + +* Say something about `TysWiredIn.parrTyCon' as soon as we know how it + actually works... + +Parser and AST Notes: +- Parser and AST is quite straight forward. Essentially, the list cases + duplicated with a name containing `PArr' or `parr' and modified to fit the + slightly different semantics (ie, finite length, strict). +- The value and pattern `[::]' is an empty explicit parallel array (ie, + something of the form `ExplicitPArr ty []' in the AST). This is in contrast + to lists, which use the nil-constructor instead. In the case of parallel + arrays, using a constructor would be rather awkward, as it is not a + constructor-based type. +- Thus, array patterns have the general form `[:p1, p2, ..., pn:]', where n >= + 0. Thus, two array patterns overlap iff they have the same length. +- The type constructor for parallel is internally represented as a + `TyCon.AlgTyCon' with a wired in definition in `TysWiredIn'. + +Desugarer Notes: +- Desugaring of patterns involving parallel arrays: + * In Match.tidy1, we use fake array constructors; ie, any pattern `[:p1, ..., + pn:]' is replaces by the expression `MkPArr<n> p1 ... pn', where + `MkPArr<n>' is the n-ary array constructor. These constructors are fake, + because they are never used to actually represent array values; in fact, + they are removed again before pattern compilation is finished. However, + the use of these fake constructors implies that we need not modify large + parts of the machinery of the pattern matching compiler, as array patterns + are handled like any other constructor pattern. + * Check.simplify_pat introduces the same fake constructors as Match.tidy1 + and removed again by Check.make_con. + * In DsUtils.mkCoAlgCaseMatchResult, we catch the case of array patterns and + generate code as the following example illustrates, where the LHS is the + code that would be produced if array construtors would really exist: + + case v of pa { + MkPArr1 x1 -> e1 + MkPArr2 x2 x3 x4 -> e2 + DFT -> e3 + } + + => + + case lengthP v of + Int# i# -> + case i# of l { + 1 -> let x1 = v!:0 in e1 + 3 -> let x2 = v!:0; x2 = v!:1; x3 = v!:2 in e2 + DFT -> e3 + } + * The desugaring of array comprehensions is in `DsListComp', but follows + rules that are different from that for translating list comprehensions. + Denotationally, it boils down to the same, but the operational + requirements for an efficient implementation of array comprehensions are + rather different. + + [:e | qss:] = <<[:e | qss:]>> () [:():] + + <<[:e' | :]>> pa ea = mapP (\pa -> e') ea + <<[:e' | b , qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) + <<[:e' | p <- e, qs:]>> pa ea = + let ef = filterP (\x -> case x of {p -> True; _ -> False}) e + in + <<[:e' | qs:]>> (pa, p) (crossP ea ef) + <<[:e' | let ds, qs:]>> pa ea = + <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) + (mapP (\v@pa -> (v, let ds in (x_1, ..., x_n))) ea) + where + {x_1, ..., x_n} = DV (ds) -- Defined Variables + <<[:e' | qs | qss:]>> pa ea = + <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) + (zipP ea <<[:(x_1, ..., x_n) | qs:]>>) + where + {x_1, ..., x_n} = DV (qs) + + Moreover, we have + + crossP :: [:a:] -> [:b:] -> [:(a, b):] + crossP a1 a2 = let + len1 = lengthP a1 + len2 = lengthP a2 + x1 = concatP $ mapP (replicateP len2) a1 + x2 = concatP $ replicateP len1 a2 + in + zipP x1 x2 + + For a more efficient implementation of `crossP', see `PrelPArr'. + + Optimisations: + - In the `p <- e' rule, if `pa = ()', drop it and simplify the `crossP ea + e' to `e'. + - We assume that fusion will optimise sequences of array processing + combinators. + - Do we want to have the following function? + + mapFilterP :: (a -> Maybe b) -> [:a:] -> [:b:] + + Even with fusion `(mapP (\p -> e) . filterP (\p -> b))' may still result + in redundant pattern matching operations. (Let's wait with this until + we have seen what the Simplifier does to the generated code.) + +Flattening Notes: +* The story about getting access to all the names like "fst" etc that we need + to generate during flattening is quite involved. To have a reasonable + chance to get at the stuff, we need to put flattening inbetween the + desugarer and the simplifier as an extra pass in HscMain.hscMain. After + that point, the persistent compiler state is zapped (for heap space + reduction reasons, I guess) and nothing remains of the imported interfaces + in one shot mode. + + Moreover, to get the Ids that we need into the type environment, we need to + force the renamer to include them. This is done in + RnEnv.getImplicitModuleFVs, which computes all implicitly imported names. + We let it add the names from FlattenInfo.namesNeededForFlattening. + + Given all these arrangements, FlattenMonad can obtain the needed Ids from + the persistent compiler state without much further hassle. + + [It might be worthwhile to document in the non-Flattening part of the + Commentary that the persistent compiler state is zapped after desugaring and + how the free variables determined by the renamer imply which names are + imported.] |