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