2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[DefExpr]{Transformation Algorithm for Expressions}
6 >#include "HsVersions.h"
15 > import Core2Def ( c2d ) -- for unfoldings
19 > import AbsUniType ( applyTypeEnvToTy, isPrimType,
20 > SigmaType(..), UniType
21 > IF_ATTACK_PRAGMAS(COMMA cmpUniType)
23 > import CmdLineOpts ( SwitchResult, switchIsOn )
24 > import CoreFuns ( mkCoLam, unTagBinders, typeOfCoreExpr )
25 > import Id ( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id,
28 > import Inst -- Inst(..)
31 > import Maybes ( Maybe(..) )
33 > import SimplEnv ( SwitchChecker(..), UnfoldingDetails(..) )
42 -----------------------------------------------------------------------------
43 Top level transformation
45 A type environment mapping type variables to types is carried around.
46 This is extended by one rule only: reduction of a type application.
49 > :: SwitchChecker who_knows
50 > -> IdEnv DefExpr -- Environment
51 > -> TypeEnv -- Type environment
52 > -> DefExpr -- input expression
53 > -> [DefCoreArg] -- args
56 > tran sw p t e@(CoVar (DefArgVar id)) as =
59 > mapArgs (\e -> tran sw p t e []) as `thenSUs` \as ->
60 > returnSUs (applyToArgs (CoVar (DefArgVar new_id)) as)
64 > tran sw p t e as `thenSUs` \e ->
65 > returnSUs (mkLabel (applyToArgs (CoVar (DefArgVar new_id))
66 > (map (substTyArg t) as))
69 > where new_id = applyTypeEnvToId t id
71 > tran sw p t e@(CoLit l) [] =
74 > tran sw p t (CoCon c ts es) [] =
75 > mapSUs (tranAtom sw p t) es `thenSUs` \es ->
76 > returnSUs (CoCon c (map (applyTypeEnvToTy t) ts) es)
78 > tran sw p t (CoPrim op ts es) [] = -- XXX constant folding?
79 > mapSUs (tranAtom sw p t) es `thenSUs` \es ->
80 > returnSUs (CoPrim op (map (applyTypeEnvToTy t) ts) es)
82 > tran sw p t (CoLam vs e) [] =
83 > tran sw p t e [] `thenSUs` \e ->
84 > returnSUs (mkCoLam (map (applyTypeEnvToId t) vs) e)
86 > tran sw p t (CoLam vs e) as =
87 > subst s e `thenSUs` \e ->
88 > tran sw p t (mkCoLam rvs e) ras
90 > (rvs,ras,s) = mkSubst vs as []
92 > tran sw p t (CoTyLam alpha e) [] =
93 > tran sw p t e [] `thenSUs` \e ->
94 > returnSUs (CoTyLam alpha e)
97 ToDo: use the environment rather than doing explicit substitution
98 (didn't work last time I tried :)
100 > tran sw p t (CoTyLam alpha e) (TypeArg ty : as) =
101 > tran sw p t (applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e) as
103 > tran sw p t (CoApp e v) as =
104 > maybeJumbleApp e v `thenSUs` \j ->
106 > Nothing -> tran sw p t e (ValArg v : as)
107 > Just e' -> tran sw p t e' as
109 > tran sw p t (CoTyApp e ty) as =
110 > tran sw p t e (TypeArg (applyTypeEnvToTy t ty) : as)
112 > tran sw p t (CoLet (CoNonRec v e) e') as =
113 > tran sw p t e [] `thenSUs` \e ->
114 > if isConstant e then
116 > subst [(v,removeLabels e)] e' `thenSUs` \e' ->
119 > tran sw p t e' as `thenSUs` \e' ->
120 > returnSUs (CoLet (CoNonRec (applyTypeEnvToId t v) e) e')
122 > tran sw p t (CoLet (CoRec bs) e) as =
123 > tranRecBinds sw p t bs e `thenSUs` \(p',resid,e) ->
124 > tran sw p' t e as `thenSUs` \e ->
125 > returnSUs (mkDefLetrec resid e)
127 > tran sw p t (CoSCC l e) as =
128 > tran sw p t e [] `thenSUs` \e ->
129 > mapArgs (\e -> tran sw p t e []) as `thenSUs` \as ->
130 > returnSUs (applyToArgs (CoSCC l e) as)
132 > tran sw p t (CoCase e ps) as =
133 > tranCase sw p t e [] ps as
136 > defPanic "DefExpr" "tran" (applyToArgs 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 > CoVar (DefArgVar id) ->
156 > tranAlts sw p t ps as `thenSUs` \ps ->
157 > mapArgs (\e -> tran sw p t e []) bs `thenSUs` \bs ->
160 > (applyToArgs (CoVar (DefArgVar
161 > (applyTypeEnvToId t id)))
167 > tranCase sw p t e bs ps as `thenSUs` \e ->
171 > (CoCase (applyToArgs (CoVar (DefArgVar id))
172 > (map (substTyArg t) bs))
174 > (map (substTyArg t) as))
180 > [] -> tranAlts sw p t ps as `thenSUs` \ps ->
181 > returnSUs (CoCase e ps)
186 > [] -> tranAlts sw p t ps as `thenSUs` \ps ->
187 > mapSUs (tranAtom sw p t) es `thenSUs` \es ->
188 > returnSUs (CoCase (CoPrim op
189 > (map (applyTypeEnvToTy t) ts) es) ps)
195 > CoAlgAlts alts def ->
196 > reduceCase sw p c ts es alts def as
197 > CoPrimAlts alts def -> die_horribly
203 > (TypeArg _ : _) -> die_horribly
204 > _ -> subst s e `thenSUs` \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 `thenSUs` \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 > CoLet (CoNonRec v e) e' ->
226 > tran sw p t e [] `thenSUs` \e ->
227 > if isConstant e then
228 > trace "yippee2!!" $
229 > subst [(v,removeLabels e)] e' `thenSUs` \e' ->
230 > tranCase sw p t e' bs ps as
232 > tranCase sw p t e' bs ps as `thenSUs` \e' ->
233 > returnSUs (CoLet (CoNonRec
234 > (applyTypeEnvToId t v) e) e')
236 > CoLet (CoRec binds) e ->
237 > tranRecBinds sw p t binds e `thenSUs` \(p',resid,e) ->
238 > tranCase sw p' t e bs ps as `thenSUs` \e ->
239 > returnSUs (mkDefLetrec resid e)
241 > -- ToDo: sort out cost centres. Currently they act as a barrier
242 > -- to optimisation.
244 > tran sw p t e [] `thenSUs` \e ->
245 > mapArgs (\e -> tran sw p t e []) bs
247 > tranAlts sw p t ps as `thenSUs` \ps ->
248 > returnSUs (CoCase (applyToArgs (CoSCC l e) bs)
252 > tranCase sw p t e []
253 > (mapAlts (\e -> applyToArgs (CoCase e ps) bs) ps') as
257 > where die_horribly = defPanic "DefExpr" "tranCase"
258 > (applyToArgs (CoCase (applyToArgs e bs) ps) as)
260 -----------------------------------------------------------------------------
261 Deciding whether or not to replace a function variable with it's
262 definition. The tranVar function is passed four arguments: the
263 environment, the Id itself, the expression to return if no
264 unfolding takes place, and a function to apply to the unfolded expression
265 should an unfolding be required.
268 > :: SwitchChecker who_knows
272 > -> (DefExpr -> SUniqSM DefExpr)
275 > tranVar sw p id no_unfold unfold_with =
277 > case lookupIdEnv p id of
279 > rebindExpr e' `thenSUs` \e' ->
281 > then unfold_with e'
282 > else panic "DefExpr(tran): not deforestable id in env"
284 No mapping in the environment, but it could be an
285 imported function that was annotated with DEFOREST,
286 in which case it will have an unfolding inside the Id
290 > if (not . deforestable) id
293 > else case (getIdUnfolding id) of
294 > GeneralForm _ _ expr guidance ->
295 > panic "DefExpr:GeneralForm has changed a little; needs mod here"
298 >--??? -- ToDo: too much overhead here.
299 >--??? let e' = c2d nullIdEnv expr in
300 >--??? convertToTreelessForm sw e' `thenSUs` \e'' ->
301 >--??? unfold_with e''
304 If the unfolding isn't present, this is
305 a sign that the function is from this module and
306 is not in the environemnt yet (maybe because
307 we are transforming the body of the definition
311 > ("DefExpr(tran): Deforestable id `"
312 > ++ ppShow 80 (ppr PprDebug id)
313 > ++ "' doesn't have an unfolding.") -}
315 -----------------------------------------------------------------------------
316 Transform a set of case alternatives.
319 > :: SwitchChecker who_knows
322 > -> DefCaseAlternatives
324 > -> SUniqSM DefCaseAlternatives
326 > tranAlts sw p t (CoAlgAlts alts def) as =
327 > mapSUs (tranAlgAlt sw p t as) alts `thenSUs` \alts ->
328 > tranDefault sw p t def as `thenSUs` \def ->
329 > returnSUs (CoAlgAlts alts def)
330 > tranAlts sw p t (CoPrimAlts alts def) as =
331 > mapSUs (tranPrimAlt sw p t as) alts `thenSUs` \alts ->
332 > tranDefault sw p t def as `thenSUs` \def ->
333 > returnSUs (CoPrimAlts alts def)
335 > tranAlgAlt sw p t as (c, vs, e) =
336 > tran sw p t e as `thenSUs` \e ->
337 > returnSUs (c, map (applyTypeEnvToId t) vs, e)
338 > tranPrimAlt sw p t as (l, e) =
339 > tran sw p t e as `thenSUs` \e ->
342 > tranDefault sw p t CoNoDefault as = returnSUs CoNoDefault
343 > tranDefault sw p t (CoBindDefault v e) as =
344 > tran sw p t e as `thenSUs` \e ->
345 > returnSUs (CoBindDefault (applyTypeEnvToId t v) e)
347 -----------------------------------------------------------------------------
351 > :: SwitchChecker who_knows
357 > tranAtom sw p t (CoVarAtom v) =
358 > tranArg sw p t v `thenSUs` \v ->
359 > returnSUs (CoVarAtom v)
360 > tranAtom sw p t e@(CoLitAtom l) = -- XXX
363 > tranArg sw p t (DefArgExpr e) =
364 > tran sw p t e [] `thenSUs` \e ->
365 > returnSUs (DefArgExpr e)
366 > tranArg sw p t e@(Label _ _) =
367 > defPanic "DefExpr" "tranArg" (CoVar e)
368 > tranArg sw p t (DefArgVar v) =
369 > tran sw p t (CoVar (DefArgVar v)) [] `thenSUs` \e ->
370 > returnSUs (DefArgExpr e) -- XXX remove this case
372 -----------------------------------------------------------------------------
373 Translating recursive definition groups.
375 We first transform each binding, and then seperate the results into
376 deforestable and non-deforestable sets of bindings. The deforestable
377 bindings are processed by the knot-tyer, and added to the current
378 environment. The rest of the bindings are returned as residual.
380 ToDo: conversion to treeless form should be unnecessary here, becuase
381 the transformer/knot-tyer should leave things in treeless form.
383 > tranRecBinds sw p t bs e =
385 Transform all the deforestable definitions, yielding
387 list of extracted functions = concat extracted ok, so let's get the
388 total set of free variables of the whole function set, call this set
389 fvs. Expand the argument list of each function by
391 and substitute the new function calls throughout the function set.
395 > (unfold,resid) = partition (deforestable . fst) bs
398 > mapSUs (tranRecBind sw p t) unfold `thenSUs` \unfold ->
399 > mapSUs (tranRecBind sw p t) resid `thenSUs` \resid ->
401 Tie knots in the deforestable right-hand sides, and convert the
402 results to treeless form. Then extract any nested deforestable
403 recursive functions, and place everything we've got in the new
406 > let (vs,es) = unzip unfold in
407 > mapSUs mkLoops es `thenSUs` \res ->
409 > (extracted,new_rhss) = unzip res
410 > new_binds = zip vs new_rhss ++ concat extracted
413 Convert everything to treeless form (these functions aren't
414 necessarily already in treeless form because the functions
415 bound in this letrec are about to change status from not
416 unfolded to unfolded).
419 > convertToTreelessForm sw e `thenSUs` \e ->
420 > returnSUs (v,e)) new_binds `thenSUs` \fs ->
422 Now find the total set of free variables of this function set.
425 > fvs = filter (\id -> isArgId id{- && (not . isLitId) id-})
426 > (foldr union [] (map freeVars (map snd fs)))
429 Now expand the argument lists to include the total set of free vars.
432 > stuff = [ fixupFreeVars fvs id e | (id,e) <- fs ]
433 > fs' = map fst stuff
434 > s = concat (map snd stuff)
435 > subIt (id,e) = subst s e `thenSUs` \e -> returnSUs (id,e)
437 > subst s e `thenSUs` \e ->
438 > mapSUs subIt resid `thenSUs` \resid ->
439 > mapSUs subIt fs' `thenSUs` \fs ->
441 > let res = returnSUs (growIdEnvList p fs, resid, e) in
443 > (evs,ees) -> mapSUs d2c ees `thenSUs` \ees ->
444 > let (vs',es') = unzip bs in
445 > mapSUs d2c es' `thenSUs` \es' ->
446 > trace ("extraction "
447 > ++ showIds (map fst bs)
449 > ++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n"
450 > ++ "{ result:\n" ++ (concat (map showBind (zip evs ees))) ++ "}\n") res
451 > where showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
453 > tranRecBind sw p t (id,e) =
454 > tran sw p t e [] `thenSUs` \e ->
455 > returnSUs (applyTypeEnvToId t id,e)
457 > showIds :: [Id] -> String
458 > showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids)
461 -----------------------------------------------------------------------------
463 > reduceCase sw p c ts es alts def as =
464 > case [ a | a@(c',vs,e) <- alts, c' == c ] of
466 > subst (zip vs (map atom2expr es)) e `thenSUs` \e ->
467 > tran sw p nullTyVarEnv e as
470 > panic "DefExpr(reduceCase): no match"
471 > CoBindDefault v e ->
472 > subst [(v,CoCon c ts es)] e `thenSUs` \e ->
473 > tran sw p nullTyVarEnv e as
474 > _ -> panic "DefExpr(reduceCase): multiple matches"
476 -----------------------------------------------------------------------------
484 > applyTypeEnvToExpr p e = substTy e
486 > substTy e' = case e' of
487 > CoVar (DefArgExpr e) -> panic "DefExpr(substTy): CoVar (DefArgExpr _)"
488 > CoVar (Label l e) -> panic "DefExpr(substTy): CoVar (Label _ _)"
489 > CoVar (DefArgVar id) -> CoVar (DefArgVar (applyTypeEnvToId p id))
492 > CoCon c (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
494 > CoPrim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
495 > CoLam vs e -> CoLam (map (applyTypeEnvToId p) vs) (substTy e)
496 > CoTyLam alpha e -> CoTyLam alpha (substTy e)
497 > CoApp e v -> CoApp (substTy e) (substTyAtom v)
498 > CoTyApp e t -> mkCoTyApp (substTy e) (applyTypeEnvToTy p t)
499 > CoCase e ps -> CoCase (substTy e) (substTyCaseAlts ps)
500 > CoLet (CoNonRec id e) e' ->
501 > CoLet (CoNonRec (applyTypeEnvToId p id) (substTy e))
503 > CoLet (CoRec bs) e ->
504 > CoLet (CoRec (map substTyRecBind bs)) (substTy e)
505 > where substTyRecBind (v,e) = (applyTypeEnvToId p v, substTy e)
506 > CoSCC l e -> CoSCC l (substTy e)
508 > substTyAtom :: DefAtom -> DefAtom
509 > substTyAtom (CoVarAtom v) = CoVarAtom (substTyArg v)
510 > substTyAtom (CoLitAtom l) = CoLitAtom l -- XXX
512 > substTyArg :: DefBindee -> DefBindee
513 > substTyArg (DefArgExpr e) = DefArgExpr (substTy e)
514 > substTyArg e@(Label _ _) = panic "DefExpr(substArg): Label _ _"
515 > substTyArg e@(DefArgVar id) = -- XXX
516 > DefArgVar (applyTypeEnvToId p id)
518 > substTyCaseAlts (CoAlgAlts as def)
519 > = CoAlgAlts (map substTyAlgAlt as) (substTyDefault def)
520 > substTyCaseAlts (CoPrimAlts as def)
521 > = CoPrimAlts (map substTyPrimAlt as) (substTyDefault def)
523 > substTyAlgAlt (c, vs, e) = (c, map (applyTypeEnvToId p) vs, substTy e)
524 > substTyPrimAlt (l, e) = (l, substTy e)
526 > substTyDefault CoNoDefault = CoNoDefault
527 > substTyDefault (CoBindDefault id e) =
528 > CoBindDefault (applyTypeEnvToId p id) (substTy e)
530 > substTyArg t (ValArg e) =
531 > ValArg (CoVarAtom (DefArgExpr (applyTypeEnvToExpr t (atom2expr e))))
532 > substTyArg t (TypeArg ty) = TypeArg ty
534 -----------------------------------------------------------------------------
536 > mapAlts f ps = case ps of
537 > CoAlgAlts alts def ->
538 > CoAlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def)
539 > CoPrimAlts alts def ->
540 > CoPrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def)
542 > mapDef f CoNoDefault = CoNoDefault
543 > mapDef f (CoBindDefault v e) = CoBindDefault v (f e)
545 -----------------------------------------------------------------------------
546 Apply a function to all the ValArgs in an Args list.
549 > :: (DefExpr -> SUniqSM DefExpr)
551 > -> SUniqSM [DefCoreArg]
555 > mapArgs f (a@(TypeArg ty) : as) =
556 > mapArgs f as `thenSUs` \as ->
558 > mapArgs f (ValArg v : as) =
559 > f (atom2expr v) `thenSUs` \e ->
560 > mapArgs f as `thenSUs` \as ->
561 > returnSUs (ValArg (CoVarAtom (DefArgExpr e)) : as)
564 > mkSubst [] as s = ([],as,s)
565 > mkSubst vs [] s = (vs,[],s)
566 > mkSubst (v:vs) (ValArg e:as) s = mkSubst vs as ((v,atom2expr e):s)
568 -----------------------------------------------------------------------------
570 The next function does a bit of extraction for applicative terms
571 before they are transformed. We look for boring expressions - those
572 that won't be any use in removing intermediate data structures. These
573 include applicative terms where we cannot unfold the head,
574 non-reducible case expressions, primitive applications and some let
577 Extracting these expressions helps the knot-tyer to find loops
578 earlier, and avoids the need to do matching instead of renaming.
580 We also pull out lets from function arguments, and primitive case
581 expressions (which can't fail anyway).
585 (t (case u of x -> v))
589 Maybe shouldn't do this if -fpedantic-bottoms? Also can't do it if u
592 ToDo: sort this mess out - could be more efficient.
594 > maybeJumbleApp :: DefExpr -> DefAtom -> SUniqSM (Maybe DefExpr)
595 > maybeJumbleApp e (CoLitAtom _) = returnSUs Nothing -- ToDo remove
596 > maybeJumbleApp e (CoVarAtom (DefArgExpr (CoVar (DefArgVar _))))
597 > = returnSUs Nothing
598 > maybeJumbleApp e (CoVarAtom (DefArgExpr t))
599 > = let t' = pull_out t [] in
601 > CoLet _ _ -> returnSUs (Just t')
602 > CoCase (CoPrim _ _ _) (CoPrimAlts [] _) -> returnSUs (Just t')
603 > _ -> if isBoringExpr t then
608 > where isBoringExpr (CoVar (DefArgVar z)) = (not . deforestable) z
609 > isBoringExpr (CoPrim op ts es) = True
610 > isBoringExpr (CoCase e ps) = isBoringExpr e
611 > && boringCaseAlternatives ps
612 > isBoringExpr (CoApp l r) = isBoringExpr l
613 > isBoringExpr (CoTyApp l t) = isBoringExpr l
614 > isBoringExpr _ = False
616 > boringCaseAlternatives (CoAlgAlts as d) =
617 > all boringAlgAlt as && boringDefault d
618 > boringCaseAlternatives (CoPrimAlts as d) =
619 > all boringPrimAlt as && boringDefault d
621 > boringAlgAlt (c,xs,e) = isBoringExpr e
622 > boringPrimAlt (l,e) = isBoringExpr e
624 > boringDefault CoNoDefault = True
625 > boringDefault (CoBindDefault x e) = isBoringExpr e
627 > pull_out (CoLet b t) as = CoLet b (pull_out t as)
628 > pull_out (CoApp l r) as = pull_out l (r:as)
629 > pull_out (CoCase prim@(CoPrim _ _ _)
630 > (CoPrimAlts [] (CoBindDefault x u))) as
631 > = CoCase prim (CoPrimAlts [] (CoBindDefault x
634 > = CoApp e (CoVarAtom (DefArgExpr (foldl CoApp t as)))
636 > rebind_with_let t =
637 > d2c t `thenSUs` \core_t ->
638 > newDefId (typeOfCoreExpr core_t) `thenSUs` \x ->
639 > trace "boring epxr found!" $
640 > returnSUs (Just (CoLet (CoNonRec x t)
641 > (CoApp e (CoVarAtom (
642 > DefArgExpr (CoVar (
645 -----------------------------------------------------------------------------
647 > isLitId id = case isInstId_maybe id of
648 > Just (LitInst _ _ _ _) -> True
651 > isConstant (CoCon c [] []) = True
652 > isConstant (CoLit l) = True
653 > isConstant (CoVar (Label l e)) = isConstant e
654 > isConstant _ = False
656 > removeLabels (CoVar (Label l e)) = removeLabels e