summaryrefslogtreecommitdiff
path: root/compiler/GHC/IfaceToCore.hs
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2019-10-02 12:36:44 +0300
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-02-20 21:17:57 -0500
commit74ad75e87317196c600dfabc61aee1b87d95c214 (patch)
tree37f85f608112a1372f097b4c2eea9f4c8c8f00fc /compiler/GHC/IfaceToCore.hs
parent19680ee533bb95c0c5c42aca5c81197e4b233979 (diff)
downloadhaskell-74ad75e87317196c600dfabc61aee1b87d95c214.tar.gz
Re-implement unsafe coercions in terms of unsafe equality proofs
(Commit message written by Omer, most of the code is written by Simon and Richard) See Note [Implementing unsafeCoerce] for how unsafe equality proofs and the new unsafeCoerce# are implemented. New notes added: - [Checking for levity polymorphism] in CoreLint.hs - [Implementing unsafeCoerce] in base/Unsafe/Coerce.hs - [Patching magic definitions] in Desugar.hs - [Wiring in unsafeCoerce#] in Desugar.hs Only breaking change in this patch is unsafeCoerce# is not exported from GHC.Exts, instead of GHC.Prim. Fixes #17443 Fixes #16893 NoFib ----- -------------------------------------------------------------------------------- Program Size Allocs Instrs Reads Writes -------------------------------------------------------------------------------- CS -0.1% 0.0% -0.0% -0.0% -0.0% CSD -0.1% 0.0% -0.0% -0.0% -0.0% FS -0.1% 0.0% -0.0% -0.0% -0.0% S -0.1% 0.0% -0.0% -0.0% -0.0% VS -0.1% 0.0% -0.0% -0.0% -0.0% VSD -0.1% 0.0% -0.0% -0.0% -0.1% VSM -0.1% 0.0% -0.0% -0.0% -0.0% anna -0.0% 0.0% -0.0% -0.0% -0.0% ansi -0.1% 0.0% -0.0% -0.0% -0.0% atom -0.1% 0.0% -0.0% -0.0% -0.0% awards -0.1% 0.0% -0.0% -0.0% -0.0% banner -0.1% 0.0% -0.0% -0.0% -0.0% bernouilli -0.1% 0.0% -0.0% -0.0% -0.0% binary-trees -0.1% 0.0% -0.0% -0.0% -0.0% boyer -0.1% 0.0% -0.0% -0.0% -0.0% boyer2 -0.1% 0.0% -0.0% -0.0% -0.0% bspt -0.1% 0.0% -0.0% -0.0% -0.0% cacheprof -0.1% 0.0% -0.0% -0.0% -0.0% calendar -0.1% 0.0% -0.0% -0.0% -0.0% cichelli -0.1% 0.0% -0.0% -0.0% -0.0% circsim -0.1% 0.0% -0.0% -0.0% -0.0% clausify -0.1% 0.0% -0.0% -0.0% -0.0% comp_lab_zift -0.1% 0.0% -0.0% -0.0% -0.0% compress -0.1% 0.0% -0.0% -0.0% -0.0% compress2 -0.1% 0.0% -0.0% -0.0% -0.0% constraints -0.1% 0.0% -0.0% -0.0% -0.0% cryptarithm1 -0.1% 0.0% -0.0% -0.0% -0.0% cryptarithm2 -0.1% 0.0% -0.0% -0.0% -0.0% cse -0.1% 0.0% -0.0% -0.0% -0.0% digits-of-e1 -0.1% 0.0% -0.0% -0.0% -0.0% digits-of-e2 -0.1% 0.0% -0.0% -0.0% -0.0% dom-lt -0.1% 0.0% -0.0% -0.0% -0.0% eliza -0.1% 0.0% -0.0% -0.0% -0.0% event -0.1% 0.0% -0.0% -0.0% -0.0% exact-reals -0.1% 0.0% -0.0% -0.0% -0.0% exp3_8 -0.1% 0.0% -0.0% -0.0% -0.0% expert -0.1% 0.0% -0.0% -0.0% -0.0% fannkuch-redux -0.1% 0.0% -0.0% -0.0% -0.0% fasta -0.1% 0.0% -0.5% -0.3% -0.4% fem -0.1% 0.0% -0.0% -0.0% -0.0% fft -0.1% 0.0% -0.0% -0.0% -0.0% fft2 -0.1% 0.0% -0.0% -0.0% -0.0% fibheaps -0.1% 0.0% -0.0% -0.0% -0.0% fish -0.1% 0.0% -0.0% -0.0% -0.0% fluid -0.1% 0.0% -0.0% -0.0% -0.0% fulsom -0.1% 0.0% +0.0% +0.0% +0.0% gamteb -0.1% 0.0% -0.0% -0.0% -0.0% gcd -0.1% 0.0% -0.0% -0.0% -0.0% gen_regexps -0.1% 0.0% -0.0% -0.0% -0.0% genfft -0.1% 0.0% -0.0% -0.0% -0.0% gg -0.1% 0.0% -0.0% -0.0% -0.0% grep -0.1% 0.0% -0.0% -0.0% -0.0% hidden -0.1% 0.0% -0.0% -0.0% -0.0% hpg -0.1% 0.0% -0.0% -0.0% -0.0% ida -0.1% 0.0% -0.0% -0.0% -0.0% infer -0.1% 0.0% -0.0% -0.0% -0.0% integer -0.1% 0.0% -0.0% -0.0% -0.0% integrate -0.1% 0.0% -0.0% -0.0% -0.0% k-nucleotide -0.1% 0.0% -0.0% -0.0% -0.0% kahan -0.1% 0.0% -0.0% -0.0% -0.0% knights -0.1% 0.0% -0.0% -0.0% -0.0% lambda -0.1% 0.0% -0.0% -0.0% -0.0% last-piece -0.1% 0.0% -0.0% -0.0% -0.0% lcss -0.1% 0.0% -0.0% -0.0% -0.0% life -0.1% 0.0% -0.0% -0.0% -0.0% lift -0.1% 0.0% -0.0% -0.0% -0.0% linear -0.1% 0.0% -0.0% -0.0% -0.0% listcompr -0.1% 0.0% -0.0% -0.0% -0.0% listcopy -0.1% 0.0% -0.0% -0.0% -0.0% maillist -0.1% 0.0% -0.0% -0.0% -0.0% mandel -0.1% 0.0% -0.0% -0.0% -0.0% mandel2 -0.1% 0.0% -0.0% -0.0% -0.0% mate -0.1% 0.0% -0.0% -0.0% -0.0% minimax -0.1% 0.0% -0.0% -0.0% -0.0% mkhprog -0.1% 0.0% -0.0% -0.0% -0.0% multiplier -0.1% 0.0% -0.0% -0.0% -0.0% n-body -0.1% 0.0% -0.0% -0.0% -0.0% nucleic2 -0.1% 0.0% -0.0% -0.0% -0.0% para -0.1% 0.0% -0.0% -0.0% -0.0% paraffins -0.1% 0.0% -0.0% -0.0% -0.0% parser -0.1% 0.0% -0.0% -0.0% -0.0% parstof -0.1% 0.0% -0.0% -0.0% -0.0% pic -0.1% 0.0% -0.0% -0.0% -0.0% pidigits -0.1% 0.0% -0.0% -0.0% -0.0% power -0.1% 0.0% -0.0% -0.0% -0.0% pretty -0.1% 0.0% -0.1% -0.1% -0.1% primes -0.1% 0.0% -0.0% -0.0% -0.0% primetest -0.1% 0.0% -0.0% -0.0% -0.0% prolog -0.1% 0.0% -0.0% -0.0% -0.0% puzzle -0.1% 0.0% -0.0% -0.0% -0.0% queens -0.1% 0.0% -0.0% -0.0% -0.0% reptile -0.1% 0.0% -0.0% -0.0% -0.0% reverse-complem -0.1% 0.0% -0.0% -0.0% -0.0% rewrite -0.1% 0.0% -0.0% -0.0% -0.0% rfib -0.1% 0.0% -0.0% -0.0% -0.0% rsa -0.1% 0.0% -0.0% -0.0% -0.0% scc -0.1% 0.0% -0.1% -0.1% -0.1% sched -0.1% 0.0% -0.0% -0.0% -0.0% scs -0.1% 0.0% -0.0% -0.0% -0.0% simple -0.1% 0.0% -0.0% -0.0% -0.0% solid -0.1% 0.0% -0.0% -0.0% -0.0% sorting -0.1% 0.0% -0.0% -0.0% -0.0% spectral-norm -0.1% 0.0% -0.0% -0.0% -0.0% sphere -0.1% 0.0% -0.0% -0.0% -0.0% symalg -0.1% 0.0% -0.0% -0.0% -0.0% tak -0.1% 0.0% -0.0% -0.0% -0.0% transform -0.1% 0.0% -0.0% -0.0% -0.0% treejoin -0.1% 0.0% -0.0% -0.0% -0.0% typecheck -0.1% 0.0% -0.0% -0.0% -0.0% veritas -0.0% 0.0% -0.0% -0.0% -0.0% wang -0.1% 0.0% -0.0% -0.0% -0.0% wave4main -0.1% 0.0% -0.0% -0.0% -0.0% wheel-sieve1 -0.1% 0.0% -0.0% -0.0% -0.0% wheel-sieve2 -0.1% 0.0% -0.0% -0.0% -0.0% x2n1 -0.1% 0.0% -0.0% -0.0% -0.0% -------------------------------------------------------------------------------- Min -0.1% 0.0% -0.5% -0.3% -0.4% Max -0.0% 0.0% +0.0% +0.0% +0.0% Geometric Mean -0.1% -0.0% -0.0% -0.0% -0.0% Test changes ------------ - break006 is marked as broken, see #17833 - The compiler allocates less when building T14683 (an unsafeCoerce#- heavy happy-generated code) on 64-platforms. Allocates more on 32-bit platforms. - Rest of the increases are tiny amounts (still enough to pass the threshold) in micro-benchmarks. I briefly looked at each one in a profiling build: most of the increased allocations seem to be because of random changes in the generated code. Metric Decrease: T14683 Metric Increase: T12150 T12234 T12425 T13035 T14683 T5837 T6048 Co-Authored-By: Richard Eisenberg <rae@cs.brynmawr.edu> Co-Authored-By: Ömer Sinan Ağacan <omeragacan@gmail.com>
Diffstat (limited to 'compiler/GHC/IfaceToCore.hs')
-rw-r--r--compiler/GHC/IfaceToCore.hs44
1 files changed, 29 insertions, 15 deletions
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 5cd4806e62..aa74a16284 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1249,7 +1249,6 @@ tcIfaceCo = go
go_var = tcIfaceLclId
tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
-tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
@@ -1465,12 +1464,23 @@ tcIdInfo ignore_prags toplvl name ty info = do
-- we start; default assumption is that it has CAFs
let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
| otherwise = vanillaIdInfo
- if ignore_prags
- then return init_info
- else case info of
- NoInfo -> return init_info
- HasInfo info -> foldlM tcPrag init_info info
+
+ case info of
+ NoInfo -> return init_info
+ HasInfo info -> let needed = needed_prags info in
+ foldlM tcPrag init_info needed
where
+ needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem]
+ needed_prags items
+ | not ignore_prags = items
+ | otherwise = filter need_prag items
+
+ need_prag :: IfaceInfoItem -> Bool
+ -- compulsory unfoldings are really compulsory.
+ -- See wrinkle in Note [Wiring in unsafeCoerce#] in Desugar
+ need_prag (HsUnfold _ (IfCompulsory {})) = True
+ need_prag _ = False
+
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
@@ -1493,7 +1503,7 @@ tcJoinInfo IfaceNotJoinPoint = Nothing
tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
= do { dflags <- getDynFlags
- ; mb_expr <- tcPragExpr toplvl name if_expr
+ ; mb_expr <- tcPragExpr False toplvl name if_expr
; let unf_src | stable = InlineStable
| otherwise = InlineRhs
; return $ case mb_expr of
@@ -1507,13 +1517,13 @@ tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
-- Strictness should occur before unfolding!
strict_sig = strictnessInfo info
tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
- = do { mb_expr <- tcPragExpr toplvl name if_expr
+ = do { mb_expr <- tcPragExpr True toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCompulsoryUnfolding expr) }
tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
- = do { mb_expr <- tcPragExpr toplvl name if_expr
+ = do { mb_expr <- tcPragExpr False toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
@@ -1535,17 +1545,20 @@ For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
-}
-tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
-tcPragExpr toplvl name expr
+tcPragExpr :: Bool -- Is this unfolding compulsory?
+ -- See Note [Checking for levity polymorphism] in CoreLint
+ -> TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
+tcPragExpr is_compulsory toplvl name expr
= forkM_maybe doc $ do
core_expr' <- tcIfaceExpr expr
-- Check for type consistency in the unfolding
-- See Note [Linting Unfoldings from Interfaces]
- when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
+ when (isTopLevel toplvl) $
+ whenGOptM Opt_DoCoreLinting $ do
in_scope <- get_in_scope
dflags <- getDynFlags
- case lintUnfolding dflags noSrcLoc in_scope core_expr' of
+ case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of
Nothing -> return ()
Just fail_msg -> do { mod <- getIfModule
; pprPanic "Iface Lint failure"
@@ -1555,7 +1568,8 @@ tcPragExpr toplvl name expr
, text "Iface expr =" <+> ppr expr ]) }
return core_expr'
where
- doc = text "Unfolding of" <+> ppr name
+ doc = ppWhen is_compulsory (text "Compulsory") <+>
+ text "Unfolding of" <+> ppr name
get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
get_in_scope
@@ -1686,7 +1700,7 @@ tcIfaceTyCon (IfaceTyCon name info)
= do { thing <- tcIfaceGlobal name
; return $ case ifaceTyConIsPromoted info of
NotPromoted -> tyThingTyCon thing
- IsPromoted -> promoteDataCon $ tyThingDataCon thing }
+ IsPromoted -> promoteDataCon $ tyThingDataCon thing }
tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
View Lorry Controller Status