Merge pull request #5534 from unisonweb/cp/fix-unit-tags

Ensure units are all created with matching tags

unison-runtime/src/Unison/Runtime/Builtin.hs

@@ -38,6 +38,7 @@ import Unison.Runtime.Builtin.Types
 import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName)
 import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), unboxedTypeTagToInt)
 import Unison.Runtime.Stack qualified as Closure
+import Unison.Runtime.TypeTags qualified as TT
 import Unison.Symbol
 import Unison.Type qualified as Ty
 import Unison.Util.EnumContainers as EC
@@ -1709,7 +1710,7 @@ declareForeign sand op func = do
      in (Map.insert func (sand, code) funcs)
 
 unitValue :: Val
-unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0)
+unitValue = BoxedVal $ Closure.Enum Ty.unitRef TT.unitTag
 
 natValue :: Word64 -> Val
 natValue w = NatVal w

unison-runtime/src/Unison/Runtime/Foreign/Function.hs

@@ -137,7 +137,7 @@ import Unison.Builtin.Decls qualified as Ty
 import Unison.Prelude hiding (Text, some)
 import Unison.Reference
 import Unison.Referent (Referent, pattern Ref)
-import Unison.Runtime.ANF (Code, PackedTag (..), Value, internalBug)
+import Unison.Runtime.ANF (Code, Value, internalBug)
 import Unison.Runtime.ANF qualified as ANF
 import Unison.Runtime.ANF.Rehash (checkGroupHashes)
 import Unison.Runtime.ANF.Serialize qualified as ANF
@@ -150,6 +150,7 @@ import Unison.Runtime.Foreign qualified as F
 import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..))
 import Unison.Runtime.MCode
 import Unison.Runtime.Stack
+import Unison.Runtime.TypeTags qualified as TT
 import Unison.Symbol
 import Unison.Type
   ( iarrayRef,
@@ -1764,10 +1765,10 @@ toUnisonPair ::
 toUnisonPair (x, y) =
   DataC
     Ty.pairRef
-    (PackedTag 0)
-    [BoxedVal $ wr x, BoxedVal $ DataC Ty.pairRef (PackedTag 0) [BoxedVal $ wr y, BoxedVal $ un]]
+    TT.pairTag
+    [BoxedVal $ wr x, BoxedVal $ DataC Ty.pairRef TT.pairTag [BoxedVal $ wr y, BoxedVal $ un]]
   where
-    un = DataC Ty.unitRef (PackedTag 0) []
+    un = DataC Ty.unitRef TT.unitTag []
     wr z = Foreign $ wrapBuiltin z
 
 unwrapForeignClosure :: Closure -> a

unison-runtime/src/Unison/Runtime/Interface.hs

@@ -143,6 +143,7 @@ import Unison.Runtime.Machine
 import Unison.Runtime.Pattern
 import Unison.Runtime.Serialize as SER
 import Unison.Runtime.Stack
+import Unison.Runtime.TypeTags qualified as TT
 import Unison.Symbol (Symbol)
 import Unison.Syntax.HashQualified qualified as HQ (toText)
 import Unison.Syntax.NamePrinter (prettyHashQualified)
@@ -1063,7 +1064,7 @@ executeMainComb ::
   CCache ->
   IO (Either (Pretty ColorText) ())
 executeMainComb init cc = do
-  rSection <- resolveSection cc $ Ins (Pack RF.unitRef (PackedTag 0) ZArgs) $ Call True init init (VArg1 0)
+  rSection <- resolveSection cc $ Ins (Pack RF.unitRef TT.unitTag ZArgs) $ Call True init init (VArg1 0)
   result <-
     UnliftIO.try . eval0 cc Nothing $ rSection
   case result of
@@ -1440,18 +1441,19 @@ buildSCache crsrc cssrc cacheableCombs trsrc ftm fty int rtmsrc rtysrc sndbx =
     restrictTyR m = Map.restrictKeys m typeRefs
 
 standalone :: CCache -> Word64 -> IO StoredCache
-standalone cc init = readTVarIO (combRefs cc) >>= \crs ->
-  case EC.lookup init crs of
-    Just rinit ->
-      buildSCache crs
-        <$> readTVarIO (srcCombs cc)
-        <*> readTVarIO (cacheableCombs cc)
-        <*> readTVarIO (tagRefs cc)
-        <*> readTVarIO (freshTm cc)
-        <*> readTVarIO (freshTy cc)
-        <*> (readTVarIO (intermed cc) >>= traceNeeded rinit)
-        <*> readTVarIO (refTm cc)
-        <*> readTVarIO (refTy cc)
-        <*> readTVarIO (sandbox cc)
-    Nothing ->
-      die $ "standalone: unknown combinator: " ++ show init
+standalone cc init =
+  readTVarIO (combRefs cc) >>= \crs ->
+    case EC.lookup init crs of
+      Just rinit ->
+        buildSCache crs
+          <$> readTVarIO (srcCombs cc)
+          <*> readTVarIO (cacheableCombs cc)
+          <*> readTVarIO (tagRefs cc)
+          <*> readTVarIO (freshTm cc)
+          <*> readTVarIO (freshTy cc)
+          <*> (readTVarIO (intermed cc) >>= traceNeeded rinit)
+          <*> readTVarIO (refTm cc)
+          <*> readTVarIO (refTy cc)
+          <*> readTVarIO (sandbox cc)
+      Nothing ->
+        die $ "standalone: unknown combinator: " ++ show init

unison-runtime/src/Unison/Runtime/Machine.hs

@@ -285,7 +285,7 @@ unitValue = BoxedVal $ unitClosure
 {-# NOINLINE unitValue #-}
 
 unitClosure :: Closure
-unitClosure = Enum Ty.unitRef (PackedTag 0)
+unitClosure = Enum Ty.unitRef TT.unitTag
 {-# NOINLINE unitClosure #-}
 
 litToVal :: MLit -> Val
@@ -691,7 +691,7 @@ eval env !denv !activeThreads !stk !k r (NMatch _mr i br) = do
   eval env denv activeThreads stk k r $ selectBranch n br
 eval env !denv !activeThreads !stk !k r (RMatch i pu br) = do
   (t, stk) <- dumpDataNoTag Nothing stk =<< peekOff stk i
-  if t == PackedTag 0
+  if t == TT.pureEffectTag
     then eval env denv activeThreads stk k r pu
     else case ANF.unpackTags t of
       (ANF.rawTag -> e, ANF.rawTag -> t)

unison-runtime/src/Unison/Runtime/TypeTags.hs

@@ -15,6 +15,8 @@ module Unison.Runtime.TypeTags
     rightTag,
     falseTag,
     trueTag,
+    pairTag,
+    pureEffectTag,
   )
 where
 
@@ -143,6 +145,17 @@ leftTag, rightTag :: PackedTag
       (packTags et lt, packTags et rt)
   | otherwise = error "internal error: either tags"
 
+pairTag :: PackedTag
+pairTag
+  | Just n <- Map.lookup Ty.pairRef builtinTypeNumbering,
+    pt <- toEnum (fromIntegral n) =
+      packTags pt 0
+  | otherwise = internalBug "internal error: pairTag"
+
+-- | A tag we use to represent the 'pure' effect case.
+pureEffectTag :: PackedTag
+pureEffectTag = PackedTag 0
+
 -- | Construct a tag for a single-constructor builtin type
 mkSimpleTag :: String -> Reference -> PackedTag
 mkSimpleTag msg r = mkEnumTag msg r 0