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