suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: path adjustments on write and read of compiled code

Browse Source 
Use `current-write-relative-directory`, etc.
This commit is contained in:
Matthew Flatt 2019-01-13 07:46:04 -07:00
parent 56846a9ca2
commit 3b76e44730
13 changed files with 201 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.2.0.1")
(define version "7.2.0.2")
(define deps `("racket-lib"
["racket" #:version ,version]))

5
pkgs/racket-test-core/tests/racket/print.rktl
View File

@ -352,7 +352,8 @@
(define c (compile `,(srcloc v 1 2 3 4)))
(cond
[ok?
(write c o)
(parameterize ([current-write-relative-directory (current-directory)])
(write c o))
(test result-v
srcloc-source
(parameterize ([current-load-relative-directory (build-path (current-directory) "sub")])
@ -377,6 +378,8 @@
(try (build-path "x" "apple" 'same) ".../apple/.")
(let ([d (car (filesystem-root-list))])
(try (build-path d 'up) (path->string (build-path d 'up))))
(try (build-path (current-directory) "apple")
(build-path (current-directory) "sub" "apple"))
(try 7 #:ok? #f)
(try (box 7) #:ok? #f))

69
racket/src/cs/linklet.sls
View File

@ -202,18 +202,21 @@
(hash-for-each table (lambda (k v) (hash-set! primitives k v))))
tables))
(define (outer-eval s format)
(define (outer-eval s paths format)
(if (eq? format 'interpret)
(interpret-linklet s primitives variable-ref variable-ref/no-check variable-set!
(interpret-linklet s paths primitives variable-ref variable-ref/no-check variable-set!
make-arity-wrapper-procedure)
(compile* s)))
(let ([proc (compile* s)])
(if (null? paths)
proc
(#%apply proc paths)))))
(define (compile*-to-bytevector s)
(let-values ([(o get) (open-bytevector-output-port)])
(compile-to-port* (list `(lambda () ,s)) o)
(get)))
(define (compile-to-bytevector s format)
(define (compile-to-bytevector s paths format)
(let ([bv (cond
[(eq? format 'interpret)
(let-values ([(o get) (open-bytevector-output-port)])
@ -224,7 +227,7 @@
(bytevector-compress bv)
bv)))
(define (eval-from-bytevector c-bv format)
(define (eval-from-bytevector c-bv paths format)
(let ([bv (if (bytevector-uncompressed-fasl? c-bv)
c-bv
(begin
@ -240,11 +243,14 @@
(fasl-read (open-bytevector-input-port bv)))])
(performance-region
'outer
(outer-eval r format)))]
(outer-eval r paths format)))]
[else
(performance-region
'faslin-code
(code-from-bytevector bv))])))
(let ([proc (performance-region
'faslin-code
(code-from-bytevector bv))])
(if (null? paths)
proc
(#%apply proc paths)))])))
(define (code-from-bytevector bv)
(let ([i (open-bytevector-input-port bv)])
@ -319,13 +325,13 @@
[code (lookup-code hash)])
(cond
[code
(let* ([f (eval-from-bytevector code 'compile)])
(let* ([f (eval-from-bytevector code '() 'compile)])
(wrapped-code-content-set! wc f)
f)]
[else
(let ([code (compile-to-bytevector (vector-ref f 1) 'compile)])
(let ([code (compile-to-bytevector (vector-ref f 1) '() 'compile)])
(insert-code hash code)
(let* ([f (eval-from-bytevector code 'compile)])
(let* ([f (eval-from-bytevector code '() 'compile)])
(wrapped-code-content-set! wc f)
f))]))]
[else
@ -384,7 +390,8 @@
;; A linklet also has a table of information about its
(define-record-type linklet
(fields (mutable code) ; the procedure
(fields (mutable code) ; the procedure or interpretable form
paths ; list of paths; if non-empty, `code` expects them as arguments
format ; 'compile or 'interpret (where the latter may have compiled internal parts)
(mutable preparation) ; 'faslable, 'faslable-strict, 'callable, or 'lazy
importss-abi ; ABI for each import, in parallel to `importss`
@ -392,10 +399,11 @@
name ; name of the linklet (for debugging purposes)
importss ; list of list of import symbols
exports) ; list of export symbols
(nongenerative #{linklet Zuquy0g9bh5vmeespyap4g-0}))
(nongenerative #{linklet Zuquy0g9bh5vmeespyap4g-1}))
(define (set-linklet-code linklet code preparation)
(make-linklet code
(linklet-paths linklet)
(linklet-format linklet)
preparation
(linklet-importss-abi linklet)
@ -404,6 +412,17 @@
(linklet-importss linklet)
(linklet-exports linklet)))
(define (set-linklet-paths linklet paths)
(make-linklet (linklet-code linklet)
paths
(linklet-format linklet)
(linklet-preparation linklet)
(linklet-importss-abi linklet)
(linklet-exports-info linklet)
(linklet-name linklet)
(linklet-importss linklet)
(linklet-exports linklet)))
(define compile-linklet
(case-lambda
[(c) (compile-linklet c #f #f (lambda (key) (values #f #f)) '(serializable))]
@ -475,18 +494,22 @@
(if serializable?
(make-wrapped-code code arity-mask name)
code))))])))]))
(define-values (paths impl-lam/paths)
(if serializable?
(extract-paths-from-schemified-linklet impl-lam/jitified (not jitify-mode?))
(values '() impl-lam/jitified)))
(define impl-lam/interpable
(let ([impl-lam (case (and jitify-mode?
linklet-compilation-mode)
[(mach) (show post-lambda-on? "post-lambda" impl-lam/jitified)]
[else (show "schemified" impl-lam/jitified)])])
[(mach) (show post-lambda-on? "post-lambda" impl-lam/paths)]
[else (show "schemified" impl-lam/paths)])])
(if jitify-mode?
(interpretable-jitified-linklet impl-lam correlated->datum)
(correlated->annotation impl-lam))))
(when known-on?
(show "known" (hash-map exports-info (lambda (k v) (list k v)))))
(when cp0-on?
(show "cp0" (#%expand/optimize impl-lam/interpable)))
(when (and cp0-on? (not jitify-mode?))
(show "cp0" (#%expand/optimize impl-lam/paths)))
(performance-region
'compile-linklet
;; Create the linklet:
@ -494,7 +517,9 @@
(lambda ()
((if serializable? compile-to-bytevector outer-eval)
(show (and jitify-mode? post-interp-on?) "post-interp" impl-lam/interpable)
paths
format)))
paths
format
(if serializable? 'faslable 'callable)
importss-abi
@ -539,7 +564,9 @@
[(faslable)
(set-linklet-code linklet (linklet-code linklet) 'lazy)]
[(faslable-strict)
(set-linklet-code linklet (eval-from-bytevector (linklet-code linklet) (linklet-format linklet)) 'callable)]
(set-linklet-code linklet
(eval-from-bytevector (linklet-code linklet) (linklet-paths linklet) (linklet-format linklet))
'callable)]
[else
linklet]))
@ -559,7 +586,7 @@
(register-linklet-instantiate-continuation! k (instance-name target-instance))
(when (eq? 'lazy (linklet-preparation linklet))
;; Trigger lazy conversion of code from bytevector
(let ([code (eval-from-bytevector (linklet-code linklet) (linklet-format linklet))])
(let ([code (eval-from-bytevector (linklet-code linklet) (linklet-paths linklet) (linklet-format linklet))])
(with-interrupts-disabled
(when (eq? 'lazy (linklet-preparation linklet))
(linklet-code-set! linklet code)
@ -577,7 +604,7 @@
(apply
(if (eq? 'callable (linklet-preparation linklet))
(linklet-code linklet)
(eval-from-bytevector (linklet-code linklet) (linklet-format linklet)))
(eval-from-bytevector (linklet-code linklet) (linklet-paths linklet) (linklet-format linklet)))
(make-variable-reference target-instance #f)
(append (apply append
(map (make-extract-variables target-instance)

14
racket/src/cs/linklet/read.ss
View File

@ -4,7 +4,7 @@
'read-linklet
(let* ([len (integer-bytes->integer (read-bytes 4 in) #f #f)]
[bstr (read-bytes len in)])
(adjust-linklet-bundle-laziness
(adjust-linklet-bundle-laziness-and-paths
(fasl-read (open-bytevector-input-port bstr))))))
(define read-on-demand-source
@ -17,7 +17,7 @@
v))
v)))
(define (adjust-linklet-bundle-laziness ht)
(define (adjust-linklet-bundle-laziness-and-paths ht)
(let loop ([i (hash-iterate-first ht)])
(cond
[(not i) (hasheq)]
@ -26,7 +26,8 @@
(hash-set (loop (hash-iterate-next ht i))
key
(if (linklet? val)
(adjust-linklet-laziness val)
(adjust-linklet-laziness
(decode-linklet-paths val))
val)))])))
(define (adjust-linklet-laziness linklet)
@ -36,3 +37,10 @@
'faslable
'faslable-strict)))
(define (decode-linklet-paths linklet)
(let ([paths (linklet-paths linklet)])
(cond
[(null? paths)
linklet]
[else
(set-linklet-paths linklet (map compiled-path->path paths))])))

20
racket/src/cs/linklet/write.ss
View File

@ -5,7 +5,25 @@
(define (write-linklet-bundle-hash ht dest-o)
(let-values ([(o get) (open-bytevector-output-port)])
(fasl-write* ht o)
(fasl-write* (encode-linklet-paths ht) o)
(let ([bstr (get)])
(write-bytes (integer->integer-bytes (bytes-length bstr) 4 #f #f) dest-o)
(write-bytes bstr dest-o))))
(define (encode-linklet-paths orig-ht)
(let ([path->compiled-path (make-path->compiled-path 'write-linklet)])
(let loop ([i (hash-iterate-first orig-ht)] [ht orig-ht])
(cond
[(not i) ht]
[else
(let-values ([(key v) (hash-iterate-key+value orig-ht i)])
(let ([new-ht (if (and (linklet? v)
(pair? (linklet-paths v)))
(hash-set ht key
(set-linklet-paths
v
(map path->compiled-path
(linklet-paths v))))
ht)])
(loop (hash-iterate-next orig-ht i)
new-ht)))]))))

3
racket/src/cs/schemify.sls
View File

@ -3,9 +3,12 @@
lift-in-schemified-linklet
jitify-schemified-linklet
xify
extract-paths-from-schemified-linklet
interpretable-jitified-linklet
interpret-linklet
linklet-bigger-than?
make-path->compiled-path
compiled-path->path
prim-knowns
known-procedure
known-procedure/pure

2
racket/src/expander/main.rkt
View File

@ -117,7 +117,7 @@
expander-place-init!
fasl->s-exp/intern
fasl->s-exp/intern ; for Chez Scheme as "primitive" and in linklet layer
;; The remaining functions are provided for basic testing
;; (such as "demo.rkt")

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "7.2.0.1"
#define MZSCHEME_VERSION "7.2.0.2"
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 1
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

28
racket/src/schemify/interpret.rkt
View File

@ -3,6 +3,7 @@
racket/fixnum
"match.rkt"
"wrap.rkt"
"path-for-srcloc.rkt"
"interp-match.rkt"
"interp-stack.rkt")
@ -80,8 +81,17 @@
(loop (cdr bindings)
(fx+ elem 1)
(hash-set env (car binding) (indirect 0 elem))
(cons (compile-expr (cadr binding) env 1 bindings-stk-i #t)
accum)))]))]))
(let ([rhs (cadr binding)])
(cons (cond
[(or (path? rhs)
(path-for-srcloc? rhs))
;; The caller must extract all the paths from the bindings
;; and pass them back in at interp time; assume '#%path is
;; not a primitive
'#%path]
[else
(compile-expr rhs env 1 bindings-stk-i #t)])
accum))))]))]))
(define (compile-linklet-body v env stack-depth)
(match v
@ -408,6 +418,7 @@
;; ----------------------------------------
(define (interpret-linklet b ; compiled form
paths ; unmarshaled paths
primitives ; hash of symbol -> value
;; the implementation of variables:
variable-ref variable-ref/no-check variable-set!
@ -419,10 +430,15 @@
(let ([consts (and consts
(let ([vec (make-vector (vector*-length consts))])
(define stack (stack-set empty-stack 0 vec))
(for ([b (in-vector consts)]
[i (in-naturals)])
(vector-set! vec i (interpret-expr b stack primitives void void void void))
vec)
(for/fold ([paths paths]) ([b (in-vector consts)]
[i (in-naturals)])
(cond
[(eq? b '#%path)
(vector-set! vec i (car paths))
(cdr paths)]
[else
(vector-set! vec i (interpret-expr b stack primitives void void void void))
paths]))
vec))])
(lambda args
(define start-stack (if consts

5
racket/src/schemify/main.rkt
View File

@ -4,6 +4,7 @@
"lift.rkt"
"jitify.rkt"
"xify.rkt"
"path.rkt"
"interpret.rkt"
"size.rkt")
@ -19,6 +20,10 @@
xify
extract-paths-from-schemified-linklet
make-path->compiled-path
compiled-path->path
interpretable-jitified-linklet
interpret-linklet

5
racket/src/schemify/path-for-srcloc.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(provide (struct-out path-for-srcloc))
(struct path-for-srcloc (path))

66
racket/src/schemify/path.rkt Normal file
View File

@ -0,0 +1,66 @@
#lang racket/base
(require racket/private/relative-path
racket/private/truncate-path
"match.rkt"
"path-for-srcloc.rkt")
(provide extract-paths-from-schemified-linklet
make-path->compiled-path
compiled-path->path)
;; Recognize lifted paths in a schemified linklet, and
;; return the list of path values. If `convert?`, then
;; change the schemified linklet to expect the paths
;; as arguments.
(define (extract-paths-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)))
(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)
(define p (if (path-for-srcloc? orig-p)
(path-for-srcloc-path orig-p)
orig-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)]))))
(define (compiled-path->path e)
(cond
[(bytes? e) (bytes->path e)]
[(string? e) e] ; was `path-for-srcloc` on write
[else (relative-path-elements->path e)]))

17
racket/src/schemify/serialize.rkt
View File

@ -3,6 +3,7 @@
racket/prefab
"match.rkt"
"wrap.rkt"
"path-for-srcloc.rkt"
"quoted.rkt")
(provide convert-for-serialize)
@ -160,13 +161,23 @@
[else
(define rhs
(cond
[(path? q) `(bytes->path ,(path->bytes q)
',(path-convention-type q))]
[(path? q)
(if for-cify?
`(bytes->path ,(path->bytes q)
',(path-convention-type q))
;; We expect paths to be recognized in lifted bindings
;; and handled specially, so no conversion here:
q)]
[(path-for-srcloc? q) q]
[(regexp? q)
`(,(if (pregexp? q) 'pregexp 'regexp) ,(object-name q))]
[(srcloc? q)
`(unsafe-make-srcloc
,(make-construct (srcloc-source q))
,(let ([src (srcloc-source q)])
(if (and (path? src) (not for-cify?))
;; Like paths, `path-for-srcloc` must be recognized later
(make-construct (path-for-srcloc src))
(make-construct src)))
,(make-construct (srcloc-line q))
,(make-construct (srcloc-column q))
,(make-construct (srcloc-position q))