[project @ 2001-06-01 17:14:07 by apt]
authorapt <unknown>
Fri, 1 Jun 2001 17:14:08 +0000 (17:14 +0000)
committerapt <unknown>
Fri, 1 Jun 2001 17:14:08 +0000 (17:14 +0000)
added support for emiting external core format

ghc/compiler/coreSyn/ExternalCore.lhs [new file with mode: 0644]
ghc/compiler/coreSyn/MkExternalCore.lhs [new file with mode: 0644]
ghc/compiler/coreSyn/PprExternalCore.lhs [new file with mode: 0644]
ghc/compiler/main/CmdLineOpts.lhs
ghc/compiler/main/DriverPipeline.hs
ghc/compiler/main/HscMain.lhs
ghc/utils/genprimopcode/Main.hs

diff --git a/ghc/compiler/coreSyn/ExternalCore.lhs b/ghc/compiler/coreSyn/ExternalCore.lhs
new file mode 100644 (file)
index 0000000..4894deb
--- /dev/null
@@ -0,0 +1,112 @@
+%
+% (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}
+
+
+
+
diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs
new file mode 100644 (file)
index 0000000..e5f5f4f
--- /dev/null
@@ -0,0 +1,227 @@
+%
+% (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}
+
+
+
+
diff --git a/ghc/compiler/coreSyn/PprExternalCore.lhs b/ghc/compiler/coreSyn/PprExternalCore.lhs
new file mode 100644 (file)
index 0000000..8ed16c5
--- /dev/null
@@ -0,0 +1,177 @@
+%
+% (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}
+
+
+
+
index 972e9bb..406e1d0 100644 (file)
@@ -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",
index 48ae181..401032b 100644 (file)
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $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
index a138007..5d09d7b 100644 (file)
@@ -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}
 
 
index 79cdada..2d267fc 100644 (file)
@@ -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"
+     ++ (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"