\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
-- Class NamedThing and overloaded friends
NamedThing(..),
- getSrcLoc, isLocallyDefined, getOccString
+ getSrcLoc, isLocallyDefined, getOccString, toRdrName
) where
#include "HsVersions.h"
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
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}
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,
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}
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 ->
-- 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,
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
| 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)
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,
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")
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
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.
: INTEGER { Just (fromInteger $1) }
| {- empty -} { Nothing }
-sigtypes :: { [RdrNameHsType] }
- : sigtype { [ $1 ] }
- | sigtypes ',' sigtype { $3 : $1 }
-
wherebinds :: { RdrNameHsBinds }
: where { cvBinds cvValSig (groupBindings $1) }
(Fixity $3 $2) $1))
| n <- $4 ] }
-sigtype :: { RdrNameHsType }
- : ctype { mkHsForAllTy Nothing [] $1 }
-
-sig_vars :: { [RdrName] }
- : sig_vars ',' var { $3 : $1 }
- | var { [ $1 ] }
-
-----------------------------------------------------------------------------
-- Transformation Rules
| 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
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) }
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 $
)
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}
-\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}
| 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 ()
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"
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)
= 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
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(..),
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 )
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}
Nothing -- no 'as M'
[] -- Hide nothing
avails
- (\n -> n)
where
mod = mkThisModule mod_name
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)
-> 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.
| 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}
import Rules ( RuleBase )
import CostCentre ( CostCentreStack, subsumedCCS )
import Name ( isLocallyDefined )
+import OccName ( UserFS )
import Var ( TyVar )
import VarEnv
import VarSet
\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}
= 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 $
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
= 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
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
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'))
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
-- 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) ->
- newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
+ -- See comment about "$j" name above
+ newId SLIT("$j") (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
-- Notice that we make the lambdas into one-shot-lambdas. The
-- join point is sure to be applied at most once, and doing so
import PrimOp ( PrimOp(..), ccallMayGC )
import TysWiredIn ( isForeignObjTy )
import Maybes ( maybeToBool, orElse )
-import Name ( isLocallyDefined )
+import Name ( isLocallyDefined, getOccName )
+import OccName ( occNameUserString )
import BasicTypes ( Arity )
import Outputable
-- Compute the new let-expression
let
- new_let = if let_no_escape then
- -- trace "StgLetNoEscape!" (
- StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
- -- )
- else
- StgLet bind2 body2
+ new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
+ | otherwise = StgLet bind2 body2
free_in_whole_let
= (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
-- this let(rec)
no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
+
+#ifdef DEBUG
+ -- Debugging code as requested by Andrew Kennedy
+ checked_no_binder_escapes
+ | not no_binder_escapes && any is_join_var binders
+ = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
+ False
+ | otherwise = no_binder_escapes
+#else
+ checked_no_binder_escapes = no_binder_escapes
+#endif
+
-- Mustn't depend on the passed-in let_no_escape flag, since
-- no_binder_escapes is used by the caller to derive the flag!
in
new_let,
free_in_whole_let,
let_escs,
- no_binder_escapes
+ checked_no_binder_escapes
))
where
set_of_binders = mkVarSet binders
in
returnLne (StgRec (binders' `zip` rhss2), fvs, escs, env_ext)
))
+
+is_join_var :: Id -> Bool
+-- A hack (used only for compiler debuggging) to tell if
+-- a variable started life as a join point ($j)
+is_join_var j = occNameUserString (getOccName j) == "$j"
\end{code}
%************************************************************************
import {-# SOURCE #-} TcExpr ( tcExpr )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
- collectMonoBinders, andMonoBindList, andMonoBinds
+ Match(..), collectMonoBinders, andMonoBindList, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
is_elem v vs = isIn "isUnResMono" v vs
-isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
-isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
+isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches ||
+ v `is_elem` sigs
isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
isUnRestrictedGroup sigs mb2
isUnRestrictedGroup sigs EmptyMonoBinds = True
+
+isUnRestrictedMatch (Match _ [] Nothing _) = False -- No args, no signature
+isUnRestrictedMatch other = True -- Some args or a signature
\end{code}
import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
InPat(..), HsBinds(..), GRHSs(..),
HsExpr(..), HsLit(..), HsType(..), HsPred(..),
- pprHsClassAssertion, unguardedRHS,
- andMonoBinds, andMonoBindList, getTyVarName,
+ pprHsClassAssertion, mkSimpleMatch,
+ andMonoBinds, andMonoBindList, getTyVarName,
isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
)
import HsPragmas ( ClassPragmas(..) )
returnTc (sc_theta', sc_tys, sc_sel_ids)
where
- rec_tyvar_tys = mkTyVarTys rec_tyvars
-
check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
(superClassErr class_name (c, tys))
-- but we must use the method name; so we substitute it here. Crude but simple.
find_bind meth_name (FunMonoBind op_name fix matches loc)
| op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
- find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc)
- | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc)
find_bind meth_name (AndMonoBinds b1 b2)
= find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
find_bind meth_name other = Nothing -- Default case
find_prags meth_name (prag:prags) = find_prags meth_name prags
mk_default_bind local_meth_name loc
- = PatMonoBind (VarPatIn local_meth_name)
- (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing)
+ = FunMonoBind local_meth_name
+ False -- Not infix decl
+ [mkSimpleMatch [] (default_expr loc) Nothing loc]
loc
default_expr loc
newTyVarTy boxedTypeKind `thenNF_Tc` \ result_ty ->
let
io_result_ty = mkTyConApp ioTyCon [result_ty]
- [ioDataCon] = tyConDataCons ioTyCon
in
unifyTauTy res_ty io_result_ty `thenTc_`
splitSigmaTy (idType sel_id) -- Selectors can be overloaded
-- when the data type has a context
Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
- (tycon, _, data_cons) = splitAlgTyConApp data_ty
- (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
+ (tycon, _, data_cons) = splitAlgTyConApp data_ty
+ (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
in
tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
(main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
- (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
- ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
- ex_tys' = mkTyVarTys ex_tyvars'
- arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
- id_names = drop (length ex_tyvars) names
+ (_, inst_tys, cons) = splitAlgTyConApp scrut_ty
+ ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
+ ex_tys' = mkTyVarTys ex_tyvars'
+ arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
+ id_names = drop (length ex_tyvars) names
arg_ids
#ifdef DEBUG
| length id_names /= length arg_tys
Just (tycon, arg_tys) = maybe_tycon_app
-- Stuff for an *algebraic* data type
- alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
- -- The "Alg" part looks through synonyms
- is_alg_tycon_app = maybeToBool alg_tycon_app_maybe
- Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe
-
- constructors_visible = not (null data_cons)
+ alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
+ -- The "Alg" part looks through synonyms
+ Just (alg_tycon, _, _) = alg_tycon_app_maybe
ccallable_type ty = isFFIArgumentTy False {- Not safe call -} ty
creturnable_type ty = isFFIResultTy ty
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_tc )
+import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_types, opt_PprStyle_Debug )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
import RnHsSyn ( RenamedHsModule )
import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds,
import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv,
getEnvTyCons, getEnvClasses, tcLookupValueMaybe,
explicitLookupValueByKey, tcSetValueEnv,
- tcLookupTyCon, initEnv,
+ tcLookupTyCon, initEnv, valueEnvIds,
ValueEnv, TcTyThing(..)
)
import TcExpr ( tcId )
import ErrUtils ( Message, printErrorsAndWarnings, dumpIfSet )
import Id ( Id, idType )
import Module ( pprModuleName )
-import Name ( Name, nameUnique, isLocallyDefined, NamedThing(..) )
+import OccName ( isSysOcc )
+import Name ( Name, nameUnique, nameOccName, isLocallyDefined,
+ toRdrName, NamedThing(..)
+ )
import TyCon ( TyCon, tyConKind )
import Class ( Class, classSelIds, classTyCon )
import Type ( mkTyConApp, mkForAllTy,
Nothing -> return ()
) >>
- dumpIfSet opt_D_dump_tc "Typechecked"
- (case maybe_result of
- Just results -> ppr (tc_binds results)
- $$
- pp_rules (tc_rules results)
- Nothing -> text "Typecheck failed") >>
-
+ (case maybe_result of
+ Nothing -> return ()
+ Just results -> dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results)
+ ) >>
+
return (if isEmptyBag errs then
maybe_result
else
Nothing)
+dump_tc results
+ = ppr (tc_binds results) $$ pp_rules (tc_rules results)
+
pp_rules [] = empty
pp_rules rs = vcat [ptext SLIT("{-# RULES"),
nest 4 (vcat (map ppr rs)),
polyPatSig :: TcType -> SDoc
polyPatSig sig_ty
- = hang (ptext SLIT("Polymorphic type signature in pattern"))
+ = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
4 (ppr sig_ty)
\end{code}
tcDecl is_rec_group unf_env inst_mapper vrcs_env decl
= tcAddDeclCtxt decl $
--- traceTc (text "Starting" <+> ppr name) `thenTc_`
if isClassDecl decl then
tcClassDecl1 unf_env inst_mapper vrcs_env decl `thenTc` \ clas ->
--- traceTc (text "Finished" <+> ppr name) `thenTc_`
returnTc (getName clas, AClass clas)
else
tcTyDecl is_rec_group vrcs_env decl `thenTc` \ tycon ->
--- traceTc (text "Finished" <+> ppr name) `thenTc_`
returnTc (getName tycon, ATyCon tycon)
-
- where
- name = tyClDeclName decl
tcAddDeclCtxt decl thing_inside
edges = map mk_edges tycl_decls
is_syn_decl (d, _, _) = isSynDecl d
- is_cls_decl (d, _, _) = isClassDecl d
\end{code}
Edges in Type/Class decls
projects / ghc-hetmet.git / commitdiff