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