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 ( ModGuts(..), ModGuts, HscEnv(..), hscEPS )
77 import CoreFVs (exprFreeVars)
78 import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
79 CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
81 import PprCore (pprCoreExpr)
82 import CoreLint (showPass, endPass)
84 import CoreUtils (exprType, applyTypeToArg, mkPiType)
85 import VarEnv (zipVarEnv)
86 import TysWiredIn (mkTupleTy)
87 import BasicTypes (Boxity(..))
92 -- FIXME: fro debugging - remove this
96 import Monad (liftM, foldM)
98 -- toplevel transformation
99 -- -----------------------
101 -- entry point to the flattening transformation for the compiler driver when
102 -- compiling a complete module (EXPORTED)
107 flatten hsc_env mod_impl@(ModGuts {mg_binds = binds})
108 | not opt_Flatten = return mod_impl -- skip without -fflatten
111 let dflags = hsc_dflags hsc_env
113 eps <- hscEPS hsc_env
114 us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
116 -- announce vectorisation
118 showPass dflags "Flattening [first phase: vectorisation]"
120 -- vectorise all toplevel bindings
122 let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds
124 -- and dump the result if requested
126 endPass dflags "Flattening [first phase: vectorisation]"
127 Opt_D_dump_vect binds'
128 return $ mod_impl {mg_binds = binds'}
130 -- entry point to the flattening transformation for the compiler driver when
131 -- compiling a single expression in interactive mode (EXPORTED)
133 flattenExpr :: HscEnv
134 -> CoreExpr -- the expression to be flattened
136 flattenExpr hsc_env expr
137 | not opt_Flatten = return expr -- skip without -fflatten
140 let dflags = hsc_dflags hsc_env
141 eps <- hscEPS hsc_env
143 us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
145 -- announce vectorisation
147 showPass dflags "Flattening [first phase: vectorisation]"
149 -- vectorise the expression
151 let expr' = fst . runFlatten hsc_env eps us $ vectorise expr
153 -- and dump the result if requested
155 dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression"
160 -- vectorisation of bindings and expressions
161 -- -----------------------------------------
164 vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind]
165 vectoriseTopLevelBinds binds =
167 vbinds <- mapM vectoriseBind binds
168 return (adjustTypeBinds vbinds)
170 adjustTypeBinds:: [CoreBind] -> [CoreBind]
171 adjustTypeBinds vbinds =
173 ids = concat (map extIds vbinds)
174 idEnv = zipVarEnv ids ids
175 in map (substIdEnvBind idEnv) vbinds
177 -- FIXME replace by 'bindersOf'
178 extIds (NonRec b expr) = [b]
179 extIds (Rec bnds) = map fst bnds
180 substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr)
181 substIdEnvBind idEnv (Rec bnds)
182 = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds)
184 -- vectorise a single core binder
186 vectoriseBind :: CoreBind -> Flatten CoreBind
187 vectoriseBind (NonRec b expr) =
188 liftM (NonRec b) $ liftM fst $ vectorise expr
189 vectoriseBind (Rec bindings) =
190 liftM Rec $ mapM vectoriseOne bindings
192 vectoriseOne (b, expr) =
194 (vexpr, ty) <- vectorise expr
195 return (b{varType = ty}, vexpr)
198 -- Searches for function definitions and creates a lifted version for
200 -- We have only two interesting cases:
201 -- 1) function application (ex1) (ex2)
202 -- vectorise both subexpressions. The function will end up becoming a
203 -- pair (orig. fun, lifted fun), choose first component (in many cases,
204 -- this is pretty inefficient, since the lifted version is generated
205 -- although it is clear that it won't be used
207 -- 2) lambda abstraction
208 -- any function has to exist in two forms: it's original form and it's
209 -- lifted form. Therefore, every lambda abstraction is transformed into
210 -- a pair of functions: the original function and its lifted variant
213 -- FIXME: currently, I use 'exprType' all over the place - this is terribly
214 -- inefficient. It should be suffiecient to change 'vectorise' and 'lift' to
215 -- return the type of the result expression as well.
217 vectorise:: CoreExpr -> Flatten (CoreExpr, Type)
220 let varTy = varType id
221 let vecTy = vectoriseTy varTy
222 return ((Var id{varType = vecTy}), vecTy)
224 vectorise (Lit lit) =
225 return ((Lit lit), literalType lit)
228 vectorise e@(App expr t@(Type _)) =
230 (vexpr, vexprTy) <- vectorise expr
231 return ((App vexpr t), applyTypeToArg vexprTy t)
233 vectorise (App (Lam b expr) arg) =
235 (varg, argTy) <- vectorise arg
236 (vexpr, vexprTy) <- vectorise expr
237 let vb = b{varType = argTy}
238 return ((App (Lam vb vexpr) varg),
239 applyTypeToArg (mkPiType vb vexprTy) varg)
241 -- if vexpr expects a type as first argument
242 -- application stays just as it is
244 vectorise (App expr arg) =
246 (vexpr, vexprTy) <- vectorise expr
247 (varg, vargTy) <- vectorise arg
249 if (isPolyType vexprTy)
251 let resTy = applyTypeToArg vexprTy varg
252 return (App vexpr varg, resTy)
254 let [t1, t2] = tupleTyArgs vexprTy
255 vexpr' <- mk'fst t1 t2 vexpr
256 let resTy = applyTypeToArg t1 varg
257 return ((App vexpr' varg), resTy) -- apply the first component of
258 -- the vectorized function
262 (ForAllTy _ _) -> True
263 (NoteTy _ nt) -> isPolyType nt
267 vectorise e@(Lam b expr)
268 | isTypeKind (varType b) =
270 (vexpr, vexprTy) <- vectorise expr -- don't vectorise 'b'!
271 return ((Lam b vexpr), mkPiType b vexprTy)
274 (vexpr, vexprTy) <- vectorise expr
275 let vb = b{varType = vectoriseTy (varType b)}
276 let ve = Lam vb vexpr
277 (lexpr, lexprTy) <- lift e
278 let veTy = mkPiType vb vexprTy
279 return $ (mkTuple [veTy, lexprTy] [ve, lexpr],
280 mkTupleTy Boxed 2 [veTy, lexprTy])
282 vectorise (Let bind body) =
284 vbind <- vectoriseBind bind
285 (vbody, vbodyTy) <- vectorise body
286 return ((Let vbind vbody), vbodyTy)
288 vectorise (Case expr b alts) =
290 (vexpr, vexprTy) <- vectorise expr
291 valts <- mapM vectorise' alts
292 return (Case vexpr b{varType = vexprTy} (map fst valts), snd (head valts))
293 where vectorise' (con, bs, expr) =
295 (vexpr, vexprTy) <- vectorise expr
296 return ((con, bs, vexpr), vexprTy) -- FIXME: change type of con
301 vectorise (Note note expr) =
303 (vexpr, vexprTy) <- vectorise expr -- FIXME: is this ok or does it
304 return ((Note note vexpr), vexprTy) -- change the validity of note?
306 vectorise e@(Type t) =
307 return (e, t) -- FIXME: panic instead of 't'???
311 myShowTy (TyVarTy _) = "TyVar "
312 myShowTy (AppTy t1 t2) =
313 "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
314 myShowTy (TyConApp _ t) =
315 "TyConApp TC (" ++ (myShowTy t) ++ ")"
318 vectoriseTy :: Type -> Type
319 vectoriseTy t@(TyVarTy v) = t
320 vectoriseTy t@(AppTy t1 t2) =
321 AppTy (vectoriseTy t1) (vectoriseTy t2)
322 vectoriseTy t@(TyConApp tc ts) =
323 TyConApp tc (map vectoriseTy ts)
324 vectoriseTy t@(FunTy t1 t2) =
325 mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)),
327 vectoriseTy t@(ForAllTy v ty) =
328 ForAllTy v (vectoriseTy ty)
329 vectoriseTy t@(NoteTy note ty) = -- FIXME: is the note still valid after
330 NoteTy note (vectoriseTy ty) -- this or should we just throw it away
334 -- liftTy: wrap the type in an array but be careful with function types
335 -- on the *top level* (is this sufficient???)
337 liftTy:: Type -> Type
338 liftTy (FunTy t1 t2) = FunTy (liftTy t1) (liftTy t2)
339 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
340 liftTy (NoteTy n t) = NoteTy n $ liftTy t
341 liftTy t = mkPArrTy t
350 -- liftBinderType: Converts a type 'a' stored in the binder to the
351 -- representation of '[:a:]' will therefore call liftType
353 -- lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
354 -- but I'm not entirely sure about some fields (e.g., strictness info)
355 liftBinderType:: CoreBndr -> Flatten CoreBndr
356 liftBinderType bndr = return $ bndr {varType = liftTy (varType bndr)}
358 -- lift: lifts an expression (a -> [:a:])
359 -- If the expression is a simple expression, it is treated like a constant
361 -- If the body of a lambda expression is a simple expression, it is
362 -- transformed into a mapP
363 lift:: CoreExpr -> Flatten (CoreExpr, Type)
364 lift cExpr@(Var id) =
366 lVar@(Var lId) <- liftVar id
367 return (lVar, varType lId)
369 lift cExpr@(Lit lit) =
371 lLit <- liftConst cExpr
372 return (lLit, exprType lLit)
376 | isSimpleExpr expr = liftSimpleFun b expr
377 | isTypeKind (varType b) =
379 (lexpr, lexprTy) <- lift expr -- don't lift b!
380 return (Lam b lexpr, mkPiType b lexprTy)
383 lb <- liftBinderType b
384 (lexpr, lexprTy) <- extendContext [lb] (lift expr)
385 return ((Lam lb lexpr) , mkPiType lb lexprTy)
387 lift (App expr1 expr2) =
389 (lexpr1, lexpr1Ty) <- lift expr1
390 (lexpr2, _) <- lift expr2
391 return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2)
394 lift (Let (NonRec b expr1) expr2)
395 |isSimpleExpr expr2 =
397 (lexpr1, _) <- lift expr1
398 (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2
399 let (t1, t2) = funTyArgs lexpr2Ty
400 liftM (\x -> (x, liftTy t2)) $ mk'mapP t1 t2 lexpr2 lexpr1
404 (lexpr1, _) <- lift expr1
405 lb <- liftBinderType b
406 (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1)
407 return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty)
409 lift (Let (Rec binds) expr2) =
411 let (bndVars, exprs) = unzip binds
412 lBndVars <- mapM liftBinderType bndVars
413 lexprs <- extendContext bndVars (mapM lift exprs)
414 (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2)
415 return ((Let (Rec (zip lBndVars (map fst lexprs))) lexpr2), lexpr2Ty)
418 -- Assumption: alternatives can either be literals or data construtors.
419 -- Due to type restrictions, I don't think it is possible
420 -- that they are mixed.
421 -- The handling of literals and data constructors is completely
425 -- let b = expr in alts
427 -- I think I read somewhere that the default case (if present) is stored
428 -- in the head of the list. Assume for now this is true, have to check
431 -- (2) data constructors
433 -- FIXME: optimisation: first, filter out all simple expression and
434 -- loop (mapP & filter) over all the corresponding values in a single
437 -- (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr])
438 -- simple alts reg alts
439 -- (2) if simpleAlts = [] then (just as before)
440 -- if regAlts = [] then (the whole thing is just a loop)
441 -- otherwise (a) compute index vector for simpleAlts (for def permute
444 lift cExpr@(Case expr b alts) =
446 (lExpr, _) <- lift expr
447 lb <- liftBinderType b -- lift alt-expression
448 lalts <- if isLit alts
449 then extendContext [lb] (liftCaseLit b alts)
450 else extendContext [lb] (liftCaseDataCon b alts)
451 letWrapper lExpr b lalts
453 lift (Note (Coerce t1 t2) expr) =
455 (lexpr, t) <- lift expr
457 return ((Note (Coerce lt1 (liftTy t2)) lexpr), lt1)
459 lift (Note note expr) =
461 (lexpr, t) <- lift expr
462 return ((Note note lexpr), t)
464 lift e@(Type t) = return (e, t)
467 -- auxilliary functions for lifting of case statements
470 liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] ->
471 Flatten (([CoreBind], [CoreBind], [CoreBind]))
472 liftCaseDataCon b [] =
474 liftCaseDataCon b alls@(alt:alts)
477 (i, e, defAltBndrs) <- liftCaseDataConDefault b alt alts
478 (is, es, altBndrs) <- liftCaseDataCon' b alts
479 return (i:is, e:es, defAltBndrs ++ altBndrs)
481 liftCaseDataCon' b alls
483 liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->
484 Flatten ([CoreBind], [CoreBind], [CoreBind])
485 liftCaseDataCon' _ [] =
490 liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
492 (permBnd, exprBnd, packBnd) <- liftSingleDataCon b dcon bnds expr
493 (permBnds, exprBnds, packBnds) <- liftCaseDataCon' b alts
494 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
497 -- FIXME: is is really necessary to return the binding to the permutation
498 -- array in the data constructor case, as the representation already
499 -- contains the extended flag vector
500 liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
501 Flatten (CoreBind, CoreBind, [CoreBind])
502 liftSingleDataCon b dcon bnds expr =
504 let dconId = dataConTag dcon
505 indexExpr <- mkIndexOfExprDCon (varType b) b dconId
506 (bb, bbind) <- mkBind FSLIT("is") indexExpr
507 lbnds <- mapM liftBinderType bnds
508 ((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr))
509 (_, vbind) <- mkBind FSLIT("r") lExpr
510 return (bbind, vbind, bnds')
512 -- FIXME: clean this up. the datacon and the literal case are so
513 -- similar that it would be easy to use the same function here
514 -- instead of duplicating all the code.
516 liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
517 -> Flatten (CoreBind, CoreBind, [CoreBind])
518 liftCaseDataConDefault b (_, _, def) alts =
520 let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts
521 indexExpr <- mkIndexOfExprDConDft (varType b) b dconIds
522 (bb, bbind) <- mkBind FSLIT("is") indexExpr
523 ((lDef, _), bnds) <- packContext bb (lift def)
524 (_, vbind) <- mkBind FSLIT("r") lDef
525 return (bbind, vbind, bnds)
527 -- liftCaseLit: checks if we have a default case and handles it
529 liftCaseLit:: CoreBndr -> [Alt CoreBndr] ->
530 Flatten ([CoreBind], [CoreBind], [CoreBind])
532 return ([], [], []) --FIXME: a case with no cases at all???
533 liftCaseLit b alls@(alt:alts)
536 (i, e, defAltBndrs) <- liftCaseLitDefault b alt alts
537 (is, es, altBndrs) <- liftCaseLit' b alts
538 return (i:is, e:es, defAltBndrs ++ altBndrs)
543 -- liftCaseLitDefault: looks at all the other alternatives which
544 -- contain a literal and filters all those elements from the
545 -- array which do not match any of the literals in the other
547 liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
548 -> Flatten (CoreBind, CoreBind, [CoreBind])
549 liftCaseLitDefault b (_, _, def) alts =
551 let lits = map (\(LitAlt l, _, _) -> l) alts
552 indexExpr <- mkIndexOfExprDft (varType b) b lits
553 (bb, bbind) <- mkBind FSLIT("is") indexExpr
554 ((lDef, _), bnds) <- packContext bb (lift def)
555 (_, vbind) <- mkBind FSLIT("r") lDef
556 return (bbind, vbind, bnds)
559 -- Assumption: in case of Lit, the list of binders of the alt is empty.
562 -- a list of all vars bound to the expr in the body of the alternative
563 -- a list of (var, expr) pairs, where var has to be bound to expr
565 liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->
566 Flatten ([CoreBind], [CoreBind], [CoreBind])
570 liftCaseLit' b ((LitAlt lit, [], expr):alts) =
572 (permBnd, exprBnd, packBnd) <- liftSingleCaseLit b lit expr
573 (permBnds, exprBnds, packBnds) <- liftCaseLit' b alts
574 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
576 -- lift a single alternative of the form: case b of lit -> expr.
578 -- It returns the bindings:
579 -- (a) let b' = indexOfP (mapP (\x -> x == lit) b)
581 -- (b) lift expr in the packed context. Returns lexpr and the
582 -- list of binds (bnds) that describe the packed arrays
584 -- (c) create new var v' to bind lexpr to
586 -- (d) return (b' = indexOf...., v' = lexpr, bnds)
587 liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr ->
588 Flatten (CoreBind, CoreBind, [CoreBind])
589 liftSingleCaseLit b lit expr =
591 indexExpr <- mkIndexOfExpr (varType b) b lit -- (a)
592 (bb, bbind) <- mkBind FSLIT("is") indexExpr
593 ((lExpr, t), bnds) <- packContext bb (lift expr) -- (b)
594 (_, vbind) <- mkBind FSLIT("r") lExpr
595 return (bbind, vbind, bnds)
597 -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
600 -- let index_bnd_1 in
603 -- let exprbnd_1 in ....
605 -- let nvar = replicate dummy (length <current context>)
606 -- nvar1 = bpermuteDftP index_bnd_1 ...
608 -- in bpermuteDftP index_bnd_n nvar_(n-1)
610 letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
611 Flatten (CoreExpr, Type)
612 letWrapper lExpr b (indBnds, exprBnds, pckBnds) =
614 (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
615 let resExpr = getExprOfBind (head defBpBnds)
616 return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
618 -- dftbpBinders: return the list of binders necessary to construct the overall
619 -- result from the subresults computed in the different branches of the case
620 -- statement. The binding which contains the final result is in the *head*
621 -- of the result list.
623 -- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
625 -- let def = replicate (length of context) undefined
626 -- d1 = bpermuteDftP dft e1 i1
629 dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
630 dftbpBinders indexBnds exprBnds =
632 let expr = getExprOfBind (head exprBnds)
633 defVecExpr <- createDftArrayBind expr
634 ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
637 dftbpBinders' :: [CoreBind]
640 -> Flatten ((CoreBind, [CoreBind]), Type)
641 dftbpBinders' [] [] cBnd =
642 return ((cBnd, []), panic "dftbpBinders: undefined type")
643 dftbpBinders' (i:is) (e:es) cBind =
645 let iVar = getVarOfBind i
646 let eVar = getVarOfBind e
647 let cVar = getVarOfBind cBind
648 let ty = varType eVar
649 newBnd <- mkDftBackpermute ty iVar eVar cVar
650 ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
651 return ((fBnd, (newBnd:restBnds)), liftTy ty)
653 dftbpBinders' _ _ _ =
654 panic "Flattening.dftbpBinders: index and expression binder lists \
655 \have different length!"
657 getExprOfBind:: CoreBind -> CoreExpr
658 getExprOfBind (NonRec _ expr) = expr
660 getVarOfBind:: CoreBind -> Var
661 getVarOfBind (NonRec b _) = b
665 -- Optimised Transformation
666 -- =========================
670 -- if variables x_1 to x_i occur in the context *and* free in expr
672 -- (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn)
674 liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type)
675 liftSimpleFun b expr =
677 bndVars <- collectBoundVars expr
678 let bndVars' = b:bndVars
679 bndVarsTuple = mkTuple (map varType bndVars') (map Var bndVars')
680 lamExpr = mkLams (b:bndVars) expr -- FIXME: should be tuple
682 let (t1, t2) = funTyArgs . exprType $ lamExpr
683 mapExpr <- mk'mapP t1 t2 lamExpr bndVarsTuple
684 let lexpr = mkApps mapExpr [bndVarsTuple]
685 return (lexpr, undefined) -- FIXME!!!!!
688 collectBoundVars:: CoreExpr -> Flatten [CoreBndr]
689 collectBoundVars expr =
690 intersectWithContext (exprFreeVars expr)
693 -- auxilliary routines
694 -- -------------------
696 -- mkIndexOfExpr b lit ->
697 -- indexOf (mapP (\x -> x == lit) b) b
699 mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
700 mkIndexOfExpr varType b lit =
702 eqExpr <- mk'eq varType (Var b) (Lit lit)
703 let lambdaExpr = (Lam b eqExpr)
704 mk'indexOfP varType lambdaExpr (Var b)
706 -- there is FlattenMonad.mk'indexOfP as well as
707 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
709 -- for case-distinction over data constructors:
713 -- dconId = dataConTag dcon
714 -- the call "mkIndexOfExprDCon b dconId" computes the core expression for
715 -- indexOfP (\x -> x == dconId) b)
717 mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr
718 mkIndexOfExprDCon varType b dId =
720 let intExpr = mkIntLitInt dId
721 eqExpr <- mk'eq varType (Var b) intExpr
722 let lambdaExpr = (Lam b intExpr)
723 mk'indexOfP varType lambdaExpr (Var b)
727 -- there is FlattenMonad.mk'indexOfP as well as
728 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
730 -- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the
731 -- default case. "dconIds" is a list of all the data constructor idents which
732 -- are covered by the other cases.
733 -- indexOfP (\x -> x != dconId_1 && ....) b)
735 mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
736 mkIndexOfExprDConDft varType b dId =
738 let intExprs = map mkIntLitInt dId
739 bExpr <- foldM (mk'neq varType) (head intExprs) (tail intExprs)
740 let lambdaExpr = (Lam b bExpr)
741 mk'indexOfP varType (Var b) bExpr
744 -- mkIndexOfExprDef b [lit1, lit2,...] ->
745 -- indexOf (\x -> not (x == lit1 || x == lit2 ....) b
746 mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
747 mkIndexOfExprDft varType b lits =
749 let litExprs = map (\l-> Lit l) lits
750 bExpr <- foldM (mk'neq varType) (head litExprs) (tail litExprs)
751 let lambdaExpr = (Lam b bExpr)
752 mk'indexOfP varType bExpr (Var b)
755 -- create a back-permute binder
757 -- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
758 -- Core binding of the form
760 -- x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
762 -- where `x' is a new local variable
764 mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind
765 mkDftBackpermute ty idx src dft =
767 rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft)
768 liftM snd $ mkBind FSLIT("dbp") rhs
770 -- create a dummy array with elements of the given type, which can be used as
771 -- default array for the combination of the subresults of the lifted case
774 createDftArrayBind :: CoreExpr -> Flatten CoreBind
775 createDftArrayBind e =
776 panic "Flattening.createDftArrayBind: not implemented yet"
779 let ty = parrElemTy . exprType $ expr
781 rhs <- mk'replicateP ty len err??
782 lift snd $ mkBind FSLIT("dft") rhs
783 FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde
784 beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen
785 generischen Wert f"ur jeden beliebigen Typ zu erfinden.
791 -- show functions (the pretty print functions sometimes don't
792 -- show it the way I want....
794 -- shows just the structure
795 showCoreExpr (Var _ ) = "Var "
796 showCoreExpr (Lit _) = "Lit "
797 showCoreExpr (App e1 e2) =
798 "(App \n " ++ (showCoreExpr e1) ++ "\n " ++ (showCoreExpr e2) ++ ") "
799 showCoreExpr (Lam b e) =
800 "Lam b " ++ (showCoreExpr e)
801 showCoreExpr (Let bnds expr) =
802 "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr)
803 where showBinds (NonRec b e) = showBind (b,e)
804 showBinds (Rec bnds) = concat (map showBind bnds)
805 showBind (b,e) = " b = " ++ (showCoreExpr e)++ "\n"
806 showCoreExpr (Case ex b alts) =
807 "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
808 where showAlts _ = ""
809 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
810 showCoreExpr (Type t) = "Type"