Commit 9500b166 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 5c9dfadd c5555640
......@@ -110,9 +110,9 @@ endif
.PHONY: test
test:
$(MAKE) -C testsuite/tests/ghc-regress CLEANUP=1 OUTPUT_SUMMARY=../../../testsuite_summary.txt fast
$(MAKE) -C testsuite/tests CLEANUP=1 OUTPUT_SUMMARY=../../testsuite_summary.txt fast
.PHONY: fulltest
fulltest:
$(MAKE) -C testsuite/tests/ghc-regress CLEANUP=1 OUTPUT_SUMMARY=../../../testsuite_summary.txt
$(MAKE) -C testsuite/tests CLEANUP=1 OUTPUT_SUMMARY=../../testsuite_summary.txt
......@@ -47,8 +47,8 @@ module BasicTypes(
TupCon(..), tupleParens,
OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc,
nonRuleLoopBreaker,
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc,
strongLoopBreaker, weakLoopBreaker,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch,
......@@ -456,24 +456,20 @@ data OccInfo
-- | This identifier breaks a loop of mutually recursive functions. The field
-- marks whether it is only a loop breaker due to a reference in a rule
| IAmALoopBreaker -- Note [LoopBreaker OccInfo]
!RulesOnly -- True <=> This is a weak or rules-only loop breaker
-- See OccurAnal Note [Weak loop breakers]
!RulesOnly
type RulesOnly = Bool
\end{code}
Note [LoopBreaker OccInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~
An OccInfo of (IAmLoopBreaker False) is used by the occurrence
analyser in two ways:
(a) to mark loop-breakers in a group of recursive
definitions (hence the name)
(b) to mark binders that must not be inlined in this phase
(perhaps it has a NOINLINE pragma)
Things with (IAmLoopBreaker False) do not get an unfolding
pinned on to them, so they are completely opaque.
IAmALoopBreaker True <=> A "weak" or rules-only loop breaker
Do not preInlineUnconditionally
See OccurAnal Note [Weak loop breakers] for (IAmLoopBreaker True).
IAmALoopBreaker False <=> A "strong" loop breaker
Do not inline at all
See OccurAnal Note [Weak loop breakers]
\begin{code}
......@@ -504,16 +500,17 @@ oneBranch, notOneBranch :: OneBranch
oneBranch = True
notOneBranch = False
isLoopBreaker :: OccInfo -> Bool
isLoopBreaker (IAmALoopBreaker _) = True
isLoopBreaker _ = False
strongLoopBreaker, weakLoopBreaker :: OccInfo
strongLoopBreaker = IAmALoopBreaker False
weakLoopBreaker = IAmALoopBreaker True
isNonRuleLoopBreaker :: OccInfo -> Bool
isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle
isNonRuleLoopBreaker _ = False
isWeakLoopBreaker :: OccInfo -> Bool
isWeakLoopBreaker (IAmALoopBreaker _) = True
isWeakLoopBreaker _ = False
nonRuleLoopBreaker :: OccInfo
nonRuleLoopBreaker = IAmALoopBreaker False
isStrongLoopBreaker :: OccInfo -> Bool
isStrongLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle
isStrongLoopBreaker _ = False
isDeadOcc :: OccInfo -> Bool
isDeadOcc IAmDead = True
......
......@@ -508,8 +508,8 @@ isStrictId id
idUnfolding :: Id -> Unfolding
-- Do not expose the unfolding of a loop breaker!
idUnfolding id
| isNonRuleLoopBreaker (occInfo info) = NoUnfolding
| otherwise = unfoldingInfo info
| isStrongLoopBreaker (occInfo info) = NoUnfolding
| otherwise = unfoldingInfo info
where
info = idInfo id
......
......@@ -38,7 +38,7 @@ module IdInfo (
-- ** The OccInfo type
OccInfo(..),
isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker,
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,
occInfo, setOccInfo,
InsideLam, OneBranch,
......
......@@ -375,7 +375,7 @@ filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a
delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
delVarEnv :: VarEnv a -> Var -> VarEnv a
minusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a
minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a
intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool
plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
......
......@@ -51,6 +51,7 @@ import VarSet
import Var
import TcType
import Coercion
import Maybes( orElse )
import Util
import BasicTypes( Activation )
import Outputable
......@@ -443,13 +444,15 @@ idUnfoldingVars :: Id -> VarSet
-- and we'll get exponential behaviour if we look at both unf and rhs!
-- But do look at the *real* unfolding, even for loop breakers, else
-- we might get out-of-scope variables
idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id)
stableUnfoldingVars :: Unfolding -> VarSet
stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
| isStableSource src = exprFreeVars rhs
stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars args
stableUnfoldingVars _ = emptyVarSet
idUnfoldingVars id = stableUnfoldingVars isLocalId (realIdUnfolding id) `orElse` emptyVarSet
stableUnfoldingVars :: InterestingVarFun -> Unfolding -> Maybe VarSet
stableUnfoldingVars fv_cand unf
= case unf of
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
| isStableSource src -> Just (exprSomeFreeVars fv_cand rhs)
DFunUnfolding _ _ args -> Just (exprsSomeFreeVars fv_cand args)
_other -> Nothing
\end{code}
......
......@@ -182,7 +182,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- Check whether binder's specialisations contain any out-of-scope variables
; mapM_ (checkBndrIdInScope binder) bndr_vars
; when (isNonRuleLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder))
; when (isStrongLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder))
(addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder))
-- Only non-rule loop breakers inhibit inlining
......
......@@ -51,6 +51,7 @@ import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substC
import OptCoercion ( optCoercion )
import PprCore ( pprCoreBindings )
import Module ( Module )
import VarSet
import VarEnv
import Id
......@@ -794,15 +795,16 @@ simpleOptExprWith :: Subst -> InExpr -> OutExpr
simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr)
----------------------
simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> [CoreVect]
simpleOptPgm :: DynFlags -> Module
-> [CoreBind] -> [CoreRule] -> [CoreVect]
-> IO ([CoreBind], [CoreRule], [CoreVect])
simpleOptPgm dflags binds rules vects
simpleOptPgm dflags this_mod binds rules vects
= do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings occ_anald_binds);
; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) }
where
occ_anald_binds = occurAnalysePgm Nothing {- No rules active -}
occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}
rules vects binds
(subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
......
......@@ -1229,10 +1229,10 @@ hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_ha
hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e
hash_expr env (Case e _ _ _) = hash_expr env e
hash_expr env (Lam b e) = hash_expr (extend_env env b) e
hash_expr env (Coercion co) = fast_hash_co env co
hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1
-- Shouldn't happen. Better to use WARN than trace, because trace
-- prevents the CPR optimisation kicking in for hash_expr.
hash_expr _ (Coercion _) = WARN(True, text "hash_expr: coercion") 1
fast_hash_expr :: HashEnv -> CoreExpr -> Word32
fast_hash_expr env (Var v) = hashVar env v
......@@ -1391,7 +1391,7 @@ tryEtaReduce bndrs body
---------------
fun_arity fun -- See Note [Arity care]
| isLocalId fun && isNonRuleLoopBreaker (idOccInfo fun) = 0
| isLocalId fun && isStrongLoopBreaker (idOccInfo fun) = 0
| otherwise = idArity fun
---------------
......
......@@ -61,7 +61,8 @@ deSugar hsc_env
tcg_imports = imports,
tcg_exports = exports,
tcg_keep = keep_var,
tcg_rdr_env = rdr_env,
tcg_th_splice_used = tc_splice_used,
tcg_rdr_env = rdr_env,
tcg_fix_env = fix_env,
tcg_inst_env = inst_env,
tcg_fam_inst_env = fam_inst_env,
......@@ -138,7 +139,7 @@ deSugar hsc_env
, pprRules rules_for_imps ])
; (ds_binds, ds_rules_for_imps, ds_vects)
<- simpleOptPgm dflags final_pgm rules_for_imps vects0
<- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
-- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code
......@@ -147,13 +148,16 @@ deSugar hsc_env
; let used_names = mkUsedNames tcg_env
; deps <- mkDependencies tcg_env
; let mod_guts = ModGuts {
; used_th <- readIORef tc_splice_used
; let mod_guts = ModGuts {
mg_module = mod,
mg_boot = isHsBoot hsc_src,
mg_exports = exports,
mg_deps = deps,
mg_used_names = used_names,
mg_dir_imps = imp_mods imports,
mg_used_th = used_th,
mg_dir_imps = imp_mods imports,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_warns = warns,
......
......@@ -517,8 +517,11 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
; let spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
| otherwise = spec_inl
inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl
| not is_local_id -- See Note [Specialising imported functions]
-- in OccurAnal
, isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
| otherwise = idInlinePragma poly_id
-- Get the INLINE pragma from SPECIALISE declaration, or,
-- failing that, from the original Id
......
......@@ -1232,13 +1232,14 @@ pushAtom _ _ (AnnLit lit)
= case lit of
MachLabel _ _ _ -> code NonPtrArg
MachWord _ -> code NonPtrArg
MachInt _ -> code PtrArg
MachInt _ -> code NonPtrArg
MachWord64 _ -> code LongArg
MachInt64 _ -> code LongArg
MachFloat _ -> code FloatArg
MachDouble _ -> code DoubleArg
MachChar _ -> code NonPtrArg
MachNullAddr -> code NonPtrArg
MachStr s -> pushStr s
l -> pprPanic "pushAtom" (ppr l)
where
code rep
= let size_host_words = fromIntegral (cgRepSizeW rep)
......
......@@ -465,7 +465,6 @@ cvtl e = wrapL (cvt e)
; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens)
cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
cvt (UnboxedTupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens)
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
; return $ HsIf (Just noSyntaxExpr) x' y' z' }
......@@ -632,7 +631,6 @@ cvtp (TH.LitP l)
cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
cvtp (TupP [p]) = cvtp p
cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
cvtp (UnboxedTupP [p]) = cvtp p
cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
......@@ -710,8 +708,6 @@ cvtType ty
-> if n==1 then return (head tys') -- Singleton tuples treated
-- like nothing (ie just parens)
else returnL (HsTupleTy Unboxed tys')
| n == 1
-> failWith (ptext (sLit "Illegal 1-unboxed-tuple type constructor"))
| otherwise
-> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
ArrowT
......
......@@ -716,10 +716,13 @@ data ConDecl name
, con_qvars :: [LHsTyVarBndr name]
-- ^ Type variables. Depending on 'con_res' this describes the
-- follewing entities
-- following entities
--
-- - ResTyH98: the constructor's *existential* type variables
-- - ResTyGADT: *all* the constructor's quantified type variables
--
-- If con_explicit is Implicit, then con_qvars is irrelevant
-- until after renaming.
, con_cxt :: LHsContext name
-- ^ The context. This /does not/ include the \"stupid theta\" which
......
......@@ -380,7 +380,8 @@ instance Binary ModIface where
mi_usages = usages,
mi_exports = exports,
mi_exp_hash = exp_hash,
mi_fixities = fixities,
mi_used_th = used_th,
mi_fixities = fixities,
mi_warns = warns,
mi_anns = anns,
mi_decls = decls,
......@@ -402,7 +403,8 @@ instance Binary ModIface where
lazyPut bh usages
put_ bh exports
put_ bh exp_hash
put_ bh fixities
put_ bh used_th
put_ bh fixities
lazyPut bh warns
lazyPut bh anns
put_ bh decls
......@@ -426,7 +428,8 @@ instance Binary ModIface where
usages <- {-# SCC "bin_usages" #-} lazyGet bh
exports <- {-# SCC "bin_exports" #-} get bh
exp_hash <- get bh
fixities <- {-# SCC "bin_fixities" #-} get bh
used_th <- get bh
fixities <- {-# SCC "bin_fixities" #-} get bh
warns <- {-# SCC "bin_warns" #-} lazyGet bh
anns <- {-# SCC "bin_anns" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh
......@@ -448,8 +451,9 @@ instance Binary ModIface where
mi_deps = deps,
mi_usages = usages,
mi_exports = exports,
mi_exp_hash = exp_hash,
mi_anns = anns,
mi_exp_hash = exp_hash,
mi_used_th = used_th,
mi_anns = anns,
mi_fixities = fixities,
mi_warns = warns,
mi_decls = decls,
......
......@@ -195,7 +195,7 @@ data IfaceInfoItem
= HsArity Arity
| HsStrictness StrictSig
| HsInline InlinePragma
| HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true
| HsUnfold Bool -- True <=> isStrongLoopBreaker is true
IfaceUnfolding -- See Note [Expose recursive functions]
| HsNoCafRefs
......
......@@ -655,6 +655,7 @@ pprModIface iface
, nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
, nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
, nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
, nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
, nest 2 (ptext (sLit "where"))
, vcat (map pprExport (mi_exports iface))
, pprDeps (mi_deps iface)
......
......@@ -126,6 +126,7 @@ mkIface hsc_env maybe_old_fingerprint mod_details
ModGuts{ mg_module = this_mod,
mg_boot = is_boot,
mg_used_names = used_names,
mg_used_th = used_th,
mg_deps = deps,
mg_dir_imps = dir_imp_mods,
mg_rdr_env = rdr_env,
......@@ -134,7 +135,7 @@ mkIface hsc_env maybe_old_fingerprint mod_details
mg_hpc_info = hpc_info,
mg_trust_pkg = self_trust }
= mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env fix_env
this_mod is_boot used_names used_th deps rdr_env fix_env
warns hpc_info dir_imp_mods self_trust mod_details
-- | make an interface from the results of typechecking only. Useful
......@@ -152,14 +153,16 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details
tcg_rdr_env = rdr_env,
tcg_fix_env = fix_env,
tcg_warns = warns,
tcg_hpc = other_hpc_info
tcg_hpc = other_hpc_info,
tcg_th_splice_used = tc_splice_used
}
= do
let used_names = mkUsedNames tc_result
deps <- mkDependencies tc_result
let hpc_info = emptyHpcInfo other_hpc_info
used_th <- readIORef tc_splice_used
mkIface_ hsc_env maybe_old_fingerprint
this_mod (isHsBoot hsc_src) used_names deps rdr_env
this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env
fix_env warns hpc_info (imp_mods imports)
(imp_trust_own_pkg imports) mod_details
......@@ -203,14 +206,14 @@ mkDependencies
-- NB. remember to use lexicographic ordering
mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
-> NameSet -> Dependencies -> GlobalRdrEnv
-> NameSet -> Bool -> Dependencies -> GlobalRdrEnv
-> NameEnv FixItem -> Warnings -> HpcInfo
-> ImportedMods -> Bool
-> ModDetails
-> IO (Messages, Maybe (ModIface, Bool))
mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
dir_imp_mods pkg_trust_req
this_mod is_boot used_names used_th deps rdr_env fix_env src_warns
hpc_info dir_imp_mods pkg_trust_req
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
......@@ -268,7 +271,8 @@ mkIface_ hsc_env maybe_old_fingerprint
mi_iface_hash = fingerprint0,
mi_mod_hash = fingerprint0,
mi_exp_hash = fingerprint0,
mi_orphan_hash = fingerprint0,
mi_used_th = used_th,
mi_orphan_hash = fingerprint0,
mi_orphan = False, -- Always set by addVersionInfo, but
-- it's a strict field, so we can't omit it.
mi_finsts = False, -- Ditto
......@@ -1032,21 +1036,20 @@ so we may need to split up a single Avail into multiple ones.
\begin{code}
checkOldIface :: HscEnv
-> ModSummary
-> Bool -- Source unchanged
-> SourceModified
-> Maybe ModIface -- Old interface from compilation manager, if any
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface hsc_env mod_summary source_unchanged maybe_iface
checkOldIface hsc_env mod_summary source_modified maybe_iface
= do showPass (hsc_dflags hsc_env) $
"Checking old interface for " ++ (showSDoc $ ppr $ ms_mod mod_summary)
initIfaceCheck hsc_env $
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
check_old_iface hsc_env mod_summary source_modified maybe_iface
check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
check_old_iface :: HscEnv -> ModSummary -> SourceModified -> Maybe ModIface
-> IfG (Bool, Maybe ModIface)
check_old_iface hsc_env mod_summary src_unchanged maybe_iface
= let src_changed = not src_unchanged
dflags = hsc_dflags hsc_env
check_old_iface hsc_env mod_summary src_modified maybe_iface
= let dflags = hsc_dflags hsc_env
getIface =
case maybe_iface of
Just _ -> do
......@@ -1064,23 +1067,34 @@ check_old_iface hsc_env mod_summary src_unchanged maybe_iface
return $ Just iface
in do
when src_changed
let src_changed
| dopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
| SourceModified <- src_modified = True
| otherwise = False
when src_changed
(traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
-- If the source has changed and we're in interactive mode, avoid reading
-- an interface; just return the one we might have been supplied with.
if not (isObjectTarget $ hscTarget dflags) && src_changed
-- If the source has changed and we're in interactive mode,
-- avoid reading an interface; just return the one we might
-- have been supplied with.
if not (isObjectTarget $ hscTarget dflags) && src_changed
then return (outOfDate, maybe_iface)
else do
-- Try and read the old interface for the current module
-- from the .hi file left from the last time we compiled it
maybe_iface' <- getIface
if src_changed
then return (outOfDate, maybe_iface')
else do
case maybe_iface' of
Nothing -> return (outOfDate, maybe_iface')
Just iface -> do
-- We have got the old iface; check its versions
recomp <- checkVersions hsc_env src_unchanged mod_summary iface
return recomp
Just iface ->
-- We have got the old iface; check its versions
-- even in the SourceUnmodifiedAndStable case we
-- should check versions because some packages
-- might have changed or gone away.
checkVersions hsc_env mod_summary iface
\end{code}
@recompileRequired@ is called from the HscMain. It checks whether
......@@ -1101,16 +1115,10 @@ safeHsChanged hsc_env iface
= (getSafeMode $ mi_trust iface) /= (safeHaskell $ hsc_dflags hsc_env)
checkVersions :: HscEnv
-> Bool -- True <=> source unchanged
-> ModSummary
-> ModIface -- Old interface
-> IfG (RecompileRequired, Maybe ModIface)
checkVersions hsc_env source_unchanged mod_summary iface
| not source_unchanged
= let iface' = if safeHsChanged hsc_env iface then Nothing else Just iface
in return (outOfDate, iface')
| otherwise
checkVersions hsc_env mod_summary iface
= do { traceHiDiffs (text "Considering whether compilation is required for" <+>
ppr (mi_module iface) <> colon)
......@@ -1523,7 +1531,7 @@ toIfaceIdInfo id_info
------------ Unfolding --------------
unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
loop_breaker = isNonRuleLoopBreaker (occInfo id_info)
loop_breaker = isStrongLoopBreaker (occInfo id_info)
------------ Inline prag --------------
inline_prag = inlinePragInfo id_info
......
......@@ -40,7 +40,7 @@ import TyCon
import DataCon
import TysWiredIn
import TysPrim ( anyTyConOfKind )
import BasicTypes ( Arity, nonRuleLoopBreaker )
import BasicTypes ( Arity, strongLoopBreaker )
import qualified Var
import VarEnv
import VarSet
......@@ -1055,7 +1055,7 @@ tcIdInfo ignore_prags name ty info
-- The next two are lazy, so they don't transitively suck stuff in
tcPrag info (HsUnfold lb if_unf)
= do { unf <- tcUnfolding name ty info if_unf
; let info1 | lb = info `setOccInfo` nonRuleLoopBreaker
; let info1 | lb = info `setOccInfo` strongLoopBreaker
| otherwise = info
; return (info1 `setUnfoldingInfoLazily` unf) }
\end{code}
......
......@@ -17,18 +17,22 @@ module LlvmMangler ( llvmFixupAsm ) where
import LlvmCodeGen.Ppr ( infoSection )
import Control.Exception
import Control.Monad ( when )
import qualified Data.ByteString.Char8 as B
import Data.Char
import qualified Data.IntMap as I
import System.IO
import Data.List ( sortBy )
import Data.Function ( on )
-- Magic Strings
secStmt, infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
secStmt, infoSec, newLine, spInst, jmpInst, textStmt, dataStmt :: B.ByteString
secStmt = B.pack "\t.section\t"
infoSec = B.pack infoSection
newInfoSec = B.pack "\n\t.text"
newLine = B.pack "\n"
jmpInst = B.pack "\n\tjmp"
textStmt = B.pack "\t.text"
dataStmt = B.pack "\t.data"
infoLen, labelStart, spFix :: Int
infoLen = B.length infoSec
......@@ -53,54 +57,79 @@ llvmFixupAsm :: FilePath -> FilePath -> IO ()
llvmFixupAsm f1 f2 = do
r <- openBinaryFile f1 ReadMode
w <- openBinaryFile f2 WriteMode
fixTables r w I.empty
B.hPut w (B.pack "\n\n")
ss <- readSections r w
hClose r
let fixed = fixTables ss
mapM_ (writeSection w) fixed
hClose w
return ()
{- |
Here we process the assembly file one function and data
definition at a time. When a function is encountered that
should have a info table we store it in a map. Otherwise
we print it. When an info table is found we retrieve its
function from the map and print them both.
For all functions we fix up the stack alignment. We also
fix up the section definition for functions and info tables.
-}
fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO ()
fixTables r w m = do
f <- getFun r
if B.null f
then return ()
else let fun = fixupStack f B.empty
(a,b) = B.breakSubstring infoSec fun
(a',s) = B.breakEnd eolPred a
-- We search for the section header in two parts as it makes
-- us portable across OS types and LLVM version types since
-- section names are wrapped differently.
secHdr = secStmt `B.isPrefixOf` s
(x,c) = B.break eolPred b
fun' = a' `B.append` newInfoSec `B.append` c
n = readInt $ B.takeWhile isDigit $ B.drop infoLen x
(bs, m') | B.null b || not secHdr = ([fun], m)
| even n = ([], I.insert n fun' m)
| otherwise = case I.lookup (n+1) m of
Just xf' -> ([fun',xf'], m)
Nothing -> ([fun'], m)
in mapM_ (B.hPut w) bs >> fixTables r w m'
-- | Read in the next function/data defenition
getFun :: Handle -> IO B.ByteString
getFun r = go [] >>= return . B.intercalate newLine
where go ls = do
l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString)
case l of
Right l' | B.null l' -> return (B.empty : reverse ls)
| otherwise -> go (l':ls)
Left _ -> return []
type Section = (B.ByteString, B.ByteString)