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,
20 > SYN_IE(SigmaType), Type
22 > import CmdLineOpts ( SwitchResult, switchIsOn )
23 > import CoreUnfold ( Unfolding(..) )
24 > import CoreUtils ( mkValLam, unTagBinders, coreExprType )
25 > import Id ( applyTypeEnvToId, getIdUnfolding, Id,
28 > import Inst -- Inst(..)
38 -----------------------------------------------------------------------------
39 Top level transformation
41 A type environment mapping type variables to types is carried around.
42 This is extended by one rule only: reduction of a type application.
45 > :: SwitchChecker who_knows
46 > -> IdEnv DefExpr -- Environment
47 > -> TypeEnv -- Type environment
48 > -> DefExpr -- input expression
49 > -> [DefCoreArg] -- args
52 > tran sw p t e@(Var (DefArgVar id)) as =
55 > mapArgs (\e -> tran sw p t e []) as `thenUs` \as ->
56 > returnUs (mkGenApp (Var (DefArgVar new_id)) as)
60 > tran sw p t e as `thenUs` \e ->
61 > returnUs (mkLabel (mkGenApp (Var (DefArgVar new_id))
62 > (map (substTyArg t) as))
65 > where new_id = applyTypeEnvToId t id
67 > tran sw p t e@(Lit l) [] =
70 > tran sw p t (Con c ts es) [] =
71 > mapUs (tranAtom sw p t) es `thenUs` \es ->
72 > returnUs (Con c (map (applyTypeEnvToTy t) ts) es)
74 > tran sw p t (Prim op ts es) [] = -- XXX constant folding?
75 > mapUs (tranAtom sw p t) es `thenUs` \es ->
76 > returnUs (Prim op (map (applyTypeEnvToTy t) ts) es)
78 > tran sw p t (Lam vs e) [] =
79 > tran sw p t e [] `thenUs` \e ->
80 > returnUs (mkValLam (map (applyTypeEnvToId t) vs) e)
82 > tran sw p t (Lam vs e) as =
83 > subst s e `thenUs` \e ->
84 > tran sw p t (mkValLam rvs e) ras
86 > (rvs,ras,s) = mkSubst vs as []
88 > tran sw p t (CoTyLam alpha e) [] =
89 > tran sw p t e [] `thenUs` \e ->
90 > returnUs (CoTyLam alpha e)
93 ToDo: use the environment rather than doing explicit substitution
94 (didn't work last time I tried :)
96 > tran sw p t (CoTyLam alpha e) (TypeArg ty : as) =
97 > tran sw p t (applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e) as
99 > tran sw p t (App e v) as =
100 > maybeJumbleApp e v `thenUs` \j ->
102 > Nothing -> tran sw p t e (ValArg v : as)
103 > Just e' -> tran sw p t e' as
105 > tran sw p t (CoTyApp e ty) as =
106 > tran sw p t e (TypeArg (applyTypeEnvToTy t ty) : as)
108 > tran sw p t (Let (NonRec v e) e') as =
109 > tran sw p t e [] `thenUs` \e ->
110 > if isConstant e then
112 > subst [(v,removeLabels e)] e' `thenUs` \e' ->
115 > tran sw p t e' as `thenUs` \e' ->
116 > returnUs (Let (NonRec (applyTypeEnvToId t v) e) e')
118 > tran sw p t (Let (Rec bs) e) as =
119 > tranRecBinds sw p t bs e `thenUs` \(p',resid,e) ->
120 > tran sw p' t e as `thenUs` \e ->
121 > returnUs (mkDefLetrec resid e)
123 > tran sw p t (SCC l e) as =
124 > tran sw p t e [] `thenUs` \e ->
125 > mapArgs (\e -> tran sw p t e []) as `thenUs` \as ->
126 > returnUs (mkGenApp (SCC l e) as)
128 > tran sw p t (Coerce c ty e) as =
129 > panic "DefExpr:tran:Coerce"
131 > tran sw p t (Case e ps) as =
132 > tranCase sw p t e [] ps as
135 > defPanic "DefExpr" "tran" (mkGenApp e as)
137 -----------------------------------------------------------------------------
138 Transformation for case expressions of the form (case e1..en of {..})
141 > :: SwitchChecker who_knows
146 > -> DefCaseAlternatives
150 > tranCase sw p t e bs ps as = case e of
152 > Var (DefArgVar id) ->
155 > tranAlts sw p t ps as `thenUs` \ps ->
156 > mapArgs (\e -> tran sw p t e []) bs `thenUs` \bs ->
159 > (mkGenApp (Var (DefArgVar
160 > (applyTypeEnvToId t id)))
166 > tranCase sw p t e bs ps as `thenUs` \e ->
170 > (Case (mkGenApp (Var (DefArgVar id))
171 > (map (substTyArg t) bs))
173 > (map (substTyArg t) as))
179 > [] -> tranAlts sw p t ps as `thenUs` \ps ->
180 > returnUs (Case e ps)
185 > [] -> tranAlts sw p t ps as `thenUs` \ps ->
186 > mapUs (tranAtom sw p t) es `thenUs` \es ->
187 > returnUs (Case (Prim op
188 > (map (applyTypeEnvToTy t) ts) es) ps)
194 > AlgAlts alts def ->
195 > reduceCase sw p c ts es alts def as
196 > PrimAlts alts def -> die_horribly
202 > (TypeArg _ : _) -> die_horribly
203 > _ -> subst s e `thenUs` \e ->
204 > tranCase sw p t e rbs ps as
206 > (rvs,rbs,s) = mkSubst vs bs []
210 > TypeArg ty : bs' -> tranCase sw p t e' bs' ps as
211 > where e' = applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e
215 > maybeJumbleApp e v `thenUs` \j ->
217 > Nothing -> tranCase sw p t e (ValArg v : bs) ps as
218 > Just e' -> tranCase sw p t e' bs ps as
221 > tranCase sw p t e (TypeArg (applyTypeEnvToTy t ty) : bs)
224 > Let (NonRec v e) e' ->
225 > tran sw p t e [] `thenUs` \e ->
226 > if isConstant e then
227 > trace "yippee2!!" $
228 > subst [(v,removeLabels e)] e' `thenUs` \e' ->
229 > tranCase sw p t e' bs ps as
231 > tranCase sw p t e' bs ps as `thenUs` \e' ->
232 > returnUs (Let (NonRec
233 > (applyTypeEnvToId t v) e) e')
235 > Let (Rec binds) e ->
236 > tranRecBinds sw p t binds e `thenUs` \(p',resid,e) ->
237 > tranCase sw p' t e bs ps as `thenUs` \e ->
238 > returnUs (mkDefLetrec resid e)
240 > -- ToDo: sort out cost centres. Currently they act as a barrier
241 > -- to optimisation.
243 > tran sw p t e [] `thenUs` \e ->
244 > mapArgs (\e -> tran sw p t e []) bs
246 > tranAlts sw p t ps as `thenUs` \ps ->
247 > returnUs (Case (mkGenApp (SCC l e) bs)
250 > Coerce _ _ _ -> panic "DefExpr:tranCase:Coerce"
253 > tranCase sw p t e []
254 > (mapAlts (\e -> mkGenApp (Case e ps) bs) ps') as
258 > where die_horribly = defPanic "DefExpr" "tranCase"
259 > (mkGenApp (Case (mkGenApp e bs) ps) as)
261 -----------------------------------------------------------------------------
262 Deciding whether or not to replace a function variable with it's
263 definition. The tranVar function is passed four arguments: the
264 environment, the Id itself, the expression to return if no
265 unfolding takes place, and a function to apply to the unfolded expression
266 should an unfolding be required.
269 > :: SwitchChecker who_knows
273 > -> (DefExpr -> UniqSM DefExpr)
276 > tranVar sw p id no_unfold unfold_with =
278 > case lookupIdEnv p id of
280 > rebindExpr e' `thenUs` \e' ->
282 > then unfold_with e'
283 > else panic "DefExpr(tran): not deforestable id in env"
285 No mapping in the environment, but it could be an
286 imported function that was annotated with DEFOREST,
287 in which case it will have an unfolding inside the Id
291 > if (not . deforestable) id
294 > else case (getIdUnfolding id) of
295 > SimpleUnfolding _ expr guidance ->
296 > panic "DefExpr:SimpleUnfolding has changed a little; needs mod here"
299 >--??? -- ToDo: too much overhead here.
300 >--??? let e' = c2d nullIdEnv expr in
301 >--??? convertToTreelessForm sw e' `thenUs` \e'' ->
302 >--??? unfold_with e''
305 If the unfolding isn't present, this is
306 a sign that the function is from this module and
307 is not in the environemnt yet (maybe because
308 we are transforming the body of the definition
312 > ("DefExpr(tran): Deforestable id `"
313 > ++ show (ppr PprDebug id)
314 > ++ "' doesn't have an unfolding.") -}
316 -----------------------------------------------------------------------------
317 Transform a set of case alternatives.
320 > :: SwitchChecker who_knows
323 > -> DefCaseAlternatives
325 > -> UniqSM DefCaseAlternatives
327 > tranAlts sw p t (AlgAlts alts def) as =
328 > mapUs (tranAlgAlt sw p t as) alts `thenUs` \alts ->
329 > tranDefault sw p t def as `thenUs` \def ->
330 > returnUs (AlgAlts alts def)
331 > tranAlts sw p t (PrimAlts alts def) as =
332 > mapUs (tranPrimAlt sw p t as) alts `thenUs` \alts ->
333 > tranDefault sw p t def as `thenUs` \def ->
334 > returnUs (PrimAlts alts def)
336 > tranAlgAlt sw p t as (c, vs, e) =
337 > tran sw p t e as `thenUs` \e ->
338 > returnUs (c, map (applyTypeEnvToId t) vs, e)
339 > tranPrimAlt sw p t as (l, e) =
340 > tran sw p t e as `thenUs` \e ->
343 > tranDefault sw p t NoDefault as = returnUs NoDefault
344 > tranDefault sw p t (BindDefault v e) as =
345 > tran sw p t e as `thenUs` \e ->
346 > returnUs (BindDefault (applyTypeEnvToId t v) e)
348 -----------------------------------------------------------------------------
352 > :: SwitchChecker who_knows
358 > tranAtom sw p t (VarArg v) =
359 > tranArg sw p t v `thenUs` \v ->
360 > returnUs (VarArg v)
361 > tranAtom sw p t e@(LitArg l) = -- XXX
364 > tranArg sw p t (DefArgExpr e) =
365 > tran sw p t e [] `thenUs` \e ->
366 > returnUs (DefArgExpr e)
367 > tranArg sw p t e@(Label _ _) =
368 > defPanic "DefExpr" "tranArg" (Var e)
369 > tranArg sw p t (DefArgVar v) =
370 > tran sw p t (Var (DefArgVar v)) [] `thenUs` \e ->
371 > returnUs (DefArgExpr e) -- XXX remove this case
373 -----------------------------------------------------------------------------
374 Translating recursive definition groups.
376 We first transform each binding, and then seperate the results into
377 deforestable and non-deforestable sets of bindings. The deforestable
378 bindings are processed by the knot-tyer, and added to the current
379 environment. The rest of the bindings are returned as residual.
381 ToDo: conversion to treeless form should be unnecessary here, becuase
382 the transformer/knot-tyer should leave things in treeless form.
384 > tranRecBinds sw p t bs e =
386 Transform all the deforestable definitions, yielding
388 list of extracted functions = concat extracted ok, so let's get the
389 total set of free variables of the whole function set, call this set
390 fvs. Expand the argument list of each function by
392 and substitute the new function calls throughout the function set.
396 > (unfold,resid) = partition (deforestable . fst) bs
399 > mapUs (tranRecBind sw p t) unfold `thenUs` \unfold ->
400 > mapUs (tranRecBind sw p t) resid `thenUs` \resid ->
402 Tie knots in the deforestable right-hand sides, and convert the
403 results to treeless form. Then extract any nested deforestable
404 recursive functions, and place everything we've got in the new
407 > let (vs,es) = unzip unfold in
408 > mapUs mkLoops es `thenUs` \res ->
410 > (extracted,new_rhss) = unzip res
411 > new_binds = zip vs new_rhss ++ concat extracted
414 Convert everything to treeless form (these functions aren't
415 necessarily already in treeless form because the functions
416 bound in this letrec are about to change status from not
417 unfolded to unfolded).
420 > convertToTreelessForm sw e `thenUs` \e ->
421 > returnUs (v,e)) new_binds `thenUs` \fs ->
423 Now find the total set of free variables of this function set.
426 > fvs = filter (\id -> isArgId id{- && (not . isLitId) id-})
427 > (foldr union [] (map freeVars (map snd fs)))
430 Now expand the argument lists to include the total set of free vars.
433 > stuff = [ fixupFreeVars fvs id e | (id,e) <- fs ]
434 > fs' = map fst stuff
435 > s = concat (map snd stuff)
436 > subIt (id,e) = subst s e `thenUs` \e -> returnUs (id,e)
438 > subst s e `thenUs` \e ->
439 > mapUs subIt resid `thenUs` \resid ->
440 > mapUs subIt fs' `thenUs` \fs ->
442 > let res = returnUs (growIdEnvList p fs, resid, e) in
444 > (evs,ees) -> mapUs d2c ees `thenUs` \ees ->
445 > let (vs',es') = unzip bs in
446 > mapUs d2c es' `thenUs` \es' ->
447 > trace ("extraction "
448 > ++ showIds (map fst bs)
450 > ++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n"
451 > ++ "{ result:\n" ++ (concat (map showBind (zip evs ees))) ++ "}\n") res
452 > where showBind (v,e) = show (ppr PprDebug v) ++ "=\n" ++ show (ppr PprDebug e) ++ "\n"
454 > tranRecBind sw p t (id,e) =
455 > tran sw p t e [] `thenUs` \e ->
456 > returnUs (applyTypeEnvToId t id,e)
458 > showIds :: [Id] -> String
459 > showIds ids = "(" ++ concat (map ((' ' :) . show . ppr PprDebug) ids)
462 -----------------------------------------------------------------------------
464 > reduceCase sw p c ts es alts def as =
465 > case [ a | a@(c',vs,e) <- alts, c' == c ] of
467 > subst (zip vs (map atom2expr es)) e `thenUs` \e ->
468 > tran sw p nullTyVarEnv e as
471 > panic "DefExpr(reduceCase): no match"
473 > subst [(v,Con c ts es)] e `thenUs` \e ->
474 > tran sw p nullTyVarEnv e as
475 > _ -> panic "DefExpr(reduceCase): multiple matches"
477 -----------------------------------------------------------------------------
485 > applyTypeEnvToExpr p e = substTy e
487 > substTy e' = case e' of
488 > Var (DefArgExpr e) -> panic "DefExpr(substTy): Var (DefArgExpr _)"
489 > Var (Label l e) -> panic "DefExpr(substTy): Var (Label _ _)"
490 > Var (DefArgVar id) -> Var (DefArgVar (applyTypeEnvToId p id))
493 > Con c (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
495 > Prim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
496 > Lam vs e -> Lam (map (applyTypeEnvToId p) vs) (substTy e)
497 > CoTyLam alpha e -> CoTyLam alpha (substTy e)
498 > App e v -> App (substTy e) (substTyAtom v)
499 > CoTyApp e t -> CoTyApp (substTy e) (applyTypeEnvToTy p t)
500 > Case e ps -> Case (substTy e) (substTyCaseAlts ps)
501 > Let (NonRec id e) e' ->
502 > Let (NonRec (applyTypeEnvToId p id) (substTy e))
505 > Let (Rec (map substTyRecBind bs)) (substTy e)
506 > where substTyRecBind (v,e) = (applyTypeEnvToId p v, substTy e)
507 > SCC l e -> SCC l (substTy e)
508 > Coerce _ _ _ -> panic "DefExpr:applyTypeEnvToExpr:Coerce"
510 > substTyAtom :: DefAtom -> DefAtom
511 > substTyAtom (VarArg v) = VarArg (substTyArg v)
512 > substTyAtom (LitArg l) = LitArg l -- XXX
514 > substTyArg :: DefBindee -> DefBindee
515 > substTyArg (DefArgExpr e) = DefArgExpr (substTy e)
516 > substTyArg e@(Label _ _) = panic "DefExpr(substArg): Label _ _"
517 > substTyArg e@(DefArgVar id) = -- XXX
518 > DefArgVar (applyTypeEnvToId p id)
520 > substTyCaseAlts (AlgAlts as def)
521 > = AlgAlts (map substTyAlgAlt as) (substTyDefault def)
522 > substTyCaseAlts (PrimAlts as def)
523 > = PrimAlts (map substTyPrimAlt as) (substTyDefault def)
525 > substTyAlgAlt (c, vs, e) = (c, map (applyTypeEnvToId p) vs, substTy e)
526 > substTyPrimAlt (l, e) = (l, substTy e)
528 > substTyDefault NoDefault = NoDefault
529 > substTyDefault (BindDefault id e) =
530 > BindDefault (applyTypeEnvToId p id) (substTy e)
532 > substTyArg t (ValArg e) =
533 > ValArg (VarArg (DefArgExpr (applyTypeEnvToExpr t (atom2expr e))))
534 > substTyArg t (TypeArg ty) = TypeArg ty
536 -----------------------------------------------------------------------------
538 > mapAlts f ps = case ps of
539 > AlgAlts alts def ->
540 > AlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def)
541 > PrimAlts alts def ->
542 > PrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def)
544 > mapDef f NoDefault = NoDefault
545 > mapDef f (BindDefault v e) = BindDefault v (f e)
547 -----------------------------------------------------------------------------
548 Apply a function to all the ValArgs in an Args list.
551 > :: (DefExpr -> UniqSM DefExpr)
553 > -> UniqSM [DefCoreArg]
557 > mapArgs f (a@(TypeArg ty) : as) =
558 > mapArgs f as `thenUs` \as ->
560 > mapArgs f (ValArg v : as) =
561 > f (atom2expr v) `thenUs` \e ->
562 > mapArgs f as `thenUs` \as ->
563 > returnUs (ValArg (VarArg (DefArgExpr e)) : as)
566 > mkSubst [] as s = ([],as,s)
567 > mkSubst vs [] s = (vs,[],s)
568 > mkSubst (v:vs) (ValArg e:as) s = mkSubst vs as ((v,atom2expr e):s)
570 -----------------------------------------------------------------------------
572 The next function does a bit of extraction for applicative terms
573 before they are transformed. We look for boring expressions - those
574 that won't be any use in removing intermediate data structures. These
575 include applicative terms where we cannot unfold the head,
576 non-reducible case expressions, primitive applications and some let
579 Extracting these expressions helps the knot-tyer to find loops
580 earlier, and avoids the need to do matching instead of renaming.
582 We also pull out lets from function arguments, and primitive case
583 expressions (which can't fail anyway).
587 (t (case u of x -> v))
591 Maybe shouldn't do this if -fpedantic-bottoms? Also can't do it if u
594 ToDo: sort this mess out - could be more efficient.
596 > maybeJumbleApp :: DefExpr -> DefAtom -> UniqSM (Maybe DefExpr)
597 > maybeJumbleApp e (LitArg _) = returnUs Nothing -- ToDo remove
598 > maybeJumbleApp e (VarArg (DefArgExpr (Var (DefArgVar _))))
600 > maybeJumbleApp e (VarArg (DefArgExpr t))
601 > = let t' = pull_out t [] in
603 > Let _ _ -> returnUs (Just t')
604 > Case (Prim _ _ _) (PrimAlts [] _) -> returnUs (Just t')
605 > _ -> if isBoringExpr t then
610 > where isBoringExpr (Var (DefArgVar z)) = (not . deforestable) z
611 > isBoringExpr (Prim op ts es) = True
612 > isBoringExpr (Case e ps) = isBoringExpr e
613 > && boringCaseAlternatives ps
614 > isBoringExpr (App l r) = isBoringExpr l
615 > isBoringExpr (CoTyApp l t) = isBoringExpr l
616 > isBoringExpr _ = False
618 > boringCaseAlternatives (AlgAlts as d) =
619 > all boringAlgAlt as && boringDefault d
620 > boringCaseAlternatives (PrimAlts as d) =
621 > all boringPrimAlt as && boringDefault d
623 > boringAlgAlt (c,xs,e) = isBoringExpr e
624 > boringPrimAlt (l,e) = isBoringExpr e
626 > boringDefault NoDefault = True
627 > boringDefault (BindDefault x e) = isBoringExpr e
629 > pull_out (Let b t) as = Let b (pull_out t as)
630 > pull_out (App l r) as = pull_out l (r:as)
631 > pull_out (Case prim@(Prim _ _ _)
632 > (PrimAlts [] (BindDefault x u))) as
633 > = Case prim (PrimAlts [] (BindDefault x
636 > = App e (VarArg (DefArgExpr (foldl App t as)))
638 > rebind_with_let t =
639 > d2c t `thenUs` \core_t ->
640 > newDefId (coreExprType core_t) `thenUs` \x ->
641 > trace "boring epxr found!" $
642 > returnUs (Just (Let (NonRec x t)
647 -----------------------------------------------------------------------------
649 > isLitId id = case isInstId_maybe id of
650 > Just (LitInst _ _ _ _) -> True
653 > isConstant (Con c [] []) = True
654 > isConstant (Lit l) = True
655 > isConstant (Var (Label l e)) = isConstant e
656 > isConstant _ = False
658 > removeLabels (Var (Label l e)) = removeLabels e