From b0045fdd4404f3ac2ddacad8c39a017f01f8ff6b Mon Sep 17 00:00:00 2001 From: Tim Chevalier Date: Tue, 22 Apr 2008 01:27:34 +0000 Subject: [PATCH] Naming changes in External Core Two changes: - Top-level bindings in a given module are now printed as a single %rec group. I found that in External Core generated from optimized code, nonrec bindings weren't being printed in dependency order. Rather than fixing that, I decided to not even pretend to preserve dependency order (since there's recursion between modules anyway.) - Internal names are now printed with their uniques attached (otherwise, GHC was printing out code with shadowed bindings, and this isn't supposed to happen in External Core.) --- compiler/coreSyn/MkExternalCore.lhs | 19 +++++++++++++++---- compiler/coreSyn/PprExternalCore.lhs | 3 ++- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 5ca4345..ba0c198 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -63,9 +63,18 @@ mkExternalCore :: CgGuts -> C.Module -- not been injected, so we have to add them manually here -- We don't include the strange data-con *workers* because they are -- implicit in the data type declaration itself -mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, cg_binds = binds}) - = (C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds) - this_mod)) +mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, + cg_binds = binds}) + -- Note that we flatten binds at the top level: + -- every module is just a single recursive bag of declarations. + -- Rationale: since modules can be mutually recursive, + -- there's not much reason to preserve dependency info within a module. + = C.Module mname tdefs (case flattenBinds binds of + -- check for empty list so we don't create an + -- empty Rec group + [] -> [] + bs -> [(runCoreM (make_vdef True + (Rec bs)) this_mod)]) where mname = make_mid this_mod tdefs = foldr collect_tdefs [] tycons @@ -261,7 +270,9 @@ make_kind _ = error "MkExternalCore died: make_kind" {- Id generation. -} make_id :: Bool -> Name -> C.Id -make_id _is_var nm = (occNameString . nameOccName) nm +-- include uniques for internal names in order to avoid name shadowing +make_id _is_var nm = ((occNameString . nameOccName) nm) + ++ (if isInternalName nm then (show . nameUnique) nm else "") make_var_id :: Name -> C.Id make_var_id = make_id True diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs index ffa4675..fb4fc45 100644 --- a/compiler/coreSyn/PprExternalCore.lhs +++ b/compiler/coreSyn/PprExternalCore.lhs @@ -55,6 +55,7 @@ ptdef (Data tcon tbinds cdefs) = $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs))))) ptdef (Newtype tcon tbinds (coercion,tbs,k) rep) = +-- TODO: I think this is kind of redundant now. -- Here we take apart the newtype tycon in order to get the newtype coercion, -- which needs to be represented in the External Core file because it's not -- straightforward to derive its definition from the newtype declaration alone. @@ -107,7 +108,7 @@ paty (Tcon c) = pqname c paty t = parens (pty t) pbty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [pbty t1, text "->",pty t2]) -pbty (Tapp t1 t2) = pappty t1 [t2] +pbty (Tapp t1 t2) = parens $ pappty t1 [t2] pbty t = paty t pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2] -- 1.7.10.4