2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[NmbrCore]{Renumber Core for printing}
7 #include "HsVersions.h"
13 import PprEnv ( NmbrEnv )
17 nmbrCoreBindings :: [CoreBinding] -> NmbrEnv -> (NmbrEnv, [CoreBinding])
19 nmbr_bind :: CoreBinding -> NmbrEnv -> (NmbrEnv, CoreBinding)
20 nmbr_expr :: CoreExpr -> NmbrEnv -> (NmbrEnv, CoreExpr)
21 nmbr_arg :: CoreArg -> NmbrEnv -> (NmbrEnv, CoreArg)
23 nmbrCoreBindings nenv [] = (nenv, [])
24 nmbrCoreBindings nenv (b:bs)
26 (new_nenv, new_b) = nmbr_bind nenv b
27 (fin_nenv, new_bs) = nmbrCoreBindings new_nenv bs
29 (fin_nenv, new_b : new_bs)
31 nmbr_bind nenv (NonRec binder rhs)
32 -- remember, binder cannot appear in rhs
34 (_, new_rhs) = nmbr_expr nenv rhs
35 (nenv2, new_binder) = addId nenv binder
37 (nenv2, NonRec new_binder new_rhs)
39 nmbr_bind nenv (Rec binds)
40 = -- for letrec, we plug in new bindings BEFORE cloning rhss
42 (binders, rhss) = unzip binds
44 (nenv2, new_binders) = mapAccumL addId nenv binders
46 (_, new_rhss) = mapAndUnzip (nmbr_expr nenv2) rhss
48 returnUs (nenv2, Rec (zipEqual "nmbr_bind" new_binders new_rhss))
52 nmbr_arg nenv (VarArg v)
54 (nenv2, new_v) = nmbrId nenv v
58 nmbr_arg nenv (TyArg ty)
60 (nenv2, new_ty) = nmbrType nenv ty
64 nmbr_arg nenv (UsageArg use)
66 (nenv2, new_use) = nmbrUsage nenv use
68 (nenv2, UsageArg new_use)
77 nmbr_expr nenv tenv orig_expr@(Var var)
79 case (lookupIdEnv nenv var) of
80 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
85 nmbr_expr nenv tenv e@(Lit _) = returnUs e
87 nmbr_expr nenv tenv (Con con as)
88 = mapUs (nmbr_arg nenv tenv) as `thenUs` \ new_as ->
91 nmbr_expr nenv tenv (Prim op as)
92 = mapUs (nmbr_arg nenv tenv) as `thenUs` \ new_as ->
93 do_PrimOp op `thenUs` \ new_op ->
94 mkCoPrim new_op new_as
96 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
98 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
99 new_result_ty = applyTypeEnvToTy tenv result_ty
101 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
103 do_PrimOp other_op = returnUs other_op
105 nmbr_expr nenv tenv (Lam binder expr)
106 = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
107 let new_nenv = addOneToIdEnv nenv old new in
108 nmbr_expr new_nenv tenv expr `thenUs` \ new_expr ->
109 returnUs (Lam new_binder new_expr)
111 nmbr_expr nenv tenv (App expr arg)
112 = nmbr_expr nenv tenv expr `thenUs` \ new_expr ->
113 nmbr_arg nenv tenv arg `thenUs` \ new_arg ->
114 mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
116 nmbr_expr nenv tenv (Case expr alts)
117 = nmbr_expr nenv tenv expr `thenUs` \ new_expr ->
118 do_alts nenv tenv alts `thenUs` \ new_alts ->
119 returnUs (Case new_expr new_alts)
121 do_alts nenv tenv (AlgAlts alts deflt)
122 = mapUs (do_boxed_alt nenv tenv) alts `thenUs` \ new_alts ->
123 do_default nenv tenv deflt `thenUs` \ new_deflt ->
124 returnUs (AlgAlts new_alts new_deflt)
126 do_boxed_alt nenv tenv (con, binders, expr)
127 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
128 let new_nenv = growIdEnvList nenv new_vmaps in
129 nmbr_expr new_nenv tenv expr `thenUs` \ new_expr ->
130 returnUs (con, new_binders, new_expr)
133 do_alts nenv tenv (PrimAlts alts deflt)
134 = mapUs (do_unboxed_alt nenv tenv) alts `thenUs` \ new_alts ->
135 do_default nenv tenv deflt `thenUs` \ new_deflt ->
136 returnUs (PrimAlts new_alts new_deflt)
138 do_unboxed_alt nenv tenv (lit, expr)
139 = nmbr_expr nenv tenv expr `thenUs` \ new_expr ->
140 returnUs (lit, new_expr)
142 do_default nenv tenv NoDefault = returnUs NoDefault
144 do_default nenv tenv (BindDefault binder expr)
145 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
146 let new_nenv = addOneToIdEnv nenv old new in
147 nmbr_expr new_nenv tenv expr `thenUs` \ new_expr ->
148 returnUs (BindDefault new_binder new_expr)
150 nmbr_expr nenv tenv (Let core_bind expr)
151 = nmbr_bind nenv tenv core_bind `thenUs` \ (new_bind, new_nenv) ->
152 -- and do the body of the let
153 nmbr_expr new_nenv tenv expr `thenUs` \ new_expr ->
154 returnUs (Let new_bind new_expr)
156 nmbr_expr nenv tenv (SCC label expr)
157 = nmbr_expr nenv tenv expr `thenUs` \ new_expr ->
158 returnUs (SCC label new_expr)
160 nmbr_expr nenv tenv (Coerce c ty expr)
161 = nmbr_expr nenv tenv expr `thenUs` \ new_expr ->
162 returnUs (Coerce c ty new_expr)