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

diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs
index 948f595..fa17734 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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
 
            -------------------