1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
%
% (c) The AQUA Project, Glasgow University, 1996-1998
%
%************************************************************************
%* *
\section[PprCore]{Printing of Core syntax, including for interfaces}
%* *
%************************************************************************
\begin{code}
module CoreTidy (
tidyExpr, tidyVarOcc,
tidyIdRules, pprTidyIdRules
) where
#include "HsVersions.h"
import CoreSyn
import CoreUtils ( exprArity )
import Unify ( coreRefineTys )
import PprCore ( pprIdRules )
import DataCon ( DataCon, isVanillaDataCon )
import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique,
idType, setIdType, idCoreRules )
import IdInfo ( setArityInfo, vanillaIdInfo,
newStrictnessInfo, setAllStrictnessInfo,
newDemandInfo, setNewDemandInfo )
import Type ( Type, tidyType, tidyTyVarBndr, substTy, mkTvSubst )
import Var ( Var, TyVar )
import VarEnv
import Name ( getOccName )
import OccName ( tidyOccName )
import SrcLoc ( noSrcLoc )
import Maybes ( orElse )
import Outputable
import Util ( mapAccumL )
\end{code}
This module contains "tidying" code for *nested* expressions, bindings, rules.
The code for *top-level* bindings is in TidyPgm.
%************************************************************************
%* *
\subsection{Tidying expressions, rules}
%* *
%************************************************************************
\begin{code}
tidyBind :: TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyBind env (NonRec bndr rhs)
= tidyLetBndr env (bndr,rhs) =: \ (env', bndr') ->
(env', NonRec bndr' (tidyExpr env' rhs))
tidyBind env (Rec prs)
= mapAccumL tidyLetBndr env prs =: \ (env', bndrs') ->
map (tidyExpr env') (map snd prs) =: \ rhss' ->
(env', Rec (zip bndrs' rhss'))
------------ Expressions --------------
tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
tidyExpr env (Var v) = Var (tidyVarOcc env v)
tidyExpr env (Type ty) = Type (tidyType env ty)
tidyExpr env (Lit lit) = Lit lit
tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
tidyExpr env (Let b e)
= tidyBind env b =: \ (env', b') ->
Let b' (tidyExpr env' e)
tidyExpr env (Case e b ty alts)
= tidyBndr env b =: \ (env', b) ->
Case (tidyExpr env e) b (tidyType env ty)
(map (tidyAlt b env') alts)
tidyExpr env (Lam b e)
= tidyBndr env b =: \ (env', b) ->
Lam b (tidyExpr env' e)
------------ Case alternatives --------------
tidyAlt case_bndr env (DataAlt con, vs, rhs)
| not (isVanillaDataCon con) -- GADT case
= tidyBndrs env tvs =: \ (env1, tvs') ->
let
env2 = refineTidyEnv env con tvs' scrut_ty
in
tidyBndrs env2 ids =: \ (env3, ids') ->
(DataAlt con, tvs' ++ ids', tidyExpr env3 rhs)
where
(tvs, ids) = span isTyVar vs
scrut_ty = idType case_bndr
tidyAlt case_bndr env (con, vs, rhs)
= tidyBndrs env vs =: \ (env', vs) ->
(con, vs, tidyExpr env' rhs)
refineTidyEnv :: TidyEnv -> DataCon -> [TyVar] -> Type -> TidyEnv
-- Refine the TidyEnv in the light of the type refinement from coreRefineTys
refineTidyEnv tidy_env@(occ_env, var_env) con tvs scrut_ty
= case coreRefineTys in_scope con tvs scrut_ty of
Nothing -> tidy_env
Just (tv_subst, all_bound_here)
| all_bound_here -- Local type refinement only
-> tidy_env
| otherwise -- Apply the refining subst to the tidy env
-- This ensures that occurences have the most refined type
-- And that means that exprType will work right everywhere
-> (occ_env, mapVarEnv (refine subst) var_env)
where
subst = mkTvSubst in_scope tv_subst
where
refine subst var | isId var = setIdType var (substTy subst (idType var))
| otherwise = var
in_scope = mkInScopeSet var_env -- Seldom used
------------ Notes --------------
tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
tidyNote env note = note
------------ Rules --------------
tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
tidyIdRules env [] = []
tidyIdRules env (IdCoreRule fn is_orph rule : rules)
= tidyRule env rule =: \ rule ->
tidyIdRules env rules =: \ rules ->
(IdCoreRule (tidyVarOcc env fn) is_orph rule : rules)
tidyRule :: TidyEnv -> CoreRule -> CoreRule
tidyRule env rule@(BuiltinRule _ _) = rule
tidyRule env (Rule name act vars tpl_args rhs)
= tidyBndrs env vars =: \ (env', vars) ->
map (tidyExpr env') tpl_args =: \ tpl_args ->
(Rule name act vars tpl_args (tidyExpr env' rhs))
pprTidyIdRules :: Id -> SDoc
pprTidyIdRules id = pprIdRules (tidyIdRules emptyTidyEnv (idCoreRules id))
\end{code}
%************************************************************************
%* *
\subsection{Tidying non-top-level binders}
%* *
%************************************************************************
\begin{code}
tidyVarOcc :: TidyEnv -> Var -> Var
tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v
-- tidyBndr is used for lambda and case binders
tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
tidyBndr env var
| isTyVar var = tidyTyVarBndr env var
| otherwise = tidyIdBndr env var
tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
tidyBndrs env vars = mapAccumL tidyBndr env vars
tidyLetBndr :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
-- Used for local (non-top-level) let(rec)s
tidyLetBndr env (id,rhs)
= ((tidy_env,new_var_env), final_id)
where
((tidy_env,var_env), new_id) = tidyIdBndr env id
-- We need to keep around any interesting strictness and
-- demand info because later on we may need to use it when
-- converting to A-normal form.
-- eg.
-- f (g x), where f is strict in its argument, will be converted
-- into case (g x) of z -> f z by CorePrep, but only if f still
-- has its strictness info.
--
-- Similarly for the demand info - on a let binder, this tells
-- CorePrep to turn the let into a case.
--
-- Similarly arity info for eta expansion in CorePrep
--
final_id = new_id `setIdInfo` new_info
idinfo = idInfo id
new_info = vanillaIdInfo
`setArityInfo` exprArity rhs
`setAllStrictnessInfo` newStrictnessInfo idinfo
`setNewDemandInfo` newDemandInfo idinfo
-- Override the env we get back from tidyId with the new IdInfo
-- so it gets propagated to the usage sites.
new_var_env = extendVarEnv var_env id final_id
-- Non-top-level variables
tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr env@(tidy_env, var_env) id
= -- do this pattern match strictly, otherwise we end up holding on to
-- stuff in the OccName.
case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->
let
-- Give the Id a fresh print-name, *and* rename its type
-- The SrcLoc isn't important now,
-- though we could extract it from the Id
--
-- All nested Ids now have the same IdInfo, namely vanillaIdInfo,
-- which should save some space.
-- But note that tidyLetBndr puts some of it back.
ty' = tidyType env (idType id)
id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc
`setIdInfo` vanillaIdInfo
var_env' = extendVarEnv var_env id id'
in
((tidy_env', var_env'), id')
}
\end{code}
\begin{code}
m =: k = m `seq` k m
\end{code}
|
