[project @ 1996-12-19 12:02:09 by dnt]

Removed unused file

ghc/compiler/coreSyn/NmbrCore.lhs

-%
-% (c) The AQUA Project, Glasgow University, 1996
-%
-\section[NmbrCore]{Renumber Core for printing}
-
-\begin{code}
-#include "HsVersions.h"
-
-module NmbrCore where
-
-IMP_Ubiq(){-uitous-}
-
-import PprEnv		( NmbrEnv )
-\end{code}
-
-\begin{code}
-nmbrCoreBindings :: [CoreBinding] -> NmbrEnv -> (NmbrEnv, [CoreBinding])
-
-nmbr_bind :: CoreBinding -> NmbrEnv -> (NmbrEnv, CoreBinding)
-nmbr_expr :: CoreExpr    -> NmbrEnv -> (NmbrEnv, CoreExpr)
-nmbr_arg  :: CoreArg     -> NmbrEnv -> (NmbrEnv, CoreArg)
-
-nmbrCoreBindings nenv [] = (nenv, [])
-nmbrCoreBindings nenv (b:bs)
-  = let
-	(new_nenv, new_b)  = nmbr_bind        nenv     b
-	(fin_nenv, new_bs) = nmbrCoreBindings new_nenv bs
-    in
-    (fin_nenv, new_b : new_bs)
-
-nmbr_bind nenv (NonRec binder rhs)
-    -- remember, binder cannot appear in rhs
-  = let
-	(_,     new_rhs)    = nmbr_expr nenv rhs
-	(nenv2, new_binder) = addId     nenv binder
-    in
-    (nenv2, NonRec new_binder new_rhs)
-
-nmbr_bind nenv (Rec binds)
-  = -- for letrec, we plug in new bindings BEFORE cloning rhss
-    let
-	(binders, rhss)	     = unzip binds
-
-	(nenv2, new_binders) = mapAccumL addId nenv binders
-
-	(_, new_rhss)	     = mapAndUnzip (nmbr_expr nenv2) rhss
-    in
-    returnUs (nenv2, Rec (zipEqual "nmbr_bind" new_binders new_rhss))
-\end{code}
-
-\begin{code}
-nmbr_arg nenv (VarArg v)
-  = let
-	(nenv2, new_v) = nmbrId nenv v
-    in
-    (nenv2, VarArg new_v)
-
-nmbr_arg nenv (TyArg ty)
-  = let
-	(nenv2, new_ty) = nmbrType nenv ty
-    in
-    (nenv2, TyArg new_ty)
-
-nmbr_arg nenv (UsageArg use)
-  = let
-	(nenv2, new_use) = nmbrUsage nenv use
-    in
-    (nenv2, UsageArg new_use)
-\end{code}
-
-\begin{code}
-nmbr_expr :: NmbrEnv
-	    -> TypeEnv
-	    -> CoreExpr
-	    -> UniqSM CoreExpr
-
-nmbr_expr nenv tenv orig_expr@(Var var)
-  = returnUs (
-      case (lookupIdEnv nenv var) of
-	Nothing	    -> --false:ASSERT(toplevelishId var) (SIGH)
-		       orig_expr
-	Just expr   -> expr
-    )
-
-nmbr_expr nenv tenv e@(Lit _) = returnUs e
-
-nmbr_expr nenv tenv (Con con as)
-  = mapUs  (nmbr_arg nenv tenv) as `thenUs`  \ new_as ->
-    mkCoCon con new_as
-
-nmbr_expr nenv tenv (Prim op as)
-  = mapUs  (nmbr_arg nenv tenv) as 	`thenUs`  \ new_as ->
-    do_PrimOp op			`thenUs`  \ new_op ->
-    mkCoPrim new_op new_as
-  where
-    do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
-      = let
-	    new_arg_tys   = map (applyTypeEnvToTy tenv) arg_tys
-	    new_result_ty = applyTypeEnvToTy tenv result_ty
-	in
-	returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
-
-    do_PrimOp other_op = returnUs other_op
-
-nmbr_expr nenv tenv (Lam binder expr)
-  = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
-    let  new_nenv = addOneToIdEnv nenv old new  in
-    nmbr_expr new_nenv tenv expr  `thenUs` \ new_expr ->
-    returnUs (Lam new_binder new_expr)
-
-nmbr_expr nenv tenv (App expr arg)
-  = nmbr_expr nenv tenv expr	`thenUs` \ new_expr ->
-    nmbr_arg  nenv tenv arg   `thenUs` \ new_arg  ->
-    mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
-
-nmbr_expr nenv tenv (Case expr alts)
-  = nmbr_expr nenv tenv expr	    `thenUs` \ new_expr ->
-    do_alts nenv tenv alts	    `thenUs` \ new_alts ->
-    returnUs (Case new_expr new_alts)
-  where
-    do_alts nenv tenv (AlgAlts alts deflt)
-      = mapUs (do_boxed_alt nenv tenv) alts `thenUs` \ new_alts ->
-    	do_default nenv tenv deflt	    `thenUs` \ new_deflt ->
-	returnUs (AlgAlts new_alts new_deflt)
-      where
-	do_boxed_alt nenv tenv (con, binders, expr)
-	  = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
-	    let  new_nenv = growIdEnvList nenv new_vmaps  in
-	    nmbr_expr new_nenv tenv expr  `thenUs` \ new_expr ->
-	    returnUs (con, new_binders, new_expr)
-
-
-    do_alts nenv tenv (PrimAlts alts deflt)
-      = mapUs (do_unboxed_alt nenv tenv) alts `thenUs` \ new_alts ->
-    	do_default nenv tenv deflt	      `thenUs` \ new_deflt ->
-	returnUs (PrimAlts new_alts new_deflt)
-      where
-	do_unboxed_alt nenv tenv (lit, expr)
-	  = nmbr_expr nenv tenv expr	`thenUs` \ new_expr ->
-	    returnUs (lit, new_expr)
-
-    do_default nenv tenv NoDefault = returnUs NoDefault
-
-    do_default nenv tenv (BindDefault binder expr)
-      =	dup_binder tenv binder		`thenUs` \ (new_binder, (old, new)) ->
-	let  new_nenv = addOneToIdEnv nenv old new  in
-	nmbr_expr new_nenv tenv expr	`thenUs` \ new_expr ->
-	returnUs (BindDefault new_binder new_expr)
-
-nmbr_expr nenv tenv (Let core_bind expr)
-  = nmbr_bind nenv tenv core_bind	`thenUs` \ (new_bind, new_nenv) ->
-    -- and do the body of the let
-    nmbr_expr new_nenv tenv expr  	`thenUs` \ new_expr ->
-    returnUs (Let new_bind new_expr)
-
-nmbr_expr nenv tenv (SCC label expr)
-  = nmbr_expr nenv tenv expr	    	`thenUs` \ new_expr ->
-    returnUs (SCC label new_expr)
-
-nmbr_expr nenv tenv (Coerce c ty expr)
-  = nmbr_expr nenv tenv expr	    	`thenUs` \ new_expr ->
-    returnUs (Coerce c ty new_expr)
-\end{code}