Commit bb91427f authored by simonpj's avatar simonpj
Browse files

[project @ 2000-05-23 11:35:36 by simonpj]

*** MERGE WITH 4.07 (once I've checked it works) ***

* Fix result type signatures.  Note that a consequential change is that
  an ordinary binding with a variable on the left
	f = e
  is now treated as a FunMonoBind, not a PatMonoBind.  This makes
  a few things a bit simpler (eg rnMethodBinds)

* Fix warnings for unused imports.  This meant moving where provenances
  are improved in RnNames.  Move mkExportAvails from RnEnv to RnNames.

* Print module names right (small change in Module.lhs and Rename.lhs)

* Remove a few unused bindings
  
* Add a little hack to let us print info about join points that turn
  out not to be let-no-escaped.  The idea is to call them "$j" and report
  any such variables that are not let-no-escaped.

* Some small things aiming towards -ddump-types (harmless but incomplete)
parent 20adb5df
......@@ -183,9 +183,7 @@ instance Ord Module where
\begin{code}
pprModule :: Module -> SDoc
pprModule (Module mod p) = getPprStyle $ \ sty ->
if userStyle sty then
text (moduleNameUserString mod)
else if debugStyle sty then
if debugStyle sty then
-- Print the package too
text (show p) <> dot <> pprModuleName mod
else
......
......@@ -37,7 +37,7 @@ module Name (
-- Class NamedThing and overloaded friends
NamedThing(..),
getSrcLoc, isLocallyDefined, getOccString
getSrcLoc, isLocallyDefined, getOccString, toRdrName
) where
#include "HsVersions.h"
......@@ -423,6 +423,12 @@ nameRdrName :: Name -> RdrName
nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ
nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ
ifaceNameRdrName :: Name -> RdrName
-- Makes a qualified naem for imported things,
-- and an unqualified one for local things
ifaceNameRdrName n | isLocallyDefined n = mkRdrUnqual (nameOccName n)
| otherwise = mkRdrQual (moduleName (nameModule n)) (nameOccName n)
isUserExportedName (Name { n_prov = LocalDef _ Exported }) = True
isUserExportedName other = False
......@@ -622,10 +628,12 @@ class NamedThing a where
getSrcLoc :: NamedThing a => a -> SrcLoc
isLocallyDefined :: NamedThing a => a -> Bool
getOccString :: NamedThing a => a -> String
toRdrName :: NamedThing a => a -> RdrName
getSrcLoc = nameSrcLoc . getName
isLocallyDefined = isLocallyDefinedName . getName
getOccString x = occNameString (getOccName x)
toRdrName = ifaceNameRdrName . getName
\end{code}
\begin{code}
......
......@@ -19,7 +19,7 @@ module OccName (
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
setOccNameSpace,
......@@ -310,6 +310,13 @@ mkSpecOcc = mk_simple_deriv varName "$s"
mkForeignExportOcc = mk_simple_deriv varName "$f"
mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
isSysOcc :: OccName -> Bool -- True for all these '$' things
isSysOcc occ = case occNameUserString occ of
('$' : _ ) -> True
other -> False -- We don't care about the ':' ones
-- isSysOcc is only called for Ids anyway
\end{code}
\begin{code}
......
......@@ -373,8 +373,6 @@ dsExpr (TyApp expr tys)
dsExpr (ExplicitListOut ty xs)
= go xs
where
list_ty = mkListTy ty
go [] = returnDs (mkNilExpr ty)
go (x:xs) = dsExpr x `thenDs` \ core_x ->
go xs `thenDs` \ core_xs ->
......@@ -490,10 +488,10 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
-- necessary so that we don't lose sharing
let
record_in_ty = exprType record_expr'
(tycon, in_inst_tys, cons) = splitAlgTyConApp record_in_ty
(_, out_inst_tys, _) = splitAlgTyConApp record_out_ty
cons_to_upd = filter has_all_fields cons
record_in_ty = exprType record_expr'
(_, in_inst_tys, cons) = splitAlgTyConApp record_in_ty
(_, out_inst_tys, _) = splitAlgTyConApp record_out_ty
cons_to_upd = filter has_all_fields cons
mk_val_arg field old_arg_id
= case [rhs | (sel_id, rhs, _) <- rbinds,
......
......@@ -288,14 +288,15 @@ mkCoAlgCaseMatchResult var match_alts
where
-- Common stuff
scrut_ty = idType var
(tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
(tycon, _, _) = splitAlgTyConApp scrut_ty
-- Stuff for newtype
(con_id, arg_ids, match_result) = head match_alts
arg_id = head arg_ids
coercion_bind = NonRec arg_id
(Note (Coerce (unUsgTy (idType arg_id)) (unUsgTy scrut_ty)) (Var var))
newtype_sanity = null (tail match_alts) && null (tail arg_ids)
(_, arg_ids, match_result) = head match_alts
arg_id = head arg_ids
coercion_bind = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id))
(unUsgTy scrut_ty))
(Var var))
newtype_sanity = null (tail match_alts) && null (tail arg_ids)
-- Stuff for data types
data_cons = tyConDataCons tycon
......
......@@ -103,15 +103,19 @@ data MonoBinds id pat
| AndMonoBinds (MonoBinds id pat)
(MonoBinds id pat)
| PatMonoBind pat
(GRHSs id pat)
SrcLoc
| FunMonoBind id
| FunMonoBind id -- Used for both functions f x = e
-- and variables f = \x -> e
-- Reason: the Match stuff lets us have an optional
-- result type sig f :: a->a = ...mentions a...
Bool -- True => infix declaration
[Match id pat]
SrcLoc
| PatMonoBind pat -- The pattern is never a simple variable;
-- That case is done by FunMonoBind
(GRHSs id pat)
SrcLoc
| VarMonoBind id -- TRANSLATION
(HsExpr id pat)
......
......@@ -38,6 +38,7 @@ module CmdLineOpts (
opt_D_dump_stg,
opt_D_dump_stranal,
opt_D_dump_tc,
opt_D_dump_types,
opt_D_dump_usagesp,
opt_D_dump_worker_wrapper,
opt_D_show_passes,
......@@ -324,6 +325,7 @@ opt_D_dump_spec = opt_D_dump_most || lookUp SLIT("-ddump-spec")
opt_D_dump_stg = opt_D_dump_most || lookUp SLIT("-ddump-stg")
opt_D_dump_stranal = opt_D_dump_most || lookUp SLIT("-ddump-stranal")
opt_D_dump_tc = opt_D_dump_most || lookUp SLIT("-ddump-tc")
opt_D_dump_types = opt_D_dump_most || lookUp SLIT("-ddump-types")
opt_D_dump_rules = opt_D_dump_most || lookUp SLIT("-ddump-rules")
opt_D_dump_usagesp = opt_D_dump_most || lookUp SLIT("-ddump-usagesp")
opt_D_dump_cse = opt_D_dump_most || lookUp SLIT("-ddump-cse")
......
......@@ -548,7 +548,7 @@ ifaceTyCon tycon
braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
]
where
(tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
(tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
field_labels = dataConFieldLabels data_con
strict_marks = dataConStrictMarks data_con
name = getName data_con
......
......@@ -340,11 +340,12 @@ checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
checkValSig other ty loc = parseError "Type signature given for an expression"
-- A variable binding is parsed as an RdrNamePatBind.
-- A variable binding is parsed as an RdrNameFunMonoBind.
-- See comments with HsBinds.MonoBinds
isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
= Just (op, True, (l:r:es))
isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f)
isFunLhs (HsVar f) es | not (isRdrDataCon f)
= Just (f,False,es)
isFunLhs (HsApp f e) es = isFunLhs f (e:es)
isFunLhs (HsPar e) es = isFunLhs e es
......
{-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.29 2000/03/24 17:49:30 simonpj Exp $
$Id: Parser.y,v 1.30 2000/05/23 11:35:37 simonpj Exp $
Haskell grammar.
......@@ -397,10 +397,6 @@ opt_phase :: { Maybe Int }
: INTEGER { Just (fromInteger $1) }
| {- empty -} { Nothing }
sigtypes :: { [RdrNameHsType] }
: sigtype { [ $1 ] }
| sigtypes ',' sigtype { $3 : $1 }
wherebinds :: { RdrNameHsBinds }
: where { cvBinds cvValSig (groupBindings $1) }
......@@ -421,13 +417,6 @@ fixdecl :: { RdrBinding }
(Fixity $3 $2) $1))
| n <- $4 ] }
sigtype :: { RdrNameHsType }
: ctype { mkHsForAllTy Nothing [] $1 }
sig_vars :: { [RdrName] }
: sig_vars ',' var { $3 : $1 }
| var { [ $1 ] }
-----------------------------------------------------------------------------
-- Transformation Rules
......@@ -485,6 +474,29 @@ ext_name :: { Maybe ExtName }
| STRING STRING { Just (ExtName $2 (Just $1)) }
| {- empty -} { Nothing }
-----------------------------------------------------------------------------
-- Type signatures
opt_sig :: { Maybe RdrNameHsType }
: {- empty -} { Nothing }
| '::' sigtype { Just $2 }
opt_asig :: { Maybe RdrNameHsType }
: {- empty -} { Nothing }
| '::' atype { Just $2 }
sigtypes :: { [RdrNameHsType] }
: sigtype { [ $1 ] }
| sigtypes ',' sigtype { $3 : $1 }
sigtype :: { RdrNameHsType }
: ctype { mkHsForAllTy Nothing [] $1 }
sig_vars :: { [RdrName] }
: sig_vars ',' var { $3 : $1 }
| var { [ $1 ] }
-----------------------------------------------------------------------------
-- Types
......@@ -797,14 +809,6 @@ alt :: { RdrNameMatch }
returnP (Match [] [p] $2
(GRHSs $3 $4 Nothing)) }
opt_sig :: { Maybe RdrNameHsType }
: {- empty -} { Nothing }
| '::' sigtype { Just $2 }
opt_asig :: { Maybe RdrNameHsType }
: {- empty -} { Nothing }
| '::' atype { Just $2 }
ralt :: { [RdrNameGRHS] }
: '->' srcloc exp { [GRHS [ExprStmt $3 $2] $2] }
| gdpats { (reverse $1) }
......
......@@ -379,12 +379,6 @@ rnMethodBinds (FunMonoBind name inf matches locn)
mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_`
returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name)
rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn)
= pushSrcLocRn locn $
lookupGlobalOccRn name `thenRn` \ sel_name ->
rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs `addOneFV` sel_name)
-- Can't handle method pattern-bindings which bind multiple methods.
rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
= pushSrcLocRn locn $
......
......@@ -35,17 +35,15 @@ import OccName ( OccName,
)
import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon )
import Type ( funTyCon )
import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule )
import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule, pprModuleName )
import TyCon ( TyCon )
import FiniteMap
import Unique ( Unique, Uniquable(..) )
import UniqFM ( emptyUFM, listToUFM, plusUFM_C )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import Outputable
import Util ( removeDups, equivClasses, thenCmp )
import List ( nub )
import Maybes ( mapMaybe )
\end{code}
......@@ -595,46 +593,6 @@ will still have different provenances.
\subsubsection{ExportAvails}% ================
\begin{code}
mkEmptyExportAvails :: ModuleName -> ExportAvails
mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
mkExportAvails mod_name unqual_imp name_env avails
= (mod_avail_env, entity_avail_env)
where
mod_avail_env = unitFM mod_name unqual_avails
-- unqual_avails is the Avails that are visible in *unqualfied* form
-- (1.4 Report, Section 5.1.1)
-- For example, in
-- import T hiding( f )
-- we delete f from avails
unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
| otherwise = mapMaybe prune avails
prune (Avail n) | unqual_in_scope n = Just (Avail n)
prune (Avail n) | otherwise = Nothing
prune (AvailTC n ns) | null uqs = Nothing
| otherwise = Just (AvailTC n uqs)
where
uqs = filter unqual_in_scope ns
unqual_in_scope n = unQualInScope name_env n
entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
name <- availNames avail]
plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
plusExportAvails (m1, e1) (m2, e2)
= (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)
-- ToDo: wasteful: we do this once for each constructor!
\end{code}
\subsubsection{AvailInfo}% ================
\begin{code}
......@@ -768,7 +726,7 @@ warnUnusedModules mods
| not opt_WarnUnusedImports = returnRn ()
| otherwise = mapRn_ (addWarnRn . unused_mod) mods
where
unused_mod m = ptext SLIT("Module") <+> quotes (ppr m) <+>
unused_mod m = ptext SLIT("Module") <+> quotes (pprModuleName m) <+>
ptext SLIT("is imported, but nothing from it is used")
warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d ()
......
......@@ -174,7 +174,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
rhs_sig_tyvars = case maybe_rhs_sig of
Nothing -> []
Just ty -> extractHsTyRdrNames ty
Just ty -> extractHsTyRdrTyVars ty
tyvars_in_pats = extractPatsTyVars pats
forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
doc_sig = text "a pattern type-signature"
......@@ -191,7 +191,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
(case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs)
Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
Just ty | opt_GlasgowExts -> rnHsPolyType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs)
......@@ -638,7 +638,7 @@ mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the righ
= addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
returnRn (OpApp e1 op1 fix1 e2)
where
(nofix_err, associate_right) = compareFixity fix1 negateFixity
(_, associate_right) = compareFixity fix1 negateFixity
---------------------------
-- Default case
......
......@@ -34,7 +34,6 @@ import PrelMods
import PrelInfo ( main_RDR )
import UniqFM ( lookupUFM )
import Bag ( bagToList )
import Maybes ( maybeToBool, catMaybes )
import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
import NameSet
import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..),
......@@ -46,6 +45,8 @@ import OccName ( setOccNameSpace, dataName )
import SrcLoc ( SrcLoc )
import NameSet ( elemNameSet, emptyNameSet )
import Outputable
import Maybes ( maybeToBool, catMaybes, mapMaybe )
import UniqFM ( emptyUFM, listToUFM, plusUFM_C )
import Unique ( getUnique )
import Util ( removeDups, equivClassesByUniq, sortLt )
import List ( partition )
......@@ -241,27 +242,29 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i
returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name)
else
filterImports imp_mod_name import_spec avails
`thenRn` \ (filtered_avails, hides, explicits) ->
filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
qualifyImports imp_mod_name
(not qual_only) -- Maybe want unqualified names
as_mod hides
(improveAvails imp_mod iloc explicits
is_unqual filtered_avails)
improveAvails imp_mod iloc explicits is_unqual avails
-- We 'improve' the provenance by setting
-- (a) the import-reason field, so that the Name says how it came into scope
-- including whether it's explicitly imported
-- (b) the print-unqualified field
-- But don't fiddle with wired-in things or we get in a twist
let
improve_prov name =
setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name))
(is_unqual name))
is_explicit name = name `elemNameSet` explicits
in
qualifyImports imp_mod_name
(not qual_only) -- Maybe want unqualified names
as_mod hides
filtered_avails improve_prov
`thenRn` \ (rdr_name_env, mod_avails) ->
= map improve_avail avails
where
improve_avail (Avail n) = Avail (improve n)
improve_avail (AvailTC n ns) = AvailTC n (map improve ns) -- n doesn't matter
returnRn (rdr_name_env, mod_avails)
improve name = setNameProvenance name
(NonLocalDef (UserImport imp_mod iloc (is_explicit name))
(is_unqual name))
is_explicit name = name `elemNameSet` explicits
\end{code}
......@@ -290,7 +293,6 @@ importsFromLocalDecls mod_name rec_exp_fn decls
Nothing -- no 'as M'
[] -- Hide nothing
avails
(\n -> n)
where
mod = mkThisModule mod_name
......@@ -437,9 +439,6 @@ filterImports mod (Just (want_hiding, import_items)) avails
Nothing -> bale_out item
Just avail -> returnRn [(avail, availNames avail)]
ok_dotdot_item (AvailTC _ [n]) = False
ok_dotdot_item other = True
check_item item
| not (maybeToBool maybe_in_import_avails) ||
not (maybeToBool maybe_filtered_avail)
......@@ -476,14 +475,9 @@ qualifyImports :: ModuleName -- Imported module
-> Maybe ModuleName -- Optional "as M" part
-> [AvailInfo] -- What's to be hidden
-> Avails -- Whats imported and how
-> (Name -> Name) -- Improves the provenance on imported things
-> RnMG (GlobalRdrEnv, ExportAvails)
-- NB: the Names in ExportAvails don't have the improve-provenance
-- function applied to them
-- We could fix that, but I don't think it matters
qualifyImports this_mod unqual_imp as_mod hides
avails improve_prov
qualifyImports this_mod unqual_imp as_mod hides avails
=
-- Make the name environment. We're talking about a
-- single module here, so there must be no name clashes.
......@@ -513,14 +507,49 @@ qualifyImports this_mod unqual_imp as_mod hides
| unqual_imp = env2
| otherwise = env1
where
env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) better_name
env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) better_name
occ = nameOccName name
better_name = improve_prov name
env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) name
env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) name
occ = nameOccName name
del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
where
rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
mkEmptyExportAvails :: ModuleName -> ExportAvails
mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
mkExportAvails mod_name unqual_imp name_env avails
= (mod_avail_env, entity_avail_env)
where
mod_avail_env = unitFM mod_name unqual_avails
-- unqual_avails is the Avails that are visible in *unqualfied* form
-- (1.4 Report, Section 5.1.1)
-- For example, in
-- import T hiding( f )
-- we delete f from avails
unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
| otherwise = mapMaybe prune avails
prune (Avail n) | unqual_in_scope n = Just (Avail n)
prune (Avail n) | otherwise = Nothing
prune (AvailTC n ns) | null uqs = Nothing
| otherwise = Just (AvailTC n uqs)
where
uqs = filter unqual_in_scope ns
unqual_in_scope n = unQualInScope name_env n
entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
name <- availNames avail]
plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
plusExportAvails (m1, e1) (m2, e2)
= (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)
-- ToDo: wasteful: we do this once for each constructor!
\end{code}
......
......@@ -54,6 +54,7 @@ import PprCore () -- Instances
import Rules ( RuleBase )
import CostCentre ( CostCentreStack, subsumedCCS )
import Name ( isLocallyDefined )
import OccName ( UserFS )
import Var ( TyVar )
import VarEnv
import VarSet
......@@ -674,20 +675,19 @@ setSimplBinderStuff (subst, us) m env _ sc
\begin{code}
newId :: Type -> (Id -> SimplM a) -> SimplM a
newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
-- Extends the in-scope-env too
newId ty m env@(SimplEnv {seSubst = subst}) us sc
newId fs ty m env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
(us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
where
v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
v = mkSysLocal fs (uniqFromSupply us1) ty
newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
newIds tys m env@(SimplEnv {seSubst = subst}) us sc
newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
newIds fs tys m env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
(us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
where
vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
vs = zipWithEqual "newIds" (mkSysLocal fs)
(uniqsFromSupply (length tys) us1) tys
\end{code}
......@@ -567,7 +567,7 @@ tryEtaExpansion rhs
= returnSmpl rhs
| otherwise -- Consider eta expansion
= newIds y_tys $ ( \ y_bndrs ->
= newIds SLIT("y") y_tys $ ( \ y_bndrs ->
tick (EtaExpansion (head y_bndrs)) `thenSmpl_`
mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args) `thenSmpl` (\ (maybe_z_binds, z_args) ->
returnSmpl (mkLams x_bndrs $
......@@ -582,7 +582,7 @@ tryEtaExpansion rhs
bind_z_arg (arg, trivial_arg)
| trivial_arg = returnSmpl (Nothing, arg)
| otherwise = newId (exprType arg) $ \ z ->
| otherwise = newId SLIT("z") (exprType arg) $ \ z ->
returnSmpl (Just (NonRec z arg), Var z)
-- Note: I used to try to avoid the exprType call by using
......
......@@ -898,7 +898,7 @@ prepareArgs no_case_of_case fun orig_cont thing_inside
= simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg ->
-- A data constructor whose argument is now non-trivial;
-- so let/case bind it.
newId arg_ty $ \ arg_id ->
newId SLIT("a") arg_ty $ \ arg_id ->
addNonRecBind arg_id new_arg $
go (Var arg_id : acc) ds' res_ty cont
......@@ -1345,10 +1345,10 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts
let
ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
arg_tys = dataConArgTys data_con
(inst_tys ++ mkTyVarTys ex_tyvars')
in
newIds (dataConArgTys
data_con
(inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
newIds SLIT("a") arg_tys $ \ bndrs ->
returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
other -> returnSmpl filtered_alts
......@@ -1452,13 +1452,15 @@ mkDupableCont ty (InlinePlease cont) thing_inside
mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
= -- Build the RHS of the join point
newId join_arg_ty ( \ arg_id ->
newId SLIT("a") join_arg_ty ( \ arg_id ->
cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs))
) `thenSmpl` \ join_rhs ->
-- Build the join Id and continuation
newId (exprType join_rhs) $ \ join_id ->
-- We give it a "$j" name just so that for later amusement
-- we can identify any join points that don't end up as let-no-escapes
newId SLIT("$j") (exprType join_rhs) $ \ join_id ->
let
new_cont = ArgOf OkToDup cont_ty
(\arg' -> rebuild_done (App (Var join_id) arg'))
......@@ -1476,9 +1478,9 @@ mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
if exprIsDupable arg' then
thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
else
newId (exprType arg') $ \ bndr ->
newId SLIT("a") (exprType arg') $ \ bndr ->
tick (CaseOfCase bndr) `thenSmpl_`
tick (CaseOfCase bndr) `thenSmpl_`
-- Want to tick here so that we go round again,
-- and maybe copy or inline the code;
-- not strictly CaseOf Case
......@@ -1574,14 +1576,15 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs)
-- then 78
-- else 5
then newId realWorldStatePrimTy $ \ rw_id ->
then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
else
returnSmpl (used_bndrs', map varToCoreExpr used_bndrs)
)
`thenSmpl` \ (final_bndrs', final_args) ->