2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TreelessForm]{Convert Arbitrary expressions into treeless form}
6 >#include "HsVersions.h"
8 > module TreelessForm (
9 > convertToTreelessForm
15 > import CmdLineOpts ( SwitchResult, switchIsOn )
16 > import CoreUtils ( coreExprType )
17 > import Id ( replaceIdInfo, getIdInfo )
20 > import SimplEnv ( SYN_IE(SwitchChecker) )
28 Very simplistic approach to begin with:
30 case e of {...} ====> let x = e in case x of {...}
31 x e1 ... en ====> let x1 = e1 in ... let xn = en in (x x1 ... xn)
33 ToDo: make this better.
35 > convertToTreelessForm
40 > convertToTreelessForm sw e
47 > convExpr e = case e of
49 > Var (DefArgExpr e) ->
50 > panic "TreelessForm(substTy): Var (DefArgExpr _)"
53 > panic "TreelessForm(substTy): Var (Label _ _)"
55 > Var (DefArgVar id) -> returnUs e
60 > mapUs convAtom es `thenUs` \es ->
61 > returnUs (Con c ts es)
64 > mapUs convAtom es `thenUs` \es ->
65 > returnUs (Prim op ts es)
68 > convExpr e `thenUs` \e ->
72 > convExpr e `thenUs` \e ->
73 > returnUs (CoTyLam alpha e)
76 > convExpr e `thenUs` \e ->
78 > LitArg l -> returnUs (App e v)
81 > DefArgVar _ -> panic "TreelessForm(convExpr): DefArgVar"
82 > DefArgExpr (Var (DefArgVar id))
83 > | (not.deforestable) id ->
86 > newLet e' (\id -> App e (VarArg
90 > convExpr e `thenUs` \e ->
91 > returnUs (CoTyApp e ty)
94 > convCaseAlts ps `thenUs` \ps ->
96 > Var (DefArgVar id) | (not.deforestable) id ->
97 > returnUs (Case e ps)
98 > Prim op ts es -> returnUs (Case e ps)
99 > _ -> d2c e `thenUs` \e' ->
100 > newLet e (\v -> Case v ps)
102 > Let (NonRec id e) e' ->
103 > convExpr e `thenUs` \e ->
104 > convExpr e' `thenUs` \e' ->
105 > returnUs (Let (NonRec id e) e')
108 >-- convRecBinds bs e `thenUs` \(bs,e) ->
109 >-- returnUs (Let (Rec bs) e)
110 > convExpr e `thenUs` \e ->
111 > mapUs convRecBind bs `thenUs` \bs ->
112 > returnUs (Let (Rec bs) e)
114 > convRecBind (v,e) =
115 > convExpr e `thenUs` \e ->
119 > convExpr e `thenUs` \e ->
122 > Coerce _ _ _ -> panic "TreelessForm:convExpr:Coerce"
124 Mark all the recursive functions as deforestable. Might as well,
125 since they will be in treeless form anyway. This helps to cope with
126 overloaded functions, where the compiler earlier lifts out the
127 dictionary deconstruction.
129 > convRecBinds bs e =
130 > convExpr e `thenUs` \e' ->
131 > mapUs convExpr es `thenUs` \es' ->
132 > mapUs (subst s) es' `thenUs` \es'' ->
133 > subst s e' `thenUs` \e'' ->
134 > returnUs (zip vs' es', e')
137 > vs' = map mkDeforestable vs
138 > s = zip vs (map (Var . DefArgVar) vs')
139 > mkDeforestable v = addIdDeforestInfo v DoDeforest
141 > convAtom :: DefAtom -> UniqSM DefAtom
143 > convAtom (VarArg v) =
144 > convArg v `thenUs` \v ->
145 > returnUs (VarArg v)
146 > convAtom (LitArg l) =
147 > returnUs (LitArg l) -- XXX
149 > convArg :: DefBindee -> UniqSM DefBindee
151 > convArg (DefArgExpr e) =
152 > convExpr e `thenUs` \e ->
153 > returnUs (DefArgExpr e)
154 > convArg e@(Label _ _) =
155 > panic "TreelessForm(convArg): Label _ _"
156 > convArg e@(DefArgVar id) =
157 > panic "TreelessForm(convArg): DefArgVar _ _"
159 > convCaseAlts :: DefCaseAlternatives -> UniqSM DefCaseAlternatives
161 > convCaseAlts (AlgAlts as def) =
162 > mapUs convAlgAlt as `thenUs` \as ->
163 > convDefault def `thenUs` \def ->
164 > returnUs (AlgAlts as def)
165 > convCaseAlts (PrimAlts as def) =
166 > mapUs convPrimAlt as `thenUs` \as ->
167 > convDefault def `thenUs` \def ->
168 > returnUs (PrimAlts as def)
170 > convAlgAlt (c, vs, e) =
171 > convExpr e `thenUs` \e ->
172 > returnUs (c, vs, e)
173 > convPrimAlt (l, e) =
174 > convExpr e `thenUs` \e ->
177 > convDefault NoDefault =
179 > convDefault (BindDefault id e) =
180 > convExpr e `thenUs` \e ->
181 > returnUs (BindDefault id e)
183 > newLet :: DefExpr -> (DefExpr -> DefExpr) -> UniqSM DefExpr
185 > d2c e `thenUs` \core_expr ->
186 > newDefId (coreExprType core_expr) `thenUs` \new_id ->
187 > returnUs (Let (NonRec new_id e) (body (Var (DefArgVar new_id))))