ghc/compiler/coreSyn/MkExternalCore.lhs

   1 %
   2 % (c) The University of Glasgow 2001
   3 %
   4 \begin{code}
   5
   6 module MkExternalCore (
   7         emitExternalCore
   8 ) where
   9
  10 #include "HsVersions.h"
  11
  12 import qualified ExternalCore as C
  13 import Char
  14 import Module
  15 import CoreSyn
  16 import HscTypes
  17 import TyCon
  18 import Class
  19 import TypeRep
  20 import Type
  21 import DataCon
  22 import CoreSyn
  23 import Var
  24 import IdInfo
  25 import Id( idUnfolding )
  26 import Literal
  27 import Name
  28 import CostCentre
  29 import Outputable
  30 import ForeignCall
  31 import PprExternalCore
  32 import CmdLineOpts
  33 import Maybes( orElse )
  34 import IO
  35 import FastString
  36
  37 emitExternalCore :: DynFlags -> ModGuts -> IO ()
  38 emitExternalCore dflags mod_impl
  39  | opt_EmitExternalCore
  40  = (do handle <- openFile corename WriteMode
  41        hPutStr handle (show (mkExternalCore mod_impl))
  42        hClose handle)
  43    `catch` (\err -> pprPanic "Failed to open or write external core output file"
  44                              (text corename))
  45    where corename = extCoreName dflags
  46 emitExternalCore _ _
  47  | otherwise
  48  = return ()
  49
  50
  51 mkExternalCore :: ModGuts -> C.Module
  52 mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = binds})
  53   = C.Module mname tdefs vdefs
  54   where
  55     mname  = make_mid this_mod
  56     tdefs  = foldr collect_tdefs [] tycons
  57     vdefs  = map make_vdef (implicit_binds ++ binds)
  58     tycons = map classTyCon (typeEnvClasses type_env) ++ typeEnvTyCons type_env
  59
  60         -- Don't forget to include the implicit bindings!
  61     implicit_binds = map get_defn (concatMap implicit_ids (typeEnvElts type_env))
  62
  63 implicit_ids :: TyThing -> [Id]
  64 -- C.f. HscTypes.mkImplicitBinds, but we do not include constructor workers
  65 implicit_ids (ATyCon tc) = map dataConWrapId (tyConDataCons_maybe tc `orElse` [])
  66                                  ++ tyConSelIds tc ++ tyConGenIds tc
  67 implicit_ids (AClass cl) = classSelIds cl
  68 implicit_ids other       = []
  69
  70 get_defn :: Id -> CoreBind
  71 get_defn id = NonRec id (unfoldingTemplate (idUnfolding id))
  72
  73 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
  74 collect_tdefs tcon tdefs
  75   | isAlgTyCon tcon = tdef: tdefs
  76   where
  77     tdef | isNewTyCon tcon =
  78                 C.Newtype (make_con_qid (tyConName tcon)) (map make_tbind tyvars) repclause
  79          | otherwise =
  80                 C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon))
  81          where repclause | isRecursiveTyCon tcon = Nothing
  82                          | otherwise = Just (make_ty rep)
  83                                            where (_, rep) = newTyConRep tcon
  84     tyvars = tyConTyVars tcon
  85
  86 collect_tdefs _ tdefs = tdefs
  87
  88
  89 make_cdef :: DataCon -> C.Cdef
  90 make_cdef dcon =  C.Constr dcon_name existentials tys
  91   where
  92     dcon_name    = make_con_qid (dataConName dcon)
  93     existentials = map make_tbind ex_tyvars
  94     ex_tyvars    = dataConExistentialTyVars dcon
  95     tys          = map make_ty (dataConRepArgTys dcon)
  96
  97 make_tbind :: TyVar -> C.Tbind
  98 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
  99
 100 make_vbind :: Var -> C.Vbind
 101 make_vbind v = (make_var_id  (Var.varName v), make_ty (varType v))
 102
 103 make_vdef :: CoreBind -> C.Vdefg
 104 make_vdef b =
 105   case b of
 106     NonRec v e -> C.Nonrec (f (v,e))
 107     Rec ves -> C.Rec (map f ves)
 108   where f (v,e) = (make_var_qid (Var.varName v), make_ty (varType v),make_exp e)
 109
 110 make_exp :: CoreExpr -> C.Exp
 111 make_exp (Var v) =
 112   case globalIdDetails v of
 113      -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
 114 --    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
 115     FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (varType v))
 116     FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
 117     _ -> C.Var (make_var_qid (Var.varName v))
 118 make_exp (Lit (l@(MachLabel s))) = C.External (unpackFS s) (make_ty (literalType l))
 119 make_exp (Lit l) = C.Lit (make_lit l)
 120 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 121 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
 122 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
 123 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
 124 make_exp (Let b e) = C.Let (make_vdef b) (make_exp e)
 125 make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts)
 126 make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
 127 make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e)
 128 make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e)
 129 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
 130 make_exp _ = error "MkExternalCore died: make_exp"
 131
 132 make_alt :: CoreAlt -> C.Alt
 133 make_alt (DataAlt dcon, vs, e) =
 134     C.Acon (make_con_qid (dataConName dcon))
 135            (map make_tbind tbs)
 136            (map make_vbind vbs)
 137            (make_exp e)
 138         where (tbs,vbs) = span isTyVar vs
 139 make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
 140 make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
 141
 142 make_lit :: Literal -> C.Lit
 143 make_lit l =
 144   case l of
 145     MachChar i | i <= 0xff -> C.Lchar (chr i) t
 146     MachChar i | otherwise -> C.Lint (toEnum i) t
 147     MachStr s -> C.Lstring (unpackFS s) t
 148     MachAddr i -> C.Lint i t
 149     MachInt i -> C.Lint i t
 150     MachInt64 i -> C.Lint i t
 151     MachWord i -> C.Lint i t
 152     MachWord64 i -> C.Lint i t
 153     MachFloat r -> C.Lrational r t
 154     MachDouble r -> C.Lrational r t
 155     _ -> error "MkExternalCore died: make_lit"
 156   where
 157     t = make_ty (literalType l)
 158
 159 make_ty :: Type -> C.Ty
 160 make_ty (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
 161 make_ty (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
 162 make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts)
 163 make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
 164 make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
 165 make_ty (SourceTy p) = make_ty (sourceTypeRep p)
 166 make_ty (NoteTy _ t) = make_ty t
 167
 168
 169 make_kind :: Kind -> C.Kind
 170 make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
 171 make_kind k | k `eqKind` liftedTypeKind = C.Klifted
 172 make_kind k | k `eqKind` unliftedTypeKind = C.Kunlifted
 173 make_kind k | k `eqKind` openTypeKind = C.Kopen
 174 make_kind _ = error "MkExternalCore died: make_kind"
 175
 176 {- Id generation. -}
 177
 178 {- Use encoded strings.
 179    Also, adjust casing to work around some badly-chosen internal names. -}
 180 make_id :: Bool -> Name -> C.Id
 181 make_id is_var nm = (occNameString . nameOccName) nm
 182
 183 {-      SIMON thinks this stuff isn't necessary
 184 make_id is_var nm =
 185   case n of
 186     'Z':cs | is_var -> 'z':cs
 187     'z':cs | not is_var -> 'Z':cs
 188     c:cs | isUpper c && is_var -> 'z':'d':n
 189     c:cs | isLower c && (not is_var) -> 'Z':'d':n
 190     _ -> n
 191   where n = (occNameString . nameOccName) nm
 192 -}
 193
 194 make_var_id :: Name -> C.Id
 195 make_var_id = make_id True
 196
 197 make_mid :: Module -> C.Id
 198 make_mid = moduleNameString . moduleName
 199
 200 make_qid :: Bool -> Name -> C.Qual C.Id
 201 make_qid is_var n = (mname,make_id is_var n)
 202     where mname =
 203            case nameModule_maybe n of
 204             Just m -> make_mid m
 205             Nothing -> ""
 206
 207 make_var_qid :: Name -> C.Qual C.Id
 208 make_var_qid = make_qid True
 209
 210 make_con_qid :: Name -> C.Qual C.Id
 211 make_con_qid = make_qid False
 212
 213 \end{code}
 214
 215
 216
 217