import CoreSyn
import HscTypes
import TyCon
+-- import Class
+-- import TysPrim( eqPredPrimTyCon )
import TypeRep
import Type
import PprExternalCore () -- Instances
import Encoding
import ForeignCall
import DynFlags
-import StaticFlags
import FastString
+import Exception
-import IO
import Data.Char
+import System.IO
emitExternalCore :: DynFlags -> CgGuts -> IO ()
emitExternalCore dflags cg_guts
- | opt_EmitExternalCore
+ | dopt Opt_EmitExternalCore dflags
= (do handle <- openFile corename WriteMode
- hPutStrLn handle (show (mkExternalCore cg_guts))
+ hPutStrLn handle (show (mkExternalCore cg_guts))
hClose handle)
- `catch` (\_ -> pprPanic "Failed to open or write external core output file"
- (text corename))
+ `catchIO` (\_ -> pprPanic "Failed to open or write external core output file"
+ (text corename))
where corename = extCoreName dflags
emitExternalCore _ _
| otherwise
-- implicit in the data type declaration itself
mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons,
cg_binds = binds})
- -- Note that we flatten binds at the top level:
- -- every module is just a single recursive bag of declarations.
- -- Rationale: since modules can be mutually recursive,
- -- there's not much reason to preserve dependency info within a module.
- = C.Module mname tdefs (case flattenBinds binds of
- -- check for empty list so we don't create an
- -- empty Rec group
- [] -> []
- bs -> [(runCoreM (make_vdef True
- (Rec bs)) this_mod)])
+{- Note that modules can be mutually recursive, but even so, we
+ print out dependency information within each module. -}
+ = C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds) this_mod)
where
mname = make_mid this_mod
tdefs = foldr collect_tdefs [] tycons
where
tdef | isNewTyCon tcon =
C.Newtype (qtc tcon)
- (case newTyConCo_maybe tcon of
- Just co -> qtc co
- Nothing -> pprPanic ("MkExternalCore: newtype tcon\
- should have a coercion: ") (ppr tcon))
+ (qcc (newTyConCo tcon))
(map make_tbind tyvars)
(make_ty (snd (newTyConRhs tcon)))
| otherwise =
qtc :: TyCon -> C.Qual C.Tcon
qtc = make_con_qid . tyConName
+qcc :: CoAxiom -> C.Qual C.Tcon
+qcc = make_con_qid . co_ax_name
make_cdef :: DataCon -> C.Cdef
make_cdef dcon = C.Constr dcon_name existentials tys
make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
make_vbind :: Var -> C.Vbind
-make_vbind v = (make_var_id (Var.varName v), make_ty (idType v))
+make_vbind v = (make_var_id (Var.varName v), make_ty (varType v))
make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg
make_vdef topLevel b =
let local = not topLevel || localN
rhs <- make_exp e
-- use local flag to determine where to add the module name
- return (local, make_qid local True vName, make_ty (idType v),rhs)
+ return (local, make_qid local True vName, make_ty (varType v),rhs)
where vName = Var.varName v
make_exp :: CoreExpr -> CoreM C.Exp
let vName = Var.varName v
isLocal <- isALocal vName
return $
- case globalIdDetails v of
- FCallId (CCall (CCallSpec (StaticTarget nm) callconv _))
- -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (idType v))
+ case idDetails v of
+ FCallId (CCall (CCallSpec (StaticTarget nm _) callconv _))
+ -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
FCallId (CCall (CCallSpec DynamicTarget callconv _))
- -> C.DynExternal (showSDoc (ppr callconv)) (make_ty (idType v))
- FCallId _
- -> pprPanic "MkExternalCore died: can't handle non-{static,dynamic}-C foreign call"
- (ppr v)
+ -> C.DynExternal (showSDoc (ppr callconv)) (make_ty (varType v))
-- Constructors are always exported, so make sure to declare them
-- with qualified names
DataConWorkId _ -> C.Var (make_var_qid False vName)
DataConWrapId _ -> C.Var (make_var_qid False vName)
_ -> C.Var (make_var_qid isLocal vName)
-make_exp (Lit (MachLabel s _)) = return $ C.Label (unpackFS s)
+make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
make_exp (Lit l) = return $ C.Lit (make_lit l)
make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
+make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))" -- TODO
make_exp (App e1 e2) = do
rator <- make_exp e1
rand <- make_exp e2
return $ C.Lam (C.Tb (make_tbind v)) b)
make_exp (Lam v e) | otherwise = make_exp e >>= (\ b ->
return $ C.Lam (C.Vb (make_vbind v)) b)
-make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_ty co))
+make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co))
make_exp (Let b e) = do
vd <- make_vdef False b
body <- make_exp e
return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts
make_exp (Note (SCC _) e) = make_exp e >>= (return . C.Note "SCC") -- temporary
make_exp (Note (CoreNote s) e) = make_exp e >>= (return . C.Note s) -- hdaume: core annotations
-make_exp (Note InlineMe e) = make_exp e >>= (return . C.Note "InlineMe")
make_exp _ = error "MkExternalCore died: make_exp"
make_alt :: CoreAlt -> CoreM C.Alt
make_ty' (PredTy p) = make_ty (predTypeRep p)
make_tyConApp :: TyCon -> [Type] -> C.Ty
-make_tyConApp tc [t1, t2] | tc == transCoercionTyCon =
- C.TransCoercion (make_ty t1) (make_ty t2)
-make_tyConApp tc [t] | tc == symCoercionTyCon =
- C.SymCoercion (make_ty t)
-make_tyConApp tc [t1, t2] | tc == unsafeCoercionTyCon =
- C.UnsafeCoercion (make_ty t1) (make_ty t2)
-make_tyConApp tc [t] | tc == leftCoercionTyCon =
- C.LeftCoercion (make_ty t)
-make_tyConApp tc [t] | tc == rightCoercionTyCon =
- C.RightCoercion (make_ty t)
-make_tyConApp tc [t1, t2] | tc == instCoercionTyCon =
- C.InstCoercion (make_ty t1) (make_ty t2)
--- this fails silently if we have an application
--- of a wired-in coercion tycon to the wrong number of args.
--- Not great...
make_tyConApp tc ts =
foldl C.Tapp (C.Tcon (qtc tc))
(map make_ty ts)
-
make_kind :: Kind -> C.Kind
-make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
- where (t1, t2) = getEqPredTys p
+make_kind (PredTy (EqPred t1 t2)) = C.Keq (make_ty t1) (make_ty t2)
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
make_kind k
| isLiftedTypeKind k = C.Klifted
make_con_qid :: Name -> C.Qual C.Id
make_con_qid = make_qid False False
+make_co :: Coercion -> C.Ty
+make_co (Refl ty) = make_ty ty
+make_co (TyConAppCo tc cos) = make_conAppCo (qtc tc) cos
+make_co (AppCo c1 c2) = C.Tapp (make_co c1) (make_co c2)
+make_co (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co co)
+make_co (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv))
+make_co (AxiomInstCo cc cos) = make_conAppCo (qcc cc) cos
+make_co (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty t1) (make_ty t2)
+make_co (SymCo co) = C.SymCoercion (make_co co)
+make_co (TransCo c1 c2) = C.TransCoercion (make_co c1) (make_co c2)
+make_co (NthCo d co) = C.NthCoercion d (make_co co)
+make_co (InstCo co ty) = C.InstCoercion (make_co co) (make_ty ty)
+
+-- Used for both tycon app coercions and axiom instantiations.
+make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty
+make_conAppCo con cos =
+ foldl C.Tapp (C.Tcon con)
+ (map make_co cos)
+
-------
isALocal :: Name -> CoreM Bool
isALocal vName = do
projects / ghc-hetmet.git / blobdiff