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 ...@@ -875,7 +875,7 @@ else
fi; fi;
changequote([, ])dnl 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 then
FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19], FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19],
[AC_MSG_ERROR([Happy version 1.19 or later is required to compile GHC.])])[] [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 ...@@ -232,11 +232,8 @@ Library
CoreTidy CoreTidy
CoreUnfold CoreUnfold
CoreUtils CoreUtils
ExternalCore
MkCore MkCore
MkExternalCore
PprCore PprCore
PprExternalCore
Check Check
Coverage Coverage
Desugar Desugar
...@@ -303,12 +300,9 @@ Library ...@@ -303,12 +300,9 @@ Library
TidyPgm TidyPgm
Ctype Ctype
HaddockUtils HaddockUtils
LexCore
Lexer Lexer
OptCoercion OptCoercion
Parser Parser
ParserCore
ParserCoreUtils
RdrHsSyn RdrHsSyn
ForeignCall ForeignCall
PrelInfo PrelInfo
......
...@@ -23,7 +23,7 @@ module HsSyn ( ...@@ -23,7 +23,7 @@ module HsSyn (
module HsDoc, module HsDoc,
Fixity, Fixity,
HsModule(..), HsExtCore(..), HsModule(..)
) where ) where
-- friends: -- friends:
...@@ -40,10 +40,9 @@ import HsDoc ...@@ -40,10 +40,9 @@ import HsDoc
-- others: -- others:
import OccName ( HasOccName ) import OccName ( HasOccName )
import IfaceSyn ( IfaceBinding )
import Outputable import Outputable
import SrcLoc import SrcLoc
import Module ( Module, ModuleName ) import Module ( ModuleName )
import FastString import FastString
-- libraries: -- libraries:
...@@ -77,13 +76,6 @@ data HsModule name ...@@ -77,13 +76,6 @@ data HsModule name
hsmodHaddockModHeader :: Maybe LHsDocString hsmodHaddockModHeader :: Maybe LHsDocString
-- ^ Haddock module info and description, unparsed -- ^ Haddock module info and description, unparsed
} deriving (Data, Typeable) } 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} \end{code}
......
...@@ -12,8 +12,7 @@ module TcIface ( ...@@ -12,8 +12,7 @@ module TcIface (
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceVectInfo, tcIfaceAnnotations,
tcIfaceExpr, -- Desired by HERMIT (Trac #7683) tcIfaceExpr, -- Desired by HERMIT (Trac #7683)
tcIfaceGlobal, tcIfaceGlobal
tcExtCoreBindings
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -1251,30 +1250,6 @@ tcIfaceDataAlt con inst_tys arg_strs rhs ...@@ -1251,30 +1250,6 @@ tcIfaceDataAlt con inst_tys arg_strs rhs
\end{code} \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 IdInfo
...@@ -1518,14 +1493,6 @@ bindIfaceBndrs (b:bs) thing_inside ...@@ -1518,14 +1493,6 @@ bindIfaceBndrs (b:bs) thing_inside
bindIfaceBndrs bs $ \ bs' -> bindIfaceBndrs bs $ \ bs' ->
thing_inside (b':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 :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside bindIfaceTyVar (occ,kind) thing_inside
......
...@@ -18,7 +18,6 @@ module DriverPhases ( ...@@ -18,7 +18,6 @@ module DriverPhases (
isHaskellSrcSuffix, isHaskellSrcSuffix,
isObjectSuffix, isObjectSuffix,
isCishSuffix, isCishSuffix,
isExtCoreSuffix,
isDynLibSuffix, isDynLibSuffix,
isHaskellUserSrcSuffix, isHaskellUserSrcSuffix,
isSourceSuffix, isSourceSuffix,
...@@ -27,7 +26,6 @@ module DriverPhases ( ...@@ -27,7 +26,6 @@ module DriverPhases (
isHaskellSrcFilename, isHaskellSrcFilename,
isObjectFilename, isObjectFilename,
isCishFilename, isCishFilename,
isExtCoreFilename,
isDynLibFilename, isDynLibFilename,
isHaskellUserSrcFilename, isHaskellUserSrcFilename,
isSourceFilename isSourceFilename
...@@ -56,7 +54,7 @@ import System.FilePath ...@@ -56,7 +54,7 @@ import System.FilePath
-} -}
data HscSource data HscSource
= HsSrcFile | HsBootFile | ExtCoreFile = HsSrcFile | HsBootFile
deriving( Eq, Ord, Show ) deriving( Eq, Ord, Show )
-- Ord needed for the finite maps we build in CompManager -- Ord needed for the finite maps we build in CompManager
...@@ -64,7 +62,6 @@ data HscSource ...@@ -64,7 +62,6 @@ data HscSource
hscSourceString :: HscSource -> String hscSourceString :: HscSource -> String
hscSourceString HsSrcFile = "" hscSourceString HsSrcFile = ""
hscSourceString HsBootFile = "[boot]" hscSourceString HsBootFile = "[boot]"
hscSourceString ExtCoreFile = "[ext core]"
isHsBoot :: HscSource -> Bool isHsBoot :: HscSource -> Bool
isHsBoot HsBootFile = True isHsBoot HsBootFile = True
...@@ -175,7 +172,6 @@ startPhase "hs" = Cpp HsSrcFile ...@@ -175,7 +172,6 @@ startPhase "hs" = Cpp HsSrcFile
startPhase "hs-boot" = Cpp HsBootFile startPhase "hs-boot" = Cpp HsBootFile
startPhase "hscpp" = HsPp HsSrcFile startPhase "hscpp" = HsPp HsSrcFile
startPhase "hspp" = Hsc HsSrcFile startPhase "hspp" = Hsc HsSrcFile
startPhase "hcr" = Hsc ExtCoreFile
startPhase "hc" = HCc startPhase "hc" = HCc
startPhase "c" = Cc startPhase "c" = Cc
startPhase "cpp" = Ccpp startPhase "cpp" = Ccpp
...@@ -202,7 +198,6 @@ startPhase _ = StopLn -- all unknown file types ...@@ -202,7 +198,6 @@ startPhase _ = StopLn -- all unknown file types
phaseInputExt :: Phase -> String phaseInputExt :: Phase -> String
phaseInputExt (Unlit HsSrcFile) = "lhs" phaseInputExt (Unlit HsSrcFile) = "lhs"
phaseInputExt (Unlit HsBootFile) = "lhs-boot" phaseInputExt (Unlit HsBootFile) = "lhs-boot"
phaseInputExt (Unlit ExtCoreFile) = "lhcr"
phaseInputExt (Cpp _) = "lpp" -- intermediate only phaseInputExt (Cpp _) = "lpp" -- intermediate only
phaseInputExt (HsPp _) = "hscpp" -- intermediate only phaseInputExt (HsPp _) = "hscpp" -- intermediate only
phaseInputExt (Hsc _) = "hspp" -- intermediate only phaseInputExt (Hsc _) = "hspp" -- intermediate only
...@@ -227,13 +222,12 @@ phaseInputExt MergeStub = "o" ...@@ -227,13 +222,12 @@ phaseInputExt MergeStub = "o"
phaseInputExt StopLn = "o" phaseInputExt StopLn = "o"
haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, haskellish_src_suffixes, haskellish_suffixes, cish_suffixes,
extcoreish_suffixes, haskellish_user_src_suffixes haskellish_user_src_suffixes
:: [String] :: [String]
haskellish_src_suffixes = haskellish_user_src_suffixes ++ haskellish_src_suffixes = haskellish_user_src_suffixes ++
[ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ] [ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ]
haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"] haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"]
cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] 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: -- Will not be deleted as temp files:
haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ]
...@@ -250,13 +244,12 @@ dynlib_suffixes platform = case platformOS platform of ...@@ -250,13 +244,12 @@ dynlib_suffixes platform = case platformOS platform of
OSDarwin -> ["dylib", "so"] OSDarwin -> ["dylib", "so"]
_ -> ["so"] _ -> ["so"]
isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix, isExtCoreSuffix, isHaskellishSuffix, isHaskellSrcSuffix, isCishSuffix,
isHaskellUserSrcSuffix isHaskellUserSrcSuffix
:: String -> Bool :: String -> Bool
isHaskellishSuffix s = s `elem` haskellish_suffixes isHaskellishSuffix s = s `elem` haskellish_suffixes
isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes
isCishSuffix s = s `elem` cish_suffixes isCishSuffix s = s `elem` cish_suffixes
isExtCoreSuffix s = s `elem` extcoreish_suffixes
isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes
isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool
...@@ -267,13 +260,12 @@ isSourceSuffix :: String -> Bool ...@@ -267,13 +260,12 @@ isSourceSuffix :: String -> Bool
isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff
isHaskellishFilename, isHaskellSrcFilename, isCishFilename, isHaskellishFilename, isHaskellSrcFilename, isCishFilename,
isExtCoreFilename, isHaskellUserSrcFilename, isSourceFilename isHaskellUserSrcFilename, isSourceFilename
:: FilePath -> Bool :: FilePath -> Bool
-- takeExtension return .foo, so we drop 1 to get rid of the . -- takeExtension return .foo, so we drop 1 to get rid of the .
isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f)
isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f)
isCishFilename f = isCishSuffix (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) isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f)
isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f)
......
...@@ -54,7 +54,6 @@ import Util ...@@ -54,7 +54,6 @@ import Util
import StringBuffer ( hGetStringBuffer ) import StringBuffer ( hGetStringBuffer )
import BasicTypes ( SuccessFlag(..) ) import BasicTypes ( SuccessFlag(..) )
import Maybes ( expectJust ) import Maybes ( expectJust )
import ParserCoreUtils ( getCoreModuleName )
import SrcLoc import SrcLoc
import FastString import FastString
import LlvmCodeGen ( llvmFixupAsm ) import LlvmCodeGen ( llvmFixupAsm )
...@@ -169,8 +168,6 @@ compileOne' m_tc_result mHscMessage ...@@ -169,8 +168,6 @@ compileOne' m_tc_result mHscMessage
output_fn <- getOutputFilename next_phase output_fn <- getOutputFilename next_phase
Temporary basename dflags next_phase (Just location) Temporary basename dflags next_phase (Just location)
let extCore_filename = basename ++ ".hcr"
-- -fforce-recomp should also work with --make -- -fforce-recomp should also work with --make
let force_recomp = gopt Opt_ForceRecomp dflags let force_recomp = gopt Opt_ForceRecomp dflags
source_modified source_modified
...@@ -207,7 +204,7 @@ compileOne' m_tc_result mHscMessage ...@@ -207,7 +204,7 @@ compileOne' m_tc_result mHscMessage
hm_linkable = maybe_old_linkable }) hm_linkable = maybe_old_linkable })
_ -> do guts0 <- hscDesugar hsc_env summary tc_result _ -> do guts0 <- hscDesugar hsc_env summary tc_result
guts <- hscSimplify hsc_env guts0 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 (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary