+tidyCorePgm mod binds_in
+ = initTM mod nullIdEnv $
+ tidyTopBindings binds_in `thenTM` \ binds ->
+ returnTM (bagToList binds)
+\end{code}
+
+Top level bindings
+~~~~~~~~~~~~~~~~~~
+\begin{code}
+tidyTopBindings [] = returnTM emptyBag
+tidyTopBindings (b:bs)
+ = tidyTopBinding b $
+ tidyTopBindings bs
+
+tidyTopBinding :: CoreBinding
+ -> TopTidyM (Bag CoreBinding)
+ -> TopTidyM (Bag CoreBinding)
+
+tidyTopBinding (NonRec bndr rhs) thing_inside
+ = initNestedTM (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
+ mungeTopBinder bndr $ \ bndr' ->
+ thing_inside `thenTM` \ binds ->
+ returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
+
+tidyTopBinding (Rec pairs) thing_inside
+ = mungeTopBinders binders $ \ binders' ->
+ initNestedTM (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
+ thing_inside `thenTM` \ binds_inside ->
+ returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
+ where
+ (binders, rhss) = unzip pairs
+\end{code}
+
+
+
+Expressions
+~~~~~~~~~~~
+\begin{code}
+tidyCoreExpr (Var v) = lookupId v `thenTM` \ v' ->
+ returnTM (Var v')
+
+tidyCoreExpr (Lit lit)
+ = litToRep lit `thenTM` \ (_, lit_expr) ->
+ returnTM lit_expr
+
+tidyCoreExpr (App fun arg)
+ = tidyCoreExpr fun `thenTM` \ fun' ->
+ tidyCoreArg arg `thenTM` \ arg' ->
+ returnTM (App fun' arg')
+
+tidyCoreExpr (Con con args)
+ = mapTM tidyCoreArg args `thenTM` \ args' ->
+ returnTM (Con con args')
+
+tidyCoreExpr (Prim prim args)
+ = tidyPrimOp prim `thenTM` \ prim' ->
+ mapTM tidyCoreArg args `thenTM` \ args' ->
+ returnTM (Prim prim' args')
+
+tidyCoreExpr (Lam (ValBinder v) body)
+ = newId v $ \ v' ->
+ tidyCoreExpr body `thenTM` \ body' ->
+ returnTM (Lam (ValBinder v') body')
+
+tidyCoreExpr (Lam (TyBinder tv) body)
+ = newTyVar tv $ \ tv' ->
+ tidyCoreExpr body `thenTM` \ body' ->
+ returnTM (Lam (TyBinder tv') body')
+
+ -- Try for let-to-case (see notes in Simplify.lhs for why
+ -- some let-to-case stuff is deferred to now).
+tidyCoreExpr (Let (NonRec bndr rhs) body)
+ | willBeDemanded (getIdDemandInfo bndr) &&
+ not rhs_is_whnf && -- Don't do it if RHS is already in WHNF
+ typeOkForCase (idType bndr)
+ = ASSERT( not (isUnpointedType (idType bndr)) )
+ tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
+ where
+ rhs_is_whnf = case mkFormSummary rhs of
+ VarForm -> True
+ ValueForm -> True
+ other -> False
+
+tidyCoreExpr (Let (NonRec bndr rhs) body)
+ = tidyCoreExpr rhs `thenTM` \ rhs' ->
+ newId bndr $ \ bndr' ->
+ tidyCoreExprEta body `thenTM` \ body' ->
+ returnTM (Let (NonRec bndr' rhs') body')
+
+tidyCoreExpr (Let (Rec pairs) body)
+ = newIds bndrs $ \ bndrs' ->
+ mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
+ tidyCoreExprEta body `thenTM` \ body' ->
+ returnTM (Let (Rec (bndrs' `zip` rhss')) body')
+ where
+ (bndrs, rhss) = unzip pairs
+
+tidyCoreExpr (Note (Coerce to_ty from_ty) body)
+ = tidyCoreExprEta body `thenTM` \ body' ->
+ tidyTy to_ty `thenTM` \ to_ty' ->
+ tidyTy from_ty `thenTM` \ from_ty' ->
+ returnTM (Note (Coerce to_ty' from_ty') body')
+
+tidyCoreExpr (Note note body)
+ = tidyCoreExprEta body `thenTM` \ body' ->
+ returnTM (Note note body')
+
+-- Wierd case for par, seq, fork etc. See notes above.
+tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
+ | funnyParallelOp op
+ = tidyCoreExpr scrut `thenTM` \ scrut' ->
+ newId binder $ \ binder' ->
+ tidyCoreExprEta rhs `thenTM` \ rhs' ->
+ returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
+
+-- Eliminate polymorphic case, for which we can't generate code just yet
+tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
+ | not (typeOkForCase (idType deflt_bndr))
+ = pprTrace "Warning: discarding polymorphic case:" (ppr scrut) $
+ case scrut of
+ Var v -> lookupId v `thenTM` \ v' ->
+ extendEnvTM deflt_bndr v' (tidyCoreExpr rhs)
+ other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
+
+tidyCoreExpr (Case scrut alts)
+ = tidyCoreExpr scrut `thenTM` \ scrut' ->
+ tidy_alts scrut' alts `thenTM` \ alts' ->
+ returnTM (Case scrut' alts')
+ where
+ tidy_alts scrut (AlgAlts alts deflt)
+ = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
+ tidy_deflt scrut deflt `thenTM` \ deflt' ->
+ returnTM (AlgAlts alts' deflt')
+
+ tidy_alts scrut (PrimAlts alts deflt)
+ = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
+ tidy_deflt scrut deflt `thenTM` \ deflt' ->
+ returnTM (PrimAlts alts' deflt')
+
+ tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
+ tidyCoreExprEta rhs `thenTM` \ rhs' ->
+ returnTM (con, bndrs', rhs')
+
+ tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
+ returnTM (lit,rhs')
+
+ -- We convert case x of {...; x' -> ...x'...}
+ -- to
+ -- case x of {...; _ -> ...x... }
+ --
+ -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
+ -- It's quite easily done: simply extend the environment to bind the
+ -- default binder to the scrutinee.
+
+ tidy_deflt scrut NoDefault = returnTM NoDefault
+ tidy_deflt scrut (BindDefault bndr rhs)
+ = newId bndr $ \ bndr' ->
+ extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
+ returnTM (BindDefault bndr' rhs')
+ where
+ extend_env = case scrut of
+ Var v -> extendEnvTM bndr v
+ other -> \x -> x
+
+tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
+ returnTM (etaCoreExpr e')
+\end{code}
+
+Arguments
+~~~~~~~~~
+\begin{code}
+tidyCoreArg :: CoreArg -> NestTidyM CoreArg
+
+tidyCoreArg (VarArg v)
+ = lookupId v `thenTM` \ v' ->
+ returnTM (VarArg v')
+
+tidyCoreArg (LitArg lit)
+ = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
+ case lit_expr of
+ Var v -> returnTM (VarArg v)
+ Lit l -> returnTM (LitArg l)
+ other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
+ returnTM (VarArg v)
+
+tidyCoreArg (TyArg ty) = tidyTy ty `thenTM` \ ty' ->
+ returnTM (TyArg ty')
+\end{code}
+
+\begin{code}
+tidyPrimOp (CCallOp fn casm gc cconv tys ty)
+ = mapTM tidyTy tys `thenTM` \ tys' ->
+ tidyTy ty `thenTM` \ ty' ->
+ returnTM (CCallOp fn casm gc cconv tys' ty')
+
+tidyPrimOp other_prim_op = returnTM other_prim_op
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[coreToStg-lits]{Converting literals}
+%* *
+%************************************************************************
+
+Literals: the NoRep kind need to be de-no-rep'd.
+We always replace them with a simple variable, and float a suitable
+binding out to the top level.
+
+\begin{code}
+
+litToRep :: Literal -> NestTidyM (Type, CoreExpr)
+
+litToRep (NoRepStr s)
+ = returnTM (stringTy, rhs)
+ where
+ rhs = if (any is_NUL (_UNPK_ s))
+
+ then -- Must cater for NULs in literal string
+ mkGenApp (Var unpackCString2Id)
+ [LitArg (MachStr s),
+ LitArg (mkMachInt_safe (toInteger (_LENGTH_ s)))]
+
+ else -- No NULs in the string
+ App (Var unpackCStringId) (LitArg (MachStr s))
+
+ is_NUL c = c == '\0'
+\end{code}
+
+If an Integer is small enough (Haskell implementations must support
+Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
+otherwise, wrap with @litString2Integer@.
+
+\begin{code}
+litToRep (NoRepInteger i integer_ty)
+ = returnTM (integer_ty, rhs)
+ where
+ rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
+ | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
+ | i == 2 = Var integerPlusTwoId
+ | i == (-1) = Var integerMinusOneId
+
+ | i > tARGET_MIN_INT && -- Small enough, so start from an Int
+ i < tARGET_MAX_INT
+ = Prim Int2IntegerOp [LitArg (mkMachInt (fromInteger i))]
+
+ | otherwise -- Big, so start from a string
+ = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
+
+
+litToRep (NoRepRational r rational_ty)
+ = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
+ tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
+ returnTM (rational_ty, Con ratio_data_con [TyArg integer_ty, num_arg, denom_arg])
+ where
+ (ratio_data_con, integer_ty)
+ = case (splitAlgTyConApp_maybe rational_ty) of
+ Just (tycon, [i_ty], [con])
+ -> ASSERT(isIntegerTy i_ty && uniqueOf tycon == ratioTyConKey)
+ (con, i_ty)
+
+ _ -> (panic "ratio_data_con", panic "integer_ty")
+
+litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
+\end{code}
+
+\begin{code}
+funnyParallelOp SeqOp = True
+funnyParallelOp ParOp = True
+funnyParallelOp ForkOp = True
+funnyParallelOp _ = False
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The monad}
+%* *
+%************************************************************************
+
+\begin{code}
+type TidyM a state = Module
+ -> UniqFM CoreBinder -- Maps Ids to Ids, TyVars to TyVars etc
+ -> state
+ -> (a, state)
+
+type TopTidyM a = TidyM a Unique
+type NestTidyM a = TidyM a (Unique, -- Global names
+ Unique, -- Local names
+ Bag CoreBinding) -- Floats
+
+
+(initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
+
+initTM :: Module -> UniqFM CoreBinder -> TopTidyM a -> a
+initTM mod env m
+ = case m mod env initialTopTidyUnique of
+ (result, _) -> result
+
+initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBinding)
+initNestedTM m mod env global_us
+ = case m mod env (global_us, initialNestedTidyUnique, emptyBag) of
+ (result, (global_us', _, floats)) -> ((result, floats), global_us')
+
+returnTM v mod env usf = (v, usf)
+thenTM m k mod env usf = case m mod env usf of
+ (r, usf') -> k r mod env usf'
+
+mapTM f [] = returnTM []
+mapTM f (x:xs) = f x `thenTM` \ r ->
+ mapTM f xs `thenTM` \ rs ->
+ returnTM (r:rs)
+\end{code}
+
+
+\begin{code}
+-- Need to extend the environment when we munge a binder, so that occurrences
+-- of the binder will print the correct way (e.g. as a global not a local)
+mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
+mungeTopBinder id thing_inside mod env us
+ = -- Give it a new print-name unless it's an exported thing
+ -- setNameVisibility also does the local/global thing
+ let
+ (id1, us') | isExported id = (id, us)
+ | otherwise
+ = (setIdVisibility (Just mod) us id,
+ incrUnique us)
+
+ -- Tidy the Id's SpecEnv
+ spec_env = getIdSpecialisation id
+ id2 | isEmptySpecEnv spec_env = id1
+ | otherwise = setIdSpecialisation id1 (tidySpecEnv env spec_env)
+
+ new_env = addToUFM env id (ValBinder id2)