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 Class
  17 import TysPrim( eqPredPrimTyCon )
  18 import TypeRep
  19 import Type
  20 import PprExternalCore () -- Instances
  21 import DataCon
  22 import Coercion
  23 import Var
  24 import IdInfo
  25 import Literal
  26 import Name
  27 import Outputable
  28 import Encoding
  29 import ForeignCall
  30 import DynFlags
  31 import FastString
  32 import Exception
  33
  34 import Data.Char
  35 import System.IO
  36
  37 emitExternalCore :: DynFlags -> CgGuts -> IO ()
  38 emitExternalCore dflags cg_guts
  39  | dopt Opt_EmitExternalCore dflags
  40  = (do handle <- openFile corename WriteMode
  41        hPutStrLn handle (show (mkExternalCore cg_guts))
  42        hClose handle)
  43    `catchIO` (\_ -> 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 -- Reinventing the Reader monad; whee.
  51 newtype CoreM a = CoreM (CoreState -> (CoreState, a))
  52 type CoreState = Module
  53 instance Monad CoreM where
  54   (CoreM m) >>= f = CoreM (\ s -> case m s of
  55                                     (s',r) -> case f r of
  56                                                 CoreM f' -> f' s')
  57   return x = CoreM (\ s -> (s, x))
  58 runCoreM :: CoreM a -> CoreState -> a
  59 runCoreM (CoreM f) s = snd $ f s
  60 ask :: CoreM CoreState
  61 ask = CoreM (\ s -> (s,s))
  62
  63 mkExternalCore :: CgGuts -> C.Module
  64 -- The ModGuts has been tidied, but the implicit bindings have
  65 -- not been injected, so we have to add them manually here
  66 -- We don't include the strange data-con *workers* because they are
  67 -- implicit in the data type declaration itself
  68 mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons,
  69                         cg_binds = binds})
  70 {- Note that modules can be mutually recursive, but even so, we
  71    print out dependency information within each module. -}
  72   = C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds) this_mod)
  73   where
  74     mname  = make_mid this_mod
  75     tdefs  = foldr collect_tdefs [] tycons
  76
  77 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
  78 collect_tdefs tcon tdefs
  79   | isAlgTyCon tcon = tdef: tdefs
  80   where
  81     tdef | isNewTyCon tcon =
  82                 C.Newtype (qtc tcon)
  83                   (qcc (newTyConCo tcon))
  84                   (map make_tbind tyvars)
  85                   (make_ty (snd (newTyConRhs tcon)))
  86          | otherwise =
  87                 C.Data (qtc tcon) (map make_tbind tyvars)
  88                    (map make_cdef (tyConDataCons tcon))
  89     tyvars = tyConTyVars tcon
  90
  91 collect_tdefs _ tdefs = tdefs
  92
  93 qtc :: TyCon -> C.Qual C.Tcon
  94 qtc = make_con_qid . tyConName
  95
  96 qcc :: CoAxiom -> C.Qual C.Tcon
  97 qcc = make_con_qid . co_ax_name
  98
  99 make_cdef :: DataCon -> C.Cdef
 100 make_cdef dcon =  C.Constr dcon_name existentials tys
 101   where
 102     dcon_name    = make_qid False False (dataConName dcon)
 103     existentials = map make_tbind ex_tyvars
 104     ex_tyvars    = dataConExTyVars dcon
 105     tys          = map make_ty (dataConRepArgTys dcon)
 106
 107 make_tbind :: TyVar -> C.Tbind
 108 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
 109
 110 make_vbind :: Var -> C.Vbind
 111 make_vbind v = (make_var_id  (Var.varName v), make_ty (varType v))
 112
 113 make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg
 114 make_vdef topLevel b =
 115   case b of
 116     NonRec v e -> f (v,e)     >>= (return . C.Nonrec)
 117     Rec ves    -> mapM f ves  >>= (return . C.Rec)
 118   where
 119   f :: (CoreBndr,CoreExpr) -> CoreM C.Vdef
 120   f (v,e) = do
 121           localN <- isALocal vName
 122           let local = not topLevel || localN
 123           rhs <- make_exp e
 124           -- use local flag to determine where to add the module name
 125           return (local, make_qid local True vName, make_ty (varType v),rhs)
 126         where vName = Var.varName v
 127
 128 make_exp :: CoreExpr -> CoreM C.Exp
 129 make_exp (Var v) = do
 130   let vName = Var.varName v
 131   isLocal <- isALocal vName
 132   return $
 133      case idDetails v of
 134        FCallId (CCall (CCallSpec (StaticTarget nm _) callconv _))
 135            -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
 136        FCallId (CCall (CCallSpec DynamicTarget     callconv _))
 137            -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (varType v))
 138        -- Constructors are always exported, so make sure to declare them
 139        -- with qualified names
 140        DataConWorkId _ -> C.Var (make_var_qid False vName)
 141        DataConWrapId _ -> C.Var (make_var_qid False vName)
 142        _ -> C.Var (make_var_qid isLocal vName)
 143 make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
 144 make_exp (Lit l) = return $ C.Lit (make_lit l)
 145 make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
 146 make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))"    -- TODO
 147 make_exp (App e1 e2) = do
 148    rator <- make_exp e1
 149    rand <- make_exp e2
 150    return $ C.App rator rand
 151 make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b ->
 152                                     return $ C.Lam (C.Tb (make_tbind v)) b)
 153 make_exp (Lam v e) | otherwise = make_exp e >>= (\ b ->
 154                                     return $ C.Lam (C.Vb (make_vbind v)) b)
 155 make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co))
 156 make_exp (Let b e) = do
 157   vd   <- make_vdef False b
 158   body <- make_exp e
 159   return $ C.Let vd body
 160 make_exp (Case e v ty alts) = do
 161   scrut <- make_exp e
 162   newAlts  <- mapM make_alt alts
 163   return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts
 164 make_exp (Note (SCC _) e) = make_exp e >>= (return . C.Note "SCC") -- temporary
 165 make_exp (Note (CoreNote s) e) = make_exp e >>= (return . C.Note s)  -- hdaume: core annotations
 166 make_exp _ = error "MkExternalCore died: make_exp"
 167
 168 make_alt :: CoreAlt -> CoreM C.Alt
 169 make_alt (DataAlt dcon, vs, e) = do
 170     newE <- make_exp e
 171     return $ C.Acon (make_con_qid (dataConName dcon))
 172            (map make_tbind tbs)
 173            (map make_vbind vbs)
 174            newE
 175         where (tbs,vbs) = span isTyVar vs
 176 make_alt (LitAlt l,_,e)   = make_exp e >>= (return . (C.Alit (make_lit l)))
 177 make_alt (DEFAULT,[],e)   = make_exp e >>= (return . C.Adefault)
 178 -- This should never happen, as the DEFAULT alternative binds no variables,
 179 -- but we might as well check for it:
 180 make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
 181              ++ "alternative had a non-empty var list") (ppr a)
 182
 183
 184 make_lit :: Literal -> C.Lit
 185 make_lit l =
 186   case l of
 187     -- Note that we need to check whether the character is "big".
 188     -- External Core only allows character literals up to '\xff'.
 189     MachChar i | i <= chr 0xff -> C.Lchar i t
 190     -- For a character bigger than 0xff, we represent it in ext-core
 191     -- as an int lit with a char type.
 192     MachChar i             -> C.Lint (fromIntegral $ ord i) t
 193     MachStr s -> C.Lstring (unpackFS s) t
 194     MachNullAddr -> C.Lint 0 t
 195     MachInt i -> C.Lint i t
 196     MachInt64 i -> C.Lint i t
 197     MachWord i -> C.Lint i t
 198     MachWord64 i -> C.Lint i t
 199     MachFloat r -> C.Lrational r t
 200     MachDouble r -> C.Lrational r t
 201     _ -> error "MkExternalCore died: make_lit"
 202   where
 203     t = make_ty (literalType l)
 204
 205 -- Expand type synonyms, then convert.
 206 make_ty :: Type -> C.Ty                 -- Be sure to expand types recursively!
 207                                         -- example: FilePath ~> String ~> [Char]
 208 make_ty t | Just expanded <- tcView t = make_ty expanded
 209 make_ty t = make_ty' t
 210
 211 -- note calls to make_ty so as to expand types recursively
 212 make_ty' :: Type -> C.Ty
 213 make_ty' (TyVarTy tv)            = C.Tvar (make_var_id (tyVarName tv))
 214 make_ty' (AppTy t1 t2)           = C.Tapp (make_ty t1) (make_ty t2)
 215 make_ty' (FunTy t1 t2)           = make_ty (TyConApp funTyCon [t1,t2])
 216 make_ty' (ForAllTy tv t)         = C.Tforall (make_tbind tv) (make_ty t)
 217 make_ty' (TyConApp tc ts)        = make_tyConApp tc ts
 218
 219 -- Newtypes are treated just like any other type constructor; not expanded
 220 -- Reason: predTypeRep does substitution and, while substitution deals
 221 --         correctly with name capture, it's only correct if you see the uniques!
 222 --         If you just see occurrence names, name capture may occur.
 223 -- Example: newtype A a = A (forall b. b -> a)
 224 --          test :: forall q b. q -> A b
 225 --          test _ = undefined
 226 --      Here the 'a' gets substituted by 'b', which is captured.
 227 -- Another solution would be to expand newtypes before tidying; but that would
 228 -- expose the representation in interface files, which definitely isn't right.
 229 -- Maybe CoreTidy should know whether to expand newtypes or not?
 230
 231 make_ty' (PredTy p)     = make_ty (predTypeRep p)
 232
 233 make_tyConApp :: TyCon -> [Type] -> C.Ty
 234 make_tyConApp tc ts =
 235   foldl C.Tapp (C.Tcon (qtc tc))
 236             (map make_ty ts)
 237
 238 make_kind :: Kind -> C.Kind
 239 make_kind (PredTy (EqPred t1 t2)) = C.Keq (make_ty t1) (make_ty t2)
 240 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
 241 make_kind k
 242   | isLiftedTypeKind k   = C.Klifted
 243   | isUnliftedTypeKind k = C.Kunlifted
 244   | isOpenTypeKind k     = C.Kopen
 245 make_kind _ = error "MkExternalCore died: make_kind"
 246
 247 {- Id generation. -}
 248
 249 make_id :: Bool -> Name -> C.Id
 250 -- include uniques for internal names in order to avoid name shadowing
 251 make_id _is_var nm = ((occNameString . nameOccName) nm)
 252   ++ (if isInternalName nm then (show . nameUnique) nm else "")
 253
 254 make_var_id :: Name -> C.Id
 255 make_var_id = make_id True
 256
 257 -- It's important to encode the module name here, because in External Core,
 258 -- base:GHC.Base => base:GHCziBase
 259 -- We don't do this in pprExternalCore because we
 260 -- *do* want to keep the package name (we don't want baseZCGHCziBase,
 261 -- because that would just be ugly.)
 262 -- SIGH.
 263 -- We encode the package name as well.
 264 make_mid :: Module -> C.Id
 265 -- Super ugly code, but I can't find anything else that does quite what I
 266 -- want (encodes the hierarchical module name without encoding the colon
 267 -- that separates the package name from it.)
 268 make_mid m = showSDoc $
 269               (text $ zEncodeString $ packageIdString $ modulePackageId m)
 270               <> text ":"
 271               <> (pprEncoded $ pprModuleName $ moduleName m)
 272      where pprEncoded = pprCode CStyle
 273
 274 make_qid :: Bool -> Bool -> Name -> C.Qual C.Id
 275 make_qid force_unqual is_var n = (mname,make_id is_var n)
 276     where mname =
 277            case nameModule_maybe n of
 278             Just m | not force_unqual -> make_mid m
 279             _ -> ""
 280
 281 make_var_qid :: Bool -> Name -> C.Qual C.Id
 282 make_var_qid force_unqual = make_qid force_unqual True
 283
 284 make_con_qid :: Name -> C.Qual C.Id
 285 make_con_qid = make_qid False False
 286
 287 make_co :: Coercion -> C.Ty
 288 make_co (Refl ty)             = make_ty ty
 289 make_co (TyConAppCo tc cos)   = make_conAppCo (qtc tc) cos
 290 make_co (AppCo c1 c2)         = C.Tapp (make_co c1) (make_co c2)
 291 make_co (ForAllCo tv co)      = C.Tforall (make_tbind tv) (make_co co)
 292 make_co (PredCo (ClassP cls cos)) = make_conAppCo (qtc (classTyCon cls)) cos
 293 make_co (PredCo (IParam _ co))    = make_co co
 294 make_co (PredCo (EqPred co1 co2)) = make_conAppCo (qtc eqPredPrimTyCon) [co1,co2]
 295 make_co (CoVarCo cv)          = C.Tvar (make_var_id (coVarName cv))
 296 make_co (AxiomInstCo cc cos)  = make_conAppCo (qcc cc) cos
 297 make_co (UnsafeCo t1 t2)      = C.UnsafeCoercion (make_ty t1) (make_ty t2)
 298 make_co (SymCo co)            = C.SymCoercion (make_co co)
 299 make_co (TransCo c1 c2)       = C.TransCoercion (make_co c1) (make_co c2)
 300 make_co (NthCo d co)          = C.NthCoercion d (make_co co)
 301 make_co (InstCo co ty)        = C.InstCoercion (make_co co) (make_ty ty)
 302
 303 -- Used for both tycon app coercions and axiom instantiations.
 304 make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty
 305 make_conAppCo con cos =
 306   foldl C.Tapp (C.Tcon con)
 307             (map make_co cos)
 308
 309 -------
 310 isALocal :: Name -> CoreM Bool
 311 isALocal vName = do
 312   modName <- ask
 313   return $ case nameModule_maybe vName of
 314              -- Not sure whether isInternalName corresponds to "local"ness
 315              -- in the External Core sense; need to re-read the spec.
 316              Just m | m == modName -> isInternalName vName
 317              _                     -> False
 318 \end{code}
 319
 320
 321
 322