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 Ratio
  15 import Module
  16 import CoreSyn
  17 import HscTypes
  18 import TyCon
  19 import TypeRep
  20 import Type
  21 import DataCon
  22 import CoreSyn
  23 import Var
  24 import IdInfo
  25 import NameEnv
  26 import Literal
  27 import Name
  28 import CostCentre
  29 import Outputable
  30 import PrimOp
  31 import Class
  32 import ForeignCall
  33 import PprExternalCore
  34 import CmdLineOpts
  35 import IO
  36
  37 emitExternalCore :: DynFlags -> ModIface -> ModDetails -> IO ()
  38 emitExternalCore dflags iface details
  39  | opt_EmitExternalCore
  40  = (do handle <- openFile corename WriteMode
  41        hPutStr handle (show (mkExternalCore iface details))
  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 :: ModIface -> ModDetails -> C.Module
  52 mkExternalCore (ModIface {mi_module=mi_module,mi_exports=mi_exports})
  53                (ModDetails {md_types=md_types,md_binds=md_binds}) =
  54     C.Module mname {- exports -} tdefs vdefs
  55   where
  56     mname = make_mid mi_module
  57 {-  exports = foldr (collect_exports md_types) ([],[],[]) all_avails
  58     all_avails = concat (map snd (filter ((== moduleName mi_module) . fst) mi_exports))
  59 -}
  60     tdefs = foldr collect_tdefs [] (typeEnvTyCons md_types)
  61     vdefs = map make_vdef md_binds
  62
  63 {-
  64 collect_exports :: TypeEnv -> AvailInfo -> ([C.Tcon],[C.Dcon],[C.Var]) -> ([C.Tcon],[C.Dcon],[C.Var])
  65 collect_exports tyenv (Avail n) (tcons,dcons,vars) = (tcons,dcons,make_var_id n:vars)
  66 collect_exports tyenv (AvailTC n ns) (tcons,dcons,vars) =
  67   case lookupNameEnv_NF tyenv n of
  68      ATyCon tc | isAlgTyCon tc ->
  69          (tcon ++ tcons,workers ++ dcons,wrappers ++ vars)
  70          where
  71            tcon = if elem n ns then [make_con_id n] else []
  72            workers = if isNewTyCon tc then []
  73                      else map  (make_con_id . idName . dataConId) exported_dcs
  74            exported_dcs = filter (\dc -> elem ((idName . dataConWrapId) dc) ns') dcs
  75            dcs = tyConDataConsIfAvailable tc
  76            wrappers = map make_var_id ns'
  77            ns' = filter (\n' -> n' /= n && not (elem n' recordSels)) ns
  78            recordSels = map idName (tyConSelIds tc)
  79      AClass cl ->  {- maybe a little too free about exports -}
  80         (tcon : tcons,workers ++ dcons,wrappers ++ vars)
  81         where
  82           tcon = make_con_id (tyConName tc)
  83           workers = if isNewTyCon tc then []
  84                     else map (make_con_id . idName . dataConId) dcs
  85           wrappers = map (make_var_id . idName . dataConWrapId) dcs
  86           dcs = tyConDataConsIfAvailable tc
  87           tc = classTyCon cl
  88      _ -> (tcons,dcons,vars)
  89 -}
  90
  91
  92 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
  93 collect_tdefs tcon tdefs | isAlgTyCon tcon = tdef:tdefs
  94   where
  95     tdef =
  96       case newTyConRep tcon of
  97         Just rep ->
  98           C.Newtype (make_con_id (tyConName tcon)) (map make_tbind (tyConTyVars tcon)) (make_ty rep)
  99         Nothing ->
 100           C.Data (make_con_id (tyConName tcon)) (map make_tbind (tyConTyVars tcon)) (map make_cdef (tyConDataCons tcon))
 101 collect_tdefs _ tdefs = tdefs
 102
 103
 104 make_cdef :: DataCon -> C.Cdef
 105 make_cdef dcon =  C.Constr dcon_name existentials tys
 106   where
 107     dcon_name = make_con_id (idName (dataConId dcon))
 108     existentials = map make_tbind ex_tyvars
 109           where (_,_,ex_tyvars,_,_,_) = dataConSig dcon
 110     tys = map make_ty (dataConRepArgTys dcon)
 111
 112 make_tbind :: TyVar -> C.Tbind
 113 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
 114
 115 make_vbind :: Var -> C.Vbind
 116 make_vbind v = (make_var_id  (Var.varName v), make_ty (varType v))
 117
 118 make_vdef :: CoreBind -> (Bool, C.Vdefg)
 119 make_vdef b =
 120   case b of
 121     NonRec v e -> (isGlobalId v,C.Nonrec (f (v,e)))
 122     Rec ves -> (or (map g ves),C.Rec (map f ves))
 123   where f (v,e) = (n,t,make_exp e)
 124                   where (n,t) = make_vbind v
 125         g (v,e) = isGlobalId v
 126
 127 make_exp :: CoreExpr -> C.Exp
 128 make_exp (Var v) =
 129   case globalIdDetails v of
 130     DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
 131     FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.Ccall (_UNPK_ nm) (make_ty (varType v))
 132     _ -> C.Var (make_var_qid (Var.varName v))
 133 make_exp (Lit l) = C.Lit (make_lit l)
 134 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 135 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
 136 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
 137 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
 138 make_exp (Let b e) = C.Let (snd (make_vdef b)) (make_exp e)
 139 make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts)
 140 make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
 141 make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e)
 142 make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e)
 143 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
 144 make_exp _ = error "MkExternalCore died: make_exp"
 145
 146 make_alt :: CoreAlt -> C.Alt
 147 make_alt (DataAlt dcon, vs, e) =
 148     C.Acon (make_con_qid (idName (dataConId dcon))) (map make_tbind tbs) (map make_vbind vbs) (make_exp e)
 149         where (tbs,vbs) = span isTyVar vs
 150 make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
 151 make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
 152
 153 make_lit :: Literal -> C.Lit
 154 make_lit l =
 155   case l of
 156     MachChar i -> C.Lchar (chr i) t
 157     MachStr s -> C.Lstring (_UNPK_ s) t
 158     MachAddr i -> C.Lint i t
 159     MachInt i -> C.Lint i t
 160     MachInt64 i -> C.Lint i t
 161     MachWord i -> C.Lint i t
 162     MachWord64 i -> C.Lint i t
 163     MachFloat r -> C.Lrational r t
 164     MachDouble r -> C.Lrational r t
 165     MachLabel s -> C.Lstring (_UNPK_ s) t
 166     _ -> error "MkExternalCore died: make_lit"
 167   where
 168     t = make_ty (literalType l)
 169
 170 make_ty :: Type -> C.Ty
 171 make_ty (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
 172 make_ty (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
 173 make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts)
 174 make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
 175 make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
 176 make_ty (PredTy p) = make_ty (predRepTy p)
 177 make_ty (UsageTy _ t) = make_ty t
 178 make_ty (NoteTy _ t) = make_ty t
 179
 180
 181 make_kind :: Kind -> C.Kind
 182 make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
 183 make_kind k | k == liftedTypeKind = C.Klifted
 184 make_kind k | k == unliftedTypeKind = C.Kunlifted
 185 make_kind k | k == openTypeKind = C.Kopen
 186 make_kind _ = error "MkExternalCore died: make_kind"
 187
 188 {- Id generation. -}
 189
 190 {- Use encoded strings, except restore non-leading '#'s.
 191    Also, adjust casing to work around some badly-chosen internal names. -}
 192 make_id :: Bool -> Name -> C.Id
 193 make_id is_var nm =
 194   case n of
 195     c:cs -> if isUpper c && is_var then (toLower c):(decode cs) else (decode n)
 196   where n = (occNameString . nameOccName) nm
 197         decode ('z':'h':cs) = '#':(decode cs)
 198         decode (c:cs) = c:(decode cs)
 199         decode [] = []
 200
 201 make_var_id :: Name -> C.Id
 202 make_var_id = make_id True
 203
 204 make_con_id :: Name -> C.Id
 205 make_con_id = make_id False
 206
 207 make_mid :: Module -> C.Id
 208 make_mid = moduleNameString . moduleName
 209
 210 make_qid :: Bool -> Name -> C.Qual C.Id
 211 make_qid is_var n = (mname,make_id is_var n)
 212     where mname =
 213            case nameModule_maybe n of
 214             Just m -> make_mid m
 215             Nothing -> ""   -- for now!
 216
 217 make_var_qid :: Name -> C.Qual C.Id
 218 make_var_qid = make_qid True
 219
 220 make_con_qid :: Name -> C.Qual C.Id
 221 make_con_qid = make_qid False
 222
 223 \end{code}
 224
 225
 226
 227