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