3 -- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller
5 -- Vectorisation and lifting
7 --- DESCRIPTION ---------------------------------------------------------------
9 -- This module implements the vectorisation and function lifting
10 -- transformations of the flattening transformation.
12 --- DOCU ----------------------------------------------------------------------
14 -- Language: Haskell 98 with C preprocessor
17 -- the transformation on types has five purposes:
19 -- 1) for each type definition, derive the lifted version of this type
21 -- 2) change the type annotations of functions & variables acc. to rep.
23 -- 3) derive the type of a lifted function
26 -- this is the most fuzzy and complicated part. For each lifted
27 -- sumtype we need to generate function to access and combine the
30 -- NOTE: the type information of variables and data constructors is *not*
31 -- changed to reflect it's representation. This has to be solved
32 -- somehow (???, FIXME) using type indexed types
35 -- is very naive at the moment. One of the most striking inefficiencies is
36 -- application vect (app e1 e2) -> app (fst (vect e1) (vect e2)) if e1 is a
37 -- lambda abstraction. The vectorisation produces a pair consisting of the
38 -- original and the lifted function, but the lifted version is discarded.
39 -- I'm also not sure how much of this would be thrown out by the simplifier
46 --- TODO ----------------------------------------------------------------------
48 -- * look closer into the definition of type definition (TypeThing or so)
55 #include "HsVersions.h"
58 import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault,
59 isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
60 import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
61 liftVar, liftConst, intersectWithContext, mk'fst,
62 mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP,
63 mk'indexOfP,mk'eq,mk'neq)
66 import CmdLineOpts (opt_Flatten)
68 import ErrUtils (dumpIfSet_dyn)
69 import UniqSupply (mkSplitUniqSupply)
70 import CmdLineOpts (DynFlag(..))
71 import Literal (Literal, literalType)
73 import DataCon (DataCon, dataConTag)
74 import TypeRep (Type(..))
75 import Type (isTypeKind)
76 import HscTypes (PersistentCompilerState, ModGuts(..),
78 import CoreFVs (exprFreeVars)
79 import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
80 CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
82 import PprCore (pprCoreExpr)
83 import CoreLint (showPass, endPass)
85 import CoreUtils (exprType, applyTypeToArg, mkPiType)
86 import VarEnv (zipVarEnv)
87 import TysWiredIn (mkTupleTy)
88 import BasicTypes (Boxity(..))
93 -- FIXME: fro debugging - remove this
97 import Monad (liftM, foldM)
99 -- toplevel transformation
100 -- -----------------------
102 -- entry point to the flattening transformation for the compiler driver when
103 -- compiling a complete module (EXPORTED)
106 -> PersistentCompilerState
109 flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds})
110 | not opt_Flatten = return mod_impl -- skip without -fflatten
113 let dflags = hsc_dflags hsc_env
115 us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
117 -- announce vectorisation
119 showPass dflags "Flattening [first phase: vectorisation]"
121 -- vectorise all toplevel bindings
123 let binds' = runFlatten hsc_env pcs us $ vectoriseTopLevelBinds binds
125 -- and dump the result if requested
127 endPass dflags "Flattening [first phase: vectorisation]"
128 Opt_D_dump_vect binds'
129 return $ mod_impl {mg_binds = binds'}
131 -- entry point to the flattening transformation for the compiler driver when
132 -- compiling a single expression in interactive mode (EXPORTED)
134 flattenExpr :: HscEnv
135 -> PersistentCompilerState
136 -> CoreExpr -- the expression to be flattened
138 flattenExpr hsc_env pcs expr
139 | not opt_Flatten = return expr -- skip without -fflatten
142 let dflags = hsc_dflags hsc_env
144 us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
146 -- announce vectorisation
148 showPass dflags "Flattening [first phase: vectorisation]"
150 -- vectorise the expression
152 let expr' = fst . runFlatten hsc_env pcs us $ vectorise expr
154 -- and dump the result if requested
156 dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression"
161 -- vectorisation of bindings and expressions
162 -- -----------------------------------------
165 vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind]
166 vectoriseTopLevelBinds binds =
168 vbinds <- mapM vectoriseBind binds
169 return (adjustTypeBinds vbinds)
171 adjustTypeBinds:: [CoreBind] -> [CoreBind]
172 adjustTypeBinds vbinds =
174 ids = concat (map extIds vbinds)
175 idEnv = zipVarEnv ids ids
176 in map (substIdEnvBind idEnv) vbinds
178 -- FIXME replace by 'bindersOf'
179 extIds (NonRec b expr) = [b]
180 extIds (Rec bnds) = map fst bnds
181 substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr)
182 substIdEnvBind idEnv (Rec bnds)
183 = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds)
185 -- vectorise a single core binder
187 vectoriseBind :: CoreBind -> Flatten CoreBind
188 vectoriseBind (NonRec b expr) =
189 liftM (NonRec b) $ liftM fst $ vectorise expr
190 vectoriseBind (Rec bindings) =
191 liftM Rec $ mapM vectoriseOne bindings
193 vectoriseOne (b, expr) =
195 (vexpr, ty) <- vectorise expr
196 return (b{varType = ty}, vexpr)
199 -- Searches for function definitions and creates a lifted version for
201 -- We have only two interesting cases:
202 -- 1) function application (ex1) (ex2)
203 -- vectorise both subexpressions. The function will end up becoming a
204 -- pair (orig. fun, lifted fun), choose first component (in many cases,
205 -- this is pretty inefficient, since the lifted version is generated
206 -- although it is clear that it won't be used
208 -- 2) lambda abstraction
209 -- any function has to exist in two forms: it's original form and it's
210 -- lifted form. Therefore, every lambda abstraction is transformed into
211 -- a pair of functions: the original function and its lifted variant
214 -- FIXME: currently, I use 'exprType' all over the place - this is terribly
215 -- inefficient. It should be suffiecient to change 'vectorise' and 'lift' to
216 -- return the type of the result expression as well.
218 vectorise:: CoreExpr -> Flatten (CoreExpr, Type)
221 let varTy = varType id
222 let vecTy = vectoriseTy varTy
223 return ((Var id{varType = vecTy}), vecTy)
225 vectorise (Lit lit) =
226 return ((Lit lit), literalType lit)
229 vectorise e@(App expr t@(Type _)) =
231 (vexpr, vexprTy) <- vectorise expr
232 return ((App vexpr t), applyTypeToArg vexprTy t)
234 vectorise (App (Lam b expr) arg) =
236 (varg, argTy) <- vectorise arg
237 (vexpr, vexprTy) <- vectorise expr
238 let vb = b{varType = argTy}
239 return ((App (Lam vb vexpr) varg),
240 applyTypeToArg (mkPiType vb vexprTy) varg)
242 -- if vexpr expects a type as first argument
243 -- application stays just as it is
245 vectorise (App expr arg) =
247 (vexpr, vexprTy) <- vectorise expr
248 (varg, vargTy) <- vectorise arg
250 if (isPolyType vexprTy)
252 let resTy = applyTypeToArg vexprTy varg
253 return (App vexpr varg, resTy)
255 let [t1, t2] = tupleTyArgs vexprTy
256 vexpr' <- mk'fst t1 t2 vexpr
257 let resTy = applyTypeToArg t1 varg
258 return ((App vexpr' varg), resTy) -- apply the first component of
259 -- the vectorized function
263 (ForAllTy _ _) -> True
264 (NoteTy _ nt) -> isPolyType nt
268 vectorise e@(Lam b expr)
269 | isTypeKind (varType b) =
271 (vexpr, vexprTy) <- vectorise expr -- don't vectorise 'b'!
272 return ((Lam b vexpr), mkPiType b vexprTy)
275 (vexpr, vexprTy) <- vectorise expr
276 let vb = b{varType = vectoriseTy (varType b)}
277 let ve = Lam vb vexpr
278 (lexpr, lexprTy) <- lift e
279 let veTy = mkPiType vb vexprTy
280 return $ (mkTuple [veTy, lexprTy] [ve, lexpr],
281 mkTupleTy Boxed 2 [veTy, lexprTy])
283 vectorise (Let bind body) =
285 vbind <- vectoriseBind bind
286 (vbody, vbodyTy) <- vectorise body
287 return ((Let vbind vbody), vbodyTy)
289 vectorise (Case expr b alts) =
291 (vexpr, vexprTy) <- vectorise expr
292 valts <- mapM vectorise' alts
293 return (Case vexpr b{varType = vexprTy} (map fst valts), snd (head valts))
294 where vectorise' (con, bs, expr) =
296 (vexpr, vexprTy) <- vectorise expr
297 return ((con, bs, vexpr), vexprTy) -- FIXME: change type of con
302 vectorise (Note note expr) =
304 (vexpr, vexprTy) <- vectorise expr -- FIXME: is this ok or does it
305 return ((Note note vexpr), vexprTy) -- change the validity of note?
307 vectorise e@(Type t) =
308 return (e, t) -- FIXME: panic instead of 't'???
312 myShowTy (TyVarTy _) = "TyVar "
313 myShowTy (AppTy t1 t2) =
314 "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
315 myShowTy (TyConApp _ t) =
316 "TyConApp TC (" ++ (myShowTy t) ++ ")"
319 vectoriseTy :: Type -> Type
320 vectoriseTy t@(TyVarTy v) = t
321 vectoriseTy t@(AppTy t1 t2) =
322 AppTy (vectoriseTy t1) (vectoriseTy t2)
323 vectoriseTy t@(TyConApp tc ts) =
324 TyConApp tc (map vectoriseTy ts)
325 vectoriseTy t@(FunTy t1 t2) =
326 mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)),
328 vectoriseTy t@(ForAllTy v ty) =
329 ForAllTy v (vectoriseTy ty)
330 vectoriseTy t@(NoteTy note ty) = -- FIXME: is the note still valid after
331 NoteTy note (vectoriseTy ty) -- this or should we just throw it away
335 -- liftTy: wrap the type in an array but be careful with function types
336 -- on the *top level* (is this sufficient???)
338 liftTy:: Type -> Type
339 liftTy (FunTy t1 t2) = FunTy (liftTy t1) (liftTy t2)
340 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
341 liftTy (NoteTy n t) = NoteTy n $ liftTy t
342 liftTy t = mkPArrTy t
351 -- liftBinderType: Converts a type 'a' stored in the binder to the
352 -- representation of '[:a:]' will therefore call liftType
354 -- lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
355 -- but I'm not entirely sure about some fields (e.g., strictness info)
356 liftBinderType:: CoreBndr -> Flatten CoreBndr
357 liftBinderType bndr = return $ bndr {varType = liftTy (varType bndr)}
359 -- lift: lifts an expression (a -> [:a:])
360 -- If the expression is a simple expression, it is treated like a constant
362 -- If the body of a lambda expression is a simple expression, it is
363 -- transformed into a mapP
364 lift:: CoreExpr -> Flatten (CoreExpr, Type)
365 lift cExpr@(Var id) =
367 lVar@(Var lId) <- liftVar id
368 return (lVar, varType lId)
370 lift cExpr@(Lit lit) =
372 lLit <- liftConst cExpr
373 return (lLit, exprType lLit)
377 | isSimpleExpr expr = liftSimpleFun b expr
378 | isTypeKind (varType b) =
380 (lexpr, lexprTy) <- lift expr -- don't lift b!
381 return (Lam b lexpr, mkPiType b lexprTy)
384 lb <- liftBinderType b
385 (lexpr, lexprTy) <- extendContext [lb] (lift expr)
386 return ((Lam lb lexpr) , mkPiType lb lexprTy)
388 lift (App expr1 expr2) =
390 (lexpr1, lexpr1Ty) <- lift expr1
391 (lexpr2, _) <- lift expr2
392 return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2)
395 lift (Let (NonRec b expr1) expr2)
396 |isSimpleExpr expr2 =
398 (lexpr1, _) <- lift expr1
399 (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2
400 let (t1, t2) = funTyArgs lexpr2Ty
401 liftM (\x -> (x, liftTy t2)) $ mk'mapP t1 t2 lexpr2 lexpr1
405 (lexpr1, _) <- lift expr1
406 lb <- liftBinderType b
407 (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1)
408 return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty)
410 lift (Let (Rec binds) expr2) =
412 let (bndVars, exprs) = unzip binds
413 lBndVars <- mapM liftBinderType bndVars
414 lexprs <- extendContext bndVars (mapM lift exprs)
415 (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2)
416 return ((Let (Rec (zip lBndVars (map fst lexprs))) lexpr2), lexpr2Ty)
419 -- Assumption: alternatives can either be literals or data construtors.
420 -- Due to type restrictions, I don't think it is possible
421 -- that they are mixed.
422 -- The handling of literals and data constructors is completely
426 -- let b = expr in alts
428 -- I think I read somewhere that the default case (if present) is stored
429 -- in the head of the list. Assume for now this is true, have to check
432 -- (2) data constructors
434 -- FIXME: optimisation: first, filter out all simple expression and
435 -- loop (mapP & filter) over all the corresponding values in a single
438 -- (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr])
439 -- simple alts reg alts
440 -- (2) if simpleAlts = [] then (just as before)
441 -- if regAlts = [] then (the whole thing is just a loop)
442 -- otherwise (a) compute index vector for simpleAlts (for def permute
445 lift cExpr@(Case expr b alts) =
447 (lExpr, _) <- lift expr
448 lb <- liftBinderType b -- lift alt-expression
449 lalts <- if isLit alts
450 then extendContext [lb] (liftCaseLit b alts)
451 else extendContext [lb] (liftCaseDataCon b alts)
452 letWrapper lExpr b lalts
454 lift (Note (Coerce t1 t2) expr) =
456 (lexpr, t) <- lift expr
458 return ((Note (Coerce lt1 (liftTy t2)) lexpr), lt1)
460 lift (Note note expr) =
462 (lexpr, t) <- lift expr
463 return ((Note note lexpr), t)
465 lift e@(Type t) = return (e, t)
468 -- auxilliary functions for lifting of case statements
471 liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] ->
472 Flatten (([CoreBind], [CoreBind], [CoreBind]))
473 liftCaseDataCon b [] =
475 liftCaseDataCon b alls@(alt:alts)
478 (i, e, defAltBndrs) <- liftCaseDataConDefault b alt alts
479 (is, es, altBndrs) <- liftCaseDataCon' b alts
480 return (i:is, e:es, defAltBndrs ++ altBndrs)
482 liftCaseDataCon' b alls
484 liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->
485 Flatten ([CoreBind], [CoreBind], [CoreBind])
486 liftCaseDataCon' _ [] =
491 liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
493 (permBnd, exprBnd, packBnd) <- liftSingleDataCon b dcon bnds expr
494 (permBnds, exprBnds, packBnds) <- liftCaseDataCon' b alts
495 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
498 -- FIXME: is is really necessary to return the binding to the permutation
499 -- array in the data constructor case, as the representation already
500 -- contains the extended flag vector
501 liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
502 Flatten (CoreBind, CoreBind, [CoreBind])
503 liftSingleDataCon b dcon bnds expr =
505 let dconId = dataConTag dcon
506 indexExpr <- mkIndexOfExprDCon (varType b) b dconId
507 (bb, bbind) <- mkBind FSLIT("is") indexExpr
508 lbnds <- mapM liftBinderType bnds
509 ((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr))
510 (_, vbind) <- mkBind FSLIT("r") lExpr
511 return (bbind, vbind, bnds')
513 -- FIXME: clean this up. the datacon and the literal case are so
514 -- similar that it would be easy to use the same function here
515 -- instead of duplicating all the code.
517 liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
518 -> Flatten (CoreBind, CoreBind, [CoreBind])
519 liftCaseDataConDefault b (_, _, def) alts =
521 let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts
522 indexExpr <- mkIndexOfExprDConDft (varType b) b dconIds
523 (bb, bbind) <- mkBind FSLIT("is") indexExpr
524 ((lDef, _), bnds) <- packContext bb (lift def)
525 (_, vbind) <- mkBind FSLIT("r") lDef
526 return (bbind, vbind, bnds)
528 -- liftCaseLit: checks if we have a default case and handles it
530 liftCaseLit:: CoreBndr -> [Alt CoreBndr] ->
531 Flatten ([CoreBind], [CoreBind], [CoreBind])
533 return ([], [], []) --FIXME: a case with no cases at all???
534 liftCaseLit b alls@(alt:alts)
537 (i, e, defAltBndrs) <- liftCaseLitDefault b alt alts
538 (is, es, altBndrs) <- liftCaseLit' b alts
539 return (i:is, e:es, defAltBndrs ++ altBndrs)
544 -- liftCaseLitDefault: looks at all the other alternatives which
545 -- contain a literal and filters all those elements from the
546 -- array which do not match any of the literals in the other
548 liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
549 -> Flatten (CoreBind, CoreBind, [CoreBind])
550 liftCaseLitDefault b (_, _, def) alts =
552 let lits = map (\(LitAlt l, _, _) -> l) alts
553 indexExpr <- mkIndexOfExprDft (varType b) b lits
554 (bb, bbind) <- mkBind FSLIT("is") indexExpr
555 ((lDef, _), bnds) <- packContext bb (lift def)
556 (_, vbind) <- mkBind FSLIT("r") lDef
557 return (bbind, vbind, bnds)
560 -- Assumption: in case of Lit, the list of binders of the alt is empty.
563 -- a list of all vars bound to the expr in the body of the alternative
564 -- a list of (var, expr) pairs, where var has to be bound to expr
566 liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->
567 Flatten ([CoreBind], [CoreBind], [CoreBind])
571 liftCaseLit' b ((LitAlt lit, [], expr):alts) =
573 (permBnd, exprBnd, packBnd) <- liftSingleCaseLit b lit expr
574 (permBnds, exprBnds, packBnds) <- liftCaseLit' b alts
575 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
577 -- lift a single alternative of the form: case b of lit -> expr.
579 -- It returns the bindings:
580 -- (a) let b' = indexOfP (mapP (\x -> x == lit) b)
582 -- (b) lift expr in the packed context. Returns lexpr and the
583 -- list of binds (bnds) that describe the packed arrays
585 -- (c) create new var v' to bind lexpr to
587 -- (d) return (b' = indexOf...., v' = lexpr, bnds)
588 liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr ->
589 Flatten (CoreBind, CoreBind, [CoreBind])
590 liftSingleCaseLit b lit expr =
592 indexExpr <- mkIndexOfExpr (varType b) b lit -- (a)
593 (bb, bbind) <- mkBind FSLIT("is") indexExpr
594 ((lExpr, t), bnds) <- packContext bb (lift expr) -- (b)
595 (_, vbind) <- mkBind FSLIT("r") lExpr
596 return (bbind, vbind, bnds)
598 -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
601 -- let index_bnd_1 in
604 -- let exprbnd_1 in ....
606 -- let nvar = replicate dummy (length <current context>)
607 -- nvar1 = bpermuteDftP index_bnd_1 ...
609 -- in bpermuteDftP index_bnd_n nvar_(n-1)
611 letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
612 Flatten (CoreExpr, Type)
613 letWrapper lExpr b (indBnds, exprBnds, pckBnds) =
615 (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
616 let resExpr = getExprOfBind (head defBpBnds)
617 return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
619 -- dftbpBinders: return the list of binders necessary to construct the overall
620 -- result from the subresults computed in the different branches of the case
621 -- statement. The binding which contains the final result is in the *head*
622 -- of the result list.
624 -- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
626 -- let def = replicate (length of context) undefined
627 -- d1 = bpermuteDftP dft e1 i1
630 dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
631 dftbpBinders indexBnds exprBnds =
633 let expr = getExprOfBind (head exprBnds)
634 defVecExpr <- createDftArrayBind expr
635 ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
638 dftbpBinders' :: [CoreBind]
641 -> Flatten ((CoreBind, [CoreBind]), Type)
642 dftbpBinders' [] [] cBnd =
643 return ((cBnd, []), panic "dftbpBinders: undefined type")
644 dftbpBinders' (i:is) (e:es) cBind =
646 let iVar = getVarOfBind i
647 let eVar = getVarOfBind e
648 let cVar = getVarOfBind cBind
649 let ty = varType eVar
650 newBnd <- mkDftBackpermute ty iVar eVar cVar
651 ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
652 return ((fBnd, (newBnd:restBnds)), liftTy ty)
654 dftbpBinders' _ _ _ =
655 panic "Flattening.dftbpBinders: index and expression binder lists \
656 \have different length!"
658 getExprOfBind:: CoreBind -> CoreExpr
659 getExprOfBind (NonRec _ expr) = expr
661 getVarOfBind:: CoreBind -> Var
662 getVarOfBind (NonRec b _) = b
666 -- Optimised Transformation
667 -- =========================
671 -- if variables x_1 to x_i occur in the context *and* free in expr
673 -- (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn)
675 liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type)
676 liftSimpleFun b expr =
678 bndVars <- collectBoundVars expr
679 let bndVars' = b:bndVars
680 bndVarsTuple = mkTuple (map varType bndVars') (map Var bndVars')
681 lamExpr = mkLams (b:bndVars) expr -- FIXME: should be tuple
683 let (t1, t2) = funTyArgs . exprType $ lamExpr
684 mapExpr <- mk'mapP t1 t2 lamExpr bndVarsTuple
685 let lexpr = mkApps mapExpr [bndVarsTuple]
686 return (lexpr, undefined) -- FIXME!!!!!
689 collectBoundVars:: CoreExpr -> Flatten [CoreBndr]
690 collectBoundVars expr =
691 intersectWithContext (exprFreeVars expr)
694 -- auxilliary routines
695 -- -------------------
697 -- mkIndexOfExpr b lit ->
698 -- indexOf (mapP (\x -> x == lit) b) b
700 mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
701 mkIndexOfExpr varType b lit =
703 eqExpr <- mk'eq varType (Var b) (Lit lit)
704 let lambdaExpr = (Lam b eqExpr)
705 mk'indexOfP varType lambdaExpr (Var b)
707 -- there is FlattenMonad.mk'indexOfP as well as
708 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
710 -- for case-distinction over data constructors:
714 -- dconId = dataConTag dcon
715 -- the call "mkIndexOfExprDCon b dconId" computes the core expression for
716 -- indexOfP (\x -> x == dconId) b)
718 mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr
719 mkIndexOfExprDCon varType b dId =
721 let intExpr = mkIntLitInt dId
722 eqExpr <- mk'eq varType (Var b) intExpr
723 let lambdaExpr = (Lam b intExpr)
724 mk'indexOfP varType lambdaExpr (Var b)
728 -- there is FlattenMonad.mk'indexOfP as well as
729 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
731 -- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the
732 -- default case. "dconIds" is a list of all the data constructor idents which
733 -- are covered by the other cases.
734 -- indexOfP (\x -> x != dconId_1 && ....) b)
736 mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
737 mkIndexOfExprDConDft varType b dId =
739 let intExprs = map mkIntLitInt dId
740 bExpr <- foldM (mk'neq varType) (head intExprs) (tail intExprs)
741 let lambdaExpr = (Lam b bExpr)
742 mk'indexOfP varType (Var b) bExpr
745 -- mkIndexOfExprDef b [lit1, lit2,...] ->
746 -- indexOf (\x -> not (x == lit1 || x == lit2 ....) b
747 mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
748 mkIndexOfExprDft varType b lits =
750 let litExprs = map (\l-> Lit l) lits
751 bExpr <- foldM (mk'neq varType) (head litExprs) (tail litExprs)
752 let lambdaExpr = (Lam b bExpr)
753 mk'indexOfP varType bExpr (Var b)
756 -- create a back-permute binder
758 -- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
759 -- Core binding of the form
761 -- x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
763 -- where `x' is a new local variable
765 mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind
766 mkDftBackpermute ty idx src dft =
768 rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft)
769 liftM snd $ mkBind FSLIT("dbp") rhs
771 -- create a dummy array with elements of the given type, which can be used as
772 -- default array for the combination of the subresults of the lifted case
775 createDftArrayBind :: CoreExpr -> Flatten CoreBind
776 createDftArrayBind e =
777 panic "Flattening.createDftArrayBind: not implemented yet"
780 let ty = parrElemTy . exprType $ expr
782 rhs <- mk'replicateP ty len err??
783 lift snd $ mkBind FSLIT("dft") rhs
784 FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde
785 beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen
786 generischen Wert f"ur jeden beliebigen Typ zu erfinden.
792 -- show functions (the pretty print functions sometimes don't
793 -- show it the way I want....
795 -- shows just the structure
796 showCoreExpr (Var _ ) = "Var "
797 showCoreExpr (Lit _) = "Lit "
798 showCoreExpr (App e1 e2) =
799 "(App \n " ++ (showCoreExpr e1) ++ "\n " ++ (showCoreExpr e2) ++ ") "
800 showCoreExpr (Lam b e) =
801 "Lam b " ++ (showCoreExpr e)
802 showCoreExpr (Let bnds expr) =
803 "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr)
804 where showBinds (NonRec b e) = showBind (b,e)
805 showBinds (Rec bnds) = concat (map showBind bnds)
806 showBind (b,e) = " b = " ++ (showCoreExpr e)++ "\n"
807 showCoreExpr (Case ex b alts) =
808 "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
809 where showAlts _ = ""
810 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
811 showCoreExpr (Type t) = "Type"