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)
72 import Var (Var(..), idType, isTyVar)
74 import DataCon (DataCon, dataConTag)
75 import TypeRep (Type(..))
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 (setIdType b 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 = idType id
221 let vecTy = vectoriseTy varTy
222 return (Var (setIdType id 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 = setIdType b 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)
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 = setIdType b (vectoriseTy (idType 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)
289 vectorise (Case expr b ty alts) =
291 (vexpr, vexprTy) <- vectorise expr
292 valts <- mapM vectorise' alts
293 let res_ty = snd (head valts)
294 return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)
295 where vectorise' (con, bs, expr) =
297 (vexpr, vexprTy) <- vectorise expr
298 return ((con, bs, vexpr), vexprTy) -- FIXME: change type of con
303 vectorise (Note note expr) =
305 (vexpr, vexprTy) <- vectorise expr -- FIXME: is this ok or does it
306 return ((Note note vexpr), vexprTy) -- change the validity of note?
308 vectorise e@(Type t) =
309 return (e, t) -- FIXME: panic instead of 't'???
313 myShowTy (TyVarTy _) = "TyVar "
314 myShowTy (AppTy t1 t2) =
315 "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
316 myShowTy (TyConApp _ t) =
317 "TyConApp TC (" ++ (myShowTy t) ++ ")"
320 vectoriseTy :: Type -> Type
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)
331 vectoriseTy t@(NoteTy note ty) = -- FIXME: is the note still valid after
332 NoteTy note (vectoriseTy ty) -- this or should we just throw it away
336 -- liftTy: wrap the type in an array but be careful with function types
337 -- on the *top level* (is this sufficient???)
339 liftTy:: Type -> Type
340 liftTy (FunTy t1 t2) = FunTy (liftTy t1) (liftTy t2)
341 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
342 liftTy (NoteTy n t) = NoteTy n $ liftTy t
343 liftTy t = mkPArrTy t
352 -- liftBinderType: Converts a type 'a' stored in the binder to the
353 -- representation of '[:a:]' will therefore call liftType
355 -- lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
356 -- but I'm not entirely sure about some fields (e.g., strictness info)
357 liftBinderType:: CoreBndr -> Flatten CoreBndr
358 liftBinderType bndr = return $ setIdType bndr (liftTy (idType bndr))
360 -- lift: lifts an expression (a -> [:a:])
361 -- If the expression is a simple expression, it is treated like a constant
363 -- If the body of a lambda expression is a simple expression, it is
364 -- transformed into a mapP
365 lift:: CoreExpr -> Flatten (CoreExpr, Type)
366 lift cExpr@(Var id) =
368 lVar@(Var lId) <- liftVar id
369 return (lVar, idType lId)
371 lift cExpr@(Lit lit) =
373 lLit <- liftConst cExpr
374 return (lLit, exprType lLit)
378 | isSimpleExpr expr = liftSimpleFun b expr
381 (lexpr, lexprTy) <- lift expr -- don't lift b!
382 return (Lam b lexpr, mkPiType b lexprTy)
385 lb <- liftBinderType b
386 (lexpr, lexprTy) <- extendContext [lb] (lift expr)
387 return ((Lam lb lexpr) , mkPiType lb lexprTy)
389 lift (App expr1 expr2) =
391 (lexpr1, lexpr1Ty) <- lift expr1
392 (lexpr2, _) <- lift expr2
393 return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2)
396 lift (Let (NonRec b expr1) expr2)
397 |isSimpleExpr expr2 =
399 (lexpr1, _) <- lift expr1
400 (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2
401 let (t1, t2) = funTyArgs lexpr2Ty
402 liftM (\x -> (x, liftTy t2)) $ mk'mapP t1 t2 lexpr2 lexpr1
406 (lexpr1, _) <- lift expr1
407 lb <- liftBinderType b
408 (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1)
409 return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty)
411 lift (Let (Rec binds) expr2) =
413 let (bndVars, exprs) = unzip binds
414 lBndVars <- mapM liftBinderType bndVars
415 lexprs <- extendContext bndVars (mapM lift exprs)
416 (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2)
417 return ((Let (Rec (zip lBndVars (map fst lexprs))) lexpr2), lexpr2Ty)
420 -- Assumption: alternatives can either be literals or data construtors.
421 -- Due to type restrictions, I don't think it is possible
422 -- that they are mixed.
423 -- The handling of literals and data constructors is completely
427 -- let b = expr in alts
429 -- I think I read somewhere that the default case (if present) is stored
430 -- in the head of the list. Assume for now this is true, have to check
433 -- (2) data constructors
435 -- FIXME: optimisation: first, filter out all simple expression and
436 -- loop (mapP & filter) over all the corresponding values in a single
439 -- (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr])
440 -- simple alts reg alts
441 -- (2) if simpleAlts = [] then (just as before)
442 -- if regAlts = [] then (the whole thing is just a loop)
443 -- otherwise (a) compute index vector for simpleAlts (for def permute
447 lift cExpr@(Case expr b _ alts) =
449 (lExpr, _) <- lift expr
450 lb <- liftBinderType b -- lift alt-expression
451 lalts <- if isLit alts
452 then extendContext [lb] (liftCaseLit b alts)
453 else extendContext [lb] (liftCaseDataCon b alts)
454 letWrapper lExpr b lalts
456 lift (Note (Coerce t1 t2) expr) =
458 (lexpr, t) <- lift expr
460 return ((Note (Coerce lt1 (liftTy t2)) lexpr), lt1)
462 lift (Note note expr) =
464 (lexpr, t) <- lift expr
465 return ((Note note lexpr), t)
467 lift e@(Type t) = return (e, t)
470 -- auxilliary functions for lifting of case statements
473 liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] ->
474 Flatten (([CoreBind], [CoreBind], [CoreBind]))
475 liftCaseDataCon b [] =
477 liftCaseDataCon b alls@(alt:alts)
480 (i, e, defAltBndrs) <- liftCaseDataConDefault b alt alts
481 (is, es, altBndrs) <- liftCaseDataCon' b alts
482 return (i:is, e:es, defAltBndrs ++ altBndrs)
484 liftCaseDataCon' b alls
486 liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->
487 Flatten ([CoreBind], [CoreBind], [CoreBind])
488 liftCaseDataCon' _ [] =
493 liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
495 (permBnd, exprBnd, packBnd) <- liftSingleDataCon b dcon bnds expr
496 (permBnds, exprBnds, packBnds) <- liftCaseDataCon' b alts
497 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
500 -- FIXME: is is really necessary to return the binding to the permutation
501 -- array in the data constructor case, as the representation already
502 -- contains the extended flag vector
503 liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
504 Flatten (CoreBind, CoreBind, [CoreBind])
505 liftSingleDataCon b dcon bnds expr =
507 let dconId = dataConTag dcon
508 indexExpr <- mkIndexOfExprDCon (idType b) b dconId
509 (bb, bbind) <- mkBind FSLIT("is") indexExpr
510 lbnds <- mapM liftBinderType bnds
511 ((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr))
512 (_, vbind) <- mkBind FSLIT("r") lExpr
513 return (bbind, vbind, bnds')
515 -- FIXME: clean this up. the datacon and the literal case are so
516 -- similar that it would be easy to use the same function here
517 -- instead of duplicating all the code.
519 liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
520 -> Flatten (CoreBind, CoreBind, [CoreBind])
521 liftCaseDataConDefault b (_, _, def) alts =
523 let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts
524 indexExpr <- mkIndexOfExprDConDft (idType b) b dconIds
525 (bb, bbind) <- mkBind FSLIT("is") indexExpr
526 ((lDef, _), bnds) <- packContext bb (lift def)
527 (_, vbind) <- mkBind FSLIT("r") lDef
528 return (bbind, vbind, bnds)
530 -- liftCaseLit: checks if we have a default case and handles it
532 liftCaseLit:: CoreBndr -> [Alt CoreBndr] ->
533 Flatten ([CoreBind], [CoreBind], [CoreBind])
535 return ([], [], []) --FIXME: a case with no cases at all???
536 liftCaseLit b alls@(alt:alts)
539 (i, e, defAltBndrs) <- liftCaseLitDefault b alt alts
540 (is, es, altBndrs) <- liftCaseLit' b alts
541 return (i:is, e:es, defAltBndrs ++ altBndrs)
546 -- liftCaseLitDefault: looks at all the other alternatives which
547 -- contain a literal and filters all those elements from the
548 -- array which do not match any of the literals in the other
550 liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr]
551 -> Flatten (CoreBind, CoreBind, [CoreBind])
552 liftCaseLitDefault b (_, _, def) alts =
554 let lits = map (\(LitAlt l, _, _) -> l) alts
555 indexExpr <- mkIndexOfExprDft (idType b) b lits
556 (bb, bbind) <- mkBind FSLIT("is") indexExpr
557 ((lDef, _), bnds) <- packContext bb (lift def)
558 (_, vbind) <- mkBind FSLIT("r") lDef
559 return (bbind, vbind, bnds)
562 -- Assumption: in case of Lit, the list of binders of the alt is empty.
565 -- a list of all vars bound to the expr in the body of the alternative
566 -- a list of (var, expr) pairs, where var has to be bound to expr
568 liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->
569 Flatten ([CoreBind], [CoreBind], [CoreBind])
573 liftCaseLit' b ((LitAlt lit, [], expr):alts) =
575 (permBnd, exprBnd, packBnd) <- liftSingleCaseLit b lit expr
576 (permBnds, exprBnds, packBnds) <- liftCaseLit' b alts
577 return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
579 -- lift a single alternative of the form: case b of lit -> expr.
581 -- It returns the bindings:
582 -- (a) let b' = indexOfP (mapP (\x -> x == lit) b)
584 -- (b) lift expr in the packed context. Returns lexpr and the
585 -- list of binds (bnds) that describe the packed arrays
587 -- (c) create new var v' to bind lexpr to
589 -- (d) return (b' = indexOf...., v' = lexpr, bnds)
590 liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr ->
591 Flatten (CoreBind, CoreBind, [CoreBind])
592 liftSingleCaseLit b lit expr =
594 indexExpr <- mkIndexOfExpr (idType b) b lit -- (a)
595 (bb, bbind) <- mkBind FSLIT("is") indexExpr
596 ((lExpr, t), bnds) <- packContext bb (lift expr) -- (b)
597 (_, vbind) <- mkBind FSLIT("r") lExpr
598 return (bbind, vbind, bnds)
600 -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
603 -- let index_bnd_1 in
606 -- let exprbnd_1 in ....
608 -- let nvar = replicate dummy (length <current context>)
609 -- nvar1 = bpermuteDftP index_bnd_1 ...
611 -- in bpermuteDftP index_bnd_n nvar_(n-1)
613 letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
614 Flatten (CoreExpr, Type)
615 letWrapper lExpr b (indBnds, exprBnds, pckBnds) =
617 (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
618 let resExpr = getExprOfBind (head defBpBnds)
619 return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
621 -- dftbpBinders: return the list of binders necessary to construct the overall
622 -- result from the subresults computed in the different branches of the case
623 -- statement. The binding which contains the final result is in the *head*
624 -- of the result list.
626 -- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
628 -- let def = replicate (length of context) undefined
629 -- d1 = bpermuteDftP dft e1 i1
632 dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
633 dftbpBinders indexBnds exprBnds =
635 let expr = getExprOfBind (head exprBnds)
636 defVecExpr <- createDftArrayBind expr
637 ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
640 dftbpBinders' :: [CoreBind]
643 -> Flatten ((CoreBind, [CoreBind]), Type)
644 dftbpBinders' [] [] cBnd =
645 return ((cBnd, []), panic "dftbpBinders: undefined type")
646 dftbpBinders' (i:is) (e:es) cBind =
648 let iVar = getVarOfBind i
649 let eVar = getVarOfBind e
650 let cVar = getVarOfBind cBind
652 newBnd <- mkDftBackpermute ty iVar eVar cVar
653 ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
654 return ((fBnd, (newBnd:restBnds)), liftTy ty)
656 dftbpBinders' _ _ _ =
657 panic "Flattening.dftbpBinders: index and expression binder lists have different length!"
659 getExprOfBind:: CoreBind -> CoreExpr
660 getExprOfBind (NonRec _ expr) = expr
662 getVarOfBind:: CoreBind -> Var
663 getVarOfBind (NonRec b _) = b
667 -- Optimised Transformation
668 -- =========================
672 -- if variables x_1 to x_i occur in the context *and* free in expr
674 -- (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn)
676 liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type)
677 liftSimpleFun b expr =
679 bndVars <- collectBoundVars expr
680 let bndVars' = b:bndVars
681 bndVarsTuple = mkTuple (map idType bndVars') (map Var bndVars')
682 lamExpr = mkLams (b:bndVars) expr -- FIXME: should be tuple
684 let (t1, t2) = funTyArgs . exprType $ lamExpr
685 mapExpr <- mk'mapP t1 t2 lamExpr bndVarsTuple
686 let lexpr = mkApps mapExpr [bndVarsTuple]
687 return (lexpr, undefined) -- FIXME!!!!!
690 collectBoundVars:: CoreExpr -> Flatten [CoreBndr]
691 collectBoundVars expr =
692 intersectWithContext (exprFreeVars expr)
695 -- auxilliary routines
696 -- -------------------
698 -- mkIndexOfExpr b lit ->
699 -- indexOf (mapP (\x -> x == lit) b) b
701 mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
702 mkIndexOfExpr idType b lit =
704 eqExpr <- mk'eq idType (Var b) (Lit lit)
705 let lambdaExpr = (Lam b eqExpr)
706 mk'indexOfP idType lambdaExpr (Var b)
708 -- there is FlattenMonad.mk'indexOfP as well as
709 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
711 -- for case-distinction over data constructors:
715 -- dconId = dataConTag dcon
716 -- the call "mkIndexOfExprDCon b dconId" computes the core expression for
717 -- indexOfP (\x -> x == dconId) b)
719 mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr
720 mkIndexOfExprDCon idType b dId =
722 let intExpr = mkIntLitInt dId
723 eqExpr <- mk'eq idType (Var b) intExpr
724 let lambdaExpr = (Lam b intExpr)
725 mk'indexOfP idType lambdaExpr (Var b)
729 -- there is FlattenMonad.mk'indexOfP as well as
730 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
732 -- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the
733 -- default case. "dconIds" is a list of all the data constructor idents which
734 -- are covered by the other cases.
735 -- indexOfP (\x -> x != dconId_1 && ....) b)
737 mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
738 mkIndexOfExprDConDft idType b dId =
740 let intExprs = map mkIntLitInt dId
741 bExpr <- foldM (mk'neq idType) (head intExprs) (tail intExprs)
742 let lambdaExpr = (Lam b bExpr)
743 mk'indexOfP idType (Var b) bExpr
746 -- mkIndexOfExprDef b [lit1, lit2,...] ->
747 -- indexOf (\x -> not (x == lit1 || x == lit2 ....) b
748 mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
749 mkIndexOfExprDft idType b lits =
751 let litExprs = map (\l-> Lit l) lits
752 bExpr <- foldM (mk'neq idType) (head litExprs) (tail litExprs)
753 let lambdaExpr = (Lam b bExpr)
754 mk'indexOfP idType bExpr (Var b)
757 -- create a back-permute binder
759 -- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
760 -- Core binding of the form
762 -- x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
764 -- where `x' is a new local variable
766 mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind
767 mkDftBackpermute ty idx src dft =
769 rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft)
770 liftM snd $ mkBind FSLIT("dbp") rhs
772 -- create a dummy array with elements of the given type, which can be used as
773 -- default array for the combination of the subresults of the lifted case
776 createDftArrayBind :: CoreExpr -> Flatten CoreBind
777 createDftArrayBind e =
778 panic "Flattening.createDftArrayBind: not implemented yet"
781 let ty = parrElemTy . exprType $ expr
783 rhs <- mk'replicateP ty len err??
784 lift snd $ mkBind FSLIT("dft") rhs
785 FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde
786 beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen
787 generischen Wert f"ur jeden beliebigen Typ zu erfinden.
793 -- show functions (the pretty print functions sometimes don't
794 -- show it the way I want....
796 -- shows just the structure
797 showCoreExpr (Var _ ) = "Var "
798 showCoreExpr (Lit _) = "Lit "
799 showCoreExpr (App e1 e2) =
800 "(App \n " ++ (showCoreExpr e1) ++ "\n " ++ (showCoreExpr e2) ++ ") "
801 showCoreExpr (Lam b e) =
802 "Lam b " ++ (showCoreExpr e)
803 showCoreExpr (Let bnds expr) =
804 "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr)
805 where showBinds (NonRec b e) = showBind (b,e)
806 showBinds (Rec bnds) = concat (map showBind bnds)
807 showBind (b,e) = " b = " ++ (showCoreExpr e)++ "\n"
809 showCoreExpr (Case ex b ty alts) =
810 "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
811 where showAlts _ = ""
812 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
813 showCoreExpr (Type t) = "Type"