3 -- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller
5 -- Monad maintaining parallel contexts and substitutions for flattening.
7 --- DESCRIPTION ---------------------------------------------------------------
9 -- The flattening transformation needs to perform a fair amount of plumbing.
10 -- It needs to mainatin a set of variables, called the parallel context for
11 -- lifting, variable substitutions in case alternatives, and so on.
12 -- Moreover, we need to manage uniques to create new variables. The monad
13 -- defined in this module takes care of maintaining this state.
15 --- DOCU ----------------------------------------------------------------------
17 -- Language: Haskell 98
19 -- * a parallel context is a set of variables that get vectorised during a
20 -- lifting transformations (ie, their type changes from `t' to `[:t:]')
22 -- * all vectorised variables in a parallel context have the same size; we
23 -- call this also the size of the parallel context
25 -- * we represent contexts by maps that give the lifted version of a variable
26 -- (remember that in GHC, variables contain type information that changes
29 --- TODO ----------------------------------------------------------------------
31 -- * Assumptions currently made that should (if they turn out to be true) be
32 -- documented in The Commentary:
34 -- - Local bindings can be copied without any need to alpha-rename bound
35 -- variables (or their uniques). Such renaming is only necessary when
36 -- bindings in a recursive group are replicated; implying that this is
37 -- required in the case of top-level bindings). (Note: The CoreTidy path
38 -- generates global uniques before code generation.)
40 -- * One FIXME left to resolve.
49 -- variable generation
53 -- context management & query operations
55 extendContext, packContext, liftVar, liftConst, intersectWithContext,
57 -- construction of prelude functions
59 mk'fst, mk'eq, mk'neq, mk'and, mk'or, mk'lengthP, mk'replicateP, mk'mapP,
60 mk'bpermuteP, mk'bpermuteDftP, mk'indexOfP
68 import Outputable (Outputable(ppr), pprPanic)
69 import UniqSupply (UniqSupply, splitUniqSupply, uniqFromSupply)
70 import OccName (UserFS)
72 import Id (Id, mkSysLocal)
74 import VarSet (VarSet, emptyVarSet, extendVarSet, varSetElems )
75 import VarEnv (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv,
76 elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList)
77 import TyCon (tyConName)
78 import Type (Type, tyConAppTyCon)
79 import HscTypes (HomePackageTable, PersistentCompilerState(pcs_EPS),
80 ExternalPackageState(eps_PTE), HscEnv(hsc_HPT),
81 TyThing(..), lookupType)
82 import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName,
83 doublePrimTyConName, fstName, andName, orName,
84 lengthPName, replicatePName, mapPName, bpermutePName,
85 bpermuteDftPName, indexOfPName)
86 import PrimOp (eqCharName, eqIntName, eqFloatName, eqDoubleName,
88 -- neqCharName, neqFloatName,neqDoubleName,
89 import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps)
90 import CoreUtils (exprType)
93 import NDPCoreUtils (parrElemTy)
96 -- definition of the monad
97 -- -----------------------
99 -- state maintained by the flattening monad
101 data FlattenState = FlattenState {
103 -- our source for uniques
107 -- environment containing all known names (including all
108 -- Prelude functions)
112 -- this variable determines the parallel context; if
113 -- `Nothing', we are in pure vectorisation mode, no
116 ctxtVar :: Maybe Var,
118 -- environment that maps each variable that is
119 -- vectorised in the current parallel context to the
120 -- vectorised version of that variable
122 ctxtEnv :: VarEnv Var,
124 -- those variables from the *domain* of `ctxtEnv' that
125 -- have been used since the last context restriction (cf.
126 -- `restrictContext')
131 -- initial value of the flattening state
133 initialFlattenState :: PersistentCompilerState
137 initialFlattenState pcs hpt us =
142 ctxtEnv = emptyVarEnv,
143 usedVars = emptyVarSet
147 case lookupType hpt (eps_PTE (pcs_EPS pcs)) n of
149 _ -> pprPanic "FlattenMonad: unknown name:" (ppr n)
151 -- the monad representation (EXPORTED ABSTRACTLY)
153 newtype Flatten a = Flatten {
154 unFlatten :: (FlattenState -> (a, FlattenState))
157 instance Monad Flatten where
158 return x = Flatten $ \s -> (x, s)
159 m >>= n = Flatten $ \s -> let
160 (r, s') = unFlatten m s
164 -- execute the given flattening computation (EXPORTED)
167 -> PersistentCompilerState
171 runFlatten hsc_env pcs us m
172 = fst $ unFlatten m (initialFlattenState pcs (hsc_HPT hsc_env) us)
175 -- variable generation
176 -- -------------------
178 -- generate a new local variable whose name is based on the given lexeme and
179 -- whose type is as specified in the second argument (EXPORTED)
181 newVar :: UserFS -> Type -> Flatten Var
182 newVar lexeme ty = Flatten $ \state ->
184 (us1, us2) = splitUniqSupply (us state)
185 state' = state {us = us2}
187 (mkSysLocal lexeme (uniqFromSupply us1) ty, state')
189 -- generate a non-recursive binding using a new binder whose name is derived
190 -- from the given lexeme (EXPORTED)
192 mkBind :: UserFS -> CoreExpr -> Flatten (CoreBndr, CoreBind)
195 v <- newVar lexeme (exprType e)
196 return (v, NonRec v e)
199 -- context management
200 -- ------------------
202 -- extend the parallel context by the given set of variables (EXPORTED)
204 -- * if there is no parallel context at the moment, the first element of the
205 -- variable list will be used to determine the new parallel context
207 -- * the second argument is executed in the current context extended with the
210 -- * the variables must already have been lifted by transforming their type,
211 -- but they *must* have retained their original name (or, at least, their
212 -- unique); this is needed so that they match the original variable in
213 -- variable environments
215 -- * any trace of the given set of variables has to be removed from the state
216 -- at the end of this operation
218 extendContext :: [Var] -> Flatten a -> Flatten a
219 extendContext [] m = m
220 extendContext vs m = Flatten $ \state ->
223 ctxtVar = ctxtVar state `mplus` Just (head vs),
224 ctxtEnv = ctxtEnv state `plusVarEnv` zipVarEnv vs vs
226 (r, extState') = unFlatten m extState
227 resState = extState' { -- remove `vs' from the result state
228 ctxtVar = ctxtVar state,
229 ctxtEnv = ctxtEnv state,
230 usedVars = usedVars extState' `delVarEnvList` vs
235 -- execute the second argument in a restricted context (EXPORTED)
237 -- * all variables in the current parallel context are packed according to
238 -- the permutation vector associated with the variable passed as the first
239 -- argument (ie, all elements of vectorised context variables that are
240 -- invalid in the restricted context are dropped)
242 -- * the returned list of core binders contains the operations that perform
243 -- the restriction on all variables in the parallel context that *do* occur
244 -- during the execution of the second argument (ie, `liftVar' is executed at
245 -- least once on any such variable)
247 packContext :: Var -> Flatten a -> Flatten (a, [CoreBind])
248 packContext perm m = Flatten $ \state ->
250 -- FIXME: To set the packed environment to the unpacked on is a hack of
251 -- which I am not sure yet (a) whether it works and (b) whether it's
252 -- really worth it. The one advantages is that, we can use a var set,
253 -- after all, instead of a var environment.
255 -- The idea is the following: If we have to pack a variable `x', we
256 -- generate `let{-NonRec-} x = bpermuteP perm x in ...'. As this is a
257 -- non-recursive binding, the lhs `x' overshadows the rhs `x' in the
260 -- NB: If we leave it like this, `mkCoreBind' can be simplified.
261 packedCtxtEnv = ctxtEnv state
262 packedState = state {
264 (lookupVarEnv_NF packedCtxtEnv)
266 ctxtEnv = packedCtxtEnv,
267 usedVars = emptyVarSet
269 (r, packedState') = unFlatten m packedState
270 resState = state { -- revert to the unpacked context
271 ctxtVar = ctxtVar state,
272 ctxtEnv = ctxtEnv state,
274 bndrs = map mkCoreBind . varSetElems . usedVars $ packedState'
276 -- generate a binding for the packed variant of a context variable
279 rhs = fst $ unFlatten (mk'bpermuteP (varType var)
284 NonRec (lookupVarEnv_NF packedCtxtEnv var) $ rhs
287 ((r, bndrs), resState)
289 -- lift a single variable in the current context (EXPORTED)
291 -- * if the variable does not occur in the context, it's value is vectorised to
292 -- match the size of the current context
294 -- * otherwise, the variable is replaced by whatever the context environment
295 -- maps it to (this may either be simply the lifted version of the original
296 -- variable or a packed variant of that variable)
298 -- * the monad keeps track of all lifted variables that occur in the parallel
299 -- context, so that `packContext' can determine the correct set of core
302 liftVar :: Var -> Flatten CoreExpr
303 liftVar var = Flatten $ \s ->
306 v'elemType = parrElemTy . varType $ v
307 len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s
308 replicated = fst $ unFlatten (mk'replicateP (varType var) len (Var var)) s
309 in case lookupVarEnv (ctxtEnv s) var of
310 Just liftedVar -> (Var liftedVar,
311 s {usedVars = usedVars s `extendVarSet` var})
312 Nothing -> (replicated, s)
314 -- lift a constant expression in the current context (EXPORTED)
316 -- * the value of the constant expression is vectorised to match the current
319 liftConst :: CoreExpr -> Flatten CoreExpr
320 liftConst e = Flatten $ \s ->
323 v'elemType = parrElemTy . varType $ v
324 len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s
326 (fst $ unFlatten (mk'replicateP (exprType e) len e ) s, s)
328 -- pick those variables of the given set that occur (if albeit in lifted form)
329 -- in the current parallel context (EXPORTED)
331 -- * the variables returned are from the given set and *not* the corresponding
334 intersectWithContext :: VarSet -> Flatten [Var]
335 intersectWithContext vs = Flatten $ \s ->
337 vs' = filter (`elemVarEnv` ctxtEnv s) (varSetElems vs)
342 -- construct applications of prelude functions
343 -- -------------------------------------------
345 -- NB: keep all the used names listed in `FlattenInfo.namesNeededForFlattening'
347 -- generate an application of `fst' (EXPORTED)
349 mk'fst :: Type -> Type -> CoreExpr -> Flatten CoreExpr
350 mk'fst ty1 ty2 a = mkFunApp fstName [Type ty1, Type ty2, a]
352 -- generate an application of `&&' (EXPORTED)
354 mk'and :: CoreExpr -> CoreExpr -> Flatten CoreExpr
355 mk'and a1 a2 = mkFunApp andName [a1, a2]
357 -- generate an application of `||' (EXPORTED)
359 mk'or :: CoreExpr -> CoreExpr -> Flatten CoreExpr
360 mk'or a1 a2 = mkFunApp orName [a1, a2]
362 -- generate an application of `==' where the arguments may only be literals
363 -- that may occur in a Core case expression (i.e., `Char', `Int', `Float', and
364 -- `Double') (EXPORTED)
366 mk'eq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
367 mk'eq ty a1 a2 = mkFunApp eqName [a1, a2]
369 name = tyConName . tyConAppTyCon $ ty
371 eqName | name == charPrimTyConName = eqCharName
372 | name == intPrimTyConName = eqIntName
373 | name == floatPrimTyConName = eqFloatName
374 | name == doublePrimTyConName = eqDoubleName
376 pprPanic "FlattenMonad.mk'eq: " (ppr ty)
378 -- generate an application of `==' where the arguments may only be literals
379 -- that may occur in a Core case expression (i.e., `Char', `Int', `Float', and
380 -- `Double') (EXPORTED)
382 mk'neq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
383 mk'neq ty a1 a2 = mkFunApp neqName [a1, a2]
385 name = tyConName . tyConAppTyCon $ ty
387 neqName {- | name == charPrimTyConName = neqCharName -}
388 | name == intPrimTyConName = neqIntName
389 {- | name == floatPrimTyConName = neqFloatName -}
390 {- | name == doublePrimTyConName = neqDoubleName -}
392 pprPanic "FlattenMonad.mk'neq: " (ppr ty)
394 -- generate an application of `lengthP' (EXPORTED)
396 mk'lengthP :: Type -> CoreExpr -> Flatten CoreExpr
397 mk'lengthP ty a = mkFunApp lengthPName [Type ty, a]
399 -- generate an application of `replicateP' (EXPORTED)
401 mk'replicateP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
402 mk'replicateP ty a1 a2 = mkFunApp replicatePName [Type ty, a1, a2]
404 -- generate an application of `replicateP' (EXPORTED)
406 mk'mapP :: Type -> Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
407 mk'mapP ty1 ty2 a1 a2 = mkFunApp mapPName [Type ty1, Type ty2, a1, a2]
409 -- generate an application of `bpermuteP' (EXPORTED)
411 mk'bpermuteP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
412 mk'bpermuteP ty a1 a2 = mkFunApp bpermutePName [Type ty, a1, a2]
414 -- generate an application of `bpermuteDftP' (EXPORTED)
416 mk'bpermuteDftP :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> Flatten CoreExpr
417 mk'bpermuteDftP ty a1 a2 a3 = mkFunApp bpermuteDftPName [Type ty, a1, a2, a3]
419 -- generate an application of `indexOfP' (EXPORTED)
421 mk'indexOfP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
422 mk'indexOfP ty a1 a2 = mkFunApp indexOfPName [Type ty, a1, a2]
425 -- auxilliary functions
426 -- --------------------
428 -- obtain the context variable, aborting if it is not available (as this
429 -- signals an internal error in the usage of the `Flatten' monad)
431 ctxtVarErr :: FlattenState -> Var
432 ctxtVarErr s = case ctxtVar s of
433 Nothing -> panic "FlattenMonad.ctxtVarErr: No context \
434 \variable available!"
437 -- given the name of a known function and a set of arguments (needs to include
438 -- all needed type arguments), build a Core expression that applies the named
439 -- function to those arguments
441 mkFunApp :: Name -> [CoreExpr] -> Flatten CoreExpr
444 fun <- lookupName name
445 return $ mkApps (Var fun) args
447 -- get the `Id' of a known `Name'
449 -- * this can be the `Name' of any function that's visible on the toplevel of
450 -- the current compilation unit
452 lookupName :: Name -> Flatten Id
453 lookupName name = Flatten $ \s ->