Commit 99bab7d8 authored by Jan Rochel's avatar Jan Rochel
Browse files

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
parent 4ce08e13
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
-------------------
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment