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, isDefault,
59 isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
60 import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
61 liftVar, liftConst, intersectWithContext, mk'fst,
62 mk'mapP, mk'bpermuteDftP, mk'indexOfP,mk'eq,mk'neq)
65 import TcType ( tcIsForAllTy, tcView )
66 import TypeRep ( Type(..) )
67 import Coercion ( coercionKind )
68 import StaticFlags (opt_Flatten)
70 import ErrUtils (dumpIfSet_dyn)
71 import UniqSupply (mkSplitUniqSupply)
72 import DynFlags (DynFlag(..))
73 import Literal (Literal, literalType)
74 import Var (Var(..), idType, isTyVar)
76 import DataCon (DataCon, dataConTag)
77 import HscTypes ( ModGuts(..), HscEnv(..), hscEPS )
78 import CoreFVs (exprFreeVars)
79 import CoreSyn (Expr(..), Bind(..), Alt, AltCon(..),
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 import Monad (liftM, foldM)
95 -- toplevel transformation
96 -- -----------------------
98 -- entry point to the flattening transformation for the compiler driver when
99 -- compiling a complete module (EXPORTED)
104 flatten hsc_env mod_impl@(ModGuts {mg_binds = binds})
105 | not opt_Flatten = return mod_impl -- skip without -fflatten
108 let dflags = hsc_dflags hsc_env
110 eps <- hscEPS hsc_env
111 us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
113 -- announce vectorisation
115 showPass dflags "Flattening [first phase: vectorisation]"
117 -- vectorise all toplevel bindings
119 let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds
121 -- and dump the result if requested
123 endPass dflags "Flattening [first phase: vectorisation]"
124 Opt_D_dump_vect binds'
125 return $ mod_impl {mg_binds = binds'}
127 -- entry point to the flattening transformation for the compiler driver when
128 -- compiling a single expression in interactive mode (EXPORTED)
130 flattenExpr :: HscEnv
131 -> CoreExpr -- the expression to be flattened
133 flattenExpr hsc_env expr
134 | not opt_Flatten = return expr -- skip without -fflatten
137 let dflags = hsc_dflags hsc_env
138 eps <- hscEPS hsc_env
140 us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
142 -- announce vectorisation
144 showPass dflags "Flattening [first phase: vectorisation]"
146 -- vectorise the expression
148 let expr' = fst . runFlatten hsc_env eps us $ vectorise expr
150 -- and dump the result if requested
152 dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression"
157 -- vectorisation of bindings and expressions
158 -- -----------------------------------------
161 vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind]
162 vectoriseTopLevelBinds binds =
164 vbinds <- mapM vectoriseBind binds
165 return (adjustTypeBinds vbinds)
167 adjustTypeBinds:: [CoreBind] -> [CoreBind]
168 adjustTypeBinds vbinds =
170 ids = concat (map extIds vbinds)
171 idEnv = zipVarEnv ids ids
172 in map (substIdEnvBind idEnv) vbinds
174 -- FIXME replace by 'bindersOf'
175 extIds (NonRec b expr) = [b]
176 extIds (Rec bnds) = map fst bnds
177 substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr)
178 substIdEnvBind idEnv (Rec bnds)
179 = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds)
181 -- vectorise a single core binder
183 vectoriseBind :: CoreBind -> Flatten CoreBind
184 vectoriseBind (NonRec b expr) =
185 liftM (NonRec b) $ liftM fst $ vectorise expr
186 vectoriseBind (Rec bindings) =
187 liftM Rec $ mapM vectoriseOne bindings
189 vectoriseOne (b, expr) =
191 (vexpr, ty) <- vectorise expr
192 return (setIdType b ty, vexpr)
195 -- Searches for function definitions and creates a lifted version for
197 -- We have only two interesting cases:
198 -- 1) function application (ex1) (ex2)
199 -- vectorise both subexpressions. The function will end up becoming a
200 -- pair (orig. fun, lifted fun), choose first component (in many cases,
201 -- this is pretty inefficient, since the lifted version is generated
202 -- although it is clear that it won't be used
204 -- 2) lambda abstraction
205 -- any function has to exist in two forms: it's original form and it's
206 -- lifted form. Therefore, every lambda abstraction is transformed into
207 -- a pair of functions: the original function and its lifted variant
210 -- FIXME: currently, I use 'exprType' all over the place - this is terribly
211 -- inefficient. It should be suffiecient to change 'vectorise' and 'lift' to
212 -- return the type of the result expression as well.
214 vectorise:: CoreExpr -> Flatten (CoreExpr, Type)
217 let varTy = idType id
218 let vecTy = vectoriseTy varTy
219 return (Var (setIdType id vecTy), vecTy)
221 vectorise (Lit lit) =
222 return ((Lit lit), literalType lit)
225 vectorise e@(App expr t@(Type _)) =
227 (vexpr, vexprTy) <- vectorise expr
228 return ((App vexpr t), applyTypeToArg vexprTy t)
230 vectorise (App (Lam b expr) arg) =
232 (varg, argTy) <- vectorise arg
233 (vexpr, vexprTy) <- vectorise expr
234 let vb = setIdType b argTy
235 return ((App (Lam vb vexpr) varg),
236 applyTypeToArg (mkPiType vb vexprTy) varg)
238 -- if vexpr expects a type as first argument
239 -- application stays just as it is
241 vectorise (App expr arg) =
243 (vexpr, vexprTy) <- vectorise expr
244 (varg, vargTy) <- vectorise arg
246 if (tcIsForAllTy vexprTy)
248 let resTy = applyTypeToArg vexprTy varg
249 return (App vexpr varg, resTy)
251 let [t1, t2] = tupleTyArgs vexprTy
252 vexpr' <- mk'fst t1 t2 vexpr
253 let resTy = applyTypeToArg t1 varg
254 return ((App vexpr' varg), resTy) -- apply the first component of
255 -- the vectorized function
257 vectorise e@(Lam b expr)
260 (vexpr, vexprTy) <- vectorise expr -- don't vectorise 'b'!
261 return ((Lam b vexpr), mkPiType b vexprTy)
264 (vexpr, vexprTy) <- vectorise expr
265 let vb = setIdType b (vectoriseTy (idType b))
266 let ve = Lam vb vexpr
267 (lexpr, lexprTy) <- lift e
268 let veTy = mkPiType vb vexprTy
269 return $ (mkTuple [veTy, lexprTy] [ve, lexpr],
270 mkTupleTy Boxed 2 [veTy, lexprTy])
272 vectorise (Let bind body) =
274 vbind <- vectoriseBind bind
275 (vbody, vbodyTy) <- vectorise body
276 return ((Let vbind vbody), vbodyTy)
278 vectorise (Case expr b ty alts) =
280 (vexpr, vexprTy) <- vectorise expr
281 valts <- mapM vectorise' alts
282 let res_ty = snd (head valts)
283 return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)
284 where vectorise' (con, bs, expr) =
286 (vexpr, vexprTy) <- vectorise expr
287 return ((con, bs, vexpr), vexprTy) -- FIXME: change type of con
292 vectorise (Note note expr) =
294 (vexpr, vexprTy) <- vectorise expr -- FIXME: is this ok or does it
295 return ((Note note vexpr), vexprTy) -- change the validity of note?
297 vectorise e@(Type t) =
298 return (e, t) -- FIXME: panic instead of 't'???
302 myShowTy (TyVarTy _) = "TyVar "
303 myShowTy (AppTy t1 t2) =
304 "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
305 myShowTy (TyConApp _ t) =
306 "TyConApp TC (" ++ (myShowTy t) ++ ")"
309 vectoriseTy :: Type -> Type
310 vectoriseTy ty | Just ty' <- tcView ty = vectoriseTy ty'
311 -- Look through notes and synonyms
312 -- NB: This will discard notes and synonyms, of course
313 -- ToDo: retain somehow?
314 vectoriseTy t@(TyVarTy v) = t
315 vectoriseTy t@(AppTy t1 t2) =
316 AppTy (vectoriseTy t1) (vectoriseTy t2)
317 vectoriseTy t@(TyConApp tc ts) =
318 TyConApp tc (map vectoriseTy ts)
319 vectoriseTy t@(FunTy t1 t2) =
320 mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)),
322 vectoriseTy t@(ForAllTy v ty) =
323 ForAllTy v (vectoriseTy ty)
327 -- liftTy: wrap the type in an array but be careful with function types
328 -- on the *top level* (is this sufficient???)
330 liftTy:: Type -> Type
331 liftTy ty | Just ty' <- tcView ty = liftTy ty'
332 liftTy (FunTy t1 t2) = FunTy (liftTy t1) (liftTy t2)
333 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
334 liftTy t = mkPArrTy t
343 -- liftBinderType: Converts a type 'a' stored in the binder to the
344 -- representation of '[:a:]' will therefore call liftType
346 -- lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
347 -- but I'm not entirely sure about some fields (e.g., strictness info)
348 liftBinderType:: CoreBndr -> Flatten CoreBndr
349 liftBinderType bndr = return $ setIdType bndr (liftTy (idType bndr))
351 -- lift: lifts an expression (a -> [:a:])
352 -- If the expression is a simple expression, it is treated like a constant
354 -- If the body of a lambda expression is a simple expression, it is
355 -- transformed into a mapP
356 lift:: CoreExpr -> Flatten (CoreExpr, Type)
357 lift cExpr@(Var id) =
359 lVar@(Var lId) <- liftVar id
360 return (lVar, idType lId)
362 lift cExpr@(Lit lit) =
364 lLit <- liftConst cExpr
365 return (lLit, exprType lLit)
369 | isSimpleExpr expr = liftSimpleFun b expr
372 (lexpr, lexprTy) <- lift expr -- don't lift b!
373 return (Lam b lexpr, mkPiType b lexprTy)
376 lb <- liftBinderType b
377 (lexpr, lexprTy) <- extendContext [lb] (lift expr)
378 return ((Lam lb lexpr) , mkPiType lb lexprTy)
380 lift (App expr1 expr2) =
382 (lexpr1, lexpr1Ty) <- lift expr1
383 (lexpr2, _) <- lift expr2
384 return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2)
387 lift (Let (NonRec b expr1) expr2)
388 |isSimpleExpr expr2 =
390 (lexpr1, _) <- lift expr1
391 (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2
392 let (t1, t2) = funTyArgs lexpr2Ty
393 liftM (\x -> (x, liftTy t2)) $ mk'mapP t1 t2 lexpr2 lexpr1
397 (lexpr1, _) <- lift expr1
398 lb <- liftBinderType b
399 (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1)
400 return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty)
402 lift (Let (Rec binds) expr2) =
404 let (bndVars, exprs) = unzip binds
405 lBndVars <- mapM liftBinderType bndVars
406 lexprs <- extendContext bndVars (mapM lift exprs)
407 (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2)
408 return ((Let (Rec (zip lBndVars (map fst lexprs))) lexpr2), lexpr2Ty)
411 -- Assumption: alternatives can either be literals or data construtors.
412 -- Due to type restrictions, I don't think it is possible
413 -- that they are mixed.
414 -- The handling of literals and data constructors is completely
418 -- let b = expr in alts
420 -- I think I read somewhere that the default case (if present) is stored
421 -- in the head of the list. Assume for now this is true, have to check
424 -- (2) data constructors
426 -- FIXME: optimisation: first, filter out all simple expression and
427 -- loop (mapP & filter) over all the corresponding values in a single
430 -- (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr])
431 -- simple alts reg alts
432 -- (2) if simpleAlts = [] then (just as before)
433 -- if regAlts = [] then (the whole thing is just a loop)
434 -- otherwise (a) compute index vector for simpleAlts (for def permute
438 lift cExpr@(Case expr b _ alts) =
440 (lExpr, _) <- lift expr
441 lb <- liftBinderType b -- lift alt-expression
442 lalts <- if isLit alts
443 then extendContext [lb] (liftCaseLit b alts)
444 else extendContext [lb] (liftCaseDataCon b alts)
445 letWrapper lExpr b lalts
447 lift (Cast expr co) =
449 (lexpr, t) <- lift expr
451 let (t1, t2) = coercionKind lco
452 return ((Cast expr lco), t2)
454 lift (Note note expr) =
456 (lexpr, t) <- lift expr
457 return ((Note note lexpr), t)
459 lift e@(Type t) = return (e, t)
462 -- auxilliary functions for lifting of case statements
465 liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] ->
466 Flatten (([CoreBind], [CoreBind], [CoreBind]))
467 liftCaseDataCon b [] =
469 liftCaseDataCon b alls@(alt:alts)
472 (i, e, defAltBndrs) <- liftCaseDataConDefault b alt alts
473 (is, es, altBndrs) <- liftCaseDataCon' b alts
474 return (i:is, e:es, defAltBndrs ++ altBndrs)
476 liftCaseDataCon' b alls
478 liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->
479 Flatten ([CoreBind], [CoreBind], [CoreBind])
480 liftCaseDataCon' _ [] =
485 liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
487 (permBnd, exprBnd, packBnd) <- liftSingleDataCon b dcon bnds expr
488 (permBnds, exprBnds, packBnds) <- liftCaseDataCon' b alts
489 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
492 -- FIXME: is is really necessary to return the binding to the permutation
493 -- array in the data constructor case, as the representation already
494 -- contains the extended flag vector
495 liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
496 Flatten (CoreBind, CoreBind, [CoreBind])
497 liftSingleDataCon b dcon bnds expr =
499 let dconId = dataConTag dcon
500 indexExpr <- mkIndexOfExprDCon (idType b) b dconId
501 (bb, bbind) <- mkBind FSLIT("is") indexExpr
502 lbnds <- mapM liftBinderType bnds
503 ((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr))
504 (_, vbind) <- mkBind FSLIT("r") lExpr
505 return (bbind, vbind, bnds')
507 -- FIXME: clean this up. the datacon and the literal case are so
508 -- similar that it would be easy to use the same function here
509 -- instead of duplicating all the code.
511 liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
512 -> Flatten (CoreBind, CoreBind, [CoreBind])
513 liftCaseDataConDefault b (_, _, def) alts =
515 let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts
516 indexExpr <- mkIndexOfExprDConDft (idType b) b dconIds
517 (bb, bbind) <- mkBind FSLIT("is") indexExpr
518 ((lDef, _), bnds) <- packContext bb (lift def)
519 (_, vbind) <- mkBind FSLIT("r") lDef
520 return (bbind, vbind, bnds)
522 -- liftCaseLit: checks if we have a default case and handles it
524 liftCaseLit:: CoreBndr -> [Alt CoreBndr] ->
525 Flatten ([CoreBind], [CoreBind], [CoreBind])
527 return ([], [], []) --FIXME: a case with no cases at all???
528 liftCaseLit b alls@(alt:alts)
531 (i, e, defAltBndrs) <- liftCaseLitDefault b alt alts
532 (is, es, altBndrs) <- liftCaseLit' b alts
533 return (i:is, e:es, defAltBndrs ++ altBndrs)
538 -- liftCaseLitDefault: looks at all the other alternatives which
539 -- contain a literal and filters all those elements from the
540 -- array which do not match any of the literals in the other
542 liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
543 -> Flatten (CoreBind, CoreBind, [CoreBind])
544 liftCaseLitDefault b (_, _, def) alts =
546 let lits = map (\(LitAlt l, _, _) -> l) alts
547 indexExpr <- mkIndexOfExprDft (idType b) b lits
548 (bb, bbind) <- mkBind FSLIT("is") indexExpr
549 ((lDef, _), bnds) <- packContext bb (lift def)
550 (_, vbind) <- mkBind FSLIT("r") lDef
551 return (bbind, vbind, bnds)
554 -- Assumption: in case of Lit, the list of binders of the alt is empty.
557 -- a list of all vars bound to the expr in the body of the alternative
558 -- a list of (var, expr) pairs, where var has to be bound to expr
560 liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->
561 Flatten ([CoreBind], [CoreBind], [CoreBind])
565 liftCaseLit' b ((LitAlt lit, [], expr):alts) =
567 (permBnd, exprBnd, packBnd) <- liftSingleCaseLit b lit expr
568 (permBnds, exprBnds, packBnds) <- liftCaseLit' b alts
569 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
571 -- lift a single alternative of the form: case b of lit -> expr.
573 -- It returns the bindings:
574 -- (a) let b' = indexOfP (mapP (\x -> x == lit) b)
576 -- (b) lift expr in the packed context. Returns lexpr and the
577 -- list of binds (bnds) that describe the packed arrays
579 -- (c) create new var v' to bind lexpr to
581 -- (d) return (b' = indexOf...., v' = lexpr, bnds)
582 liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr ->
583 Flatten (CoreBind, CoreBind, [CoreBind])
584 liftSingleCaseLit b lit expr =
586 indexExpr <- mkIndexOfExpr (idType b) b lit -- (a)
587 (bb, bbind) <- mkBind FSLIT("is") indexExpr
588 ((lExpr, t), bnds) <- packContext bb (lift expr) -- (b)
589 (_, vbind) <- mkBind FSLIT("r") lExpr
590 return (bbind, vbind, bnds)
592 -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
595 -- let index_bnd_1 in
598 -- let exprbnd_1 in ....
600 -- let nvar = replicate dummy (length <current context>)
601 -- nvar1 = bpermuteDftP index_bnd_1 ...
603 -- in bpermuteDftP index_bnd_n nvar_(n-1)
605 letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
606 Flatten (CoreExpr, Type)
607 letWrapper lExpr b (indBnds, exprBnds, pckBnds) =
609 (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
610 let resExpr = getExprOfBind (head defBpBnds)
611 return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
613 -- dftbpBinders: return the list of binders necessary to construct the overall
614 -- result from the subresults computed in the different branches of the case
615 -- statement. The binding which contains the final result is in the *head*
616 -- of the result list.
618 -- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
620 -- let def = replicate (length of context) undefined
621 -- d1 = bpermuteDftP dft e1 i1
624 dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
625 dftbpBinders indexBnds exprBnds =
627 let expr = getExprOfBind (head exprBnds)
628 defVecExpr <- createDftArrayBind expr
629 ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
632 dftbpBinders' :: [CoreBind]
635 -> Flatten ((CoreBind, [CoreBind]), Type)
636 dftbpBinders' [] [] cBnd =
637 return ((cBnd, []), panic "dftbpBinders: undefined type")
638 dftbpBinders' (i:is) (e:es) cBind =
640 let iVar = getVarOfBind i
641 let eVar = getVarOfBind e
642 let cVar = getVarOfBind cBind
644 newBnd <- mkDftBackpermute ty iVar eVar cVar
645 ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
646 return ((fBnd, (newBnd:restBnds)), liftTy ty)
648 dftbpBinders' _ _ _ =
649 panic "Flattening.dftbpBinders: index and expression binder lists have different length!"
651 getExprOfBind:: CoreBind -> CoreExpr
652 getExprOfBind (NonRec _ expr) = expr
654 getVarOfBind:: CoreBind -> Var
655 getVarOfBind (NonRec b _) = b
659 -- Optimised Transformation
660 -- =========================
664 -- if variables x_1 to x_i occur in the context *and* free in expr
666 -- (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn)
668 liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type)
669 liftSimpleFun b expr =
671 bndVars <- collectBoundVars expr
672 let bndVars' = b:bndVars
673 bndVarsTuple = mkTuple (map idType bndVars') (map Var bndVars')
674 lamExpr = mkLams (b:bndVars) expr -- FIXME: should be tuple
676 let (t1, t2) = funTyArgs . exprType $ lamExpr
677 mapExpr <- mk'mapP t1 t2 lamExpr bndVarsTuple
678 let lexpr = mkApps mapExpr [bndVarsTuple]
679 return (lexpr, undefined) -- FIXME!!!!!
682 collectBoundVars:: CoreExpr -> Flatten [CoreBndr]
683 collectBoundVars expr =
684 intersectWithContext (exprFreeVars expr)
687 -- auxilliary routines
688 -- -------------------
690 -- mkIndexOfExpr b lit ->
691 -- indexOf (mapP (\x -> x == lit) b) b
693 mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
694 mkIndexOfExpr idType b lit =
696 eqExpr <- mk'eq idType (Var b) (Lit lit)
697 let lambdaExpr = (Lam b eqExpr)
698 mk'indexOfP idType lambdaExpr (Var b)
700 -- there is FlattenMonad.mk'indexOfP as well as
701 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
703 -- for case-distinction over data constructors:
707 -- dconId = dataConTag dcon
708 -- the call "mkIndexOfExprDCon b dconId" computes the core expression for
709 -- indexOfP (\x -> x == dconId) b)
711 mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr
712 mkIndexOfExprDCon idType b dId =
714 let intExpr = mkIntLitInt dId
715 eqExpr <- mk'eq idType (Var b) intExpr
716 let lambdaExpr = (Lam b intExpr)
717 mk'indexOfP idType lambdaExpr (Var b)
721 -- there is FlattenMonad.mk'indexOfP as well as
722 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
724 -- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the
725 -- default case. "dconIds" is a list of all the data constructor idents which
726 -- are covered by the other cases.
727 -- indexOfP (\x -> x != dconId_1 && ....) b)
729 mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
730 mkIndexOfExprDConDft idType b dId =
732 let intExprs = map mkIntLitInt dId
733 bExpr <- foldM (mk'neq idType) (head intExprs) (tail intExprs)
734 let lambdaExpr = (Lam b bExpr)
735 mk'indexOfP idType (Var b) bExpr
738 -- mkIndexOfExprDef b [lit1, lit2,...] ->
739 -- indexOf (\x -> not (x == lit1 || x == lit2 ....) b
740 mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
741 mkIndexOfExprDft idType b lits =
743 let litExprs = map (\l-> Lit l) lits
744 bExpr <- foldM (mk'neq idType) (head litExprs) (tail litExprs)
745 let lambdaExpr = (Lam b bExpr)
746 mk'indexOfP idType bExpr (Var b)
749 -- create a back-permute binder
751 -- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
752 -- Core binding of the form
754 -- x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
756 -- where `x' is a new local variable
758 mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind
759 mkDftBackpermute ty idx src dft =
761 rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft)
762 liftM snd $ mkBind FSLIT("dbp") rhs
764 -- create a dummy array with elements of the given type, which can be used as
765 -- default array for the combination of the subresults of the lifted case
768 createDftArrayBind :: CoreExpr -> Flatten CoreBind
769 createDftArrayBind e =
770 panic "Flattening.createDftArrayBind: not implemented yet"
773 let ty = parrElemTy . exprType $ expr
775 rhs <- mk'replicateP ty len err??
776 lift snd $ mkBind FSLIT("dft") rhs
777 FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde
778 beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen
779 generischen Wert f"ur jeden beliebigen Typ zu erfinden.
785 -- show functions (the pretty print functions sometimes don't
786 -- show it the way I want....
788 -- shows just the structure
789 showCoreExpr (Var _ ) = "Var "
790 showCoreExpr (Lit _) = "Lit "
791 showCoreExpr (App e1 e2) =
792 "(App \n " ++ (showCoreExpr e1) ++ "\n " ++ (showCoreExpr e2) ++ ") "
793 showCoreExpr (Lam b e) =
794 "Lam b " ++ (showCoreExpr e)
795 showCoreExpr (Let bnds expr) =
796 "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr)
797 where showBinds (NonRec b e) = showBind (b,e)
798 showBinds (Rec bnds) = concat (map showBind bnds)
799 showBind (b,e) = " b = " ++ (showCoreExpr e)++ "\n"
801 showCoreExpr (Case ex b ty alts) =
802 "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
803 where showAlts _ = ""
804 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
805 showCoreExpr (Type t) = "Type"