[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: JS: support levity-polymorphic datatypes (#22360,#22291)

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Mon Jun 26 17:48:08 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
8d6574bc by Sylvain Henry at 2023-06-26T13:15:06-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

- - - - -
5578bbad by Matthew Pickering at 2023-06-26T13:15:43-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

- - - - -
4427e9cf by Matthew Pickering at 2023-06-26T13:15:43-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.

- - - - -
522bd584 by Arnaud Spiwack at 2023-06-26T13:16:33-04:00
Revert "Avoid desugaring non-recursive lets into recursive lets"

This (temporary) reverts commit 3e80c2b40213bebe302b1bd239af48b33f1b30ef.

Fixes #23550

- - - - -
ae0402c0 by Greg Steuck at 2023-06-26T13:47:56-04:00
Remove undefined FP_PROG_LD_BUILD_ID from configure.ac's

- - - - -
5c050e68 by Torsten Schmits at 2023-06-26T13:47:56-04:00
Remove duplicate link label in linear types docs

- - - - -


28 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
- configure.ac
- distrib/configure.ac.in
- docs/users_guide/exts/linear_types.rst
- 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


=====================================
configure.ac
=====================================
@@ -487,7 +487,6 @@ CFLAGS="$CFLAGS $GccUseLdOpt"
 AC_SUBST([LdCmd])
 
 FP_PROG_LD_IS_GNU
-FP_PROG_LD_BUILD_ID
 FP_PROG_LD_NO_COMPACT_UNWIND
 FP_PROG_LD_FILELIST
 


=====================================
distrib/configure.ac.in
=====================================
@@ -130,7 +130,6 @@ CFLAGS="$CFLAGS $GccUseLdOpt"
 AC_SUBST([LdCmd])
 
 FP_PROG_LD_IS_GNU
-FP_PROG_LD_BUILD_ID
 FP_PROG_LD_NO_COMPACT_UNWIND
 FP_PROG_LD_FILELIST
 


=====================================
docs/users_guide/exts/linear_types.rst
=====================================
@@ -14,7 +14,7 @@ Linear types
 warts, and bad error messages; everything down to the syntax is
 subject to change**.  See, in particular,
 :ref:`linear-types-limitations` below. We encourage you to experiment
-with this extension and report issues in the GHC bug tracker `the GHC
+with this extension and report issues in `the GHC
 bug tracker <https://gitlab.haskell.org/ghc/ghc/issues>`__, adding the
 tag ``LinearTypes``.
 


=====================================
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/e09175c47ac69b2d21d49cf7b68ab4f02dd0371d...5c050e68110c9a2b706c66dead860156778e56f6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e09175c47ac69b2d21d49cf7b68ab4f02dd0371d...5c050e68110c9a2b706c66dead860156778e56f6
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/a927d6df/attachment-0001.html>


More information about the ghc-commits mailing list