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