[Git][ghc/ghc][wip/T18570] Make selectors mult. polym. when possible
Sjoerd Visscher (@trac-sjoerd_visscher)
gitlab at gitlab.haskell.org
Mon Dec 9 14:05:37 UTC 2024
Sjoerd Visscher pushed to branch wip/T18570 at Glasgow Haskell Compiler / GHC
Commits:
bb329d8a by Sjoerd Visscher at 2024-12-09T15:05:21+01:00
Make selectors mult. polym. when possible
- - - - -
4 changed files:
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- + testsuite/tests/linear/should_compile/LinearRecordSelector.hs
- testsuite/tests/linear/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -43,7 +43,7 @@ module GHC.Core.DataCon (
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs,
dataConInstUnivs,
- dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,
+ dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, dataConOtherFieldsAllMultMany,
dataConSrcBangs,
dataConSourceArity, dataConRepArity,
dataConIsInfix,
@@ -1392,6 +1392,11 @@ dataConFieldType_maybe :: DataCon -> FieldLabelString
dataConFieldType_maybe con label
= find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con))
+
+dataConOtherFieldsAllMultMany :: DataCon -> FieldLabelString -> Bool
+dataConOtherFieldsAllMultMany con label
+ = all (\(fld, mult) -> flLabel fld == label || isManyTy mult) (dcFields con `zip` (scaledMult <$> dcOrigArgTys con))
+
-- | Strictness/unpack annotations, from user; or, for imported
-- DataCons, from the interface file
-- The list is in one-to-one correspondence with the arity of the 'DataCon'
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -34,7 +34,7 @@ import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Bind( tcValBinds )
import GHC.Tc.Utils.TcType
-import GHC.Builtin.Types( unitTy )
+import GHC.Builtin.Types( unitTy, manyDataConTy, multiplicityTy )
import GHC.Builtin.Uniques ( mkBuiltinUnique )
import GHC.Hs
@@ -73,6 +73,7 @@ import GHC.Types.Name.Env
import GHC.Types.Name.Reader ( mkRdrUnqual )
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Types.Var (mkTyVar)
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Unique.Set
@@ -917,17 +918,23 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- thus suppressing making a binding
-- A slight hack!
+ all_fields_unrestricted = all all_unrestricted all_cons
+ where
+ all_unrestricted PatSynCon{} = False
+ all_unrestricted (RealDataCon dc) = dataConOtherFieldsAllMultMany dc lbl
+
sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
- | otherwise = mkForAllTys (tyVarSpecToBinders sel_tvbs) $
+ | otherwise = mkForAllTys (tyVarSpecToBinders (sel_tvbs ++ mult_tvb)) $
-- Urgh! See Note [The stupid context] in GHC.Core.DataCon
- mkPhiTy (conLikeStupidTheta con1) $
+ mkPhiTy (conLikeStupidTheta con1) $
-- req_theta is empty for normal DataCon
- mkPhiTy req_theta $
- mkVisFunTyMany data_ty $
- -- Record selectors are always typed with Many. We
- -- could improve on it in the case where all the
- -- fields in all the constructor have multiplicity Many.
+ mkPhiTy req_theta $
+ mkVisFunTy sel_mult data_ty $
field_ty
+ (mult_tvb, sel_mult) = if complete && all_fields_unrestricted
+ then ([mkForAllTyBinder InferredSpec mult_var], mkTyVarTy mult_var)
+ else ([], manyDataConTy)
+ mult_var = mkTyVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "m")) multiplicityTy
-- make the binding: sel (C2 { fld = x }) = x
-- sel (C7 { fld = x }) = x
@@ -953,7 +960,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- Add catch-all default case unless the case is exhaustive
-- We do this explicitly so that we get a nice error message that
-- mentions this particular record selector
- deflt | all dealt_with all_cons = []
+ deflt | complete = []
| otherwise = [mkSimpleMatch match_ctxt (wrapGenSpan [genWildPat])
(genLHsApp
(genHsVar (getName rEC_SEL_ERROR_ID))
@@ -968,6 +975,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- data instance T Int a where
-- A :: { fld :: Int } -> T Int Bool
-- B :: { fld :: Int } -> T Int Char
+ complete = all dealt_with all_cons
dealt_with :: ConLike -> Bool
dealt_with (PatSynCon _) = False -- We can't predict overlap
dealt_with con@(RealDataCon dc)
=====================================
testsuite/tests/linear/should_compile/LinearRecordSelector.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE LinearTypes, DataKinds #-}
+module LinearRecordSelector where
+
+import GHC.Exts (Multiplicity(..))
+
+data Test = A { test :: Int, test2 %Many :: String } | B { test :: Int, test3 %Many :: Char }
+
+test1 :: Test %1 -> Int
+test1 a = test a
+
+testM :: Test -> Int
+testM = test
=====================================
testsuite/tests/linear/should_compile/all.T
=====================================
@@ -36,6 +36,7 @@ test('LinearTH3', normal, compile, [''])
test('LinearTH4', req_th, compile, [''])
test('LinearHole', normal, compile, [''])
test('LinearDataConSections', normal, compile, [''])
+test('LinearRecordSelector', normal, compile, [''])
test('T18731', normal, compile, [''])
test('T19400', unless(compiler_debugged(), skip), compile, [''])
test('T20023', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb329d8a81c1e08bd4ce09b39a4a8e2fe7a09fa5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb329d8a81c1e08bd4ce09b39a4a8e2fe7a09fa5
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/20241209/f3296881/attachment-0001.html>
More information about the ghc-commits
mailing list