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