From 99bab7d8385401ca552f6f161bd69d9d144f8309 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Sun, 2 Jul 2006 20:45:59 +0000 Subject: [PATCH] Add %local-tag to external core output Hello, this is my first patch contributed to GHC. If there are any inadequacies about it (maybe like this introductory disclaimer), please let me know about it. So, the need for this patch arose, while I was involved with processing hcr files (external core output) and I noticed, that the output didn't fully conform to the specification [1]. No %local-tags were used, which turned out to be a real nuisance as it was not possible to determine which VDEFs can be erased in a further optimization process and which ones are exported by the module. Since the specification does not define the meaning of the %local-tag, I assume, it makes sense, that it tags all functions, that are not exported by the module. The patch does not fully comply to the specification, as in my implementation a local tag may appear before a VDEF but not before a VDEFG. [1] An External Representation for the GHC Core Language (DRAFT for GHC5.02), page 3, line 1 Greetings Jan --- compiler/coreSyn/ExternalCore.lhs | 2 +- compiler/coreSyn/MkExternalCore.lhs | 26 +++++++++++++++----------- compiler/coreSyn/PprExternalCore.lhs | 9 ++++++--- compiler/main/HscMain.lhs | 2 +- 4 files changed, 23 insertions(+), 16 deletions(-) diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs index 948f595..fa17734 100644 --- a/compiler/coreSyn/ExternalCore.lhs +++ b/compiler/coreSyn/ExternalCore.lhs @@ -21,7 +21,7 @@ data Vdefg = Rec [Vdef] | Nonrec Vdef -type Vdef = (Var,Ty,Exp) -- Top level bindings are unqualified now +type Vdef = (Bool,Var,Ty,Exp) -- Top level bindings are unqualified now data Exp = Var (Qual Var) diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 3315240..3910d5b 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -26,6 +26,8 @@ import IdInfo import Kind import Literal import Name +import NameSet ( NameSet, emptyNameSet ) +import UniqSet ( elementOfUniqSet ) import Outputable import ForeignCall import DynFlags ( DynFlags(..) ) @@ -33,27 +35,27 @@ import StaticFlags ( opt_EmitExternalCore ) import IO import FastString -emitExternalCore :: DynFlags -> CgGuts -> IO () -emitExternalCore dflags cg_guts +emitExternalCore :: DynFlags -> NameSet -> CgGuts -> IO () +emitExternalCore dflags exports cg_guts | opt_EmitExternalCore = (do handle <- openFile corename WriteMode - hPutStrLn handle (show (mkExternalCore cg_guts)) + hPutStrLn handle (show (mkExternalCore exports cg_guts)) hClose handle) `catch` (\err -> pprPanic "Failed to open or write external core output file" (text corename)) where corename = extCoreName dflags -emitExternalCore _ _ +emitExternalCore _ _ _ | otherwise = return () -mkExternalCore :: CgGuts -> C.Module +mkExternalCore :: NameSet -> CgGuts -> C.Module -- The ModGuts has been tidied, but the implicit bindings have -- 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 (map make_vdef binds) +mkExternalCore exports (CgGuts {cg_module=this_mod, cg_tycons = tycons, cg_binds = binds}) + = C.Module mname tdefs (map (make_vdef exports) binds) where mname = make_mid this_mod tdefs = foldr collect_tdefs [] tycons @@ -90,12 +92,14 @@ make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv)) make_vbind :: Var -> C.Vbind make_vbind v = (make_var_id (Var.varName v), make_ty (idType v)) -make_vdef :: CoreBind -> C.Vdefg -make_vdef b = +make_vdef :: NameSet -> CoreBind -> C.Vdefg +make_vdef exports b = case b of NonRec v e -> C.Nonrec (f (v,e)) Rec ves -> C.Rec (map f ves) - where f (v,e) = (make_var_id (Var.varName v), make_ty (idType v),make_exp e) + where + f (v,e) = (local, make_var_id (Var.varName v), make_ty (idType v),make_exp e) + where local = not $ elementOfUniqSet (Var.varName v) exports -- Top level bindings are unqualified now make_exp :: CoreExpr -> C.Exp @@ -112,7 +116,7 @@ make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t) make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2) make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e) make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e) -make_exp (Let b e) = C.Let (make_vdef b) (make_exp e) +make_exp (Let b e) = C.Let (make_vdef emptyNameSet b) (make_exp e) -- gaw 2004 make_exp (Case e v ty alts) = C.Case (make_exp e) (make_vbind v) (make_ty ty) (map make_alt alts) make_exp (Note (SCC cc) e) = C.Note "SCC" (make_exp e) -- temporary diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs index 26c89cc..29451d0 100644 --- a/compiler/coreSyn/PprExternalCore.lhs +++ b/compiler/coreSyn/PprExternalCore.lhs @@ -95,12 +95,15 @@ pappty t ts = sep (map paty (t:ts)) pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t -pvdefg (Rec vtes) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvte vtes)))) -pvdefg (Nonrec vte) = pvte vte +pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs)))) +pvdefg (Nonrec vdef) = pvdef vdef -pvte (v,t,e) = sep [pname v <+> text "::" <+> pty t <+> char '=', +pvdef (l,v,t,e) = sep [plocal l <+> pname v <+> text "::" <+> pty t <+> char '=', indent (pexp e)] +plocal True = text "%local" +plocal False = empty + paexp (Var x) = pqname x paexp (Dcon x) = pqname x paexp (Lit l) = plit l diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index d25202f..1823910 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -526,7 +526,7 @@ hscNormalIface simpl_result <- {-# SCC "MkFinalIface" #-} mkIface hsc_env maybe_old_iface simpl_result details -- Emit external core - emitExternalCore (hsc_dflags hsc_env) cg_guts -- Move this? --Lemmih 03/07/2006 + emitExternalCore (hsc_dflags hsc_env) (mg_exports simpl_result) cg_guts -- Move this? --Lemmih 03/07/2006 dumpIfaceStats hsc_env ------------------- -- 1.7.10.4