Commit c66f666e authored by apt's avatar apt
Browse files

[project @ 2001-06-01 17:14:07 by apt]

added support for emiting external core format
parent 6e5b016d
%
% (c) The University of Glasgow 2001
%
\begin{code}
module ExternalCore where
import List (elemIndex)
data Module
= Module Mname [Tdef] [(Bool,Vdefg)]
data Tdef
= Data Tcon [Tbind] [Cdef]
| Newtype Tcon [Tbind] Ty
data Cdef
= Constr Dcon [Tbind] [Ty]
data Vdefg
= Rec [Vdef]
| Nonrec Vdef
type Vdef = (Var,Ty,Exp)
data Exp
= Var (Qual Var)
| Dcon (Qual Dcon)
| Lit Lit
| App Exp Exp
| Appt Exp Ty
| Lam Bind Exp
| Let Vdefg Exp
| Case Exp Vbind [Alt] {- non-empty list -}
| Coerce Ty Exp
| Note String Exp
| Ccall String Ty
data Bind
= Vb Vbind
| Tb Tbind
data Alt
= Acon (Qual Dcon) [Tbind] [Vbind] Exp
| Alit Lit Exp
| Adefault Exp
type Vbind = (Var,Ty)
type Tbind = (Tvar,Kind)
data Ty
= Tvar Tvar
| Tcon (Qual Tcon)
| Tapp Ty Ty
| Tforall Tbind Ty
data Kind
= Klifted
| Kunlifted
| Kopen
| Karrow Kind Kind
deriving (Eq)
data Lit
= Lint Integer Ty
| Lrational Rational Ty
| Lchar Char Ty
| Lstring String Ty
deriving (Eq)
type Mname = Id
type Var = Id
type Tvar = Id
type Tcon = Id
type Dcon = Id
type Qual t = (Mname,t)
type Id = String
equalTy t1 t2 = eqTy [] [] t1 t2
where eqTy e1 e2 (Tvar v1) (Tvar v2) =
case (elemIndex v1 e1,elemIndex v2 e2) of
(Just i1, Just i2) -> i1 == i2
(Nothing, Nothing) -> v1 == v2
_ -> False
eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
tk1 == tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
eqTy _ _ _ _ = False
instance Eq Ty where (==) = equalTy
subKindOf :: Kind -> Kind -> Bool
_ `subKindOf` Kopen = True
k1 `subKindOf` k2 = k1 == k2 -- don't worry about higher kinds
instance Ord Kind where (<=) = subKindOf
primMname = "PrelGHC"
tcArrow :: Qual Tcon
tcArrow = (primMname, "ZLzmzgZR")
\end{code}
%
% (c) The University of Glasgow 2001
%
\begin{code}
module MkExternalCore (
emitExternalCore
) where
#include "HsVersions.h"
import qualified ExternalCore as C
import Char
import Ratio
import Module
import CoreSyn
import HscTypes
import TyCon
import TypeRep
import Type
import DataCon
import CoreSyn
import Var
import IdInfo
import NameEnv
import Literal
import Name
import CostCentre
import Outputable
import PrimOp
import Class
import ForeignCall
import PprExternalCore
import CmdLineOpts
import IO
emitExternalCore :: DynFlags -> ModIface -> ModDetails -> IO ()
emitExternalCore dflags iface details
| opt_EmitExternalCore
= (do handle <- openFile corename WriteMode
hPutStr handle (show (mkExternalCore iface details))
hClose handle)
`catch` (\err -> pprPanic "Failed to open or write external core output file"
(text corename))
where corename = extCoreName dflags
emitExternalCore _ _ _
| otherwise
= return ()
mkExternalCore :: ModIface -> ModDetails -> C.Module
mkExternalCore (ModIface {mi_module=mi_module,mi_exports=mi_exports})
(ModDetails {md_types=md_types,md_binds=md_binds}) =
C.Module mname {- exports -} tdefs vdefs
where
mname = make_mid mi_module
{- exports = foldr (collect_exports md_types) ([],[],[]) all_avails
all_avails = concat (map snd (filter ((== moduleName mi_module) . fst) mi_exports))
-}
tdefs = foldr collect_tdefs [] (typeEnvTyCons md_types)
vdefs = map make_vdef md_binds
{-
collect_exports :: TypeEnv -> AvailInfo -> ([C.Tcon],[C.Dcon],[C.Var]) -> ([C.Tcon],[C.Dcon],[C.Var])
collect_exports tyenv (Avail n) (tcons,dcons,vars) = (tcons,dcons,make_var_id n:vars)
collect_exports tyenv (AvailTC n ns) (tcons,dcons,vars) =
case lookupNameEnv_NF tyenv n of
ATyCon tc | isAlgTyCon tc ->
(tcon ++ tcons,workers ++ dcons,wrappers ++ vars)
where
tcon = if elem n ns then [make_con_id n] else []
workers = if isNewTyCon tc then []
else map (make_con_id . idName . dataConId) exported_dcs
exported_dcs = filter (\dc -> elem ((idName . dataConWrapId) dc) ns') dcs
dcs = tyConDataConsIfAvailable tc
wrappers = map make_var_id ns'
ns' = filter (\n' -> n' /= n && not (elem n' recordSels)) ns
recordSels = map idName (tyConSelIds tc)
AClass cl -> {- maybe a little too free about exports -}
(tcon : tcons,workers ++ dcons,wrappers ++ vars)
where
tcon = make_con_id (tyConName tc)
workers = if isNewTyCon tc then []
else map (make_con_id . idName . dataConId) dcs
wrappers = map (make_var_id . idName . dataConWrapId) dcs
dcs = tyConDataConsIfAvailable tc
tc = classTyCon cl
_ -> (tcons,dcons,vars)
-}
collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
collect_tdefs tcon tdefs | isAlgTyCon tcon = tdef:tdefs
where
tdef =
case newTyConRep tcon of
Just rep ->
C.Newtype (make_con_id (tyConName tcon)) (map make_tbind (tyConTyVars tcon)) (make_ty rep)
Nothing ->
C.Data (make_con_id (tyConName tcon)) (map make_tbind (tyConTyVars tcon)) (map make_cdef (tyConDataCons tcon))
collect_tdefs _ tdefs = tdefs
make_cdef :: DataCon -> C.Cdef
make_cdef dcon = C.Constr dcon_name existentials tys
where
dcon_name = make_con_id (idName (dataConId dcon))
existentials = map make_tbind ex_tyvars
where (_,_,ex_tyvars,_,_,_) = dataConSig dcon
tys = map make_ty (dataConRepArgTys dcon)
make_tbind :: TyVar -> C.Tbind
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 (varType v))
make_vdef :: CoreBind -> (Bool, C.Vdefg)
make_vdef b =
case b of
NonRec v e -> (isGlobalId v,C.Nonrec (f (v,e)))
Rec ves -> (or (map g ves),C.Rec (map f ves))
where f (v,e) = (n,t,make_exp e)
where (n,t) = make_vbind v
g (v,e) = isGlobalId v
make_exp :: CoreExpr -> C.Exp
make_exp (Var v) =
case globalIdDetails v of
DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.Ccall (_UNPK_ nm) (make_ty (varType v))
_ -> C.Var (make_var_qid (Var.varName v))
make_exp (Lit l) = C.Lit (make_lit l)
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 (snd (make_vdef b)) (make_exp e)
make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts)
make_exp (Note (SCC cc) e) = C.Note "SCC" (make_exp e) -- temporary
make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e)
make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e)
make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
make_exp _ = error "MkExternalCore died: make_exp"
make_alt :: CoreAlt -> C.Alt
make_alt (DataAlt dcon, vs, e) =
C.Acon (make_con_qid (idName (dataConId dcon))) (map make_tbind tbs) (map make_vbind vbs) (make_exp e)
where (tbs,vbs) = span isTyVar vs
make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
make_lit :: Literal -> C.Lit
make_lit l =
case l of
MachChar i -> C.Lchar (chr i) t
MachStr s -> C.Lstring (_UNPK_ s) t
MachAddr i -> C.Lint i t
MachInt i -> C.Lint i t
MachInt64 i -> C.Lint i t
MachWord i -> C.Lint i t
MachWord64 i -> C.Lint i t
MachFloat r -> C.Lrational r t
MachDouble r -> C.Lrational r t
MachLabel s -> C.Lstring (_UNPK_ s) t
_ -> error "MkExternalCore died: make_lit"
where
t = make_ty (literalType l)
make_ty :: Type -> C.Ty
make_ty (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
make_ty (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts)
make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
make_ty (PredTy p) = make_ty (predRepTy p)
make_ty (UsageTy _ t) = make_ty t
make_ty (NoteTy _ t) = make_ty t
make_kind :: Kind -> C.Kind
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
make_kind k | k == liftedTypeKind = C.Klifted
make_kind k | k == unliftedTypeKind = C.Kunlifted
make_kind k | k == openTypeKind = C.Kopen
make_kind _ = error "MkExternalCore died: make_kind"
{- Id generation. -}
{- Use encoded strings, except restore non-leading '#'s.
Also, adjust casing to work around some badly-chosen internal names. -}
make_id :: Bool -> Name -> C.Id
make_id is_var nm =
case n of
c:cs -> if isUpper c && is_var then (toLower c):(decode cs) else (decode n)
where n = (occNameString . nameOccName) nm
decode ('z':'h':cs) = '#':(decode cs)
decode (c:cs) = c:(decode cs)
decode [] = []
make_var_id :: Name -> C.Id
make_var_id = make_id True
make_con_id :: Name -> C.Id
make_con_id = make_id False
make_mid :: Module -> C.Id
make_mid = moduleNameString . moduleName
make_qid :: Bool -> Name -> C.Qual C.Id
make_qid is_var n = (mname,make_id is_var n)
where mname =
case nameModule_maybe n of
Just m -> make_mid m
Nothing -> "" -- for now!
make_var_qid :: Name -> C.Qual C.Id
make_var_qid = make_qid True
make_con_qid :: Name -> C.Qual C.Id
make_con_qid = make_qid False
\end{code}
%
% (c) The University of Glasgow 2001
%
\begin{code}
module PprExternalCore where
import Pretty
import ExternalCore
import Char
instance Show Module where
showsPrec d m = shows (pmodule m)
instance Show Tdef where
showsPrec d t = shows (ptdef t)
instance Show Cdef where
showsPrec d c = shows (pcdef c)
instance Show Vdefg where
showsPrec d v = shows (pvdefg v)
instance Show Exp where
showsPrec d e = shows (pexp e)
instance Show Alt where
showsPrec d a = shows (palt a)
instance Show Ty where
showsPrec d t = shows (pty t)
instance Show Kind where
showsPrec d k = shows (pkind k)
instance Show Lit where
showsPrec d l = shows (plit l)
indent = nest 2
pmodule (Module mname {- (texports,dexports,vexports) -} tdefs vdefs) =
(text "%module" <+> text mname)
{- $$ indent (parens (((fsep (map pname texports) <> char ',')
$$ (fsep (map pname dexports) <> char ',')
$$ (fsep (map pname vexports))))
-}
$$ indent ((vcat (map ((<> char ';') . ptdef) tdefs))
$$ (vcat (map ((<> char ';') . pgvdef) vdefs)))
pgvdef (False,vdef) = text "%local" <+> pvdefg vdef
pgvdef (True,vdef) = pvdefg vdef
ptdef (Data tcon tbinds cdefs) =
(text "%data" <+> pname tcon <+> (hsep (map ptbind tbinds)) <+> char '=')
$$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs)))))
ptdef (Newtype tcon tbinds ty ) =
text "%newtype" <+> pname tcon <+> (hsep (map ptbind tbinds)) <+> char '=' <+> pty ty
pcdef (Constr dcon tbinds tys) =
(pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
pname id = text id
pqname ("",id) = pname id
pqname (m,id) = pname m <> char '.' <> pname id
ptbind (t,Klifted) = pname t
ptbind (t,k) = parens (pname t <> text "::" <> pkind k)
pattbind (t,k) = char '@' <> ptbind (t,k)
pakind (Klifted) = char '*'
pakind (Kunlifted) = char '#'
pakind (Kopen) = char '?'
pakind k = parens (pkind k)
pkind (Karrow k1 k2) = parens (pakind k1 <> text "->" <> pkind k2)
pkind k = pakind k
paty (Tvar n) = pname n
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 t = paty t
pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2]
pty (Tforall tb t) = text "%forall" <+> pforall [tb] t
pty t = pbty t
pappty (Tapp t1 t2) ts = pappty t1 (t2:ts)
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
pvte (v,t,e) = sep [pname v <+> text "::" <+> pty t <+> char '=',
indent (pexp e)]
paexp (Var x) = pqname x
paexp (Dcon x) = pqname x
paexp (Lit l) = plit l
paexp e = parens(pexp e)
plamexp bs (Lam b e) = plamexp (bs ++ [b]) e
plamexp bs e = sep [sep (map pbind bs) <+> text "->",
indent (pexp e)]
pbind (Tb tb) = char '@' <+> ptbind tb
pbind (Vb vb) = pvbind vb
pfexp (App e1 e2) = pappexp e1 [Left e2]
pfexp (Appt e t) = pappexp e [Right t]
pfexp e = paexp e
pappexp (App e1 e2) as = pappexp e1 (Left e2:as)
pappexp (Appt e t) as = pappexp e (Right t:as)
pappexp e as = fsep (paexp e : map pa as)
where pa (Left e) = paexp e
pa (Right t) = char '@' <+> paty t
pexp (Lam b e) = char '\\' <+> plamexp [b] e
pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
pexp (Case e vb alts) = sep [text "%case" <+> paexp e,
text "%of" <+> pvbind vb]
$$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
pexp (Coerce t e) = (text "%coerce" <+> paty t) $$ pexp e
pexp (Note s e) = (text "%note" <+> pstring s) $$ pexp e
pexp (Ccall n t) = (text "%ccall" <+> pstring n) $$ paty t
pexp e = pfexp e
pvbind (x,t) = parens(pname x <> text "::" <> pty t)
palt (Acon c tbs vbs e) =
sep [pqname c,
sep (map pattbind tbs),
sep (map pvbind vbs) <+> text "->"]
$$ indent (pexp e)
palt (Alit l e) =
(plit l <+> text "->")
$$ indent (pexp e)
palt (Adefault e) =
(text "%_ ->")
$$ indent (pexp e)
plit (Lint i t) = parens (integer i <> text "::" <> pty t)
plit (Lrational r t) = parens (rational r <> text "::" <> pty t) -- might be better to print as two integers
plit (Lchar c t) = parens (text ("\'" ++ escape [c] ++ "\'") <> text "::" <> pty t)
plit (Lstring s t) = parens (pstring s <> text "::" <> pty t)
pstring s = doubleQuotes(text (escape s))
escape s = foldr f [] (map ord s)
where
f cv rest | (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) =
'\\':'u':h3:h2:h1:h0:rest
where (q3,r3) = quotRem cv (16*16*16)
h3 = toUpper(intToDigit q3)
(q2,r2) = quotRem r3 (16*16)
h2 = toUpper(intToDigit q2)
(q1,r1) = quotRem r2 16
h1 = toUpper(intToDigit q1)
h0 = toUpper(intToDigit r1)
f cv rest = (chr cv):rest
\end{code}
......@@ -100,7 +100,8 @@ module CmdLineOpts (
opt_NoPruneTyDecls,
opt_NoPruneDecls,
opt_Static,
opt_Unregisterised
opt_Unregisterised,
opt_EmitExternalCore
) where
#include "HsVersions.h"
......@@ -294,6 +295,7 @@ data DynFlags = DynFlags {
hscOutName :: String, -- name of the output file
hscStubHOutName :: String, -- name of the .stub_h output file
hscStubCOutName :: String, -- name of the .stub_c output file
extCoreName :: String, -- name of the .core output file
verbosity :: Int, -- verbosity level
cppFlag :: Bool, -- preprocess with cpp?
stolen_x86_regs :: Int,
......@@ -315,6 +317,7 @@ defaultDynFlags = DynFlags {
hscLang = HscC,
hscOutName = "",
hscStubHOutName = "", hscStubCOutName = "",
extCoreName = "",
verbosity = 0,
cppFlag = False,
stolen_x86_regs = 4,
......@@ -540,6 +543,7 @@ opt_NoPruneDecls = lookUp SLIT("-fno-prune-decls")
opt_NoPruneTyDecls = lookUp SLIT("-fno-prune-tydecls")
opt_Static = lookUp SLIT("-static")
opt_Unregisterised = lookUp SLIT("-funregisterised")
opt_EmitExternalCore = lookUp SLIT("-fext-core")
\end{code}
%************************************************************************
......@@ -589,7 +593,8 @@ isStaticHscFlag f =
"fno-prune-decls",
"fno-prune-tydecls",
"static",
"funregisterised"
"funregisterised",
"fext-core"
]
|| any (flip prefixMatch f) [
"fcontext-stack",
......
-----------------------------------------------------------------------------
-- $Id: DriverPipeline.hs,v 1.73 2001/05/31 11:32:25 simonmar Exp $
-- $Id: DriverPipeline.hs,v 1.74 2001/06/01 17:14:08 apt Exp $
--
-- GHC Driver
--
......@@ -500,7 +500,8 @@ run_phase Hsc basename suff input_fn output_fn
let dyn_flags' = dyn_flags { hscOutName = output_fn,
hscStubCOutName = basename ++ "_stub.c",
hscStubHOutName = basename ++ "_stub.h" }
hscStubHOutName = basename ++ "_stub.h",
extCoreName = basename ++ ".core" }
-- run the compiler!
pcs <- initPersistentCompilerState
......@@ -1011,7 +1012,8 @@ compile ghci_mode summary source_unchanged have_object
let dyn_flags' = dyn_flags { hscOutName = output_fn,
hscStubCOutName = basename ++ "_stub.c",
hscStubHOutName = basename ++ "_stub.h" }
hscStubHOutName = basename ++ "_stub.h",
extCoreName = basename ++ ".core" }
-- figure out which header files to #include in a generated .hc file
c_includes <- getPackageCIncludes
......
......@@ -78,6 +78,8 @@ import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO )
import Monad ( when )
import Maybe ( isJust, fromJust )
import IO
import MkExternalCore ( emitExternalCore )
\end{code}
......@@ -290,6 +292,7 @@ hscRecomp ghci_mode dflags have_object
-- tidy_details
-- new_iface
; emitExternalCore dflags new_iface tidy_details
-------------------
-- PREPARE FOR CODE GENERATION
-------------------
......@@ -424,6 +427,8 @@ myCoreToStg dflags this_mod tidy_binds
where
stgBindPairs (StgNonRec _ b r) = [(b,r)]
stgBindPairs (StgRec _ prs) = prs
\end{code}
......
......@@ -77,7 +77,9 @@ main = getArgs >>= \args ->
"--make-haskell-wrappers"
-> putStr (gen_wrappers p_o_specs)
"--make-latex-table"
-> putStr (gen_latex_table p_o_specs)
)
......@@ -93,13 +95,32 @@ known_args
"--primop-primop-info",
"--primop-tag",
"--primop-list",
"--make-haskell-wrappers"
"--make-haskell-wrappers",
"--make-latex-table"
]
------------------------------------------------------------------
-- Code generators -----------------------------------------------
------------------------------------------------------------------
gen_latex_table (Info defaults pos)
= "\\begin{tabular}{|l|l|}\n"
++ "\\hline\nName &\t Type\\\\\n\\hline\n"