diff options
Diffstat (limited to 'compiler/ndpFlatten/FlattenMonad.hs')
| -rw-r--r-- | compiler/ndpFlatten/FlattenMonad.hs | 451 |
1 files changed, 451 insertions, 0 deletions
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) |