From: apt Date: Fri, 1 Jun 2001 17:14:08 +0000 (+0000) Subject: [project @ 2001-06-01 17:14:07 by apt] X-Git-Tag: Approximately_9120_patches~1821 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c66f666e3ac615be4b58eb44667b9a0830d29253;p=ghc-hetmet.git [project @ 2001-06-01 17:14:07 by apt] added support for emiting external core format --- diff --git a/ghc/compiler/coreSyn/ExternalCore.lhs b/ghc/compiler/coreSyn/ExternalCore.lhs new file mode 100644 index 0000000..4894deb --- /dev/null +++ b/ghc/compiler/coreSyn/ExternalCore.lhs @@ -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 index 0000000..e5f5f4f --- /dev/null +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -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 index 0000000..8ed16c5 --- /dev/null +++ b/ghc/compiler/coreSyn/PprExternalCore.lhs @@ -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} + + + + diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 972e9bb..406e1d0 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -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", diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 48ae181..401032b 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -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 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index a138007..5d09d7b 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -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} diff --git a/ghc/utils/genprimopcode/Main.hs b/ghc/utils/genprimopcode/Main.hs index 79cdada..2d267fc 100644 --- a/ghc/utils/genprimopcode/Main.hs +++ b/ghc/utils/genprimopcode/Main.hs @@ -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"