compiler/coreSyn/MkExternalCore.lhs

   1
   2 % (c) The University of Glasgow 2001-2006
   3 %
   4 \begin{code}
   5 {-# OPTIONS -fno-warn-incomplete-patterns #-}
   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/Commentary/CodingStyle#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` (\_ -> 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          | otherwise =
  73                 C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon))
  74          where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
  75                          | otherwise = Just (make_ty (repType rhs))
  76                                            where (_, rhs) = newTyConRhs tcon
  77     tyvars = tyConTyVars tcon
  78
  79 collect_tdefs _ tdefs = tdefs
  80
  81
  82 make_cdef :: DataCon -> C.Cdef
  83 make_cdef dcon =  C.Constr dcon_name existentials tys
  84   where
  85     dcon_name    = make_var_id (dataConName dcon)
  86     existentials = map make_tbind ex_tyvars
  87     ex_tyvars    = dataConExTyVars dcon
  88     tys          = map make_ty (dataConRepArgTys dcon)
  89
  90 make_tbind :: TyVar -> C.Tbind
  91 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
  92
  93 make_vbind :: Var -> C.Vbind
  94 make_vbind v = (make_var_id  (Var.varName v), make_ty (idType v))
  95
  96 make_vdef :: NameSet -> CoreBind -> C.Vdefg
  97 make_vdef exports b =
  98   case b of
  99     NonRec v e -> C.Nonrec (f (v,e))
 100     Rec ves -> C.Rec (map f ves)
 101   where
 102   f (v,e) = (local, make_var_id (Var.varName v), make_ty (idType v),make_exp e)
 103         where local = not $ elementOfUniqSet (Var.varName v) exports
 104         -- Top level bindings are unqualified now
 105
 106 make_exp :: CoreExpr -> C.Exp
 107 make_exp (Var v) =
 108   case globalIdDetails v of
 109      -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
 110 --    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
 111     FCallId (CCall (CCallSpec (StaticTarget nm) callconv _))
 112         -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (idType v))
 113     FCallId (CCall (CCallSpec DynamicTarget     callconv _))
 114         -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (idType v))
 115     FCallId _
 116         -> pprPanic "MkExternalCore died: can't handle non-{static,dynamic}-C foreign call"
 117                     (ppr v)
 118     _ -> C.Var (make_var_qid (Var.varName v))
 119 make_exp (Lit (MachLabel s _)) = C.Label (unpackFS s)
 120 make_exp (Lit l) = C.Lit (make_lit l)
 121 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 122 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
 123 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
 124 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
 125 make_exp (Cast e co) = C.Cast (make_exp e) (make_ty co)
 126 make_exp (Let b e) = C.Let (make_vdef emptyNameSet b) (make_exp e)
 127 -- gaw 2004
 128 make_exp (Case e v ty alts) = C.Case (make_exp e) (make_vbind v) (make_ty ty) (map make_alt alts)
 129 make_exp (Note (SCC _) e) = C.Note "SCC"  (make_exp e) -- temporary
 130 make_exp (Note (CoreNote s) e) = C.Note s (make_exp e)  -- hdaume: core annotations
 131 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
 132 make_exp _ = error "MkExternalCore died: make_exp"
 133
 134 make_alt :: CoreAlt -> C.Alt
 135 make_alt (DataAlt dcon, vs, e) =
 136     C.Acon (make_con_qid (dataConName dcon))
 137            (map make_tbind tbs)
 138            (map make_vbind vbs)
 139            (make_exp e)
 140         where (tbs,vbs) = span isTyVar vs
 141 make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
 142 make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
 143
 144 make_lit :: Literal -> C.Lit
 145 make_lit l =
 146   case l of
 147     MachChar i -> C.Lchar i t
 148     MachStr s -> C.Lstring (unpackFS s) t
 149     MachNullAddr -> C.Lint 0 t
 150     MachInt i -> C.Lint i t
 151     MachInt64 i -> C.Lint i t
 152     MachWord i -> C.Lint i t
 153     MachWord64 i -> C.Lint i t
 154     MachFloat r -> C.Lrational r t
 155     MachDouble r -> C.Lrational r t
 156     _ -> error "MkExternalCore died: make_lit"
 157   where
 158     t = make_ty (literalType l)
 159
 160 make_ty :: Type -> C.Ty
 161 make_ty (TyVarTy tv)             = C.Tvar (make_var_id (tyVarName tv))
 162 make_ty (AppTy t1 t2)            = C.Tapp (make_ty t1) (make_ty t2)
 163 make_ty (FunTy t1 t2)            = make_ty (TyConApp funTyCon [t1,t2])
 164 make_ty (ForAllTy tv t)          = C.Tforall (make_tbind tv) (make_ty t)
 165 make_ty (TyConApp tc ts)         = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
 166                                          (map make_ty ts)
 167 -- Newtypes are treated just like any other type constructor; not expanded
 168 -- Reason: predTypeRep does substitution and, while substitution deals
 169 --         correctly with name capture, it's only correct if you see the uniques!
 170 --         If you just see occurrence names, name capture may occur.
 171 -- Example: newtype A a = A (forall b. b -> a)
 172 --          test :: forall q b. q -> A b
 173 --          test _ = undefined
 174 --      Here the 'a' gets substituted by 'b', which is captured.
 175 -- Another solution would be to expand newtypes before tidying; but that would
 176 -- expose the representation in interface files, which definitely isn't right.
 177 -- Maybe CoreTidy should know whether to expand newtypes or not?
 178
 179 make_ty (PredTy p)      = make_ty (predTypeRep p)
 180 make_ty (NoteTy _ t)    = make_ty t
 181
 182
 183
 184 make_kind :: Kind -> C.Kind
 185 make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
 186     where (t1, t2) = getEqPredTys p
 187 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
 188 make_kind k
 189   | isLiftedTypeKind k   = C.Klifted
 190   | isUnliftedTypeKind k = C.Kunlifted
 191   | isOpenTypeKind k     = C.Kopen
 192 make_kind _ = error "MkExternalCore died: make_kind"
 193
 194 {- Id generation. -}
 195
 196 {- Use encoded strings.
 197    Also, adjust casing to work around some badly-chosen internal names. -}
 198 make_id :: Bool -> Name -> C.Id
 199 make_id _is_var nm = (occNameString . nameOccName) nm
 200
 201 {-      SIMON thinks this stuff isn't necessary
 202 make_id is_var nm =
 203   case n of
 204     'Z':cs | is_var -> 'z':cs
 205     'z':cs | not is_var -> 'Z':cs
 206     c:cs | isUpper c && is_var -> 'z':'d':n
 207     c:cs | isLower c && (not is_var) -> 'Z':'d':n
 208     _ -> n
 209   where n = (occNameString . nameOccName) nm
 210 -}
 211
 212 make_var_id :: Name -> C.Id
 213 make_var_id = make_id True
 214
 215 make_mid :: Module -> C.Id
 216 make_mid = showSDoc . pprModule
 217
 218 make_qid :: Bool -> Name -> C.Qual C.Id
 219 make_qid is_var n = (mname,make_id is_var n)
 220     where mname =
 221            case nameModule_maybe n of
 222             Just m -> make_mid m
 223             Nothing -> ""
 224
 225 make_var_qid :: Name -> C.Qual C.Id
 226 make_var_qid = make_qid True
 227
 228 make_con_qid :: Name -> C.Qual C.Id
 229 make_con_qid = make_qid False
 230
 231 \end{code}
 232
 233
 234
 235