compiler/coreSyn/MkExternalCore.lhs

   1
   2 % (c) The University of Glasgow 2001-2006
   3 %
   4 \begin{code}
   5 module MkExternalCore (
   6         emitExternalCore
   7 ) where
   8
   9 #include "HsVersions.h"
  10
  11 import qualified ExternalCore as C
  12 import Module
  13 import CoreSyn
  14 import HscTypes
  15 import TyCon
  16 import TypeRep
  17 import Type
  18 import PprExternalCore () -- Instances
  19 import DataCon
  20 import Coercion
  21 import Var
  22 import IdInfo
  23 import Literal
  24 import Name
  25 import NameSet
  26 import UniqSet
  27 import Outputable
  28 import ForeignCall
  29 import DynFlags
  30 import StaticFlags
  31 import IO
  32 import FastString
  33
  34 emitExternalCore :: DynFlags -> NameSet -> CgGuts -> IO ()
  35 emitExternalCore dflags exports cg_guts
  36  | opt_EmitExternalCore
  37  = (do handle <- openFile corename WriteMode
  38        hPutStrLn handle (show (mkExternalCore exports cg_guts))
  39        hClose handle)
  40    `catch` (\_ -> pprPanic "Failed to open or write external core output file"
  41                            (text corename))
  42    where corename = extCoreName dflags
  43 emitExternalCore _ _ _
  44  | otherwise
  45  = return ()
  46
  47
  48 mkExternalCore :: NameSet -> CgGuts -> C.Module
  49 -- The ModGuts has been tidied, but the implicit bindings have
  50 -- not been injected, so we have to add them manually here
  51 -- We don't include the strange data-con *workers* because they are
  52 -- implicit in the data type declaration itself
  53 mkExternalCore exports (CgGuts {cg_module=this_mod, cg_tycons = tycons, cg_binds = binds})
  54   = C.Module mname tdefs (map (make_vdef exports) binds)
  55   where
  56     mname  = make_mid this_mod
  57     tdefs  = foldr collect_tdefs [] tycons
  58
  59 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
  60 collect_tdefs tcon tdefs
  61   | isAlgTyCon tcon = tdef: tdefs
  62   where
  63     tdef | isNewTyCon tcon =
  64                 C.Newtype (make_con_qid (tyConName tcon)) (map make_tbind tyvars) repclause
  65          | otherwise =
  66                 C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon))
  67          where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
  68                          | otherwise = Just (make_ty (repType rhs))
  69                                            where (_, rhs) = newTyConRhs tcon
  70     tyvars = tyConTyVars tcon
  71
  72 collect_tdefs _ tdefs = tdefs
  73
  74
  75 make_cdef :: DataCon -> C.Cdef
  76 make_cdef dcon =  C.Constr dcon_name existentials tys
  77   where
  78     dcon_name    = make_var_id (dataConName dcon)
  79     existentials = map make_tbind ex_tyvars
  80     ex_tyvars    = dataConExTyVars dcon
  81     tys          = map make_ty (dataConRepArgTys dcon)
  82
  83 make_tbind :: TyVar -> C.Tbind
  84 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
  85
  86 make_vbind :: Var -> C.Vbind
  87 make_vbind v = (make_var_id  (Var.varName v), make_ty (idType v))
  88
  89 make_vdef :: NameSet -> CoreBind -> C.Vdefg
  90 make_vdef exports b =
  91   case b of
  92     NonRec v e -> C.Nonrec (f (v,e))
  93     Rec ves -> C.Rec (map f ves)
  94   where
  95   f (v,e) = (local, make_var_id (Var.varName v), make_ty (idType v),make_exp e)
  96         where local = not $ elementOfUniqSet (Var.varName v) exports
  97         -- Top level bindings are unqualified now
  98
  99 make_exp :: CoreExpr -> C.Exp
 100 make_exp (Var v) =
 101   case globalIdDetails v of
 102      -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
 103 --    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
 104     FCallId (CCall (CCallSpec (StaticTarget nm) callconv _))
 105         -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (idType v))
 106     FCallId (CCall (CCallSpec DynamicTarget     callconv _))
 107         -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (idType v))
 108     FCallId _
 109         -> pprPanic "MkExternalCore died: can't handle non-{static,dynamic}-C foreign call"
 110                     (ppr v)
 111     _ -> C.Var (make_var_qid (Var.varName v))
 112 make_exp (Lit (MachLabel s _)) = C.Label (unpackFS s)
 113 make_exp (Lit l) = C.Lit (make_lit l)
 114 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 115 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
 116 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
 117 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
 118 make_exp (Cast e co) = C.Cast (make_exp e) (make_ty co)
 119 make_exp (Let b e) = C.Let (make_vdef emptyNameSet b) (make_exp e)
 120 -- gaw 2004
 121 make_exp (Case e v ty alts) = C.Case (make_exp e) (make_vbind v) (make_ty ty) (map make_alt alts)
 122 make_exp (Note (SCC _) e) = C.Note "SCC"  (make_exp e) -- temporary
 123 make_exp (Note (CoreNote s) e) = C.Note s (make_exp e)  -- hdaume: core annotations
 124 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
 125 make_exp _ = error "MkExternalCore died: make_exp"
 126
 127 make_alt :: CoreAlt -> C.Alt
 128 make_alt (DataAlt dcon, vs, e) =
 129     C.Acon (make_con_qid (dataConName dcon))
 130            (map make_tbind tbs)
 131            (map make_vbind vbs)
 132            (make_exp e)
 133         where (tbs,vbs) = span isTyVar vs
 134 make_alt (LitAlt l,_,e)   = C.Alit (make_lit l) (make_exp e)
 135 make_alt (DEFAULT,[],e)   = C.Adefault (make_exp e)
 136 -- This should never happen, as the DEFAULT alternative binds no variables,
 137 -- but we might as well check for it:
 138 make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
 139              ++ "alternative had a non-empty var list") (ppr a)
 140
 141
 142 make_lit :: Literal -> C.Lit
 143 make_lit l =
 144   case l of
 145     MachChar i -> C.Lchar i t
 146     MachStr s -> C.Lstring (unpackFS s) t
 147     MachNullAddr -> C.Lint 0 t
 148     MachInt i -> C.Lint i t
 149     MachInt64 i -> C.Lint i t
 150     MachWord i -> C.Lint i t
 151     MachWord64 i -> C.Lint i t
 152     MachFloat r -> C.Lrational r t
 153     MachDouble r -> C.Lrational r t
 154     _ -> error "MkExternalCore died: make_lit"
 155   where
 156     t = make_ty (literalType l)
 157
 158 make_ty :: Type -> C.Ty
 159 make_ty (TyVarTy tv)             = C.Tvar (make_var_id (tyVarName tv))
 160 make_ty (AppTy t1 t2)            = C.Tapp (make_ty t1) (make_ty t2)
 161 make_ty (FunTy t1 t2)            = make_ty (TyConApp funTyCon [t1,t2])
 162 make_ty (ForAllTy tv t)          = C.Tforall (make_tbind tv) (make_ty t)
 163 make_ty (TyConApp tc ts)         = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
 164                                          (map make_ty ts)
 165 -- Newtypes are treated just like any other type constructor; not expanded
 166 -- Reason: predTypeRep does substitution and, while substitution deals
 167 --         correctly with name capture, it's only correct if you see the uniques!
 168 --         If you just see occurrence names, name capture may occur.
 169 -- Example: newtype A a = A (forall b. b -> a)
 170 --          test :: forall q b. q -> A b
 171 --          test _ = undefined
 172 --      Here the 'a' gets substituted by 'b', which is captured.
 173 -- Another solution would be to expand newtypes before tidying; but that would
 174 -- expose the representation in interface files, which definitely isn't right.
 175 -- Maybe CoreTidy should know whether to expand newtypes or not?
 176
 177 make_ty (PredTy p)      = make_ty (predTypeRep p)
 178
 179
 180
 181 make_kind :: Kind -> C.Kind
 182 make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
 183     where (t1, t2) = getEqPredTys p
 184 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
 185 make_kind k
 186   | isLiftedTypeKind k   = C.Klifted
 187   | isUnliftedTypeKind k = C.Kunlifted
 188   | isOpenTypeKind k     = C.Kopen
 189 make_kind _ = error "MkExternalCore died: make_kind"
 190
 191 {- Id generation. -}
 192
 193 make_id :: Bool -> Name -> C.Id
 194 make_id _is_var nm = (occNameString . nameOccName) nm
 195
 196 make_var_id :: Name -> C.Id
 197 make_var_id = make_id True
 198
 199 -- It's important to encode the module name here, because in External Core,
 200 -- base:GHC.Base => base:GHCziBase
 201 -- We don't do this in pprExternalCore because we
 202 -- *do* want to keep the package name (we don't want baseZCGHCziBase,
 203 -- because that would just be ugly.)
 204 -- SIGH.
 205 make_mid :: Module -> C.Id
 206 -- Super ugly code, but I can't find anything else that does quite what I
 207 -- want (encodes the hierarchical module name without encoding the colon
 208 -- that separates the package name from it.)
 209 make_mid m = (packageIdString (modulePackageId m)) ++
 210              ":" ++
 211              showSDoc (pprCode CStyle (pprModuleName (moduleName m)))
 212
 213 make_qid :: Bool -> Name -> C.Qual C.Id
 214 make_qid is_var n = (mname,make_id is_var n)
 215     where mname =
 216            case nameModule_maybe n of
 217             Just m -> make_mid m
 218             Nothing -> ""
 219
 220 make_var_qid :: Name -> C.Qual C.Id
 221 make_var_qid = make_qid True
 222
 223 make_con_qid :: Name -> C.Qual C.Id
 224 make_con_qid = make_qid False
 225
 226 \end{code}
 227
 228
 229
 230