compiler/coreSyn/MkExternalCore.lhs

   1
   2 % (c) The University of Glasgow 2001-2006
   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 PprExternalCore  -- Instances
  21 import DataCon
  22 import CoreSyn
  23 import Coercion
  24 import Var
  25 import IdInfo
  26 import Literal
  27 import Name
  28 import NameSet
  29 import UniqSet
  30 import Outputable
  31 import ForeignCall
  32 import DynFlags
  33 import StaticFlags
  34 import IO
  35 import FastString
  36
  37 emitExternalCore :: DynFlags -> NameSet -> CgGuts -> IO ()
  38 emitExternalCore dflags exports cg_guts
  39  | opt_EmitExternalCore
  40  = (do handle <- openFile corename WriteMode
  41        hPutStrLn handle (show (mkExternalCore exports cg_guts))
  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 :: NameSet -> CgGuts -> C.Module
  52 -- The ModGuts has been tidied, but the implicit bindings have
  53 -- not been injected, so we have to add them manually here
  54 -- We don't include the strange data-con *workers* because they are
  55 -- implicit in the data type declaration itself
  56 mkExternalCore exports (CgGuts {cg_module=this_mod, cg_tycons = tycons, cg_binds = binds})
  57   = C.Module mname tdefs (map (make_vdef exports) binds)
  58   where
  59     mname  = make_mid this_mod
  60     tdefs  = foldr collect_tdefs [] tycons
  61
  62 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
  63 collect_tdefs tcon tdefs
  64   | isAlgTyCon tcon = tdef: tdefs
  65   where
  66     tdef | isNewTyCon tcon =
  67                 C.Newtype (make_con_qid (tyConName tcon)) (map make_tbind tyvars) repclause
  68 -- 20060420 GHC handles empty data types just fine. ExtCore should too! jds
  69 --         | null (tyConDataCons tcon) = error "MkExternalCore died: can't handle datatype declarations with no data constructors"
  70          | otherwise =
  71                 C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon))
  72          where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
  73                          | otherwise = Just (make_ty rep)
  74                                            where (_, rep) = newTyConRep tcon
  75     tyvars = tyConTyVars tcon
  76
  77 collect_tdefs _ tdefs = tdefs
  78
  79
  80 make_cdef :: DataCon -> C.Cdef
  81 make_cdef dcon =  C.Constr dcon_name existentials tys
  82   where
  83     dcon_name    = make_var_id (dataConName dcon)
  84     existentials = map make_tbind ex_tyvars
  85     ex_tyvars    = dataConExTyVars dcon
  86     tys          = map make_ty (dataConRepArgTys dcon)
  87
  88 make_tbind :: TyVar -> C.Tbind
  89 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
  90
  91 make_vbind :: Var -> C.Vbind
  92 make_vbind v = (make_var_id  (Var.varName v), make_ty (idType v))
  93
  94 make_vdef :: NameSet -> CoreBind -> C.Vdefg
  95 make_vdef exports b =
  96   case b of
  97     NonRec v e -> C.Nonrec (f (v,e))
  98     Rec ves -> C.Rec (map f ves)
  99   where
 100   f (v,e) = (local, make_var_id (Var.varName v), make_ty (idType v),make_exp e)
 101         where local = not $ elementOfUniqSet (Var.varName v) exports
 102         -- Top level bindings are unqualified now
 103
 104 make_exp :: CoreExpr -> C.Exp
 105 make_exp (Var v) =
 106   case globalIdDetails v of
 107      -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
 108 --    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
 109     FCallId (CCall (CCallSpec (StaticTarget nm) callconv _))
 110         -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (idType v))
 111     FCallId (CCall (CCallSpec DynamicTarget     callconv _))
 112         -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (idType v))
 113     FCallId _
 114         -> pprPanic "MkExternalCore died: can't handle non-{static,dynamic}-C foreign call"
 115                     (ppr v)
 116     _ -> C.Var (make_var_qid (Var.varName v))
 117 make_exp (Lit (l@(MachLabel s _))) = C.Label (unpackFS s)
 118 make_exp (Lit l) = C.Lit (make_lit l)
 119 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 120 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
 121 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
 122 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
 123 make_exp (Cast e co) = C.Cast (make_exp e) (make_ty co)
 124 make_exp (Let b e) = C.Let (make_vdef emptyNameSet b) (make_exp e)
 125 -- gaw 2004
 126 make_exp (Case e v ty alts) = C.Case (make_exp e) (make_vbind v) (make_ty ty) (map make_alt alts)
 127 make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
 128 make_exp (Note (CoreNote s) e) = C.Note s (make_exp e)  -- hdaume: core annotations
 129 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
 130 make_exp _ = error "MkExternalCore died: make_exp"
 131
 132 make_alt :: CoreAlt -> C.Alt
 133 make_alt (DataAlt dcon, vs, e) =
 134     C.Acon (make_con_qid (dataConName dcon))
 135            (map make_tbind tbs)
 136            (map make_vbind vbs)
 137            (make_exp e)
 138         where (tbs,vbs) = span isTyVar vs
 139 make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
 140 make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
 141
 142 make_lit :: Literal -> C.Lit
 143 make_lit l =
 144   case l of
 145     MachChar i -> C.Lchar i t
 146     MachStr s -> C.Lstring (unpackFS s) t
 147     MachNullAddr -> C.Lint 0 t
 148     MachInt i -> C.Lint i t
 149     MachInt64 i -> C.Lint i t
 150     MachWord i -> C.Lint i t
 151     MachWord64 i -> C.Lint i t
 152     MachFloat r -> C.Lrational r t
 153     MachDouble r -> C.Lrational r t
 154     _ -> error "MkExternalCore died: make_lit"
 155   where
 156     t = make_ty (literalType l)
 157
 158 make_ty :: Type -> C.Ty
 159 make_ty (TyVarTy tv)             = C.Tvar (make_var_id (tyVarName tv))
 160 make_ty (AppTy t1 t2)            = C.Tapp (make_ty t1) (make_ty t2)
 161 make_ty (FunTy t1 t2)            = make_ty (TyConApp funTyCon [t1,t2])
 162 make_ty (ForAllTy tv t)          = C.Tforall (make_tbind tv) (make_ty t)
 163 make_ty (TyConApp tc ts)         = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
 164                                          (map make_ty ts)
 165 -- Newtypes are treated just like any other type constructor; not expanded
 166 -- Reason: predTypeRep does substitution and, while substitution deals
 167 --         correctly with name capture, it's only correct if you see the uniques!
 168 --         If you just see occurrence names, name capture may occur.
 169 -- Example: newtype A a = A (forall b. b -> a)
 170 --          test :: forall q b. q -> A b
 171 --          test _ = undefined
 172 --      Here the 'a' gets substituted by 'b', which is captured.
 173 -- Another solution would be to expand newtypes before tidying; but that would
 174 -- expose the representation in interface files, which definitely isn't right.
 175 -- Maybe CoreTidy should know whether to expand newtypes or not?
 176
 177 make_ty (PredTy p)      = make_ty (predTypeRep p)
 178 make_ty (NoteTy _ t)    = make_ty t
 179
 180
 181
 182 make_kind :: Kind -> C.Kind
 183 make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
 184     where (t1, t2) = getEqPredTys p
 185 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
 186 make_kind k
 187   | isLiftedTypeKind k   = C.Klifted
 188   | isUnliftedTypeKind k = C.Kunlifted
 189   | isOpenTypeKind k     = C.Kopen
 190 make_kind _ = error "MkExternalCore died: make_kind"
 191
 192 {- Id generation. -}
 193
 194 {- Use encoded strings.
 195    Also, adjust casing to work around some badly-chosen internal names. -}
 196 make_id :: Bool -> Name -> C.Id
 197 make_id is_var nm = (occNameString . nameOccName) nm
 198
 199 {-      SIMON thinks this stuff isn't necessary
 200 make_id is_var nm =
 201   case n of
 202     'Z':cs | is_var -> 'z':cs
 203     'z':cs | not is_var -> 'Z':cs
 204     c:cs | isUpper c && is_var -> 'z':'d':n
 205     c:cs | isLower c && (not is_var) -> 'Z':'d':n
 206     _ -> n
 207   where n = (occNameString . nameOccName) nm
 208 -}
 209
 210 make_var_id :: Name -> C.Id
 211 make_var_id = make_id True
 212
 213 make_mid :: Module -> C.Id
 214 make_mid = showSDoc . pprModule
 215
 216 make_qid :: Bool -> Name -> C.Qual C.Id
 217 make_qid is_var n = (mname,make_id is_var n)
 218     where mname =
 219            case nameModule_maybe n of
 220             Just m -> make_mid m
 221             Nothing -> ""
 222
 223 make_var_qid :: Name -> C.Qual C.Id
 224 make_var_qid = make_qid True
 225
 226 make_con_qid :: Name -> C.Qual C.Id
 227 make_con_qid = make_qid False
 228
 229 \end{code}
 230
 231
 232
 233