Thread class sort members through CIclass; keep SClass sorts package-independent

src/comp/CFreeVars.hs

@@ -576,7 +576,7 @@ getFTCDn (Cinstance qt ds) =
 getFTCDn (CIinstance _ qt) = getFQTyCons qt
 getFTCDn (CIValueSign _ t) = getFQTyCons t
 getFTCDn (CItype i vs useposs) = S.empty
-getFTCDn (CIclass incoh ps i vs fds atfs useposs) =
+getFTCDn (CIclass incoh ps i vs fds atfs _ useposs) =
       S.unions (map getCPTyCons ps) `S.union` S.fromList (map ca_name atfs)
 
 getVDefIds :: CDefn -> [Id]
@@ -594,5 +594,5 @@ getVDefIds (Cclass _ _ i _ _ ats _) = iKName i : map ca_name ats
 getVDefIds (Cinstance _ _) = []
 getVDefIds (CIinstance _ _) = []
 getVDefIds (CItype i _ useposs) = [iKName i]
-getVDefIds (CIclass _ _ i _ _ _ useposs) = [iKName i]
+getVDefIds (CIclass _ _ i _ _ _ _ useposs) = [iKName i]
 getVDefIds (CIValueSign i _) = [i]

src/comp/CSyntax.hs

@@ -219,7 +219,15 @@ data CDefn
         | CIinstance Id CQType
         -- CItype is imported abstractly
         | CItype IdK [Id] [Position] -- positions of use that caused export
-        | CIclass (Maybe Bool) [CPred] IdK [Id] CFunDeps [CAssocDepFun] [Position] -- positions of use that caused export
+        -- The [Id] before the positions is the class tycon's sort member
+        -- list (field names ++ superclass ids) exactly as the defining
+        -- package's symtab computed it (MakeSymTab.getTI on Cclass), so
+        -- importers reconstruct an identical TIstruct SClass payload for
+        -- the class tycon even though the fields themselves are hidden.
+        -- Without it, importers could only rebuild the sort from the
+        -- superclass preds, leaving a payload divergent from the
+        -- defining compile's (papered over by SymTab.pickBetter).
+        | CIclass (Maybe Bool) [CPred] IdK [Id] CFunDeps [CAssocDepFun] [Id] [Position] -- positions of use that caused export
         | CIValueSign Id CQType
         deriving (Eq, Ord, Show)
 
@@ -237,7 +245,7 @@ instance NFData CDefn where
     rnf (CPragma pr) = rnf pr
     rnf (CIinstance i qt) = rnf2 i qt
     rnf (CItype i as poss) = rnf3 i as poss
-    rnf (CIclass incoh ps ik is fd ats poss) = rnf7 incoh ps ik is fd ats poss
+    rnf (CIclass incoh ps ik is fd ats ms poss) = rnf8 incoh ps ik is fd ats ms poss
     rnf (CIValueSign i ty) = rnf2 i ty
 
 -- Since IdPKind is only expected in some disjuncts of CDefn, we could
@@ -904,7 +912,7 @@ getName (Cstruct _ _ i _ _ _) = Right $ iKName i
 getName (Cclass _ _ i _ _ _ _) = Right $ iKName i
 getName (Cinstance qt _) = Left $ getPosition qt
 getName (CItype i _ _) = Right $ iKName i
-getName (CIclass _ _ i _ _ _ _) = Right $ iKName i
+getName (CIclass _ _ i _ _ _ _ _) = Right $ iKName i
 getName (CIinstance _ qt) = Left $ getPosition qt
 getName (CIValueSign i _) = Right i
 
@@ -928,7 +936,7 @@ isTDef (Cdata {}) = True
 isTDef (Cstruct _ _ _ _ _ _) = True
 isTDef (Cclass _ _ _ _ _ _ _) = True
 isTDef (CItype _ _ _) = True
-isTDef (CIclass _ _ _ _ _ _ _) = True
+isTDef (CIclass _ _ _ _ _ _ _ _) = True
 isTDef (CprimType _) = True
 isTDef _ = False
 
@@ -1181,7 +1189,7 @@ instance PPrint CDefn where
         t"instance" <+> ppConId d i <+> pPrint d 0 qt
     pPrint d p (CItype i as positions) =
         sep (t"type" <+> ppConIdK d i : map (nest 2 . ppVarId d) as)
-    pPrint d p (CIclass incoh ps ik is fd ats positions) =
+    pPrint d p (CIclass incoh ps ik is fd ats _ positions) =
         t_cls <+> ppPreds d ps (sep (ppConIdK d ik : map (nest 2 . ppVarId d) is)) <> ppFDs d fd
       where t_cls = case incoh of
                      Just False -> t"class coherent"

src/comp/GenABin.hs

@@ -34,7 +34,7 @@ import qualified Data.ByteString as B
 -- .ba file tag -- change this whenever the .ba format changes
 -- See also GenBin.header
 header :: [Byte]
-header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-ba-20260712-1"
+header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-ba-20260715-3"
 
 headerBS :: B.ByteString
 headerBS = B.pack header

src/comp/GenBin.hs

@@ -26,7 +26,7 @@ doTrace = elem "-trace-genbin" progArgs
 -- .bo file tag -- change this whenever the .bo format changes
 -- See also GenABin.header
 header :: [Byte]
-header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-bo-20260714-1"
+header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-bo-20260715-3"
 
 headerBS :: B.ByteString
 headerBS = B.pack header
@@ -92,8 +92,8 @@ instance Bin CDefn where
     writeBytes (Cprimitive i cqt) = do putI 5; toBin i; toBin cqt
     writeBytes (CprimType ik) = do putI 6; toBin ik
     writeBytes (CIinstance i cqt) = do putI 7; toBin i; toBin cqt
-    writeBytes (CIclass incoh ps ik is deps ats poss) =
-        do putI 8; toBin incoh; toBin ps; toBin ik; toBin is; toBin deps; toBin ats; toBin poss
+    writeBytes (CIclass incoh ps ik is deps ats ms poss) =
+        do putI 8; toBin incoh; toBin ps; toBin ik; toBin is; toBin deps; toBin ats; toBin ms; toBin poss
     writeBytes (CIValueSign i cqt) = do putI 9; toBin i; toBin cqt
     writeBytes (CItype ik is poss) = do putI 10; toBin ik; toBin is; toBin poss
     writeBytes (CPragma p) = do putI 11; toBin p
@@ -150,8 +150,9 @@ instance Bin CDefn where
                               is <- fromBin
                               deps <- fromBin
                               ats <- fromBin
+                              ms <- fromBin
                               poss <- fromBin
-                              return (CIclass incoh ps ik is deps ats poss)
+                              return (CIclass incoh ps ik is deps ats ms poss)
                      9  -> do when doTrace $ traceM ("CIValueSign")
                               i <- fromBin; cqt <- fromBin
                               return (CIValueSign i cqt)

src/comp/GenSign.hs

@@ -149,7 +149,7 @@ genSign errh exportAll symt
                           [ qualId currentPkg (ca_name at)
                           | Cclass  _ _ _ _ _ ats _ <- ss, at <- ats ] ++
                           [ ca_name at
-                          | CIclass _ _ _ _ _ ats _ <- ss, at <- ats ])
+                          | CIclass _ _ _ _ _ ats _ _ <- ss, at <- ats ])
 
         -- ssFVs: pairing of each def in ss with
         --        the type constructors referenced in it
@@ -160,7 +160,7 @@ genSign errh exportAll symt
 
         -- isHiddenDef: whether the constructors of the type def are visible
         isHiddenDef (Cdata { cd_visible =  vis }) = not vis
-        isHiddenDef (CIclass _ _ _ _ _ _ _) = True
+        isHiddenDef (CIclass _ _ _ _ _ _ _ _) = True
         isHiddenDef d = False
 
         -- useLoci: map from used variable to definitions where it's used
@@ -208,7 +208,7 @@ genSign errh exportAll symt
         -- given a used type constructor, find the type that it belongs to
         -- and return it in signature-file form (CItype or CIclass)
         tdef i = case findType symt i of
-                 Just (TypeInfo _ k vs (TIstruct SClass _) _) ->
+                 Just (TypeInfo _ k vs (TIstruct SClass ms) _) ->
                      case (findSClass symt (CTypeclass i)) of
                        Nothing -> internalError ("GenSign.genSign: " ++
                                                  "couldn't find class " ++
@@ -218,7 +218,7 @@ genSign errh exportAll symt
                            let rawAts = M.findWithDefault [] i classDeclaredAts
                                ats = map (\(CAssocDepFun name params rhs) ->
                                            CAssocDepFun (qualTId symt name) params rhs) rawAts
-                           in [classToIClass i k cl ats (findPoss i)]
+                           in [classToIClass i k cl ats ms (findPoss i)]
                  -- ATF type constructors are embedded in the enclosing class's
                  -- CAssocDepFun list and must not be re-exported as a standalone CItype.
                  Just (TypeInfo _ _ _ (TIatf {}) _) -> []
@@ -394,11 +394,17 @@ genDefSign s look currentPkg (Cclass incoh ps ik vs fds ats fs) =
       -- Matches GHC: exporting a class without (..) does not export its ATFs,
       -- but ATFs can be exported independently by naming them in the export list.
       indepExportedATFs = filter (\at -> look (ca_name at) /= Nothing) qats
+      -- The class tycon's sort member list, exactly as this package's
+      -- own symtab computed it (MakeSymTab.getTI on Cclass): field names
+      -- then superclass ids, in source form.  Threaded through CIclass
+      -- so importers build an identical TIstruct SClass payload for the
+      -- class tycon (the fields themselves stay hidden).
+      sortMembers = map cf_name fs ++ [ i' | CPred (CTypeclass i') _ <- ps ]
   in
     case look qi of
     Nothing -> []
     Just True -> [(Cclass incoh (map (qualPred s) ps) (qualIdK currentPkg s ik) vs fds qats (qualFields currentPkg s fs),[])]
-    Just False -> [(CIclass incoh (map (qualPred s) ps) (qualIdK currentPkg s ik) vs fds indepExportedATFs [getPosition ik], [])]
+    Just False -> [(CIclass incoh (map (qualPred s) ps) (qualIdK currentPkg s ik) vs fds indepExportedATFs sortMembers [getPosition ik], [])]
 genDefSign s look currentPkg d@(Cinstance qt@(CQType ps t) _) =
     -- trace (ppReadable (leftCon t, map leftCon (tyConArgs t))) $
     let tcs = leftTyCons (t : tyConArgs t) in
@@ -692,9 +698,10 @@ expandPkgExports symt impsigs exps =
 
 -- ---------------
 
-classToIClass :: Id -> Kind -> Class -> [CAssocDepFun] -> [Position] -> CDefn
+classToIClass :: Id -> Kind -> Class -> [CAssocDepFun] -> [Id] -> [Position]
+              -> CDefn
 classToIClass i k (Class { csig=tvs, super=ps, funDeps2=bss2,
-                           allowIncoherent = incoh}) ats poss =
+                           allowIncoherent = incoh}) ats ms poss =
     let getTVarId (TyVar i _ _) = i
         tvis = map getTVarId tvs
 
@@ -716,7 +723,7 @@ classToIClass i k (Class { csig=tvs, super=ps, funDeps2=bss2,
             in  foldr foldFn ([],[]) bis
         fds = map bsToFd bss2
     in
-        CIclass incoh ps' (IdKind i k) tvis fds ats poss
+        CIclass incoh ps' (IdKind i k) tvis fds ats ms poss
 
 -- ---------------
 -- Package usage tracking for unused import warnings
@@ -754,7 +761,7 @@ getPackagesUsedByExports currentPkg (CSignature _ _ _ defns) =
     getPackageFromDefn (Cdata { cd_name = IdKind i _ }) = getIdPackage i
     getPackageFromDefn (Cstruct _ _ (IdKind i _) _ _ _) = getIdPackage i
     getPackageFromDefn (Cclass _ _ (IdKind i _) _ _ _ _) = getIdPackage i
-    getPackageFromDefn (CIclass _ _ (IdKind i _) _ _ _ _) = getIdPackage i
+    getPackageFromDefn (CIclass _ _ (IdKind i _) _ _ _ _ _) = getIdPackage i
     getPackageFromDefn (CIValueSign i _) = getIdPackage i
     getPackageFromDefn (Cforeign i _ _ _ _) = getIdPackage i
     getPackageFromDefn (Cprimitive i _) = getIdPackage i

src/comp/InferKind.hs

@@ -26,7 +26,7 @@ inferKinds mi s ds = run $ do
             atf_entries <- mapM getATFIK ats
             return (ik_entry ++ concat atf_entries)
         get (CItype ik _ _) = getIK ik
-        get (CIclass _ _ ik _ _ _ _) = getIK ik
+        get (CIclass _ _ ik _ _ _ _ _) = getIK ik
         get (CprimType ik) = getIK ik
         get _ = return []
         getIK (IdK i) = do v <- newKVar (Just i); return [(i, v)]

src/comp/MakeSymTab.hs

@@ -94,7 +94,7 @@ mkSymTab errh (CPackage mi _ imps impsigs _ ds _) =
                  [ (iKName ik, vs, fds) | CImpSign _ _ (CSignature _ _ _ ids) <- impsigs,
                                           Cclass _ _ ik vs fds _ _ <- ids ] ++
                  [ (iKName ik, vs, fds) | CImpSign _ _ (CSignature _ _ _ ids) <- impsigs,
-                                          CIclass _ _ ik vs fds _ _ <- ids ] ++
+                                          CIclass _ _ ik vs fds _ _ _ <- ids ] ++
                  [ (qualId mi (iKName ik), vs, fds) | Cclass _ _ ik vs fds _ _ <- ds ]
 
         -- XXX imported fundeps don't need to be checked
@@ -738,10 +738,13 @@ mkTypeSyms errh mkQuals maybePackageName src_pkg iks defs qts s =
     let importedTypeInfos = concatMap (getTI errh maybePackageName src_pkg r iks) defs
         (cls, errss) =
             unzip $
-              [ getCls errh maybePackageName src_pkg iks r incoh ps ik vs fds ats ifs qts
+              [ getCls errh maybePackageName src_pkg iks r incoh ps ik vs fds ats ifs Nothing qts
                     | Cclass  incoh ps ik vs fds ats ifs <- defs ] ++
-              [ getCls errh maybePackageName src_pkg iks r incoh ps ik vs fds ats []  qts
-                    | CIclass incoh ps ik vs fds ats _   <- defs ]
+              -- The class's fields are hidden, but CIclass threads the
+              -- defining package's sort member list so tyConOf carries
+              -- the same TIstruct SClass payload as the defining compile.
+              [ getCls errh maybePackageName src_pkg iks r incoh ps ik vs fds ats [] (Just ms) qts
+                    | CIclass incoh ps ik vs fds ats ms _ <- defs ]
         r = addClasses mkQuals (addTypes mkQuals s importedTypeInfos) cls
     in  (r, concat errss)
 
@@ -778,12 +781,18 @@ getTI errh mi src_pkg _ iks (Cclass _ ps ik vs fds ats fs) =
 getTI _ mi src_pkg _ iks (CItype ik vs _) =
     [(i, TypeInfo (Just i) (getK iks ik) vs TIabstract src_pkg)]
   where i = qual mi (iKName ik)
-getTI _ mi src_pkg _ iks (CIclass _ ps ik vs _ ats _) =
+getTI _ mi src_pkg _ iks (CIclass _ _ ik vs _ ats ms _) =
     (i, TypeInfo (Just i) k vs ti src_pkg) : mkATFTIs mi src_pkg i vs ks ats
   where i = qual mi (iKName ik)
         k = getK iks ik
         ks = getArgKinds k
-        ti = TIstruct SClass (map (\ (CPred (CTypeclass i) _) -> i) ps)
+        -- ms is the defining package's sort member list (field names ++
+        -- superclass ids), threaded through the signature so this
+        -- TypeInfo's sort matches the defining compile's exactly: the
+        -- class tycon's TIstruct SClass payload should be
+        -- package-independent, not rebuilt (impoverished) from the
+        -- superclass preds alone.
+        ti = TIstruct SClass ms
 getTI _ mi src_pkg _ iks (CprimType ik) =
     [(i, TypeInfo (Just i) (getK iks ik) vs TIabstract src_pkg)]
   where i = qual mi (iKName ik)
@@ -939,8 +948,11 @@ getCls :: ErrorHandle -> Maybe Id -> Maybe Id -> M.Map Id Kind -> SymTab ->
           -- class components
           Maybe Bool -> [CPred] -> IdK -> [Id] -> CFunDeps -> [CAssocDepFun] ->
           CFields ->
+          -- sort member list override: for CIclass (fields hidden), the
+          -- defining package's list threaded through the signature
+          Maybe [Id] ->
           QInsts -> (Class, [EMsg])
-getCls errh mi src_pkg iks r incoh ps ik vs fds ats ifs qts =
+getCls errh mi src_pkg iks r incoh ps ik vs fds ats ifs msort qts =
     let k = getK iks ik
         i = iKName ik
         ks = getNK (genericLength vs) k
@@ -987,8 +999,10 @@ getCls errh mi src_pkg iks r incoh ps ik vs fds ats ifs qts =
             genInsts  = genInsts',
             getInsts  = getInsts',
             tyConOf = TyCon qi (Just k)
-                      (TIstruct SClass (map cf_name ifs ++
-                                        map (\ (CPred (CTypeclass i) _) -> i) ps)),
+                      (TIstruct SClass
+                           (fromMaybe (map cf_name ifs ++
+                                       map (\ (CPred (CTypeclass i) _) -> i) ps)
+                                      msort)),
             funDeps = bss,
             funDeps2 = bss2,
             inputPositions = pureInputPositions bss (length tvs),

src/comp/TypeAnalysis.hs

@@ -10,6 +10,7 @@ module TypeAnalysis (
                      ) where
 
 import Data.List(genericDrop, intercalate, (\\), nub, sortBy)
+import Data.Maybe(mapMaybe)
 import Data.Char(isUpper)
 
 import Util(doRight, itos)
@@ -285,7 +286,11 @@ analyzeType' flags symtab unqual_ty primpair_is_interface = doRight analyze (kin
             fields' = let isField (c:cs) | isUpper c = False
                           isField _                  = True
                       in  filter (isField . getIdBaseString) fields
-            fieldInfos = map (getFieldInfo symtab qi) fields'
+            -- The sort's member list names every method (it is package-
+            -- independent), but methods of a class exported without (..)
+            -- have no FieldInfo in this package's symtab -- they are
+            -- hidden, so skip them.
+            fieldInfos = mapMaybe (findFieldInfo symtab qi) fields'
             mkPair (FieldInfo _ _ _ (i :>: (Forall ks qt)) _ _ _ _) =
                 let as' = addGenVars orig_as ks
                     qt' = apType (expandSynN flags symtab . rmStructArg) (inst as' qt)