ghc/compiler/coreSyn/NmbrCore.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[NmbrCore]{Renumber Core for printing}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module NmbrCore where
  10
  11 IMP_Ubiq(){-uitous-}
  12
  13 import PprEnv           ( NmbrEnv )
  14 \end{code}
  15
  16 \begin{code}
  17 nmbrCoreBindings :: [CoreBinding] -> NmbrEnv -> (NmbrEnv, [CoreBinding])
  18
  19 nmbr_bind :: CoreBinding -> NmbrEnv -> (NmbrEnv, CoreBinding)
  20 nmbr_expr :: CoreExpr    -> NmbrEnv -> (NmbrEnv, CoreExpr)
  21 nmbr_arg  :: CoreArg     -> NmbrEnv -> (NmbrEnv, CoreArg)
  22
  23 nmbrCoreBindings nenv [] = (nenv, [])
  24 nmbrCoreBindings nenv (b:bs)
  25   = let
  26         (new_nenv, new_b)  = nmbr_bind        nenv     b
  27         (fin_nenv, new_bs) = nmbrCoreBindings new_nenv bs
  28     in
  29     (fin_nenv, new_b : new_bs)
  30
  31 nmbr_bind nenv (NonRec binder rhs)
  32     -- remember, binder cannot appear in rhs
  33   = let
  34         (_,     new_rhs)    = nmbr_expr nenv rhs
  35         (nenv2, new_binder) = addId     nenv binder
  36     in
  37     (nenv2, NonRec new_binder new_rhs)
  38
  39 nmbr_bind nenv (Rec binds)
  40   = -- for letrec, we plug in new bindings BEFORE cloning rhss
  41     let
  42         (binders, rhss)      = unzip binds
  43
  44         (nenv2, new_binders) = mapAccumL addId nenv binders
  45
  46         (_, new_rhss)        = mapAndUnzip (nmbr_expr nenv2) rhss
  47     in
  48     returnUs (nenv2, Rec (zipEqual "nmbr_bind" new_binders new_rhss))
  49 \end{code}
  50
  51 \begin{code}
  52 nmbr_arg nenv (VarArg v)
  53   = let
  54         (nenv2, new_v) = nmbrId nenv v
  55     in
  56     (nenv2, VarArg new_v)
  57
  58 nmbr_arg nenv (TyArg ty)
  59   = let
  60         (nenv2, new_ty) = nmbrType nenv ty
  61     in
  62     (nenv2, TyArg new_ty)
  63
  64 nmbr_arg nenv (UsageArg use)
  65   = let
  66         (nenv2, new_use) = nmbrUsage nenv use
  67     in
  68     (nenv2, UsageArg new_use)
  69 \end{code}
  70
  71 \begin{code}
  72 nmbr_expr :: NmbrEnv
  73             -> TypeEnv
  74             -> CoreExpr
  75             -> UniqSM CoreExpr
  76
  77 nmbr_expr nenv tenv orig_expr@(Var var)
  78   = returnUs (
  79       case (lookupIdEnv nenv var) of
  80         Nothing     -> --false:ASSERT(toplevelishId var) (SIGH)
  81                        orig_expr
  82         Just expr   -> expr
  83     )
  84
  85 nmbr_expr nenv tenv e@(Lit _) = returnUs e
  86
  87 nmbr_expr nenv tenv (Con con as)
  88   = mapUs  (nmbr_arg nenv tenv) as `thenUs`  \ new_as ->
  89     mkCoCon con new_as
  90
  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
  95   where
  96     do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
  97       = let
  98             new_arg_tys   = map (applyTypeEnvToTy tenv) arg_tys
  99             new_result_ty = applyTypeEnvToTy tenv result_ty
 100         in
 101         returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
 102
 103     do_PrimOp other_op = returnUs other_op
 104
 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)
 110
 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?
 115
 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)
 120   where
 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)
 125       where
 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)
 131
 132
 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)
 137       where
 138         do_unboxed_alt nenv tenv (lit, expr)
 139           = nmbr_expr nenv tenv expr    `thenUs` \ new_expr ->
 140             returnUs (lit, new_expr)
 141
 142     do_default nenv tenv NoDefault = returnUs NoDefault
 143
 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)
 149
 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)
 155
 156 nmbr_expr nenv tenv (SCC label expr)
 157   = nmbr_expr nenv tenv expr            `thenUs` \ new_expr ->
 158     returnUs (SCC label new_expr)
 159
 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)
 163 \end{code}