From 0ea62b8b87a1684a656785ec10b27ee6f852cc82 Mon Sep 17 00:00:00 2001
From: Dan Doel <dan.doel@gmail.com>
Date: Wed, 25 Oct 2023 15:24:28 -0400
Subject: [PATCH] Corrected dynamic sandboxing algorithm

CACH wasn't actually adding to the sandbox, and the sandbox expansion
algorithm wasn't correctly handling mutually recursive functions.
---
 .../racket/unison/primops-generated.rkt       | 16 +++++-----
 scheme-libs/racket/unison/sandbox.rkt         | 31 ++++++++++++++-----
 2 files changed, 32 insertions(+), 15 deletions(-)

diff --git a/scheme-libs/racket/unison/primops-generated.rkt b/scheme-libs/racket/unison/primops-generated.rkt
index 7220f8f6d3..434314af2d 100644
--- a/scheme-libs/racket/unison/primops-generated.rkt
+++ b/scheme-libs/racket/unison/primops-generated.rkt
@@ -518,22 +518,21 @@
       runtime-namespace)))
 
 (define (code-dependencies co)
-  (group-term-dependencies (unison-code-rep co)))
+  (chunked-list->list
+    (group-term-dependencies
+      (unison-code-rep co))))
 
 (define (unison-POp-CACH dfns0)
-  (define (flat-map f l)
-    (foldl
-      (lambda (x acc)
-        (append (chunked-list->list (f (usnd x))) acc))
-      '()
-      l))
+  (define (map-links dss)
+    (map (lambda (ds) (map reference->termlink ds)) dss))
 
   (let ([udefs (chunked-list->list dfns0)])
     (cond
       [(not (null? udefs))
        (let* ([links (map ufst udefs)]
               [refs (map termlink->reference links)]
-              [deps (flat-map code-dependencies udefs)]
+              [depss (map (compose code-dependencies usnd) udefs)]
+              [deps (flatten depss)]
               [fdeps (filter need-dependency? deps)]
               [rdeps (remove* refs fdeps)])
          (cond
@@ -541,6 +540,7 @@
            [(null? rdeps)
             (let ([sdefs (flatten (map gen-code udefs))]
                   [mname (generate-module-name links)])
+              (expand-sandbox links (map-links depss))
               (register-code udefs)
               (add-module-associations links mname)
               (add-runtime-module mname links sdefs)
diff --git a/scheme-libs/racket/unison/sandbox.rkt b/scheme-libs/racket/unison/sandbox.rkt
index 7286a4072b..d1e634f06d 100644
--- a/scheme-libs/racket/unison/sandbox.rkt
+++ b/scheme-libs/racket/unison/sandbox.rkt
@@ -3,7 +3,7 @@
 
 (provide expand-sandbox check-sandbox set-sandbox)
 
-(require racket)
+(require racket racket/hash)
 (require (except-in unison/data true false unit))
 
 ; sandboxing information
@@ -13,15 +13,32 @@
 (define (check-sandbox ln)
   (hash-ref sandbox-links ln '()))
 
+(define (expand build have ds)
+  (define (check d)
+    (hash-ref build d (lambda () (check-sandbox d))))
+
+  (for/fold ([acc '()]) ([d ds])
+    (append (remove* have (check d)) acc)))
+
 ; Add a link to the sandboxing information.
 ; deps0 should be the immediate dependencies of the code for ln.
 ; They will be used to generate the overall sandboxing 
-(define (expand-sandbox ln deps0)
-  (let rec ([tot '()] [deps deps0])
-    (match deps
-      ['() (hash-set! sandbox-links ln (remove-duplicates tot))]
-      [(cons d ds)
-       (rec (append (check-sandbox d) tot) ds)])))
+(define (expand-sandbox ls dss)
+  (let rec ([build (make-immutable-hash)])
+    (for/fold
+      ([new (make-immutable-hash)]
+
+       #:result
+       (if (hash-empty? new)
+         ; set the newly found links
+         (hash-union! sandbox-links build #:combine append)
+         (rec (hash-union build new #:combine append))))
+       
+      ([l ls] [ds dss])
+      (let ([xp (expand build (hash-ref build l '()) ds)])
+        (if (not (null? xp))
+          (hash-set new l xp)
+          new)))))
 
 (define (set-sandbox link links)
   (hash-set! sandbox-links link links))