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
67 import CmdLineOpts (opt_Flatten)
69 import Outputable (Outputable(ppr), pprPanic)
70 import UniqSupply (UniqSupply, splitUniqSupply, uniqFromSupply)
71 import OccName (UserFS)
73 import Id (Id, mkSysLocal)
75 import VarSet (VarSet, emptyVarSet, extendVarSet, varSetElems )
76 import VarEnv (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv,
77 elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList)
78 import TyCon (tyConName)
79 import Type (Type, tyConAppTyCon)
80 import HscTypes (HomePackageTable, PersistentCompilerState(pcs_EPS),
81 ExternalPackageState(eps_PTE), HscEnv(hsc_HPT),
82 TyThing(..), lookupType)
83 import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName,
84 doublePrimTyConName, fstName, andName, orName,
85 lengthPName, replicatePName, mapPName, bpermutePName,
86 bpermuteDftPName, indexOfPName)
87 import PrimOp (eqCharName, eqIntName, eqFloatName, eqDoubleName,
89 -- neqCharName, neqFloatName,neqDoubleName,
90 import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps)
91 import CoreUtils (exprType)
94 import NDPCoreUtils (parrElemTy)
97 -- definition of the monad
98 -- -----------------------
100 -- state maintained by the flattening monad
102 data FlattenState = FlattenState {
104 -- our source for uniques
108 -- environment containing all known names (including all
109 -- Prelude functions)
113 -- this variable determines the parallel context; if
114 -- `Nothing', we are in pure vectorisation mode, no
117 ctxtVar :: Maybe Var,
119 -- environment that maps each variable that is
120 -- vectorised in the current parallel context to the
121 -- vectorised version of that variable
123 ctxtEnv :: VarEnv Var,
125 -- those variables from the *domain* of `ctxtEnv' that
126 -- have been used since the last context restriction (cf.
127 -- `restrictContext')
132 -- initial value of the flattening state
134 initialFlattenState :: PersistentCompilerState
138 initialFlattenState pcs hpt us =
143 ctxtEnv = emptyVarEnv,
144 usedVars = emptyVarSet
148 case lookupType hpt (eps_PTE (pcs_EPS pcs)) n of
150 _ -> pprPanic "FlattenMonad: unknown name:" (ppr n)
152 -- the monad representation (EXPORTED ABSTRACTLY)
154 newtype Flatten a = Flatten {
155 unFlatten :: (FlattenState -> (a, FlattenState))
158 instance Monad Flatten where
159 return x = Flatten $ \s -> (x, s)
160 m >>= n = Flatten $ \s -> let
161 (r, s') = unFlatten m s
165 -- execute the given flattening computation (EXPORTED)
168 -> PersistentCompilerState
172 runFlatten hsc_env pcs us m
173 = fst $ unFlatten m (initialFlattenState pcs (hsc_HPT hsc_env) us)
176 -- variable generation
177 -- -------------------
179 -- generate a new local variable whose name is based on the given lexeme and
180 -- whose type is as specified in the second argument (EXPORTED)
182 newVar :: UserFS -> Type -> Flatten Var
183 newVar lexeme ty = Flatten $ \state ->
185 (us1, us2) = splitUniqSupply (us state)
186 state' = state {us = us2}
188 (mkSysLocal lexeme (uniqFromSupply us1) ty, state')
190 -- generate a non-recursive binding using a new binder whose name is derived
191 -- from the given lexeme (EXPORTED)
193 mkBind :: UserFS -> CoreExpr -> Flatten (CoreBndr, CoreBind)
196 v <- newVar lexeme (exprType e)
197 return (v, NonRec v e)
200 -- context management
201 -- ------------------
203 -- extend the parallel context by the given set of variables (EXPORTED)
205 -- * if there is no parallel context at the moment, the first element of the
206 -- variable list will be used to determine the new parallel context
208 -- * the second argument is executed in the current context extended with the
211 -- * the variables must already have been lifted by transforming their type,
212 -- but they *must* have retained their original name (or, at least, their
213 -- unique); this is needed so that they match the original variable in
214 -- variable environments
216 -- * any trace of the given set of variables has to be removed from the state
217 -- at the end of this operation
219 extendContext :: [Var] -> Flatten a -> Flatten a
220 extendContext [] m = m
221 extendContext vs m = Flatten $ \state ->
224 ctxtVar = ctxtVar state `mplus` Just (head vs),
225 ctxtEnv = ctxtEnv state `plusVarEnv` zipVarEnv vs vs
227 (r, extState') = unFlatten m extState
228 resState = extState' { -- remove `vs' from the result state
229 ctxtVar = ctxtVar state,
230 ctxtEnv = ctxtEnv state,
231 usedVars = usedVars extState' `delVarEnvList` vs
236 -- execute the second argument in a restricted context (EXPORTED)
238 -- * all variables in the current parallel context are packed according to
239 -- the permutation vector associated with the variable passed as the first
240 -- argument (ie, all elements of vectorised context variables that are
241 -- invalid in the restricted context are dropped)
243 -- * the returned list of core binders contains the operations that perform
244 -- the restriction on all variables in the parallel context that *do* occur
245 -- during the execution of the second argument (ie, `liftVar' is executed at
246 -- least once on any such variable)
248 packContext :: Var -> Flatten a -> Flatten (a, [CoreBind])
249 packContext perm m = Flatten $ \state ->
251 -- FIXME: To set the packed environment to the unpacked on is a hack of
252 -- which I am not sure yet (a) whether it works and (b) whether it's
253 -- really worth it. The one advantages is that, we can use a var set,
254 -- after all, instead of a var environment.
256 -- The idea is the following: If we have to pack a variable `x', we
257 -- generate `let{-NonRec-} x = bpermuteP perm x in ...'. As this is a
258 -- non-recursive binding, the lhs `x' overshadows the rhs `x' in the
261 -- NB: If we leave it like this, `mkCoreBind' can be simplified.
262 packedCtxtEnv = ctxtEnv state
263 packedState = state {
265 (lookupVarEnv_NF packedCtxtEnv)
267 ctxtEnv = packedCtxtEnv,
268 usedVars = emptyVarSet
270 (r, packedState') = unFlatten m packedState
271 resState = state { -- revert to the unpacked context
272 ctxtVar = ctxtVar state,
273 ctxtEnv = ctxtEnv state,
275 bndrs = map mkCoreBind . varSetElems . usedVars $ packedState'
277 -- generate a binding for the packed variant of a context variable
280 rhs = fst $ unFlatten (mk'bpermuteP (varType var)
285 NonRec (lookupVarEnv_NF packedCtxtEnv var) $ rhs
288 ((r, bndrs), resState)
290 -- lift a single variable in the current context (EXPORTED)
292 -- * if the variable does not occur in the context, it's value is vectorised to
293 -- match the size of the current context
295 -- * otherwise, the variable is replaced by whatever the context environment
296 -- maps it to (this may either be simply the lifted version of the original
297 -- variable or a packed variant of that variable)
299 -- * the monad keeps track of all lifted variables that occur in the parallel
300 -- context, so that `packContext' can determine the correct set of core
303 liftVar :: Var -> Flatten CoreExpr
304 liftVar var = Flatten $ \s ->
307 v'elemType = parrElemTy . varType $ v
308 len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s
309 replicated = fst $ unFlatten (mk'replicateP (varType var) len (Var var)) s
310 in case lookupVarEnv (ctxtEnv s) var of
311 Just liftedVar -> (Var liftedVar,
312 s {usedVars = usedVars s `extendVarSet` var})
313 Nothing -> (replicated, s)
315 -- lift a constant expression in the current context (EXPORTED)
317 -- * the value of the constant expression is vectorised to match the current
320 liftConst :: CoreExpr -> Flatten CoreExpr
321 liftConst e = Flatten $ \s ->
324 v'elemType = parrElemTy . varType $ v
325 len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s
327 (fst $ unFlatten (mk'replicateP (exprType e) len e ) s, s)
329 -- pick those variables of the given set that occur (if albeit in lifted form)
330 -- in the current parallel context (EXPORTED)
332 -- * the variables returned are from the given set and *not* the corresponding
335 intersectWithContext :: VarSet -> Flatten [Var]
336 intersectWithContext vs = Flatten $ \s ->
338 vs' = filter (`elemVarEnv` ctxtEnv s) (varSetElems vs)
343 -- construct applications of prelude functions
344 -- -------------------------------------------
346 -- NB: keep all the used names listed in `FlattenInfo.namesNeededForFlattening'
348 -- generate an application of `fst' (EXPORTED)
350 mk'fst :: Type -> Type -> CoreExpr -> Flatten CoreExpr
351 mk'fst ty1 ty2 a = mkFunApp fstName [Type ty1, Type ty2, a]
353 -- generate an application of `&&' (EXPORTED)
355 mk'and :: CoreExpr -> CoreExpr -> Flatten CoreExpr
356 mk'and a1 a2 = mkFunApp andName [a1, a2]
358 -- generate an application of `||' (EXPORTED)
360 mk'or :: CoreExpr -> CoreExpr -> Flatten CoreExpr
361 mk'or a1 a2 = mkFunApp orName [a1, a2]
363 -- generate an application of `==' where the arguments may only be literals
364 -- that may occur in a Core case expression (i.e., `Char', `Int', `Float', and
365 -- `Double') (EXPORTED)
367 mk'eq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
368 mk'eq ty a1 a2 = mkFunApp eqName [a1, a2]
370 name = tyConName . tyConAppTyCon $ ty
372 eqName | name == charPrimTyConName = eqCharName
373 | name == intPrimTyConName = eqIntName
374 | name == floatPrimTyConName = eqFloatName
375 | name == doublePrimTyConName = eqDoubleName
377 pprPanic "FlattenMonad.mk'eq: " (ppr ty)
379 -- generate an application of `==' where the arguments may only be literals
380 -- that may occur in a Core case expression (i.e., `Char', `Int', `Float', and
381 -- `Double') (EXPORTED)
383 mk'neq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
384 mk'neq ty a1 a2 = mkFunApp neqName [a1, a2]
386 name = tyConName . tyConAppTyCon $ ty
388 neqName {- | name == charPrimTyConName = neqCharName -}
389 | name == intPrimTyConName = neqIntName
390 {- | name == floatPrimTyConName = neqFloatName -}
391 {- | name == doublePrimTyConName = neqDoubleName -}
393 pprPanic "FlattenMonad.mk'neq: " (ppr ty)
395 -- generate an application of `lengthP' (EXPORTED)
397 mk'lengthP :: Type -> CoreExpr -> Flatten CoreExpr
398 mk'lengthP ty a = mkFunApp lengthPName [Type ty, a]
400 -- generate an application of `replicateP' (EXPORTED)
402 mk'replicateP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
403 mk'replicateP ty a1 a2 = mkFunApp replicatePName [Type ty, a1, a2]
405 -- generate an application of `replicateP' (EXPORTED)
407 mk'mapP :: Type -> Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
408 mk'mapP ty1 ty2 a1 a2 = mkFunApp mapPName [Type ty1, Type ty2, a1, a2]
410 -- generate an application of `bpermuteP' (EXPORTED)
412 mk'bpermuteP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
413 mk'bpermuteP ty a1 a2 = mkFunApp bpermutePName [Type ty, a1, a2]
415 -- generate an application of `bpermuteDftP' (EXPORTED)
417 mk'bpermuteDftP :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> Flatten CoreExpr
418 mk'bpermuteDftP ty a1 a2 a3 = mkFunApp bpermuteDftPName [Type ty, a1, a2, a3]
420 -- generate an application of `indexOfP' (EXPORTED)
422 mk'indexOfP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
423 mk'indexOfP ty a1 a2 = mkFunApp indexOfPName [Type ty, a1, a2]
426 -- auxilliary functions
427 -- --------------------
429 -- obtain the context variable, aborting if it is not available (as this
430 -- signals an internal error in the usage of the `Flatten' monad)
432 ctxtVarErr :: FlattenState -> Var
433 ctxtVarErr s = case ctxtVar s of
434 Nothing -> panic "FlattenMonad.ctxtVarErr: No context \
435 \variable available!"
438 -- given the name of a known function and a set of arguments (needs to include
439 -- all needed type arguments), build a Core expression that applies the named
440 -- function to those arguments
442 mkFunApp :: Name -> [CoreExpr] -> Flatten CoreExpr
445 fun <- lookupName name
446 return $ mkApps (Var fun) args
448 -- get the `Id' of a known `Name'
450 -- * this can be the `Name' of any function that's visible on the toplevel of
451 -- the current compilation unit
453 lookupName :: Name -> Flatten Id
454 lookupName name = Flatten $ \s ->