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 tdefs vdefs
  51   where
  52     mname = make_mid mi_module
  53     tdefs = foldr collect_tdefs [] (typeEnvTyCons md_types)
  54     vdefs = map make_vdef md_binds
  55
  56 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
  57 collect_tdefs tcon tdefs
  58   | isAlgTyCon tcon = tdef: tdefs
  59   where
  60     tdef | isNewTyCon tcon =
  61                 C.Newtype (make_con_qid (tyConName tcon)) (map make_tbind tyvars) repclause
  62          | otherwise =
  63                 C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon))
  64          where repclause | isRecursiveTyCon tcon = Nothing
  65                          | otherwise = Just (make_ty rep)
  66                                            where (_, rep) = newTyConRep tcon
  67     tyvars = tyConTyVars tcon
  68
  69 collect_tdefs _ tdefs = tdefs
  70
  71
  72 make_cdef :: DataCon -> C.Cdef
  73 make_cdef dcon =  C.Constr dcon_name existentials tys
  74   where
  75     dcon_name = make_con_qid (idName (dataConId dcon))
  76     existentials = map make_tbind ex_tyvars
  77           where (_,_,ex_tyvars,_,_,_) = dataConSig dcon
  78     tys = map make_ty (dataConRepArgTys dcon)
  79
  80 make_tbind :: TyVar -> C.Tbind
  81 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
  82
  83 make_vbind :: Var -> C.Vbind
  84 make_vbind v = (make_var_id  (Var.varName v), make_ty (varType v))
  85
  86 make_vdef :: CoreBind -> C.Vdefg
  87 make_vdef b =
  88   case b of
  89     NonRec v e -> C.Nonrec (f (v,e))
  90     Rec ves -> C.Rec (map f ves)
  91   where f (v,e) = (make_var_qid (Var.varName v), make_ty (varType v),make_exp e)
  92
  93 make_exp :: CoreExpr -> C.Exp
  94 make_exp (Var v) =
  95   case globalIdDetails v of
  96     DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
  97     FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (_UNPK_ nm) (make_ty (varType v))
  98     FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
  99     _ -> C.Var (make_var_qid (Var.varName v))
 100 make_exp (Lit (l@(MachLabel s))) = C.External (_UNPK_ s) (make_ty (literalType l))
 101 make_exp (Lit l) = C.Lit (make_lit l)
 102 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 103 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
 104 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
 105 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
 106 make_exp (Let b e) = C.Let (make_vdef b) (make_exp e)
 107 make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts)
 108 make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
 109 make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e)
 110 make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e)
 111 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
 112 make_exp _ = error "MkExternalCore died: make_exp"
 113
 114 make_alt :: CoreAlt -> C.Alt
 115 make_alt (DataAlt dcon, vs, e) =
 116     C.Acon (make_con_qid (idName (dataConId dcon))) (map make_tbind tbs) (map make_vbind vbs) (make_exp e)
 117         where (tbs,vbs) = span isTyVar vs
 118 make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
 119 make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
 120
 121 make_lit :: Literal -> C.Lit
 122 make_lit l =
 123   case l of
 124     MachChar i | i <= 0xff -> C.Lchar (chr i) t
 125     MachChar i | otherwise -> C.Lint (toEnum i) t
 126     MachStr s -> C.Lstring (_UNPK_ s) t
 127     MachAddr i -> C.Lint i t
 128     MachInt i -> C.Lint i t
 129     MachInt64 i -> C.Lint i t
 130     MachWord i -> C.Lint i t
 131     MachWord64 i -> C.Lint i t
 132     MachFloat r -> C.Lrational r t
 133     MachDouble r -> C.Lrational r t
 134     _ -> error "MkExternalCore died: make_lit"
 135   where
 136     t = make_ty (literalType l)
 137
 138 make_ty :: Type -> C.Ty
 139 make_ty (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
 140 make_ty (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
 141 make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts)
 142 make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
 143 make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
 144 make_ty (SourceTy p) = make_ty (sourceTypeRep p)
 145 make_ty (UsageTy _ t) = make_ty t
 146 make_ty (NoteTy _ t) = make_ty t
 147
 148
 149 make_kind :: Kind -> C.Kind
 150 make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
 151 make_kind k | k `eqKind` liftedTypeKind = C.Klifted
 152 make_kind k | k `eqKind` unliftedTypeKind = C.Kunlifted
 153 make_kind k | k `eqKind` openTypeKind = C.Kopen
 154 make_kind _ = error "MkExternalCore died: make_kind"
 155
 156 {- Id generation. -}
 157
 158 {- Use encoded strings.
 159    Also, adjust casing to work around some badly-chosen internal names. -}
 160 make_id :: Bool -> Name -> C.Id
 161 make_id is_var nm =
 162   case n of
 163     'Z':cs | is_var -> 'z':cs
 164     'z':cs | not is_var -> 'Z':cs
 165     c:cs | isUpper c && is_var -> 'z':'d':n
 166     c:cs | isLower c && (not is_var) -> 'Z':'d':n
 167     _ -> n
 168   where n = (occNameString . nameOccName) nm
 169
 170 make_var_id :: Name -> C.Id
 171 make_var_id = make_id True
 172
 173 make_mid :: Module -> C.Id
 174 make_mid = moduleNameString . moduleName
 175
 176 make_qid :: Bool -> Name -> C.Qual C.Id
 177 make_qid is_var n = (mname,make_id is_var n)
 178     where mname =
 179            case nameModule_maybe n of
 180             Just m -> make_mid m
 181             Nothing -> ""
 182
 183 make_var_qid :: Name -> C.Qual C.Id
 184 make_var_qid = make_qid True
 185
 186 make_con_qid :: Name -> C.Qual C.Id
 187 make_con_qid = make_qid False
 188
 189 \end{code}
 190
 191
 192
 193