Merge pull request #2998 from unisonweb/fix/assorted

Some assorted fixes

parser-typechecker/src/Unison/Runtime/ANF.hs

@@ -317,6 +317,10 @@ floater ::
   (Term v a -> FloatM v a (Term v a)) ->
   Term v a ->
   Maybe (FloatM v a (Term v a))
+floater top rec tm0@(Ann' tm ty) =
+  (fmap . fmap) (\tm -> ann a tm ty) (floater top rec tm)
+  where
+    a = ABT.annotation tm0
 floater top rec (LetRecNamed' vbs e) =
   Just $
     letFloater rec vbs e >>= \case

parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs

@@ -16,6 +16,7 @@ import Data.Functor ((<&>))
 import Data.Map as Map (Map, fromList, lookup)
 import qualified Data.Sequence as Seq
 import Data.Serialize.Put (runPutLazy)
+import Data.Text (Text)
 import Data.Word (Word16, Word64)
 import GHC.Stack
 import Unison.ABT.Normalized (Term (..))
@@ -23,6 +24,7 @@ import Unison.Reference (Reference)
 import Unison.Runtime.ANF as ANF hiding (Tag)
 import Unison.Runtime.Exception
 import Unison.Runtime.Serialize
+import qualified Unison.Util.EnumContainers as EC
 import qualified Unison.Util.Text as Util.Text
 import Unison.Var (Type (ANFBlank), Var (..))
 import Prelude hiding (getChar, putChar)
@@ -47,6 +49,7 @@ data FnTag
   | FConT
   | FReqT
   | FPrimT
+  | FForeignT
 
 data MtTag
   = MIntT
@@ -106,6 +109,7 @@ instance Tag FnTag where
     FConT -> 3
     FReqT -> 4
     FPrimT -> 5
+    FForeignT -> 6
 
   word2tag = \case
     0 -> pure FVarT
@@ -114,6 +118,7 @@ instance Tag FnTag where
     3 -> pure FConT
     4 -> pure FReqT
     5 -> pure FPrimT
+    6 -> pure FForeignT
     n -> unknownTag "FnTag" n
 
 instance Tag MtTag where
@@ -209,6 +214,9 @@ deindex (v : vs) n
   | n == 0 = v
   | otherwise = deindex vs (n - 1)
 
+pushCtx :: [v] -> [v] -> [v]
+pushCtx us vs = reverse us ++ vs
+
 putIndex :: MonadPut m => Word64 -> m ()
 putIndex = serialize . VarInt
 
@@ -244,24 +252,37 @@ getCCs =
       1 -> BX
       _ -> exn "getCCs: bad calling convention"
 
-putGroup :: MonadPut m => Var v => SuperGroup v -> m ()
-putGroup (Rec bs e) =
-  putLength n *> traverse_ (putComb ctx) cs *> putComb ctx e
+putGroup ::
+  MonadPut m =>
+  Var v =>
+  EC.EnumMap FOp Text ->
+  SuperGroup v ->
+  m ()
+putGroup fops (Rec bs e) =
+  putLength n *> traverse_ (putComb fops ctx) cs *> putComb fops ctx e
   where
-    n = length ctx
-    (ctx, cs) = unzip bs
+    n = length us
+    (us, cs) = unzip bs
+    ctx = pushCtx us []
 
 getGroup :: MonadGet m => Var v => m (SuperGroup v)
 getGroup = do
   l <- getLength
   let n = fromIntegral l
       vs = getFresh <$> take l [0 ..]
-  cs <- replicateM l (getComb vs n)
-  Rec (zip vs cs) <$> getComb vs n
+      ctx = pushCtx vs []
+  cs <- replicateM l (getComb ctx n)
+  Rec (zip ctx cs) <$> getComb ctx n
 
-putComb :: MonadPut m => Var v => [v] -> SuperNormal v -> m ()
-putComb ctx (Lambda ccs (TAbss us e)) =
-  putCCs ccs *> putNormal (us ++ ctx) e
+putComb ::
+  MonadPut m =>
+  Var v =>
+  EC.EnumMap FOp Text ->
+  [v] ->
+  SuperNormal v ->
+  m ()
+putComb fops ctx (Lambda ccs (TAbss us e)) =
+  putCCs ccs *> putNormal fops (pushCtx us ctx) e
 
 getFresh :: Var v => Word64 -> v
 getFresh n = freshenId n $ typed ANFBlank
@@ -271,31 +292,37 @@ getComb ctx frsh0 = do
   ccs <- getCCs
   let us = zipWith (\_ -> getFresh) ccs [frsh0 ..]
       frsh = frsh0 + fromIntegral (length ccs)
-  Lambda ccs . TAbss us <$> getNormal (us ++ ctx) frsh
+  Lambda ccs . TAbss us <$> getNormal (pushCtx us ctx) frsh
 
-putNormal :: MonadPut m => Var v => [v] -> ANormal v -> m ()
-putNormal ctx tm = case tm of
+putNormal ::
+  MonadPut m =>
+  Var v =>
+  EC.EnumMap FOp Text ->
+  [v] ->
+  ANormal v ->
+  m ()
+putNormal fops ctx tm = case tm of
   TVar v -> putTag VarT *> putVar ctx v
   TFrc v -> putTag ForceT *> putVar ctx v
-  TApp f as -> putTag AppT *> putFunc ctx f *> putArgs ctx as
+  TApp f as -> putTag AppT *> putFunc fops ctx f *> putArgs ctx as
   THnd rs h e ->
-    putTag HandleT *> putRefs rs *> putVar ctx h *> putNormal ctx e
+    putTag HandleT *> putRefs rs *> putVar ctx h *> putNormal fops ctx e
   TShift r v e ->
-    putTag ShiftT *> putReference r *> putNormal (v : ctx) e
-  TMatch v bs -> putTag MatchT *> putVar ctx v *> putBranches ctx bs
+    putTag ShiftT *> putReference r *> putNormal fops (v : ctx) e
+  TMatch v bs -> putTag MatchT *> putVar ctx v *> putBranches fops ctx bs
   TLit l -> putTag LitT *> putLit l
   TName v (Left r) as e ->
     putTag NameRefT *> putReference r *> putArgs ctx as
-      *> putNormal (v : ctx) e
+      *> putNormal fops (v : ctx) e
   TName v (Right u) as e ->
     putTag NameVarT *> putVar ctx u *> putArgs ctx as
-      *> putNormal (v : ctx) e
+      *> putNormal fops (v : ctx) e
   TLets Direct us ccs l e ->
-    putTag LetDirT *> putCCs ccs *> putNormal ctx l
-      *> putNormal (us ++ ctx) e
+    putTag LetDirT *> putCCs ccs *> putNormal fops ctx l
+      *> putNormal fops (pushCtx us ctx) e
   TLets (Indirect w) us ccs l e ->
-    putTag LetIndT *> putWord16be w *> putCCs ccs *> putNormal ctx l
-      *> putNormal (us ++ ctx) e
+    putTag LetIndT *> putWord16be w *> putCCs ccs *> putNormal fops ctx l
+      *> putNormal fops (pushCtx us ctx) e
   _ -> exn "putNormal: malformed term"
 
 getNormal :: MonadGet m => Var v => [v] -> Word64 -> m (ANormal v)
@@ -332,7 +359,7 @@ getNormal ctx frsh0 =
           us = getFresh <$> take l [frsh0 ..]
       TLets Direct us ccs
         <$> getNormal ctx frsh0
-        <*> getNormal (us ++ ctx) frsh
+        <*> getNormal (pushCtx us ctx) frsh
     LetIndT -> do
       w <- getWord16be
       ccs <- getCCs
@@ -341,17 +368,26 @@ getNormal ctx frsh0 =
           us = getFresh <$> take l [frsh0 ..]
       TLets (Indirect w) us ccs
         <$> getNormal ctx frsh0
-        <*> getNormal (us ++ ctx) frsh
+        <*> getNormal (pushCtx us ctx) frsh
 
-putFunc :: MonadPut m => Var v => [v] -> Func v -> m ()
-putFunc ctx f = case f of
+putFunc ::
+  MonadPut m =>
+  Var v =>
+  EC.EnumMap FOp Text ->
+  [v] ->
+  Func v ->
+  m ()
+putFunc fops ctx f = case f of
   FVar v -> putTag FVarT *> putVar ctx v
   FComb r -> putTag FCombT *> putReference r
   FCont v -> putTag FContT *> putVar ctx v
   FCon r c -> putTag FConT *> putReference r *> putCTag c
   FReq r c -> putTag FReqT *> putReference r *> putCTag c
   FPrim (Left p) -> putTag FPrimT *> putPOp p
-  FPrim _ -> exn "putFunc: can't serialize foreign func"
+  FPrim (Right f)
+    | Just nm <- EC.lookup f fops ->
+        putTag FForeignT *> putText nm
+    | otherwise -> exn $ "putFUnc: unknown FOp: " ++ show f
 
 getFunc :: MonadGet m => Var v => [v] -> m (Func v)
 getFunc ctx =
@@ -362,6 +398,7 @@ getFunc ctx =
     FConT -> FCon <$> getReference <*> getCTag
     FReqT -> FReq <$> getReference <*> getCTag
     FPrimT -> FPrim . Left <$> getPOp
+    FForeignT -> exn "getFunc: can't deserialize a foreign func"
 
 putPOp :: MonadPut m => POp -> m ()
 putPOp op
@@ -535,31 +572,37 @@ putRefs rs = putFoldable putReference rs
 getRefs :: MonadGet m => m [Reference]
 getRefs = getList getReference
 
-putBranches :: MonadPut m => Var v => [v] -> Branched (ANormal v) -> m ()
-putBranches ctx bs = case bs of
+putBranches ::
+  MonadPut m =>
+  Var v =>
+  EC.EnumMap FOp Text ->
+  [v] ->
+  Branched (ANormal v) ->
+  m ()
+putBranches fops ctx bs = case bs of
   MatchEmpty -> putTag MEmptyT
   MatchIntegral m df -> do
     putTag MIntT
-    putEnumMap putWord64be (putNormal ctx) m
-    putMaybe df $ putNormal ctx
+    putEnumMap putWord64be (putNormal fops ctx) m
+    putMaybe df $ putNormal fops ctx
   MatchText m df -> do
     putTag MTextT
-    putMap (putText . Util.Text.toText) (putNormal ctx) m
-    putMaybe df $ putNormal ctx
+    putMap (putText . Util.Text.toText) (putNormal fops ctx) m
+    putMaybe df $ putNormal fops ctx
   MatchRequest m (TAbs v df) -> do
     putTag MReqT
-    putMap putReference (putEnumMap putCTag (putCase ctx)) m
-    putNormal (v : ctx) df
+    putMap putReference (putEnumMap putCTag (putCase fops ctx)) m
+    putNormal fops (v : ctx) df
     where
 
   MatchData r m df -> do
     putTag MDataT
     putReference r
-    putEnumMap putCTag (putCase ctx) m
-    putMaybe df $ putNormal ctx
+    putEnumMap putCTag (putCase fops ctx) m
+    putMaybe df $ putNormal fops ctx
   MatchSum m -> do
     putTag MSumT
-    putEnumMap putWord64be (putCase ctx) m
+    putEnumMap putWord64be (putCase fops ctx) m
   _ -> exn "putBranches: malformed intermediate term"
 
 getBranches ::
@@ -588,8 +631,15 @@ getBranches ctx frsh0 =
         <*> getMaybe (getNormal ctx frsh0)
     MSumT -> MatchSum <$> getEnumMap getWord64be (getCase ctx frsh0)
 
-putCase :: MonadPut m => Var v => [v] -> ([Mem], ANormal v) -> m ()
-putCase ctx (ccs, (TAbss us e)) = putCCs ccs *> putNormal (us ++ ctx) e
+putCase ::
+  MonadPut m =>
+  Var v =>
+  EC.EnumMap FOp Text ->
+  [v] ->
+  ([Mem], ANormal v) ->
+  m ()
+putCase fops ctx (ccs, (TAbss us e)) =
+  putCCs ccs *> putNormal fops (pushCtx us ctx) e
 
 getCase :: MonadGet m => Var v => [v] -> Word64 -> m ([Mem], ANormal v)
 getCase ctx frsh0 = do
@@ -597,7 +647,7 @@ getCase ctx frsh0 = do
   let l = length ccs
       frsh = frsh0 + fromIntegral l
       us = getFresh <$> take l [frsh0 ..]
-  (,) ccs . TAbss us <$> getNormal (us ++ ctx) frsh
+  (,) ccs . TAbss us <$> getNormal (pushCtx us ctx) frsh
 
 putCTag :: MonadPut m => CTag -> m ()
 putCTag c = serialize (VarInt $ fromEnum c)
@@ -684,8 +734,9 @@ deserializeGroup bs = runGetS (getVersion *> getGroup) bs
         1 -> pure ()
         n -> fail $ "deserializeGroup: unknown version: " ++ show n
 
-serializeGroup :: Var v => SuperGroup v -> ByteString
-serializeGroup sg = runPutS (putVersion *> putGroup sg)
+serializeGroup ::
+  Var v => EC.EnumMap FOp Text -> SuperGroup v -> ByteString
+serializeGroup fops sg = runPutS (putVersion *> putGroup fops sg)
   where
     putVersion = putWord32be 1
 

parser-typechecker/src/Unison/Runtime/Builtin.hs

@@ -1683,7 +1683,7 @@ builtinLookup =
       ++ foreignWrappers
 
 type FDecl v =
-  State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 ForeignFunc)
+  State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc))
 
 -- Data type to determine whether a builtin should be tracked for
 -- sandboxing. Untracked means that it can be freely used, and Tracked
@@ -1700,7 +1700,7 @@ declareForeign ::
   FDecl Symbol ()
 declareForeign sand name op func =
   modify $ \(w, cs, fs) ->
-    (w + 1, (name, (sand, uncurry Lambda (op w))) : cs, mapInsert w func fs)
+    (w + 1, (name, (sand, uncurry Lambda (op w))) : cs, mapInsert w (name, func) fs)
 
 mkForeignIOF ::
   (ForeignConvention a, ForeignConvention r) =>
@@ -2086,7 +2086,7 @@ declareForeigns = do
   declareForeign Untracked "Code.serialize" boxDirect
     . mkForeign
     $ \(sg :: SuperGroup Symbol) ->
-      pure . Bytes.fromArray $ serializeGroup sg
+      pure . Bytes.fromArray $ serializeGroup builtinForeignNames sg
   declareForeign Untracked "Code.deserialize" boxToEBoxBox
     . mkForeign
     $ pure . deserializeGroup @Symbol . Bytes.toArray
@@ -2205,7 +2205,7 @@ typeReferences = zip rs [1 ..]
         ++ [DerivedId i | (_, i, _) <- Ty.builtinEffectDecls]
 
 foreignDeclResults ::
-  (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 ForeignFunc)
+  (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc))
 foreignDeclResults = execState declareForeigns (0, [], mempty)
 
 foreignWrappers :: [(Data.Text.Text, (Sandbox, SuperNormal Symbol))]
@@ -2232,7 +2232,10 @@ builtinTypeBackref = mapFromList $ swap <$> typeReferences
     swap (x, y) = (y, x)
 
 builtinForeigns :: EnumMap Word64 ForeignFunc
-builtinForeigns | (_, _, m) <- foreignDeclResults = m
+builtinForeigns | (_, _, m) <- foreignDeclResults = snd <$> m
+
+builtinForeignNames :: EnumMap Word64 Data.Text.Text
+builtinForeignNames | (_, _, m) <- foreignDeclResults = fst <$> m
 
 -- Bootstrapping for sandbox check. The eventual map will be one with
 -- associations `r -> s` where `s` is all the 'sensitive' base

parser-typechecker/src/Unison/Runtime/Interface.hs

@@ -566,7 +566,7 @@ putStoredCache (SCache cs crs trs ftm fty int rtm rty sbs) = do
   putEnumMap putNat putReference trs
   putNat ftm
   putNat fty
-  putMap putReference putGroup int
+  putMap putReference (putGroup mempty) int
   putMap putReference putNat rtm
   putMap putReference putNat rty
   putMap putReference (putFoldable putReference) sbs

parser-typechecker/src/Unison/Runtime/Machine.hs

@@ -288,7 +288,13 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i) = do
   m <- readTVarIO (intermed env)
   ustk <- bump ustk
   bstk <- case M.lookup link m of
-    Nothing -> bstk <$ poke ustk 0
+    Nothing
+      | Just w <- M.lookup link builtinTermNumbering,
+        Just sn <- EC.lookup w numberedTermLookup -> do
+          poke ustk 1
+          bstk <- bump bstk
+          bstk <$ pokeBi bstk (ANF.Rec [] sn)
+      | otherwise -> bstk <$ poke ustk 0
     Just sg -> do
       poke ustk 1
       bstk <- bump bstk

unison-src/transcripts-using-base/hashing.output.md

@@ -106,11 +106,11 @@ ex5 = crypto.hmac Sha2_256 mysecret f |> hex
   
     25 | > ex4
            ⧩
-           "1e014deb2a1ef1dc3c8765a6f7ebf7184ccaeaecbc2b5428030befd7085139db"
+           "a52c81c976ff4fe9c809d9896d6dc32775c6272bb100555c507b72f20ace4b39"
   
     26 | > ex5
            ⧩
-           "c729f5ed4b2a89dc33ae06cd0b925174c990328c736123bc220e6fe8b42d3d53"
+           "b9f05335381fc8eecba3bfa6e82a4dc23fdab95a04f24b97d14785f0f15f56b4"
 
 ```
 And here's the full API:

unison-src/transcripts/fix2053.output.md

@@ -1,13 +1,12 @@
 ```ucm
 .> display List.map
 
-  f a ->
-    go f i as acc =
-      match List.at i as with
-        None   -> acc
-        Some a ->
-          use Nat +
-          go f (i + 1) as (acc :+ f a)
-    go f 0 a []
+  go f i as acc =
+    match List.at i as with
+      None   -> acc
+      Some a ->
+        use Nat +
+        go f (i + 1) as (acc :+ f a)
+  f a -> go f 0 a []
 
 ```