Merge pull request #5405 from unisonweb/topic/cache-serial

.github/workflows/ci-test-jit.yaml

@@ -4,7 +4,7 @@ on:
   workflow_call:
 
 env:
-  runtime_tests_version: "@unison/runtime-tests/releases/0.0.2"
+  runtime_tests_version: "@unison/runtime-tests/releases/0.0.1"
   # for best results, this should match the path in ci.yaml too; but GH doesn't make it easy to share them.
   runtime_tests_codebase: "~/.cache/unisonlanguage/runtime-tests.unison"
 

.github/workflows/ci.yaml

@@ -14,8 +14,8 @@ on:
 env:
   ## Some version numbers that are used during CI
   ormolu_version: 0.7.2.0
-  jit_version: "@unison/internal/releases/0.0.21"
-  runtime_tests_version: "@unison/runtime-tests/releases/0.0.2"
+  jit_version: "@unison/internal/releases/0.0.22"
+  runtime_tests_version: "@unison/runtime-tests/releases/0.0.1"
 
   ## Some cached directories
   # a temp path for caching a built `ucm`

scheme-libs/racket/unison/boot.ss

@@ -216,12 +216,17 @@
 ; This builds the core definition for a unison definition. It is just
 ; a lambda expression with the original code, but with an additional
 ; keyword argument for threading purity information.
-(define-for-syntax (make-impl name:impl:stx arg:stx body:stx)
+(define-for-syntax (make-impl value? name:impl:stx arg:stx body:stx)
   (with-syntax ([name:impl name:impl:stx]
                 [args arg:stx]
                 [body body:stx])
-    (syntax/loc body:stx
-      (define (name:impl . args) . body))))
+    (cond
+      [value?
+        (syntax/loc body:stx
+          (define name:impl . body))]
+      [else
+       (syntax/loc body:stx
+         (define (name:impl . args) . body))])))
 
 (define frame-contents (gensym))
 
@@ -235,41 +240,53 @@
 (define-for-syntax
   (make-fast-path
     #:force-pure force-pure?
+    #:value value?
     loc ; original location
     name:fast:stx name:impl:stx
     arg:stx)
 
   (with-syntax ([name:impl name:impl:stx]
                 [name:fast name:fast:stx]
                 [args arg:stx])
-    (if force-pure?
-      (syntax/loc loc
-        ; note: for some reason this performs better than
-        ; (define name:fast name:impl)
-        (define (name:fast . args) (name:impl . args)))
-
-      (syntax/loc loc
-        (define (name:fast #:pure pure? . args)
-          (if pure?
-            (name:impl #:pure pure? . args)
-            (with-continuation-mark
-              frame-contents
-              (vector . args)
-              (name:impl #:pure pure? . args))))))))
+    (cond
+      [value?
+       (syntax/loc loc
+         (define (name:fast) name:impl))]
+
+      [force-pure?
+       (syntax/loc loc
+         ; note: for some reason this performs better than
+         ; (define name:fast name:impl)
+         (define (name:fast . args) (name:impl . args)))]
+
+      [else
+       (syntax/loc loc
+         (define (name:fast #:pure pure? . args)
+           (if pure?
+             (name:impl #:pure pure? . args)
+             (with-continuation-mark
+               frame-contents
+               (vector . args)
+               (name:impl #:pure pure? . args)))))])))
 
 (define-for-syntax
-  (make-main loc inline? name:stx ref:stx name:impl:stx n)
+  (make-main loc value? inline? name:stx ref:stx name:impl:stx n)
   (with-syntax ([name name:stx]
                 [name:impl name:impl:stx]
                 [gr ref:stx]
                 [n (datum->syntax loc n)])
-    (if inline?
-      (syntax/loc loc
-        (define name
-          (unison-curry #:inline n gr name:impl)))
-      (syntax/loc loc
-        (define name
-          (unison-curry n gr name:impl))))))
+    (cond
+      [value?
+       (syntax/loc loc
+         (define (name) name:impl))]
+      [inline?
+       (syntax/loc loc
+         (define name
+           (unison-curry #:inline n gr name:impl)))]
+      [else
+       (syntax/loc loc
+         (define name
+           (unison-curry n gr name:impl)))])))
 
 (define-for-syntax
   (link-decl no-link-decl? loc name:stx name:fast:stx name:impl:stx)
@@ -299,7 +316,8 @@
              [no-link-decl? #f]
              [trace? #f]
              [inline? #f]
-             [recursive? #f])
+             [recursive? #f]
+             [value? #f])
             ([h hs])
     (values
       (or internal? (eq? h 'internal))
@@ -308,7 +326,9 @@
       (or no-link-decl? (eq? h 'no-link-decl))
       (or trace? (eq? h 'trace))
       (or inline? (eq? h 'inline))
-      (or recursive? (eq? h 'recursive)))))
+      (or recursive? (eq? h 'recursive))
+      ; TODO: enable values
+      value?)))
 
 (define-for-syntax
   (make-link-def gen-link? loc name:stx name:link:stx)
@@ -343,7 +363,8 @@
                   no-link-decl?
                   trace?
                   inline?
-                  recursive?)
+                  recursive?
+                  value?)
     (process-hints hints))
 
 
@@ -356,9 +377,10 @@
       ([(link ...) (make-link-def gen-link? loc name:stx name:link:stx)]
        [fast (make-fast-path
                #:force-pure #t ; force-pure?
+               #:value value?
                loc name:fast:stx name:impl:stx arg:stx)]
-       [impl (make-impl name:impl:stx arg:stx expr:stx)]
-       [main (make-main loc inline? name:stx ref:stx name:impl:stx arity)]
+       [impl (make-impl value? name:impl:stx arg:stx expr:stx)]
+       [main (make-main loc value? inline? name:stx ref:stx name:impl:stx arity)]
        ; [(decls ...)
        ;  (link-decl no-link-decl? loc name:stx name:fast:stx name:impl:stx)]
        [(traces ...)

scheme-libs/racket/unison/primops-generated.rkt

@@ -176,6 +176,13 @@
        (if (null? hints)
          (list def '#:local ln head body)
          (list def '#:local ln '#:hints hints head body)))]
+    [(unison-data _ t (list nm hs bd))
+     #:when (= t ref-schemedefn-defineval:tag)
+     (let-values
+       ([(head) (text->ident nm)]
+        [(def hints) (decode-hints (chunked-list->list hs))]
+        [(body) (decode-term bd)])
+       (list def '#:hints (cons 'value hints) (list head) body))]
     [(unison-data _ t (list nm bd))
      #:when (= t ref-schemedefn-alias:tag)
      (list 'define (text->ident nm) (decode-term bd))]
@@ -684,16 +691,31 @@
        "unison-termlink-derived?"
        tl)]))
 
+; Converts a link->code map into an appropriately sorted list
+; for code generation. It's necessary to topologically sort
+; the code so that values occur after the things they reference.
+(define (codemap->link-order defs)
+  (define input
+    (for/list ([(tl co) defs])
+      (unison-tuple
+        (termlink->reference tl)
+        (unison-code-rep co))))
+
+  (define result (topsort-code-refs (list->chunked-list input)))
+
+  (for/list ([r (in-chunked-list result)])
+    (reference->termlink r)))
+
 ; Given a list of termlink, code pairs, returns multiple lists
 ; of definitions and declarations. The lists are returned as
 ; multiple results, each one containing a particular type of
 ; definition.
 ;
-; This is the version for compiling to intermediate code.
+; This is the version for compiling to runtime code.
 (define (gen-codes:runtime arities defs)
   (for/lists (lndefs lndecs dfns)
-             ([(tl co) defs])
-    (gen-code:runtime arities tl co)))
+             ([tl (codemap->link-order defs)])
+    (gen-code:runtime arities tl (hash-ref defs tl))))
 
 ; Given a list of termlink, code pairs, returns multiple lists
 ; of definitions and declarations. The lists are returned as
@@ -703,8 +725,8 @@
 ; This is the version for compiling to intermediate code.
 (define (gen-codes:intermed arities defs)
   (for/lists (lndefs lndecs codefs codecls dfns)
-             ([(tl co) defs])
-      (gen-code:intermed arities tl co)))
+             ([tl (codemap->link-order defs)])
+      (gen-code:intermed arities tl (hash-ref defs tl))))
 
 (define (flatten ls)
   (cond

unison-runtime/src/Unison/Runtime/ANF/Serialize.hs

@@ -88,6 +88,7 @@ data BLTag
   | CharT
   | FloatT
   | ArrT
+  | CachedCodeT
 
 data VaTag = PartialT | DataT | ContT | BLitT
 
@@ -197,6 +198,7 @@ instance Tag BLTag where
     CharT -> 10
     FloatT -> 11
     ArrT -> 12
+    CachedCodeT -> 13
 
   word2tag = \case
     0 -> pure TextT
@@ -212,6 +214,7 @@ instance Tag BLTag where
     10 -> pure CharT
     11 -> pure FloatT
     12 -> pure ArrT
+    13 -> pure CachedCodeT
     t -> unknownTag "BLTag" t
 
 instance Tag VaTag where
@@ -330,24 +333,26 @@ getGroup = do
   cs <- replicateM l (getComb ctx n)
   Rec (zip vs cs) <$> getComb ctx n
 
-putCode :: MonadPut m => EC.EnumMap FOp Text -> Code -> m ()
+putCode :: (MonadPut m) => EC.EnumMap FOp Text -> Code -> m ()
 putCode fops (CodeRep g c) = putGroup mempty fops g *> putCacheability c
 
-getCode :: MonadGet m => Word32 -> m Code
+getCode :: (MonadGet m) => Word32 -> m Code
 getCode v = CodeRep <$> getGroup <*> getCache
   where
-  getCache | v == 3 = getCacheability
-           | otherwise = pure Uncacheable
+    getCache
+      | v == 3 = getCacheability
+      | otherwise = pure Uncacheable
 
-putCacheability :: MonadPut m => Cacheability -> m ()
+putCacheability :: (MonadPut m) => Cacheability -> m ()
 putCacheability Uncacheable = putWord8 0
 putCacheability Cacheable = putWord8 1
 
-getCacheability :: MonadGet m => m Cacheability
-getCacheability = getWord8 >>= \case
-  0 -> pure Uncacheable
-  1 -> pure Cacheable
-  n -> exn $ "getBLit: unrecognized cacheability byte: " ++ show n
+getCacheability :: (MonadGet m) => m Cacheability
+getCacheability =
+  getWord8 >>= \case
+    0 -> pure Uncacheable
+    1 -> pure Cacheable
+    n -> exn $ "getBLit: unrecognized cacheability byte: " ++ show n
 
 putComb ::
   (MonadPut m) =>
@@ -678,7 +683,10 @@ putBLit (TmLink r) = putTag TmLinkT *> putReferent r
 putBLit (TyLink r) = putTag TyLinkT *> putReference r
 putBLit (Bytes b) = putTag BytesT *> putBytes b
 putBLit (Quote v) = putTag QuoteT *> putValue v
-putBLit (Code co) = putTag CodeT *> putCode mempty co
+putBLit (Code (CodeRep sg ch)) =
+  putTag tag *> putGroup mempty mempty sg
+  where
+    tag | Cacheable <- ch = CachedCodeT | otherwise = CodeT
 putBLit (BArr a) = putTag BArrT *> putByteArray a
 putBLit (Pos n) = putTag PosT *> putPositive n
 putBLit (Neg n) = putTag NegT *> putPositive n
@@ -695,15 +703,14 @@ getBLit v =
     TyLinkT -> TyLink <$> getReference
     BytesT -> Bytes <$> getBytes
     QuoteT -> Quote <$> getValue v
-    CodeT -> Code <$> getCode cv
-      where
-        cv | v == 5 = 3 | otherwise = 2
+    CodeT -> Code . flip CodeRep Uncacheable <$> getGroup
     BArrT -> BArr <$> getByteArray
     PosT -> Pos <$> getPositive
     NegT -> Neg <$> getPositive
     CharT -> Char <$> getChar
     FloatT -> Float <$> getFloat
     ArrT -> Arr . GHC.IsList.fromList <$> getList (getValue v)
+    CachedCodeT -> Code . flip CodeRep Cacheable <$> getGroup
 
 putRefs :: (MonadPut m) => [Reference] -> m ()
 putRefs rs = putFoldable putReference rs
@@ -989,7 +996,7 @@ getVersionedValue = getVersion >>= getValue
         n
           | n < 1 -> fail $ "deserializeValue: unknown version: " ++ show n
           | n < 3 -> fail $ "deserializeValue: unsupported version: " ++ show n
-          | n <= 5 -> pure n
+          | n <= 4 -> pure n
           | otherwise -> fail $ "deserializeValue: unknown version: " ++ show n
 
 deserializeValue :: ByteString -> Either String Value
@@ -1008,13 +1015,18 @@ serializeValue v = runPutS (putVersion *> putValue v)
 -- The 4 prefix is used because we were previously including the
 -- version in the hash, so to maintain the same hashes, we need to
 -- include the extra bytes that were previously there.
+--
+-- Additionally, any major serialization changes should consider
+-- retaining this representation as much as possible, even if it
+-- becomes a separate format, because there is no need to parse from
+-- the hash serialization, just generate and hash it.
 serializeValueForHash :: Value -> L.ByteString
 serializeValueForHash v = runPutLazy (putPrefix *> putValue v)
   where
     putPrefix = putWord32be 4
 
 valueVersion :: Word32
-valueVersion = 5
+valueVersion = 4
 
 codeVersion :: Word32
 codeVersion = 3

unison-src/builtin-tests/interpreter-tests.sh

@@ -1,10 +1,10 @@
 #!/bin/bash
 set -ex
 
-ucm=$(stack exec -- which unison)
+ucm=$(cabal exec -- which unison)
 echo "$ucm"
 
-runtime_tests_version="@unison/runtime-tests/releases/0.0.2"
+runtime_tests_version="@unison/runtime-tests/releases/0.0.1"
 echo $runtime_tests_version
 
 codebase=${XDG_CACHE_HOME:-"$HOME/.cache"}/unisonlanguage/runtime-tests.unison

unison-src/builtin-tests/jit-tests.sh

@@ -8,7 +8,7 @@ if [ -z "$1" ]; then
   exit 1
 fi
 
-runtime_tests_version="@unison/runtime-tests/releases/0.0.2"
+runtime_tests_version="@unison/runtime-tests/releases/0.0.1"
 echo $runtime_tests_version
 
 codebase=${XDG_CACHE_HOME:-"$HOME/.cache"}/unisonlanguage/runtime-tests.unison

unison-src/transcripts-manual/gen-racket-libs.md

@@ -3,7 +3,7 @@ When we start out, `./scheme-libs/racket` contains a bunch of library files that
 Next, we'll download the jit project and generate a few Racket files from it.
 
 ``` ucm
-jit-setup/main> lib.install @unison/internal/releases/0.0.21
+jit-setup/main> lib.install @unison/internal/releases/0.0.22
 ```
 
 ``` unison

unison-src/transcripts-manual/gen-racket-libs.output.md

@@ -3,12 +3,12 @@ When we start out, `./scheme-libs/racket` contains a bunch of library files that
 Next, we'll download the jit project and generate a few Racket files from it.
 
 ``` ucm
-jit-setup/main> lib.install @unison/internal/releases/0.0.21
+jit-setup/main> lib.install @unison/internal/releases/0.0.22
 
-  Downloaded 14985 entities.
+  Downloaded 14996 entities.
 
-  I installed @unison/internal/releases/0.0.21 as
-  unison_internal_0_0_21.
+  I installed @unison/internal/releases/0.0.22 as
+  unison_internal_0_0_22.
 
 ```
 ``` unison