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