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