[Git][ghc/ghc][wip/with2-primop] Fix it
Ben Gamari
gitlab at gitlab.haskell.org
Thu Mar 26 02:49:35 UTC 2020
Ben Gamari pushed to branch wip/with2-primop at Glasgow Haskell Compiler / GHC
Commits:
85d077c3 by Ben Gamari at 2020-03-26T02:49:26+00:00
Fix it
- - - - -
8 changed files:
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/basicTypes/MkId.hs
- compiler/prelude/PrelNames.hs
- compiler/prelude/primops.txt.pp
- libraries/base/GHC/Exts.hs
- libraries/base/GHC/ForeignPtr.hs
- libraries/ghc-compact/GHC/Compact/Serialized.hs
Changes:
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -24,7 +24,7 @@ import GHC.Core.Op.OccurAnal
import GHC.Driver.Types
import PrelNames
import MkId ( realWorldPrimId, mkPrimOpId )
-import PrimOp ( PrimOp(TouchOp, WithOp) )
+import PrimOp ( PrimOp(TouchOp) )
import GHC.Core.Utils
import GHC.Core.Arity
import GHC.Core.FVs
@@ -861,7 +861,7 @@ cpeApp top_env expr
cpe_app env (Var f) [CpeApp (Type argRep), CpeApp (Type argTy),
CpeApp (Type resultRep), CpeApp (Type resultTy),
CpeApp x, CpeApp k, CpeApp s0] _depth
- | Just WithOp <- isPrimOpId_maybe f
+ | f `hasKey` withKey
= do { let voidRepTy = primRepToRuntimeRep VoidRep
; b0 <- newVar $ mkTyConApp (tupleTyCon Unboxed 2)
[voidRepTy, resultRep, realWorldStatePrimTy, resultTy]
@@ -877,13 +877,17 @@ cpeApp top_env expr
(DataAlt (tupleDataCon Unboxed 2), [stateVar, resultVar], rhs)
expr = Case (App k s0) b0 (varType b0) [stateResultAlt s1 y rhs1]
- rhs1 = Case (mkApps (Var touchId) [Type argTy, x, Var s1]) s1 (varType s1) [(DEFAULT, [], rhs2)]
- rhs2 = mkApps (Var $ dataConWrapId $ tupleDataCon Unboxed 2) [Var s2, Var y]
+ rhs1 =
+ let scrut = mkApps (Var touchId) [Type argRep, Type argTy, x, Var s1]
+ in Case scrut s2 (mkTupleTy Unboxed [realWorldStatePrimTy, resultTy]) [(DEFAULT, [], rhs2)]
+
+ -- (# s2, y #)
+ rhs2 = mkApps (Var $ dataConWrapId $ tupleDataCon Unboxed 2) [Type voidRepTy, Type resultRep, Type realWorldStatePrimTy, Type resultTy, Var s2, Var y]
; cpeBody env expr
}
- cpe_app env (Var f) args n
- | Just WithOp <- isPrimOpId_maybe f
+ cpe_app _env (Var f) args n
+ | f `hasKey` withKey
= pprPanic "cpe_app" (ppr f $$ ppr args $$ ppr n)
cpe_app env (Var v) args depth
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -344,10 +344,6 @@ emitPrimOp dflags = \case
GetSizeofMutableByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do
emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
-
- WithOp -> \args ->
- pprPanic "WithOp" (ppr args)
-
-- #define touchzh(o) /* nothing */
TouchOp -> \args@[_] -> opAllDone $ \res@[] -> do
emitPrimCall res MO_Touch args
=====================================
compiler/basicTypes/MkId.hs
=====================================
@@ -157,6 +157,7 @@ ghcPrimIds
, seqId
, magicDictId
, coerceId
+ , withId
, proxyHashId
]
@@ -1334,7 +1335,7 @@ another gun with which to shoot yourself in the foot.
nullAddrName, seqName,
realWorldName, voidPrimIdName, coercionTokenName,
- magicDictName, coerceName, proxyName :: Name
+ magicDictName, coerceName, proxyName, withName :: Name
nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
@@ -1343,12 +1344,35 @@ coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionT
magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId
coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId
proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId
+withName = mkWiredInIdName gHC_PRIM (fsLit "with#") withKey withId
lazyIdName, oneShotName, noinlineIdName :: Name
lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId
oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId
noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId
+------------------------------------------------
+withId :: Id
+withId
+ = pcMiscPrelId withName ty noCafIdInfo
+ where
+ -- with# :: forall (rep_a :: RuntimeRep) (a :: TYPE rep_a)
+ -- (rep_r :: RuntimeRep) (r :: TYPE rep_r).
+ -- a
+ -- -> (State# RealWorld -> (# State# RealWorld, r #))
+ -- -> State# RealWorld
+ -- -> (# State# RealWorld, r #)
+ --
+ rep_a = runtimeRep1TyVar
+ a = openAlphaTyVar
+ rep_r = runtimeRep2TyVar
+ r = openBetaTyVar
+ ty = mkInvForAllTys [rep_a, a, rep_r, r]
+ $ mkVisFunTys [mkTyVarTy a, cont_ty, realWorldStatePrimTy] result_ty
+ cont_ty = realWorldStatePrimTy `mkVisFunTy` result_ty
+ -- (# State# RealWorld, r #)
+ result_ty = mkTupleTy Unboxed [realWorldStatePrimTy, mkTyVarTy r]
+
------------------------------------------------
proxyHashId :: Id
proxyHashId
=====================================
compiler/prelude/PrelNames.hs
=====================================
@@ -2198,12 +2198,13 @@ rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 101
runMainKey = mkPreludeMiscIdUnique 102
-thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique
+thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, withKey :: Unique
thenIOIdKey = mkPreludeMiscIdUnique 103
lazyIdKey = mkPreludeMiscIdUnique 104
assertErrorIdKey = mkPreludeMiscIdUnique 105
oneShotKey = mkPreludeMiscIdUnique 106
runRWKey = mkPreludeMiscIdUnique 107
+withKey = mkPreludeMiscIdUnique 108
traceKey :: Unique
traceKey = mkPreludeMiscIdUnique 109
=====================================
compiler/prelude/primops.txt.pp
=====================================
@@ -3025,12 +3025,6 @@ primop FinalizeWeakOp "finalizeWeak#" GenPrimOp
has_side_effects = True
out_of_line = True
-primop WithOp "with#" GenPrimOp
- o -> (State# RealWorld -> (# State# RealWorld, p #)) -> State# RealWorld -> (# State# RealWorld, p #)
- { TODO. }
- with
- code_size = { 0 }
-
primop TouchOp "touch#" GenPrimOp
o -> State# RealWorld -> State# RealWorld
with
@@ -3400,6 +3394,10 @@ pseudoop "proxy#"
{ Witness for an unboxed {\tt Proxy#} value, which has no runtime
representation. }
+pseudoop "with#"
+ o -> (State# RealWorld -> (# State# RealWorld, p #)) -> State# RealWorld -> (# State# RealWorld, p #)
+ { TODO. }
+
pseudoop "seq"
a -> b -> b
{ The value of {\tt seq a b} is bottom if {\tt a} is bottom, and
=====================================
libraries/base/GHC/Exts.hs
=====================================
@@ -61,9 +61,6 @@ module GHC.Exts
-- * Running 'RealWorld' state thread
runRW#,
- -- * Keeping values alive
- with#,
-
-- * Safe coercions
--
-- | These are available from the /Trustworthy/ module "Data.Coerce" as well
=====================================
libraries/base/GHC/ForeignPtr.hs
=====================================
@@ -55,7 +55,6 @@ import GHC.Base
import GHC.IORef
import GHC.STRef ( STRef(..) )
import GHC.Ptr ( Ptr(..), FunPtr(..) )
-import GHC.Prim ( with# )
import Unsafe.Coerce ( unsafeCoerce, unsafeCoerceUnlifted )
@@ -410,7 +409,7 @@ withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
-- or from the object pointed to by the
-- 'ForeignPtr', using the operations from the
-- 'Storable' class.
-withForeignPtr fo@(ForeignPtr _ r) f = IO $ \s ->
+withForeignPtr fo@(ForeignPtr _ r) f = IO $ \s ->
case f (unsafeForeignPtrToPtr fo) of
IO action# -> with# r action# s
=====================================
libraries/ghc-compact/GHC/Compact/Serialized.hs
=====================================
@@ -30,7 +30,6 @@ import GHC.Prim
import GHC.Types
import GHC.Word (Word8)
-import GHC.Magic (with#)
import GHC.Ptr (Ptr(..), plusPtr)
import Control.Concurrent
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85d077c3d2ecd2479d7244adf33159f7aaa73b7d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85d077c3d2ecd2479d7244adf33159f7aaa73b7d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200325/2e9b0eec/attachment-0001.html>
More information about the ghc-commits
mailing list