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 -> ModGuts -> IO ()
  35 emitExternalCore dflags mod_impl
  36  | opt_EmitExternalCore
  37  = (do handle <- openFile corename WriteMode
  38        hPutStr handle (show (mkExternalCore mod_impl))
  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 :: ModGuts -> C.Module
  49 mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = binds})
  50   = C.Module mname tdefs vdefs
  51   where
  52     mname = make_mid this_mod
  53     tdefs = foldr collect_tdefs [] (typeEnvTyCons type_env)
  54     vdefs = map make_vdef 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 (dataConName dcon)
  76     existentials = map make_tbind ex_tyvars
  77     ex_tyvars    = dataConExistentialTyVars 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      -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
  97 --    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
  98     FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (varType v))
  99     FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
 100     _ -> C.Var (make_var_qid (Var.varName v))
 101 make_exp (Lit (l@(MachLabel s))) = C.External (unpackFS s) (make_ty (literalType l))
 102 make_exp (Lit l) = C.Lit (make_lit l)
 103 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 104 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
 105 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
 106 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
 107 make_exp (Let b e) = C.Let (make_vdef b) (make_exp e)
 108 make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts)
 109 make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
 110 make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e)
 111 make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e)
 112 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
 113 make_exp _ = error "MkExternalCore died: make_exp"
 114
 115 make_alt :: CoreAlt -> C.Alt
 116 make_alt (DataAlt dcon, vs, e) =
 117     C.Acon (make_con_qid (dataConName dcon))
 118            (map make_tbind tbs)
 119            (map make_vbind vbs)
 120            (make_exp e)
 121         where (tbs,vbs) = span isTyVar vs
 122 make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
 123 make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
 124
 125 make_lit :: Literal -> C.Lit
 126 make_lit l =
 127   case l of
 128     MachChar i | i <= 0xff -> C.Lchar (chr i) t
 129     MachChar i | otherwise -> C.Lint (toEnum i) t
 130     MachStr s -> C.Lstring (unpackFS s) t
 131     MachAddr i -> C.Lint i t
 132     MachInt i -> C.Lint i t
 133     MachInt64 i -> C.Lint i t
 134     MachWord i -> C.Lint i t
 135     MachWord64 i -> C.Lint i t
 136     MachFloat r -> C.Lrational r t
 137     MachDouble r -> C.Lrational r t
 138     _ -> error "MkExternalCore died: make_lit"
 139   where
 140     t = make_ty (literalType l)
 141
 142 make_ty :: Type -> C.Ty
 143 make_ty (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
 144 make_ty (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
 145 make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts)
 146 make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
 147 make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
 148 make_ty (SourceTy p) = make_ty (sourceTypeRep p)
 149 make_ty (NoteTy _ t) = make_ty t
 150
 151
 152 make_kind :: Kind -> C.Kind
 153 make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
 154 make_kind k | k `eqKind` liftedTypeKind = C.Klifted
 155 make_kind k | k `eqKind` unliftedTypeKind = C.Kunlifted
 156 make_kind k | k `eqKind` openTypeKind = C.Kopen
 157 make_kind _ = error "MkExternalCore died: make_kind"
 158
 159 {- Id generation. -}
 160
 161 {- Use encoded strings.
 162    Also, adjust casing to work around some badly-chosen internal names. -}
 163 make_id :: Bool -> Name -> C.Id
 164 make_id is_var nm = (occNameString . nameOccName) nm
 165
 166 {-      SIMON thinks this stuff isn't necessary
 167 make_id is_var nm =
 168   case n of
 169     'Z':cs | is_var -> 'z':cs
 170     'z':cs | not is_var -> 'Z':cs
 171     c:cs | isUpper c && is_var -> 'z':'d':n
 172     c:cs | isLower c && (not is_var) -> 'Z':'d':n
 173     _ -> n
 174   where n = (occNameString . nameOccName) nm
 175 -}
 176
 177 make_var_id :: Name -> C.Id
 178 make_var_id = make_id True
 179
 180 make_mid :: Module -> C.Id
 181 make_mid = moduleNameString . moduleName
 182
 183 make_qid :: Bool -> Name -> C.Qual C.Id
 184 make_qid is_var n = (mname,make_id is_var n)
 185     where mname =
 186            case nameModule_maybe n of
 187             Just m -> make_mid m
 188             Nothing -> ""
 189
 190 make_var_qid :: Name -> C.Qual C.Id
 191 make_var_qid = make_qid True
 192
 193 make_con_qid :: Name -> C.Qual C.Id
 194 make_con_qid = make_qid False
 195
 196 \end{code}
 197
 198
 199
 200