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