2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[DefExpr]{Transformation Algorithm for Expressions}
6 >#include "HsVersions.h"
15 > import Core2Def ( c2d ) -- for unfoldings
19 > import Type ( applyTypeEnvToTy, isPrimType,
21 > IF_ATTACK_PRAGMAS(COMMA cmpUniType)
23 > import CmdLineOpts ( SwitchResult, switchIsOn )
24 > import CoreUnfold ( UnfoldingDetails(..) )
25 > import CoreUtils ( mkValLam, unTagBinders, coreExprType )
26 > import Id ( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id,
29 > import Inst -- Inst(..)
31 > import Maybes ( Maybe(..) )
40 -----------------------------------------------------------------------------
41 Top level transformation
43 A type environment mapping type variables to types is carried around.
44 This is extended by one rule only: reduction of a type application.
47 > :: SwitchChecker who_knows
48 > -> IdEnv DefExpr -- Environment
49 > -> TypeEnv -- Type environment
50 > -> DefExpr -- input expression
51 > -> [DefCoreArg] -- args
54 > tran sw p t e@(Var (DefArgVar id)) as =
57 > mapArgs (\e -> tran sw p t e []) as `thenUs` \as ->
58 > returnUs (mkGenApp (Var (DefArgVar new_id)) as)
62 > tran sw p t e as `thenUs` \e ->
63 > returnUs (mkLabel (mkGenApp (Var (DefArgVar new_id))
64 > (map (substTyArg t) as))
67 > where new_id = applyTypeEnvToId t id
69 > tran sw p t e@(Lit l) [] =
72 > tran sw p t (Con c ts es) [] =
73 > mapUs (tranAtom sw p t) es `thenUs` \es ->
74 > returnUs (Con c (map (applyTypeEnvToTy t) ts) es)
76 > tran sw p t (Prim op ts es) [] = -- XXX constant folding?
77 > mapUs (tranAtom sw p t) es `thenUs` \es ->
78 > returnUs (Prim op (map (applyTypeEnvToTy t) ts) es)
80 > tran sw p t (Lam vs e) [] =
81 > tran sw p t e [] `thenUs` \e ->
82 > returnUs (mkValLam (map (applyTypeEnvToId t) vs) e)
84 > tran sw p t (Lam vs e) as =
85 > subst s e `thenUs` \e ->
86 > tran sw p t (mkValLam rvs e) ras
88 > (rvs,ras,s) = mkSubst vs as []
90 > tran sw p t (CoTyLam alpha e) [] =
91 > tran sw p t e [] `thenUs` \e ->
92 > returnUs (CoTyLam alpha e)
95 ToDo: use the environment rather than doing explicit substitution
96 (didn't work last time I tried :)
98 > tran sw p t (CoTyLam alpha e) (TypeArg ty : as) =
99 > tran sw p t (applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e) as
101 > tran sw p t (App e v) as =
102 > maybeJumbleApp e v `thenUs` \j ->
104 > Nothing -> tran sw p t e (ValArg v : as)
105 > Just e' -> tran sw p t e' as
107 > tran sw p t (CoTyApp e ty) as =
108 > tran sw p t e (TypeArg (applyTypeEnvToTy t ty) : as)
110 > tran sw p t (Let (NonRec v e) e') as =
111 > tran sw p t e [] `thenUs` \e ->
112 > if isConstant e then
114 > subst [(v,removeLabels e)] e' `thenUs` \e' ->
117 > tran sw p t e' as `thenUs` \e' ->
118 > returnUs (Let (NonRec (applyTypeEnvToId t v) e) e')
120 > tran sw p t (Let (Rec bs) e) as =
121 > tranRecBinds sw p t bs e `thenUs` \(p',resid,e) ->
122 > tran sw p' t e as `thenUs` \e ->
123 > returnUs (mkDefLetrec resid e)
125 > tran sw p t (SCC l e) as =
126 > tran sw p t e [] `thenUs` \e ->
127 > mapArgs (\e -> tran sw p t e []) as `thenUs` \as ->
128 > returnUs (mkGenApp (SCC l e) as)
130 > tran sw p t (Case e ps) as =
131 > tranCase sw p t e [] ps as
134 > defPanic "DefExpr" "tran" (mkGenApp e as)
136 -----------------------------------------------------------------------------
137 Transformation for case expressions of the form (case e1..en of {..})
140 > :: SwitchChecker who_knows
145 > -> DefCaseAlternatives
149 > tranCase sw p t e bs ps as = case e of
151 > Var (DefArgVar id) ->
154 > tranAlts sw p t ps as `thenUs` \ps ->
155 > mapArgs (\e -> tran sw p t e []) bs `thenUs` \bs ->
158 > (mkGenApp (Var (DefArgVar
159 > (applyTypeEnvToId t id)))
165 > tranCase sw p t e bs ps as `thenUs` \e ->
169 > (Case (mkGenApp (Var (DefArgVar id))
170 > (map (substTyArg t) bs))
172 > (map (substTyArg t) as))
178 > [] -> tranAlts sw p t ps as `thenUs` \ps ->
179 > returnUs (Case e ps)
184 > [] -> tranAlts sw p t ps as `thenUs` \ps ->
185 > mapUs (tranAtom sw p t) es `thenUs` \es ->
186 > returnUs (Case (Prim op
187 > (map (applyTypeEnvToTy t) ts) es) ps)
193 > AlgAlts alts def ->
194 > reduceCase sw p c ts es alts def as
195 > PrimAlts alts def -> die_horribly
201 > (TypeArg _ : _) -> die_horribly
202 > _ -> subst s e `thenUs` \e ->
203 > tranCase sw p t e rbs ps as
205 > (rvs,rbs,s) = mkSubst vs bs []
209 > TypeArg ty : bs' -> tranCase sw p t e' bs' ps as
210 > where e' = applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e
214 > maybeJumbleApp e v `thenUs` \j ->
216 > Nothing -> tranCase sw p t e (ValArg v : bs) ps as
217 > Just e' -> tranCase sw p t e' bs ps as
220 > tranCase sw p t e (TypeArg (applyTypeEnvToTy t ty) : bs)
223 > Let (NonRec v e) e' ->
224 > tran sw p t e [] `thenUs` \e ->
225 > if isConstant e then
226 > trace "yippee2!!" $
227 > subst [(v,removeLabels e)] e' `thenUs` \e' ->
228 > tranCase sw p t e' bs ps as
230 > tranCase sw p t e' bs ps as `thenUs` \e' ->
231 > returnUs (Let (NonRec
232 > (applyTypeEnvToId t v) e) e')
234 > Let (Rec binds) e ->
235 > tranRecBinds sw p t binds e `thenUs` \(p',resid,e) ->
236 > tranCase sw p' t e bs ps as `thenUs` \e ->
237 > returnUs (mkDefLetrec resid e)
239 > -- ToDo: sort out cost centres. Currently they act as a barrier
240 > -- to optimisation.
242 > tran sw p t e [] `thenUs` \e ->
243 > mapArgs (\e -> tran sw p t e []) bs
245 > tranAlts sw p t ps as `thenUs` \ps ->
246 > returnUs (Case (mkGenApp (SCC l e) bs)
250 > tranCase sw p t e []
251 > (mapAlts (\e -> mkGenApp (Case e ps) bs) ps') as
255 > where die_horribly = defPanic "DefExpr" "tranCase"
256 > (mkGenApp (Case (mkGenApp e bs) ps) as)
258 -----------------------------------------------------------------------------
259 Deciding whether or not to replace a function variable with it's
260 definition. The tranVar function is passed four arguments: the
261 environment, the Id itself, the expression to return if no
262 unfolding takes place, and a function to apply to the unfolded expression
263 should an unfolding be required.
266 > :: SwitchChecker who_knows
270 > -> (DefExpr -> UniqSM DefExpr)
273 > tranVar sw p id no_unfold unfold_with =
275 > case lookupIdEnv p id of
277 > rebindExpr e' `thenUs` \e' ->
279 > then unfold_with e'
280 > else panic "DefExpr(tran): not deforestable id in env"
282 No mapping in the environment, but it could be an
283 imported function that was annotated with DEFOREST,
284 in which case it will have an unfolding inside the Id
288 > if (not . deforestable) id
291 > else case (getIdUnfolding id) of
292 > GenForm _ _ expr guidance ->
293 > panic "DefExpr:GenForm has changed a little; needs mod here"
296 >--??? -- ToDo: too much overhead here.
297 >--??? let e' = c2d nullIdEnv expr in
298 >--??? convertToTreelessForm sw e' `thenUs` \e'' ->
299 >--??? unfold_with e''
302 If the unfolding isn't present, this is
303 a sign that the function is from this module and
304 is not in the environemnt yet (maybe because
305 we are transforming the body of the definition
309 > ("DefExpr(tran): Deforestable id `"
310 > ++ ppShow 80 (ppr PprDebug id)
311 > ++ "' doesn't have an unfolding.") -}
313 -----------------------------------------------------------------------------
314 Transform a set of case alternatives.
317 > :: SwitchChecker who_knows
320 > -> DefCaseAlternatives
322 > -> UniqSM DefCaseAlternatives
324 > tranAlts sw p t (AlgAlts alts def) as =
325 > mapUs (tranAlgAlt sw p t as) alts `thenUs` \alts ->
326 > tranDefault sw p t def as `thenUs` \def ->
327 > returnUs (AlgAlts alts def)
328 > tranAlts sw p t (PrimAlts alts def) as =
329 > mapUs (tranPrimAlt sw p t as) alts `thenUs` \alts ->
330 > tranDefault sw p t def as `thenUs` \def ->
331 > returnUs (PrimAlts alts def)
333 > tranAlgAlt sw p t as (c, vs, e) =
334 > tran sw p t e as `thenUs` \e ->
335 > returnUs (c, map (applyTypeEnvToId t) vs, e)
336 > tranPrimAlt sw p t as (l, e) =
337 > tran sw p t e as `thenUs` \e ->
340 > tranDefault sw p t NoDefault as = returnUs NoDefault
341 > tranDefault sw p t (BindDefault v e) as =
342 > tran sw p t e as `thenUs` \e ->
343 > returnUs (BindDefault (applyTypeEnvToId t v) e)
345 -----------------------------------------------------------------------------
349 > :: SwitchChecker who_knows
355 > tranAtom sw p t (VarArg v) =
356 > tranArg sw p t v `thenUs` \v ->
357 > returnUs (VarArg v)
358 > tranAtom sw p t e@(LitArg l) = -- XXX
361 > tranArg sw p t (DefArgExpr e) =
362 > tran sw p t e [] `thenUs` \e ->
363 > returnUs (DefArgExpr e)
364 > tranArg sw p t e@(Label _ _) =
365 > defPanic "DefExpr" "tranArg" (Var e)
366 > tranArg sw p t (DefArgVar v) =
367 > tran sw p t (Var (DefArgVar v)) [] `thenUs` \e ->
368 > returnUs (DefArgExpr e) -- XXX remove this case
370 -----------------------------------------------------------------------------
371 Translating recursive definition groups.
373 We first transform each binding, and then seperate the results into
374 deforestable and non-deforestable sets of bindings. The deforestable
375 bindings are processed by the knot-tyer, and added to the current
376 environment. The rest of the bindings are returned as residual.
378 ToDo: conversion to treeless form should be unnecessary here, becuase
379 the transformer/knot-tyer should leave things in treeless form.
381 > tranRecBinds sw p t bs e =
383 Transform all the deforestable definitions, yielding
385 list of extracted functions = concat extracted ok, so let's get the
386 total set of free variables of the whole function set, call this set
387 fvs. Expand the argument list of each function by
389 and substitute the new function calls throughout the function set.
393 > (unfold,resid) = partition (deforestable . fst) bs
396 > mapUs (tranRecBind sw p t) unfold `thenUs` \unfold ->
397 > mapUs (tranRecBind sw p t) resid `thenUs` \resid ->
399 Tie knots in the deforestable right-hand sides, and convert the
400 results to treeless form. Then extract any nested deforestable
401 recursive functions, and place everything we've got in the new
404 > let (vs,es) = unzip unfold in
405 > mapUs mkLoops es `thenUs` \res ->
407 > (extracted,new_rhss) = unzip res
408 > new_binds = zip vs new_rhss ++ concat extracted
411 Convert everything to treeless form (these functions aren't
412 necessarily already in treeless form because the functions
413 bound in this letrec are about to change status from not
414 unfolded to unfolded).
417 > convertToTreelessForm sw e `thenUs` \e ->
418 > returnUs (v,e)) new_binds `thenUs` \fs ->
420 Now find the total set of free variables of this function set.
423 > fvs = filter (\id -> isArgId id{- && (not . isLitId) id-})
424 > (foldr union [] (map freeVars (map snd fs)))
427 Now expand the argument lists to include the total set of free vars.
430 > stuff = [ fixupFreeVars fvs id e | (id,e) <- fs ]
431 > fs' = map fst stuff
432 > s = concat (map snd stuff)
433 > subIt (id,e) = subst s e `thenUs` \e -> returnUs (id,e)
435 > subst s e `thenUs` \e ->
436 > mapUs subIt resid `thenUs` \resid ->
437 > mapUs subIt fs' `thenUs` \fs ->
439 > let res = returnUs (growIdEnvList p fs, resid, e) in
441 > (evs,ees) -> mapUs d2c ees `thenUs` \ees ->
442 > let (vs',es') = unzip bs in
443 > mapUs d2c es' `thenUs` \es' ->
444 > trace ("extraction "
445 > ++ showIds (map fst bs)
447 > ++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n"
448 > ++ "{ result:\n" ++ (concat (map showBind (zip evs ees))) ++ "}\n") res
449 > where showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
451 > tranRecBind sw p t (id,e) =
452 > tran sw p t e [] `thenUs` \e ->
453 > returnUs (applyTypeEnvToId t id,e)
455 > showIds :: [Id] -> String
456 > showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids)
459 -----------------------------------------------------------------------------
461 > reduceCase sw p c ts es alts def as =
462 > case [ a | a@(c',vs,e) <- alts, c' == c ] of
464 > subst (zip vs (map atom2expr es)) e `thenUs` \e ->
465 > tran sw p nullTyVarEnv e as
468 > panic "DefExpr(reduceCase): no match"
470 > subst [(v,Con c ts es)] e `thenUs` \e ->
471 > tran sw p nullTyVarEnv e as
472 > _ -> panic "DefExpr(reduceCase): multiple matches"
474 -----------------------------------------------------------------------------
482 > applyTypeEnvToExpr p e = substTy e
484 > substTy e' = case e' of
485 > Var (DefArgExpr e) -> panic "DefExpr(substTy): Var (DefArgExpr _)"
486 > Var (Label l e) -> panic "DefExpr(substTy): Var (Label _ _)"
487 > Var (DefArgVar id) -> Var (DefArgVar (applyTypeEnvToId p id))
490 > Con c (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
492 > Prim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
493 > Lam vs e -> Lam (map (applyTypeEnvToId p) vs) (substTy e)
494 > CoTyLam alpha e -> CoTyLam alpha (substTy e)
495 > App e v -> App (substTy e) (substTyAtom v)
496 > CoTyApp e t -> CoTyApp (substTy e) (applyTypeEnvToTy p t)
497 > Case e ps -> Case (substTy e) (substTyCaseAlts ps)
498 > Let (NonRec id e) e' ->
499 > Let (NonRec (applyTypeEnvToId p id) (substTy e))
502 > Let (Rec (map substTyRecBind bs)) (substTy e)
503 > where substTyRecBind (v,e) = (applyTypeEnvToId p v, substTy e)
504 > SCC l e -> SCC l (substTy e)
506 > substTyAtom :: DefAtom -> DefAtom
507 > substTyAtom (VarArg v) = VarArg (substTyArg v)
508 > substTyAtom (LitArg l) = LitArg l -- XXX
510 > substTyArg :: DefBindee -> DefBindee
511 > substTyArg (DefArgExpr e) = DefArgExpr (substTy e)
512 > substTyArg e@(Label _ _) = panic "DefExpr(substArg): Label _ _"
513 > substTyArg e@(DefArgVar id) = -- XXX
514 > DefArgVar (applyTypeEnvToId p id)
516 > substTyCaseAlts (AlgAlts as def)
517 > = AlgAlts (map substTyAlgAlt as) (substTyDefault def)
518 > substTyCaseAlts (PrimAlts as def)
519 > = PrimAlts (map substTyPrimAlt as) (substTyDefault def)
521 > substTyAlgAlt (c, vs, e) = (c, map (applyTypeEnvToId p) vs, substTy e)
522 > substTyPrimAlt (l, e) = (l, substTy e)
524 > substTyDefault NoDefault = NoDefault
525 > substTyDefault (BindDefault id e) =
526 > BindDefault (applyTypeEnvToId p id) (substTy e)
528 > substTyArg t (ValArg e) =
529 > ValArg (VarArg (DefArgExpr (applyTypeEnvToExpr t (atom2expr e))))
530 > substTyArg t (TypeArg ty) = TypeArg ty
532 -----------------------------------------------------------------------------
534 > mapAlts f ps = case ps of
535 > AlgAlts alts def ->
536 > AlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def)
537 > PrimAlts alts def ->
538 > PrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def)
540 > mapDef f NoDefault = NoDefault
541 > mapDef f (BindDefault v e) = BindDefault v (f e)
543 -----------------------------------------------------------------------------
544 Apply a function to all the ValArgs in an Args list.
547 > :: (DefExpr -> UniqSM DefExpr)
549 > -> UniqSM [DefCoreArg]
553 > mapArgs f (a@(TypeArg ty) : as) =
554 > mapArgs f as `thenUs` \as ->
556 > mapArgs f (ValArg v : as) =
557 > f (atom2expr v) `thenUs` \e ->
558 > mapArgs f as `thenUs` \as ->
559 > returnUs (ValArg (VarArg (DefArgExpr e)) : as)
562 > mkSubst [] as s = ([],as,s)
563 > mkSubst vs [] s = (vs,[],s)
564 > mkSubst (v:vs) (ValArg e:as) s = mkSubst vs as ((v,atom2expr e):s)
566 -----------------------------------------------------------------------------
568 The next function does a bit of extraction for applicative terms
569 before they are transformed. We look for boring expressions - those
570 that won't be any use in removing intermediate data structures. These
571 include applicative terms where we cannot unfold the head,
572 non-reducible case expressions, primitive applications and some let
575 Extracting these expressions helps the knot-tyer to find loops
576 earlier, and avoids the need to do matching instead of renaming.
578 We also pull out lets from function arguments, and primitive case
579 expressions (which can't fail anyway).
583 (t (case u of x -> v))
587 Maybe shouldn't do this if -fpedantic-bottoms? Also can't do it if u
590 ToDo: sort this mess out - could be more efficient.
592 > maybeJumbleApp :: DefExpr -> DefAtom -> UniqSM (Maybe DefExpr)
593 > maybeJumbleApp e (LitArg _) = returnUs Nothing -- ToDo remove
594 > maybeJumbleApp e (VarArg (DefArgExpr (Var (DefArgVar _))))
596 > maybeJumbleApp e (VarArg (DefArgExpr t))
597 > = let t' = pull_out t [] in
599 > Let _ _ -> returnUs (Just t')
600 > Case (Prim _ _ _) (PrimAlts [] _) -> returnUs (Just t')
601 > _ -> if isBoringExpr t then
606 > where isBoringExpr (Var (DefArgVar z)) = (not . deforestable) z
607 > isBoringExpr (Prim op ts es) = True
608 > isBoringExpr (Case e ps) = isBoringExpr e
609 > && boringCaseAlternatives ps
610 > isBoringExpr (App l r) = isBoringExpr l
611 > isBoringExpr (CoTyApp l t) = isBoringExpr l
612 > isBoringExpr _ = False
614 > boringCaseAlternatives (AlgAlts as d) =
615 > all boringAlgAlt as && boringDefault d
616 > boringCaseAlternatives (PrimAlts as d) =
617 > all boringPrimAlt as && boringDefault d
619 > boringAlgAlt (c,xs,e) = isBoringExpr e
620 > boringPrimAlt (l,e) = isBoringExpr e
622 > boringDefault NoDefault = True
623 > boringDefault (BindDefault x e) = isBoringExpr e
625 > pull_out (Let b t) as = Let b (pull_out t as)
626 > pull_out (App l r) as = pull_out l (r:as)
627 > pull_out (Case prim@(Prim _ _ _)
628 > (PrimAlts [] (BindDefault x u))) as
629 > = Case prim (PrimAlts [] (BindDefault x
632 > = App e (VarArg (DefArgExpr (foldl App t as)))
634 > rebind_with_let t =
635 > d2c t `thenUs` \core_t ->
636 > newDefId (coreExprType core_t) `thenUs` \x ->
637 > trace "boring epxr found!" $
638 > returnUs (Just (Let (NonRec x t)
643 -----------------------------------------------------------------------------
645 > isLitId id = case isInstId_maybe id of
646 > Just (LitInst _ _ _ _) -> True
649 > isConstant (Con c [] []) = True
650 > isConstant (Lit l) = True
651 > isConstant (Var (Label l e)) = isConstant e
652 > isConstant _ = False
654 > removeLabels (Var (Label l e)) = removeLabels e