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,
22 > import CmdLineOpts ( SwitchResult, switchIsOn )
23 > import CoreUnfold ( UnfoldingDetails(..) )
24 > import CoreUtils ( mkValLam, unTagBinders, coreExprType )
25 > import Id ( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id,
28 > import Inst -- Inst(..)
30 > import Maybes ( Maybe(..) )
39 -----------------------------------------------------------------------------
40 Top level transformation
42 A type environment mapping type variables to types is carried around.
43 This is extended by one rule only: reduction of a type application.
46 > :: SwitchChecker who_knows
47 > -> IdEnv DefExpr -- Environment
48 > -> TypeEnv -- Type environment
49 > -> DefExpr -- input expression
50 > -> [DefCoreArg] -- args
53 > tran sw p t e@(Var (DefArgVar id)) as =
56 > mapArgs (\e -> tran sw p t e []) as `thenUs` \as ->
57 > returnUs (mkGenApp (Var (DefArgVar new_id)) as)
61 > tran sw p t e as `thenUs` \e ->
62 > returnUs (mkLabel (mkGenApp (Var (DefArgVar new_id))
63 > (map (substTyArg t) as))
66 > where new_id = applyTypeEnvToId t id
68 > tran sw p t e@(Lit l) [] =
71 > tran sw p t (Con c ts es) [] =
72 > mapUs (tranAtom sw p t) es `thenUs` \es ->
73 > returnUs (Con c (map (applyTypeEnvToTy t) ts) es)
75 > tran sw p t (Prim op ts es) [] = -- XXX constant folding?
76 > mapUs (tranAtom sw p t) es `thenUs` \es ->
77 > returnUs (Prim op (map (applyTypeEnvToTy t) ts) es)
79 > tran sw p t (Lam vs e) [] =
80 > tran sw p t e [] `thenUs` \e ->
81 > returnUs (mkValLam (map (applyTypeEnvToId t) vs) e)
83 > tran sw p t (Lam vs e) as =
84 > subst s e `thenUs` \e ->
85 > tran sw p t (mkValLam rvs e) ras
87 > (rvs,ras,s) = mkSubst vs as []
89 > tran sw p t (CoTyLam alpha e) [] =
90 > tran sw p t e [] `thenUs` \e ->
91 > returnUs (CoTyLam alpha e)
94 ToDo: use the environment rather than doing explicit substitution
95 (didn't work last time I tried :)
97 > tran sw p t (CoTyLam alpha e) (TypeArg ty : as) =
98 > tran sw p t (applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e) as
100 > tran sw p t (App e v) as =
101 > maybeJumbleApp e v `thenUs` \j ->
103 > Nothing -> tran sw p t e (ValArg v : as)
104 > Just e' -> tran sw p t e' as
106 > tran sw p t (CoTyApp e ty) as =
107 > tran sw p t e (TypeArg (applyTypeEnvToTy t ty) : as)
109 > tran sw p t (Let (NonRec v e) e') as =
110 > tran sw p t e [] `thenUs` \e ->
111 > if isConstant e then
113 > subst [(v,removeLabels e)] e' `thenUs` \e' ->
116 > tran sw p t e' as `thenUs` \e' ->
117 > returnUs (Let (NonRec (applyTypeEnvToId t v) e) e')
119 > tran sw p t (Let (Rec bs) e) as =
120 > tranRecBinds sw p t bs e `thenUs` \(p',resid,e) ->
121 > tran sw p' t e as `thenUs` \e ->
122 > returnUs (mkDefLetrec resid e)
124 > tran sw p t (SCC l e) as =
125 > tran sw p t e [] `thenUs` \e ->
126 > mapArgs (\e -> tran sw p t e []) as `thenUs` \as ->
127 > returnUs (mkGenApp (SCC l e) as)
129 > tran sw p t (Coerce c ty e) as =
130 > panic "DefExpr:tran:Coerce"
132 > tran sw p t (Case e ps) as =
133 > tranCase sw p t e [] ps as
136 > defPanic "DefExpr" "tran" (mkGenApp e as)
138 -----------------------------------------------------------------------------
139 Transformation for case expressions of the form (case e1..en of {..})
142 > :: SwitchChecker who_knows
147 > -> DefCaseAlternatives
151 > tranCase sw p t e bs ps as = case e of
153 > Var (DefArgVar id) ->
156 > tranAlts sw p t ps as `thenUs` \ps ->
157 > mapArgs (\e -> tran sw p t e []) bs `thenUs` \bs ->
160 > (mkGenApp (Var (DefArgVar
161 > (applyTypeEnvToId t id)))
167 > tranCase sw p t e bs ps as `thenUs` \e ->
171 > (Case (mkGenApp (Var (DefArgVar id))
172 > (map (substTyArg t) bs))
174 > (map (substTyArg t) as))
180 > [] -> tranAlts sw p t ps as `thenUs` \ps ->
181 > returnUs (Case e ps)
186 > [] -> tranAlts sw p t ps as `thenUs` \ps ->
187 > mapUs (tranAtom sw p t) es `thenUs` \es ->
188 > returnUs (Case (Prim op
189 > (map (applyTypeEnvToTy t) ts) es) ps)
195 > AlgAlts alts def ->
196 > reduceCase sw p c ts es alts def as
197 > PrimAlts alts def -> die_horribly
203 > (TypeArg _ : _) -> die_horribly
204 > _ -> subst s e `thenUs` \e ->
205 > tranCase sw p t e rbs ps as
207 > (rvs,rbs,s) = mkSubst vs bs []
211 > TypeArg ty : bs' -> tranCase sw p t e' bs' ps as
212 > where e' = applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e
216 > maybeJumbleApp e v `thenUs` \j ->
218 > Nothing -> tranCase sw p t e (ValArg v : bs) ps as
219 > Just e' -> tranCase sw p t e' bs ps as
222 > tranCase sw p t e (TypeArg (applyTypeEnvToTy t ty) : bs)
225 > Let (NonRec v e) e' ->
226 > tran sw p t e [] `thenUs` \e ->
227 > if isConstant e then
228 > trace "yippee2!!" $
229 > subst [(v,removeLabels e)] e' `thenUs` \e' ->
230 > tranCase sw p t e' bs ps as
232 > tranCase sw p t e' bs ps as `thenUs` \e' ->
233 > returnUs (Let (NonRec
234 > (applyTypeEnvToId t v) e) e')
236 > Let (Rec binds) e ->
237 > tranRecBinds sw p t binds e `thenUs` \(p',resid,e) ->
238 > tranCase sw p' t e bs ps as `thenUs` \e ->
239 > returnUs (mkDefLetrec resid e)
241 > -- ToDo: sort out cost centres. Currently they act as a barrier
242 > -- to optimisation.
244 > tran sw p t e [] `thenUs` \e ->
245 > mapArgs (\e -> tran sw p t e []) bs
247 > tranAlts sw p t ps as `thenUs` \ps ->
248 > returnUs (Case (mkGenApp (SCC l e) bs)
251 > Coerce _ _ _ -> panic "DefExpr:tranCase:Coerce"
254 > tranCase sw p t e []
255 > (mapAlts (\e -> mkGenApp (Case e ps) bs) ps') as
259 > where die_horribly = defPanic "DefExpr" "tranCase"
260 > (mkGenApp (Case (mkGenApp e bs) ps) as)
262 -----------------------------------------------------------------------------
263 Deciding whether or not to replace a function variable with it's
264 definition. The tranVar function is passed four arguments: the
265 environment, the Id itself, the expression to return if no
266 unfolding takes place, and a function to apply to the unfolded expression
267 should an unfolding be required.
270 > :: SwitchChecker who_knows
274 > -> (DefExpr -> UniqSM DefExpr)
277 > tranVar sw p id no_unfold unfold_with =
279 > case lookupIdEnv p id of
281 > rebindExpr e' `thenUs` \e' ->
283 > then unfold_with e'
284 > else panic "DefExpr(tran): not deforestable id in env"
286 No mapping in the environment, but it could be an
287 imported function that was annotated with DEFOREST,
288 in which case it will have an unfolding inside the Id
292 > if (not . deforestable) id
295 > else case (getIdUnfolding id) of
296 > GenForm _ _ expr guidance ->
297 > panic "DefExpr:GenForm has changed a little; needs mod here"
300 >--??? -- ToDo: too much overhead here.
301 >--??? let e' = c2d nullIdEnv expr in
302 >--??? convertToTreelessForm sw e' `thenUs` \e'' ->
303 >--??? unfold_with e''
306 If the unfolding isn't present, this is
307 a sign that the function is from this module and
308 is not in the environemnt yet (maybe because
309 we are transforming the body of the definition
313 > ("DefExpr(tran): Deforestable id `"
314 > ++ ppShow 80 (ppr PprDebug id)
315 > ++ "' doesn't have an unfolding.") -}
317 -----------------------------------------------------------------------------
318 Transform a set of case alternatives.
321 > :: SwitchChecker who_knows
324 > -> DefCaseAlternatives
326 > -> UniqSM DefCaseAlternatives
328 > tranAlts sw p t (AlgAlts alts def) as =
329 > mapUs (tranAlgAlt sw p t as) alts `thenUs` \alts ->
330 > tranDefault sw p t def as `thenUs` \def ->
331 > returnUs (AlgAlts alts def)
332 > tranAlts sw p t (PrimAlts alts def) as =
333 > mapUs (tranPrimAlt sw p t as) alts `thenUs` \alts ->
334 > tranDefault sw p t def as `thenUs` \def ->
335 > returnUs (PrimAlts alts def)
337 > tranAlgAlt sw p t as (c, vs, e) =
338 > tran sw p t e as `thenUs` \e ->
339 > returnUs (c, map (applyTypeEnvToId t) vs, e)
340 > tranPrimAlt sw p t as (l, e) =
341 > tran sw p t e as `thenUs` \e ->
344 > tranDefault sw p t NoDefault as = returnUs NoDefault
345 > tranDefault sw p t (BindDefault v e) as =
346 > tran sw p t e as `thenUs` \e ->
347 > returnUs (BindDefault (applyTypeEnvToId t v) e)
349 -----------------------------------------------------------------------------
353 > :: SwitchChecker who_knows
359 > tranAtom sw p t (VarArg v) =
360 > tranArg sw p t v `thenUs` \v ->
361 > returnUs (VarArg v)
362 > tranAtom sw p t e@(LitArg l) = -- XXX
365 > tranArg sw p t (DefArgExpr e) =
366 > tran sw p t e [] `thenUs` \e ->
367 > returnUs (DefArgExpr e)
368 > tranArg sw p t e@(Label _ _) =
369 > defPanic "DefExpr" "tranArg" (Var e)
370 > tranArg sw p t (DefArgVar v) =
371 > tran sw p t (Var (DefArgVar v)) [] `thenUs` \e ->
372 > returnUs (DefArgExpr e) -- XXX remove this case
374 -----------------------------------------------------------------------------
375 Translating recursive definition groups.
377 We first transform each binding, and then seperate the results into
378 deforestable and non-deforestable sets of bindings. The deforestable
379 bindings are processed by the knot-tyer, and added to the current
380 environment. The rest of the bindings are returned as residual.
382 ToDo: conversion to treeless form should be unnecessary here, becuase
383 the transformer/knot-tyer should leave things in treeless form.
385 > tranRecBinds sw p t bs e =
387 Transform all the deforestable definitions, yielding
389 list of extracted functions = concat extracted ok, so let's get the
390 total set of free variables of the whole function set, call this set
391 fvs. Expand the argument list of each function by
393 and substitute the new function calls throughout the function set.
397 > (unfold,resid) = partition (deforestable . fst) bs
400 > mapUs (tranRecBind sw p t) unfold `thenUs` \unfold ->
401 > mapUs (tranRecBind sw p t) resid `thenUs` \resid ->
403 Tie knots in the deforestable right-hand sides, and convert the
404 results to treeless form. Then extract any nested deforestable
405 recursive functions, and place everything we've got in the new
408 > let (vs,es) = unzip unfold in
409 > mapUs mkLoops es `thenUs` \res ->
411 > (extracted,new_rhss) = unzip res
412 > new_binds = zip vs new_rhss ++ concat extracted
415 Convert everything to treeless form (these functions aren't
416 necessarily already in treeless form because the functions
417 bound in this letrec are about to change status from not
418 unfolded to unfolded).
421 > convertToTreelessForm sw e `thenUs` \e ->
422 > returnUs (v,e)) new_binds `thenUs` \fs ->
424 Now find the total set of free variables of this function set.
427 > fvs = filter (\id -> isArgId id{- && (not . isLitId) id-})
428 > (foldr union [] (map freeVars (map snd fs)))
431 Now expand the argument lists to include the total set of free vars.
434 > stuff = [ fixupFreeVars fvs id e | (id,e) <- fs ]
435 > fs' = map fst stuff
436 > s = concat (map snd stuff)
437 > subIt (id,e) = subst s e `thenUs` \e -> returnUs (id,e)
439 > subst s e `thenUs` \e ->
440 > mapUs subIt resid `thenUs` \resid ->
441 > mapUs subIt fs' `thenUs` \fs ->
443 > let res = returnUs (growIdEnvList p fs, resid, e) in
445 > (evs,ees) -> mapUs d2c ees `thenUs` \ees ->
446 > let (vs',es') = unzip bs in
447 > mapUs d2c es' `thenUs` \es' ->
448 > trace ("extraction "
449 > ++ showIds (map fst bs)
451 > ++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n"
452 > ++ "{ result:\n" ++ (concat (map showBind (zip evs ees))) ++ "}\n") res
453 > where showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
455 > tranRecBind sw p t (id,e) =
456 > tran sw p t e [] `thenUs` \e ->
457 > returnUs (applyTypeEnvToId t id,e)
459 > showIds :: [Id] -> String
460 > showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids)
463 -----------------------------------------------------------------------------
465 > reduceCase sw p c ts es alts def as =
466 > case [ a | a@(c',vs,e) <- alts, c' == c ] of
468 > subst (zip vs (map atom2expr es)) e `thenUs` \e ->
469 > tran sw p nullTyVarEnv e as
472 > panic "DefExpr(reduceCase): no match"
474 > subst [(v,Con c ts es)] e `thenUs` \e ->
475 > tran sw p nullTyVarEnv e as
476 > _ -> panic "DefExpr(reduceCase): multiple matches"
478 -----------------------------------------------------------------------------
486 > applyTypeEnvToExpr p e = substTy e
488 > substTy e' = case e' of
489 > Var (DefArgExpr e) -> panic "DefExpr(substTy): Var (DefArgExpr _)"
490 > Var (Label l e) -> panic "DefExpr(substTy): Var (Label _ _)"
491 > Var (DefArgVar id) -> Var (DefArgVar (applyTypeEnvToId p id))
494 > Con c (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
496 > Prim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
497 > Lam vs e -> Lam (map (applyTypeEnvToId p) vs) (substTy e)
498 > CoTyLam alpha e -> CoTyLam alpha (substTy e)
499 > App e v -> App (substTy e) (substTyAtom v)
500 > CoTyApp e t -> CoTyApp (substTy e) (applyTypeEnvToTy p t)
501 > Case e ps -> Case (substTy e) (substTyCaseAlts ps)
502 > Let (NonRec id e) e' ->
503 > Let (NonRec (applyTypeEnvToId p id) (substTy e))
506 > Let (Rec (map substTyRecBind bs)) (substTy e)
507 > where substTyRecBind (v,e) = (applyTypeEnvToId p v, substTy e)
508 > SCC l e -> SCC l (substTy e)
509 > Coerce _ _ _ -> panic "DefExpr:applyTypeEnvToExpr:Coerce"
511 > substTyAtom :: DefAtom -> DefAtom
512 > substTyAtom (VarArg v) = VarArg (substTyArg v)
513 > substTyAtom (LitArg l) = LitArg l -- XXX
515 > substTyArg :: DefBindee -> DefBindee
516 > substTyArg (DefArgExpr e) = DefArgExpr (substTy e)
517 > substTyArg e@(Label _ _) = panic "DefExpr(substArg): Label _ _"
518 > substTyArg e@(DefArgVar id) = -- XXX
519 > DefArgVar (applyTypeEnvToId p id)
521 > substTyCaseAlts (AlgAlts as def)
522 > = AlgAlts (map substTyAlgAlt as) (substTyDefault def)
523 > substTyCaseAlts (PrimAlts as def)
524 > = PrimAlts (map substTyPrimAlt as) (substTyDefault def)
526 > substTyAlgAlt (c, vs, e) = (c, map (applyTypeEnvToId p) vs, substTy e)
527 > substTyPrimAlt (l, e) = (l, substTy e)
529 > substTyDefault NoDefault = NoDefault
530 > substTyDefault (BindDefault id e) =
531 > BindDefault (applyTypeEnvToId p id) (substTy e)
533 > substTyArg t (ValArg e) =
534 > ValArg (VarArg (DefArgExpr (applyTypeEnvToExpr t (atom2expr e))))
535 > substTyArg t (TypeArg ty) = TypeArg ty
537 -----------------------------------------------------------------------------
539 > mapAlts f ps = case ps of
540 > AlgAlts alts def ->
541 > AlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def)
542 > PrimAlts alts def ->
543 > PrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def)
545 > mapDef f NoDefault = NoDefault
546 > mapDef f (BindDefault v e) = BindDefault v (f e)
548 -----------------------------------------------------------------------------
549 Apply a function to all the ValArgs in an Args list.
552 > :: (DefExpr -> UniqSM DefExpr)
554 > -> UniqSM [DefCoreArg]
558 > mapArgs f (a@(TypeArg ty) : as) =
559 > mapArgs f as `thenUs` \as ->
561 > mapArgs f (ValArg v : as) =
562 > f (atom2expr v) `thenUs` \e ->
563 > mapArgs f as `thenUs` \as ->
564 > returnUs (ValArg (VarArg (DefArgExpr e)) : as)
567 > mkSubst [] as s = ([],as,s)
568 > mkSubst vs [] s = (vs,[],s)
569 > mkSubst (v:vs) (ValArg e:as) s = mkSubst vs as ((v,atom2expr e):s)
571 -----------------------------------------------------------------------------
573 The next function does a bit of extraction for applicative terms
574 before they are transformed. We look for boring expressions - those
575 that won't be any use in removing intermediate data structures. These
576 include applicative terms where we cannot unfold the head,
577 non-reducible case expressions, primitive applications and some let
580 Extracting these expressions helps the knot-tyer to find loops
581 earlier, and avoids the need to do matching instead of renaming.
583 We also pull out lets from function arguments, and primitive case
584 expressions (which can't fail anyway).
588 (t (case u of x -> v))
592 Maybe shouldn't do this if -fpedantic-bottoms? Also can't do it if u
595 ToDo: sort this mess out - could be more efficient.
597 > maybeJumbleApp :: DefExpr -> DefAtom -> UniqSM (Maybe DefExpr)
598 > maybeJumbleApp e (LitArg _) = returnUs Nothing -- ToDo remove
599 > maybeJumbleApp e (VarArg (DefArgExpr (Var (DefArgVar _))))
601 > maybeJumbleApp e (VarArg (DefArgExpr t))
602 > = let t' = pull_out t [] in
604 > Let _ _ -> returnUs (Just t')
605 > Case (Prim _ _ _) (PrimAlts [] _) -> returnUs (Just t')
606 > _ -> if isBoringExpr t then
611 > where isBoringExpr (Var (DefArgVar z)) = (not . deforestable) z
612 > isBoringExpr (Prim op ts es) = True
613 > isBoringExpr (Case e ps) = isBoringExpr e
614 > && boringCaseAlternatives ps
615 > isBoringExpr (App l r) = isBoringExpr l
616 > isBoringExpr (CoTyApp l t) = isBoringExpr l
617 > isBoringExpr _ = False
619 > boringCaseAlternatives (AlgAlts as d) =
620 > all boringAlgAlt as && boringDefault d
621 > boringCaseAlternatives (PrimAlts as d) =
622 > all boringPrimAlt as && boringDefault d
624 > boringAlgAlt (c,xs,e) = isBoringExpr e
625 > boringPrimAlt (l,e) = isBoringExpr e
627 > boringDefault NoDefault = True
628 > boringDefault (BindDefault x e) = isBoringExpr e
630 > pull_out (Let b t) as = Let b (pull_out t as)
631 > pull_out (App l r) as = pull_out l (r:as)
632 > pull_out (Case prim@(Prim _ _ _)
633 > (PrimAlts [] (BindDefault x u))) as
634 > = Case prim (PrimAlts [] (BindDefault x
637 > = App e (VarArg (DefArgExpr (foldl App t as)))
639 > rebind_with_let t =
640 > d2c t `thenUs` \core_t ->
641 > newDefId (coreExprType core_t) `thenUs` \x ->
642 > trace "boring epxr found!" $
643 > returnUs (Just (Let (NonRec x t)
648 -----------------------------------------------------------------------------
650 > isLitId id = case isInstId_maybe id of
651 > Just (LitInst _ _ _ _) -> True
654 > isConstant (Con c [] []) = True
655 > isConstant (Lit l) = True
656 > isConstant (Var (Label l e)) = isConstant e
657 > isConstant _ = False
659 > removeLabels (Var (Label l e)) = removeLabels e