Working again, now with FieldRefs

Author: ChrisPenner

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

@@ -36,6 +36,7 @@ module Unison.Runtime.MCode
     Branch,
     RBranch,
     RecordFieldMappings (..),
+    convertFieldNamesToRefs,
     emitCombs,
     emitComb,
     resolveCombs,
@@ -711,7 +712,7 @@ data RefNums = RN
     -- Map record schemas into their runtime reference
     recNum :: ANF.RecordSchema -> ANF.RecordRef,
     -- Map record field names into their runtime reference
-    recField :: ANF.FieldName -> FieldRef
+    recField :: RecordFieldMappings -> ANF.FieldName -> FieldRef
   }
 
 emptyRNs :: RefNums
@@ -993,7 +994,7 @@ data RecordFieldMappings
   deriving stock (Show, Eq, Ord)
 
 -- | Note that the Ord instance for Field Refs is arbitrary and not tied to the field name Ord instance.
-convertFieldNamesToRefs :: (Traversable f) => f ANF.FieldName -> Emit (f FieldRef)
+convertFieldNamesToRefs :: (MonadState RecordFieldMappings m, Traversable f) => f ANF.FieldName -> m (f FieldRef)
 convertFieldNamesToRefs names = for names \name -> do
   RecordFieldMappings next m <- get
   case BiMap.lookupL name m of
@@ -1125,8 +1126,9 @@ emitSection _ _ grpn _ ctx (TFOp p args) =
     . VArgV
     $ countBlock ctx
 emitSection rns grpr grpn rec ctx (TApp f args) =
-  emitClosures grpr grpn rec ctx args $ \ctx as ->
-    countCtx ctx $ emitFunction rns grpr grpn rec ctx f as
+  emitClosures grpr grpn rec ctx args $ \ctx as -> do
+    rfm <- get
+    countCtx ctx $ emitFunction rns rfm grpr grpn rec ctx f as
 emitSection rns grpr grpn rec ctx (TLocal v bo)
   | Just (i, BX) <- ctxResolve ctx v =
       Ins (InLocal i)
@@ -1237,21 +1239,22 @@ emitSection _ _ _ _ _ tm =
 emitFunction ::
   (Var v) =>
   RefNums ->
+  RecordFieldMappings ->
   Reference ->
   Word64 -> -- self combinator number
   RCtx v -> -- recursive binding group
   Ctx v -> -- local context
   Func Reference v ->
   Args ->
   Section
-emitFunction _ grpr grpn rec ctx (FVar v) as
+emitFunction _ _rfms grpr grpn rec ctx (FVar v) as
   | Just (i, BX) <- ctxResolve ctx v =
       App False (Stk i) as
   | Just j <- rctxResolve rec v =
       let cix = CIx grpr grpn j
        in App False (Env cix cix) as
   | otherwise = emitSectionVErr v
-emitFunction rns _grpr _ _ _ (FComb r) as
+emitFunction rns _rfms _grpr _ _ _ (FComb r) as
   | Just k <- anum rns r,
     countArgs as == k -- exactly saturated call
     =
@@ -1262,19 +1265,19 @@ emitFunction rns _grpr _ _ _ (FComb r) as
   where
     n = cnum rns r
     cix = CIx r n 0
-emitFunction rns _grpr _ _ _ (FCon r t) as =
+emitFunction rns _rfms _grpr _ _ _ (FCon r t) as =
   Ins (Pack r (packTags rt t) as)
     . Yield
     $ VArg1 0
   where
     rt = toEnum . fromIntegral $ dnum rns r
-emitFunction rns _grpr _ _ _ (FRec rs@(ANF.RecordSchema fields)) as =
-  Ins (RecPack recRef (V.fromList . fmap (recField rns) $ Set.toList fields) as)
+emitFunction rns rfms _grpr _ _ _ (FRec rs@(ANF.RecordSchema fields)) as =
+  Ins (RecPack recRef (V.fromList . fmap (recField rns rfms) $ Set.toList fields) as)
     . Yield
     $ VArg1 0
   where
     recRef = recNum rns rs
-emitFunction rns _grpr _ _ _ (FReq r e) as =
+emitFunction rns _rfms _grpr _ _ _ (FReq r e) as =
   -- Currently implementing packed calling convention for abilities
   -- TODO ct is 16 bits, but a is 48 bits. This will be a problem if we have
   -- more than 2^16 types.
@@ -1284,11 +1287,11 @@ emitFunction rns _grpr _ _ _ (FReq r e) as =
   where
     a = dnum rns r
     rt = toEnum . fromIntegral $ a
-emitFunction _ _grpr _ _ ctx (FCont k) as
+emitFunction _ _rfms _grpr _ _ ctx (FCont k) as
   | Just (i, BX) <- ctxResolve ctx k = Jump i as
   | Nothing <- ctxResolve ctx k = emitFunctionVErr k
   | otherwise = internalBug [] $ "emitFunction: continuations are boxed"
-emitFunction _ _grpr _ _ _ (FPrim _) _ =
+emitFunction _ _rfms _grpr _ _ _ (FPrim _) _ =
   internalBug [] "emitFunction: impossible"
 
 countBlock :: Ctx v -> Int
@@ -1351,8 +1354,9 @@ emitLet rns _ grpn _ _ _ ctx (TApp (FCon r n) args) =
   fmap (Ins . Pack r (packTags rt n) $ emitArgs grpn ctx args)
   where
     rt = toEnum . fromIntegral $ dnum rns r
-emitLet rns _ grpn _ _ _ ctx (TApp (FRec rs@(ANF.RecordSchema fields)) args) =
-  fmap (Ins . RecPack (recNum rns rs) (V.fromList . fmap (recField rns) $ Set.toList fields) $ emitArgs grpn ctx args)
+emitLet rns _ grpn _ _ _ ctx (TApp (FRec rs@(ANF.RecordSchema fields)) args) = \es -> do
+  rfm <- get
+  fmap (Ins . RecPack (recNum rns rs) (V.fromList . fmap (recField rns rfm) $ Set.toList fields) $ emitArgs grpn ctx args) es
 emitLet _ _ grpn _ _ _ ctx (TApp (FPrim p) args) =
   fmap (Ins . either emitPOp emitFOp p $ emitArgs grpn ctx args)
 emitLet _ _ _ _ _ _ ctx (TDiscard v)

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

@@ -1616,10 +1616,16 @@ cacheAdd0 recSchemas ntys0 (normalizeCodes -> termSuperGroups) sands cc = do
     let newRecSchemaMap = BM.fromList $ zip (Set.toList newRecSchemas) (ANF.RecordRef <$> [nrs ..])
     rtm <- updateMap (M.fromList $ zip rs [ntm ..]) (refTm cc)
     rrLookup <- updateMap newRecSchemaMap (recordRefs cc)
-    oldRfms@(RecordFieldMappings _ rfmBM) <- readTVar (recordFieldMappings cc)
+    oldRfms@(RecordFieldMappings _ existingRfmsBM) <- readTVar (recordFieldMappings cc)
+    let recFields =
+          BM.toList rrLookup
+            <&> fst
+            & foldMap (\(ANF.RecordSchema flds) -> flds)
+            & Set.toList
+    let currentRFMs = flip execState oldRfms (convertFieldNamesToRefs recFields)
     -- check for missing references
     let arities = fmap (head . ANF.arities) int <> builtinArities
-        lookupRN fn = fromMaybe (error $ "cacheAdd0: missing reference for FieldName: " ++ show fn) $ BM.lookupL fn rfmBM
+        lookupRN (RecordFieldMappings _ rfmBM) fn = fromMaybe (error $ "cacheAdd0: missing reference for FieldName: " <> show fn <> " in map: " <> (show (rfmBM <> existingRfmsBM)) <> " and schemas: " <> show rrLookup) $ BM.lookupL fn (rfmBM <> existingRfmsBM)
         rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) (flip M.lookup arities) (recordRefLookup rrLookup) lookupRN
         combinate :: Word64 -> (Reference, SuperGroup Reference Symbol) -> State RecordFieldMappings (Word64, EnumMap Word64 Comb)
         combinate n (r, g) = (n,) <$> emitCombs rns r n g
@@ -1639,7 +1645,7 @@ cacheAdd0 recSchemas ntys0 (normalizeCodes -> termSuperGroups) sands cc = do
       let (emittedCombs, newRFMs) =
             zipWith combinate [ntm ..] (M.toList opt)
               & sequenceA
-              & flip runState oldRfms
+              & flip runState currentRFMs
           unresolvedNewCombs :: EnumMap Word64 (GCombs any CombIx)
           unresolvedNewCombs =
             emittedCombs

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

@@ -348,7 +348,7 @@ codeValidate ::
 codeValidate cc tml = do
   rty0 <- readTVarIO (refTy cc)
   fty <- readTVarIO (freshTy cc)
-  (RecordFieldMappings _ rfmsBM) <- readTVarIO (recordFieldMappings cc)
+  (RecordFieldMappings _ existingRfmsBM) <- readTVarIO (recordFieldMappings cc)
   recRefs <- readTVarIO (recordRefs cc)
   let f b r
         | b, M.notMember r rty0 = S.singleton r
@@ -362,7 +362,7 @@ codeValidate cc tml = do
   rtm0 <- readTVarIO (refTm cc)
   let rs = fst <$> tml
       rtm = rtm0 `M.union` M.fromList (zip rs [ftm ..])
-      lookupFR fn = fromMaybe (error $ "Missing FieldRef for FieldName: " <> show fn) $ BM.lookupL fn rfmsBM
+      lookupFR (RecordFieldMappings _ rfmsBM) fn = fromMaybe (error $ "Missing FieldRef for FieldName: " <> show fn) $ BM.lookupL fn (rfmsBM <> existingRfmsBM)
       rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) (const Nothing) (recordRefLookup recRefs') lookupFR
       combinate (n, (r, g)) = evaluate $ emitCombs rns r n g
   (Nothing <$ traverse_ combinate (zip [ftm ..] tml))