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