Importing racket_7.6.orig.tar.gz

3 files changed, 267 insertions, 0 deletions

diff --git a/src/schemify/gensym.rkt b/src/schemify/gensym.rkt
new file mode 100644
index 0000000000..5899d7269c
--- /dev/null
+++ b/src/schemify/gensym.rkt
@@ -0,0 +1,19 @@
+#lang racket/base
+
+(provide with-deterministic-gensym
+         deterministic-gensym)
+
+(define gensym-counter (make-parameter #f))
+
+(define-syntax-rule (with-deterministic-gensym body ...)
+  (parameterize ([gensym-counter (box 0)])
+    body ...))
+
+(define (deterministic-gensym prefix)
+  (define b (gensym-counter))
+  (unless b (error 'deterministic-gensym "not in `call-with-deterministic-gensym`"))
+  (set-box! b (add1 (unbox b)))
+  (string->uninterned-symbol (string-append (if (string? prefix)
+                                                prefix
+                                                (symbol->string prefix))
+                                            (number->string (unbox b)))))
diff --git a/src/schemify/path-and-fasl.rkt b/src/schemify/path-and-fasl.rkt
new file mode 100644
index 0000000000..d61b25af5f
--- /dev/null
+++ b/src/schemify/path-and-fasl.rkt
@@ -0,0 +1,146 @@
+#lang racket/base
+(require racket/private/relative-path
+         racket/private/truncate-path
+         racket/fasl
+         "match.rkt"
+         "path-for-srcloc.rkt"
+         "to-fasl.rkt")
+
+(provide extract-paths-and-fasls-from-schemified-linklet
+         make-path->compiled-path
+         compiled-path->path
+         force-unfasl)
+
+;; Recognize lifted paths and `to-fasl`s in a schemified linklet, and
+;; return the list of path and `to-fasl` values. If `convert?`, then
+;; change the schemified linklet to expect the paths as arguments.
+;;
+;; In addition to paths, this extraction deals with values that have
+;; been packages as `to-fasl`, either because they are large values
+;; that are best handled in fasl form, because they are not
+;; serializable (and we want to delay complaining in case no
+;; serialization is needed), or because they are uninterned symbols
+;; that need to be exposed to the Scheme-level `fasl` for a full
+;; linklet.
+
+(define (extract-paths-and-fasls-from-schemified-linklet linklet-e convert?)
+  (match linklet-e
+    [`(lambda . ,_)
+     ;; No constants, so no paths:
+     (values '() linklet-e)]
+    [`(let* ,bindings ,body)
+     (define (path-binding? b)
+       (define rhs (cadr b))
+       (or (path? rhs)
+           (path-for-srcloc? rhs)
+           (to-fasl? rhs)))
+     (define any-path?
+       (for/or ([b (in-list bindings)])
+         (path-binding? b)))
+     (cond
+       [any-path?
+        (define paths (for/list ([b (in-list bindings)]
+                                 #:when (path-binding? b))
+                        (cadr b)))
+        (cond
+          [convert?
+           (define path-ids (for/list ([b (in-list bindings)]
+                                       #:when (path-binding? b))
+                              (car b)))
+           (define other-bindings (for/list ([b (in-list bindings)]
+                                             #:unless (path-binding? b))
+                                    b))
+           (values paths
+                   `(lambda ,path-ids
+                      (let* ,other-bindings ,body)))]
+          [else
+           (values paths linklet-e)])]
+       [else
+        (values '() linklet-e)])]))
+
+(define (make-path->compiled-path who)
+  (define path->relative-path-elements (make-path->relative-path-elements #:who who))
+  (lambda (orig-p)
+    (cond
+      [(to-fasl? orig-p)
+       (define v (force-unfasl orig-p))
+       (cond
+         [(symbol? v)
+          ;; Shortcut for just an uninterned symbol:
+          (box v)]
+         [else
+          (define lifts '())
+          (define bstr (s-exp->fasl v
+                                    #:handle-fail cannot-fasl
+                                    ;; We have to keep uninterned symbols exposed, so they're
+                                    ;; fasled with the encloding linklet directory
+                                    #:external-lift? (lambda (v)
+                                                       (and (symbol? v)
+                                                            (not (symbol-interned? v))
+                                                            (not (symbol-unreadable? v))
+                                                            (begin
+                                                              (set! lifts (cons v lifts))
+                                                              #t)))))
+          (if (null? lifts)
+              (box bstr)
+              (box (cons bstr (list->vector (reverse lifts)))))])]
+      [(symbol? orig-p)
+       ;; Must be an uninterned symbol:
+       orig-p]
+      [else
+       (define p (if (path-for-srcloc? orig-p)
+                     (path-for-srcloc-path orig-p)
+                     orig-p))
+       (cond
+         [(path? p)
+          (or (path->relative-path-elements p)
+              (cond
+                [(path-for-srcloc? orig-p)
+                 ;; Can't make relative, so create a string that keeps up
+                 ;; to two path elements
+                 (truncate-path p)]
+                [else (path->bytes p)]))]
+         [(or (string? p) (bytes? p) (symbol? p) (not p))
+          ;; Allowed in compiled form
+          p]
+         [else
+          (error 'write
+                 "cannot marshal value that is embedded in compiled code: ~V"
+                 p)])])))
+
+(define (compiled-path->path e)
+  (cond
+    [(box? e)
+     (define c (unbox e))
+     (to-fasl (box (if (pair? c) (car c) c))
+              (if (pair? c) (cdr c) '#())
+              (and (not (symbol? c))
+                   (or (current-load-relative-directory)
+                       (current-directory))))]
+    [(symbol? e)
+     ;; Must be an uninterned symbol:
+     e]
+    [(bytes? e) (bytes->path e)]
+    [(string? e) e] ; was `path-for-srcloc` on write
+    [else (relative-path-elements->path e)]))
+
+(define (force-unfasl tf)
+  (define vb (to-fasl-vb tf))
+  (define v (unbox vb))
+  (cond
+    [(bytes? v)
+     (define v2 (parameterize ([current-load-relative-directory (to-fasl-wrt tf)])
+                  (fasl->s-exp v
+                               #:datum-intern? #t
+                               #:external-lifts (to-fasl-lifts tf))))
+     (box-cas! vb v v2)
+     (set-to-fasl-wrt! tf #f)
+     (unbox vb)]
+    [else
+     ;; already forced (or never fasled)
+     v]))
+
+(define (cannot-fasl v)
+  (error 'write
+         "cannot marshal value that is embedded in compiled code\n  value: ~v"
+         v))
diff --git a/src/schemify/unnest-let.rkt b/src/schemify/unnest-let.rkt
new file mode 100644
index 0000000000..b1da5c1a17
--- /dev/null
+++ b/src/schemify/unnest-let.rkt
@@ -0,0 +1,102 @@
+#lang racket/base
+(require "wrap.rkt"
+         "match.rkt"
+         "simple.rkt")
+
+(provide unnest-let)
+
+;; Rotate something like
+;;
+;;  (let ([x (let ([y <simple>])
+;;              <rhs>)])
+;;    <body>)
+;;
+;; to
+;;
+;;  (let ([y <simple>])
+;;    (let ([x <rhs>])
+;;       <body>)))
+;; 
+;; to better expose procedure bindings for the lifting phase.
+;;
+;; For `letrec*`, we rewrite to
+;;
+;;  (letrec* ([y <simple>]
+ ;;           [x <rhs>])
+;;    <body>)
+;;
+;; because <simple> might refer to `x`. We only do that when <simple>
+;; and <rhs> are immediate `lambda` forms, though, to avoid
+;; pessimizing a set of mutually recursive functions.
+
+(define (unnest-let e prim-knowns knowns imports mutated simples)
+  (match e
+    [`(,let-id (,binds ...) . ,body)
+     (cond
+       [(or (eq? let-id 'let)
+            (eq? let-id 'letrec*))
+        (let loop ([binds binds]
+                   [accum-binds '()]
+                   [wraps '()]
+                   [convert? #f])
+          (cond
+            [(null? binds)
+             (if (not convert?)
+                 e
+                 (let loop ([wraps wraps] [e `(,let-id ,(reverse accum-binds) . ,body)])
+                   (cond
+                     [(null? wraps) e]
+                     [else
+                      (loop (cdr wraps)
+                            `(,(caar wraps) ,(cdar wraps) ,e))])))]
+            [else
+             (match (car binds)
+               [`[,id (,nest-let-id ([,ids ,rhss] ...)
+                                    ,body)]
+                (cond
+                  [(not (or (eq? let-id 'let)
+                            (immediate-lambda? body)))
+                   e]
+                  [(and (or (eq? 'let nest-let-id)
+                            (eq? 'letrec* nest-let-id))
+                        (for/and ([rhs (in-list rhss)])
+                          (and (or (eq? 'let let-id)
+                                   (immediate-lambda? rhs))
+                               (simple? rhs prim-knowns knowns imports mutated simples))))
+                   (match (car binds)
+                     [`[,_ (,_ ,inner-binds ,_)]
+                      (cond
+                        [(eq? 'let let-id)
+                         ;; let: can lift out
+                         (loop (cdr binds)
+                               (cons `[,id ,body] accum-binds)
+                               (cons (cons nest-let-id
+                                           inner-binds)
+                                     wraps)
+                               #t)]
+                        [else
+                         ;; letrec: need to keep in same set of bindings
+                         (loop (cdr binds)
+                               (cons `[,id ,body] (append inner-binds accum-binds))
+                               wraps
+                               #t)])])]
+                  [else (loop (cdr binds)
+                              (cons (car binds) accum-binds)
+                              wraps
+                              convert?)])]
+               [`[,_ ,rhs]
+                (if (or (eq? let-id 'let)
+                        (immediate-lambda? rhs))
+                    (loop (cdr binds)
+                          (cons (car binds) accum-binds)
+                          wraps
+                          convert?)
+                    e)])]))]
+       [else e])]
+    [`,_ e]))
+
+(define (immediate-lambda? e)
+  (match e
+    [`(lambda . ,_) #t]
+    [`(case-lambda . ,_) #t]
+    [`,_ #f]))