summaryrefslogtreecommitdiff
path: root/compiler/typecheck
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/typecheck
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/typecheck')
-rw-r--r--compiler/typecheck/TcInstDcls.hs2
-rw-r--r--compiler/typecheck/TcMType.hs1
-rw-r--r--compiler/typecheck/TcRnDriver.hs75
-rw-r--r--compiler/typecheck/TcSplice.hs6
-rw-r--r--compiler/typecheck/TcTyDecls.hs1
5 files changed, 44 insertions, 41 deletions
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 21e1ba81ba..193d6b70bb 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -163,7 +163,7 @@ Note [Instances and loop breakers]
loop-breaker because df_i isn't), op1_i will ironically never be
inlined. But this is OK: the recursion breaking happens by way of
a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
- unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
+ unfoldings. See Note [RULEs enabled in InitialPhase] in SimplUtils
Note [ClassOp/DFun selection]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index 85a59b697a..45863e4046 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -1394,7 +1394,6 @@ collect_cand_qtvs_co orig_ty bound = go_co
go_mco dv MRefl = return dv
go_mco dv (MCo co) = go_co dv co
- go_prov dv UnsafeCoerceProv = return dv
go_prov dv (PhantomProv co) = go_co dv co
go_prov dv (ProofIrrelProv co) = go_co dv co
go_prov dv (PluginProv _) = return dv
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 99cbcf1578..2caee7df9f 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -62,7 +62,6 @@ import GHC.Rename.Types
import GHC.Rename.Expr
import GHC.Rename.Utils ( HsDocContext(..) )
import GHC.Rename.Fixity ( lookupFixityRn )
-import MkId
import TysWiredIn ( unitTy, mkListTy )
import Plugins
import DynFlags
@@ -2270,51 +2269,57 @@ leaking memory as it is repeatedly queried.
-- statement in the form 'IO [()]'.
tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult
tcGhciStmts stmts
- = do { ioTyCon <- tcLookupTyCon ioTyConName ;
- ret_id <- tcLookupId returnIOName ; -- return @ IO
- let {
- ret_ty = mkListTy unitTy ;
- io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+ = do { ioTyCon <- tcLookupTyCon ioTyConName
+ ; ret_id <- tcLookupId returnIOName -- return @ IO
+ ; let ret_ty = mkListTy unitTy
+ io_ret_ty = mkTyConApp ioTyCon [ret_ty]
tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts
- (mkCheckExpType io_ret_ty) ;
- names = collectLStmtsBinders stmts ;
- } ;
+ (mkCheckExpType io_ret_ty)
+ names = collectLStmtsBinders stmts
-- OK, we're ready to typecheck the stmts
- traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
- ((tc_stmts, ids), lie) <- captureTopConstraints $
+ ; traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty
+ ; ((tc_stmts, ids), lie) <- captureTopConstraints $
tc_io_stmts $ \ _ ->
- mapM tcLookupId names ;
+ mapM tcLookupId names
-- Look up the names right in the middle,
-- where they will all be in scope
-- Simplify the context
- traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
- const_binds <- checkNoErrs (simplifyInteractive lie) ;
+ ; traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty
+ ; const_binds <- checkNoErrs (simplifyInteractive lie)
-- checkNoErrs ensures that the plan fails if context redn fails
- traceTc "TcRnDriver.tcGhciStmts: done" empty ;
- let { -- mk_return builds the expression
- -- returnIO @ [()] [coerce () x, .., coerce () z]
- --
- -- Despite the inconvenience of building the type applications etc,
- -- this *has* to be done in type-annotated post-typecheck form
- -- because we are going to return a list of *polymorphic* values
- -- coerced to type (). If we built a *source* stmt
- -- return [coerce x, ..., coerce z]
- -- then the type checker would instantiate x..z, and we wouldn't
- -- get their *polymorphic* values. (And we'd get ambiguity errs
- -- if they were overloaded, since they aren't applied to anything.)
- ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
- (noLoc $ ExplicitList unitTy Nothing
- (map mk_item ids)) ;
- mk_item id = let ty_args = [idType id, unitTy] in
- nlHsApp (nlHsTyApp unsafeCoerceId
- (map getRuntimeRep ty_args ++ ty_args))
- (nlHsVar id) ;
+
+ ; traceTc "TcRnDriver.tcGhciStmts: done" empty
+
+ -- rec_expr is the expression
+ -- returnIO @ [()] [unsafeCoerce# () x, .., unsafeCorece# () z]
+ --
+ -- Despite the inconvenience of building the type applications etc,
+ -- this *has* to be done in type-annotated post-typecheck form
+ -- because we are going to return a list of *polymorphic* values
+ -- coerced to type (). If we built a *source* stmt
+ -- return [coerce x, ..., coerce z]
+ -- then the type checker would instantiate x..z, and we wouldn't
+ -- get their *polymorphic* values. (And we'd get ambiguity errs
+ -- if they were overloaded, since they aren't applied to anything.)
+
+ ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName
+ -- We use unsafeCoerce# here because of (U11) in
+ -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
+
+ ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $
+ noLoc $ ExplicitList unitTy Nothing $
+ map mk_item ids
+
+ mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id)
+ , getRuntimeRep unitTy
+ , idType id, unitTy]
+ `nlHsApp` nlHsVar id
stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
- } ;
- return (ids, mkHsDictLet (EvBinds const_binds) $
+
+ ; return (ids, mkHsDictLet (EvBinds const_binds) $
noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts)))
}
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index ea848d391f..ed9895074b 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -135,7 +135,7 @@ import qualified Data.Map as Map
import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
import Data.Data (Data)
import Data.Proxy ( Proxy (..) )
-import GHC.Exts ( unsafeCoerce# )
+import Unsafe.Coerce ( unsafeCoerce )
{-
************************************************************************
@@ -777,7 +777,7 @@ convertAnnotationWrapper fhv = do
else do
annotation_wrapper <- liftIO $ wormhole dflags fhv
return $ Right $
- case unsafeCoerce# annotation_wrapper of
+ case unsafeCoerce annotation_wrapper of
AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
-- Got the value and dictionaries: build the serialized value and
-- call it a day. We ensure that we seq the entire serialized value
@@ -1231,7 +1231,7 @@ runTH ty fhv = do
then do
-- Run it in the local TcM
hv <- liftIO $ wormhole dflags fhv
- r <- runQuasi (unsafeCoerce# hv :: TH.Q a)
+ r <- runQuasi (unsafeCoerce hv :: TH.Q a)
return r
else
-- Run it on the server. For an overview of how TH works with
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 9aee045c7e..78104576ab 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -138,7 +138,6 @@ synonymTyConsOfType ty
go_co (SubCo co) = go_co co
go_co (AxiomRuleCo _ cs) = go_co_s cs
- go_prov UnsafeCoerceProv = emptyNameEnv
go_prov (PhantomProv co) = go_co co
go_prov (ProofIrrelProv co) = go_co co
go_prov (PluginProv _) = emptyNameEnv
View Lorry Controller Status