From: simonpj Date: Mon, 6 Dec 1999 11:54:59 +0000 (+0000) Subject: [project @ 1999-12-06 11:54:56 by simonpj] X-Git-Tag: Approximately_9120_patches~5427 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=fbdd694d0ba92a4c54d25fc609a78c93da4d6af2;p=ghc-hetmet.git [project @ 1999-12-06 11:54:56 by simonpj] Fix a major bug in exporting unfoldings involving existentials. Change core printing so that we put an '@' before type variables in case patterns. This only affects existentials. case x of C @ a x y -> ... Here 'a' is an existentially quantified type variable, and the '@' signifies this. We continue to omit kinds and type on case-bound variables; the type checker can fill them in. The reason for this change is that type variables and term variables live in a different name space, so we need to know which name space is involved when binding one. How this ever worked I will never know. While I was at it, I also arranged that -ddump-rn prints out whatever it has even if it finds errors. Adding -dppr-debug prints even the unfoldings on imported things. Simon --- diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 9f8a16d..67bd8a4 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -321,7 +321,7 @@ pprIfaceBinder CaseBind binder = pprUntypedBinder binder pprIfaceBinder other binder = pprTypedBinder binder pprUntypedBinder binder - | isTyVar binder = pprTyVarBndr binder + | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder | otherwise = pprIdBndr binder pprTypedBinder binder diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 07293c6..7148311 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -120,9 +120,11 @@ instance Outputable name => Outputable (UfExpr name) where = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body] instance Outputable name => Outputable (UfCon name) where - ppr UfDefault = text "DEFAULT" - ppr (UfDataCon d) = ppr d - ppr (UfPrimOp p) = ppr p + ppr UfDefault = text "DEFAULT" + ppr (UfLitCon l) = ppr l + ppr (UfLitLitCon l ty) = ppr l + ppr (UfDataCon d) = ppr d + ppr (UfPrimOp p) = ppr p ppr (UfCCallOp str is_dyn is_casm can_gc) = hcat [before, ptext str, after] where @@ -150,9 +152,9 @@ data IfaceSig name SrcLoc instance (Outputable name) => Outputable (IfaceSig name) where - ppr (IfaceSig var ty _ _) + ppr (IfaceSig var ty info _) = hang (hsep [ppr var, dcolon]) - 4 (ppr ty) + 4 (ppr ty $$ ifPprDebug (vcat (map ppr info))) data HsIdInfo name = HsArity ArityInfo @@ -164,6 +166,10 @@ data HsIdInfo name | HsCprInfo CprInfo | HsWorker name -- Worker, if any +instance Outputable name => Outputable (HsIdInfo name) where + ppr (HsUnfold _ unf) = ptext (SLIT("Unfolding:")) <+> ppr unf + ppr other = empty -- Havn't got around to this yet + data HsStrictnessInfo = HsStrictnessInfo ([Demand], Bool) | HsBottom diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index e507f7e..f894349 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -714,13 +714,24 @@ core_alt : core_pat '->' core_expr { (fst $1, snd $1, $3) } core_pat :: { (UfCon RdrName, [RdrName]) } core_pat : core_lit { (UfLitCon $1, []) } | '__litlit' STRING atype { (UfLitLitCon $2 $3, []) } - | qdata_name var_names { (UfDataCon $1, $2) } + | qdata_name core_pat_names { (UfDataCon $1, $2) } | '(' comma_var_names1 ')' { (UfDataCon (mkTupConRdrName (length $2)), $2) } | '(#' comma_var_names1 '#)' { (UfDataCon (mkUbxTupConRdrName (length $2)), $2) } | '__DEFAULT' { (UfDefault, []) } | '(' core_pat ')' { $2 } - +core_pat_names :: { [RdrName] } +core_pat_names : { [] } + | core_pat_name core_pat_names { $1 : $2 } + +-- Tyvar names and variable names live in different name spaces +-- so they need to be signalled separately. But we don't record +-- types or kinds in a pattern; we work that out from the type +-- of the case scrutinee +core_pat_name :: { RdrName } +core_pat_name : var_name { $1 } + | '@' tv_name { $2 } + comma_var_names1 :: { [RdrName] } -- One or more comma_var_names1 : var_name { [$1] } | var_name ',' comma_var_names1 { $1 : $3 } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 9893a3e..730f02d 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -72,18 +72,13 @@ renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc = -- Initialise the renamer monad initRn mod_name us (mkSearchPath opt_HiMap) loc (rename this_mod) >>= - \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) -> + \ ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) -> -- Check for warnings printErrorsAndWarnings rn_errs_bag rn_warns_bag >> - -- Dump output, if any - (case maybe_rn_stuff of - Nothing -> return () - Just results@(_, rn_mod, _, _, _) - -> dumpIfSet opt_D_dump_rn "Renamer:" - (ppr rn_mod) - ) >> + -- Dump any debugging output + dump_action >> -- Return results if not (isEmptyBag rn_errs_bag) then @@ -101,8 +96,8 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc) -- CHECK FOR EARLY EXIT if not (maybeToBool maybe_stuff) then -- Everything is up to date; no need to recompile further - rnStats [] `thenRn_` - returnRn Nothing + rnDump [] [] `thenRn` \ dump_action -> + returnRn (Nothing, dump_action) else let Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff @@ -122,13 +117,16 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc) -- override the implicit ones. in slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls -> + let + rn_all_decls = rn_imp_decls ++ rn_local_decls + in -- EXIT IF ERRORS FOUND - checkErrsRn `thenRn` \ no_errs_so_far -> + checkErrsRn `thenRn` \ no_errs_so_far -> if not no_errs_so_far then -- Found errors already, so exit now - rnStats [] `thenRn_` - returnRn Nothing + rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action -> + returnRn (Nothing, dump_action) else -- GENERATE THE VERSION/USAGE INFO @@ -144,18 +142,17 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc) let has_orphans = any isOrphanDecl rn_local_decls direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] - rn_all_decls = rn_imp_decls ++ rn_local_decls renamed_module = HsModule mod_name vers trashed_exports trashed_imports rn_all_decls loc in - rnStats rn_imp_decls `thenRn_` + rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action -> returnRn (Just (mkThisModule mod_name, renamed_module, (has_orphans, my_usages, export_env), name_supply, - direct_import_mods)) + direct_import_mods), dump_action) where trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing trashed_imports = {-trace "rnSource:trashed_imports"-} [] @@ -517,18 +514,20 @@ reportableUnusedName name explicitlyImported other = False -- Don't report others -rnStats :: [RenamedHsDecl] -> RnMG () -rnStats imp_decls +rnDump :: [RenamedHsDecl] -- Renamed imported decls + -> [RenamedHsDecl] -- Renamed local decls + -> RnMG (IO ()) +rnDump imp_decls decls | opt_D_dump_rn_trace || opt_D_dump_rn_stats || opt_D_dump_rn - = getRnStats imp_decls `thenRn` \ msg -> - ioToRnM (printErrs msg) `thenRn_` - returnRn () + = getRnStats imp_decls `thenRn` \ stats_msg -> - | otherwise = returnRn () -\end{code} + returnRn (printErrs stats_msg >> + dumpIfSet opt_D_dump_rn "Renamer:" (vcat (map ppr decls))) + | otherwise = returnRn (return ()) +\end{code} %*********************************************************