--- /dev/null
+%
+% (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}
+
+
+
+
--- /dev/null
+%
+% (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}
+
+
+
+
--- /dev/null
+%
+% (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}
+
+
+
+
opt_NoPruneTyDecls,
opt_NoPruneDecls,
opt_Static,
- opt_Unregisterised
+ opt_Unregisterised,
+ opt_EmitExternalCore
) where
#include "HsVersions.h"
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,
hscLang = HscC,
hscOutName = "",
hscStubHOutName = "", hscStubCOutName = "",
+ extCoreName = "",
verbosity = 0,
cppFlag = False,
stolen_x86_regs = 4,
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}
%************************************************************************
"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
--
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
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
import Monad ( when )
import Maybe ( isJust, fromJust )
import IO
+
+import MkExternalCore ( emitExternalCore )
\end{code}
-- tidy_details
-- new_iface
+ ; emitExternalCore dflags new_iface tidy_details
-------------------
-- PREPARE FOR CODE GENERATION
-------------------
where
stgBindPairs (StgNonRec _ b r) = [(b,r)]
stgBindPairs (StgRec _ prs) = prs
+
+
\end{code}
"--make-haskell-wrappers"
-> putStr (gen_wrappers p_o_specs)
-
+
+ "--make-latex-table"
+ -> putStr (gen_latex_table p_o_specs)
)
"--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"
+ ++ (concat (map f pos))
+ ++ "\\end{tabular}"
+ where
+ f spec = "@" ++ (encode (name spec)) ++ "@ &\t@" ++ (pty (ty spec)) ++ "@\\\\\n"
+ encode s = s
+ pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
+ pty t = pbty t
+ pbty (TyApp tc ts) = (encode tc) ++ (concat (map (' ':) (map paty ts)))
+ pbty (TyUTup ts) = (mkUtupnm (length ts)) ++ (concat (map (' ':) (map paty ts)))
+ pbty t = paty t
+ paty (TyVar tv) = encode tv
+ paty t = "(" ++ pty t ++ ")"
+ mkUtupnm 1 = "ZL#z32U#ZR"
+ mkUtupnm n = "Z" ++ (show (n-1)) ++ "U"
+
gen_wrappers (Info defaults pos)
= "module PrelPrimopWrappers where\n"
++ "import qualified PrelGHC\n"