[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: JS: support levity-polymorphic datatypes (#22360,#22291)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jun 26 12:04:24 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
39c3fdd2 by Sylvain Henry at 2023-06-26T08:04:08-04:00
JS: support levity-polymorphic datatypes (#22360,#22291)
- thread knowledge about levity into PrimRep instead of panicking
- JS: remove assumption that unlifted heap objects are rts objects (TVar#, etc.)
Doing this also fixes #22291 (test added).
There is a small performance hit (~1% more allocations).
Metric Increase:
T18698a
T18698b
- - - - -
bc21e5d5 by Matthew Pickering at 2023-06-26T08:04:09-04:00
MR Review Template: Mention "Blocked on Review" label
In order to improve our MR review processes we now have the label
"Blocked on Review" which allows people to signal that a MR is waiting
on a review to happen.
See: https://mail.haskell.org/pipermail/ghc-devs/2023-June/021255.html
- - - - -
ccc139ef by Matthew Pickering at 2023-06-26T08:04:09-04:00
Move MR template to Default.md
This makes it more obvious what you have to modify to affect the default
template rather than looking in the project settings.
- - - - -
e09175c4 by Arnaud Spiwack at 2023-06-26T08:04:11-04:00
Revert "Avoid desugaring non-recursive lets into recursive lets"
This (temporary) reverts commit 3e80c2b40213bebe302b1bd239af48b33f1b30ef.
Fixes #23550
- - - - -
25 changed files:
- .gitlab/merge_request_templates/merge-request.md → .gitlab/merge_request_templates/Default.md
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Cmm/Utils.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/ArgRep.hs
- compiler/GHC/StgToCmm/Lit.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/StgToJS/Types.hs
- compiler/GHC/StgToJS/Utils.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/RepType.hs
- rts/js/rts.js
- rts/js/verify.js
- testsuite/tests/ghci/should_run/T16096.stdout
- testsuite/tests/primops/should_run/all.T
- + testsuite/tests/rep-poly/T22291.hs
- + testsuite/tests/rep-poly/T22291b.hs
- testsuite/tests/rep-poly/all.T
- testsuite/tests/unlifted-datatypes/should_compile/all.T
Changes:
=====================================
.gitlab/merge_request_templates/merge-request.md → .gitlab/merge_request_templates/Default.md
=====================================
@@ -25,9 +25,9 @@ If you have any questions don't hesitate to open your merge request and inquire
in a comment. If your patch isn't quite done yet please do add prefix your MR
title with `WIP:`.
-Once your change is ready please remove the `WIP:` tag and wait for review. If
+Once your change is ready please remove the `WIP:` tag and wait for review. If
no one has offerred review in a few days then please leave a comment mentioning
- at triagers.
+ at triagers and apply the ~"Blocked on Review" label.
[notes]: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/coding-style#comments-in-the-source-code
[adding test]: https://gitlab.haskell.org/ghc/ghc/wikis/building/running-tests/adding
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -1636,10 +1636,11 @@ boxedRepDataCon = pcSpecialDataCon boxedRepDataConName
where
-- See Note [Getting from RuntimeRep to PrimRep] in RepType
prim_rep_fun [lev]
- = case tyConPromDataConInfo (tyConAppTyCon lev) of
- Levity Lifted -> [LiftedRep]
- Levity Unlifted -> [UnliftedRep]
- _ -> pprPanic "boxedRepDataCon" (ppr lev)
+ = case tyConAppTyCon_maybe lev of
+ Just tc -> case tyConPromDataConInfo tc of
+ Levity l -> [BoxedRep (Just l)]
+ _ -> [BoxedRep Nothing]
+ Nothing -> [BoxedRep Nothing]
prim_rep_fun args
= pprPanic "boxedRepDataCon" (ppr args)
=====================================
compiler/GHC/Cmm/Utils.hs
=====================================
@@ -98,8 +98,7 @@ import GHC.Cmm.Dataflow.Collections
primRepCmmType :: Platform -> PrimRep -> CmmType
primRepCmmType platform = \case
VoidRep -> panic "primRepCmmType:VoidRep"
- LiftedRep -> gcWord platform
- UnliftedRep -> gcWord platform
+ BoxedRep _ -> gcWord platform
IntRep -> bWord platform
WordRep -> bWord platform
Int8Rep -> b8
@@ -142,8 +141,7 @@ typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty)
primRepForeignHint :: PrimRep -> ForeignHint
primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
-primRepForeignHint LiftedRep = AddrHint
-primRepForeignHint UnliftedRep = AddrHint
+primRepForeignHint (BoxedRep _) = AddrHint
primRepForeignHint IntRep = SignedHint
primRepForeignHint Int8Rep = SignedHint
primRepForeignHint Int16Rep = SignedHint
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -124,7 +124,7 @@ module GHC.Core.TyCon(
tyConRepModOcc,
-- * Primitive representations of Types
- PrimRep(..), PrimElemRep(..),
+ PrimRep(..), PrimElemRep(..), Levity(..),
primElemRepToPrimRep,
isVoidRep, isGcPtrRep,
primRepSizeB,
@@ -1536,8 +1536,7 @@ See Note [RuntimeRep and PrimRep] in GHC.Types.RepType.
-- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType".
data PrimRep
= VoidRep
- | LiftedRep
- | UnliftedRep -- ^ Unlifted pointer
+ | BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value
| Int8Rep -- ^ Signed, 8-bit value
| Int16Rep -- ^ Signed, 16-bit value
| Int32Rep -- ^ Signed, 32-bit value
@@ -1548,7 +1547,7 @@ data PrimRep
| Word32Rep -- ^ Unsigned, 32 bit value
| Word64Rep -- ^ Unsigned, 64 bit value
| WordRep -- ^ Unsigned, word-sized value
- | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')
+ | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use 'BoxedRep')
| FloatRep
| DoubleRep
| VecRep Int PrimElemRep -- ^ A vector
@@ -1575,42 +1574,47 @@ instance Outputable PrimElemRep where
instance Binary PrimRep where
put_ bh VoidRep = putByte bh 0
- put_ bh LiftedRep = putByte bh 1
- put_ bh UnliftedRep = putByte bh 2
- put_ bh Int8Rep = putByte bh 3
- put_ bh Int16Rep = putByte bh 4
- put_ bh Int32Rep = putByte bh 5
- put_ bh Int64Rep = putByte bh 6
- put_ bh IntRep = putByte bh 7
- put_ bh Word8Rep = putByte bh 8
- put_ bh Word16Rep = putByte bh 9
- put_ bh Word32Rep = putByte bh 10
- put_ bh Word64Rep = putByte bh 11
- put_ bh WordRep = putByte bh 12
- put_ bh AddrRep = putByte bh 13
- put_ bh FloatRep = putByte bh 14
- put_ bh DoubleRep = putByte bh 15
- put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per
+ put_ bh (BoxedRep ml) = case ml of
+ -- cheaper storage of the levity than using
+ -- the Binary (Maybe Levity) instance
+ Nothing -> putByte bh 1
+ Just Lifted -> putByte bh 2
+ Just Unlifted -> putByte bh 3
+ put_ bh Int8Rep = putByte bh 4
+ put_ bh Int16Rep = putByte bh 5
+ put_ bh Int32Rep = putByte bh 6
+ put_ bh Int64Rep = putByte bh 7
+ put_ bh IntRep = putByte bh 8
+ put_ bh Word8Rep = putByte bh 9
+ put_ bh Word16Rep = putByte bh 10
+ put_ bh Word32Rep = putByte bh 11
+ put_ bh Word64Rep = putByte bh 12
+ put_ bh WordRep = putByte bh 13
+ put_ bh AddrRep = putByte bh 14
+ put_ bh FloatRep = putByte bh 15
+ put_ bh DoubleRep = putByte bh 16
+ put_ bh (VecRep n per) = putByte bh 17 *> put_ bh n *> put_ bh per
get bh = do
h <- getByte bh
case h of
0 -> pure VoidRep
- 1 -> pure LiftedRep
- 2 -> pure UnliftedRep
- 3 -> pure Int8Rep
- 4 -> pure Int16Rep
- 5 -> pure Int32Rep
- 6 -> pure Int64Rep
- 7 -> pure IntRep
- 8 -> pure Word8Rep
- 9 -> pure Word16Rep
- 10 -> pure Word32Rep
- 11 -> pure Word64Rep
- 12 -> pure WordRep
- 13 -> pure AddrRep
- 14 -> pure FloatRep
- 15 -> pure DoubleRep
- 16 -> VecRep <$> get bh <*> get bh
+ 1 -> pure $ BoxedRep Nothing
+ 2 -> pure $ BoxedRep (Just Lifted)
+ 3 -> pure $ BoxedRep (Just Unlifted)
+ 4 -> pure Int8Rep
+ 5 -> pure Int16Rep
+ 6 -> pure Int32Rep
+ 7 -> pure Int64Rep
+ 8 -> pure IntRep
+ 9 -> pure Word8Rep
+ 10 -> pure Word16Rep
+ 11 -> pure Word32Rep
+ 12 -> pure Word64Rep
+ 13 -> pure WordRep
+ 14 -> pure AddrRep
+ 15 -> pure FloatRep
+ 16 -> pure DoubleRep
+ 17 -> VecRep <$> get bh <*> get bh
_ -> pprPanic "Binary:PrimRep" (int (fromIntegral h))
instance Binary PrimElemRep where
@@ -1622,9 +1626,8 @@ isVoidRep VoidRep = True
isVoidRep _other = False
isGcPtrRep :: PrimRep -> Bool
-isGcPtrRep LiftedRep = True
-isGcPtrRep UnliftedRep = True
-isGcPtrRep _ = False
+isGcPtrRep (BoxedRep _) = True
+isGcPtrRep _ = False
-- A PrimRep is compatible with another iff one can be coerced to the other.
-- See Note [Bad unsafe coercion] in GHC.Core.Lint for when are two types coercible.
@@ -1665,8 +1668,7 @@ primRepSizeB platform = \case
FloatRep -> fLOAT_SIZE
DoubleRep -> dOUBLE_SIZE
AddrRep -> platformWordSizeInBytes platform
- LiftedRep -> platformWordSizeInBytes platform
- UnliftedRep -> platformWordSizeInBytes platform
+ BoxedRep _ -> platformWordSizeInBytes platform
VoidRep -> 0
(VecRep len rep) -> len * primElemRepSizeB platform rep
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -117,56 +117,10 @@ dsTopLHsBinds binds
top_level_err bindsType (L loc bind)
= putSrcSpanDs (locA loc) $
diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)
-{-
-Note [Return bindings in dependency order]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The desugarer tries to desugar a non-recursive let-binding to a collection of
-one or more non-recursive let-bindings. The alternative is to generate a letrec
-and wait for the occurrence analyser to sort it out later, but it is pretty easy
-to arrange that the [(Id,CoreExpr)] pairs returned by dsLHsBinds are returned in
-dependency order
-
-It's most important for linear types, where non-recursive lets can be linear
-whereas recursive-let can't. Since we check the output of the desugarer for
-linearity (see also Note [Linting linearity]), desugaring non-recursive lets to
-recursive lets would break linearity checks. An alternative is to refine the
-typing rule for recursive lets so that we don't have to care (see in particular
-#23218 and #18694), but the outcome of this line of work is still unclear. In
-the meantime, being a little precise in the desugarer is cheap. (paragraph
-written on 2023-06-09)
-
-In dsLHSBinds (and dependencies), a single binding can be desugared to multiple
-bindings. For instance because the source binding has the {-# SPECIALIZE #-}
-pragma. In:
-
-f _ = …
- where
- {-# SPECIALIZE g :: F Int -> F Int #-}
- g :: C a => F a -> F a
- g _ = …
-
-The g binding desugars to
-
-let {
- $sg = … } in
-
- g
- [RULES: "SPEC g" g @Int $dC = $sg]
- g = …
-In order to avoid generating a letrec that will immediately be reordered, we
-make sure to return the binding in dependency order [$sg, g].
-
-This only matters when the source binding is non-recursive as recursive bindings
-are always desugared to a single mutually recursive block.
-
--}
-- | Desugar all other kind of bindings, Ids of strict binds are returned to
-- later be forced in the binding group body, see Note [Desugar Strict binds]
---
--- Invariant: the desugared bindings are returned in dependency order,
--- see Note [Return bindings in dependency order]
dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds binds
= do { ds_bs <- mapBagM dsLHsBind binds
@@ -180,9 +134,6 @@ dsLHsBind (L loc bind) = do dflags <- getDynFlags
putSrcSpanDs (locA loc) $ dsHsBind dflags bind
-- | Desugar a single binding (or group of recursive binds).
---
--- Invariant: the desugared bindings are returned in dependency order,
--- see Note [Return bindings in dependency order]
dsHsBind :: DynFlags
-> HsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
@@ -312,7 +263,7 @@ dsAbsBinds dflags tyvars dicts exports
(isDefaultMethod prags)
(dictArity dicts) rhs
- ; return (force_vars', fromOL spec_binds ++ [main_bind]) } }
+ ; return (force_vars', main_bind : fromOL spec_binds) } }
-- Another common case: no tyvars, no dicts
-- In this case we can have a much simpler desugaring
@@ -371,7 +322,7 @@ dsAbsBinds dflags tyvars dicts exports
-- Kill the INLINE pragma because it applies to
-- the user written (local) function. The global
-- Id is just the selector. Hmm.
- ; return (fromOL spec_binds ++ [(global', rhs)]) } }
+ ; return ((global', rhs) : fromOL spec_binds) } }
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -160,20 +160,17 @@ ds_val_bind (is_rec, binds) body
-- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType
case prs of
[] -> return body
- _ -> return (mkLets (mk_binds is_rec prs) body') }
- -- We can make a non-recursive let because we make sure to return
- -- the bindings in dependency order in dsLHsBinds, see Note [Return bindings in dependency order]
-
--- | Helper function. You can use the result of 'mk_binds' with 'mkLets' for
--- instance.
---
--- * @'mk_binds' 'Recursive' binds@ makes a single mutually-recursive
--- bindings with all the rhs/lhs pairs in @binds@
--- * @'mk_binds' 'NonRecursive' binds@ makes one non-recursive binding
--- for each rhs/lhs pairs in @binds@
-mk_binds :: RecFlag -> [(b, (Expr b))] -> [Bind b]
-mk_binds Recursive binds = [Rec binds]
-mk_binds NonRecursive binds = map (uncurry NonRec) binds
+ _ -> return (Let (Rec prs) body') }
+ -- Use a Rec regardless of is_rec.
+ -- Why? Because it allows the binds to be all
+ -- mixed up, which is what happens in one rare case
+ -- Namely, for an AbsBind with no tyvars and no dicts,
+ -- but which does have dictionary bindings.
+ -- See notes with GHC.Tc.Solver.inferLoop [NO TYVARS]
+ -- It turned out that wrapping a Rec here was the easiest solution
+ --
+ -- NB The previous case dealt with unlifted bindings, so we
+ -- only have to deal with lifted ones now; so Rec is ok
------------------
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -174,10 +174,9 @@ isDllConApp platform ext_dyn_refs this_mod con args
--
-- The coercion argument here gets VoidRep
isAddrRep :: PrimRep -> Bool
-isAddrRep AddrRep = True
-isAddrRep LiftedRep = True
-isAddrRep UnliftedRep = True
-isAddrRep _ = False
+isAddrRep AddrRep = True
+isAddrRep (BoxedRep _) = True -- FIXME: not true for JavaScript
+isAddrRep _ = False
-- | Type of an @StgArg@
--
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -1603,8 +1603,7 @@ primRepToFFIType platform r
AddrRep -> FFIPointer
FloatRep -> FFIFloat
DoubleRep -> FFIDouble
- LiftedRep -> FFIPointer
- UnliftedRep -> FFIPointer
+ BoxedRep _ -> FFIPointer
_ -> pprPanic "primRepToFFIType" (ppr r)
where
(signed_word, unsigned_word) = case platformWordSize platform of
@@ -1629,9 +1628,8 @@ mkDummyLiteral platform pr
AddrRep -> LitNullAddr
DoubleRep -> LitDouble 0
FloatRep -> LitFloat 0
- LiftedRep -> LitNullAddr
- UnliftedRep -> LitNullAddr
- _ -> pprPanic "mkDummyLiteral" (ppr pr)
+ BoxedRep _ -> LitNullAddr
+ _ -> pprPanic "mkDummyLiteral" (ppr pr)
-- Convert (eg)
=====================================
compiler/GHC/StgToCmm/ArgRep.hs
=====================================
@@ -69,8 +69,7 @@ argRepString V64 = "V64"
toArgRep :: Platform -> PrimRep -> ArgRep
toArgRep platform rep = case rep of
VoidRep -> V
- LiftedRep -> P
- UnliftedRep -> P
+ BoxedRep _ -> P
IntRep -> N
WordRep -> N
Int8Rep -> N -- Gets widened to native word width for calls
=====================================
compiler/GHC/StgToCmm/Lit.hs
=====================================
@@ -53,8 +53,7 @@ cgLit (LitString s) =
cgLit (LitRubbish _ rep) =
case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants]
VoidRep -> panic "cgLit:VoidRep" -- ditto
- LiftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId
- UnliftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId
+ BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId
AddrRep -> cgLit LitNullAddr
VecRep n elem -> do
platform <- getPlatform
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Types.Literal
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.CostCentre
+import GHC.Types.RepType (mightBeFunTy)
import GHC.Stg.Syntax
@@ -204,7 +205,7 @@ genApp ctx i args
-- no args and Id can't be a function: just enter it
| [] <- args
, idFunRepArity i == 0
- , not (mightBeAFunction (idType i))
+ , not (mightBeFunTy (idType i))
= do
enter_id <- genIdArg i >>=
\case
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -382,7 +382,6 @@ verifyRuntimeReps xs = do
go _ _ = pprPanic "verifyRuntimeReps: inconsistent sizes" (ppr xs)
ver j PtrV = v "h$verify_rep_heapobj" [j]
ver j IntV = v "h$verify_rep_int" [j]
- ver j RtsObjV = v "h$verify_rep_rtsobj" [j]
ver j DoubleV = v "h$verify_rep_double" [j]
ver j ArrV = v "h$verify_rep_arr" [j]
ver _ _ = mempty
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -340,7 +340,6 @@ rts' s =
, TxtI "h$vt_double" ||= toJExpr IntV
, TxtI "h$vt_long" ||= toJExpr LongV
, TxtI "h$vt_addr" ||= toJExpr AddrV
- , TxtI "h$vt_rtsobj" ||= toJExpr RtsObjV
, TxtI "h$vt_obj" ||= toJExpr ObjV
, TxtI "h$vt_arr" ||= toJExpr ArrV
, jFun (TxtI "h$bh") (bhStats s True)
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -150,13 +150,13 @@ instance ToJExpr CIStatic where
-- | Free variable types
data VarType
- = PtrV -- ^ pointer = reference to heap object (closure object)
+ = PtrV -- ^ pointer = reference to heap object (closure object), lifted or not.
+ -- Can also be some RTS object (e.g. TVar#, MVar#, MutVar#, Weak#)
| VoidV -- ^ no fields
| DoubleV -- ^ A Double: one field
| IntV -- ^ An Int (32bit because JS): one field
| LongV -- ^ A Long: two fields one for the upper 32bits, one for the lower (NB: JS is little endian)
| AddrV -- ^ a pointer not to the heap: two fields, array + index
- | RtsObjV -- ^ some RTS object from GHCJS (for example TVar#, MVar#, MutVar#, Weak#)
| ObjV -- ^ some JS object, user supplied, be careful around these, can be anything
| ArrV -- ^ boxed array
deriving stock (Eq, Ord, Enum, Bounded, Show)
=====================================
compiler/GHC/StgToJS/Utils.hs
=====================================
@@ -38,7 +38,6 @@ module GHC.StgToJS.Utils
, assocPrimReps
, assocIdPrimReps
, assocIdExprs
- , mightBeAFunction
, mkArityTag
, toTypeList
-- * Stg Utils
@@ -147,11 +146,11 @@ assignCoerce1 _x _y = pprPanic "assignCoerce1"
-- | Assign p2 to p1 with optional coercion
assignCoerce :: TypedExpr -> TypedExpr -> JStat
-- Coercion between StablePtr# and Addr#
-assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr UnliftedRep [sptr]) = mconcat
+assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr (BoxedRep (Just Unlifted)) [sptr]) = mconcat
[ a_val |= var "h$stablePtrBuf"
, a_off |= sptr
]
-assignCoerce (TypedExpr UnliftedRep [sptr]) (TypedExpr AddrRep [_a_val, a_off]) =
+assignCoerce (TypedExpr (BoxedRep (Just Unlifted)) [sptr]) (TypedExpr AddrRep [_a_val, a_off]) =
sptr |= a_off
assignCoerce p1 p2 = assignTypedExprs [p1] [p2]
@@ -258,8 +257,7 @@ uTypeVt ut
primRepVt :: HasDebugCallStack => PrimRep -> VarType
primRepVt VoidRep = VoidV
-primRepVt LiftedRep = PtrV -- fixme does ByteArray# ever map to this?
-primRepVt UnliftedRep = RtsObjV
+primRepVt (BoxedRep _) = PtrV -- fixme does ByteArray# ever map to this?
primRepVt IntRep = IntV
primRepVt Int8Rep = IntV
primRepVt Int16Rep = IntV
@@ -316,26 +314,26 @@ primTypeVt t = case tyConAppTyCon_maybe (unwrapType t) of
| tc == word64PrimTyCon -> LongV
| tc == addrPrimTyCon -> AddrV
| tc == stablePtrPrimTyCon -> AddrV
- | tc == stableNamePrimTyCon -> RtsObjV
+ | tc == stableNamePrimTyCon -> PtrV
| tc == statePrimTyCon -> VoidV
| tc == proxyPrimTyCon -> VoidV
| tc == realWorldTyCon -> VoidV
- | tc == threadIdPrimTyCon -> RtsObjV
- | tc == weakPrimTyCon -> RtsObjV
+ | tc == threadIdPrimTyCon -> PtrV
+ | tc == weakPrimTyCon -> PtrV
| tc == arrayPrimTyCon -> ArrV
| tc == smallArrayPrimTyCon -> ArrV
| tc == byteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal
| tc == mutableArrayPrimTyCon -> ArrV
| tc == smallMutableArrayPrimTyCon -> ArrV
| tc == mutableByteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal
- | tc == mutVarPrimTyCon -> RtsObjV
- | tc == mVarPrimTyCon -> RtsObjV
- | tc == tVarPrimTyCon -> RtsObjV
- | tc == bcoPrimTyCon -> RtsObjV -- unsupported?
- | tc == stackSnapshotPrimTyCon -> RtsObjV
- | tc == ioPortPrimTyCon -> RtsObjV -- unsupported?
+ | tc == mutVarPrimTyCon -> PtrV
+ | tc == mVarPrimTyCon -> PtrV
+ | tc == tVarPrimTyCon -> PtrV
+ | tc == bcoPrimTyCon -> PtrV -- unsupported?
+ | tc == stackSnapshotPrimTyCon -> PtrV
+ | tc == ioPortPrimTyCon -> PtrV -- unsupported?
| tc == anyTyCon -> PtrV
- | tc == compactPrimTyCon -> ObjV -- unsupported?
+ | tc == compactPrimTyCon -> PtrV -- unsupported?
| tc == eqPrimTyCon -> VoidV -- coercion token?
| tc == eqReprPrimTyCon -> VoidV -- role
| tc == unboxedUnitTyCon -> VoidV -- Void#
@@ -392,17 +390,6 @@ assocIdPrimReps i = assocPrimReps (idPrimReps i)
assocIdExprs :: Id -> [JExpr] -> [TypedExpr]
assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es)
--- | Return False only if we are *sure* it's a data type
--- Look through newtypes etc as much as possible
-mightBeAFunction :: HasDebugCallStack => Type -> Bool
-mightBeAFunction ty
- | [LiftedRep] <- typePrimRep ty
- , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
- , isDataTyCon tc
- = False
- | otherwise
- = True
-
mkArityTag :: Int -> Int -> Int
mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8)
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -20,6 +20,7 @@ types that
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
module GHC.Types.Basic (
LeftOrRight(..),
@@ -1956,12 +1957,20 @@ isKindLevel KindLevel = True
data Levity
= Lifted
| Unlifted
- deriving Eq
+ deriving (Data,Eq,Ord,Show)
instance Outputable Levity where
ppr Lifted = text "Lifted"
ppr Unlifted = text "Unlifted"
+instance Binary Levity where
+ put_ bh = \case
+ Lifted -> putByte bh 0
+ Unlifted -> putByte bh 1
+ get bh = getByte bh >>= \case
+ 0 -> pure Lifted
+ _ -> pure Unlifted
+
mightBeLifted :: Maybe Levity -> Bool
mightBeLifted (Just Unlifted) = False
mightBeLifted _ = True
=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -315,8 +315,10 @@ typeSlotTy ty = case typePrimRep ty of
primRepSlot :: PrimRep -> SlotTy
primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep")
-primRepSlot LiftedRep = PtrLiftedSlot
-primRepSlot UnliftedRep = PtrUnliftedSlot
+primRepSlot (BoxedRep mlev) = case mlev of
+ Nothing -> panic "primRepSlot: levity polymorphic BoxedRep"
+ Just Lifted -> PtrLiftedSlot
+ Just Unlifted -> PtrUnliftedSlot
primRepSlot IntRep = WordSlot
primRepSlot Int8Rep = WordSlot
primRepSlot Int16Rep = WordSlot
@@ -333,8 +335,8 @@ primRepSlot DoubleRep = DoubleSlot
primRepSlot (VecRep n e) = VecSlot n e
slotPrimRep :: SlotTy -> PrimRep
-slotPrimRep PtrLiftedSlot = LiftedRep
-slotPrimRep PtrUnliftedSlot = UnliftedRep
+slotPrimRep PtrLiftedSlot = BoxedRep (Just Lifted)
+slotPrimRep PtrUnliftedSlot = BoxedRep (Just Unlifted)
slotPrimRep Word64Slot = Word64Rep
slotPrimRep WordSlot = WordRep
slotPrimRep DoubleSlot = DoubleRep
@@ -635,8 +637,10 @@ runtimeRepPrimRep_maybe rr_ty
primRepToRuntimeRep :: PrimRep -> RuntimeRepType
primRepToRuntimeRep rep = case rep of
VoidRep -> zeroBitRepTy
- LiftedRep -> liftedRepTy
- UnliftedRep -> unliftedRepTy
+ BoxedRep mlev -> case mlev of
+ Nothing -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep"
+ Just Lifted -> liftedRepTy
+ Just Unlifted -> unliftedRepTy
IntRep -> intRepDataConTy
Int8Rep -> int8RepDataConTy
Int16Rep -> int16RepDataConTy
@@ -688,7 +692,7 @@ mightBeFunTy :: Type -> Bool
-- AK: It would be nice to figure out and document the difference
-- between this and isFunTy at some point.
mightBeFunTy ty
- | [LiftedRep] <- typePrimRep ty
+ | [BoxedRep _] <- typePrimRep ty
, Just tc <- tyConAppTyCon_maybe (unwrapType ty)
, isDataTyCon tc
= False
=====================================
rts/js/rts.js
=====================================
@@ -245,7 +245,7 @@ function h$printcl(i) {
r += " ";
switch(cl.i[i]) {
case h$vt_ptr:
- r += "[ Ptr :: " + d["d"+idx].f.n + "]";
+ r += "[ Ptr :: " + d["d"+idx] + "]";
idx++;
break;
case h$vt_void:
@@ -267,10 +267,6 @@ function h$printcl(i) {
r += "(" + d["d"+idx].length + "," + d["d"+(idx+1)] + " :: ptr)";
idx+=2;
break;
- case h$vt_rtsobj:
- r += "(" + d["d"+idx].toString() + " :: RTS object)";
- idx++;
- break;
default:
r += "unknown field: " + cl.i[i];
}
=====================================
rts/js/verify.js
=====================================
@@ -113,7 +113,7 @@ function h$verify_rep_is_bytearray(o) {
function h$verify_rep_heapobj(o) {
// possibly an unlifted rts object
// XXX: we should do a different check for these
- if(h$verify_rep_is_rtsobj(o)) return;
+ if(h$verify_rep_is_rtsobj(o)) return h$verify_rep_rtsobj(o);
// unboxed rep
if(typeof o === 'number' || typeof o === 'boolean') return;
// boxed rep
=====================================
testsuite/tests/ghci/should_run/T16096.stdout
=====================================
@@ -1,6 +1,6 @@
==================== Desugared ====================
-let {
+letrec {
x :: [GHC.Types.Int]
[LclId]
x = let {
@@ -11,7 +11,7 @@ let {
x :: [GHC.Types.Int]
[LclId]
x = GHC.Enum.enumFrom @GHC.Types.Int $dEnum (GHC.Types.I# 1#); } in
- x } in
+ x; } in
GHC.Base.returnIO
@[GHC.Types.Any]
(GHC.Types.:
@@ -27,7 +27,7 @@ GHC.Base.returnIO
==================== Desugared ====================
-let {
+letrec {
x :: [GHC.Types.Int]
[LclId]
x = let {
@@ -38,7 +38,7 @@ let {
x :: [GHC.Types.Int]
[LclId]
x = GHC.Enum.enumFrom @GHC.Types.Int $dEnum (GHC.Types.I# 1#); } in
- x } in
+ x; } in
GHC.Base.returnIO
@[GHC.Types.Any]
(GHC.Types.:
=====================================
testsuite/tests/primops/should_run/all.T
=====================================
@@ -8,7 +8,7 @@ test('T10481', exit_code(1), compile_and_run, [''])
test('T10678',
[ collect_stats('bytes allocated',5),
only_ways(['normal']),
- js_broken(22360)
+ js_broken(22361)
],
compile_and_run, ['-O'])
test('T11296', normal, compile_and_run, [''])
=====================================
testsuite/tests/rep-poly/T22291.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+
+module T22291 where
+
+import GHC.Exts
+
+foo :: forall (lev :: Levity) (a :: TYPE (BoxedRep lev)). Addr# -> (# a #)
+foo x = addrToAny# x
=====================================
testsuite/tests/rep-poly/T22291b.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE DataKinds, MagicHash, UnboxedTuples #-}
+
+module T22291b where
+
+import GHC.Exts
+
+indexArray :: forall l (a :: TYPE (BoxedRep l)). Array# a -> Int# -> (# a #)
+indexArray = indexArray#
=====================================
testsuite/tests/rep-poly/all.T
=====================================
@@ -15,7 +15,7 @@ test('T18170b', [extra_files(['T18170c.hs']), expect_broken(19893)], multimod_co
# T18170b isn't actually broken, but it causes a Core Lint error
# even though the program is (correctly) rejected by the typechecker
test('T18481', normal, compile, [''])
-test('T18481a', js_broken(22360), compile, [''])
+test('T18481a', normal, compile, [''])
test('T18534', normal, compile_fail, [''])
test('T19615', normal, compile_fail, [''])
test('T19709a', normal, compile_fail, [''])
@@ -29,8 +29,10 @@ test('T20423b', normal, compile_fail, [''])
test('T20426', normal, compile_fail, [''])
test('T21239', normal, compile, [''])
test('T21544', normal, compile, ['-Wno-deprecated-flags'])
+test('T22291', normal, compile, [''])
+test('T22291b', normal, compile, [''])
-test('EtaExpandDataCon', js_broken(22360), compile, ['-O'])
+test('EtaExpandDataCon', normal, compile, ['-O'])
test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags'])
test('EtaExpandStupid2', normal, compile_fail, ['-Wno-deprecated-flags'])
test('LevPolyLet', normal, compile_fail, [''])
@@ -43,7 +45,7 @@ test('RepPolyBackpack1', normal, backpack_compile_fail, [''])
test('RepPolyBackpack2', req_c, backpack_run, [''])
test('RepPolyBackpack3', normal, backpack_compile_fail, [''])
test('RepPolyBackpack4', req_c, backpack_run, [''])
-test('RepPolyBackpack5', js_broken(22360), backpack_run, [''])
+test('RepPolyBackpack5', js_broken(22361), backpack_run, [''])
test('RepPolyBinder', normal, compile_fail, [''])
test('RepPolyCase1', normal, compile_fail, [''])
test('RepPolyClassMethod', normal, compile_fail, [''])
@@ -79,8 +81,8 @@ test('RepPolySum', normal, compile_fail, [''])
test('RepPolyTuple', normal, compile_fail, [''])
test('RepPolyTupleSection', normal, compile_fail, [''])
test('RepPolyUnboxedPatterns', normal, compile_fail, [''])
-test('RepPolyUnliftedDatatype', js_broken(22360), compile, [''])
-test('RepPolyUnliftedDatatype2', js_broken(22261), compile, ['-O'])
+test('RepPolyUnliftedDatatype', normal, compile, [''])
+test('RepPolyUnliftedDatatype2', normal, compile, ['-O'])
test('RepPolyUnliftedNewtype', normal, compile,
['-fno-warn-partial-type-signatures -fno-warn-deprecated-flags'])
test('RepPolyWildcardPattern', normal, compile_fail, [''])
=====================================
testsuite/tests/unlifted-datatypes/should_compile/all.T
=====================================
@@ -1,4 +1,4 @@
test('UnlDataMonoSigs', normal, compile, [''])
-test('UnlDataPolySigs', js_broken(22360), compile, [''])
+test('UnlDataPolySigs', normal, compile, [''])
test('UnlDataFams', normal, compile, [''])
-test('UnlDataUsersGuide', js_broken(22360), compile, [''])
+test('UnlDataUsersGuide', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7f598a99ee7a2fb2bd0a0e5ee6261086e3fbbb36...e09175c47ac69b2d21d49cf7b68ab4f02dd0371d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7f598a99ee7a2fb2bd0a0e5ee6261086e3fbbb36...e09175c47ac69b2d21d49cf7b68ab4f02dd0371d
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/20230626/52cfd9f2/attachment-0001.html>
More information about the ghc-commits
mailing list