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) _ _)) -> C.External (unpackFS nm) (make_ty (idType v))
 109     FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
 110     _ -> C.Var (make_var_qid (Var.varName v))
 111 make_exp (Lit (l@(MachLabel s _))) = error "MkExternalCore died: can't handle \"foreign label\" declarations"
 112 make_exp (Lit l) = C.Lit (make_lit l)
 113 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 114 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
 115 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
 116 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
 117 make_exp (Cast e co) = C.Cast (make_exp e) (make_ty co)
 118 make_exp (Let b e) = C.Let (make_vdef emptyNameSet b) (make_exp e)
 119 -- gaw 2004
 120 make_exp (Case e v ty alts) = C.Case (make_exp e) (make_vbind v) (make_ty ty) (map make_alt alts)
 121 make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
 122 make_exp (Note (CoreNote s) e) = C.Note s (make_exp e)  -- hdaume: core annotations
 123 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
 124 make_exp _ = error "MkExternalCore died: make_exp"
 125
 126 make_alt :: CoreAlt -> C.Alt
 127 make_alt (DataAlt dcon, vs, e) =
 128     C.Acon (make_con_qid (dataConName dcon))
 129            (map make_tbind tbs)
 130            (map make_vbind vbs)
 131            (make_exp e)
 132         where (tbs,vbs) = span isTyVar vs
 133 make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
 134 make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
 135
 136 make_lit :: Literal -> C.Lit
 137 make_lit l =
 138   case l of
 139     MachChar i -> C.Lchar i t
 140     MachStr s -> C.Lstring (unpackFS s) t
 141     MachNullAddr -> C.Lint 0 t
 142     MachInt i -> C.Lint i t
 143     MachInt64 i -> C.Lint i t
 144     MachWord i -> C.Lint i t
 145     MachWord64 i -> C.Lint i t
 146     MachFloat r -> C.Lrational r t
 147     MachDouble r -> C.Lrational r t
 148     _ -> error "MkExternalCore died: make_lit"
 149   where
 150     t = make_ty (literalType l)
 151
 152 make_ty :: Type -> C.Ty
 153 make_ty (TyVarTy tv)             = C.Tvar (make_var_id (tyVarName tv))
 154 make_ty (AppTy t1 t2)            = C.Tapp (make_ty t1) (make_ty t2)
 155 make_ty (FunTy t1 t2)            = make_ty (TyConApp funTyCon [t1,t2])
 156 make_ty (ForAllTy tv t)          = C.Tforall (make_tbind tv) (make_ty t)
 157 make_ty (TyConApp tc ts)         = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
 158                                          (map make_ty ts)
 159 -- Newtypes are treated just like any other type constructor; not expanded
 160 -- Reason: predTypeRep does substitution and, while substitution deals
 161 --         correctly with name capture, it's only correct if you see the uniques!
 162 --         If you just see occurrence names, name capture may occur.
 163 -- Example: newtype A a = A (forall b. b -> a)
 164 --          test :: forall q b. q -> A b
 165 --          test _ = undefined
 166 --      Here the 'a' gets substituted by 'b', which is captured.
 167 -- Another solution would be to expand newtypes before tidying; but that would
 168 -- expose the representation in interface files, which definitely isn't right.
 169 -- Maybe CoreTidy should know whether to expand newtypes or not?
 170
 171 make_ty (PredTy p)      = make_ty (predTypeRep p)
 172 make_ty (NoteTy _ t)    = make_ty t
 173
 174
 175
 176 make_kind :: Kind -> C.Kind
 177 make_kind (PredTy p) | isEqPred p = panic "coercion kinds in external core not implemented!"
 178 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
 179 make_kind k
 180   | isLiftedTypeKind k   = C.Klifted
 181   | isUnliftedTypeKind k = C.Kunlifted
 182   | isOpenTypeKind k     = C.Kopen
 183 make_kind _ = error "MkExternalCore died: make_kind"
 184
 185 {- Id generation. -}
 186
 187 {- Use encoded strings.
 188    Also, adjust casing to work around some badly-chosen internal names. -}
 189 make_id :: Bool -> Name -> C.Id
 190 make_id is_var nm = (occNameString . nameOccName) nm
 191
 192 {-      SIMON thinks this stuff isn't necessary
 193 make_id is_var nm =
 194   case n of
 195     'Z':cs | is_var -> 'z':cs
 196     'z':cs | not is_var -> 'Z':cs
 197     c:cs | isUpper c && is_var -> 'z':'d':n
 198     c:cs | isLower c && (not is_var) -> 'Z':'d':n
 199     _ -> n
 200   where n = (occNameString . nameOccName) nm
 201 -}
 202
 203 make_var_id :: Name -> C.Id
 204 make_var_id = make_id True
 205
 206 make_mid :: Module -> C.Id
 207 make_mid = showSDoc . pprModule
 208
 209 make_qid :: Bool -> Name -> C.Qual C.Id
 210 make_qid is_var n = (mname,make_id is_var n)
 211     where mname =
 212            case nameModule_maybe n of
 213             Just m -> make_mid m
 214             Nothing -> ""
 215
 216 make_var_qid :: Name -> C.Qual C.Id
 217 make_var_qid = make_qid True
 218
 219 make_con_qid :: Name -> C.Qual C.Id
 220 make_con_qid = make_qid False
 221
 222 \end{code}
 223
 224
 225
 226