compiler/coreSyn/MkExternalCore.lhs

   1
   2 % (c) The University of Glasgow 2001-2006
   3 %
   4 \begin{code}
   5 module MkExternalCore (
   6         emitExternalCore
   7 ) where
   8
   9 #include "HsVersions.h"
  10
  11 import qualified ExternalCore as C
  12 import Module
  13 import CoreSyn
  14 import HscTypes
  15 import TyCon
  16 import TypeRep
  17 import Type
  18 import PprExternalCore () -- Instances
  19 import DataCon
  20 import Coercion
  21 import Var
  22 import IdInfo
  23 import Literal
  24 import Name
  25 import NameSet
  26 import UniqSet
  27 import Outputable
  28 import Encoding
  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` (\_ -> 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 (qtc tcon) (map make_tbind tyvars)
  66                   (case newTyConCo_maybe tcon of
  67                      Just coercion -> (qtc coercion,
  68                        make_kind $ (uncurry mkCoKind) $
  69                                   case isCoercionTyCon_maybe coercion of
  70                                     -- See Note [Newtype coercions] in
  71                                     -- types/TyCon
  72                                     Just (arity,coKindFun) -> coKindFun $
  73                                        map mkTyVarTy $ take arity tyvars
  74                                     Nothing -> pprPanic ("MkExternalCore:\
  75                                       coercion tcon should have a kind fun")
  76                                         (ppr tcon))
  77                      Nothing       -> pprPanic ("MkExternalCore: newtype tcon\
  78                                        should have a coercion: ") (ppr tcon))
  79                    repclause
  80          | otherwise =
  81                 C.Data (qtc tcon) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon))
  82          where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
  83                          | otherwise = Just (make_ty (repType rhs))
  84                                            where (_, rhs) = newTyConRhs tcon
  85     tyvars = tyConTyVars tcon
  86
  87 collect_tdefs _ tdefs = tdefs
  88
  89 qtc :: TyCon -> C.Qual C.Tcon
  90 qtc = make_con_qid . tyConName
  91
  92
  93 make_cdef :: DataCon -> C.Cdef
  94 make_cdef dcon =  C.Constr dcon_name existentials tys
  95   where
  96     dcon_name    = make_var_id (dataConName dcon)
  97     existentials = map make_tbind ex_tyvars
  98     ex_tyvars    = dataConExTyVars dcon
  99     tys          = map make_ty (dataConRepArgTys dcon)
 100
 101 make_tbind :: TyVar -> C.Tbind
 102 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
 103
 104 make_vbind :: Var -> C.Vbind
 105 make_vbind v = (make_var_id  (Var.varName v), make_ty (idType v))
 106
 107 make_vdef :: NameSet -> CoreBind -> C.Vdefg
 108 make_vdef exports b =
 109   case b of
 110     NonRec v e -> C.Nonrec (f (v,e))
 111     Rec ves -> C.Rec (map f ves)
 112   where
 113   f (v,e) = (local, make_var_id (Var.varName v), make_ty (idType v),make_exp e)
 114         where local = not $ elementOfUniqSet (Var.varName v) exports
 115         -- Top level bindings are unqualified now
 116
 117 make_exp :: CoreExpr -> C.Exp
 118 make_exp (Var v) =
 119   case globalIdDetails v of
 120      -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
 121 --    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
 122     FCallId (CCall (CCallSpec (StaticTarget nm) callconv _))
 123         -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (idType v))
 124     FCallId (CCall (CCallSpec DynamicTarget     callconv _))
 125         -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (idType v))
 126     FCallId _
 127         -> pprPanic "MkExternalCore died: can't handle non-{static,dynamic}-C foreign call"
 128                     (ppr v)
 129     _ -> C.Var (make_var_qid (Var.varName v))
 130 make_exp (Lit (MachLabel s _)) = C.Label (unpackFS s)
 131 make_exp (Lit l) = C.Lit (make_lit l)
 132 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 133 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
 134 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
 135 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
 136 make_exp (Cast e co) = C.Cast (make_exp e) (make_ty co)
 137 make_exp (Let b e) = C.Let (make_vdef emptyNameSet b) (make_exp e)
 138 -- gaw 2004
 139 make_exp (Case e v ty alts) = C.Case (make_exp e) (make_vbind v) (make_ty ty) (map make_alt alts)
 140 make_exp (Note (SCC _) e) = C.Note "SCC"  (make_exp e) -- temporary
 141 make_exp (Note (CoreNote s) e) = C.Note s (make_exp e)  -- hdaume: core annotations
 142 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
 143 make_exp _ = error "MkExternalCore died: make_exp"
 144
 145 make_alt :: CoreAlt -> C.Alt
 146 make_alt (DataAlt dcon, vs, e) =
 147     C.Acon (make_con_qid (dataConName dcon))
 148            (map make_tbind tbs)
 149            (map make_vbind vbs)
 150            (make_exp e)
 151         where (tbs,vbs) = span isTyVar vs
 152 make_alt (LitAlt l,_,e)   = C.Alit (make_lit l) (make_exp e)
 153 make_alt (DEFAULT,[],e)   = C.Adefault (make_exp e)
 154 -- This should never happen, as the DEFAULT alternative binds no variables,
 155 -- but we might as well check for it:
 156 make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
 157              ++ "alternative had a non-empty var list") (ppr a)
 158
 159
 160 make_lit :: Literal -> C.Lit
 161 make_lit l =
 162   case l of
 163     MachChar i -> C.Lchar i t
 164     MachStr s -> C.Lstring (unpackFS s) t
 165     MachNullAddr -> C.Lint 0 t
 166     MachInt i -> C.Lint i t
 167     MachInt64 i -> C.Lint i t
 168     MachWord i -> C.Lint i t
 169     MachWord64 i -> C.Lint i t
 170     MachFloat r -> C.Lrational r t
 171     MachDouble r -> C.Lrational r t
 172     _ -> error "MkExternalCore died: make_lit"
 173   where
 174     t = make_ty (literalType l)
 175
 176 make_ty :: Type -> C.Ty
 177 make_ty (TyVarTy tv)             = C.Tvar (make_var_id (tyVarName tv))
 178 make_ty (AppTy t1 t2)            = C.Tapp (make_ty t1) (make_ty t2)
 179 make_ty (FunTy t1 t2)            = make_ty (TyConApp funTyCon [t1,t2])
 180 make_ty (ForAllTy tv t)          = C.Tforall (make_tbind tv) (make_ty t)
 181 make_ty (TyConApp tc ts)         = foldl C.Tapp (C.Tcon (qtc tc))
 182                                          (map make_ty ts)
 183 -- Newtypes are treated just like any other type constructor; not expanded
 184 -- Reason: predTypeRep does substitution and, while substitution deals
 185 --         correctly with name capture, it's only correct if you see the uniques!
 186 --         If you just see occurrence names, name capture may occur.
 187 -- Example: newtype A a = A (forall b. b -> a)
 188 --          test :: forall q b. q -> A b
 189 --          test _ = undefined
 190 --      Here the 'a' gets substituted by 'b', which is captured.
 191 -- Another solution would be to expand newtypes before tidying; but that would
 192 -- expose the representation in interface files, which definitely isn't right.
 193 -- Maybe CoreTidy should know whether to expand newtypes or not?
 194
 195 make_ty (PredTy p)      = make_ty (predTypeRep p)
 196
 197
 198
 199 make_kind :: Kind -> C.Kind
 200 make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
 201     where (t1, t2) = getEqPredTys p
 202 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
 203 make_kind k
 204   | isLiftedTypeKind k   = C.Klifted
 205   | isUnliftedTypeKind k = C.Kunlifted
 206   | isOpenTypeKind k     = C.Kopen
 207 make_kind _ = error "MkExternalCore died: make_kind"
 208
 209 {- Id generation. -}
 210
 211 make_id :: Bool -> Name -> C.Id
 212 make_id _is_var nm = (occNameString . nameOccName) nm
 213
 214 make_var_id :: Name -> C.Id
 215 make_var_id = make_id True
 216
 217 -- It's important to encode the module name here, because in External Core,
 218 -- base:GHC.Base => base:GHCziBase
 219 -- We don't do this in pprExternalCore because we
 220 -- *do* want to keep the package name (we don't want baseZCGHCziBase,
 221 -- because that would just be ugly.)
 222 -- SIGH.
 223 -- We encode the package name as well.
 224 make_mid :: Module -> C.Id
 225 -- Super ugly code, but I can't find anything else that does quite what I
 226 -- want (encodes the hierarchical module name without encoding the colon
 227 -- that separates the package name from it.)
 228 make_mid m = showSDoc $
 229               (text $ zEncodeString $ packageIdString $ modulePackageId m)
 230               <> text ":"
 231               <> (pprEncoded $ pprModuleName $ moduleName m)
 232      where pprEncoded = pprCode CStyle
 233
 234 make_qid :: Bool -> Name -> C.Qual C.Id
 235 make_qid is_var n = (mname,make_id is_var n)
 236     where mname =
 237            case nameModule_maybe n of
 238             Just m -> make_mid m
 239             Nothing -> ""
 240
 241 make_var_qid :: Name -> C.Qual C.Id
 242 make_var_qid = make_qid True
 243
 244 make_con_qid :: Name -> C.Qual C.Id
 245 make_con_qid = make_qid False
 246
 247 \end{code}
 248
 249
 250
 251