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