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

Merge git.racket-lang.org:plt

Browse Source
This commit is contained in:
Matthew Flatt 2015-07-16 08:37:48 -06:00
commit ae88c96f50
38 changed files with 1312 additions and 335 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-doc/pkg/scribblings/lib.scrbl
View File

@ -161,7 +161,7 @@ the package is should be treated as installed automatically for a
dependency.
The optional @racket[path] argument is intended for use when
@racket[type] is @racket['clone], in which case it specifies< a
@racket[type] is @racket['clone], in which case it specifies a
directory containing the repository clone (where the repository itself
is a directory within @racket[path]).

12
pkgs/racket-doc/scribblings/foreign/types.scrbl
View File

@ -1023,13 +1023,11 @@ Racket vectors instead of lists.}
(_bytes o len-expr)]]{
A @tech{custom function type} that can be used by itself as a simple
type for a byte string as a C pointer. Alternatively, the second form
is for a pointer return value, where the size should be explicitly
specified.
There is no need for other modes analogous to those of @racket[_ptr]:
input or input/output would be just like @racket[_bytes], since the
string carries its size information.}
type for a byte string as a C pointer. Coercion of a C pointer to
simply @racket[_bytes] (without a specified length) requires that the pointer
refers to a nul-terminated byte string. When the length-specifying form is used
for a function argument, a byte string is allocated with the given
length, including an extra byte for the nul terminator.}
@; ------------------------------------------------------------

28
pkgs/racket-doc/scribblings/guide/performance.scrbl
View File

@ -2,7 +2,8 @@
@(require scribble/manual "guide-utils.rkt"
(for-label racket/flonum
racket/unsafe/ops
racket/performance-hint))
racket/performance-hint
ffi/unsafe))
@title[#:tag "performance"]{Performance}
@ -358,6 +359,31 @@ crashes or memory corruption.
@; ----------------------------------------------------------------------
@section[#:tag "ffi-pointer-access"]{Foreign Pointers}
The @racketmodname[ffi/unsafe] library provides functions for unsafely
reading and writing arbitrary pointer values. The JIT recognizes uses
of @racket[ptr-ref] and @racket[ptr-set!] where the second argument is
a direct reference to one of the following built-in C types:
@racket[_int8], @racket[_int16], @racket[_int32], @racket[_int64],
@racket[_double], @racket[_float], and @racket[_pointer]. Then, if the
first argument to @racket[ptr-ref] or @racket[ptr-set!] is a C pointer
(not a byte string), then the pointer read or write is performed
inline in the generated code.
The bytecode compiler will optimize references to integer
abbreviations like @racket[_int] to C types like
@racket[_int32]---where the representation sizes are constant across
platforms---so the JIT can specialize access with those C types. C
types such as @racket[_long] or @racket[_intptr] are not constant
across platforms, so their uses are currently not specialized by the
JIT.
Pointer reads and writes using @racket[_float] or @racket[_double] are
not currently subject to unboxing optimizations.
@; ----------------------------------------------------------------------
@section[#:tag "regexp-perf"]{Regular Expression Performance}
When a string or byte string is provided to a function like

7
pkgs/racket-doc/scribblings/reference/channels.scrbl
View File

@ -15,10 +15,9 @@ often, then the thread eventually participates in a transaction.
In addition to its use with channel-specific procedures, a channel can
be used as a @tech{synchronizable event} (see @secref["sync"]). A
channel is @tech{ready for synchronization} when @racket[make-channel]
is ready when @racket[channel-get] would not block; the channel's
@tech{synchronization result} is the same as the @racket[channel-get]
result.
channel is @tech{ready for synchronization} when @racket[channel-get]
would not block; the channel's @tech{synchronization result} is the
same as the @racket[channel-get] result.
For buffered asynchronous channels, see @secref["async-channel"].

116
pkgs/racket-test-core/tests/racket/foreign-test.rktl
View File

@ -966,6 +966,122 @@
(define-cpointer-type _foo)
(test 'foo? object-name foo?)
;; ----------------------------------------
;; Test JIT inlining
(define bstr (cast (make-bytes 64) _pointer _pointer))
(for/fold ([v 1.0]) ([i (in-range 100)])
(ptr-set! bstr _float v)
(ptr-set! bstr _float 1 (+ v 0.5))
(ptr-set! bstr _float 'abs 8 (+ v 0.25))
(unless (= v (ptr-ref bstr _float))
(error 'float "failed"))
(unless (= (+ v 0.5) (ptr-ref bstr _float 'abs 4))
(error 'float "failed(2) ~s ~s" (+ v 0.5) (ptr-ref bstr _float 'abs 4)))
(unless (= (+ v 0.25) (ptr-ref bstr _float 2))
(error 'float "failed(3)"))
(+ 1.0 v))
(for/fold ([v 1.0]) ([i (in-range 100)])
(ptr-set! bstr _double v)
(ptr-set! bstr _double 1 (+ v 0.5))
(ptr-set! bstr _double 'abs 16 (+ v 0.25))
(unless (= v (ptr-ref bstr _double))
(error 'double "failed"))
(unless (= (+ v 0.5) (ptr-ref bstr _double 'abs 8))
(error 'double "failed(2)"))
(unless (= (+ v 0.25) (ptr-ref bstr _double 2))
(error 'double "failed(3)"))
(+ 1.0 v))
(for ([i (in-range 256)])
(ptr-set! bstr _uint8 i)
(ptr-set! bstr _uint8 1 (- 255 i))
(unless (= i (ptr-ref bstr _uint8))
(error 'uint8 "fail ~s vs. ~s" i (ptr-ref bstr _uint8)))
(unless (= (- 255 i) (ptr-ref bstr _uint8 'abs 1))
(error 'uint8 "fail(2) ~s vs. ~s" (- 255 i) (ptr-ref bstr _uint8 'abs 1))))
(for ([i (in-range -128 128)])
(ptr-set! bstr _int8 i)
(unless (= i (ptr-ref bstr _int8))
(error 'int8 "fail ~s vs. ~s" i (ptr-ref bstr _int8))))
(for ([i (in-range (expt 2 16))])
(ptr-set! bstr _uint16 i)
(ptr-set! bstr _uint16 3 (- (sub1 (expt 2 16)) i))
(unless (= i (ptr-ref bstr _uint16))
(error 'uint16 "fail ~s vs. ~s" i (ptr-ref bstr _uint16)))
(unless (= (- (sub1 (expt 2 16)) i) (ptr-ref bstr _uint16 'abs 6))
(error 'uint16 "fail(2) ~s vs. ~s" (- (sub1 (expt 2 16)) i) (ptr-ref bstr _uint16 'abs 6))))
(for ([j (in-range 100)])
(for ([i (in-range (- (expt 2 15)) (sub1 (expt 2 15)))])
(ptr-set! bstr _int16 i)
(unless (= i (ptr-ref bstr _int16))
(error 'int16 "fail ~s vs. ~s" i (ptr-ref bstr _int16)))))
(let ()
(define (go lo hi)
(for ([i (in-range lo hi)])
(ptr-set! bstr _uint32 i)
(ptr-set! bstr _uint32 1 (- hi (- i lo) 1))
(unless (= i (ptr-ref bstr _uint32))
(error 'uint32 "fail ~s vs. ~s" i (ptr-ref bstr _uint32)))
(unless (= (- hi (- i lo) 1) (ptr-ref bstr _uint32 'abs 4))
(error 'uint32 "fail ~s vs. ~s" (- hi (- i lo) 1) (ptr-ref bstr _uint32)))))
(go 0 256)
(go (- (expt 2 31) 256) (+ (expt 2 31) 256))
(go (- (expt 2 32) 256) (expt 2 32)))
(let ()
(define (go lo hi)
(for ([i (in-range lo hi)])
(ptr-set! bstr _int32 i)
(unless (= i (ptr-ref bstr _int32))
(error 'int32 "fail ~s vs. ~s" i (ptr-ref bstr _int32)))))
(go -256 256)
(go (- (expt 2 31) 256) (sub1 (expt 2 31)))
(go (- (expt 2 31)) (- 256 (expt 2 31))))
(let ()
(define (go lo hi)
(for ([i (in-range lo hi)])
(ptr-set! bstr _uint64 i)
(ptr-set! bstr _uint64 1 (- hi (- i lo) 1))
(unless (= i (ptr-ref bstr _uint64))
(error 'uint64 "fail ~s vs. ~s" i (ptr-ref bstr _uint64)))
(unless (= (- hi (- i lo) 1) (ptr-ref bstr _uint64 'abs 8))
(error 'uint32 "fail ~s vs. ~s" (- hi (- i lo) 1) (ptr-ref bstr _uint64)))))
(go 0 256)
(go (- (expt 2 63) 256) (+ (expt 2 63) 256))
(go (- (expt 2 64) 256) (expt 2 64)))
(let ()
(define (go lo hi)
(for ([i (in-range lo hi)])
(ptr-set! bstr _int64 i)
(unless (= i (ptr-ref bstr _int64))
(error 'int64 "fail ~s vs. ~s" i (ptr-ref bstr _int64)))))
(go -256 256)
(go (- (expt 2 63) 256) (sub1 (expt 2 63)))
(go (- (expt 2 63)) (- 256 (expt 2 63))))
(let ()
(define p (cast bstr _pointer _pointer))
(for ([i (in-range 100)])
(ptr-set! bstr _pointer (ptr-add p i))
(ptr-set! bstr _pointer 2 p)
(unless (ptr-equal? p (ptr-add (ptr-ref bstr _pointer) (- i)))
(error 'pointer "fail ~s vs. ~s"
(cast p _pointer _intptr)
(cast (ptr-ref bstr _pointer) _pointer _intptr)))
(unless (ptr-equal? p (ptr-ref bstr _pointer 'abs (* 2 (ctype-sizeof _pointer))))
(error 'pointer "fail ~s vs. ~s"
(cast p _pointer _intptr)
(cast (ptr-ref bstr _pointer 'abs (ctype-sizeof _pointer)) _pointer _intptr)))))
;; ----------------------------------------
(report-errs)

56
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -1485,6 +1485,11 @@
(let ([y (random)])
(begin0 y (set! y 5)))))
(test-comp '(lambda (x y) (car x) (unbox y) #f)
'(lambda (x y) (car x) (unbox y) (eq? x y)))
(test-comp '(lambda (x) (car x) #f)
'(lambda (x) (car x) (eq? x (box 0))))
(test-comp '(lambda (w) (car w) (mcar w))
'(lambda (w) (car w) (mcar w) (random)))
(test-comp '(lambda (w) (car w w))
@ -1563,6 +1568,17 @@
(test-comp '(lambda (w) (if (void (list w)) 1 2))
'(lambda (w) 1))
; Diferent number of argumets use different codepaths
(test-comp '(lambda (f x) (void))
'(lambda (f x) (void (list))))
(test-comp '(lambda (f x) (begin (values (f x)) (void)))
'(lambda (f x) (void (list (f x)))))
(test-comp '(lambda (f x) (begin (values (f x)) (values (f x)) (void)))
'(lambda (f x) (void (list (f x) (f x)))))
(test-comp '(lambda (f x) (begin (values (f x)) (values (f x)) (values (f x)) (void)))
'(lambda (f x) (void (list (f x) (f x) (f x)))))
(test null
call-with-values (lambda () (with-continuation-mark 'a 'b (values))) list)
@ -1689,6 +1705,13 @@
(test-comp '(lambda (x) (not (if x #f 2)))
'(lambda (x) (not (if x #f #t))))
(test-comp '(lambda (x) (let ([z 2]) (not (if x #f z))))
'(lambda (x) (let ([z 2]) (not (if x #f #t)))))
(test-comp '(lambda (z) (when (pair? z) #f))
'(lambda (z) (when (pair? z) (not z))))
(test-comp '(lambda (z) (when (pair? z) (set! z #f) #f))
'(lambda (z) (when (pair? z) (set! z #f) (not z)))
#f)
(test-comp '(lambda (x) (if x x #f))
'(lambda (x) x))
@ -1734,6 +1757,27 @@
(if r #t (something-else))))
'(lambda (x) (if (something) #t (something-else))))
(let ([test-pred-implies-val
(lambda (pred? val)
(test-comp `(lambda (x) (if (,pred? x) ,val 0))
`(lambda (x) (if (,pred? x) x 0))))])
(test-pred-implies-val 'null? 'null)
(test-pred-implies-val 'void? '(void))
(test-pred-implies-val 'eof-object? 'eof)
(test-pred-implies-val 'not '#f))
(test-comp '(lambda (x) (if (null? x) 1 0) null)
'(lambda (x) (if (null? x) 1 0) x)
#f)
(test-comp '(lambda (x) (if (eq? x '(0)) #t 0))
'(lambda (x) (if (eq? x '(0)) (pair? x) 0)))
(test-comp '(lambda (x) (if (eq? x (list 0)) #t 0))
'(lambda (x) (if (eq? x (list 0)) (pair? x) 0)))
(test-comp '(lambda (x y) (car y) (if (eq? x y) #t 0))
'(lambda (x y) (car y) (if (eq? x y) (pair? x) 0)))
(test-comp '(lambda (x) (if x 1 (list #f)))
'(lambda (x) (if x 1 (list x))))
(test-comp '(lambda (x) (let ([r (something)])
(r)))
'(lambda (x) ((something))))
@ -4866,6 +4910,18 @@
#f))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure the compiler doesn't try to inline forever,
;; due to bad single-use tracking:
(module check-inline-single-use-tracking racket/base
(define dup (lambda (f) (f f)))
(lambda ()
;; Initially, `rep` is used only once, but inlining
;; followed by other optimizations changes that:
(let ([rep (lambda (f) (f f))])
(dup rep))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

60
pkgs/racket-test/tests/pkg/tests-clone.rkt
View File

@ -44,14 +44,15 @@
(define a-dir (build-path tmp-dir "a"))
(define (commit-changes-cmd [a-dir a-dir])
(~a "cd " a-dir "; git add .; git commit -m change; git update-server-info"))
;; ----------------------------------------
;; Single-package repository
(make-directory a-dir)
$ (~a "cd " a-dir "; git init")
(set-file (build-path a-dir "main.rkt") "#lang racket/base 1")
(define (commit-changes-cmd [a-dir a-dir])
(~a "cd " a-dir "; git add .; git commit -m change; git update-server-info"))
$ (commit-changes-cmd)
(with-fake-root
@ -186,6 +187,61 @@
(delete-directory/files (build-path clone-dir "a"))
(delete-directory/files a-dir)
;; ----------------------------------------
;; Single-package repository that becomes multi-package
(define (check-changing try-bogus?)
(shelly-case
"Single-package repository that becomes multi-package"
(make-directory a-dir)
$ (~a "cd " a-dir "; git init")
(set-file (build-path a-dir "main.rkt") "#lang racket/base 1")
$ (commit-changes-cmd)
(with-fake-root
(shelly-begin
(shelly-case
"--clone installation with path into repository"
$ (~a "raco pkg install --clone " (build-path clone-dir "a") " --name one http://localhost:9998/a/.git")
$ "racket -l one" =stdout> "1\n"
$ (~a "ls " (build-path clone-dir "a")))
$ (~a "cd " a-dir "; git rm main.rkt")
(make-directory* (build-path a-dir "one"))
(set-file (build-path a-dir "one" "main.rkt") "#lang racket/base 1")
(set-file (build-path a-dir "one" "info.rkt") "#lang info (define deps '(\"http://localhost:9998/a/.git?path=two\"))")
(make-directory* (build-path a-dir "two"))
(set-file (build-path a-dir "two" "main.rkt") "#lang racket/base 2")
$ (commit-changes-cmd)
(when try-bogus?
;; A `raco pkg update one` at this point effectively
;; breaks the package installation, because the package
;; source will remain pathless. We only try this sometimes,
;; so that we check the next step with an without creating
;; paths "one" and "two" before that step.
(shelly-begin
$ "raco pkg update one"
$ "racket -l one" =exit> 1))
$ (~a "raco pkg update --clone " (build-path clone-dir "a") " --auto --multi-clone convert http://localhost:9998/a/.git?path=one")
$ "racket -l one" =stdout> "1\n"
$ "racket -l two" =stdout> "2\n"
(set-file (build-path a-dir "two" "main.rkt") "#lang racket/base 2.0")
$ (commit-changes-cmd)
$ "racket -l two" =stdout> "2\n"
$ "raco pkg update two"
$ "racket -l two" =stdout> "2.0\n"))
(delete-directory/files (build-path clone-dir "a"))
(delete-directory/files a-dir)))
(check-changing #f)
(check-changing #t)
;; ----------------------------------------
;; Using local changes for metadata

34
racket/collects/ffi/unsafe.rkt
View File

@ -67,29 +67,33 @@
[else (error 'foreign "internal error: bad compiler size for `~s'"
c-type)]))
;; _short etc is a convenient name for whatever is the compiler's `short'
;; (_short is signed)
;; _short etc is a convenient name for the compiler's `short',
;; which is always a 16-bit value for Racket:
(provide _short _ushort _sshort)
(define-values (_short _ushort _sshort) (sizeof->3ints 'short))
(define _short _int16)
(define _ushort _uint16)
(define _sshort _short)
;; _int etc is a convenient name for whatever is the compiler's `int'
;; (_int is signed)
;; _int etc is a convenient name for whatever is the compiler's `int',
;; which is always a 32-byte value for Racket:
(provide _int _uint _sint)
(define-values (_int _uint _sint) (sizeof->3ints 'int))
(define _int _int32)
(define _uint _uint32)
(define _sint _int)
;; _long etc is a convenient name for whatever is the compiler's `long'
;; (_long is signed)
;; _long etc is a convenient name for whatever is the compiler's `long',
;; which varies among platforms:
(provide _long _ulong _slong)
(define-values (_long _ulong _slong) (sizeof->3ints 'long))
;; _llong etc is a convenient name for whatever is the compiler's `long long'
;; (_llong is signed)
;; which varies among platforms:
(provide _llong _ullong _sllong)
(define-values (_llong _ullong _sllong) (sizeof->3ints '(long long)))
;; _intptr etc is a convenient name for whatever is the integer
;; equivalent of the compiler's pointer (see `intptr_t') (_intptr is
;; signed)
;; equivalent of the compiler's pointer (see `intptr_t'),
;; which varies among platforms:
(provide _intptr _uintptr _sintptr)
(define-values (_intptr _uintptr _sintptr) (sizeof->3ints '(void *)))
@ -1042,8 +1046,12 @@
(provide (rename-out [_bytes* _bytes]))
(define-fun-syntax _bytes*
(syntax-id-rules (o)
[(_ o n) (type: _pointer
pre: (make-sized-byte-string (malloc n) n)
[(_ o n) (type: _gcpointer
pre: (let ([bstr (make-sized-byte-string (malloc (add1 n)) n)])
;; Ensure a null terminator, so that the result is
;; compatible with `_bytes`:
(ptr-set! bstr _byte n 0)
bstr)
;; post is needed when this is used as a function output type
post: (x => (make-sized-byte-string x n)))]
[(_ . xs) (_bytes . xs)]

2
racket/collects/ffi/unsafe/com.rkt
View File

@ -920,7 +920,7 @@
accum2
(for/fold ([accum accum2]) ([i (in-range (TYPEATTR-cVars type-attr))])
(define var-desc (GetVarDesc type-info i))
(let-values ([(name count) (GetNames type-info (FUNCDESC-memid var-desc))])
(let-values ([(name count) (GetNames type-info (VARDESC-memid var-desc))])
(begin0
(cons name accum)
(ReleaseVarDesc type-info var-desc))))))

2
racket/collects/pkg/main.rkt
View File

@ -129,7 +129,7 @@
" package: ~a\n"
" given path: ~a\n")
pkg
name)
clone)
(list pkg)]
[else
((pkg-error cmd)

11
racket/collects/pkg/private/clone-path.rkt
View File

@ -130,17 +130,18 @@
string-append
"packages from a Git repository " would " not share a local clone"
convert "\n"
(~a " repository: " repo "\n")
(~a " repository: " repo)
(append
(for/list ([(clone names) (in-hash clones)])
(~a " local clone: " clone "\n"
(~a "\n"
" local clone: " clone "\n"
" packages for local clone:"
(format-list names)
"\n"))
(format-list names)))
(list
(if (null? non-clones)
""
(~a " non-clone packages:"
(~a "\n"
" non-clone packages:"
(format-list non-clones)))))))
;; Determine a direction of conversion; we consider converting from

53
racket/collects/pkg/private/install.rkt
View File

@ -83,17 +83,21 @@
pkg-path
pkg-name)))
;; Check installed packages:
(for ([f (in-directory simple-pkg-path)])
(define found-pkg (path->pkg f #:cache path-pkg-cache))
(when (and found-pkg
(not (equal? found-pkg pkg-name)))
(pkg-error (~a "cannot link a directory that overlaps with existing packages\n"
" existing package: ~a\n"
" overlapping path: ~a\n"
" attempted package: ~a")
found-pkg
f
pkg-name)))
(when (directory-exists? simple-pkg-path) ; might not exist for a clone shifting to a subdir
(for ([f (in-directory simple-pkg-path)])
(define found-pkg (path->pkg f #:cache path-pkg-cache))
(when (and found-pkg
(not (equal? found-pkg pkg-name))
;; In case a new clone dir would overlap with an old one that is being
;; relocated (and if simultaneous installs really overlap, it's caught below):
(not (hash-ref simultaneous-installs found-pkg #f)))
(pkg-error (~a "cannot link a directory that overlaps with existing packages\n"
" existing package: ~a\n"
" overlapping path: ~a\n"
" attempted package: ~a")
found-pkg
f
pkg-name))))
;; Check simultaneous installs:
(for ([(other-pkg other-dir) (in-hash simultaneous-installs)])
(unless (equal? other-pkg pkg-name)
@ -993,7 +997,7 @@
(pkg-desc-type pkg-name)
#:link-dirs? link-dirs?
#:must-infer-name? (not (pkg-desc-name pkg-name))
#:complain (complain-about-source (pkg-desc-name pkg-name))))
#:complain (complain-about-source (pkg-desc-name pkg-name))))
(define name (or (pkg-desc-name pkg-name)
inferred-name))
;; Check that the package is installed, and get current checksum:
@ -1296,14 +1300,25 @@
(define (early-check-for-installed in-pkgs db #:wanted? wanted?)
(for ([d (in-list in-pkgs)])
(define name
(define-values (name ignored-type)
(if (pkg-desc? d)
(or (pkg-desc-name d)
(package-source->name (pkg-desc-source d)
(if (eq? 'clone (pkg-desc-type d))
'name
(pkg-desc-type d))))
(package-source->name d)))
;; For install of update:
(cond
[(pkg-desc-name d)
(values (pkg-desc-name d) #f)]
[(and (eq? (pkg-desc-type d) 'clone)
;; If syntax of the source is a package name, then it's a package name:
(let-values ([(name type) (package-source->name+type (pkg-desc-source d) 'name)])
name))
=> (lambda (name)
(values name #f))]
[else
(package-source->name+type (pkg-desc-source d)
(pkg-desc-type d)
#:must-infer-name? #t
#:complain (complain-about-source #f))])
;; Must be a string package name for update:
(values d #f)))
(define info (package-info name wanted? #:db db))
(when (and info
(not wanted?)

2
racket/collects/racket/contract/private/base.rkt
View File

@ -155,8 +155,6 @@
(define (recursive-contract-stronger this that) (equal? this that))
(define trail (make-parameter #f))
(define ((recursive-contract-first-order ctc) val)
(contract-first-order-passes? (force-recursive-contract ctc)
val))

4
racket/src/configure vendored
View File

@ -4537,7 +4537,7 @@ case "$host_os" in
LIBS="$LIBS -lsocket -lnsl -lintl"
need_gcc_static_libgcc="yes"
check_gcc_dash_e="yes"
try_poll_syscall="yes"
try_poll_syscall="no" # poll() has performance problems on Solaris?
use_flag_pthread="no"
use_flag_posix_pthread="yes"
;;
@ -6607,6 +6607,8 @@ fi
if test "${enable_noopt}" = "yes" ; then
AWKPRG='BEGIN { FS = "(^| )-O(0|1|2|3|4|5|6|7|8|9)?( |$)" } /.*/ { for (i = 1; i < NF; i++) printf "%s ", $i; print $NF }'
CFLAGS=`echo "$CFLAGS" | awk "$AWKPRG"`
CPPFLAGS=`echo "$CPPFLAGS" | awk "$AWKPRG"`
PREFLAGS=`echo "$PREFLAGS" | awk "$AWKPRG"`
fi
############## usersetup ################

75
racket/src/foreign/foreign.c
View File

@ -3100,6 +3100,11 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
}
#undef MYNAME
Scheme_Object *scheme_foreign_ptr_ref(int argc, Scheme_Object **argv)
{
return foreign_ptr_ref(argc, argv);
}
/* (ptr-set! cpointer type [['abs] n] value) -> void */
/* n defaults to 0 which is the only value that should be used with ffi_objs */
/* if n is given, an 'abs flag can precede it to make n be a byte offset */
@ -3148,6 +3153,11 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
}
#undef MYNAME
void scheme_foreign_ptr_set(int argc, Scheme_Object **argv)
{
(void)foreign_ptr_set_bang(argc, argv);
}
/* (ptr-equal? cpointer cpointer) -> boolean */
#define MYNAME "ptr-equal?"
static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[])
@ -3212,7 +3222,7 @@ void do_ptr_finalizer(void *p, void *finalizer)
THREAD_LOCAL_DECL(static Scheme_Hash_Table *ffi_lock_ht);
#ifdef MZ_PRECISE_GC
#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
static Scheme_Object *make_vector_in_master(int count, Scheme_Object *val) {
Scheme_Object *vec;
void *original_gc;
@ -4363,6 +4373,39 @@ void scheme_init_foreign_places() {
#endif
}
static Scheme_Object *scheme_make_inline_noncm_prim(Scheme_Prim *prim,
const char *name,
mzshort mina, mzshort maxa)
{
Scheme_Object *p;
int flags = 0;
p = scheme_make_noncm_prim(prim, name, mina, maxa);
if ((mina <= 1) && (maxa >= 1))
flags |= SCHEME_PRIM_IS_UNARY_INLINED;
if ((mina <= 2) && (maxa >= 2))
flags |= SCHEME_PRIM_IS_BINARY_INLINED;
if ((mina <= 0) || (maxa > 2))
flags |= SCHEME_PRIM_IS_NARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags);
return p;
}
Scheme_Object *scheme_pointer_ctype;
Scheme_Object *scheme_float_ctype;
Scheme_Object *scheme_double_ctype;
Scheme_Object *scheme_int8_ctype;
Scheme_Object *scheme_uint8_ctype;
Scheme_Object *scheme_int16_ctype;
Scheme_Object *scheme_uint16_ctype;
Scheme_Object *scheme_int32_ctype;
Scheme_Object *scheme_uint32_ctype;
Scheme_Object *scheme_int64_ctype;
Scheme_Object *scheme_uint64_ctype;
void scheme_init_foreign(Scheme_Env *env)
{
Scheme_Env *menv;
@ -4449,9 +4492,9 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global_constant("memcpy",
scheme_make_noncm_prim(foreign_memcpy, "memcpy", 3, 6), menv);
scheme_add_global_constant("ptr-ref",
scheme_make_noncm_prim(foreign_ptr_ref, "ptr-ref", 2, 4), menv);
scheme_make_inline_noncm_prim(foreign_ptr_ref, "ptr-ref", 2, 4), menv);
scheme_add_global_constant("ptr-set!",
scheme_make_noncm_prim(foreign_ptr_set_bang, "ptr-set!", 3, 5), menv);
scheme_make_inline_noncm_prim(foreign_ptr_set_bang, "ptr-set!", 3, 5), menv);
scheme_add_global_constant("ptr-equal?",
scheme_make_noncm_prim(foreign_ptr_equal_p, "ptr-equal?", 2, 2), menv);
scheme_add_global_constant("make-sized-byte-string",
@ -4483,6 +4526,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8);
REGISTER_SO(scheme_int8_ctype);
scheme_int8_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_int8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint8");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4490,6 +4535,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8);
REGISTER_SO(scheme_uint8_ctype);
scheme_uint8_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_uint8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4497,6 +4544,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16);
REGISTER_SO(scheme_int16_ctype);
scheme_int16_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_int16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4504,6 +4553,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16);
REGISTER_SO(scheme_uint16_ctype);
scheme_uint16_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_uint16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4511,6 +4562,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32);
REGISTER_SO(scheme_int32_ctype);
scheme_int32_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_int32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4518,6 +4571,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32);
REGISTER_SO(scheme_uint32_ctype);
scheme_uint32_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_uint32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4525,6 +4580,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64);
REGISTER_SO(scheme_int64_ctype);
scheme_int64_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_int64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4532,6 +4589,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64);
REGISTER_SO(scheme_uint64_ctype);
scheme_uint64_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_uint64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fixint");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4567,6 +4626,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_float);
REGISTER_SO(scheme_float_ctype);
scheme_float_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_float", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4574,6 +4635,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_double);
REGISTER_SO(scheme_double_ctype);
scheme_double_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_double", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("longdouble");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4644,6 +4707,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
REGISTER_SO(scheme_pointer_ctype);
scheme_pointer_ctype = (Scheme_Object *)t;
scheme_add_global_constant("_pointer", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("gcpointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4798,9 +4863,9 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global_constant("memcpy",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memcpy", 3, 6), menv);
scheme_add_global_constant("ptr-ref",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-ref", 2, 4), menv);
scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-ref", 2, 4), menv);
scheme_add_global_constant("ptr-set!",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-set!", 3, 5), menv);
scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-set!", 3, 5), menv);
scheme_add_global_constant("ptr-equal?",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), menv);
scheme_add_global_constant("make-sized-byte-string",

55
racket/src/foreign/foreign.rktc
View File

@ -2218,7 +2218,7 @@ static Scheme_Object *do_memop(const char *who, int mode,
/* if n is given, an 'abs flag can precede it to make n be a byte offset */
/* rather than some multiple of sizeof(type). */
/* WARNING: there are *NO* checks at all, this is raw C level code. */
@cdefine[ptr-ref 2 4]{
@cdefine[ptr-ref 2 4 #:kind inline_noncm]{
intptr_t size=0; void *ptr; Scheme_Object *base;
intptr_t delta; int gcsrc=1;
Scheme_Object *cp, *already_ptr = NULL;
@ -2274,12 +2274,17 @@ static Scheme_Object *do_memop(const char *who, int mode,
return C2SCHEME(already_ptr, argv[1], ptr, delta, 0, gcsrc);
}
Scheme_Object *scheme_foreign_ptr_ref(int argc, Scheme_Object **argv)
{
return foreign_ptr_ref(argc, argv);
}
/* (ptr-set! cpointer type [['abs] n] value) -> void */
/* n defaults to 0 which is the only value that should be used with ffi_objs */
/* if n is given, an 'abs flag can precede it to make n be a byte offset */
/* rather than some multiple of sizeof(type). */
/* WARNING: there are *NO* checks at all, this is raw C level code. */
@cdefine[ptr-set! 3 5]{
@cdefine[ptr-set! 3 5 #:kind inline_noncm]{
intptr_t size=0; void *ptr;
intptr_t delta;
Scheme_Object *val = argv[argc-1], *base;
@ -2319,6 +2324,11 @@ static Scheme_Object *do_memop(const char *who, int mode,
return scheme_void;
}
void scheme_foreign_ptr_set(int argc, Scheme_Object **argv)
{
(void)foreign_ptr_set_bang(argc, argv);
}
/* (ptr-equal? cpointer cpointer) -> boolean */
@cdefine[ptr-equal? 2 2]{
Scheme_Object *cp1, *cp2;
@ -2377,7 +2387,7 @@ void do_ptr_finalizer(void *p, void *finalizer)
THREAD_LOCAL_DECL(static Scheme_Hash_Table *ffi_lock_ht);
#ifdef MZ_PRECISE_GC
#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
static Scheme_Object *make_vector_in_master(int count, Scheme_Object *val) {
Scheme_Object *vec;
void *original_gc;
@ -3492,6 +3502,39 @@ void scheme_init_foreign_places() {
#endif
}
static Scheme_Object *scheme_make_inline_noncm_prim(Scheme_Prim *prim,
const char *name,
mzshort mina, mzshort maxa)
{
Scheme_Object *p;
int flags = 0;
p = scheme_make_noncm_prim(prim, name, mina, maxa);
if ((mina <= 1) && (maxa >= 1))
flags |= SCHEME_PRIM_IS_UNARY_INLINED;
if ((mina <= 2) && (maxa >= 2))
flags |= SCHEME_PRIM_IS_BINARY_INLINED;
if ((mina <= 0) || (maxa > 2))
flags |= SCHEME_PRIM_IS_NARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags);
return p;
}
@(define exported-types '("pointer"
"float" "double"
"int8" "uint8"
"int16" "uint16"
"int32" "uint32"
"int64" "uint64"))
@(maplines
(lambda (exported)
@list{Scheme_Object *scheme_@|exported|_ctype})
exported-types)
void scheme_init_foreign(Scheme_Env *env)
{
Scheme_Env *menv;
@ -3513,6 +3556,12 @@ void scheme_init_foreign(Scheme_Env *env)
@cmake["t" ctype "s"
@list{(Scheme_Object*)(void*)(&ffi_type_@ftype)}
@list{(Scheme_Object*)FOREIGN_@cname}]
@(if (member stype exported-types)
(append
@list{REGISTER_SO(scheme_@|stype|_ctype);
scheme_@|stype|_ctype = (Scheme_Object *)t;}
'("\n"))
null)@;
scheme_add_global_constant("_@stype", (Scheme_Object*)t, menv)})
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(menv);

4
racket/src/racket/configure.ac
View File

@ -668,7 +668,7 @@ case "$host_os" in
LIBS="$LIBS -lsocket -lnsl -lintl"
need_gcc_static_libgcc="yes"
check_gcc_dash_e="yes"
try_poll_syscall="yes"
try_poll_syscall="no" # poll() has performance problems on Solaris?
use_flag_pthread="no"
use_flag_posix_pthread="yes"
;;
@ -1530,6 +1530,8 @@ fi
if test "${enable_noopt}" = "yes" ; then
AWKPRG='BEGIN { FS = "(^| )-O(0|1|2|3|4|5|6|7|8|9)?( |$)" } /.*/ { for (i = 1; i < NF; i++) printf "%s ", $i; print $NF }'
CFLAGS=`echo "$CFLAGS" | awk "$AWKPRG"`
CPPFLAGS=`echo "$CPPFLAGS" | awk "$AWKPRG"`
PREFLAGS=`echo "$PREFLAGS" | awk "$AWKPRG"`
fi
############## usersetup ################

2
racket/src/racket/gc2/gc2.h
View File

@ -585,7 +585,7 @@ GC2_EXTERN void GC_set_backpointer_object(void *p);
#endif
/* Macros (implementation-specific): */
#if defined(__x86_64__) || defined(_WIN64)
#ifdef SIXTY_FOUR_BIT_INTEGERS
# define gcLOG_WORD_SIZE 3
#else
# define gcLOG_WORD_SIZE 2

5
racket/src/racket/gc2/sighand.c
View File

@ -219,9 +219,10 @@ static void initialize_signal_handler(GCTYPE *gc)
# ifdef NEED_SIGSTACK
{
stack_t ss;
uintptr_t sz = 10*SIGSTKSZ;
ss.ss_sp = malloc(SIGSTKSZ);
ss.ss_size = SIGSTKSZ;
ss.ss_sp = malloc(sz);
ss.ss_size = sz;
ss.ss_flags = 0;
sigaltstack(&ss, NULL);

8
racket/src/racket/gc2/vm.c
View File

@ -17,7 +17,7 @@ enum {
};
#if defined(_WIN32) || defined(__CYGWIN32__)
/* No block cache or alloc cache */
/* No block cache or alloc cache; relies on APAGE_SIZE matching allocator's alignment */
#elif defined(OSKIT)
# define OS_ALLOCATOR_NEEDS_ALIGNMENT
#elif defined(MZ_USE_PLACES) || defined(PREFER_MMAP_LARGE_BLOCKS)
@ -33,6 +33,10 @@ enum {
# define QUEUED_MPROTECT_IS_PROMISCUOUS 0
#endif
/* Either USE_ALLOC_CACHE or OS_ALLOCATOR_NEEDS_ALIGNMENT must be
enabled, unless the lower-level allocator's alignment matches
APAGE_SIZE. */
struct AllocCacheBlock;
struct BlockCache;
typedef struct MMU {
@ -81,7 +85,7 @@ static inline size_t mmu_round_up_to_os_page_size(MMU *mmu, size_t len) {
static inline void mmu_assert_os_page_aligned(MMU *mmu, size_t p) {
if (p & (mmu->os_pagesize - 1)) {
printf("address or size is not OS PAGE ALIGNED!!!!");
GCPRINT(GCOUTF, "address or size is not page-aligned\n");
abort();
}
}

10
racket/src/racket/src/fun.c
View File

@ -88,6 +88,7 @@ READ_ONLY Scheme_Object *scheme_values_func; /* the function bound to `values' *
READ_ONLY Scheme_Object *scheme_procedure_p_proc;
READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc;
READ_ONLY Scheme_Object *scheme_void_proc;
READ_ONLY Scheme_Object *scheme_void_p_proc;
READ_ONLY Scheme_Object *scheme_check_not_undefined_proc;
READ_ONLY Scheme_Object *scheme_check_assign_not_undefined_proc;
READ_ONLY Scheme_Object *scheme_apply_proc;
@ -507,10 +508,11 @@ scheme_init_fun (Scheme_Env *env)
scheme_add_global_constant("void", scheme_void_proc, env);
o = scheme_make_folding_prim(void_p, "void?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("void?", o, env);
REGISTER_SO(scheme_void_p_proc);
scheme_void_p_proc = scheme_make_folding_prim(void_p, "void?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(scheme_void_p_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("void?", scheme_void_p_proc, env);
#ifdef TIME_SYNTAX
scheme_add_global_constant("time-apply",

3
racket/src/racket/src/gen-jit-ts.rkt
View File

@ -197,7 +197,8 @@
ss_i
iSp_v
sss_s
_v))
_v
iS_v))
(with-output-to-file "jit_ts_def.c"
#:exists 'replace

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

@ -369,6 +369,7 @@ struct scheme_jit_common_record {
void *make_rest_list_code, *make_rest_list_clear_code;
void *call_check_not_defined_code, *call_check_assign_not_defined_code;
void *force_value_same_mark_code;
void *slow_ptr_set_code, *slow_ptr_ref_code;
Continuation_Apply_Indirect continuation_apply_indirect_code;
#ifdef MZ_USE_LWC
@ -1160,7 +1161,9 @@ static void emit_indentation(mz_jit_state *jitter)
#define jit_movi_d_fppush(rd,immd) jit_movi_d(rd,immd)
#define jit_ldi_d_fppush(rd, is) jit_ldi_d(rd, is)
#define jit_ldr_d_fppush(rd, rs) jit_ldr_d(rd, rs)
#define jit_ldr_f_fppush(rd, rs) jit_ldr_f(rd, rs)
#define jit_ldxi_d_fppush(rd, rs, is) jit_ldxi_d(rd, rs, is)
#define jit_ldxi_f_fppush(rd, rs, is) jit_ldxi_f(rd, rs, is)
#define jit_ldxr_d_fppush(rd, rs, is) jit_ldxr_d(rd, rs, is)
#define jit_addr_d_fppop(rd,s1,s2) jit_addr_d(rd,s1,s2)
#define jit_subr_d_fppop(rd,s1,s2) jit_subr_d(rd,s1,s2)
@ -1173,6 +1176,7 @@ static void emit_indentation(mz_jit_state *jitter)
#define jit_sqrt_d_fppop(rd,rs) jit_sqrt_d(rd,rs)
#define jit_sti_d_fppop(id, rs) jit_sti_d(id, rs)
#define jit_str_d_fppop(id, rd) jit_str_d(id, rd)
#define jit_str_f_fppop(id, rd) jit_str_f(id, rd)
#define jit_stxi_d_fppop(id, rd, rs) jit_stxi_d(id, rd, rs)
#define jit_stxr_d_fppop(id, rd, rs) jit_stxr_d(id, rd, rs)
#define jit_bger_d_fppop(d, s1, s2) jit_bger_d(d, s1, s2)

4
racket/src/racket/src/jit_ts.c
View File

@ -108,6 +108,8 @@ define_ts_iSi_s(scheme_build_list_offset, FSRC_OTHER)
# endif
define_ts_iS_s(scheme_check_not_undefined, FSRC_MARKS)
define_ts_iS_s(scheme_check_assign_not_undefined, FSRC_MARKS)
define_ts_iS_s(scheme_foreign_ptr_ref, FSRC_MARKS)
define_ts_iS_v(scheme_foreign_ptr_set, FSRC_MARKS)
#endif
#ifdef JITCALL_TS_PROCS
@ -242,4 +244,6 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
# define ts_scheme_checked_integer_to_char scheme_checked_integer_to_char
# define ts_scheme_check_not_undefined scheme_check_not_undefined
# define ts_scheme_check_assign_not_undefined scheme_check_assign_not_undefined
# define ts_scheme_foreign_ptr_ref scheme_foreign_ptr_ref
# define ts_scheme_foreign_ptr_set scheme_foreign_ptr_set
#endif

189
racket/src/racket/src/jit_ts_def.c
View File

@ -1,38 +1,38 @@
#define define_ts_siS_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object* g8, int g9, Scheme_Object** g10) \
static Scheme_Object* ts_ ## id(Scheme_Object* g12, int g13, Scheme_Object** g14) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_siS_s("[" #id "]", src_type, id, g8, g9, g10); \
return scheme_rtcall_siS_s("[" #id "]", src_type, id, g12, g13, g14); \
else \
return id(g8, g9, g10); \
return id(g12, g13, g14); \
}
#define define_ts_iSs_s(id, src_type) \
static Scheme_Object* ts_ ## id(int g11, Scheme_Object** g12, Scheme_Object* g13) \
static Scheme_Object* ts_ ## id(int g15, Scheme_Object** g16, Scheme_Object* g17) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_iSs_s("[" #id "]", src_type, id, g11, g12, g13); \
return scheme_rtcall_iSs_s("[" #id "]", src_type, id, g15, g16, g17); \
else \
return id(g11, g12, g13); \
return id(g15, g16, g17); \
}
#define define_ts_s_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object* g14) \
static Scheme_Object* ts_ ## id(Scheme_Object* g18) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_s_s("[" #id "]", src_type, id, g14); \
return scheme_rtcall_s_s("[" #id "]", src_type, id, g18); \
else \
return id(g14); \
return id(g18); \
}
#define define_ts_n_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Native_Closure_Data* g15) \
static Scheme_Object* ts_ ## id(Scheme_Native_Closure_Data* g19) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_n_s("[" #id "]", src_type, id, g15); \
return scheme_rtcall_n_s("[" #id "]", src_type, id, g19); \
else \
return id(g15); \
return id(g19); \
}
#define define_ts__s(id, src_type) \
static Scheme_Object* ts_ ## id() \
@ -44,202 +44,202 @@ static Scheme_Object* ts_ ## id() \
return id(); \
}
#define define_ts_ss_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object* g16, Scheme_Object* g17) \
static Scheme_Object* ts_ ## id(Scheme_Object* g20, Scheme_Object* g21) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_ss_s("[" #id "]", src_type, id, g16, g17); \
return scheme_rtcall_ss_s("[" #id "]", src_type, id, g20, g21); \
else \
return id(g16, g17); \
return id(g20, g21); \
}
#define define_ts_ssi_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object* g18, Scheme_Object* g19, int g20) \
static Scheme_Object* ts_ ## id(Scheme_Object* g22, Scheme_Object* g23, int g24) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_ssi_s("[" #id "]", src_type, id, g18, g19, g20); \
return scheme_rtcall_ssi_s("[" #id "]", src_type, id, g22, g23, g24); \
else \
return id(g18, g19, g20); \
return id(g22, g23, g24); \
}
#define define_ts_tt_s(id, src_type) \
static Scheme_Object* ts_ ## id(const Scheme_Object* g21, const Scheme_Object* g22) \
static Scheme_Object* ts_ ## id(const Scheme_Object* g25, const Scheme_Object* g26) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_tt_s("[" #id "]", src_type, id, g21, g22); \
else \
return id(g21, g22); \
}
#define define_ts_ss_m(id, src_type) \
static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g23, Scheme_Object* g24) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_ss_m("[" #id "]", src_type, id, g23, g24); \
else \
return id(g23, g24); \
}
#define define_ts_Sl_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object** g25, intptr_t g26) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_Sl_s("[" #id "]", src_type, id, g25, g26); \
return scheme_rtcall_tt_s("[" #id "]", src_type, id, g25, g26); \
else \
return id(g25, g26); \
}
#define define_ts_l_s(id, src_type) \
static Scheme_Object* ts_ ## id(intptr_t g27) \
#define define_ts_ss_m(id, src_type) \
static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g27, Scheme_Object* g28) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_l_s("[" #id "]", src_type, id, g27); \
return scheme_rtcall_ss_m("[" #id "]", src_type, id, g27, g28); \
else \
return id(g27); \
return id(g27, g28); \
}
#define define_ts_Sl_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object** g29, intptr_t g30) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_Sl_s("[" #id "]", src_type, id, g29, g30); \
else \
return id(g29, g30); \
}
#define define_ts_l_s(id, src_type) \
static Scheme_Object* ts_ ## id(intptr_t g31) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_l_s("[" #id "]", src_type, id, g31); \
else \
return id(g31); \
}
#define define_ts_bsi_v(id, src_type) \
static void ts_ ## id(Scheme_Bucket* g28, Scheme_Object* g29, int g30) \
static void ts_ ## id(Scheme_Bucket* g32, Scheme_Object* g33, int g34) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall_bsi_v("[" #id "]", src_type, id, g28, g29, g30); \
scheme_rtcall_bsi_v("[" #id "]", src_type, id, g32, g33, g34); \
else \
id(g28, g29, g30); \
id(g32, g33, g34); \
}
#define define_ts_iiS_v(id, src_type) \
static void ts_ ## id(int g31, int g32, Scheme_Object** g33) \
static void ts_ ## id(int g35, int g36, Scheme_Object** g37) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall_iiS_v("[" #id "]", src_type, id, g31, g32, g33); \
scheme_rtcall_iiS_v("[" #id "]", src_type, id, g35, g36, g37); \
else \
id(g31, g32, g33); \
id(g35, g36, g37); \
}
#define define_ts_ss_v(id, src_type) \
static void ts_ ## id(Scheme_Object* g34, Scheme_Object* g35) \
static void ts_ ## id(Scheme_Object* g38, Scheme_Object* g39) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall_ss_v("[" #id "]", src_type, id, g34, g35); \
scheme_rtcall_ss_v("[" #id "]", src_type, id, g38, g39); \
else \
id(g34, g35); \
id(g38, g39); \
}
#define define_ts_b_v(id, src_type) \
static void ts_ ## id(Scheme_Bucket* g36) \
static void ts_ ## id(Scheme_Bucket* g40) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall_b_v("[" #id "]", src_type, id, g36); \
scheme_rtcall_b_v("[" #id "]", src_type, id, g40); \
else \
id(g36); \
id(g40); \
}
#define define_ts_sl_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object* g37, intptr_t g38) \
static Scheme_Object* ts_ ## id(Scheme_Object* g41, intptr_t g42) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_sl_s("[" #id "]", src_type, id, g37, g38); \
return scheme_rtcall_sl_s("[" #id "]", src_type, id, g41, g42); \
else \
return id(g37, g38); \
return id(g41, g42); \
}
#define define_ts_iS_s(id, src_type) \
static Scheme_Object* ts_ ## id(int g39, Scheme_Object** g40) \
static Scheme_Object* ts_ ## id(int g43, Scheme_Object** g44) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_iS_s("[" #id "]", src_type, id, g39, g40); \
return scheme_rtcall_iS_s("[" #id "]", src_type, id, g43, g44); \
else \
return id(g39, g40); \
return id(g43, g44); \
}
#define define_ts_S_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object** g41) \
static Scheme_Object* ts_ ## id(Scheme_Object** g45) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_S_s("[" #id "]", src_type, id, g41); \
return scheme_rtcall_S_s("[" #id "]", src_type, id, g45); \
else \
return id(g41); \
return id(g45); \
}
#define define_ts_s_v(id, src_type) \
static void ts_ ## id(Scheme_Object* g42) \
static void ts_ ## id(Scheme_Object* g46) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall_s_v("[" #id "]", src_type, id, g42); \
scheme_rtcall_s_v("[" #id "]", src_type, id, g46); \
else \
id(g42); \
id(g46); \
}
#define define_ts_iSi_s(id, src_type) \
static Scheme_Object* ts_ ## id(int g43, Scheme_Object** g44, int g45) \
static Scheme_Object* ts_ ## id(int g47, Scheme_Object** g48, int g49) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_iSi_s("[" #id "]", src_type, id, g43, g44, g45); \
return scheme_rtcall_iSi_s("[" #id "]", src_type, id, g47, g48, g49); \
else \
return id(g43, g44, g45); \
return id(g47, g48, g49); \
}
#define define_ts_siS_v(id, src_type) \
static void ts_ ## id(Scheme_Object* g46, int g47, Scheme_Object** g48) \
static void ts_ ## id(Scheme_Object* g50, int g51, Scheme_Object** g52) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall_siS_v("[" #id "]", src_type, id, g46, g47, g48); \
scheme_rtcall_siS_v("[" #id "]", src_type, id, g50, g51, g52); \
else \
id(g46, g47, g48); \
id(g50, g51, g52); \
}
#define define_ts_z_p(id, src_type) \
static void* ts_ ## id(size_t g49) \
static void* ts_ ## id(size_t g53) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_z_p("[" #id "]", src_type, id, g49); \
return scheme_rtcall_z_p("[" #id "]", src_type, id, g53); \
else \
return id(g49); \
return id(g53); \
}
#define define_ts_si_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object* g50, int g51) \
static Scheme_Object* ts_ ## id(Scheme_Object* g54, int g55) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_si_s("[" #id "]", src_type, id, g50, g51); \
return scheme_rtcall_si_s("[" #id "]", src_type, id, g54, g55); \
else \
return id(g50, g51); \
return id(g54, g55); \
}
#define define_ts_sis_v(id, src_type) \
static void ts_ ## id(Scheme_Object* g52, int g53, Scheme_Object* g54) \
static void ts_ ## id(Scheme_Object* g56, int g57, Scheme_Object* g58) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall_sis_v("[" #id "]", src_type, id, g52, g53, g54); \
scheme_rtcall_sis_v("[" #id "]", src_type, id, g56, g57, g58); \
else \
id(g52, g53, g54); \
id(g56, g57, g58); \
}
#define define_ts_ss_i(id, src_type) \
static int ts_ ## id(Scheme_Object* g55, Scheme_Object* g56) \
static int ts_ ## id(Scheme_Object* g59, Scheme_Object* g60) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_ss_i("[" #id "]", src_type, id, g55, g56); \
return scheme_rtcall_ss_i("[" #id "]", src_type, id, g59, g60); \
else \
return id(g55, g56); \
return id(g59, g60); \
}
#define define_ts_iSp_v(id, src_type) \
static void ts_ ## id(int g57, Scheme_Object** g58, void* g59) \
static void ts_ ## id(int g61, Scheme_Object** g62, void* g63) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall_iSp_v("[" #id "]", src_type, id, g57, g58, g59); \
scheme_rtcall_iSp_v("[" #id "]", src_type, id, g61, g62, g63); \
else \
id(g57, g58, g59); \
id(g61, g62, g63); \
}
#define define_ts_sss_s(id, src_type) \
static Scheme_Object* ts_ ## id(Scheme_Object* g60, Scheme_Object* g61, Scheme_Object* g62) \
static Scheme_Object* ts_ ## id(Scheme_Object* g64, Scheme_Object* g65, Scheme_Object* g66) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
return scheme_rtcall_sss_s("[" #id "]", src_type, id, g60, g61, g62); \
return scheme_rtcall_sss_s("[" #id "]", src_type, id, g64, g65, g66); \
else \
return id(g60, g61, g62); \
return id(g64, g65, g66); \
}
#define define_ts__v(id, src_type) \
static void ts_ ## id() \
@ -250,3 +250,12 @@ static void ts_ ## id() \
else \
id(); \
}
#define define_ts_iS_v(id, src_type) \
static void ts_ ## id(int g67, Scheme_Object** g68) \
XFORM_SKIP_PROC \
{ \
if (scheme_use_rtcall) \
scheme_rtcall_iS_v("[" #id "]", src_type, id, g67, g68); \
else \
id(g67, g68); \
}

192
racket/src/racket/src/jit_ts_future_glue.c
View File

@ -1,4 +1,4 @@
Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g63, int g64, Scheme_Object** g65)
Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g69, int g70, Scheme_Object** g71)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -13,9 +13,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g63;
future->arg_i1 = g64;
future->arg_S2 = g65;
future->arg_s0 = g69;
future->arg_i1 = g70;
future->arg_S2 = g71;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -25,7 +25,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g66, Scheme_Object** g67, Scheme_Object* g68)
Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g72, Scheme_Object** g73, Scheme_Object* g74)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -40,9 +40,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_i0 = g66;
future->arg_S1 = g67;
future->arg_s2 = g68;
future->arg_i0 = g72;
future->arg_S1 = g73;
future->arg_s2 = g74;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -52,7 +52,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g69)
Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g75)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -67,8 +67,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g69;
send_special_result(future, g69);
future->arg_s0 = g75;
send_special_result(future, g75);
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
future = fts->thread->current_ft;
@ -77,7 +77,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g70)
Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g76)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -92,7 +92,7 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_n0 = g70;
future->arg_n0 = g76;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -127,7 +127,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g71, Scheme_Object* g72)
Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g77, Scheme_Object* g78)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -142,8 +142,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g71;
future->arg_s1 = g72;
future->arg_s0 = g77;
future->arg_s1 = g78;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -153,7 +153,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_ssi_s(const char *who, int src_type, prim_ssi_s f, Scheme_Object* g73, Scheme_Object* g74, int g75)
Scheme_Object* scheme_rtcall_ssi_s(const char *who, int src_type, prim_ssi_s f, Scheme_Object* g79, Scheme_Object* g80, int g81)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -168,9 +168,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g73;
future->arg_s1 = g74;
future->arg_i2 = g75;
future->arg_s0 = g79;
future->arg_s1 = g80;
future->arg_i2 = g81;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -180,7 +180,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_tt_s(const char *who, int src_type, prim_tt_s f, const Scheme_Object* g76, const Scheme_Object* g77)
Scheme_Object* scheme_rtcall_tt_s(const char *who, int src_type, prim_tt_s f, const Scheme_Object* g82, const Scheme_Object* g83)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -195,8 +195,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_t0 = g76;
future->arg_t1 = g77;
future->arg_t0 = g82;
future->arg_t1 = g83;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -206,7 +206,7 @@
receive_special_result(future, retval, 1);
return retval;
}
MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g78, Scheme_Object* g79)
MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g84, Scheme_Object* g85)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -221,8 +221,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g78;
future->arg_s1 = g79;
future->arg_s0 = g84;
future->arg_s1 = g85;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -232,7 +232,7 @@
return retval;
}
Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g80, intptr_t g81)
Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g86, intptr_t g87)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -247,8 +247,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_S0 = g80;
future->arg_l1 = g81;
future->arg_S0 = g86;
future->arg_l1 = g87;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -258,7 +258,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, intptr_t g82)
Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, intptr_t g88)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -273,7 +273,7 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_l0 = g82;
future->arg_l0 = g88;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -283,7 +283,7 @@
receive_special_result(future, retval, 1);
return retval;
}
void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g83, Scheme_Object* g84, int g85)
void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g89, Scheme_Object* g90, int g91)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -298,9 +298,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_b0 = g83;
future->arg_s1 = g84;
future->arg_i2 = g85;
future->arg_b0 = g89;
future->arg_s1 = g90;
future->arg_i2 = g91;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -310,7 +310,7 @@
}
void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g86, int g87, Scheme_Object** g88)
void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g92, int g93, Scheme_Object** g94)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -325,9 +325,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_i0 = g86;
future->arg_i1 = g87;
future->arg_S2 = g88;
future->arg_i0 = g92;
future->arg_i1 = g93;
future->arg_S2 = g94;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -337,7 +337,7 @@
}
void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g89, Scheme_Object* g90)
void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g95, Scheme_Object* g96)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -352,8 +352,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g89;
future->arg_s1 = g90;
future->arg_s0 = g95;
future->arg_s1 = g96;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -363,7 +363,7 @@
}
void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g91)
void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g97)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -378,7 +378,7 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_b0 = g91;
future->arg_b0 = g97;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -388,7 +388,7 @@
}
Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g92, intptr_t g93)
Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g98, intptr_t g99)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -403,8 +403,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g92;
future->arg_l1 = g93;
future->arg_s0 = g98;
future->arg_l1 = g99;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -414,7 +414,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g94, Scheme_Object** g95)
Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g100, Scheme_Object** g101)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -429,8 +429,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_i0 = g94;
future->arg_S1 = g95;
future->arg_i0 = g100;
future->arg_S1 = g101;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -440,7 +440,7 @@
receive_special_result(future, retval, 1);
return retval;
}
Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g96)
Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g102)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -455,7 +455,7 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_S0 = g96;
future->arg_S0 = g102;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -465,7 +465,7 @@
receive_special_result(future, retval, 1);
return retval;
}
void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g97)
void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g103)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -480,8 +480,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g97;
send_special_result(future, g97);
future->arg_s0 = g103;
send_special_result(future, g103);
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
future = fts->thread->current_ft;
@ -490,7 +490,7 @@
}
Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g98, Scheme_Object** g99, int g100)
Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g104, Scheme_Object** g105, int g106)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -505,9 +505,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_i0 = g98;
future->arg_S1 = g99;
future->arg_i2 = g100;
future->arg_i0 = g104;
future->arg_S1 = g105;
future->arg_i2 = g106;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -517,7 +517,7 @@
receive_special_result(future, retval, 1);
return retval;
}
void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g101, int g102, Scheme_Object** g103)
void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g107, int g108, Scheme_Object** g109)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -532,9 +532,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g101;
future->arg_i1 = g102;
future->arg_S2 = g103;
future->arg_s0 = g107;
future->arg_i1 = g108;
future->arg_S2 = g109;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -544,7 +544,7 @@
}
void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g104)
void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g110)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -559,7 +559,7 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_z0 = g104;
future->arg_z0 = g110;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -569,7 +569,7 @@
return retval;
}
Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g105, int g106)
Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g111, int g112)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -584,8 +584,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g105;
future->arg_i1 = g106;
future->arg_s0 = g111;
future->arg_i1 = g112;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -595,7 +595,7 @@
receive_special_result(future, retval, 1);
return retval;
}
void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g107, int g108, Scheme_Object* g109)
void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g113, int g114, Scheme_Object* g115)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -610,9 +610,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g107;
future->arg_i1 = g108;
future->arg_s2 = g109;
future->arg_s0 = g113;
future->arg_i1 = g114;
future->arg_s2 = g115;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -622,7 +622,7 @@
}
int scheme_rtcall_ss_i(const char *who, int src_type, prim_ss_i f, Scheme_Object* g110, Scheme_Object* g111)
int scheme_rtcall_ss_i(const char *who, int src_type, prim_ss_i f, Scheme_Object* g116, Scheme_Object* g117)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -637,8 +637,8 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g110;
future->arg_s1 = g111;
future->arg_s0 = g116;
future->arg_s1 = g117;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -648,7 +648,7 @@
return retval;
}
void scheme_rtcall_iSp_v(const char *who, int src_type, prim_iSp_v f, int g112, Scheme_Object** g113, void* g114)
void scheme_rtcall_iSp_v(const char *who, int src_type, prim_iSp_v f, int g118, Scheme_Object** g119, void* g120)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -663,9 +663,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_i0 = g112;
future->arg_S1 = g113;
future->arg_p2 = g114;
future->arg_i0 = g118;
future->arg_S1 = g119;
future->arg_p2 = g120;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -675,7 +675,7 @@
}
Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g115, Scheme_Object* g116, Scheme_Object* g117)
Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g121, Scheme_Object* g122, Scheme_Object* g123)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -690,9 +690,9 @@
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_s0 = g115;
future->arg_s1 = g116;
future->arg_s2 = g117;
future->arg_s0 = g121;
future->arg_s1 = g122;
future->arg_s2 = g123;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
@ -726,4 +726,30 @@
}
void scheme_rtcall_iS_v(const char *who, int src_type, prim_iS_v f, int g124, Scheme_Object** g125)
XFORM_SKIP_PROC
{
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
future_t *future;
double tm;
future = fts->thread->current_ft;
future->prim_protocol = SIG_iS_v;
future->prim_func = f;
tm = get_future_timestamp();
future->time_of_request = tm;
future->source_of_request = who;
future->source_type = src_type;
future->arg_i0 = g124;
future->arg_S1 = g125;
future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread;
future = fts->thread->current_ft;
}

55
racket/src/racket/src/jit_ts_protos.h
View File

@ -1,84 +1,87 @@
#define SIG_siS_s 11
typedef Scheme_Object* (*prim_siS_s)(Scheme_Object*, int, Scheme_Object**);
Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g173, int g174, Scheme_Object** g175);
Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g183, int g184, Scheme_Object** g185);
#define SIG_iSs_s 12
typedef Scheme_Object* (*prim_iSs_s)(int, Scheme_Object**, Scheme_Object*);
Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g176, Scheme_Object** g177, Scheme_Object* g178);
Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g186, Scheme_Object** g187, Scheme_Object* g188);
#define SIG_s_s 13
typedef Scheme_Object* (*prim_s_s)(Scheme_Object*);
Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g179);
Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g189);
#define SIG_n_s 14
typedef Scheme_Object* (*prim_n_s)(Scheme_Native_Closure_Data*);
Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g180);
Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g190);
#define SIG__s 15
typedef Scheme_Object* (*prim__s)();
Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f );
#define SIG_ss_s 16
typedef Scheme_Object* (*prim_ss_s)(Scheme_Object*, Scheme_Object*);
Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g181, Scheme_Object* g182);
Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g191, Scheme_Object* g192);
#define SIG_ssi_s 17
typedef Scheme_Object* (*prim_ssi_s)(Scheme_Object*, Scheme_Object*, int);
Scheme_Object* scheme_rtcall_ssi_s(const char *who, int src_type, prim_ssi_s f, Scheme_Object* g183, Scheme_Object* g184, int g185);
Scheme_Object* scheme_rtcall_ssi_s(const char *who, int src_type, prim_ssi_s f, Scheme_Object* g193, Scheme_Object* g194, int g195);
#define SIG_tt_s 18
typedef Scheme_Object* (*prim_tt_s)(const Scheme_Object*, const Scheme_Object*);
Scheme_Object* scheme_rtcall_tt_s(const char *who, int src_type, prim_tt_s f, const Scheme_Object* g186, const Scheme_Object* g187);
Scheme_Object* scheme_rtcall_tt_s(const char *who, int src_type, prim_tt_s f, const Scheme_Object* g196, const Scheme_Object* g197);
#define SIG_ss_m 19
typedef MZ_MARK_STACK_TYPE (*prim_ss_m)(Scheme_Object*, Scheme_Object*);
MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g188, Scheme_Object* g189);
MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g198, Scheme_Object* g199);
#define SIG_Sl_s 20
typedef Scheme_Object* (*prim_Sl_s)(Scheme_Object**, intptr_t);
Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g190, intptr_t g191);
Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g200, intptr_t g201);
#define SIG_l_s 21
typedef Scheme_Object* (*prim_l_s)(intptr_t);
Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, intptr_t g192);
Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, intptr_t g202);
#define SIG_bsi_v 22
typedef void (*prim_bsi_v)(Scheme_Bucket*, Scheme_Object*, int);
void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g193, Scheme_Object* g194, int g195);
void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g203, Scheme_Object* g204, int g205);
#define SIG_iiS_v 23
typedef void (*prim_iiS_v)(int, int, Scheme_Object**);
void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g196, int g197, Scheme_Object** g198);
void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g206, int g207, Scheme_Object** g208);
#define SIG_ss_v 24
typedef void (*prim_ss_v)(Scheme_Object*, Scheme_Object*);
void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g199, Scheme_Object* g200);
void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g209, Scheme_Object* g210);
#define SIG_b_v 25
typedef void (*prim_b_v)(Scheme_Bucket*);
void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g201);
void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g211);
#define SIG_sl_s 26
typedef Scheme_Object* (*prim_sl_s)(Scheme_Object*, intptr_t);
Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g202, intptr_t g203);
Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g212, intptr_t g213);
#define SIG_iS_s 27
typedef Scheme_Object* (*prim_iS_s)(int, Scheme_Object**);
Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g204, Scheme_Object** g205);
Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g214, Scheme_Object** g215);
#define SIG_S_s 28
typedef Scheme_Object* (*prim_S_s)(Scheme_Object**);
Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g206);
Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g216);
#define SIG_s_v 29
typedef void (*prim_s_v)(Scheme_Object*);
void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g207);
void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g217);
#define SIG_iSi_s 30
typedef Scheme_Object* (*prim_iSi_s)(int, Scheme_Object**, int);
Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g208, Scheme_Object** g209, int g210);
Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g218, Scheme_Object** g219, int g220);
#define SIG_siS_v 31
typedef void (*prim_siS_v)(Scheme_Object*, int, Scheme_Object**);
void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g211, int g212, Scheme_Object** g213);
void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g221, int g222, Scheme_Object** g223);
#define SIG_z_p 32
typedef void* (*prim_z_p)(size_t);
void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g214);
void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g224);
#define SIG_si_s 33
typedef Scheme_Object* (*prim_si_s)(Scheme_Object*, int);
Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g215, int g216);
Scheme_Object* scheme_rtcall_si_s(const char *who, int src_type, prim_si_s f, Scheme_Object* g225, int g226);
#define SIG_sis_v 34
typedef void (*prim_sis_v)(Scheme_Object*, int, Scheme_Object*);
void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g217, int g218, Scheme_Object* g219);
void scheme_rtcall_sis_v(const char *who, int src_type, prim_sis_v f, Scheme_Object* g227, int g228, Scheme_Object* g229);
#define SIG_ss_i 35
typedef int (*prim_ss_i)(Scheme_Object*, Scheme_Object*);
int scheme_rtcall_ss_i(const char *who, int src_type, prim_ss_i f, Scheme_Object* g220, Scheme_Object* g221);
int scheme_rtcall_ss_i(const char *who, int src_type, prim_ss_i f, Scheme_Object* g230, Scheme_Object* g231);
#define SIG_iSp_v 36
typedef void (*prim_iSp_v)(int, Scheme_Object**, void*);
void scheme_rtcall_iSp_v(const char *who, int src_type, prim_iSp_v f, int g222, Scheme_Object** g223, void* g224);
void scheme_rtcall_iSp_v(const char *who, int src_type, prim_iSp_v f, int g232, Scheme_Object** g233, void* g234);
#define SIG_sss_s 37
typedef Scheme_Object* (*prim_sss_s)(Scheme_Object*, Scheme_Object*, Scheme_Object*);
Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g225, Scheme_Object* g226, Scheme_Object* g227);
Scheme_Object* scheme_rtcall_sss_s(const char *who, int src_type, prim_sss_s f, Scheme_Object* g235, Scheme_Object* g236, Scheme_Object* g237);
#define SIG__v 38
typedef void (*prim__v)();
void scheme_rtcall__v(const char *who, int src_type, prim__v f );
#define SIG_iS_v 39
typedef void (*prim_iS_v)(int, Scheme_Object**);
void scheme_rtcall_iS_v(const char *who, int src_type, prim_iS_v f, int g238, Scheme_Object** g239);

14
racket/src/racket/src/jit_ts_runtime_glue.c
View File

@ -388,5 +388,19 @@ case SIG__v:
f();
break;
}
case SIG_iS_v:
{
prim_iS_v f = (prim_iS_v)future->prim_func;
JIT_TS_LOCALIZE(int, arg_i0); JIT_TS_LOCALIZE(Scheme_Object**, arg_S1);
future->arg_S1 = NULL;
ADJUST_RS_ARG(future, arg_S1);
f(arg_i0, arg_S1);
break;
}

2
racket/src/racket/src/jitcall.c
View File

@ -545,7 +545,7 @@ int scheme_generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
int scheme_generate_force_value_same_mark(mz_jit_state *jitter)
{
GC_CAN_IGNORE jit_insn *refr USED_ONLY_FOR_FUTURES;
jit_movi_p(JIT_R0, SCHEME_TAIL_CALL_WAITING);
(void)jit_movi_p(JIT_R0, SCHEME_TAIL_CALL_WAITING);
mz_prepare(1);
jit_pusharg_p(JIT_R0);
(void)mz_finish_lwe(ts_scheme_force_value_same_mark, refr);

29
racket/src/racket/src/jitcommon.c
View File

@ -3279,6 +3279,33 @@ static int common12(mz_jit_state *jitter, void *_data)
static int common13(mz_jit_state *jitter, void *_data)
{
GC_CAN_IGNORE jit_insn *refr USED_ONLY_FOR_FUTURES;
/* *** slow_ptr_ref_code *** */
sjc.slow_ptr_ref_code = jit_get_ip();
mz_prolog(JIT_R2);
JIT_UPDATE_THREAD_RSPTR();
mz_prepare(2);
jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_i(JIT_R0);
mz_finish_prim_lwe(ts_scheme_foreign_ptr_ref, refr);
jit_retval(JIT_R0);
mz_epilog(JIT_R2);
scheme_jit_register_sub_func(jitter, sjc.slow_ptr_ref_code, scheme_false);
CHECK_LIMIT();
/* *** slow_ptr_set_code *** */
sjc.slow_ptr_set_code = jit_get_ip();
mz_prolog(JIT_R2);
JIT_UPDATE_THREAD_RSPTR();
mz_prepare(2);
jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_i(JIT_R0);
mz_finish_prim_lwe(ts_scheme_foreign_ptr_set, refr);
mz_epilog(JIT_R2);
scheme_jit_register_sub_func(jitter, sjc.slow_ptr_set_code, scheme_false);
CHECK_LIMIT();
/* *** force_value_same_mark_code *** */
/* Helper for futures: a synthetic functon that just forces values,
which will bounce back to the runtime thread (but with lightweight
@ -3293,9 +3320,11 @@ static int common13(mz_jit_state *jitter, void *_data)
mz_pop_threadlocal();
mz_pop_locals();
jit_ret();
return 1;
}
int scheme_do_generate_common(mz_jit_state *jitter, void *_data)
{
if (!common0(jitter, _data)) return 0;

303
racket/src/racket/src/jitinline.c
View File

@ -2394,6 +2394,18 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
{
Scheme_Object *rator = app->rator;
if (SCHEME_PRIMP(rator) && IS_NAMED_PRIM(rator, "ptr-ref")) {
Scheme_App_Rec *app2;
if (need_sync) mz_rs_sync();
app2 = scheme_malloc_application(3);
app2->args[0] = app->rator;
app2->args[1] = app->rand1;
app2->args[2] = app->rand2;
return scheme_generate_inlined_nary(jitter, app2, is_tail, multi_ok,
for_branch, branch_short, result_ignored,
dest);
}
if (!for_branch) {
int k;
k = inlineable_struct_prim(rator, jitter, 2, 2);
@ -4311,6 +4323,297 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
mz_rs_inc(5);
mz_runstack_popped(jitter, 5);
return 1;
} else if (IS_NAMED_PRIM(rator, "ptr-ref")
|| IS_NAMED_PRIM(rator, "ptr-set!")) {
int n = app->num_args, is_ref, step_shift = 0, want_int_min = 0, want_int_max = 0;
int abs_offset;
Scheme_Type want_type;
Scheme_Object *ctype;
GC_CAN_IGNORE jit_insn *refslow, *reffast = NULL;
is_ref = IS_NAMED_PRIM(rator, "ptr-ref");
abs_offset = (n == (is_ref ? 4 : 5));
scheme_generate_app(app, NULL, n, jitter, 0, 0, 0, 2); /* sync'd below */
CHECK_LIMIT();
mz_rs_sync();
ctype = app->args[2];
if (abs_offset
&& (!SCHEME_SYMBOLP(app->args[3])
|| SCHEME_SYM_WEIRDP(app->args[3])
|| strcmp("abs", SCHEME_SYM_VAL(app->args[3])))) {
want_type = 0;
} else if (ctype == scheme_pointer_ctype) {
if (is_ref) {
want_type = 0;
} else {
want_type = scheme_cpointer_type;
step_shift = JIT_LOG_WORD_SIZE;
}
} else if (ctype == scheme_double_ctype) {
want_type = scheme_double_type;
step_shift = 3;
#ifndef CAN_INLINE_ALLOC
if (is_ref) want_type = 0;
#endif
} else if (ctype == scheme_float_ctype) {
want_type = scheme_double_type;
step_shift = 2;
#ifndef CAN_INLINE_ALLOC
if (is_ref) want_type = 0;
#endif
} else if ((ctype == scheme_int8_ctype)
|| (ctype == scheme_uint8_ctype)) {
want_type = scheme_integer_type;
step_shift = 0;
if (app->args[2] == scheme_int8_ctype) {
want_int_min = -128;
want_int_max = 127;
} else {
want_int_max = 255;
}
} else if ((ctype == scheme_int16_ctype)
|| (ctype == scheme_uint16_ctype)) {
want_type = scheme_integer_type;
step_shift = 1;
if (app->args[2] == scheme_int16_ctype) {
want_int_min = -32768;
want_int_max = 32767;
} else {
want_int_max = 65535;
}
} else if ((ctype == scheme_int32_ctype)
|| (ctype == scheme_uint32_ctype)) {
want_type = scheme_integer_type;
step_shift = 2;
#ifdef SIXTY_FOUR_BIT_INTEGERS
} else if ((ctype == scheme_int64_ctype)
|| (ctype == scheme_uint64_ctype)) {
want_type = scheme_integer_type;
step_shift = 3;
#endif
} else
want_type = 0;
__START_SHORT_JUMPS__(1);
if (want_type) {
mz_rs_ldr(JIT_R0);
reffast = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
}
refslow = jit_get_ip();
jit_movi_i(JIT_R0, n);
if (is_ref) {
(void)jit_calli(sjc.slow_ptr_ref_code);
jit_movr_p(dest, JIT_R0);
} else
(void)jit_calli(sjc.slow_ptr_set_code);
CHECK_LIMIT();
if (want_type) {
GC_CAN_IGNORE jit_insn *refdone, *refok;
refdone = jit_jmpi(jit_forward());
mz_patch_branch(reffast);
/* JIT_V1 will contain an offset
JIT_R0 will contain the pointer
In set mode, JIT_R1 will contain the new value */
if ((n == (is_ref ? 3 : 4)) || (n == (is_ref ? 4 : 5))) {
mz_rs_ldxi(JIT_V1, n - (is_ref ? 1 : 2));
(void)jit_bmci_ul(refslow, JIT_V1, 0x1);
jit_rshi_l(JIT_V1, JIT_V1, 1);
if (!abs_offset) {
jit_lshi_l(JIT_V1, JIT_V1, step_shift);
}
} else {
jit_movi_ul(JIT_V1, 0);
}
(void)mz_bnei_t(refslow, JIT_R0, scheme_cpointer_type, JIT_R2);
jit_ldxi_s(JIT_R2, JIT_R0, (intptr_t)&SCHEME_CPTR_FLAGS((Scheme_Chaperone *)0x0));
refok = jit_bmci_ul(jit_forward(), JIT_R2, 0x2);
jit_ldxi_l(JIT_R2, JIT_R0, (intptr_t)&((Scheme_Offset_Cptr *)0x0)->offset);
jit_addr_l(JIT_V1, JIT_V1, JIT_R2);
mz_patch_branch(refok);
jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&((Scheme_Cptr *)0x0)->val);
jit_addr_p(JIT_R0, JIT_R0, JIT_V1);
CHECK_LIMIT();
/* At this point, JIT_V1 is folded into JIT_R0 */
if (!is_ref) {
mz_rs_ldxi(JIT_R1, n-1);
if (want_type == scheme_integer_type) {
(void)jit_bmci_ul(refslow, JIT_R1, 0x1);
jit_rshi_l(JIT_R1, JIT_R1, 1);
if (want_int_max) {
(void)jit_blti_l(refslow, JIT_R1, want_int_min);
(void)jit_bgti_l(refslow, JIT_R1, want_int_max);
} else {
#ifdef SIXTY_FOUR_BIT_INTEGERS
if (((ctype == scheme_int32_ctype)
|| (ctype == scheme_uint32_ctype))) {
jit_rshi_ul(JIT_R2, JIT_R1, 32);
jit_extr_i_l(JIT_R2, JIT_R2);
(void)jit_bgti_l(refslow, JIT_R2, 0);
(void)jit_blti_l(refslow, JIT_R2, -1);
} else if (ctype == scheme_uint64_ctype) {
(void)jit_blti_l(refslow, JIT_R1, 0);
}
#endif
}
} else {
(void)jit_bmsi_ul(refslow, JIT_R1, 0x1);
(void)mz_bnei_t(refslow, JIT_R1, want_type, JIT_R2);
}
}
if (ctype == scheme_pointer_ctype) {
if (is_ref) {
scheme_signal_error("internal error: _pointer reference not implemented");
} else {
jit_movi_l(JIT_V1, 0);
jit_ldxi_s(JIT_R2, JIT_R1, (intptr_t)&SCHEME_CPTR_FLAGS((Scheme_Chaperone *)0x0));
refok = jit_bmci_ul(jit_forward(), JIT_R2, 0x2);
jit_ldxi_l(JIT_V1, JIT_R1, (intptr_t)&((Scheme_Offset_Cptr *)0x0)->offset);
mz_patch_branch(refok);
jit_ldxi_p(JIT_R1, JIT_R1, (intptr_t)&((Scheme_Cptr *)0x0)->val);
jit_addr_p(JIT_R1, JIT_R1, JIT_V1);
jit_str_p(JIT_R0, JIT_R1);
}
} else if (ctype == scheme_double_ctype) {
if (is_ref) {
jit_ldr_d_fppush(JIT_FPR0, JIT_R0);
CHECK_LIMIT();
__END_SHORT_JUMPS__(1);
scheme_generate_alloc_double(jitter, 0, dest);
__START_SHORT_JUMPS__(1);
CHECK_LIMIT();
} else {
jit_ldxi_d_fppush(JIT_FPR0, JIT_R1, &((Scheme_Double *)0x0)->double_val);
jit_str_d_fppop(JIT_R0, JIT_FPR0);
}
} else if (ctype == scheme_float_ctype) {
if (is_ref) {
jit_ldr_f_fppush(JIT_FPR0, JIT_R0);
jit_extr_f_d(JIT_FPR0, JIT_FPR0);
CHECK_LIMIT();
__END_SHORT_JUMPS__(1);
scheme_generate_alloc_double(jitter, 0, dest);
__START_SHORT_JUMPS__(1);
CHECK_LIMIT();
} else {
jit_ldxi_d_fppush(JIT_FPR0, JIT_R1, &((Scheme_Double *)0x0)->double_val);
jit_extr_d_f(JIT_FPR0, JIT_FPR0);
jit_str_f_fppop(JIT_R0, JIT_FPR0);
}
} else if (ctype == scheme_int8_ctype) {
if (is_ref) {
jit_ldr_c(JIT_R1, JIT_R0);
jit_extr_c_l(JIT_R1, JIT_R1);
jit_fixnum_l(dest, JIT_R1);
} else {
jit_str_c(JIT_R0, JIT_R1);
}
} else if (ctype == scheme_uint8_ctype) {
if (is_ref) {
jit_ldr_uc(JIT_R1, JIT_R0);
jit_extr_uc_l(JIT_R1, JIT_R1);
jit_fixnum_l(dest, JIT_R1);
} else {
jit_str_uc(JIT_R0, JIT_R1);
}
} else if (ctype == scheme_int16_ctype) {
if (is_ref) {
jit_ldr_s(JIT_R1, JIT_R0);
jit_extr_s_l(JIT_R1, JIT_R1);
jit_fixnum_l(dest, JIT_R1);
} else {
jit_str_s(JIT_R0, JIT_R1);
}
} else if (ctype == scheme_uint16_ctype) {
if (is_ref) {
jit_ldr_us(JIT_R1, JIT_R0);
jit_extr_us_l(JIT_R1, JIT_R1);
jit_fixnum_l(dest, JIT_R1);
} else {
jit_str_us(JIT_R0, JIT_R1);
}
} else if (ctype == scheme_int32_ctype) {
if (is_ref) {
jit_ldr_i(JIT_R1, JIT_R0);
#ifdef SIXTY_FOUR_BIT_INTEGERS
jit_extr_i_l(JIT_R1, JIT_R1);
jit_fixnum_l(dest, JIT_R1);
#else
jit_fixnum_l(JIT_R0, JIT_R1);
jit_lshi_l(JIT_R2, JIT_R0, 1);
(void)jit_bner_l(refslow, JIT_R1, JIT_R2);
jit_movr_p(dest, JIT_R0);
#endif
} else {
jit_str_i(JIT_R0, JIT_R1);
}
} else if (ctype == scheme_uint32_ctype) {
if (is_ref) {
jit_ldr_i(JIT_R1, JIT_R0);
#ifdef SIXTY_FOUR_BIT_INTEGERS
jit_extr_ui_l(JIT_R1, JIT_R1);
jit_fixnum_l(dest, JIT_R1);
#else
(void)jit_blti_l(refslow, JIT_R1, 0);
jit_fixnum_l(JIT_R0, JIT_R1);
jit_lshi_l(JIT_R2, JIT_R0, 1);
(void)jit_bner_l(refslow, JIT_R1, JIT_R2);
jit_movr_p(dest, JIT_R0);
#endif
} else {
jit_str_ui(JIT_R0, JIT_R1);
}
#ifdef SIXTY_FOUR_BIT_INTEGERS
} else if (ctype == scheme_int64_ctype) {
if (is_ref) {
jit_ldr_l(JIT_R1, JIT_R0);
jit_fixnum_l(JIT_R0, JIT_R1);
jit_lshi_l(JIT_R2, JIT_R0, 1);
(void)jit_bner_l(refslow, JIT_R1, JIT_R2);
jit_movr_p(dest, JIT_R0);
} else {
jit_str_l(JIT_R0, JIT_R1);
}
} else if (ctype == scheme_uint64_ctype) {
if (is_ref) {
jit_ldr_l(JIT_R1, JIT_R0);
(void)jit_blti_l(refslow, JIT_R1, 0);
jit_fixnum_l(JIT_R0, JIT_R1);
jit_lshi_l(JIT_R2, JIT_R0, 1);
(void)jit_bner_l(refslow, JIT_R1, JIT_R2);
jit_movr_p(dest, JIT_R0);
} else {
jit_str_ul(JIT_R0, JIT_R1);
}
#endif
} else {
scheme_signal_error("internal error: unhandled ctype");
}
CHECK_LIMIT();
mz_patch_ucbranch(refdone);
}
__END_SHORT_JUMPS__(1);
mz_rs_inc(n); /* no sync */
mz_runstack_popped(jitter, n);
if (!is_ref && !result_ignored)
(void)jit_movi_p(dest, scheme_void);
return 1;
}
}

5
racket/src/racket/src/lightning/i386/fp-extfpu.h
View File

@ -195,6 +195,7 @@ union jit_fpu_double_imm {
: (FPX(), FLDLm(0, (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_fpu_ldr_d_fppush(rd, rs) (FPX(), FLDLm(0, (rs), 0, 0))
#define jit_fpu_ldr_f_fppush(rd, rs) (FPX(), FLDSm(0, (rs), 0, 0))
#define jit_fpu_ldr_ld(rd, rs) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDTm(0, (rs), 0, 0)) \
@ -288,11 +289,15 @@ union jit_fpu_double_imm {
#define jit_fpu_stxi_d_fppop(id, rd, rs) (FPX(), FSTPLm((id), (rd), 0, 0))
#define jit_fpu_str_d_fppop(rd, rs) (FPX(), FSTPLm(0, (rd), 0, 0))
#define jit_fpu_stxr_d_fppop(d1, d2, rs) (FPX(), FSTPLm(0, (d1), (d2), 1))
#define jit_fpu_str_f_fppop(rd, rs) (FPX(), FSTPSm(0, (rd), 0, 0))
#define jit_fpu_stxi_ld_fppop(id, rd, rs) (FPX(), FSTPTm((id), (rd), 0, 0))
#define jit_fpu_str_ld_fppop(rd, rs) (FPX(), FSTPTm(0, (rd), 0, 0))
#define jit_fpu_stxr_ld_fppop(d1, d2, rs) (FPX(), FSTPTm(0, (d1), (d2), 1))
#define jit_fpu_extr_d_f(r1, r2) jit_fpu_movr_d(r1, r2)
#define jit_fpu_extr_f_d(r1, r2) jit_fpu_movr_d(r1, r2)
/* Assume round to near mode */
#define jit_fpu_floorr_d_i(rd, rs) \
(FLDr (rs), jit_fpu_floor2((rd), ((rd) == _EDX ? _EAX : _EDX)))

2
racket/src/racket/src/lightning/i386/fp-sse.h
View File

@ -100,6 +100,7 @@
#define jit_ldxi_d(f0, r0, i0) MOVSDmr(i0, r0, _NOREG, _SCL1, f0)
#define jit_str_f(r0, f0) MOVSSrm(f0, 0, r0, _NOREG, _SCL1)
#define jit_str_d(r0, f0) MOVSDrm(f0, 0, r0, _NOREG, _SCL1)
#define _jit_sti_d(i0, f0) MOVSDrm(f0, (long)i0, _NOREG, _NOREG, _SCL1)
@ -140,6 +141,7 @@
#endif
# define jit_extr_d_f(f0, f1) CVTSD2SSrr(f1, f0)
# define jit_extr_f_d(f0, f1) CVTSS2SDrr(f1, f0)
#define jit_abs_d(f0, f1) \
((f0 == f1) \

5
racket/src/racket/src/lightning/i386/fp.h
View File

@ -98,6 +98,7 @@
# define jit_ldi_ld_fppush(rd, is) jit_fpu_ldi_ld_fppush(rd, is)
# define jit_ldr_d(rd, rs) jit_fpu_ldr_d(rd, rs)
# define jit_ldr_d_fppush(rd, rs) jit_fpu_ldr_d_fppush(rd, rs)
# define jit_ldr_f_fppush(rd, rs) jit_fpu_ldr_f_fppush(rd, rs)
# define jit_ldr_ld(rd, rs) jit_fpu_ldr_ld(rd, rs)
# define jit_ldr_ld_fppush(rd, rs) jit_fpu_ldr_ld_fppush(rd, rs)
# define jit_ldxi_d(rd, rs, is) jit_fpu_ldxi_d(rd, rs, is)
@ -113,16 +114,20 @@
# define jit_extr_i_ld_fppush(rd, rs) jit_fpu_extr_i_ld_fppush(rd, rs)
# define jit_extr_l_d_fppush(rd, rs) jit_fpu_extr_l_d_fppush(rd, rs)
# define jit_extr_l_ld_fppush(rd, rs) jit_fpu_extr_l_ld_fppush(rd, rs)
# define jit_extr_d_f(rd, rs) jit_fpu_extr_d_f(rd, rs)
# define jit_extr_f_d(rd, rs) jit_fpu_extr_f_d(rd, rs)
# define jit_stxi_f(id, rd, rs) jit_fpu_stxi_f(id, rd, rs)
# define jit_stxr_f(d1, d2, rs) jit_fpu_stxr_f(d1, d2, rs)
# define jit_stxi_d(id, rd, rs) jit_fpu_stxi_d(id, rd, rs)
# define jit_stxr_d(d1, d2, rs) jit_fpu_stxr_d(d1, d2, rs)
# define jit_sti_d(id, rs) jit_fpu_sti_d(id, rs)
# define jit_str_d(rd, rs) jit_fpu_str_d(rd, rs)
# define jit_str_f(rd, rs) jit_fpu_str_f(rd, rs)
# define jit_sti_d_fppop(id, rs) jit_fpu_sti_d_fppop(id, rs)
# define jit_sti_ld_fppop(id, rs) jit_fpu_sti_ld_fppop(id, rs)
# define jit_stxi_d_fppop(id, rd, rs) jit_fpu_stxi_d_fppop(id, rd, rs)
# define jit_str_d_fppop(rd, rs) jit_fpu_str_d_fppop(rd, rs)
# define jit_str_f_fppop(rd, rs) jit_fpu_str_f_fppop(rd, rs)
# define jit_stxr_d_fppop(d1, d2, rs) jit_fpu_stxr_d_fppop(d1, d2, rs)
# define jit_stxi_ld_fppop(id, rd, rs) jit_fpu_stxi_ld_fppop(id, rd, rs)
# define jit_str_ld_fppop(rd, rs) jit_fpu_str_ld_fppop(rd, rs)

4
racket/src/racket/src/lightning/ppc/fp.h
View File

@ -234,6 +234,8 @@
STWrm(JIT_AUX, -4, JIT_SP), \
LFDrri(rd, JIT_SP, -8), \
FSUBDrrr(rd, rd, JIT_FPR(5)))
#define jit_extr_d_f(rd, rs) jit_movr_d(rd, rs)
#define jit_extr_f_d(rd, rs) jit_movr_d(rd, rs)
#endif /* __lightning_asm_h */

231
racket/src/racket/src/optimize.c
View File

@ -109,6 +109,8 @@ static int closure_argument_flags(Scheme_Closure_Data *data, int i);
static int wants_local_type_arguments(Scheme_Object *rator, int argpos);
static void add_types_for_f_branch(Scheme_Object *t, Optimize_Info *info, int fuel);
static int optimize_info_is_ready(Optimize_Info *info, int pos);
static void optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use);
@ -131,6 +133,7 @@ static int optimize_is_mutated(Optimize_Info *info, int pos);
static int optimize_escapes_after_k_tick(Optimize_Info *info, int pos);
static int optimize_is_local_type_arg(Optimize_Info *info, int pos, int depth);
static int optimize_is_local_type_valued(Optimize_Info *info, int pos);
static void optimize_set_not_single_use(Optimize_Info *info, int pos);
static int env_uses_toplevel(Optimize_Info *frame);
static void env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map);
@ -1212,10 +1215,11 @@ Scheme_Object *scheme_make_struct_proc_shape(intptr_t k)
}
static int single_valued_noncm_expression(Scheme_Object *expr, int fuel)
/* Not necessarily omittable or copyable, but single-valued expresions that are not sensitive
/* Not necessarily omittable or copyable, but single-valued expressions that are not sensitive
to being in tail position. */
{
Scheme_Object *rator = NULL;
int num_args = 0;
switch (SCHEME_TYPE(expr)) {
case scheme_local_type:
@ -1224,31 +1228,29 @@ static int single_valued_noncm_expression(Scheme_Object *expr, int fuel)
return 1;
case scheme_application_type:
rator = ((Scheme_App_Rec *)expr)->args[0];
num_args = ((Scheme_App_Rec *)expr)->num_args;
break;
case scheme_application2_type:
rator = ((Scheme_App2_Rec *)expr)->rator;
num_args = 1;
break;
case scheme_application3_type:
rator = ((Scheme_App2_Rec *)expr)->rator;
break;
case scheme_compiled_let_void_type:
{
Scheme_Let_Header *lh = (Scheme_Let_Header *)expr;
Scheme_Compiled_Let_Value *clv;
if ((lh->count == 1) && (lh->num_clauses == 1) && (fuel > 0)) {
clv = (Scheme_Compiled_Let_Value *)lh->body;
return single_valued_noncm_expression(clv->body, fuel - 1);
}
}
num_args = 2;
break;
case scheme_branch_type:
if (fuel > 0) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr;
return (single_valued_noncm_expression(b->test, fuel - 1)
&& single_valued_noncm_expression(b->tbranch, fuel - 1)
return (single_valued_noncm_expression(b->tbranch, fuel - 1)
&& single_valued_noncm_expression(b->fbranch, fuel - 1));
}
break;
case scheme_begin0_sequence_type:
if (fuel > 0) {
Scheme_Sequence *seq = (Scheme_Sequence *)expr;
return single_valued_noncm_expression(seq->array[0], fuel - 1);
}
break;
case scheme_compiled_unclosed_procedure_type:
case scheme_case_lambda_sequence_type:
case scheme_set_bang_type:
@ -1256,6 +1258,17 @@ static int single_valued_noncm_expression(Scheme_Object *expr, int fuel)
default:
if (SCHEME_TYPE(expr) > _scheme_compiled_values_types_)
return 1;
/* for scheme_compiled_let_void_type
and scheme_begin_sequence_type */
if (fuel > 0) {
int offset = 0;
Scheme_Object *tail = expr, *inside = NULL;
extract_tail_inside(&tail, &inside, &offset);
if (inside)
return single_valued_noncm_expression(tail, fuel - 1);
}
break;
}
@ -1264,6 +1277,10 @@ static int single_valued_noncm_expression(Scheme_Object *expr, int fuel)
opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
if (opt >= SCHEME_PRIM_OPT_NONCM)
return 1;
/* special case: (values <expr>) */
if (SAME_OBJ(rator, scheme_values_func) && (num_args == 1))
return 1;
}
return 0;
@ -2439,6 +2456,8 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc)
else if (SAME_OBJ(rator, scheme_box_proc)
|| SAME_OBJ(rator, scheme_box_immutable_proc))
return scheme_box_p_proc;
else if (SAME_OBJ(rator, scheme_void_proc))
return scheme_void_p_proc;
{
Scheme_Object *p;
@ -2456,9 +2475,6 @@ static Scheme_Object *expr_implies_predicate(Scheme_Object *expr, Optimize_Info
Scheme_Object *rator = NULL;
int argc = 0;
/* Any returned predicate must match only non-#f values, since
that's assumed by optimize_branch(). */
if (fuel <= 0)
return NULL;
@ -2552,6 +2568,20 @@ static Scheme_Object *expr_implies_predicate(Scheme_Object *expr, Optimize_Info
if (SCHEME_INTP(expr)
&& IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(expr)))
return scheme_fixnum_p_proc;
if (SCHEME_NULLP(expr))
return scheme_null_p_proc;
if (SCHEME_PAIRP(expr))
return scheme_pair_p_proc;
if (SCHEME_MPAIRP(expr))
return scheme_mpair_p_proc;
if (SCHEME_VOIDP(expr))
return scheme_void_p_proc;
if (SCHEME_EOFP(expr))
return scheme_eof_object_p_proc;
if (SCHEME_FALSEP(expr))
return scheme_not_prim;
}
if (rator)
@ -2792,7 +2822,7 @@ static void check_known(Optimize_Info *info, Scheme_Object *app,
/* Replace the rator with an unsafe version if we know that it's ok. Alternatively,
the rator implies a check, so add type information for subsequent expressions.
If the rand has alredy a different type, mark that this will generate an error.
If unsafe is NULL then rator has no unsafe vesion, so only check the type. */
If unsafe is NULL then rator has no unsafe version, so only check the type. */
{
if (SCHEME_PRIMP(rator) && IS_NAMED_PRIM(rator, who)) {
Scheme_Object *pred;
@ -2845,8 +2875,10 @@ static Scheme_Object *finish_optimize_any_application(Scheme_Object *app, Scheme
check_known_rator(info, rator, 0);
if ((context & OPT_CONTEXT_BOOLEAN) && !info->escapes)
if (rator_implies_predicate(rator, argc))
return make_discarding_sequence(app, scheme_true, info, 0);
if (rator_implies_predicate(rator, argc)){
Scheme_Object *val = SAME_OBJ(rator, scheme_not_prim) ? scheme_false : scheme_true;
return make_discarding_sequence(app, val, info, 0);
}
if (SAME_OBJ(rator, scheme_void_proc))
return make_discarding_sequence(app, scheme_void, info, 0);
@ -3526,6 +3558,21 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
}
}
if (SAME_OBJ(app->rator, scheme_eq_prim)) {
Scheme_Object *pred1, *pred2;
pred1 = expr_implies_predicate(app->rand1, info, 0, 5);
if (pred1) {
pred2 = expr_implies_predicate(app->rand2, info, 0, 5);
if (pred2) {
if (!SAME_OBJ(pred1, pred2)) {
info->preserves_marks = 1;
info->single_result = 1;
return scheme_false;
}
}
}
}
info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
if (rator_flags & CLOS_RESULT_TENTATIVE) {
@ -3890,7 +3937,8 @@ int scheme_compiled_duplicate_ok(Scheme_Object *fb, int cross_module)
&& (!cross_module || (SCHEME_BYTE_STRLEN_VAL(fb) < STR_INLINE_LIMIT)))
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type)
|| (SCHEME_NUMBERP(fb)
&& (!cross_module || small_inline_number(fb))));
&& (!cross_module || small_inline_number(fb)))
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_ctype_type));
}
static int equivalent_exprs(Scheme_Object *a, Scheme_Object *b)
@ -3979,8 +4027,9 @@ Scheme_Hash_Tree *intersect_and_merge_types(Scheme_Hash_Tree *t_types, Scheme_Ha
static int relevant_predicate(Scheme_Object *pred)
{
/* Relevant predicates need to be disjoint for try_reduce_predicate(),
and they need to recognize non-#f values for optimize_branch().
list? is recognized in try_reduce_predicate as a special case*/
finish_optimize_application3() and add_types_for_t_branch().
As 'not' is included, all the other need to recognize non-#f values.
list? is recognized in try_reduce_predicate as a special case */
return (SAME_OBJ(pred, scheme_pair_p_proc)
|| SAME_OBJ(pred, scheme_null_p_proc)
@ -3992,10 +4041,13 @@ static int relevant_predicate(Scheme_Object *pred)
|| SAME_OBJ(pred, scheme_fixnum_p_proc)
|| SAME_OBJ(pred, scheme_flonum_p_proc)
|| SAME_OBJ(pred, scheme_extflonum_p_proc)
|| SAME_OBJ(pred, scheme_void_p_proc)
|| SAME_OBJ(pred, scheme_eof_object_p_proc)
|| SAME_OBJ(pred, scheme_not_prim)
);
}
static void add_types(Scheme_Object *t, Optimize_Info *info, int fuel)
static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fuel)
{
if (fuel < 0)
return;
@ -4004,17 +4056,68 @@ static void add_types(Scheme_Object *t, Optimize_Info *info, int fuel)
Scheme_App2_Rec *app = (Scheme_App2_Rec *)t;
if (SCHEME_PRIMP(app->rator)
&& SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)
&& !optimize_is_mutated(info, SCHEME_LOCAL_POS(app->rand))
&& relevant_predicate(app->rator)) {
/* Looks like a predicate on a local variable. Record that the
predicate succeeded, which may allow conversion of safe
operations to unsafe operations. */
add_type(info, SCHEME_LOCAL_POS(app->rand), app->rator);
}
} else if (SAME_TYPE(SCHEME_TYPE(t), scheme_application3_type)) {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)t;
Scheme_Object *pred1, *pred2;
if (SAME_OBJ(app->rator, scheme_eq_prim)) {
if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_local_type)
&& !optimize_is_mutated(info, SCHEME_LOCAL_POS(app->rand1))) {
pred1 = optimize_get_predicate(SCHEME_LOCAL_POS(app->rand1), info);
if (!pred1) {
pred2 = expr_implies_predicate(app->rand2, info, 0, 5);
if (pred2)
add_type(info, SCHEME_LOCAL_POS(app->rand1), pred2);
}
}
if (SAME_TYPE(SCHEME_TYPE(app->rand2), scheme_local_type)
&& !optimize_is_mutated(info, SCHEME_LOCAL_POS(app->rand2))) {
pred2 = optimize_get_predicate(SCHEME_LOCAL_POS(app->rand2), info);
if (!pred2) {
pred1 = expr_implies_predicate(app->rand1, info, 0, 5);
if (pred1)
add_type(info, SCHEME_LOCAL_POS(app->rand2), pred1);
}
}
}
} else if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)t;
if (SCHEME_FALSEP(b->fbranch)) {
add_types(b->test, info, fuel-1);
add_types(b->tbranch, info, fuel-1);
add_types_for_t_branch(b->test, info, fuel-1);
add_types_for_t_branch(b->tbranch, info, fuel-1);
}
if (SCHEME_FALSEP(b->tbranch)) {
add_types_for_f_branch(b->test, info, fuel-1);
add_types_for_t_branch(b->fbranch, info, fuel-1);
}
}
}
static void add_types_for_f_branch(Scheme_Object *t, Optimize_Info *info, int fuel)
{
if (fuel < 0)
return;
if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type)) {
add_type(info, SCHEME_LOCAL_POS(t), scheme_not_prim);
} else if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)t;
if (SAME_OBJ(b->fbranch, scheme_true)) {
add_types_for_t_branch(b->test, info, fuel-1);
add_types_for_f_branch(b->tbranch, info, fuel-1);
}
if (SAME_OBJ(b->tbranch, scheme_true)) {
add_types_for_f_branch(b->test, info, fuel-1);
add_types_for_f_branch(b->fbranch, info, fuel-1);
}
}
}
@ -4040,6 +4143,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
int then_escapes, then_preserves_marks, then_single_result;
int then_vclock, then_kclock, then_sclock;
Optimize_Info_Sequence info_seq;
Scheme_Object *pred;
b = (Scheme_Branch_Rec *)o;
@ -4101,19 +4205,21 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
break;
}
if (expr_implies_predicate(t2, info, id_offset, 5)) {
/* (if (let () (cons x y)) a b) => (if (begin (let () (begin x y #<void>)) #t) a b) */
/* all predicates recognize non-#f things */
pred = expr_implies_predicate(t2, info, id_offset, 5);
if (pred) {
/* (if (let () (cons x y)) a b) => (if (begin (let () (begin x y #<void>)) #t/#f) a b) */
Scheme_Object *test_val = SAME_OBJ(pred, scheme_not_prim) ? scheme_false : scheme_true;
t2 = optimize_ignored(t2, info, id_offset, 1, 0, 5);
t = replace_tail_inside(t2, inside, t);
t2 = scheme_true;
t2 = test_val;
id_offset = 0;
if (scheme_omittable_expr(t, 1, 5, 0, info, NULL, 0, 0, ID_OMIT)) {
t = scheme_true;
t = test_val;
inside = NULL;
} else {
t = make_sequence_2(t, scheme_true);
t = make_sequence_2(t, test_val);
inside = t;
}
}
@ -4152,7 +4258,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
init_sclock = info->sclock;
init_types = info->types;
add_types(t, info, 5);
add_types_for_t_branch(t, info, 5);
tb = scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context));
@ -4171,6 +4277,8 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
optimize_info_seq_step(info, &info_seq);
add_types_for_f_branch(t, info, 5);
fb = scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context));
if (info->escapes && then_escapes) {
@ -7325,13 +7433,13 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
case scheme_local_type:
{
Scheme_Object *val;
int pos, delta, is_mutated = 0;
int pos, delta, is_mutated = 0, single_use;
info->size += 1;
pos = SCHEME_LOCAL_POS(expr);
val = optimize_info_lookup(info, pos, NULL, NULL,
val = optimize_info_lookup(info, pos, NULL, &single_use,
(context & OPT_CONTEXT_NO_SINGLE) ? 0 : 1,
context, NULL, &is_mutated);
@ -7373,7 +7481,14 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
if (val)
return val;
} else {
if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type)) {
if (!single_use && SAME_TYPE(SCHEME_TYPE(val), scheme_local_type)) {
/* Since the replaced local was not single use, make sure the
replacement is also not marked as single use anymore */
optimize_set_not_single_use(info, SCHEME_LOCAL_POS(val));
}
if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type)
|| (SCHEME_TYPE(val) > _scheme_compiled_values_types_)) {
info->size -= 1;
return scheme_optimize_expr(val, info, context);
}
@ -7385,17 +7500,30 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
delta = optimize_info_get_shift(info, pos);
if (context & OPT_CONTEXT_BOOLEAN) {
if (!optimize_is_mutated(info, pos + delta)) {
Scheme_Object *pred;
pred = optimize_get_predicate(pos + delta, info);
if (pred) {
/* all predicates recognize non-#f things */
return scheme_true;
if (SAME_OBJ(pred, scheme_not_prim))
return scheme_false;
if (context & OPT_CONTEXT_BOOLEAN) {
/* all other predicates recognize non-#f things */
return scheme_true;
}
if (SAME_OBJ(pred, scheme_null_p_proc))
return scheme_null;
if (SAME_OBJ(pred, scheme_void_p_proc))
return scheme_void;
if (SAME_OBJ(pred, scheme_eof_object_p_proc))
return scheme_eof;
}
}
if (delta)
expr = scheme_make_local(scheme_local_type, pos + delta, 0);
expr = scheme_make_local(scheme_local_type, pos + delta, 0);
return expr;
}
@ -8313,6 +8441,31 @@ static int optimize_is_local_type_valued(Optimize_Info *info, int pos)
return check_use(info, pos, SCHEME_MAX_LOCAL_TYPE_MASK, OPT_LOCAL_TYPE_VAL_SHIFT);
}
static void optimize_set_not_single_use(Optimize_Info *info, int pos)
/* pos is in new-frame counts */
{
Scheme_Object *p, *n;
while (info) {
if (pos < info->new_frame)
break;
pos -= info->new_frame;
info = info->next;
}
p = info->consts;
while (p) {
n = SCHEME_VEC_ELS(p)[1];
if (SCHEME_INT_VAL(n) == pos) {
if (SCHEME_TRUEP(SCHEME_VEC_ELS(p)[3]))
SCHEME_VEC_ELS(p)[3] = scheme_false;
break;
}
p = SCHEME_VEC_ELS(p)[0];
}
}
static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
{
int j, i;

40
racket/src/racket/src/portfun.c
View File

@ -158,6 +158,7 @@ READ_ONLY static Scheme_Object *default_display_handler;
READ_ONLY static Scheme_Object *default_write_handler;
READ_ONLY static Scheme_Object *default_print_handler;
READ_ONLY Scheme_Object *scheme_eof_object_p_proc;
READ_ONLY Scheme_Object *scheme_default_global_print_handler;
READ_ONLY Scheme_Object *scheme_write_proc;
@ -242,20 +243,20 @@ scheme_init_port_fun(Scheme_Env *env)
GLOBAL_FOLDING_PRIM("string-port?", string_port_p, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("terminal-port?", scheme_terminal_port_p, 1, 1, 1, env);
GLOBAL_PRIM_W_ARITY("port-closed?", port_closed_p, 1, 1, env);
GLOBAL_PRIM_W_ARITY("open-input-file", open_input_file, 1, 3, env);
GLOBAL_PRIM_W_ARITY("open-input-bytes", open_input_byte_string, 1, 2, env);
GLOBAL_PRIM_W_ARITY("open-input-string", open_input_char_string, 1, 2, env);
GLOBAL_PRIM_W_ARITY("open-output-file", open_output_file, 1, 3, env);
GLOBAL_PRIM_W_ARITY("open-output-bytes", open_output_string, 0, 1, env);
GLOBAL_PRIM_W_ARITY("open-output-string", open_output_string, 0, 1, env);
GLOBAL_PRIM_W_ARITY("get-output-bytes", get_output_byte_string, 1, 4, env);
GLOBAL_PRIM_W_ARITY("get-output-string", get_output_char_string, 1, 1, env);
GLOBAL_PRIM_W_ARITY("open-input-output-file", open_input_output_file, 1, 3, env);
GLOBAL_PRIM_W_ARITY("close-input-port", close_input_port, 1, 1, env);
GLOBAL_PRIM_W_ARITY("close-output-port", close_output_port, 1, 1, env);
GLOBAL_PRIM_W_ARITY("make-input-port", make_input_port, 4, 10, env);
GLOBAL_PRIM_W_ARITY("make-output-port", make_output_port, 4, 11, env);
GLOBAL_NONCM_PRIM("port-closed?", port_closed_p, 1, 1, env);
GLOBAL_NONCM_PRIM("open-input-file", open_input_file, 1, 3, env);
GLOBAL_NONCM_PRIM("open-input-bytes", open_input_byte_string, 1, 2, env);
GLOBAL_NONCM_PRIM("open-input-string", open_input_char_string, 1, 2, env);
GLOBAL_NONCM_PRIM("open-output-file", open_output_file, 1, 3, env);
GLOBAL_NONCM_PRIM("open-output-bytes", open_output_string, 0, 1, env);
GLOBAL_NONCM_PRIM("open-output-string", open_output_string, 0, 1, env);
GLOBAL_NONCM_PRIM("get-output-bytes", get_output_byte_string, 1, 4, env);
GLOBAL_NONCM_PRIM("get-output-string", get_output_char_string, 1, 1, env);
GLOBAL_NONCM_PRIM("open-input-output-file", open_input_output_file, 1, 3, env);
GLOBAL_NONCM_PRIM("close-input-port", close_input_port, 1, 1, env);
GLOBAL_NONCM_PRIM("close-output-port", close_output_port, 1, 1, env);
GLOBAL_NONCM_PRIM("make-input-port", make_input_port, 4, 10, env);
GLOBAL_NONCM_PRIM("make-output-port", make_output_port, 4, 11, env);
GLOBAL_PRIM_W_ARITY2("call-with-output-file", call_with_output_file, 2, 4, 0, -1, env);
GLOBAL_PRIM_W_ARITY2("call-with-input-file", call_with_input_file, 2, 3, 0, -1, env);
@ -264,7 +265,7 @@ scheme_init_port_fun(Scheme_Env *env)
GLOBAL_PRIM_W_ARITY2("load", load, 1, 1, 0, -1, env);
GLOBAL_PRIM_W_ARITY2("make-pipe", sch_pipe, 0, 3, 2, 2, env);
GLOBAL_PRIM_W_ARITY2("port-next-location", port_next_location, 1, 1, 3, 3, env);
GLOBAL_PRIM_W_ARITY("set-port-next-location!", set_port_next_location, 4, 4, env);
GLOBAL_NONCM_PRIM("set-port-next-location!", set_port_next_location, 4, 4, env);
GLOBAL_PRIM_W_ARITY("filesystem-change-evt", filesystem_change_evt, 1, 2, env);
GLOBAL_NONCM_PRIM("filesystem-change-evt?", filesystem_change_evt_p, 1, 1, env);
@ -335,10 +336,11 @@ scheme_init_port_fun(Scheme_Env *env)
GLOBAL_NONCM_PRIM("port-count-lines!", port_count_lines, 1, 1, env);
GLOBAL_NONCM_PRIM("port-counts-lines?", port_counts_lines_p, 1, 1, env);
p = scheme_make_folding_prim(eof_object_p, "eof-object?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("eof-object?", p, env);
REGISTER_SO(scheme_eof_object_p_proc);
scheme_eof_object_p_proc = scheme_make_folding_prim(eof_object_p, "eof-object?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(scheme_eof_object_p_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("eof-object?", scheme_eof_object_p_proc, env);
scheme_add_global_constant("write", scheme_write_proc, env);
scheme_add_global_constant("display", scheme_display_proc, env);

17
racket/src/racket/src/schpriv.h
View File

@ -441,6 +441,7 @@ extern Scheme_Object *scheme_values_func;
extern Scheme_Object *scheme_procedure_p_proc;
extern Scheme_Object *scheme_procedure_arity_includes_proc;
extern Scheme_Object *scheme_void_proc;
extern Scheme_Object *scheme_void_p_proc;
extern Scheme_Object *scheme_syntax_p_proc;
extern Scheme_Object *scheme_check_not_undefined_proc;
extern Scheme_Object *scheme_check_assign_not_undefined_proc;
@ -549,6 +550,18 @@ extern Scheme_Object *scheme_reduced_procedure_struct;
#define scheme_constant_key scheme_stack_dump_key
#define scheme_fixed_key scheme_default_prompt_tag
extern Scheme_Object *scheme_double_ctype;
extern Scheme_Object *scheme_float_ctype;
extern Scheme_Object *scheme_pointer_ctype;
extern Scheme_Object *scheme_int8_ctype;
extern Scheme_Object *scheme_uint8_ctype;
extern Scheme_Object *scheme_int16_ctype;
extern Scheme_Object *scheme_uint16_ctype;
extern Scheme_Object *scheme_int32_ctype;
extern Scheme_Object *scheme_uint32_ctype;
extern Scheme_Object *scheme_int64_ctype;
extern Scheme_Object *scheme_uint64_ctype;
/*========================================================================*/
/* hash functions */
/*========================================================================*/
@ -648,6 +661,9 @@ extern void scheme_check_foreign_work(void);
XFORM_NONGCING extern void *scheme_extract_pointer(Scheme_Object *v);
#endif
Scheme_Object *scheme_foreign_ptr_ref(int argc, Scheme_Object **argv);
void scheme_foreign_ptr_set(int argc, Scheme_Object **argv);
void scheme_kickoff_green_thread_time_slice_timer(intptr_t usec);
#ifdef UNIX_PROCESSES
@ -2479,6 +2495,7 @@ Scheme_Object *scheme_default_prompt_read_handler(int, Scheme_Object *[]);
Scheme_Object *scheme_default_read_input_port_handler(int argc, Scheme_Object *[]);
Scheme_Object *scheme_default_read_handler(int argc, Scheme_Object *[]);
extern Scheme_Object *scheme_eof_object_p_proc;
extern Scheme_Object *scheme_default_global_print_handler;
/* Type readers & writers for compiled code data */