Commit 5bf22f06 authored by Austin Seipp's avatar Austin Seipp

Remove external core

Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent a05f8dd1
......@@ -875,7 +875,7 @@ else
fi;
changequote([, ])dnl
])
if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs || test ! -f compiler/parser/ParserCore.hs
if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs
then
FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19],
[AC_MSG_ERROR([Happy version 1.19 or later is required to compile GHC.])])[]
......
%
% (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}
This diff is collapsed.
%
% (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}
......@@ -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
......
......@@ -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}
......
......@@ -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
......@@ -1518,14 +1493,6 @@ bindIfaceBndrs (b:bs) thing_inside
bindIfaceBndrs bs $ \ bs' ->
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
......
......@@ -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)
......
......@@ -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,
......
......@@ -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 ),
......
......@@ -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 = "",