compiler/coreSyn/MkExternalCore.lhs

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