summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/coreSyn/ExternalCore.lhs118
-rw-r--r--compiler/coreSyn/MkExternalCore.lhs360
-rw-r--r--compiler/coreSyn/PprExternalCore.lhs260
-rw-r--r--compiler/ghc.cabal.in6
-rw-r--r--compiler/hsSyn/HsSyn.lhs12
-rw-r--r--compiler/iface/TcIface.lhs35
-rw-r--r--compiler/main/DriverPhases.hs16
-rw-r--r--compiler/main/DriverPipeline.hs26
-rw-r--r--compiler/main/DynFlags.hs3
-rw-r--r--compiler/main/GHC.hs40
-rw-r--r--compiler/main/Hooks.lhs2
-rw-r--r--compiler/main/HscMain.hs36
-rw-r--r--compiler/parser/LexCore.hs115
-rw-r--r--compiler/parser/ParserCore.y397
-rw-r--r--compiler/parser/ParserCoreUtils.hs77
-rw-r--r--compiler/typecheck/TcRnDriver.lhs129
-rw-r--r--compiler/typecheck/TcRnMonad.lhs11
17 files changed, 31 insertions, 1612 deletions
diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs
deleted file mode 100644
index ecc24b1155..0000000000
--- a/compiler/coreSyn/ExternalCore.lhs
+++ /dev/null
@@ -1,118 +0,0 @@
-%
-% (c) The University of Glasgow 2001-2006
-%
-\begin{code}
-module ExternalCore where
-
-import Data.Word
-
-data Module
- = Module Mname [Tdef] [Vdefg]
-
-data Tdef
- = Data (Qual Tcon) [Tbind] [Cdef]
- | Newtype (Qual Tcon) (Qual Tcon) [Tbind] Ty
-
-data Cdef
- = Constr (Qual Dcon) [Tbind] [Ty]
- | GadtConstr (Qual Dcon) Ty
-
-data Vdefg
- = Rec [Vdef]
- | Nonrec Vdef
-
--- Top-level bindings are qualified, so that the printer doesn't have to pass
--- around the module name.
-type Vdef = (Bool,Qual Var,Ty,Exp)
-
-data Exp
- = Var (Qual Var)
- | Dcon (Qual Dcon)
- | Lit Lit
- | App Exp Exp
- | Appt Exp Ty
- | Lam Bind Exp
- | Let Vdefg Exp
- | Case Exp Vbind Ty [Alt] {- non-empty list -}
- | Cast Exp Coercion
- | Tick String Exp {- XXX probably wrong -}
- | External String String Ty {- target name, convention, and type -}
- | DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -}
- | Label String
-
-data Bind
- = Vb Vbind
- | Tb Tbind
-
-data Alt
- = Acon (Qual Dcon) [Tbind] [Vbind] Exp
- | Alit Lit Exp
- | Adefault Exp
-
-type Vbind = (Var,Ty)
-type Tbind = (Tvar,Kind)
-
-data Ty
- = Tvar Tvar
- | Tcon (Qual Tcon)
- | Tapp Ty Ty
- | Tforall Tbind Ty
-
-data Coercion
--- We distinguish primitive coercions because External Core treats
--- them specially, so we have to print them out with special syntax.
- = ReflCoercion Role Ty
- | SymCoercion Coercion
- | TransCoercion Coercion Coercion
- | TyConAppCoercion Role (Qual Tcon) [Coercion]
- | AppCoercion Coercion Coercion
- | ForAllCoercion Tbind Coercion
- | CoVarCoercion Var
- | UnivCoercion Role Ty Ty
- | InstCoercion Coercion Ty
- | NthCoercion Int Coercion
- | AxiomCoercion (Qual Tcon) Int [Coercion]
- | LRCoercion LeftOrRight Coercion
- | SubCoercion Coercion
-
-data Role = Nominal | Representational | Phantom
-
-data LeftOrRight = CLeft | CRight
-
-data Kind
- = Klifted
- | Kunlifted
- | Kunboxed
- | Kopen
- | Karrow Kind Kind
-
-data Lit
- = Lint Integer Ty
- | Lrational Rational Ty
- | Lchar Char Ty
- | Lstring [Word8] Ty
-
-
-type Mname = Id
-type Var = Id
-type Tvar = Id
-type Tcon = Id
-type Dcon = Id
-
-type Qual t = (Mname,t)
-
-type Id = String
-
-primMname :: Mname
--- For truly horrible reasons, this must be z-encoded.
--- With any hope, the z-encoding will die soon.
-primMname = "ghczmprim:GHCziPrim"
-
-tcArrow :: Qual Tcon
-tcArrow = (primMname, "(->)")
-
-\end{code}
-
-
-
-
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
deleted file mode 100644
index 6a6f0551ed..0000000000
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ /dev/null
@@ -1,360 +0,0 @@
-
-% (c) The University of Glasgow 2001-2006
-%
-\begin{code}
-module MkExternalCore (
- emitExternalCore
-) where
-
-#include "HsVersions.h"
-
-import qualified ExternalCore as C
-import Module
-import CoreSyn
-import HscTypes
-import TyCon
-import CoAxiom
--- import Class
-import TypeRep
-import Type
-import Kind
-import PprExternalCore () -- Instances
-import DataCon
-import Coercion
-import Var
-import IdInfo
-import Literal
-import Name
-import Outputable
-import Encoding
-import ForeignCall
-import DynFlags
-import FastString
-import Exception
-
-import Control.Applicative (Applicative(..))
-import Control.Monad
-import qualified Data.ByteString as BS
-import Data.Char
-import System.IO
-
-emitExternalCore :: DynFlags -> FilePath -> CgGuts -> IO ()
-emitExternalCore dflags extCore_filename cg_guts
- | gopt Opt_EmitExternalCore dflags
- = (do handle <- openFile extCore_filename WriteMode
- hPutStrLn handle (show (mkExternalCore dflags cg_guts))
- hClose handle)
- `catchIO` (\_ -> pprPanic "Failed to open or write external core output file"
- (text extCore_filename))
-emitExternalCore _ _ _
- | otherwise
- = return ()
-
--- Reinventing the Reader monad; whee.
-newtype CoreM a = CoreM (CoreState -> (CoreState, a))
-data CoreState = CoreState {
- cs_dflags :: DynFlags,
- cs_module :: Module
- }
-
-instance Functor CoreM where
- fmap = liftM
-
-instance Applicative CoreM where
- pure = return
- (<*>) = ap
-
-instance Monad CoreM where
- (CoreM m) >>= f = CoreM (\ s -> case m s of
- (s',r) -> case f r of
- CoreM f' -> f' s')
- return x = CoreM (\ s -> (s, x))
-runCoreM :: CoreM a -> CoreState -> a
-runCoreM (CoreM f) s = snd $ f s
-ask :: CoreM CoreState
-ask = CoreM (\ s -> (s,s))
-
-instance HasDynFlags CoreM where
- getDynFlags = liftM cs_dflags ask
-
-mkExternalCore :: DynFlags -> CgGuts -> C.Module
--- The ModGuts has been tidied, but the implicit bindings have
--- not been injected, so we have to add them manually here
--- We don't include the strange data-con *workers* because they are
--- implicit in the data type declaration itself
-mkExternalCore dflags (CgGuts {cg_module=this_mod, cg_tycons = tycons,
- cg_binds = binds})
-{- Note that modules can be mutually recursive, but even so, we
- print out dependency information within each module. -}
- = C.Module (mname dflags) tdefs (runCoreM (mapM (make_vdef True) binds) initialState)
- where
- initialState = CoreState {
- cs_dflags = dflags,
- cs_module = this_mod
- }
- mname dflags = make_mid dflags this_mod
- tdefs = foldr (collect_tdefs dflags) [] tycons
-
-collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef]
-collect_tdefs dflags tcon tdefs
- | isAlgTyCon tcon = tdef: tdefs
- where
- tdef | isNewTyCon tcon =
- C.Newtype (qtc dflags tcon)
- (qcc dflags (newTyConCo tcon))
- (map make_tbind tyvars)
- (make_ty dflags (snd (newTyConRhs tcon)))
- | otherwise =
- C.Data (qtc dflags tcon) (map make_tbind tyvars)
- (map (make_cdef dflags) (tyConDataCons tcon))
- tyvars = tyConTyVars tcon
-
-collect_tdefs _ _ tdefs = tdefs
-
-qtc :: DynFlags -> TyCon -> C.Qual C.Tcon
-qtc dflags = make_con_qid dflags . tyConName
-
-qcc :: DynFlags -> CoAxiom br -> C.Qual C.Tcon
-qcc dflags = make_con_qid dflags . co_ax_name
-
-make_cdef :: DynFlags -> DataCon -> C.Cdef
-make_cdef dflags dcon = C.Constr dcon_name existentials tys
- where
- dcon_name = make_qid dflags False False (dataConName dcon)
- existentials = map make_tbind ex_tyvars
- ex_tyvars = dataConExTyVars dcon
- tys = map (make_ty dflags) (dataConRepArgTys dcon)
-
-make_tbind :: TyVar -> C.Tbind
-make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
-
-make_vbind :: DynFlags -> Var -> C.Vbind
-make_vbind dflags v = (make_var_id (Var.varName v), make_ty dflags (varType v))
-
-make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg
-make_vdef topLevel b =
- case b of
- NonRec v e -> f (v,e) >>= (return . C.Nonrec)
- Rec ves -> mapM f ves >>= (return . C.Rec)
- where
- f :: (CoreBndr,CoreExpr) -> CoreM C.Vdef
- f (v,e) = do
- localN <- isALocal vName
- let local = not topLevel || localN
- rhs <- make_exp e
- -- use local flag to determine where to add the module name
- dflags <- getDynFlags
- return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs)
- where vName = Var.varName v
-
-make_exp :: CoreExpr -> CoreM C.Exp
-make_exp (Var v) = do
- let vName = Var.varName v
- isLocal <- isALocal vName
- dflags <- getDynFlags
- return $
- case idDetails v of
- FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _))
- -> C.External (unpackFS nm) (showPpr dflags callconv) (make_ty dflags (varType v))
- FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
- panic "make_exp: FFI values not supported"
- FCallId (CCall (CCallSpec DynamicTarget callconv _))
- -> C.DynExternal (showPpr dflags callconv) (make_ty dflags (varType v))
- -- Constructors are always exported, so make sure to declare them
- -- with qualified names
- DataConWorkId _ -> C.Var (make_var_qid dflags False vName)
- DataConWrapId _ -> C.Var (make_var_qid dflags False vName)
- _ -> C.Var (make_var_qid dflags isLocal vName)
-make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
-make_exp (Lit l) = do dflags <- getDynFlags
- return $ C.Lit (make_lit dflags l)
-make_exp (App e (Type t)) = do b <- make_exp e
- dflags <- getDynFlags
- return $ C.Appt b (make_ty dflags 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.App rator rand
-make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b ->
- return $ C.Lam (C.Tb (make_tbind v)) b)
-make_exp (Lam v e) | otherwise = do b <- make_exp e
- dflags <- getDynFlags
- return $ C.Lam (C.Vb (make_vbind dflags v)) b
-make_exp (Cast e co) = do b <- make_exp e
- dflags <- getDynFlags
- return $ C.Cast b (make_co dflags co)
-make_exp (Let b e) = do
- vd <- make_vdef False b
- body <- make_exp e
- return $ C.Let vd body
-make_exp (Case e v ty alts) = do
- scrut <- make_exp e
- newAlts <- mapM make_alt alts
- dflags <- getDynFlags
- return $ C.Case scrut (make_vbind dflags v) (make_ty dflags ty) newAlts
-make_exp (Tick _ e) = make_exp e >>= (return . C.Tick "SCC") -- temporary
-make_exp _ = error "MkExternalCore died: make_exp"
-
-make_alt :: CoreAlt -> CoreM C.Alt
-make_alt (DataAlt dcon, vs, e) = do
- newE <- make_exp e
- dflags <- getDynFlags
- return $ C.Acon (make_con_qid dflags (dataConName dcon))
- (map make_tbind tbs)
- (map (make_vbind dflags) vbs)
- newE
- where (tbs,vbs) = span isTyVar vs
-make_alt (LitAlt l,_,e) = do x <- make_exp e
- dflags <- getDynFlags
- return $ C.Alit (make_lit dflags l) x
-make_alt (DEFAULT,[],e) = make_exp e >>= (return . C.Adefault)
--- This should never happen, as the DEFAULT alternative binds no variables,
--- but we might as well check for it:
-make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
- ++ "alternative had a non-empty var list") (ppr a)
-
-
-make_lit :: DynFlags -> Literal -> C.Lit
-make_lit dflags l =
- case l of
- -- Note that we need to check whether the character is "big".
- -- External Core only allows character literals up to '\xff'.
- MachChar i | i <= chr 0xff -> C.Lchar i t
- -- For a character bigger than 0xff, we represent it in ext-core
- -- as an int lit with a char type.
- MachChar i -> C.Lint (fromIntegral $ ord i) t
- MachStr s -> C.Lstring (BS.unpack s) t
- MachNullAddr -> C.Lint 0 t
- MachInt i -> C.Lint i t
- MachInt64 i -> C.Lint i t
- MachWord i -> C.Lint i t
- MachWord64 i -> C.Lint i t
- MachFloat r -> C.Lrational r t
- MachDouble r -> C.Lrational r t
- LitInteger i _ -> C.Lint i t
- _ -> pprPanic "MkExternalCore died: make_lit" (ppr l)
- where
- t = make_ty dflags (literalType l)
-
--- Expand type synonyms, then convert.
-make_ty :: DynFlags -> Type -> C.Ty -- Be sure to expand types recursively!
- -- example: FilePath ~> String ~> [Char]
-make_ty dflags t | Just expanded <- tcView t = make_ty dflags expanded
-make_ty dflags t = make_ty' dflags t
-
--- note calls to make_ty so as to expand types recursively
-make_ty' :: DynFlags -> Type -> C.Ty
-make_ty' _ (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
-make_ty' dflags (AppTy t1 t2) = C.Tapp (make_ty dflags t1) (make_ty dflags t2)
-make_ty' dflags (FunTy t1 t2) = make_ty dflags (TyConApp funTyCon [t1,t2])
-make_ty' dflags (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty dflags t)
-make_ty' dflags (TyConApp tc ts) = make_tyConApp dflags tc ts
-make_ty' _ (LitTy {}) = panic "MkExernalCore can't do literal types yet"
-
--- Newtypes are treated just like any other type constructor; not expanded
--- Reason: predTypeRep does substitution and, while substitution deals
--- correctly with name capture, it's only correct if you see the uniques!
--- If you just see occurrence names, name capture may occur.
--- Example: newtype A a = A (forall b. b -> a)
--- test :: forall q b. q -> A b
--- test _ = undefined
--- Here the 'a' gets substituted by 'b', which is captured.
--- Another solution would be to expand newtypes before tidying; but that would
--- expose the representation in interface files, which definitely isn't right.
--- Maybe CoreTidy should know whether to expand newtypes or not?
-
-make_tyConApp :: DynFlags -> TyCon -> [Type] -> C.Ty
-make_tyConApp dflags tc ts =
- foldl C.Tapp (C.Tcon (qtc dflags tc))
- (map (make_ty dflags) ts)
-
-make_kind :: Kind -> C.Kind
-make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
-make_kind k
- | isLiftedTypeKind k = C.Klifted
- | isUnliftedTypeKind k = C.Kunlifted
- | isOpenTypeKind k = C.Kopen
-make_kind _ = error "MkExternalCore died: make_kind"
-
-{- Id generation. -}
-
-make_id :: Bool -> Name -> C.Id
--- include uniques for internal names in order to avoid name shadowing
-make_id _is_var nm = ((occNameString . nameOccName) nm)
- ++ (if isInternalName nm then (show . nameUnique) nm else "")
-
-make_var_id :: Name -> C.Id
-make_var_id = make_id True
-
--- It's important to encode the module name here, because in External Core,
--- base:GHC.Base => base:GHCziBase
--- We don't do this in pprExternalCore because we
--- *do* want to keep the package name (we don't want baseZCGHCziBase,
--- because that would just be ugly.)
--- SIGH.
--- We encode the package name as well.
-make_mid :: DynFlags -> Module -> C.Id
--- Super ugly code, but I can't find anything else that does quite what I
--- want (encodes the hierarchical module name without encoding the colon
--- that separates the package name from it.)
-make_mid dflags m
- = showSDoc dflags $
- (text $ zEncodeString $ packageIdString $ modulePackageId m)
- <> text ":"
- <> (pprEncoded $ pprModuleName $ moduleName m)
- where pprEncoded = pprCode CStyle
-
-make_qid :: DynFlags -> Bool -> Bool -> Name -> C.Qual C.Id
-make_qid dflags force_unqual is_var n = (mname,make_id is_var n)
- where mname =
- case nameModule_maybe n of
- Just m | not force_unqual -> make_mid dflags m
- _ -> ""
-
-make_var_qid :: DynFlags -> Bool -> Name -> C.Qual C.Id
-make_var_qid dflags force_unqual = make_qid dflags force_unqual True
-
-make_con_qid :: DynFlags -> Name -> C.Qual C.Id
-make_con_qid dflags = make_qid dflags False False
-
-make_co :: DynFlags -> Coercion -> C.Coercion
-make_co dflags (Refl r ty) = C.ReflCoercion (make_role r) $ make_ty dflags ty
-make_co dflags (TyConAppCo r tc cos) = C.TyConAppCoercion (make_role r) (qtc dflags tc) (map (make_co dflags) cos)
-make_co dflags (AppCo c1 c2) = C.AppCoercion (make_co dflags c1) (make_co dflags c2)
-make_co dflags (ForAllCo tv co) = C.ForAllCoercion (make_tbind tv) (make_co dflags co)
-make_co _ (CoVarCo cv) = C.CoVarCoercion (make_var_id (coVarName cv))
-make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos)
-make_co dflags (UnivCo r t1 t2) = C.UnivCoercion (make_role r) (make_ty dflags t1) (make_ty dflags t2)
-make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co)
-make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
-make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co)
-make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co)
-make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty)
-make_co dflags (SubCo co) = C.SubCoercion (make_co dflags co)
-make_co _ (AxiomRuleCo {}) = panic "make_co AxiomRuleCo: not yet implemented"
-
-
-make_lr :: LeftOrRight -> C.LeftOrRight
-make_lr CLeft = C.CLeft
-make_lr CRight = C.CRight
-
-make_role :: Role -> C.Role
-make_role Nominal = C.Nominal
-make_role Representational = C.Representational
-make_role Phantom = C.Phantom
-
--------
-isALocal :: Name -> CoreM Bool
-isALocal vName = do
- modName <- liftM cs_module ask
- return $ case nameModule_maybe vName of
- -- Not sure whether isInternalName corresponds to "local"ness
- -- in the External Core sense; need to re-read the spec.
- Just m | m == modName -> isInternalName vName
- _ -> False
-\end{code}
-
-
-
-
diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs
deleted file mode 100644
index 7fd3ac1d65..0000000000
--- a/compiler/coreSyn/PprExternalCore.lhs
+++ /dev/null
@@ -1,260 +0,0 @@
-%
-% (c) The University of Glasgow 2001-2006
-%
-
-\begin{code}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module PprExternalCore () where
-
-import Encoding
-import ExternalCore
-
-import Pretty
-import Data.Char
-import Data.Ratio
-
-instance Show Module where
- showsPrec _ m = shows (pmodule m)
-
-instance Show Tdef where
- showsPrec _ t = shows (ptdef t)
-
-instance Show Cdef where
- showsPrec _ c = shows (pcdef c)
-
-instance Show Vdefg where
- showsPrec _ v = shows (pvdefg v)
-
-instance Show Exp where
- showsPrec _ e = shows (pexp e)
-
-instance Show Alt where
- showsPrec _ a = shows (palt a)
-
-instance Show Ty where
- showsPrec _ t = shows (pty t)
-
-instance Show Kind where
- showsPrec _ k = shows (pkind k)
-
-instance Show Lit where
- showsPrec _ l = shows (plit l)
-
-
-indent :: Doc -> Doc
-indent = nest 2
-
-pmodule :: Module -> Doc
-pmodule (Module mname tdefs vdefgs) =
- (text "%module" <+> text mname)
- $$ indent ((vcat (map ((<> char ';') . ptdef) tdefs))
- $$ (vcat (map ((<> char ';') . pvdefg) vdefgs)))
-
-ptdef :: Tdef -> Doc
-ptdef (Data tcon tbinds cdefs) =
- (text "%data" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> char '=')
- $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs)))))
-
-ptdef (Newtype tcon coercion tbinds rep) =
- text "%newtype" <+> pqname tcon <+> pqname coercion
- <+> (hsep (map ptbind tbinds)) $$ indent repclause
- where repclause = char '=' <+> pty rep
-
-pcdef :: Cdef -> Doc
-pcdef (Constr dcon tbinds tys) =
- (pqname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
-pcdef (GadtConstr dcon ty) =
- (pqname dcon) <+> text "::" <+> pty ty
-
-pname :: Id -> Doc
-pname id = text (zEncodeString id)
-
-pqname :: Qual Id -> Doc
-pqname ("",id) = pname id
-pqname (m,id) = text m <> char '.' <> pname id
-
-ptbind, pattbind :: Tbind -> Doc
-ptbind (t,Klifted) = pname t
-ptbind (t,k) = parens (pname t <> text "::" <> pkind k)
-
-pattbind (t,k) = char '@' <> ptbind (t,k)
-
-pakind, pkind :: Kind -> Doc
-pakind (Klifted) = char '*'
-pakind (Kunlifted) = char '#'
-pakind (Kopen) = char '?'
-pakind k = parens (pkind k)
-
-pkind (Karrow k1 k2) = parens (pakind k1 <> text "->" <> pkind k2)
-pkind k = pakind k
-
-paty, pbty, pty :: Ty -> Doc
--- paty: print in parens, if non-atomic (like a name)
--- pbty: print in parens, if arrow (used only for lhs of arrow)
--- pty: not in parens
-paty (Tvar n) = pname n
-paty (Tcon c) = pqname c
-paty t = parens (pty t)
-
-pbty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [pbty t1, text "->",pty t2])
-pbty t = paty t
-
-pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2]
-pty (Tforall tb t) = text "%forall" <+> pforall [tb] t
-pty ty@(Tapp {}) = pappty ty []
-pty ty@(Tvar {}) = paty ty
-pty ty@(Tcon {}) = paty ty
-
-pappty :: Ty -> [Ty] -> Doc
-pappty (Tapp t1 t2) ts = pappty t1 (t2:ts)
-pappty t ts = sep (map paty (t:ts))
-
-pforall :: [Tbind] -> Ty -> Doc
-pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t
-pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t
-
-paco, pbco, pco :: Coercion -> Doc
-paco (ReflCoercion r ty) = char '<' <> pty ty <> text ">_" <> prole r
-paco (TyConAppCoercion r qtc []) = pqname qtc <> char '_' <> prole r
-paco (AxiomCoercion qtc i []) = pqname qtc <> char '[' <> int i <> char ']'
-paco (CoVarCoercion cv) = pname cv
-paco c = parens (pco c)
-
-pbco (TyConAppCoercion _ arr [co1, co2])
- | arr == tcArrow
- = parens (fsep [pbco co1, text "->", pco co2])
-pbco co = paco co
-
-pco c@(ReflCoercion {}) = paco c
-pco (SymCoercion co) = sep [text "%sub", paco co]
-pco (TransCoercion co1 co2) = sep [text "%trans", paco co1, paco co2]
-pco (TyConAppCoercion _ arr [co1, co2])
- | arr == tcArrow = fsep [pbco co1, text "->", pco co2]
-pco (TyConAppCoercion r qtc cos) = parens (pqname qtc <+> sep (map paco cos)) <> char '_' <> prole r
-pco co@(AppCoercion {}) = pappco co []
-pco (ForAllCoercion tb co) = text "%forall" <+> pforallco [tb] co
-pco co@(CoVarCoercion {}) = paco co
-pco (UnivCoercion r ty1 ty2) = sep [text "%univ", prole r, paty ty1, paty ty2]
-pco (InstCoercion co ty) = sep [text "%inst", paco co, paty ty]
-pco (NthCoercion i co) = sep [text "%nth", int i, paco co]
-pco (AxiomCoercion qtc i cos) = pqname qtc <> char '[' <> int i <> char ']' <+> sep (map paco cos)
-pco (LRCoercion CLeft co) = sep [text "%left", paco co]
-pco (LRCoercion CRight co) = sep [text "%right", paco co]
-pco (SubCoercion co) = sep [text "%sub", paco co]
-
-pappco :: Coercion -> [Coercion ] -> Doc
-pappco (AppCoercion co1 co2) cos = pappco co1 (co2:cos)
-pappco co cos = sep (map paco (co:cos))
-
-pforallco :: [Tbind] -> Coercion -> Doc
-pforallco tbs (ForAllCoercion tb co) = pforallco (tbs ++ [tb]) co
-pforallco tbs co = hsep (map ptbind tbs) <+> char '.' <+> pco co
-
-prole :: Role -> Doc
-prole Nominal = char 'N'
-prole Representational = char 'R'
-prole Phantom = char 'P'
-
-pvdefg :: Vdefg -> Doc
-pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs))))
-pvdefg (Nonrec vdef) = pvdef vdef
-
-pvdef :: Vdef -> Doc
--- TODO: Think about whether %local annotations are actually needed.
--- Right now, the local flag is never used, because the Core doc doesn't
--- explain the meaning of %local.
-pvdef (_l,v,t,e) = sep [(pqname v <+> text "::" <+> pty t <+> char '='),
- indent (pexp e)]
-
-paexp, pfexp, pexp :: Exp -> Doc
-paexp (Var x) = pqname x
-paexp (Dcon x) = pqname x
-paexp (Lit l) = plit l
-paexp e = parens(pexp e)
-
-plamexp :: [Bind] -> Exp -> Doc
-plamexp bs (Lam b e) = plamexp (bs ++ [b]) e
-plamexp bs e = sep [sep (map pbind bs) <+> text "->",
- indent (pexp e)]
-
-pbind :: Bind -> Doc
-pbind (Tb tb) = char '@' <+> ptbind tb
-pbind (Vb vb) = pvbind vb
-
-pfexp (App e1 e2) = pappexp e1 [Left e2]
-pfexp (Appt e t) = pappexp e [Right t]
-pfexp e = paexp e
-
-pappexp :: Exp -> [Either Exp Ty] -> Doc
-pappexp (App e1 e2) as = pappexp e1 (Left e2:as)
-pappexp (Appt e t) as = pappexp e (Right t:as)
-pappexp e as = fsep (paexp e : map pa as)
- where pa (Left e) = paexp e
- pa (Right t) = char '@' <+> paty t
-
-pexp (Lam b e) = char '\\' <+> plamexp [b] e
-pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
-pexp (Case e vb ty alts) = sep [text "%case" <+> paty ty <+> paexp e,
- text "%of" <+> pvbind vb]
- $$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
-pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paco co
-pexp (Tick s e) = (text "%source" <+> pstring s) $$ pexp e
-pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t
-pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t
-pexp (Label n) = (text "%label" <+> pstring n)
-pexp e = pfexp e
-
-pvbind :: Vbind -> Doc
-pvbind (x,t) = parens(pname x <> text "::" <> pty t)
-
-palt :: Alt -> Doc
-palt (Acon c tbs vbs e) =
- sep [pqname c,
- sep (map pattbind tbs),
- sep (map pvbind vbs) <+> text "->"]
- $$ indent (pexp e)
-palt (Alit l e) =
- (plit l <+> text "->")
- $$ indent (pexp e)
-palt (Adefault e) =
- (text "%_ ->")
- $$ indent (pexp e)
-
-plit :: Lit -> Doc
-plit (Lint i t) = parens (integer i <> text "::" <> pty t)
--- we use (text (show (numerator r))) (and the same for denominator)
--- because "(rational r)" was printing out things like "2.0e-2" (which
--- isn't External Core), and (text (show r)) was printing out things
--- like "((-1)/5)" which isn't either (it should be "(-1/5)").
-plit (Lrational r t) = parens (text (show (numerator r)) <+> char '%'
- <+> text (show (denominator r)) <> text "::" <> pty t)
-plit (Lchar c t) = parens (text ("\'" ++ escape [c] ++ "\'") <> text "::" <> pty t)
--- This is a little messy. We shouldn't really be going via String.
-plit (Lstring bs t) = parens (pstring str <> text "::" <> pty t)
- where str = map (chr . fromIntegral) bs
-
-pstring :: String -> Doc
-pstring s = doubleQuotes(text (escape s))
-
-escape :: String -> String
-escape s = foldr f [] (map ord s)
- where
- f cv rest
- | cv > 0xFF = '\\':'x':hs ++ rest
- | (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) =
- '\\':'x':h1:h0:rest
- where (q1,r1) = quotRem cv 16
- h1 = intToDigit q1
- h0 = intToDigit r1
- hs = dropWhile (=='0') $ reverse $ mkHex cv
- mkHex 0 = ""
- mkHex cv = intToDigit r : mkHex q
- where (q,r) = quotRem cv 16
- f cv rest = (chr cv):rest
-
-\end{code}
-
-
-
-
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index bf62ac3996..1b160aced7 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -232,11 +232,8 @@ Library
CoreTidy
CoreUnfold
CoreUtils
- ExternalCore
MkCore
- MkExternalCore
PprCore
- PprExternalCore
Check
Coverage
Desugar
@@ -303,12 +300,9 @@ Library
TidyPgm
Ctype
HaddockUtils
- LexCore
Lexer
OptCoercion
Parser
- ParserCore
- ParserCoreUtils
RdrHsSyn
ForeignCall
PrelInfo
diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs
index e9c3a5eeee..72cbac1487 100644
--- a/compiler/hsSyn/HsSyn.lhs
+++ b/compiler/hsSyn/HsSyn.lhs
@@ -23,7 +23,7 @@ module HsSyn (
module HsDoc,
Fixity,
- HsModule(..), HsExtCore(..),
+ HsModule(..)
) where
-- friends:
@@ -40,10 +40,9 @@ import HsDoc
-- others:
import OccName ( HasOccName )
-import IfaceSyn ( IfaceBinding )
import Outputable
import SrcLoc
-import Module ( Module, ModuleName )
+import Module ( ModuleName )
import FastString
-- libraries:
@@ -77,13 +76,6 @@ data HsModule name
hsmodHaddockModHeader :: Maybe LHsDocString
-- ^ Haddock module info and description, unparsed
} deriving (Data, Typeable)
-
-data HsExtCore name -- Read from Foo.hcr
- = HsExtCore
- Module
- [TyClDecl name] -- Type declarations only; just as in Haskell source,
- -- so that we can infer kinds etc
- [IfaceBinding] -- And the bindings
\end{code}
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index cc45648ea2..01a2114b74 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -12,8 +12,7 @@ module TcIface (
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceVectInfo, tcIfaceAnnotations,
tcIfaceExpr, -- Desired by HERMIT (Trac #7683)
- tcIfaceGlobal,
- tcExtCoreBindings
+ tcIfaceGlobal
) where
#include "HsVersions.h"
@@ -1251,30 +1250,6 @@ tcIfaceDataAlt con inst_tys arg_strs rhs
\end{code}
-\begin{code}
-tcExtCoreBindings :: [IfaceBinding] -> IfL CoreProgram -- Used for external core
-tcExtCoreBindings [] = return []
-tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
-
-do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
-do_one (IfaceNonRec bndr rhs) thing_inside
- = do { rhs' <- tcIfaceExpr rhs
- ; bndr' <- newExtCoreBndr bndr
- ; extendIfaceIdEnv [bndr'] $ do
- { core_binds <- thing_inside
- ; return (NonRec bndr' rhs' : core_binds) }}
-
-do_one (IfaceRec pairs) thing_inside
- = do { bndrs' <- mapM newExtCoreBndr bndrs
- ; extendIfaceIdEnv bndrs' $ do
- { rhss' <- mapM tcIfaceExpr rhss
- ; core_binds <- thing_inside
- ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
- where
- (bndrs,rhss) = unzip pairs
-\end{code}
-
-
%************************************************************************
%* *
IdInfo
@@ -1519,14 +1494,6 @@ bindIfaceBndrs (b:bs) thing_inside
thing_inside (b':bs')
-----------------------
-newExtCoreBndr :: IfaceLetBndr -> IfL Id
-newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now
- = do { mod <- getIfModule
- ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan
- ; ty' <- tcIfaceType ty
- ; return (mkLocalId name ty') }
-
------------------------
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
= do { name <- newIfaceName (mkTyVarOccFS occ)
diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index 2981269d54..8c69d4ece4 100644
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -18,7 +18,6 @@ module DriverPhases (
isHaskellSrcSuffix,
isObjectSuffix,
isCishSuffix,
- isExtCoreSuffix,
isDynLibSuffix,
isHaskellUserSrcSuffix,
isSourceSuffix,
@@ -27,7 +26,6 @@ module DriverPhases (
isHaskellSrcFilename,
isObjectFilename,
isCishFilename,
- isExtCoreFilename,
isDynLibFilename,
isHaskellUserSrcFilename,
isSourceFilename
@@ -56,7 +54,7 @@ import System.FilePath
-}
data HscSource
- = HsSrcFile | HsBootFile | ExtCoreFile
+ = HsSrcFile | HsBootFile
deriving( Eq, Ord, Show )
-- Ord needed for the finite maps we build in CompManager
@@ -64,7 +62,6 @@ data HscSource
hscSourceString :: HscSource -> String
hscSourceString HsSrcFile = ""
hscSourceString HsBootFile = "[boot]"
-hscSourceString ExtCoreFile = "[ext core]"
isHsBoot :: HscSource -> Bool
isHsBoot HsBootFile = True
@@ -175,7 +172,6 @@ startPhase "hs" = Cpp HsSrcFile
startPhase "hs-boot" = Cpp HsBootFile
startPhase "hscpp" = HsPp HsSrcFile
startPhase "hspp" = Hsc HsSrcFile
-startPhase "hcr" = Hsc ExtCoreFile
startPhase "hc" = HCc
startPhase "c" = Cc
startPhase "cpp" = Ccpp
@@ -202,7 +198,6 @@ startPhase _ = StopLn -- all unknown file types
phaseInputExt :: Phase -> String
phaseInputExt (Unlit HsSrcFile) = "lhs"
phaseInputExt (Unlit HsBootFile) = "lhs-boot"
-phaseInputExt (Unlit ExtCoreFile) = "lhcr"
phaseInputExt (Cpp _) = "lpp" -- intermediate only
phaseInputExt (HsPp _) = "hscpp" -- intermediate only
phaseInputExt (Hsc _) = "hspp" -- intermediate only
@@ -227,13 +222,12 @@ phaseInputExt MergeStub = "o"
phaseInputExt StopLn = "o"
haskellish_src_suffixes, haskellish_suffixes, cish_suffixes,
- extcoreish_suffixes, haskellish_user_src_suffixes
+ haskellish_user_src_suffixes
:: [String]
haskellish_src_suffixes = haskellish_user_src_suffixes ++
[ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ]
haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"]
cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ]
-extcoreish_suffixes = [ "hcr" ]
-- Will not be deleted as temp files:
haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ]
@@ -250,13 +244,12 @@ dynlib_suffixes platform = case platformOS platform of
OSDarwin -> ["dylib", "so"]
_ -> ["so"]
-isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix, isExtCoreSuffix,
+isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix,
isHaskellUserSrcSuffix
:: String -> Bool
isHaskellishSuffix s = s `elem` haskellish_suffixes
isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes
isCishSuffix s = s `elem` cish_suffixes
-isExtCoreSuffix s = s `elem` extcoreish_suffixes
isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes
isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool
@@ -267,13 +260,12 @@ isSourceSuffix :: String -> Bool
isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff
isHaskellishFilename, isHaskellSrcFilename, isCishFilename,
- isExtCoreFilename, isHaskellUserSrcFilename, isSourceFilename
+ isHaskellUserSrcFilename, isSourceFilename
:: FilePath -> Bool
-- takeExtension return .foo, so we drop 1 to get rid of the .
isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f)
isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f)
isCishFilename f = isCishSuffix (drop 1 $ takeExtension f)
-isExtCoreFilename f = isExtCoreSuffix (drop 1 $ takeExtension f)
isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f)
isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f)
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index b93cef1fba..762f4da422 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -54,7 +54,6 @@ import Util
import StringBuffer ( hGetStringBuffer )
import BasicTypes ( SuccessFlag(..) )
import Maybes ( expectJust )
-import ParserCoreUtils ( getCoreModuleName )
import SrcLoc
import FastString
import LlvmCodeGen ( llvmFixupAsm )
@@ -169,8 +168,6 @@ compileOne' m_tc_result mHscMessage
output_fn <- getOutputFilename next_phase
Temporary basename dflags next_phase (Just location)
- let extCore_filename = basename ++ ".hcr"
-
-- -fforce-recomp should also work with --make
let force_recomp = gopt Opt_ForceRecomp dflags
source_modified
@@ -207,7 +204,7 @@ compileOne' m_tc_result mHscMessage
hm_linkable = maybe_old_linkable })
_ -> do guts0 <- hscDesugar hsc_env summary tc_result
guts <- hscSimplify hsc_env guts0
- (iface, _changed, details, cgguts) <- hscNormalIface hsc_env extCore_filename guts mb_old_hash
+ (iface, _changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash
(hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary
stub_o <- case hasStub of
@@ -251,7 +248,7 @@ compileOne' m_tc_result mHscMessage
_ -> do guts0 <- hscDesugar hsc_env summary tc_result
guts <- hscSimplify hsc_env guts0
- (iface, changed, details, cgguts) <- hscNormalIface hsc_env extCore_filename guts mb_old_hash
+ (iface, changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash
hscWriteIface dflags iface changed summary
-- We're in --make mode: finish the compilation pipeline.
@@ -892,16 +889,11 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
setDynFlags dflags
-- gather the imports and module name
- (hspp_buf,mod_name,imps,src_imps) <- liftIO $
- case src_flavour of
- ExtCoreFile -> do -- no explicit imports in ExtCore input.
- m <- getCoreModuleName input_fn
- return (Nothing, mkModuleName m, [], [])
-
- _ -> do
- buf <- hGetStringBuffer input_fn
- (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
- return (Just buf, mod_name, imps, src_imps)
+ (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do
+ do
+ buf <- hGetStringBuffer input_fn
+ (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
+ return (Just buf, mod_name, imps, src_imps)
-- Take -o into account if present
-- Very like -ohi, but we must *only* do this if we aren't linking
@@ -936,8 +928,6 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
then return SourceUnmodified
else return SourceModified
- let extCore_filename = basename ++ ".hcr"
-
PipeState{hsc_env=hsc_env'} <- getPipeState
-- Tell the finder cache about this module
@@ -957,7 +947,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
ms_srcimps = src_imps }
-- run the compiler!
- result <- liftIO $ hscCompileOneShot hsc_env' extCore_filename
+ result <- liftIO $ hscCompileOneShot hsc_env'
mod_summary source_unchanged
return (HscOut src_flavour mod_name result,
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 72ebb38fc2..7d24785c63 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -2685,7 +2685,8 @@ fFlags = [
( "fun-to-thunk", Opt_FunToThunk, nop ),
( "gen-manifest", Opt_GenManifest, nop ),
( "embed-manifest", Opt_EmbedManifest, nop ),
- ( "ext-core", Opt_EmitExternalCore, nop ),
+ ( "ext-core", Opt_EmitExternalCore,
+ \_ -> deprecate "it has no effect, and will be removed in GHC 7.12" ),
( "shared-implib", Opt_SharedImplib, nop ),
( "ghci-sandbox", Opt_GhciSandbox, nop ),
( "ghci-history", Opt_GhciHistory, nop ),
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 7694bc9821..6576a501ab 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -53,7 +53,6 @@ module GHC (
-- ** Compiling to Core
CoreModule(..),
compileToCoreModule, compileToCoreSimplified,
- compileCoreToObj,
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
@@ -310,7 +309,7 @@ import FastString
import qualified Parser
import Lexer
-import System.Directory ( doesFileExist, getCurrentDirectory )
+import System.Directory ( doesFileExist )
import Data.Maybe
import Data.List ( find )
import Data.Time
@@ -925,43 +924,6 @@ compileToCoreModule = compileCore False
-- as to return simplified and tidied Core.
compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
compileToCoreSimplified = compileCore True
--- | Takes a CoreModule and compiles the bindings therein
--- to object code. The first argument is a bool flag indicating
--- whether to run the simplifier.
--- The resulting .o, .hi, and executable files, if any, are stored in the
--- current directory, and named according to the module name.
--- This has only so far been tested with a single self-contained module.
-compileCoreToObj :: GhcMonad m
- => Bool -> CoreModule -> FilePath -> FilePath -> m ()
-compileCoreToObj simplify cm@(CoreModule{ cm_module = mName })
- output_fn extCore_filename = do
- dflags <- getSessionDynFlags
- currentTime <- liftIO $ getCurrentTime
- cwd <- liftIO $ getCurrentDirectory
- modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
- ((moduleNameSlashes . moduleName) mName)
-
- let modSum = ModSummary { ms_mod = mName,
- ms_hsc_src = ExtCoreFile,
- ms_location = modLocation,
- -- By setting the object file timestamp to Nothing,
- -- we always force recompilation, which is what we
- -- want. (Thus it doesn't matter what the timestamp
- -- for the (nonexistent) source file is.)
- ms_hs_date = currentTime,
- ms_obj_date = Nothing,
- -- Only handling the single-module case for now, so no imports.
- ms_srcimps = [],
- ms_textual_imps = [],
- -- No source file
- ms_hspp_file = "",
- ms_hspp_opts = dflags,
- ms_hspp_buf = Nothing
- }
-
- hsc_env <- getSession
- liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) output_fn extCore_filename
-
compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
compileCore simplify fn = do
diff --git a/compiler/main/Hooks.lhs b/compiler/main/Hooks.lhs
index 3bd9643dc6..63aaafa2a7 100644
--- a/compiler/main/Hooks.lhs
+++ b/compiler/main/Hooks.lhs
@@ -63,7 +63,7 @@ data Hooks = Hooks
, tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt))
, tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt))
, hscFrontendHook :: Maybe (ModSummary -> Hsc TcGblEnv)
- , hscCompileOneShotHook :: Maybe (HscEnv -> FilePath -> ModSummary -> SourceModified -> IO HscStatus)
+ , hscCompileOneShotHook :: Maybe (HscEnv -> ModSummary -> SourceModified -> IO HscStatus)
, hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue)
, ghcPrimIfaceHook :: Maybe ModIface
, runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 748f7480ec..475b124dd3 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -146,7 +146,6 @@ import ErrUtils
import Outputable
import HscStats ( ppSourceStats )
import HscTypes
-import MkExternalCore ( emitExternalCore )
import FastString
import UniqFM ( emptyUFM )
import UniqSupply
@@ -580,31 +579,25 @@ genericHscFrontend mod_summary =
getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)
genericHscFrontend' :: ModSummary -> Hsc TcGblEnv
-genericHscFrontend' mod_summary
- | ExtCoreFile <- ms_hsc_src mod_summary =
- panic "GHC does not currently support reading External Core files"
- | otherwise =
- hscFileFrontEnd mod_summary
+genericHscFrontend' mod_summary = hscFileFrontEnd mod_summary
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------
hscCompileOneShot :: HscEnv
- -> FilePath
-> ModSummary
-> SourceModified
-> IO HscStatus
hscCompileOneShot env =
lookupHook hscCompileOneShotHook hscCompileOneShot' (hsc_dflags env) env
--- Compile Haskell, boot and extCore in OneShot mode.
+-- Compile Haskell/boot in OneShot mode.
hscCompileOneShot' :: HscEnv
- -> FilePath
-> ModSummary
-> SourceModified
-> IO HscStatus
-hscCompileOneShot' hsc_env extCore_filename mod_summary src_changed
+hscCompileOneShot' hsc_env mod_summary src_changed
= do
-- One-shot mode needs a knot-tying mutable variable for interface
-- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
@@ -633,7 +626,7 @@ hscCompileOneShot' hsc_env extCore_filename mod_summary src_changed
return HscUpdateBoot
_ ->
do guts <- hscSimplify' guts0
- (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts mb_old_hash
+ (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash
liftIO $ hscWriteIface dflags iface changed mod_summary
return $ HscRecomp cgguts mod_summary
@@ -1070,18 +1063,16 @@ hscSimpleIface' tc_result mb_old_iface = do
return (new_iface, no_change, details)
hscNormalIface :: HscEnv
- -> FilePath
-> ModGuts
-> Maybe Fingerprint
-> IO (ModIface, Bool, ModDetails, CgGuts)
-hscNormalIface hsc_env extCore_filename simpl_result mb_old_iface =
- runHsc hsc_env $ hscNormalIface' extCore_filename simpl_result mb_old_iface
+hscNormalIface hsc_env simpl_result mb_old_iface =
+ runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
-hscNormalIface' :: FilePath
- -> ModGuts
+hscNormalIface' :: ModGuts
-> Maybe Fingerprint
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
-hscNormalIface' extCore_filename simpl_result mb_old_iface = do
+hscNormalIface' simpl_result mb_old_iface = do
hsc_env <- getHscEnv
(cg_guts, details) <- {-# SCC "CoreTidy" #-}
liftIO $ tidyProgram hsc_env simpl_result
@@ -1096,11 +1087,6 @@ hscNormalIface' extCore_filename simpl_result mb_old_iface = do
ioMsgMaybe $
mkIface hsc_env mb_old_iface details simpl_result
- -- Emit external core
- -- This should definitely be here and not after CorePrep,
- -- because CorePrep produces unqualified constructor wrapper declarations,
- -- so its output isn't valid External Core (without some preprocessing).
- liftIO $ emitExternalCore (hsc_dflags hsc_env) extCore_filename cg_guts
liftIO $ dumpIfaceStats hsc_env
-- Return the prepared code.
@@ -1533,11 +1519,11 @@ hscParseThingWithLocation source linenumber parser str
return thing
hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary
- -> CoreProgram -> FilePath -> FilePath -> IO ()
-hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename extCore_filename
+ -> CoreProgram -> FilePath -> IO ()
+hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename
= runHsc hsc_env $ do
guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds)
- (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts Nothing
+ (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing
liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary
_ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary output_filename
return ()
diff --git a/compiler/parser/LexCore.hs b/compiler/parser/LexCore.hs
deleted file mode 100644
index 861fffb7f6..0000000000
--- a/compiler/parser/LexCore.hs
+++ /dev/null
@@ -1,115 +0,0 @@
-module LexCore where
-
-import ParserCoreUtils
-import Panic
-import Data.Char
-import Numeric
-
-isNameChar :: Char -> Bool
-isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'')
- || (c == '$') || (c == '-') || (c == '.')
-
-isKeywordChar :: Char -> Bool
-isKeywordChar c = isAlpha c || (c == '_')
-
-lexer :: (Token -> P a) -> P a
-lexer cont [] = cont TKEOF []
-lexer cont ('\n':cs) = \line -> lexer cont cs (line+1)
-lexer cont ('-':'>':cs) = cont TKrarrow cs
-
-lexer cont (c:cs)
- | isSpace c = lexer cont cs
- | isLower c || (c == '_') = lexName cont TKname (c:cs)
- | isUpper c = lexName cont TKcname (c:cs)
- | isDigit c || (c == '-') = lexNum cont (c:cs)
-
-lexer cont ('%':cs) = lexKeyword cont cs
-lexer cont ('\'':cs) = lexChar cont cs
-lexer cont ('\"':cs) = lexString [] cont cs
-lexer cont ('#':cs) = cont TKhash cs
-lexer cont ('(':cs) = cont TKoparen cs
-lexer cont (')':cs) = cont TKcparen cs
-lexer cont ('{':cs) = cont TKobrace cs
-lexer cont ('}':cs) = cont TKcbrace cs
-lexer cont ('=':cs) = cont TKeq cs
-lexer cont (':':'=':':':cs) = cont TKcoloneqcolon cs
-lexer cont (':':':':cs) = cont TKcoloncolon cs
-lexer cont ('*':cs) = cont TKstar cs
-lexer cont ('.':cs) = cont TKdot cs
-lexer cont ('\\':cs) = cont TKlambda cs
-lexer cont ('@':cs) = cont TKat cs
-lexer cont ('?':cs) = cont TKquestion cs
-lexer cont (';':cs) = cont TKsemicolon cs
--- 20060420 GHC spits out constructors with colon in them nowadays. jds
--- 20061103 but it's easier to parse if we split on the colon, and treat them
--- as several tokens
-lexer cont (':':cs) = cont TKcolon cs
--- 20060420 Likewise does it create identifiers starting with dollar. jds
-lexer cont ('$':cs) = lexName cont TKname ('$':cs)
-lexer _ (c:_) = failP "invalid character" [c]
-
-lexChar :: (Token -> String -> Int -> ParseResult a) -> String -> Int
- -> ParseResult a
-lexChar cont ('\\':'x':h1:h0:'\'':cs)
- | isHexEscape [h1,h0] = cont (TKchar (hexToChar h1 h0)) cs
-lexChar _ ('\\':cs) = failP "invalid char character" ('\\':(take 10 cs))
-lexChar _ ('\'':_) = failP "invalid char character" ['\'']
-lexChar _ ('\"':_) = failP "invalid char character" ['\"']
-lexChar cont (c:'\'':cs) = cont (TKchar c) cs
-lexChar _ cs = panic ("lexChar: " ++ show cs)
-
-lexString :: String -> (Token -> [Char] -> Int -> ParseResult a)
- -> String -> Int -> ParseResult a
-lexString s cont ('\\':'x':h1:h0:cs)
- | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs
-lexString _ _ ('\\':_) = failP "invalid string character" ['\\']
-lexString _ _ ('\'':_) = failP "invalid string character" ['\'']
-lexString s cont ('\"':cs) = cont (TKstring s) cs
-lexString s cont (c:cs) = lexString (s++[c]) cont cs
-lexString _ _ [] = panic "lexString []"
-
-isHexEscape :: String -> Bool
-isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c))
-
-hexToChar :: Char -> Char -> Char
-hexToChar h1 h0 = chr (digitToInt h1 * 16 + digitToInt h0)
-
-lexNum :: (Token -> String -> a) -> String -> a
-lexNum cont cs =
- case cs of
- ('-':cs) -> f (-1) cs
- _ -> f 1 cs
- where f sgn cs =
- case span isDigit cs of
- (digits,'.':c:rest)
- | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest'
- where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest))
- -- When reading a floating-point number, which is
- -- a bit complicated, use the standard library function
- -- "readFloat"
- (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest
-
-lexName :: (a -> String -> b) -> (String -> a) -> String -> b
-lexName cont cstr cs = cont (cstr name) rest
- where (name,rest) = span isNameChar cs
-
-lexKeyword :: (Token -> [Char] -> Int -> ParseResult a) -> String -> Int
- -> ParseResult a
-lexKeyword cont cs =
- case span isKeywordChar cs of
- ("module",rest) -> cont TKmodule rest
- ("data",rest) -> cont TKdata rest
- ("newtype",rest) -> cont TKnewtype rest
- ("forall",rest) -> cont TKforall rest
- ("rec",rest) -> cont TKrec rest
- ("let",rest) -> cont TKlet rest
- ("in",rest) -> cont TKin rest
- ("case",rest) -> cont TKcase rest
- ("of",rest) -> cont TKof rest
- ("cast",rest) -> cont TKcast rest
- ("note",rest) -> cont TKnote rest
- ("external",rest) -> cont TKexternal rest
- ("local",rest) -> cont TKlocal rest
- ("_",rest) -> cont TKwild rest
- _ -> failP "invalid keyword" ('%':cs)
-
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
deleted file mode 100644
index 4e7f48c6fc..0000000000
--- a/compiler/parser/ParserCore.y
+++ /dev/null
@@ -1,397 +0,0 @@
-{
-{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
-{-# OPTIONS -Wwarn -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-module ParserCore ( parseCore ) where
-
-import IfaceSyn
-import ForeignCall
-import RdrHsSyn
-import HsSyn hiding (toHsType, toHsKind)
-import RdrName
-import OccName
-import TypeRep ( TyThing(..) )
-import Type ( Kind,
- liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
- mkTyConApp
- )
-import Kind( mkArrowKind )
-import Name( Name, nameOccName, nameModule, mkExternalName, wiredInNameTyThing_maybe )
-import Module
-import ParserCoreUtils
-import LexCore
-import Literal
-import SrcLoc
-import PrelNames
-import TysPrim
-import TyCon ( TyCon, tyConName )
-import FastString
-import Outputable
-import Data.Char
-import Unique
-
-#include "../HsVersions.h"
-
-}
-
-%name parseCore
-%expect 0
-%tokentype { Token }
-
-%token
- '%module' { TKmodule }
- '%data' { TKdata }
- '%newtype' { TKnewtype }
- '%forall' { TKforall }
- '%rec' { TKrec }
- '%let' { TKlet }
- '%in' { TKin }
- '%case' { TKcase }
- '%of' { TKof }
- '%cast' { TKcast }
- '%note' { TKnote }
- '%external' { TKexternal }
- '%local' { TKlocal }
- '%_' { TKwild }
- '(' { TKoparen }
- ')' { TKcparen }
- '{' { TKobrace }
- '}' { TKcbrace }
- '#' { TKhash}
- '=' { TKeq }
- ':' { TKcolon }
- '::' { TKcoloncolon }
- ':=:' { TKcoloneqcolon }
- '*' { TKstar }
- '->' { TKrarrow }
- '\\' { TKlambda}
- '@' { TKat }
- '.' { TKdot }
- '?' { TKquestion}
- ';' { TKsemicolon }
- NAME { TKname $$ }
- CNAME { TKcname $$ }
- INTEGER { TKinteger $$ }
- RATIONAL { TKrational $$ }
- STRING { TKstring $$ }
- CHAR { TKchar $$ }
-
-%monad { P } { thenP } { returnP }
-%lexer { lexer } { TKEOF }
-
-%%
-
-module :: { HsExtCore RdrName }
- -- : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 }
- : '%module' modid tdefs vdefgs { HsExtCore $2 [] [] }
-
-
--------------------------------------------------------------
--- Names: the trickiest bit in here
-
--- A name of the form A.B.C could be:
--- module A.B.C
--- dcon C in module A.B
--- tcon C in module A.B
-modid :: { Module }
- : NAME ':' mparts { undefined }
-
-q_dc_name :: { Name }
- : NAME ':' mparts { undefined }
-
-q_tc_name :: { Name }
- : NAME ':' mparts { undefined }
-
-q_var_occ :: { Name }
- : NAME ':' vparts { undefined }
-
-mparts :: { [String] }
- : CNAME { [$1] }
- | CNAME '.' mparts { $1:$3 }
-
-vparts :: { [String] }
- : var_occ { [$1] }
- | CNAME '.' vparts { $1:$3 }
-
--------------------------------------------------------------
--- Type and newtype declarations are in HsSyn syntax
-
-tdefs :: { [TyClDecl RdrName] }
- : {- empty -} {[]}
- | tdef tdefs {$1:$2}
-
-tdef :: { TyClDecl RdrName }
- : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
- { DataDecl { tcdLName = noLoc (ifaceExtRdrName $2)
- , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
- , tcdDataDefn = HsDataDefn { dd_ND = DataType, dd_ctxt = noLoc []
- , dd_kindSig = Nothing
- , dd_cons = $6, dd_derivs = Nothing } } }
- | '%newtype' q_tc_name tv_bndrs trep ';'
- { let tc_rdr = ifaceExtRdrName $2 in
- DataDecl { tcdLName = noLoc tc_rdr
- , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
- , tcdDataDefn = HsDataDefn { dd_ND = NewType, dd_ctxt = noLoc []
- , dd_kindSig = Nothing
- , dd_cons = $4 (rdrNameOcc tc_rdr), dd_derivs = Nothing } } }
-
--- For a newtype we have to invent a fake data constructor name
--- It doesn't matter what it is, because it won't be used
-trep :: { OccName -> [LConDecl RdrName] }
- : {- empty -} { (\ tc_occ -> []) }
- | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
- con_info = PrefixCon [toHsType $2] }
- in [noLoc $ mkSimpleConDecl (noLoc dc_name) []
- (noLoc []) con_info]) }
-
-cons :: { [LConDecl RdrName] }
- : {- empty -} { [] } -- 20060420 Empty data types allowed. jds
- | con { [$1] }
- | con ';' cons { $1:$3 }
-
-con :: { LConDecl RdrName }
- : d_pat_occ attv_bndrs hs_atys
- { noLoc $ mkSimpleConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3) }
--- ToDo: parse record-style declarations
-
-attv_bndrs :: { [LHsTyVarBndr RdrName] }
- : {- empty -} { [] }
- | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 }
-
-hs_atys :: { [LHsType RdrName] }
- : atys { map toHsType $1 }
-
-
----------------------------------------
--- Types
----------------------------------------
-
-atys :: { [IfaceType] }
- : {- empty -} { [] }
- | aty atys { $1:$2 }
-
-aty :: { IfaceType }
- : fs_var_occ { IfaceTyVar $1 }
- | q_tc_name { IfaceTyConApp (IfaceTc $1) [] }
- | '(' ty ')' { $2 }
-
-bty :: { IfaceType }
- : fs_var_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 }
- | q_var_occ atys { undefined }
- | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 }
- | '(' ty ')' { $2 }
-
-ty :: { IfaceType }
- : bty { $1 }
- | bty '->' ty { IfaceFunTy $1 $3 }
- | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 }
-
-----------------------------------------------
--- Bindings are in Iface syntax
-
-vdefgs :: { [IfaceBinding] }
- : {- empty -} { [] }
- | let_bind ';' vdefgs { $1 : $3 }
-
-let_bind :: { IfaceBinding }
- : '%rec' '{' vdefs1 '}' { IfaceRec $3 } -- Can be empty. Do we care?
- | vdef { let (b,r) = $1
- in IfaceNonRec b r }
-
-vdefs1 :: { [(IfaceLetBndr, IfaceExpr)] }
- : vdef { [$1] }
- | vdef ';' vdefs1 { $1:$3 }
-
-vdef :: { (IfaceLetBndr, IfaceExpr) }
- : fs_var_occ '::' ty '=' exp { (IfLetBndr $1 $3 NoInfo, $5) }
- | '%local' vdef { $2 }
-
- -- NB: qd_occ includes data constructors, because
- -- we allow data-constructor wrappers at top level
- -- But we discard the module name, because it must be the
- -- same as the module being compiled, and Iface syntax only
- -- has OccNames in binding positions. Ah, but it has Names now!
-
----------------------------------------
--- Binders
-bndr :: { IfaceBndr }
- : '@' tv_bndr { IfaceTvBndr $2 }
- | id_bndr { IfaceIdBndr $1 }
-
-bndrs :: { [IfaceBndr] }
- : bndr { [$1] }
- | bndr bndrs { $1:$2 }
-
-id_bndr :: { IfaceIdBndr }
- : '(' fs_var_occ '::' ty ')' { ($2,$4) }
-
-tv_bndr :: { IfaceTvBndr }
- : fs_var_occ { ($1, ifaceLiftedTypeKind) }
- | '(' fs_var_occ '::' akind ')' { ($2, $4) }
-
-tv_bndrs :: { [IfaceTvBndr] }
- : {- empty -} { [] }
- | tv_bndr tv_bndrs { $1:$2 }
-
-akind :: { IfaceKind }
- : '*' { ifaceLiftedTypeKind }
- | '#' { ifaceUnliftedTypeKind }
- | '?' { ifaceOpenTypeKind }
- | '(' kind ')' { $2 }
-
-kind :: { IfaceKind }
- : akind { $1 }
- | akind '->' kind { ifaceArrow $1 $3 }
-
------------------------------------------
--- Expressions
-
-aexp :: { IfaceExpr }
- : fs_var_occ { IfaceLcl $1 }
- | q_var_occ { IfaceExt $1 }
- | q_dc_name { IfaceExt $1 }
- | lit { IfaceLit $1 }
- | '(' exp ')' { $2 }
-
-fexp :: { IfaceExpr }
- : fexp aexp { IfaceApp $1 $2 }
- | fexp '@' aty { IfaceApp $1 (IfaceType $3) }
- | aexp { $1 }
-
-exp :: { IfaceExpr }
- : fexp { $1 }
- | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 }
- | '%let' let_bind '%in' exp { IfaceLet $2 $4 }
--- gaw 2004
- | '%case' '(' ty ')' aexp '%of' id_bndr
- '{' alts1 '}' { IfaceCase $5 (fst $7) $9 }
--- The following line is broken and is hard to fix. Not fixing now
--- because this whole parser is bitrotten anyway.
--- Richard Eisenberg, July 2013
--- | '%cast' aexp aty { IfaceCast $2 $3 }
--- No InlineMe any more
--- | '%note' STRING exp
--- { case $2 of
--- --"SCC" -> IfaceNote (IfaceSCC "scc") $3
--- "InlineMe" -> IfaceNote IfaceInlineMe $3
--- }
- | '%external' STRING aty { IfaceFCall (ForeignCall.CCall
- (CCallSpec (StaticTarget (mkFastString $2) Nothing True)
- CCallConv PlaySafe))
- $3 }
-
-alts1 :: { [IfaceAlt] }
- : alt { [$1] }
- | alt ';' alts1 { $1:$3 }
-
-alt :: { IfaceAlt }
- : q_dc_name bndrs '->' exp
- { (IfaceDataAlt $1, map ifaceBndrName $2, $4) }
- -- The external syntax currently includes the types of the
- -- the args, but they aren't needed internally
- -- Nor is the module qualifier
- | q_dc_name '->' exp
- { (IfaceDataAlt $1, [], $3) }
- | lit '->' exp
- { (IfaceLitAlt $1, [], $3) }
- | '%_' '->' exp
- { (IfaceDefault, [], $3) }
-
-lit :: { Literal }
- : '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
- | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
- | '(' CHAR '::' aty ')' { MachChar $2 }
- | '(' STRING '::' aty ')' { MachStr (fastStringToByteString (mkFastString $2)) }
-
-fs_var_occ :: { FastString }
- : NAME { mkFastString $1 }
-
-var_occ :: { String }
- : NAME { $1 }
-
-
--- Data constructor in a pattern or data type declaration; use the dataName,
--- because that's what we expect in Core case patterns
-d_pat_occ :: { OccName }
- : CNAME { mkOccName dataName $1 }
-
-{
-
-ifaceKind kc = IfaceTyConApp kc []
-
-ifaceBndrName (IfaceIdBndr (n,_)) = n
-ifaceBndrName (IfaceTvBndr (n,_)) = n
-
-convIntLit :: Integer -> IfaceType -> Literal
-convIntLit i (IfaceTyConApp tc [])
- | tc `eqTc` intPrimTyCon = MachInt i
- | tc `eqTc` wordPrimTyCon = MachWord i
- | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i))
- | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr
-convIntLit i aty
- = pprPanic "Unknown integer literal type" (ppr aty)
-
-convRatLit :: Rational -> IfaceType -> Literal
-convRatLit r (IfaceTyConApp tc [])
- | tc `eqTc` floatPrimTyCon = MachFloat r
- | tc `eqTc` doublePrimTyCon = MachDouble r
-convRatLit i aty
- = pprPanic "Unknown rational literal type" (ppr aty)
-
-eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh!
-eqTc (IfaceTc name) tycon = name == tyConName tycon
-
--- Tiresomely, we have to generate both HsTypes (in type/class decls)
--- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes,
--- and convert to HsTypes here. But the IfaceTypes we can see here
--- are very limited (see the productions for 'ty'), so the translation
--- isn't hard
-toHsType :: IfaceType -> LHsType RdrName
-toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS v))
-toHsType (IfaceAppTy t1 t2) = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
-toHsType (IfaceFunTy t1 t2) = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
-toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts)
-toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t)
-
--- Only a limited form of kind will be encountered... hopefully
-toHsKind :: IfaceKind -> LHsKind RdrName
--- IA0_NOTE: Shouldn't we add kind variables?
-toHsKind (IfaceFunTy ifK1 ifK2) = noLoc $ HsFunTy (toHsKind ifK1) (toHsKind ifK2)
-toHsKind (IfaceTyConApp ifKc []) = noLoc $ HsTyVar (nameRdrName (tyConName (toKindTc ifKc)))
-toHsKind other = pprPanic "toHsKind" (ppr other)
-
-toKindTc :: IfaceTyCon -> TyCon
-toKindTc (IfaceTc n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n = tc
-toKindTc other = pprPanic "toKindTc" (ppr other)
-
-ifaceTcType ifTc = IfaceTyConApp ifTc []
-
-ifaceLiftedTypeKind = ifaceTcType (IfaceTc liftedTypeKindTyConName)
-ifaceOpenTypeKind = ifaceTcType (IfaceTc openTypeKindTyConName)
-ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
-
-ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
-
-toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
- where
- bsig = toHsKind k
-
-ifaceExtRdrName :: Name -> RdrName
-ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
-ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
-
-add_forall tv (L _ (HsForAllTy exp tvs cxt t))
- = noLoc $ HsForAllTy exp (mkHsQTvs (tv : hsQTvBndrs tvs)) cxt t
-add_forall tv t
- = noLoc $ HsForAllTy Explicit (mkHsQTvs [tv]) (noLoc []) t
-
-happyError :: P a
-happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
-}
-
diff --git a/compiler/parser/ParserCoreUtils.hs b/compiler/parser/ParserCoreUtils.hs
deleted file mode 100644
index 8f67d96239..0000000000
--- a/compiler/parser/ParserCoreUtils.hs
+++ /dev/null
@@ -1,77 +0,0 @@
-module ParserCoreUtils where
-
-import Exception
-import System.IO
-
-data ParseResult a = OkP a | FailP String
-type P a = String -> Int -> ParseResult a
-
-thenP :: P a -> (a -> P b) -> P b
-m `thenP` k = \ s l ->
- case m s l of
- OkP a -> k a s l
- FailP s -> FailP s
-
-returnP :: a -> P a
-returnP m _ _ = OkP m
-
-failP :: String -> P a
-failP s s' _ = FailP (s ++ ":" ++ s')
-
-getCoreModuleName :: FilePath -> IO String
-getCoreModuleName fpath =
- catchIO (do
- h <- openFile fpath ReadMode
- ls <- hGetContents h
- let mo = findMod (words ls)
- -- make sure we close up the file right away.
- (length mo) `seq` return ()
- hClose h
- return mo)
- (\ _ -> return "Main")
- where
- findMod [] = "Main"
- -- TODO: this should just return the module name, without the package name
- findMod ("%module":m:_) = m
- findMod (_:xs) = findMod xs
-
-
-data Token =
- TKmodule
- | TKdata
- | TKnewtype
- | TKforall
- | TKrec
- | TKlet
- | TKin
- | TKcase
- | TKof
- | TKcast
- | TKnote
- | TKexternal
- | TKlocal
- | TKwild
- | TKoparen
- | TKcparen
- | TKobrace
- | TKcbrace
- | TKhash
- | TKeq
- | TKcolon
- | TKcoloncolon
- | TKcoloneqcolon
- | TKstar
- | TKrarrow
- | TKlambda
- | TKat
- | TKdot
- | TKquestion
- | TKsemicolon
- | TKname String
- | TKcname String
- | TKinteger Integer
- | TKrational Rational
- | TKstring String
- | TKchar Char
- | TKEOF
-
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 5b39132254..26e83cd071 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -18,8 +18,7 @@ module TcRnDriver (
tcRnLookupName,
tcRnGetInfo,
tcRnModule, tcRnModuleTcRnM,
- tcTopSrcDecls,
- tcRnExtCore
+ tcTopSrcDecls
) where
#ifdef GHCI
@@ -58,8 +57,6 @@ import LoadIface
import RnNames
import RnEnv
import RnSource
-import PprCore
-import CoreSyn
import ErrUtils
import Id
import VarEnv
@@ -82,7 +79,6 @@ import CoAxiom
import Inst ( tcGetInstEnvs )
import Annotations
import Data.List ( sortBy )
-import Data.IORef ( readIORef )
import Data.Ord
#ifdef GHCI
import BasicTypes hiding( SuccessFlag(..) )
@@ -306,107 +302,6 @@ tcRnImports hsc_env import_decls
%************************************************************************
%* *
- Type-checking external-core modules
-%* *
-%************************************************************************
-
-\begin{code}
-tcRnExtCore :: HscEnv
- -> HsExtCore RdrName
- -> IO (Messages, Maybe ModGuts)
- -- Nothing => some error occurred
-
-tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
- -- The decls are IfaceDecls; all names are original names
- = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
-
- initTc hsc_env ExtCoreFile False this_mod $ do {
-
- let { ldecls = map noLoc decls } ;
-
- -- Bring the type and class decls into scope
- -- ToDo: check that this doesn't need to extract the val binds.
- -- It seems that only the type and class decls need to be in scope below because
- -- (a) tcTyAndClassDecls doesn't need the val binds, and
- -- (b) tcExtCoreBindings doesn't need anything
- -- (in fact, it might not even need to be in the scope of
- -- this tcg_env at all)
- (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -}
- (mkFakeGroup ldecls) ;
- setEnvs tc_envs $ do {
-
- (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [] [mkTyClGroup ldecls] ;
- -- The empty list is for extra dependencies coming from .hs-boot files
- -- See Note [Extra dependencies from .hs-boot files] in RnSource
-
- -- Dump trace of renaming part
- rnDump (ppr rn_decls) ;
-
- -- Typecheck them all together so that
- -- any mutually recursive types are done right
- -- Just discard the auxiliary bindings; they are generated
- -- only for Haskell source code, and should already be in Core
- tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ;
- safe_mode <- liftIO $ finalSafeMode (hsc_dflags hsc_env) tcg_env ;
- dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ;
-
- setGblEnv tcg_env $ do {
- -- Make the new type env available to stuff slurped from interface files
-
- -- Now the core bindings
- core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
-
-
- -- Wrap up
- let {
- bndrs = bindersOfBinds core_binds ;
- my_exports = map (Avail . idName) bndrs ;
- -- ToDo: export the data types also?
-
- mod_guts = ModGuts { mg_module = this_mod,
- mg_boot = False,
- mg_used_names = emptyNameSet, -- ToDo: compute usage
- mg_used_th = False,
- mg_dir_imps = emptyModuleEnv, -- ??
- mg_deps = noDependencies, -- ??
- mg_exports = my_exports,
- mg_tcs = tcg_tcs tcg_env,
- mg_insts = tcg_insts tcg_env,
- mg_fam_insts = tcg_fam_insts tcg_env,
- mg_inst_env = tcg_inst_env tcg_env,
- mg_fam_inst_env = tcg_fam_inst_env tcg_env,
- mg_patsyns = [], -- TODO
- mg_rules = [],
- mg_vect_decls = [],
- mg_anns = [],
- mg_binds = core_binds,
-
- -- Stubs
- mg_rdr_env = emptyGlobalRdrEnv,
- mg_fix_env = emptyFixityEnv,
- mg_warns = NoWarnings,
- mg_foreign = NoStubs,
- mg_hpc_info = emptyHpcInfo False,
- mg_modBreaks = emptyModBreaks,
- mg_vect_info = noVectInfo,
- mg_safe_haskell = safe_mode,
- mg_trust_pkg = False,
- mg_dependent_files = dep_files
- } } ;
-
- tcCoreDump mod_guts ;
-
- return mod_guts
- }}}}
-
-mkFakeGroup :: [LTyClDecl a] -> HsGroup a
-mkFakeGroup decls -- Rather clumsy; lots of unused fields
- = emptyRdrGroup { hs_tyclds = [mkTyClGroup decls] }
-\end{code}
-
-
-%************************************************************************
-%* *
Type-checking the top level of a module
%* *
%************************************************************************
@@ -1864,17 +1759,6 @@ tcDump env
-- NB: foreign x-d's have undefined's in their types;
-- hence can't show the tc_fords
-tcCoreDump :: ModGuts -> TcM ()
-tcCoreDump mod_guts
- = do { dflags <- getDynFlags ;
- when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
- (dumpTcRn (pprModGuts mod_guts)) ;
-
- -- Dump bindings if -ddump-tc
- dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
- where
- full_dump = pprCoreBindings (mg_binds mod_guts)
-
-- It's unpleasant having both pprModGuts and pprModDetails here
pprTcGblEnv :: TcGblEnv -> SDoc
pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
@@ -1900,12 +1784,6 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
`thenCmp`
(is_boot1 `compare` is_boot2)
-pprModGuts :: ModGuts -> SDoc
-pprModGuts (ModGuts { mg_tcs = tcs
- , mg_rules = rules })
- = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)),
- ppr_rules rules ]
-
ppr_types :: [ClsInst] -> TypeEnv -> SDoc
ppr_types insts type_env
= text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
@@ -1960,9 +1838,4 @@ ppr_tydecls tycons
-- Temporarily print the kind signature too
, ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
-ppr_rules :: [CoreRule] -> SDoc
-ppr_rules [] = empty
-ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
- nest 2 (pprRules rs),
- ptext (sLit "#-}")]
\end{code}
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 01c9d36cf3..0fc4d6ba9a 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -1245,17 +1245,6 @@ initIfaceTcRn thing_inside
; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
; setEnvs (if_env, ()) thing_inside }
-initIfaceExtCore :: IfL a -> TcRn a
-initIfaceExtCore thing_inside
- = do { tcg_env <- getGblEnv
- ; let { mod = tcg_mod tcg_env
- ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod)
- ; if_env = IfGblEnv {
- if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
- ; if_lenv = mkIfLclEnv mod doc
- }
- ; setEnvs (if_env, if_lenv) thing_inside }
-
initIfaceCheck :: HscEnv -> IfG a -> IO a
-- Used when checking the up-to-date-ness of the old Iface
-- Initialise the environment with no useful info at all
View Lorry Controller Status