IType: intern all type nodes behind normalizing smart constructors; name/value intern keys

src/Libraries/Base1/Prelude.bs

@@ -4651,16 +4651,21 @@ class (WrapField :: $ -> * -> * -> *) name f w | name f -> w where
   saveFieldPortTypes :: StrArg name -> f -> Maybe Name__ -> String -> List String -> String -> Module ()
 
 instance (WrapMethod m w) => (WrapField name m w) where
-  toWrapField _ prefix argNames resultName =
-    let argBaseNames = methodArgBaseNames (_ :: m) prefix argNames 1
+  -- The name proxy is generated (GenWrap) with the interface field's
+  -- decl-side position, so port-name checking errors point at the
+  -- field in the user's interface declaration.
+  toWrapField np prefix argNames resultName =
+    let pos = getEvalPosition np
+        argBaseNames = methodArgBaseNames (_ :: m) pos prefix argNames 1
     in primMethod
-      (inputPortNames (_ :: m) argBaseNames)
-      (outputPortNames (_ :: m) resultName)
+      (inputPortNames (_ :: m) pos argBaseNames)
+      (outputPortNames (_ :: m) pos resultName)
       ∘ toWrapMethod
   fromWrapField _ = fromWrapMethod
-  saveFieldPortTypes _ _ modName prefix argNames resultName =
-    let baseNames = methodArgBaseNames (_ :: m) prefix argNames 1
-    in saveMethodPortTypes (_ :: m) modName baseNames resultName
+  saveFieldPortTypes np _ modName prefix argNames resultName =
+    let pos = getEvalPosition np
+        baseNames = methodArgBaseNames (_ :: m) pos prefix argNames 1
+    in saveMethodPortTypes (_ :: m) pos modName baseNames resultName
 
 -- TODO: It doesn't seem possible to have a PrimAction field in a synthesized interface,
 -- but this case was being handled in GenWrap.
@@ -4693,10 +4698,11 @@ instance (Bits a n) => WrapField name (Inout a) (Inout_ n) where
 -- and output ports; only the arg names are supplied separately.
 fromWrapNoInline :: (WrapMethod m w) => String -> List String -> w -> m
 fromWrapNoInline name argNames x =
-  let argBaseNames = methodArgBaseNames (_ :: m) name argNames 1
+  let pos = getStringPosition name  -- the noinline function's position
+      argBaseNames = methodArgBaseNames (_ :: m) pos name argNames 1
   in fromWrapMethod (primNoInline
-                       (inputPortNames (_ :: m) argBaseNames)
-                       (outputPortNames (_ :: m) name)
+                       (inputPortNames (_ :: m) pos argBaseNames)
+                       (outputPortNames (_ :: m) pos name)
                        x)
 
 class WrapMethod m w | m -> w where
@@ -4706,17 +4712,20 @@ class WrapMethod m w | m -> w where
   -- Convert a wrapper interface method to its synthesized interface method.
   fromWrapMethod :: w -> m
 
+  -- The Position__ argument is a term-side error position: the interface
+  -- field (or noinline function) whose ports are being checked.
+
   -- Compute the actual argument base names for a method, given the prefix and arg_names pragmas.
-  methodArgBaseNames :: m -> String -> List String -> Integer -> List String
+  methodArgBaseNames :: m -> Position__ -> String -> List String -> Integer -> List String
 
   -- Compute the list of input port names for each method argument, given the per-argument base names.
-  inputPortNames :: m -> List String -> List (List String)
+  inputPortNames :: m -> Position__ -> List String -> List (List String)
 
   -- Compute the list of output port names for a method, from the result base name.
-  outputPortNames :: m -> String -> List String
+  outputPortNames :: m -> Position__ -> String -> List String
 
   -- Save the port types for a method, given the module name, argument base names and result name.
-  saveMethodPortTypes :: m -> Maybe Name__ -> List String -> String -> Module ()
+  saveMethodPortTypes :: m -> Position__ -> Maybe Name__ -> List String -> String -> Module ()
 
 instance (WrapPorts (PortsOf a) pb, TupleSize (PortsOf a) n,
           PrimSeqTupleBits pb, WrapMethod b v) =>
@@ -4726,57 +4735,57 @@ instance (WrapPorts (PortsOf a) pb, TupleSize (PortsOf a) n,
   toWrapMethod f = toWrapMethod ∘ f ∘ unsplitPorts ∘ unpackPorts ∘ primDeepSeqTupleBits
   fromWrapMethod g = fromWrapMethod ∘ g ∘ primDeepSeqTupleBits ∘ packPorts ∘ splitPorts
 
-  methodArgBaseNames _ prefix (Cons h t) i = Cons
+  methodArgBaseNames _ pos prefix (Cons h t) i = Cons
     -- arg_names can start with a digit
     (if prefix == "" && (h == "" || not (isDigit $ stringHead h))
      then h
      else prefix +++ "_" +++ h)
-    (methodArgBaseNames (_ :: b) prefix t $ i + 1)
-  methodArgBaseNames _ prefix Nil i = Cons
+    (methodArgBaseNames (_ :: b) pos prefix t $ i + 1)
+  methodArgBaseNames _ pos prefix Nil i = Cons
     (prefix +++ "_" +++ integerToString i)
-    (methodArgBaseNames (_ :: b) prefix Nil $ i + 1)
+    (methodArgBaseNames (_ :: b) pos prefix Nil $ i + 1)
 
-  inputPortNames _ (Cons h t) =
-    Cons (filterZeroWidthPorts (_ :: PortsOf a) (checkPortNames (_ :: a) h))
-         (inputPortNames (_ :: b) t)
-  inputPortNames _ Nil = error "inputPortNames: empty arg names list"
+  inputPortNames _ pos (Cons h t) =
+    Cons (filterZeroWidthPorts (_ :: PortsOf a) (checkPortNames pos (_ :: a) h))
+         (inputPortNames (_ :: b) pos t)
+  inputPortNames _ _ Nil = error "inputPortNames: empty arg names list"
 
-  outputPortNames _ = outputPortNames (_ :: b)
+  outputPortNames _ pos = outputPortNames (_ :: b) pos
 
-  saveMethodPortTypes _ modName (Cons h t) result = do
-    savePortTypes (_ :: PortsOf a) modName $ checkPortNames (_ :: a) h
-    saveMethodPortTypes (_ :: b) modName t result
-  saveMethodPortTypes _ _ Nil _ = error "saveMethodPortTypes: empty arg names list"
+  saveMethodPortTypes _ pos modName (Cons h t) result = do
+    savePortTypes (_ :: PortsOf a) modName $ checkPortNames pos (_ :: a) h
+    saveMethodPortTypes (_ :: b) pos modName t result
+  saveMethodPortTypes _ _ _ Nil _ = error "saveMethodPortTypes: empty arg names list"
 
 instance (WrapPorts (PortsOf a) pb, TupleSize (PortsOf a) n,
           PrimSeqTupleBits pb) =>
     WrapMethod (ActionValue a) (ActionValue_ pb) where
   toWrapMethod = bitsToActionValue_ ∘ fmap (primDeepSeqTupleBits ∘ packPorts ∘ splitPorts)
   fromWrapMethod = fmap (unsplitPorts ∘ unpackPorts) ∘ bitsFromActionValue_
-  methodArgBaseNames _ _ Nil _ = Nil
-  methodArgBaseNames prx prefix argNames _ =
-    primError (getEvalPosition prx) $ integerToString (listLength argNames) +++
+  methodArgBaseNames _ _ _ Nil _ = Nil
+  methodArgBaseNames _ pos prefix argNames _ =
+    primError pos $ integerToString (listLength argNames) +++
     " excess arg_names provided for method " +++ prefix
-  inputPortNames _ Nil = Nil
-  inputPortNames _ (Cons _ _) = error "inputPortNames: uncaught excess arg names"
-  outputPortNames _ base = filterZeroWidthPorts (_ :: PortsOf a) $ checkPortNames (_ :: a) base
-  saveMethodPortTypes _ modName _ result =
-    savePortTypes (_ :: PortsOf a) modName $ checkPortNames (_ :: a) result
+  inputPortNames _ _ Nil = Nil
+  inputPortNames _ _ (Cons _ _) = error "inputPortNames: uncaught excess arg names"
+  outputPortNames _ pos base = filterZeroWidthPorts (_ :: PortsOf a) $ checkPortNames pos (_ :: a) base
+  saveMethodPortTypes _ pos modName _ result =
+    savePortTypes (_ :: PortsOf a) modName $ checkPortNames pos (_ :: a) result
 
 instance (WrapPorts (PortsOf a) pb, TupleSize (PortsOf a) n,
           PrimSeqTupleBits pb) =>
     WrapMethod a pb where
   toWrapMethod = primDeepSeqTupleBits ∘ packPorts ∘ splitPorts
   fromWrapMethod = unsplitPorts ∘ unpackPorts
-  methodArgBaseNames _ _ Nil _ = Nil
-  methodArgBaseNames prx prefix argNames _ =
-    primError (getEvalPosition prx) $ integerToString (listLength argNames) +++
+  methodArgBaseNames _ _ _ Nil _ = Nil
+  methodArgBaseNames _ pos prefix argNames _ =
+    primError pos $ integerToString (listLength argNames) +++
     " excess arg_names provided for method " +++ prefix
-  inputPortNames _ Nil = Nil
-  inputPortNames _ (Cons _ _) = error "inputPortNames: uncaught excess arg names"
-  outputPortNames _ base = filterZeroWidthPorts (_ :: PortsOf a) $ checkPortNames (_ :: a) base
-  saveMethodPortTypes _ modName _ result =
-    savePortTypes (_ :: PortsOf a) modName $ checkPortNames (_ :: a) result
+  inputPortNames _ _ Nil = Nil
+  inputPortNames _ _ (Cons _ _) = error "inputPortNames: uncaught excess arg names"
+  outputPortNames _ pos base = filterZeroWidthPorts (_ :: PortsOf a) $ checkPortNames pos (_ :: a) base
+  saveMethodPortTypes _ pos modName _ result =
+    savePortTypes (_ :: PortsOf a) modName $ checkPortNames pos (_ :: a) result
 
 class WrapPorts p pb | p -> pb where
   -- Convert from a tuple of Port values to a tuple of bits.
@@ -4854,12 +4863,13 @@ instance PrimSeqTupleBits () where
 -- Compute the list port names for type 'a' given a base name.
 -- Check that the number of port names matches the number of ports.
 -- This error should only occur if there is an error in a SplitPorts instance.
-checkPortNames :: (SplitPorts a p, TupleSize p n) => a -> String -> List String
-checkPortNames proxy base =
+-- The position is the interface field (or noinline function) under check.
+checkPortNames :: (SplitPorts a p, TupleSize p n) => Position__ -> a -> String -> List String
+checkPortNames pos proxy base =
   let pn = portNames proxy base
   in
     if listLength pn /= valueOf n
-    then primError (getEvalPosition proxy) $
+    then primError pos $
       "SplitPorts: " +++ base +++ " has " +++ integerToString (valueOf n) +++
       " ports, but " +++ integerToString (listLength pn) +++ " port names were given"
     else pn

src/Libraries/Makefile

@@ -23,14 +23,21 @@ BUILD_ORDER= \
 # Find files to build tags
 SRCS = $(shell find . -name "*.bsv")
 
-.PHONY: all install clean full_clean
+.PHONY: all build tconcheck install clean full_clean
 
 all: install TAGS
 
 build:
 	$(foreach dir, $(BUILD_ORDER), $(MAKE) -C $(dir) $@ &&) true
 
-install: build
+# Check that the compiler's handwritten tycon constants agree with the
+# just-built Prelude (see src/comp/tconcheck.hs); drift fails the build
+TCONCHECK ?= $(BINDIR)/tconcheck
+
+tconcheck: build
+	$(TCONCHECK) $(BUILDDIR)
+
+install: build tconcheck
 	install -d $(INSTALLDIR)
 	install -m644 $(BUILDDIR)/* $(INSTALLDIR)
 

src/comp/.gitignore

@@ -18,6 +18,7 @@ bsc2bsv
 bsv2bsc
 showrules
 vcdcheck
+tconcheck
 
 # Ignore TAGS files
 TAGS

src/comp/BinData.hs

@@ -44,6 +44,7 @@ import SchedInfo(SchedInfo(..), MethodConflictInfo(..),
 import Pragma
 import ASyntax
 import ISyntax
+import IType(iTypeNodeId)
 import Wires
 import CType
 import IntLit
@@ -259,21 +260,31 @@ type_key (TDefMonad _) = internalError $ "BinData.type_key: TDefMonad"
 
 -- We don't use the IType as a key since the Eq instance for some
 -- variants (like ITForAll) ignore Kinds in the equality test.
-data ITypeKey = ITKF IdKey IKind ITypeKey
-              | ITKA ITypeKey ITypeKey
+--
+-- Interior nodes (ITAp/ITForAll) are hash-consed (see IType): the
+-- intern table guarantees one node per exact-serialization-granularity
+-- key, so the intern unique IS the node's structural identity, and the
+-- deep structural key that used to be built here (which re-walked
+-- shared subtrees once per path, exponentially many times on
+-- DAG-shaped types) is unnecessary.  Leaves are not interned and keep
+-- their exact keys.  The unique never enters the byte stream: it only
+-- keys the writer-local sharing map, and the emitted bytes remain
+-- structure plus first-occurrence LOCAL indices, fully
+-- content-determined.
+data ITypeKey = ITKI {-# UNPACK #-} !Int
               | ITKV IdKey
               | ITKC IdKey IKind TISort
               | ITKN Integer
               | ITKS FString
   deriving (Eq, Ord, Show)
 
 itype_key :: IType -> ITypeKey
-itype_key (ITForAll i k t) = ITKF (id_key i) k (itype_key t)
-itype_key (ITAp t1 t2)     = ITKA (itype_key t1) (itype_key t2)
-itype_key (ITVar i)        = ITKV (id_key i)
-itype_key (ITCon i k s)    = ITKC (id_key i) k s
-itype_key (ITNum n)        = ITKN n
-itype_key (ITStr s)        = ITKS s
+itype_key t@(ITForAll _ _ _) = ITKI (iTypeNodeId t)
+itype_key t@(ITAp _ _)       = ITKI (iTypeNodeId t)
+itype_key (ITVar i)          = ITKV (id_key i)
+itype_key (ITCon i k s)      = ITKC (id_key i) k s
+itype_key (ITNum n)          = ITKN n
+itype_key (ITStr s)          = ITKS s
 
 -- -------------------------------------------------------------
 -- The Out monad makes it easy to generate composite BinData

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/CType.hs

@@ -201,12 +201,39 @@ instance Eq Type where
 instance Eq TyVar where
     TyVar i n _ == TyVar i' n' _  =  (n, i) == (n', i')
 
+-- TyCon comparison and the one-tycon-per-qualified-name invariant
+--
+-- BSC's front end enforces one type constructor per qualified name, so a
+-- qualified Id determines its (kind, sort) payload.  The invariant holds
+-- ONLY for qualified names: unqualified TyCons exist during scope
+-- resolution, where the same base name may denote different constructors.
+-- The tconcheck build step (src/comp/tconcheck.hs) verifies the compiler's
+-- handwritten copies of Prelude tycon payloads against the compiled
+-- Prelude, keeping the invariant checkable.
+--
+-- Eq is therefore scoped by qualification:
+--  * both ids qualified: the invariant's regime.  Comparison is by Id;
+--    the payloads are determined by the name (checker-verified), so a
+--    payload comparison would be a dead tail.
+--  * either id unqualified: resolution-era fuzz, where the invariant is
+--    undefined; the kind comparison is kept as a hedge.
+--
+-- Two pre-existing quirks, both deliberate and unchanged:
+--  * Eq is non-transitive: qualEq compares by base name alone when either
+--    side is unqualified, so P.T == T and T == Q.T but P.T /= Q.T.
+--  * Eq and Ord disagree: Ord compares the full qualifier on both sides
+--    (a lawful total order), while Eq admits the qualEq fuzz.  Containers
+--    key on Ord.
 instance Eq TyCon where
-    TyCon i k _ == TyCon i' k' _  =  qualEq i i' && k == k'
+    TyCon i k _ == TyCon i' k' _  =  qualEq i i' && (bothQualified i i' || k == k')
     TyNum i _   == TyNum i' _     =  i == i'
     TyStr s _   == TyStr s' _     =  s == s'
     _           == _              =  False
 
+-- both ids carry a package qualifier (see the invariant note above)
+bothQualified :: Id -> Id -> Bool
+bothQualified i i' = not (isUnqualId i) && not (isUnqualId i')
+
 -- Ord instances
 
 instance Ord Type where
@@ -220,7 +247,15 @@ instance Ord TyVar where
     TyVar i n _ `compare` TyVar i' n' _  =  (n, i) `compare` (n', i')
 
 instance Ord TyCon where
-    TyCon i k _ `compare` TyCon i' k' _   =  (getIdBase i, getIdQual i, k) `compare` (getIdBase i', getIdQual i', k')
+    -- lexicographic on (base, qual); within a (base, qual) bucket either
+    -- both ids are qualified -- unique by the invariant documented at Eq,
+    -- so EQ without consulting the kinds -- or both are unqualified, where
+    -- the kind comparison is kept, as in Eq.  This remains a lawful total
+    -- order.
+    TyCon i k _ `compare` TyCon i' k' _   =
+        case (getIdBase i, getIdQual i) `compare` (getIdBase i', getIdQual i') of
+          EQ -> if bothQualified i i' then EQ else compare k k'
+          o  -> o
     TyCon _ _ _ `compare` TyNum _  _      =  LT
     TyCon _ _ _ `compare` TyStr _  _      =  LT
     TyNum _ _   `compare` TyCon _  _  _   =  GT
@@ -520,7 +555,7 @@ splitTAp (TAp f a) = let (l,as) = splitTAp f
                      in  (l,as ++ [a])
 splitTAp t = (t,[])
 
--- Copied from normITAp
+-- Copied from the IType reduction rules (now IType.mkITAp)
 normTAp :: Type -> Type -> Type
 normTAp (TAp (TCon (TyCon op _ _)) (TCon (TyNum x xpos))) (TCon (TyNum y ypos))
         | isJust (res) = cTNum (fromJust res) (getPosition op)

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-4"
 
 headerBS :: B.ByteString
 headerBS = B.pack header