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 -- FIXME: fro debugging - remove this
94 import Debug.Trace (trace)
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)
108 flatten hsc_env mod_impl@(ModGuts {mg_binds = binds})
109 | not opt_Flatten = return mod_impl -- skip without -fflatten
112 let dflags = hsc_dflags hsc_env
114 eps <- hscEPS 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 eps 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 -> CoreExpr -- the expression to be flattened
137 flattenExpr hsc_env expr
138 | not opt_Flatten = return expr -- skip without -fflatten
141 let dflags = hsc_dflags hsc_env
142 eps <- hscEPS 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 eps 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 (setIdType b 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 = idType id
222 let vecTy = vectoriseTy varTy
223 return (Var (setIdType id 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 = setIdType b 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 (tcIsForAllTy 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
261 vectorise e@(Lam b expr)
264 (vexpr, vexprTy) <- vectorise expr -- don't vectorise 'b'!
265 return ((Lam b vexpr), mkPiType b vexprTy)
268 (vexpr, vexprTy) <- vectorise expr
269 let vb = setIdType b (vectoriseTy (idType b))
270 let ve = Lam vb vexpr
271 (lexpr, lexprTy) <- lift e
272 let veTy = mkPiType vb vexprTy
273 return $ (mkTuple [veTy, lexprTy] [ve, lexpr],
274 mkTupleTy Boxed 2 [veTy, lexprTy])
276 vectorise (Let bind body) =
278 vbind <- vectoriseBind bind
279 (vbody, vbodyTy) <- vectorise body
280 return ((Let vbind vbody), vbodyTy)
282 vectorise (Case expr b ty alts) =
284 (vexpr, vexprTy) <- vectorise expr
285 valts <- mapM vectorise' alts
286 let res_ty = snd (head valts)
287 return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)
288 where vectorise' (con, bs, expr) =
290 (vexpr, vexprTy) <- vectorise expr
291 return ((con, bs, vexpr), vexprTy) -- FIXME: change type of con
296 vectorise (Note note expr) =
298 (vexpr, vexprTy) <- vectorise expr -- FIXME: is this ok or does it
299 return ((Note note vexpr), vexprTy) -- change the validity of note?
301 vectorise e@(Type t) =
302 return (e, t) -- FIXME: panic instead of 't'???
306 myShowTy (TyVarTy _) = "TyVar "
307 myShowTy (AppTy t1 t2) =
308 "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
309 myShowTy (TyConApp _ t) =
310 "TyConApp TC (" ++ (myShowTy t) ++ ")"
313 vectoriseTy :: Type -> Type
314 vectoriseTy ty | Just ty' <- tcView ty = vectoriseTy ty'
315 -- Look through notes and synonyms
316 -- NB: This will discard notes and synonyms, of course
317 -- ToDo: retain somehow?
318 vectoriseTy t@(TyVarTy v) = t
319 vectoriseTy t@(AppTy t1 t2) =
320 AppTy (vectoriseTy t1) (vectoriseTy t2)
321 vectoriseTy t@(TyConApp tc ts) =
322 TyConApp tc (map vectoriseTy ts)
323 vectoriseTy t@(FunTy t1 t2) =
324 mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)),
326 vectoriseTy t@(ForAllTy v ty) =
327 ForAllTy v (vectoriseTy ty)
331 -- liftTy: wrap the type in an array but be careful with function types
332 -- on the *top level* (is this sufficient???)
334 liftTy:: Type -> Type
335 liftTy ty | Just ty' <- tcView ty = liftTy ty'
336 liftTy (FunTy t1 t2) = FunTy (liftTy t1) (liftTy t2)
337 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
338 liftTy t = mkPArrTy t
347 -- liftBinderType: Converts a type 'a' stored in the binder to the
348 -- representation of '[:a:]' will therefore call liftType
350 -- lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
351 -- but I'm not entirely sure about some fields (e.g., strictness info)
352 liftBinderType:: CoreBndr -> Flatten CoreBndr
353 liftBinderType bndr = return $ setIdType bndr (liftTy (idType bndr))
355 -- lift: lifts an expression (a -> [:a:])
356 -- If the expression is a simple expression, it is treated like a constant
358 -- If the body of a lambda expression is a simple expression, it is
359 -- transformed into a mapP
360 lift:: CoreExpr -> Flatten (CoreExpr, Type)
361 lift cExpr@(Var id) =
363 lVar@(Var lId) <- liftVar id
364 return (lVar, idType lId)
366 lift cExpr@(Lit lit) =
368 lLit <- liftConst cExpr
369 return (lLit, exprType lLit)
373 | isSimpleExpr expr = liftSimpleFun b expr
376 (lexpr, lexprTy) <- lift expr -- don't lift b!
377 return (Lam b lexpr, mkPiType b lexprTy)
380 lb <- liftBinderType b
381 (lexpr, lexprTy) <- extendContext [lb] (lift expr)
382 return ((Lam lb lexpr) , mkPiType lb lexprTy)
384 lift (App expr1 expr2) =
386 (lexpr1, lexpr1Ty) <- lift expr1
387 (lexpr2, _) <- lift expr2
388 return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2)
391 lift (Let (NonRec b expr1) expr2)
392 |isSimpleExpr expr2 =
394 (lexpr1, _) <- lift expr1
395 (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2
396 let (t1, t2) = funTyArgs lexpr2Ty
397 liftM (\x -> (x, liftTy t2)) $ mk'mapP t1 t2 lexpr2 lexpr1
401 (lexpr1, _) <- lift expr1
402 lb <- liftBinderType b
403 (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1)
404 return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty)
406 lift (Let (Rec binds) expr2) =
408 let (bndVars, exprs) = unzip binds
409 lBndVars <- mapM liftBinderType bndVars
410 lexprs <- extendContext bndVars (mapM lift exprs)
411 (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2)
412 return ((Let (Rec (zip lBndVars (map fst lexprs))) lexpr2), lexpr2Ty)
415 -- Assumption: alternatives can either be literals or data construtors.
416 -- Due to type restrictions, I don't think it is possible
417 -- that they are mixed.
418 -- The handling of literals and data constructors is completely
422 -- let b = expr in alts
424 -- I think I read somewhere that the default case (if present) is stored
425 -- in the head of the list. Assume for now this is true, have to check
428 -- (2) data constructors
430 -- FIXME: optimisation: first, filter out all simple expression and
431 -- loop (mapP & filter) over all the corresponding values in a single
434 -- (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr])
435 -- simple alts reg alts
436 -- (2) if simpleAlts = [] then (just as before)
437 -- if regAlts = [] then (the whole thing is just a loop)
438 -- otherwise (a) compute index vector for simpleAlts (for def permute
442 lift cExpr@(Case expr b _ alts) =
444 (lExpr, _) <- lift expr
445 lb <- liftBinderType b -- lift alt-expression
446 lalts <- if isLit alts
447 then extendContext [lb] (liftCaseLit b alts)
448 else extendContext [lb] (liftCaseDataCon b alts)
449 letWrapper lExpr b lalts
451 lift (Cast expr co) =
453 (lexpr, t) <- lift expr
455 let (t1, t2) = coercionKind lco
456 return ((Cast expr lco), t2)
458 lift (Note note expr) =
460 (lexpr, t) <- lift expr
461 return ((Note note lexpr), t)
463 lift e@(Type t) = return (e, t)
466 -- auxilliary functions for lifting of case statements
469 liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] ->
470 Flatten (([CoreBind], [CoreBind], [CoreBind]))
471 liftCaseDataCon b [] =
473 liftCaseDataCon b alls@(alt:alts)
476 (i, e, defAltBndrs) <- liftCaseDataConDefault b alt alts
477 (is, es, altBndrs) <- liftCaseDataCon' b alts
478 return (i:is, e:es, defAltBndrs ++ altBndrs)
480 liftCaseDataCon' b alls
482 liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->
483 Flatten ([CoreBind], [CoreBind], [CoreBind])
484 liftCaseDataCon' _ [] =
489 liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
491 (permBnd, exprBnd, packBnd) <- liftSingleDataCon b dcon bnds expr
492 (permBnds, exprBnds, packBnds) <- liftCaseDataCon' b alts
493 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
496 -- FIXME: is is really necessary to return the binding to the permutation
497 -- array in the data constructor case, as the representation already
498 -- contains the extended flag vector
499 liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
500 Flatten (CoreBind, CoreBind, [CoreBind])
501 liftSingleDataCon b dcon bnds expr =
503 let dconId = dataConTag dcon
504 indexExpr <- mkIndexOfExprDCon (idType b) b dconId
505 (bb, bbind) <- mkBind FSLIT("is") indexExpr
506 lbnds <- mapM liftBinderType bnds
507 ((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr))
508 (_, vbind) <- mkBind FSLIT("r") lExpr
509 return (bbind, vbind, bnds')
511 -- FIXME: clean this up. the datacon and the literal case are so
512 -- similar that it would be easy to use the same function here
513 -- instead of duplicating all the code.
515 liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
516 -> Flatten (CoreBind, CoreBind, [CoreBind])
517 liftCaseDataConDefault b (_, _, def) alts =
519 let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts
520 indexExpr <- mkIndexOfExprDConDft (idType b) b dconIds
521 (bb, bbind) <- mkBind FSLIT("is") indexExpr
522 ((lDef, _), bnds) <- packContext bb (lift def)
523 (_, vbind) <- mkBind FSLIT("r") lDef
524 return (bbind, vbind, bnds)
526 -- liftCaseLit: checks if we have a default case and handles it
528 liftCaseLit:: CoreBndr -> [Alt CoreBndr] ->
529 Flatten ([CoreBind], [CoreBind], [CoreBind])
531 return ([], [], []) --FIXME: a case with no cases at all???
532 liftCaseLit b alls@(alt:alts)
535 (i, e, defAltBndrs) <- liftCaseLitDefault b alt alts
536 (is, es, altBndrs) <- liftCaseLit' b alts
537 return (i:is, e:es, defAltBndrs ++ altBndrs)
542 -- liftCaseLitDefault: looks at all the other alternatives which
543 -- contain a literal and filters all those elements from the
544 -- array which do not match any of the literals in the other
546 liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
547 -> Flatten (CoreBind, CoreBind, [CoreBind])
548 liftCaseLitDefault b (_, _, def) alts =
550 let lits = map (\(LitAlt l, _, _) -> l) alts
551 indexExpr <- mkIndexOfExprDft (idType b) b lits
552 (bb, bbind) <- mkBind FSLIT("is") indexExpr
553 ((lDef, _), bnds) <- packContext bb (lift def)
554 (_, vbind) <- mkBind FSLIT("r") lDef
555 return (bbind, vbind, bnds)
558 -- Assumption: in case of Lit, the list of binders of the alt is empty.
561 -- a list of all vars bound to the expr in the body of the alternative
562 -- a list of (var, expr) pairs, where var has to be bound to expr
564 liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->
565 Flatten ([CoreBind], [CoreBind], [CoreBind])
569 liftCaseLit' b ((LitAlt lit, [], expr):alts) =
571 (permBnd, exprBnd, packBnd) <- liftSingleCaseLit b lit expr
572 (permBnds, exprBnds, packBnds) <- liftCaseLit' b alts
573 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
575 -- lift a single alternative of the form: case b of lit -> expr.
577 -- It returns the bindings:
578 -- (a) let b' = indexOfP (mapP (\x -> x == lit) b)
580 -- (b) lift expr in the packed context. Returns lexpr and the
581 -- list of binds (bnds) that describe the packed arrays
583 -- (c) create new var v' to bind lexpr to
585 -- (d) return (b' = indexOf...., v' = lexpr, bnds)
586 liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr ->
587 Flatten (CoreBind, CoreBind, [CoreBind])
588 liftSingleCaseLit b lit expr =
590 indexExpr <- mkIndexOfExpr (idType b) b lit -- (a)
591 (bb, bbind) <- mkBind FSLIT("is") indexExpr
592 ((lExpr, t), bnds) <- packContext bb (lift expr) -- (b)
593 (_, vbind) <- mkBind FSLIT("r") lExpr
594 return (bbind, vbind, bnds)
596 -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
599 -- let index_bnd_1 in
602 -- let exprbnd_1 in ....
604 -- let nvar = replicate dummy (length <current context>)
605 -- nvar1 = bpermuteDftP index_bnd_1 ...
607 -- in bpermuteDftP index_bnd_n nvar_(n-1)
609 letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
610 Flatten (CoreExpr, Type)
611 letWrapper lExpr b (indBnds, exprBnds, pckBnds) =
613 (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
614 let resExpr = getExprOfBind (head defBpBnds)
615 return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
617 -- dftbpBinders: return the list of binders necessary to construct the overall
618 -- result from the subresults computed in the different branches of the case
619 -- statement. The binding which contains the final result is in the *head*
620 -- of the result list.
622 -- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
624 -- let def = replicate (length of context) undefined
625 -- d1 = bpermuteDftP dft e1 i1
628 dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
629 dftbpBinders indexBnds exprBnds =
631 let expr = getExprOfBind (head exprBnds)
632 defVecExpr <- createDftArrayBind expr
633 ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
636 dftbpBinders' :: [CoreBind]
639 -> Flatten ((CoreBind, [CoreBind]), Type)
640 dftbpBinders' [] [] cBnd =
641 return ((cBnd, []), panic "dftbpBinders: undefined type")
642 dftbpBinders' (i:is) (e:es) cBind =
644 let iVar = getVarOfBind i
645 let eVar = getVarOfBind e
646 let cVar = getVarOfBind cBind
648 newBnd <- mkDftBackpermute ty iVar eVar cVar
649 ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
650 return ((fBnd, (newBnd:restBnds)), liftTy ty)
652 dftbpBinders' _ _ _ =
653 panic "Flattening.dftbpBinders: index and expression binder lists have different length!"
655 getExprOfBind:: CoreBind -> CoreExpr
656 getExprOfBind (NonRec _ expr) = expr
658 getVarOfBind:: CoreBind -> Var
659 getVarOfBind (NonRec b _) = b
663 -- Optimised Transformation
664 -- =========================
668 -- if variables x_1 to x_i occur in the context *and* free in expr
670 -- (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn)
672 liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type)
673 liftSimpleFun b expr =
675 bndVars <- collectBoundVars expr
676 let bndVars' = b:bndVars
677 bndVarsTuple = mkTuple (map idType bndVars') (map Var bndVars')
678 lamExpr = mkLams (b:bndVars) expr -- FIXME: should be tuple
680 let (t1, t2) = funTyArgs . exprType $ lamExpr
681 mapExpr <- mk'mapP t1 t2 lamExpr bndVarsTuple
682 let lexpr = mkApps mapExpr [bndVarsTuple]
683 return (lexpr, undefined) -- FIXME!!!!!
686 collectBoundVars:: CoreExpr -> Flatten [CoreBndr]
687 collectBoundVars expr =
688 intersectWithContext (exprFreeVars expr)
691 -- auxilliary routines
692 -- -------------------
694 -- mkIndexOfExpr b lit ->
695 -- indexOf (mapP (\x -> x == lit) b) b
697 mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
698 mkIndexOfExpr idType b lit =
700 eqExpr <- mk'eq idType (Var b) (Lit lit)
701 let lambdaExpr = (Lam b eqExpr)
702 mk'indexOfP idType lambdaExpr (Var b)
704 -- there is FlattenMonad.mk'indexOfP as well as
705 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
707 -- for case-distinction over data constructors:
711 -- dconId = dataConTag dcon
712 -- the call "mkIndexOfExprDCon b dconId" computes the core expression for
713 -- indexOfP (\x -> x == dconId) b)
715 mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr
716 mkIndexOfExprDCon idType b dId =
718 let intExpr = mkIntLitInt dId
719 eqExpr <- mk'eq idType (Var b) intExpr
720 let lambdaExpr = (Lam b intExpr)
721 mk'indexOfP idType lambdaExpr (Var b)
725 -- there is FlattenMonad.mk'indexOfP as well as
726 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
728 -- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the
729 -- default case. "dconIds" is a list of all the data constructor idents which
730 -- are covered by the other cases.
731 -- indexOfP (\x -> x != dconId_1 && ....) b)
733 mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
734 mkIndexOfExprDConDft idType b dId =
736 let intExprs = map mkIntLitInt dId
737 bExpr <- foldM (mk'neq idType) (head intExprs) (tail intExprs)
738 let lambdaExpr = (Lam b bExpr)
739 mk'indexOfP idType (Var b) bExpr
742 -- mkIndexOfExprDef b [lit1, lit2,...] ->
743 -- indexOf (\x -> not (x == lit1 || x == lit2 ....) b
744 mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
745 mkIndexOfExprDft idType b lits =
747 let litExprs = map (\l-> Lit l) lits
748 bExpr <- foldM (mk'neq idType) (head litExprs) (tail litExprs)
749 let lambdaExpr = (Lam b bExpr)
750 mk'indexOfP idType bExpr (Var b)
753 -- create a back-permute binder
755 -- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
756 -- Core binding of the form
758 -- x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
760 -- where `x' is a new local variable
762 mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind
763 mkDftBackpermute ty idx src dft =
765 rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft)
766 liftM snd $ mkBind FSLIT("dbp") rhs
768 -- create a dummy array with elements of the given type, which can be used as
769 -- default array for the combination of the subresults of the lifted case
772 createDftArrayBind :: CoreExpr -> Flatten CoreBind
773 createDftArrayBind e =
774 panic "Flattening.createDftArrayBind: not implemented yet"
777 let ty = parrElemTy . exprType $ expr
779 rhs <- mk'replicateP ty len err??
780 lift snd $ mkBind FSLIT("dft") rhs
781 FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde
782 beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen
783 generischen Wert f"ur jeden beliebigen Typ zu erfinden.
789 -- show functions (the pretty print functions sometimes don't
790 -- show it the way I want....
792 -- shows just the structure
793 showCoreExpr (Var _ ) = "Var "
794 showCoreExpr (Lit _) = "Lit "
795 showCoreExpr (App e1 e2) =
796 "(App \n " ++ (showCoreExpr e1) ++ "\n " ++ (showCoreExpr e2) ++ ") "
797 showCoreExpr (Lam b e) =
798 "Lam b " ++ (showCoreExpr e)
799 showCoreExpr (Let bnds expr) =
800 "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr)
801 where showBinds (NonRec b e) = showBind (b,e)
802 showBinds (Rec bnds) = concat (map showBind bnds)
803 showBind (b,e) = " b = " ++ (showCoreExpr e)++ "\n"
805 showCoreExpr (Case ex b ty alts) =
806 "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
807 where showAlts _ = ""
808 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
809 showCoreExpr (Type t) = "Type"