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