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