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