2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
10 -- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller
12 -- Vectorisation and lifting
14 --- DESCRIPTION ---------------------------------------------------------------
16 -- This module implements the vectorisation and function lifting
17 -- transformations of the flattening transformation.
19 --- DOCU ----------------------------------------------------------------------
21 -- Language: Haskell 98 with C preprocessor
24 -- the transformation on types has five purposes:
26 -- 1) for each type definition, derive the lifted version of this type
28 -- 2) change the type annotations of functions & variables acc. to rep.
30 -- 3) derive the type of a lifted function
33 -- this is the most fuzzy and complicated part. For each lifted
34 -- sumtype we need to generate function to access and combine the
37 -- NOTE: the type information of variables and data constructors is *not*
38 -- changed to reflect it's representation. This has to be solved
39 -- somehow (???, FIXME) using type indexed types
42 -- is very naive at the moment. One of the most striking inefficiencies is
43 -- application vect (app e1 e2) -> app (fst (vect e1) (vect e2)) if e1 is a
44 -- lambda abstraction. The vectorisation produces a pair consisting of the
45 -- original and the lifted function, but the lifted version is discarded.
46 -- I'm also not sure how much of this would be thrown out by the simplifier
53 --- TODO ----------------------------------------------------------------------
55 -- * look closer into the definition of type definition (TypeThing or so)
62 #include "HsVersions.h"
65 import NDPCoreUtils (tupleTyArgs, funTyArgs, isDefault,
66 isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
67 import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
68 liftVar, liftConst, intersectWithContext, mk'fst,
69 mk'mapP, mk'bpermuteDftP, mk'indexOfP,mk'eq,mk'neq)
72 import TcType ( tcIsForAllTy, tcView )
73 import TypeRep ( Type(..) )
74 import Coercion ( coercionKind )
75 import StaticFlags (opt_Flatten)
77 import ErrUtils (dumpIfSet_dyn)
78 import UniqSupply (mkSplitUniqSupply)
79 import DynFlags (DynFlag(..))
80 import Literal (Literal, literalType)
81 import Var (Var(..), idType, isTyVar)
83 import DataCon (DataCon, dataConTag)
84 import HscTypes ( ModGuts(..), HscEnv(..), hscEPS )
85 import CoreFVs (exprFreeVars)
86 import CoreSyn (Expr(..), Bind(..), Alt, AltCon(..),
87 CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
89 import PprCore (pprCoreExpr)
90 import CoreLint (showPass, endPass)
92 import CoreUtils (exprType, applyTypeToArg, mkPiType)
93 import VarEnv (zipVarEnv)
94 import TysWiredIn (mkTupleTy)
95 import BasicTypes (Boxity(..))
100 import Monad (liftM, foldM)
102 -- toplevel transformation
103 -- -----------------------
105 -- entry point to the flattening transformation for the compiler driver when
106 -- compiling a complete module (EXPORTED)
111 flatten hsc_env mod_impl@(ModGuts {mg_binds = binds})
112 | not opt_Flatten = return mod_impl -- skip without -fflatten
115 let dflags = hsc_dflags hsc_env
117 eps <- hscEPS hsc_env
118 us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
120 -- announce vectorisation
122 showPass dflags "Flattening [first phase: vectorisation]"
124 -- vectorise all toplevel bindings
126 let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds
128 -- and dump the result if requested
130 endPass dflags "Flattening [first phase: vectorisation]"
131 Opt_D_dump_vect binds'
132 return $ mod_impl {mg_binds = binds'}
134 -- entry point to the flattening transformation for the compiler driver when
135 -- compiling a single expression in interactive mode (EXPORTED)
137 flattenExpr :: HscEnv
138 -> CoreExpr -- the expression to be flattened
140 flattenExpr hsc_env expr
141 | not opt_Flatten = return expr -- skip without -fflatten
144 let dflags = hsc_dflags hsc_env
145 eps <- hscEPS hsc_env
147 us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
149 -- announce vectorisation
151 showPass dflags "Flattening [first phase: vectorisation]"
153 -- vectorise the expression
155 let expr' = fst . runFlatten hsc_env eps us $ vectorise expr
157 -- and dump the result if requested
159 dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression"
164 -- vectorisation of bindings and expressions
165 -- -----------------------------------------
168 vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind]
169 vectoriseTopLevelBinds binds =
171 vbinds <- mapM vectoriseBind binds
172 return (adjustTypeBinds vbinds)
174 adjustTypeBinds:: [CoreBind] -> [CoreBind]
175 adjustTypeBinds vbinds =
177 ids = concat (map extIds vbinds)
178 idEnv = zipVarEnv ids ids
179 in map (substIdEnvBind idEnv) vbinds
181 -- FIXME replace by 'bindersOf'
182 extIds (NonRec b expr) = [b]
183 extIds (Rec bnds) = map fst bnds
184 substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr)
185 substIdEnvBind idEnv (Rec bnds)
186 = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds)
188 -- vectorise a single core binder
190 vectoriseBind :: CoreBind -> Flatten CoreBind
191 vectoriseBind (NonRec b expr) =
192 liftM (NonRec b) $ liftM fst $ vectorise expr
193 vectoriseBind (Rec bindings) =
194 liftM Rec $ mapM vectoriseOne bindings
196 vectoriseOne (b, expr) =
198 (vexpr, ty) <- vectorise expr
199 return (setIdType b ty, vexpr)
202 -- Searches for function definitions and creates a lifted version for
204 -- We have only two interesting cases:
205 -- 1) function application (ex1) (ex2)
206 -- vectorise both subexpressions. The function will end up becoming a
207 -- pair (orig. fun, lifted fun), choose first component (in many cases,
208 -- this is pretty inefficient, since the lifted version is generated
209 -- although it is clear that it won't be used
211 -- 2) lambda abstraction
212 -- any function has to exist in two forms: it's original form and it's
213 -- lifted form. Therefore, every lambda abstraction is transformed into
214 -- a pair of functions: the original function and its lifted variant
217 -- FIXME: currently, I use 'exprType' all over the place - this is terribly
218 -- inefficient. It should be suffiecient to change 'vectorise' and 'lift' to
219 -- return the type of the result expression as well.
221 vectorise:: CoreExpr -> Flatten (CoreExpr, Type)
224 let varTy = idType id
225 let vecTy = vectoriseTy varTy
226 return (Var (setIdType id vecTy), vecTy)
228 vectorise (Lit lit) =
229 return ((Lit lit), literalType lit)
232 vectorise e@(App expr t@(Type _)) =
234 (vexpr, vexprTy) <- vectorise expr
235 return ((App vexpr t), applyTypeToArg vexprTy t)
237 vectorise (App (Lam b expr) arg) =
239 (varg, argTy) <- vectorise arg
240 (vexpr, vexprTy) <- vectorise expr
241 let vb = setIdType b argTy
242 return ((App (Lam vb vexpr) varg),
243 applyTypeToArg (mkPiType vb vexprTy) varg)
245 -- if vexpr expects a type as first argument
246 -- application stays just as it is
248 vectorise (App expr arg) =
250 (vexpr, vexprTy) <- vectorise expr
251 (varg, vargTy) <- vectorise arg
253 if (tcIsForAllTy vexprTy)
255 let resTy = applyTypeToArg vexprTy varg
256 return (App vexpr varg, resTy)
258 let [t1, t2] = tupleTyArgs vexprTy
259 vexpr' <- mk'fst t1 t2 vexpr
260 let resTy = applyTypeToArg t1 varg
261 return ((App vexpr' varg), resTy) -- apply the first component of
262 -- the vectorized function
264 vectorise e@(Lam b expr)
267 (vexpr, vexprTy) <- vectorise expr -- don't vectorise 'b'!
268 return ((Lam b vexpr), mkPiType b vexprTy)
271 (vexpr, vexprTy) <- vectorise expr
272 let vb = setIdType b (vectoriseTy (idType b))
273 let ve = Lam vb vexpr
274 (lexpr, lexprTy) <- lift e
275 let veTy = mkPiType vb vexprTy
276 return $ (mkTuple [veTy, lexprTy] [ve, lexpr],
277 mkTupleTy Boxed 2 [veTy, lexprTy])
279 vectorise (Let bind body) =
281 vbind <- vectoriseBind bind
282 (vbody, vbodyTy) <- vectorise body
283 return ((Let vbind vbody), vbodyTy)
285 vectorise (Case expr b ty alts) =
287 (vexpr, vexprTy) <- vectorise expr
288 valts <- mapM vectorise' alts
289 let res_ty = snd (head valts)
290 return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)
291 where vectorise' (con, bs, expr) =
293 (vexpr, vexprTy) <- vectorise expr
294 return ((con, bs, vexpr), vexprTy) -- FIXME: change type of con
299 vectorise (Note note expr) =
301 (vexpr, vexprTy) <- vectorise expr -- FIXME: is this ok or does it
302 return ((Note note vexpr), vexprTy) -- change the validity of note?
304 vectorise e@(Type t) =
305 return (e, t) -- FIXME: panic instead of 't'???
309 myShowTy (TyVarTy _) = "TyVar "
310 myShowTy (AppTy t1 t2) =
311 "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
312 myShowTy (TyConApp _ t) =
313 "TyConApp TC (" ++ (myShowTy t) ++ ")"
316 vectoriseTy :: Type -> Type
317 vectoriseTy ty | Just ty' <- tcView ty = vectoriseTy ty'
318 -- Look through notes and synonyms
319 -- NB: This will discard notes and synonyms, of course
320 -- ToDo: retain somehow?
321 vectoriseTy t@(TyVarTy v) = t
322 vectoriseTy t@(AppTy t1 t2) =
323 AppTy (vectoriseTy t1) (vectoriseTy t2)
324 vectoriseTy t@(TyConApp tc ts) =
325 TyConApp tc (map vectoriseTy ts)
326 vectoriseTy t@(FunTy t1 t2) =
327 mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)),
329 vectoriseTy t@(ForAllTy v ty) =
330 ForAllTy v (vectoriseTy ty)
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 ty | Just ty' <- tcView ty = liftTy ty'
339 liftTy (FunTy t1 t2) = FunTy (liftTy t1) (liftTy t2)
340 liftTy (ForAllTy tv t) = ForAllTy tv (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 $ setIdType bndr (liftTy (idType 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, idType lId)
369 lift cExpr@(Lit lit) =
371 lLit <- liftConst cExpr
372 return (lLit, exprType lLit)
376 | isSimpleExpr expr = liftSimpleFun b expr
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
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 (Cast expr co) =
456 (lexpr, t) <- lift expr
458 let (t1, t2) = coercionKind lco
459 return ((Cast expr lco), t2)
461 lift (Note note expr) =
463 (lexpr, t) <- lift expr
464 return ((Note note lexpr), t)
466 lift e@(Type t) = return (e, t)
469 -- auxilliary functions for lifting of case statements
472 liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] ->
473 Flatten (([CoreBind], [CoreBind], [CoreBind]))
474 liftCaseDataCon b [] =
476 liftCaseDataCon b alls@(alt:alts)
479 (i, e, defAltBndrs) <- liftCaseDataConDefault b alt alts
480 (is, es, altBndrs) <- liftCaseDataCon' b alts
481 return (i:is, e:es, defAltBndrs ++ altBndrs)
483 liftCaseDataCon' b alls
485 liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->
486 Flatten ([CoreBind], [CoreBind], [CoreBind])
487 liftCaseDataCon' _ [] =
492 liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
494 (permBnd, exprBnd, packBnd) <- liftSingleDataCon b dcon bnds expr
495 (permBnds, exprBnds, packBnds) <- liftCaseDataCon' b alts
496 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
499 -- FIXME: is is really necessary to return the binding to the permutation
500 -- array in the data constructor case, as the representation already
501 -- contains the extended flag vector
502 liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
503 Flatten (CoreBind, CoreBind, [CoreBind])
504 liftSingleDataCon b dcon bnds expr =
506 let dconId = dataConTag dcon
507 indexExpr <- mkIndexOfExprDCon (idType b) b dconId
508 (bb, bbind) <- mkBind FSLIT("is") indexExpr
509 lbnds <- mapM liftBinderType bnds
510 ((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr))
511 (_, vbind) <- mkBind FSLIT("r") lExpr
512 return (bbind, vbind, bnds')
514 -- FIXME: clean this up. the datacon and the literal case are so
515 -- similar that it would be easy to use the same function here
516 -- instead of duplicating all the code.
518 liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
519 -> Flatten (CoreBind, CoreBind, [CoreBind])
520 liftCaseDataConDefault b (_, _, def) alts =
522 let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts
523 indexExpr <- mkIndexOfExprDConDft (idType b) b dconIds
524 (bb, bbind) <- mkBind FSLIT("is") indexExpr
525 ((lDef, _), bnds) <- packContext bb (lift def)
526 (_, vbind) <- mkBind FSLIT("r") lDef
527 return (bbind, vbind, bnds)
529 -- liftCaseLit: checks if we have a default case and handles it
531 liftCaseLit:: CoreBndr -> [Alt CoreBndr] ->
532 Flatten ([CoreBind], [CoreBind], [CoreBind])
534 return ([], [], []) --FIXME: a case with no cases at all???
535 liftCaseLit b alls@(alt:alts)
538 (i, e, defAltBndrs) <- liftCaseLitDefault b alt alts
539 (is, es, altBndrs) <- liftCaseLit' b alts
540 return (i:is, e:es, defAltBndrs ++ altBndrs)
545 -- liftCaseLitDefault: looks at all the other alternatives which
546 -- contain a literal and filters all those elements from the
547 -- array which do not match any of the literals in the other
549 liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
550 -> Flatten (CoreBind, CoreBind, [CoreBind])
551 liftCaseLitDefault b (_, _, def) alts =
553 let lits = map (\(LitAlt l, _, _) -> l) alts
554 indexExpr <- mkIndexOfExprDft (idType b) b lits
555 (bb, bbind) <- mkBind FSLIT("is") indexExpr
556 ((lDef, _), bnds) <- packContext bb (lift def)
557 (_, vbind) <- mkBind FSLIT("r") lDef
558 return (bbind, vbind, bnds)
561 -- Assumption: in case of Lit, the list of binders of the alt is empty.
564 -- a list of all vars bound to the expr in the body of the alternative
565 -- a list of (var, expr) pairs, where var has to be bound to expr
567 liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->
568 Flatten ([CoreBind], [CoreBind], [CoreBind])
572 liftCaseLit' b ((LitAlt lit, [], expr):alts) =
574 (permBnd, exprBnd, packBnd) <- liftSingleCaseLit b lit expr
575 (permBnds, exprBnds, packBnds) <- liftCaseLit' b alts
576 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
578 -- lift a single alternative of the form: case b of lit -> expr.
580 -- It returns the bindings:
581 -- (a) let b' = indexOfP (mapP (\x -> x == lit) b)
583 -- (b) lift expr in the packed context. Returns lexpr and the
584 -- list of binds (bnds) that describe the packed arrays
586 -- (c) create new var v' to bind lexpr to
588 -- (d) return (b' = indexOf...., v' = lexpr, bnds)
589 liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr ->
590 Flatten (CoreBind, CoreBind, [CoreBind])
591 liftSingleCaseLit b lit expr =
593 indexExpr <- mkIndexOfExpr (idType b) b lit -- (a)
594 (bb, bbind) <- mkBind FSLIT("is") indexExpr
595 ((lExpr, t), bnds) <- packContext bb (lift expr) -- (b)
596 (_, vbind) <- mkBind FSLIT("r") lExpr
597 return (bbind, vbind, bnds)
599 -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
602 -- let index_bnd_1 in
605 -- let exprbnd_1 in ....
607 -- let nvar = replicate dummy (length <current context>)
608 -- nvar1 = bpermuteDftP index_bnd_1 ...
610 -- in bpermuteDftP index_bnd_n nvar_(n-1)
612 letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
613 Flatten (CoreExpr, Type)
614 letWrapper lExpr b (indBnds, exprBnds, pckBnds) =
616 (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
617 let resExpr = getExprOfBind (head defBpBnds)
618 return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
620 -- dftbpBinders: return the list of binders necessary to construct the overall
621 -- result from the subresults computed in the different branches of the case
622 -- statement. The binding which contains the final result is in the *head*
623 -- of the result list.
625 -- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
627 -- let def = replicate (length of context) undefined
628 -- d1 = bpermuteDftP dft e1 i1
631 dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
632 dftbpBinders indexBnds exprBnds =
634 let expr = getExprOfBind (head exprBnds)
635 defVecExpr <- createDftArrayBind expr
636 ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
639 dftbpBinders' :: [CoreBind]
642 -> Flatten ((CoreBind, [CoreBind]), Type)
643 dftbpBinders' [] [] cBnd =
644 return ((cBnd, []), panic "dftbpBinders: undefined type")
645 dftbpBinders' (i:is) (e:es) cBind =
647 let iVar = getVarOfBind i
648 let eVar = getVarOfBind e
649 let cVar = getVarOfBind cBind
651 newBnd <- mkDftBackpermute ty iVar eVar cVar
652 ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
653 return ((fBnd, (newBnd:restBnds)), liftTy ty)
655 dftbpBinders' _ _ _ =
656 panic "Flattening.dftbpBinders: index and expression binder lists 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 idType 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 idType b lit =
703 eqExpr <- mk'eq idType (Var b) (Lit lit)
704 let lambdaExpr = (Lam b eqExpr)
705 mk'indexOfP idType 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 idType b dId =
721 let intExpr = mkIntLitInt dId
722 eqExpr <- mk'eq idType (Var b) intExpr
723 let lambdaExpr = (Lam b intExpr)
724 mk'indexOfP idType 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 idType b dId =
739 let intExprs = map mkIntLitInt dId
740 bExpr <- foldM (mk'neq idType) (head intExprs) (tail intExprs)
741 let lambdaExpr = (Lam b bExpr)
742 mk'indexOfP idType (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 idType b lits =
750 let litExprs = map (\l-> Lit l) lits
751 bExpr <- foldM (mk'neq idType) (head litExprs) (tail litExprs)
752 let lambdaExpr = (Lam b bExpr)
753 mk'indexOfP idType 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"
808 showCoreExpr (Case ex b ty alts) =
809 "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
810 where showAlts _ = ""
811 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
812 showCoreExpr (Type t) = "Type"