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. dependency.
The optional @racket[path] argument is intended for use when 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 directory containing the repository clone (where the repository itself
is a directory within @racket[path]). 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)]]{ (_bytes o len-expr)]]{
A @tech{custom function type} that can be used by itself as a simple 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 type for a byte string as a C pointer. Coercion of a C pointer to
is for a pointer return value, where the size should be explicitly simply @racket[_bytes] (without a specified length) requires that the pointer
specified. 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
There is no need for other modes analogous to those of @racket[_ptr]: length, including an extra byte for the nul terminator.}
input or input/output would be just like @racket[_bytes], since the
string carries its size information.}
@; ------------------------------------------------------------ @; ------------------------------------------------------------

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

@ -2,7 +2,8 @@
@(require scribble/manual "guide-utils.rkt" @(require scribble/manual "guide-utils.rkt"
(for-label racket/flonum (for-label racket/flonum
racket/unsafe/ops racket/unsafe/ops
racket/performance-hint)) racket/performance-hint
ffi/unsafe))
@title[#:tag "performance"]{Performance} @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} @section[#:tag "regexp-perf"]{Regular Expression Performance}
When a string or byte string is provided to a function like 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 In addition to its use with channel-specific procedures, a channel can
be used as a @tech{synchronizable event} (see @secref["sync"]). A be used as a @tech{synchronizable event} (see @secref["sync"]). A
channel is @tech{ready for synchronization} when @racket[make-channel] channel is @tech{ready for synchronization} when @racket[channel-get]
is ready when @racket[channel-get] would not block; the channel's would not block; the channel's @tech{synchronization result} is the
@tech{synchronization result} is the same as the @racket[channel-get] same as the @racket[channel-get] result.
result.
For buffered asynchronous channels, see @secref["async-channel"]. 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) (define-cpointer-type _foo)
(test 'foo? object-name 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) (report-errs)

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

@ -1485,6 +1485,11 @@
(let ([y (random)]) (let ([y (random)])
(begin0 y (set! y 5))))) (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)) (test-comp '(lambda (w) (car w) (mcar w))
'(lambda (w) (car w) (mcar w) (random))) '(lambda (w) (car w) (mcar w) (random)))
(test-comp '(lambda (w) (car w w)) (test-comp '(lambda (w) (car w w))
@ -1563,6 +1568,17 @@
(test-comp '(lambda (w) (if (void (list w)) 1 2)) (test-comp '(lambda (w) (if (void (list w)) 1 2))
'(lambda (w) 1)) '(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 (test null
call-with-values (lambda () (with-continuation-mark 'a 'b (values))) list) call-with-values (lambda () (with-continuation-mark 'a 'b (values))) list)
@ -1689,6 +1705,13 @@
(test-comp '(lambda (x) (not (if x #f 2))) (test-comp '(lambda (x) (not (if x #f 2)))
'(lambda (x) (not (if x #f #t)))) '(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)) (test-comp '(lambda (x) (if x x #f))
'(lambda (x) x)) '(lambda (x) x))
@ -1734,6 +1757,27 @@
(if r #t (something-else)))) (if r #t (something-else))))
'(lambda (x) (if (something) #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)]) (test-comp '(lambda (x) (let ([r (something)])
(r))) (r)))
'(lambda (x) ((something)))) '(lambda (x) ((something))))
@ -4866,6 +4910,18 @@
#f)) #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) (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 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 ;; Single-package repository
(make-directory a-dir) (make-directory a-dir)
$ (~a "cd " a-dir "; git init") $ (~a "cd " a-dir "; git init")
(set-file (build-path a-dir "main.rkt") "#lang racket/base 1") (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) $ (commit-changes-cmd)
(with-fake-root (with-fake-root
@ -186,6 +187,61 @@
(delete-directory/files (build-path clone-dir "a")) (delete-directory/files (build-path clone-dir "a"))
(delete-directory/files a-dir) (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 ;; 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'" [else (error 'foreign "internal error: bad compiler size for `~s'"
c-type)])) c-type)]))
;; _short etc is a convenient name for whatever is the compiler's `short' ;; _short etc is a convenient name for the compiler's `short',
;; (_short is signed) ;; which is always a 16-bit value for Racket:
(provide _short _ushort _sshort) (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 etc is a convenient name for whatever is the compiler's `int',
;; (_int is signed) ;; which is always a 32-byte value for Racket:
(provide _int _uint _sint) (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 etc is a convenient name for whatever is the compiler's `long',
;; (_long is signed) ;; which varies among platforms:
(provide _long _ulong _slong) (provide _long _ulong _slong)
(define-values (_long _ulong _slong) (sizeof->3ints 'long)) (define-values (_long _ulong _slong) (sizeof->3ints 'long))
;; _llong etc is a convenient name for whatever is the compiler's `long 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) (provide _llong _ullong _sllong)
(define-values (_llong _ullong _sllong) (sizeof->3ints '(long long))) (define-values (_llong _ullong _sllong) (sizeof->3ints '(long long)))
;; _intptr etc is a convenient name for whatever is the integer ;; _intptr etc is a convenient name for whatever is the integer
;; equivalent of the compiler's pointer (see `intptr_t') (_intptr is ;; equivalent of the compiler's pointer (see `intptr_t'),
;; signed) ;; which varies among platforms:
(provide _intptr _uintptr _sintptr) (provide _intptr _uintptr _sintptr)
(define-values (_intptr _uintptr _sintptr) (sizeof->3ints '(void *))) (define-values (_intptr _uintptr _sintptr) (sizeof->3ints '(void *)))
@ -1042,8 +1046,12 @@
(provide (rename-out [_bytes* _bytes])) (provide (rename-out [_bytes* _bytes]))
(define-fun-syntax _bytes* (define-fun-syntax _bytes*
(syntax-id-rules (o) (syntax-id-rules (o)
[(_ o n) (type: _pointer [(_ o n) (type: _gcpointer
pre: (make-sized-byte-string (malloc n) n) 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 is needed when this is used as a function output type
post: (x => (make-sized-byte-string x n)))] post: (x => (make-sized-byte-string x n)))]
[(_ . xs) (_bytes . xs)] [(_ . xs) (_bytes . xs)]

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

@ -920,7 +920,7 @@
accum2 accum2
(for/fold ([accum accum2]) ([i (in-range (TYPEATTR-cVars type-attr))]) (for/fold ([accum accum2]) ([i (in-range (TYPEATTR-cVars type-attr))])
(define var-desc (GetVarDesc type-info i)) (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 (begin0
(cons name accum) (cons name accum)
(ReleaseVarDesc type-info var-desc)))))) (ReleaseVarDesc type-info var-desc))))))

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

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

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

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

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

@ -83,17 +83,21 @@
pkg-path pkg-path
pkg-name))) pkg-name)))
;; Check installed packages: ;; Check installed packages:
(when (directory-exists? simple-pkg-path) ; might not exist for a clone shifting to a subdir
(for ([f (in-directory simple-pkg-path)]) (for ([f (in-directory simple-pkg-path)])
(define found-pkg (path->pkg f #:cache path-pkg-cache)) (define found-pkg (path->pkg f #:cache path-pkg-cache))
(when (and found-pkg (when (and found-pkg
(not (equal? found-pkg pkg-name))) (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" (pkg-error (~a "cannot link a directory that overlaps with existing packages\n"
" existing package: ~a\n" " existing package: ~a\n"
" overlapping path: ~a\n" " overlapping path: ~a\n"
" attempted package: ~a") " attempted package: ~a")
found-pkg found-pkg
f f
pkg-name))) pkg-name))))
;; Check simultaneous installs: ;; Check simultaneous installs:
(for ([(other-pkg other-dir) (in-hash simultaneous-installs)]) (for ([(other-pkg other-dir) (in-hash simultaneous-installs)])
(unless (equal? other-pkg pkg-name) (unless (equal? other-pkg pkg-name)
@ -1296,14 +1300,25 @@
(define (early-check-for-installed in-pkgs db #:wanted? wanted?) (define (early-check-for-installed in-pkgs db #:wanted? wanted?)
(for ([d (in-list in-pkgs)]) (for ([d (in-list in-pkgs)])
(define name (define-values (name ignored-type)
(if (pkg-desc? d) (if (pkg-desc? d)
(or (pkg-desc-name d) ;; For install of update:
(package-source->name (pkg-desc-source d) (cond
(if (eq? 'clone (pkg-desc-type d)) [(pkg-desc-name d)
'name (values (pkg-desc-name d) #f)]
(pkg-desc-type d)))) [(and (eq? (pkg-desc-type d) 'clone)
(package-source->name d))) ;; 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)) (define info (package-info name wanted? #:db db))
(when (and info (when (and info
(not wanted?) (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 (recursive-contract-stronger this that) (equal? this that))
(define trail (make-parameter #f))
(define ((recursive-contract-first-order ctc) val) (define ((recursive-contract-first-order ctc) val)
(contract-first-order-passes? (force-recursive-contract ctc) (contract-first-order-passes? (force-recursive-contract ctc)
val)) val))

4
racket/src/configure vendored
View File

@ -4537,7 +4537,7 @@ case "$host_os" in
LIBS="$LIBS -lsocket -lnsl -lintl" LIBS="$LIBS -lsocket -lnsl -lintl"
need_gcc_static_libgcc="yes" need_gcc_static_libgcc="yes"
check_gcc_dash_e="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_pthread="no"
use_flag_posix_pthread="yes" use_flag_posix_pthread="yes"
;; ;;
@ -6607,6 +6607,8 @@ fi
if test "${enable_noopt}" = "yes" ; then 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 }' 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"` CFLAGS=`echo "$CFLAGS" | awk "$AWKPRG"`
CPPFLAGS=`echo "$CPPFLAGS" | awk "$AWKPRG"`
PREFLAGS=`echo "$PREFLAGS" | awk "$AWKPRG"`
fi fi
############## usersetup ################ ############## 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 #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 */ /* (ptr-set! cpointer type [['abs] n] value) -> void */
/* n defaults to 0 which is the only value that should be used with ffi_objs */ /* 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 */ /* 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 #undef MYNAME
void scheme_foreign_ptr_set(int argc, Scheme_Object **argv)
{
(void)foreign_ptr_set_bang(argc, argv);
}
/* (ptr-equal? cpointer cpointer) -> boolean */ /* (ptr-equal? cpointer cpointer) -> boolean */
#define MYNAME "ptr-equal?" #define MYNAME "ptr-equal?"
static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[]) 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); 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) { static Scheme_Object *make_vector_in_master(int count, Scheme_Object *val) {
Scheme_Object *vec; Scheme_Object *vec;
void *original_gc; void *original_gc;
@ -4363,6 +4373,39 @@ void scheme_init_foreign_places() {
#endif #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) void scheme_init_foreign(Scheme_Env *env)
{ {
Scheme_Env *menv; Scheme_Env *menv;
@ -4449,9 +4492,9 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global_constant("memcpy", scheme_add_global_constant("memcpy",
scheme_make_noncm_prim(foreign_memcpy, "memcpy", 3, 6), menv); scheme_make_noncm_prim(foreign_memcpy, "memcpy", 3, 6), menv);
scheme_add_global_constant("ptr-ref", 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_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_add_global_constant("ptr-equal?",
scheme_make_noncm_prim(foreign_ptr_equal_p, "ptr-equal?", 2, 2), menv); scheme_make_noncm_prim(foreign_ptr_equal_p, "ptr-equal?", 2, 2), menv);
scheme_add_global_constant("make-sized-byte-string", scheme_add_global_constant("make-sized-byte-string",
@ -4483,6 +4526,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8); 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); scheme_add_global_constant("_int8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint8"); s = scheme_intern_symbol("uint8");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4490,6 +4535,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint8));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_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); scheme_add_global_constant("_uint8", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int16"); s = scheme_intern_symbol("int16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4497,6 +4544,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16); 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); scheme_add_global_constant("_int16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint16"); s = scheme_intern_symbol("uint16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4504,6 +4553,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint16));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_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); scheme_add_global_constant("_uint16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int32"); s = scheme_intern_symbol("int32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4511,6 +4562,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32); 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); scheme_add_global_constant("_int32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint32"); s = scheme_intern_symbol("uint32");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4518,6 +4571,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_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); scheme_add_global_constant("_uint32", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("int64"); s = scheme_intern_symbol("int64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4525,6 +4580,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64); 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); scheme_add_global_constant("_int64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("uint64"); s = scheme_intern_symbol("uint64");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4532,6 +4589,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint64));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_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); scheme_add_global_constant("_uint64", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("fixint"); s = scheme_intern_symbol("fixint");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4567,6 +4626,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_float));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_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); scheme_add_global_constant("_float", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double"); s = scheme_intern_symbol("double");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4574,6 +4635,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_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); scheme_add_global_constant("_double", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("longdouble"); s = scheme_intern_symbol("longdouble");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
@ -4644,6 +4707,8 @@ void scheme_init_foreign(Scheme_Env *env)
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_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); scheme_add_global_constant("_pointer", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("gcpointer"); s = scheme_intern_symbol("gcpointer");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); 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_add_global_constant("memcpy",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memcpy", 3, 6), menv); scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memcpy", 3, 6), menv);
scheme_add_global_constant("ptr-ref", 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_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_add_global_constant("ptr-equal?",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), menv); scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), menv);
scheme_add_global_constant("make-sized-byte-string", 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 */ /* if n is given, an 'abs flag can precede it to make n be a byte offset */
/* rather than some multiple of sizeof(type). */ /* rather than some multiple of sizeof(type). */
/* WARNING: there are *NO* checks at all, this is raw C level code. */ /* 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 size=0; void *ptr; Scheme_Object *base;
intptr_t delta; int gcsrc=1; intptr_t delta; int gcsrc=1;
Scheme_Object *cp, *already_ptr = NULL; 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); 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 */ /* (ptr-set! cpointer type [['abs] n] value) -> void */
/* n defaults to 0 which is the only value that should be used with ffi_objs */ /* 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 */ /* if n is given, an 'abs flag can precede it to make n be a byte offset */
/* rather than some multiple of sizeof(type). */ /* rather than some multiple of sizeof(type). */
/* WARNING: there are *NO* checks at all, this is raw C level code. */ /* 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 size=0; void *ptr;
intptr_t delta; intptr_t delta;
Scheme_Object *val = argv[argc-1], *base; Scheme_Object *val = argv[argc-1], *base;
@ -2319,6 +2324,11 @@ static Scheme_Object *do_memop(const char *who, int mode,
return scheme_void; 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 */ /* (ptr-equal? cpointer cpointer) -> boolean */
@cdefine[ptr-equal? 2 2]{ @cdefine[ptr-equal? 2 2]{
Scheme_Object *cp1, *cp2; 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); 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) { static Scheme_Object *make_vector_in_master(int count, Scheme_Object *val) {
Scheme_Object *vec; Scheme_Object *vec;
void *original_gc; void *original_gc;
@ -3492,6 +3502,39 @@ void scheme_init_foreign_places() {
#endif #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) void scheme_init_foreign(Scheme_Env *env)
{ {
Scheme_Env *menv; Scheme_Env *menv;
@ -3513,6 +3556,12 @@ void scheme_init_foreign(Scheme_Env *env)
@cmake["t" ctype "s" @cmake["t" ctype "s"
@list{(Scheme_Object*)(void*)(&ffi_type_@ftype)} @list{(Scheme_Object*)(void*)(&ffi_type_@ftype)}
@list{(Scheme_Object*)FOREIGN_@cname}] @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("_@stype", (Scheme_Object*)t, menv)})
scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv); scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv);
scheme_finish_primitive_module(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" LIBS="$LIBS -lsocket -lnsl -lintl"
need_gcc_static_libgcc="yes" need_gcc_static_libgcc="yes"
check_gcc_dash_e="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_pthread="no"
use_flag_posix_pthread="yes" use_flag_posix_pthread="yes"
;; ;;
@ -1530,6 +1530,8 @@ fi
if test "${enable_noopt}" = "yes" ; then 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 }' 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"` CFLAGS=`echo "$CFLAGS" | awk "$AWKPRG"`
CPPFLAGS=`echo "$CPPFLAGS" | awk "$AWKPRG"`
PREFLAGS=`echo "$PREFLAGS" | awk "$AWKPRG"`
fi fi
############## usersetup ################ ############## usersetup ################

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

@ -585,7 +585,7 @@ GC2_EXTERN void GC_set_backpointer_object(void *p);
#endif #endif
/* Macros (implementation-specific): */ /* Macros (implementation-specific): */
#if defined(__x86_64__) || defined(_WIN64) #ifdef SIXTY_FOUR_BIT_INTEGERS
# define gcLOG_WORD_SIZE 3 # define gcLOG_WORD_SIZE 3
#else #else
# define gcLOG_WORD_SIZE 2 # 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 # ifdef NEED_SIGSTACK
{ {
stack_t ss; stack_t ss;
uintptr_t sz = 10*SIGSTKSZ;
ss.ss_sp = malloc(SIGSTKSZ); ss.ss_sp = malloc(sz);
ss.ss_size = SIGSTKSZ; ss.ss_size = sz;
ss.ss_flags = 0; ss.ss_flags = 0;
sigaltstack(&ss, NULL); sigaltstack(&ss, NULL);

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

@ -17,7 +17,7 @@ enum {
}; };
#if defined(_WIN32) || defined(__CYGWIN32__) #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) #elif defined(OSKIT)
# define OS_ALLOCATOR_NEEDS_ALIGNMENT # define OS_ALLOCATOR_NEEDS_ALIGNMENT
#elif defined(MZ_USE_PLACES) || defined(PREFER_MMAP_LARGE_BLOCKS) #elif defined(MZ_USE_PLACES) || defined(PREFER_MMAP_LARGE_BLOCKS)
@ -33,6 +33,10 @@ enum {
# define QUEUED_MPROTECT_IS_PROMISCUOUS 0 # define QUEUED_MPROTECT_IS_PROMISCUOUS 0
#endif #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 AllocCacheBlock;
struct BlockCache; struct BlockCache;
typedef struct MMU { 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) { static inline void mmu_assert_os_page_aligned(MMU *mmu, size_t p) {
if (p & (mmu->os_pagesize - 1)) { 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(); abort();
} }
} }

8
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_p_proc;
READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc; READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc;
READ_ONLY Scheme_Object *scheme_void_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_not_undefined_proc;
READ_ONLY Scheme_Object *scheme_check_assign_not_undefined_proc; READ_ONLY Scheme_Object *scheme_check_assign_not_undefined_proc;
READ_ONLY Scheme_Object *scheme_apply_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); scheme_add_global_constant("void", scheme_void_proc, env);
o = scheme_make_folding_prim(void_p, "void?", 1, 1, 1); REGISTER_SO(scheme_void_p_proc);
SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED 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_PRIM_IS_OMITABLE);
scheme_add_global_constant("void?", o, env); scheme_add_global_constant("void?", scheme_void_p_proc, env);
#ifdef TIME_SYNTAX #ifdef TIME_SYNTAX
scheme_add_global_constant("time-apply", scheme_add_global_constant("time-apply",

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

@ -197,7 +197,8 @@
ss_i ss_i
iSp_v iSp_v
sss_s sss_s
_v)) _v
iS_v))
(with-output-to-file "jit_ts_def.c" (with-output-to-file "jit_ts_def.c"
#:exists 'replace #: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 *make_rest_list_code, *make_rest_list_clear_code;
void *call_check_not_defined_code, *call_check_assign_not_defined_code; void *call_check_not_defined_code, *call_check_assign_not_defined_code;
void *force_value_same_mark_code; void *force_value_same_mark_code;
void *slow_ptr_set_code, *slow_ptr_ref_code;
Continuation_Apply_Indirect continuation_apply_indirect_code; Continuation_Apply_Indirect continuation_apply_indirect_code;
#ifdef MZ_USE_LWC #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_movi_d_fppush(rd,immd) jit_movi_d(rd,immd)
#define jit_ldi_d_fppush(rd, is) jit_ldi_d(rd, is) #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_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_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_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_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) #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_sqrt_d_fppop(rd,rs) jit_sqrt_d(rd,rs)
#define jit_sti_d_fppop(id, rs) jit_sti_d(id, 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_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_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_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) #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 # endif
define_ts_iS_s(scheme_check_not_undefined, FSRC_MARKS) 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_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 #endif
#ifdef JITCALL_TS_PROCS #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_checked_integer_to_char scheme_checked_integer_to_char
# define ts_scheme_check_not_undefined scheme_check_not_undefined # 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_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 #endif

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

@ -1,38 +1,38 @@
#define define_ts_siS_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g8, g9, g10); \ return id(g12, g13, g14); \
} }
#define define_ts_iSs_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g11, g12, g13); \ return id(g15, g16, g17); \
} }
#define define_ts_s_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g14); \ return id(g18); \
} }
#define define_ts_n_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g15); \ return id(g19); \
} }
#define define_ts__s(id, src_type) \ #define define_ts__s(id, src_type) \
static Scheme_Object* ts_ ## id() \ static Scheme_Object* ts_ ## id() \
@ -44,202 +44,202 @@ static Scheme_Object* ts_ ## id() \
return id(); \ return id(); \
} }
#define define_ts_ss_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g16, g17); \ return id(g20, g21); \
} }
#define define_ts_ssi_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g18, g19, g20); \ return id(g22, g23, g24); \
} }
#define define_ts_tt_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ if (scheme_use_rtcall) \
return scheme_rtcall_tt_s("[" #id "]", src_type, id, g21, g22); \ return scheme_rtcall_tt_s("[" #id "]", src_type, id, g25, g26); \
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); \
else \ else \
return id(g25, g26); \ return id(g25, g26); \
} }
#define define_ts_l_s(id, src_type) \ #define define_ts_ss_m(id, src_type) \
static Scheme_Object* ts_ ## id(intptr_t g27) \ static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g27, Scheme_Object* g28) \
XFORM_SKIP_PROC \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ 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) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
id(g28, g29, g30); \ id(g32, g33, g34); \
} }
#define define_ts_iiS_v(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
id(g31, g32, g33); \ id(g35, g36, g37); \
} }
#define define_ts_ss_v(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
id(g34, g35); \ id(g38, g39); \
} }
#define define_ts_b_v(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ if (scheme_use_rtcall) \
scheme_rtcall_b_v("[" #id "]", src_type, id, g36); \ scheme_rtcall_b_v("[" #id "]", src_type, id, g40); \
else \ else \
id(g36); \ id(g40); \
} }
#define define_ts_sl_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g37, g38); \ return id(g41, g42); \
} }
#define define_ts_iS_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g39, g40); \ return id(g43, g44); \
} }
#define define_ts_S_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g41); \ return id(g45); \
} }
#define define_ts_s_v(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ if (scheme_use_rtcall) \
scheme_rtcall_s_v("[" #id "]", src_type, id, g42); \ scheme_rtcall_s_v("[" #id "]", src_type, id, g46); \
else \ else \
id(g42); \ id(g46); \
} }
#define define_ts_iSi_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g43, g44, g45); \ return id(g47, g48, g49); \
} }
#define define_ts_siS_v(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
id(g46, g47, g48); \ id(g50, g51, g52); \
} }
#define define_ts_z_p(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g49); \ return id(g53); \
} }
#define define_ts_si_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g50, g51); \ return id(g54, g55); \
} }
#define define_ts_sis_v(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
id(g52, g53, g54); \ id(g56, g57, g58); \
} }
#define define_ts_ss_i(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g55, g56); \ return id(g59, g60); \
} }
#define define_ts_iSp_v(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
id(g57, g58, g59); \ id(g61, g62, g63); \
} }
#define define_ts_sss_s(id, src_type) \ #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 \ XFORM_SKIP_PROC \
{ \ { \
if (scheme_use_rtcall) \ 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 \ else \
return id(g60, g61, g62); \ return id(g64, g65, g66); \
} }
#define define_ts__v(id, src_type) \ #define define_ts__v(id, src_type) \
static void ts_ ## id() \ static void ts_ ## id() \
@ -250,3 +250,12 @@ static void ts_ ## id() \
else \ else \
id(); \ 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -13,9 +13,9 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g63; future->arg_s0 = g69;
future->arg_i1 = g64; future->arg_i1 = g70;
future->arg_S2 = g65; future->arg_S2 = g71;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -25,7 +25,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -40,9 +40,9 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_i0 = g66; future->arg_i0 = g72;
future->arg_S1 = g67; future->arg_S1 = g73;
future->arg_s2 = g68; future->arg_s2 = g74;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -52,7 +52,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -67,8 +67,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g69; future->arg_s0 = g75;
send_special_result(future, g69); send_special_result(future, g75);
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
future = fts->thread->current_ft; future = fts->thread->current_ft;
@ -77,7 +77,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -92,7 +92,7 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_n0 = g70; future->arg_n0 = g76;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -127,7 +127,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -142,8 +142,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g71; future->arg_s0 = g77;
future->arg_s1 = g72; future->arg_s1 = g78;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -153,7 +153,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -168,9 +168,9 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g73; future->arg_s0 = g79;
future->arg_s1 = g74; future->arg_s1 = g80;
future->arg_i2 = g75; future->arg_i2 = g81;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -180,7 +180,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -195,8 +195,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_t0 = g76; future->arg_t0 = g82;
future->arg_t1 = g77; future->arg_t1 = g83;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -206,7 +206,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -221,8 +221,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g78; future->arg_s0 = g84;
future->arg_s1 = g79; future->arg_s1 = g85;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -232,7 +232,7 @@
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -247,8 +247,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_S0 = g80; future->arg_S0 = g86;
future->arg_l1 = g81; future->arg_l1 = g87;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -258,7 +258,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -273,7 +273,7 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_l0 = g82; future->arg_l0 = g88;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -283,7 +283,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -298,9 +298,9 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_b0 = g83; future->arg_b0 = g89;
future->arg_s1 = g84; future->arg_s1 = g90;
future->arg_i2 = g85; future->arg_i2 = g91;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -325,9 +325,9 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_i0 = g86; future->arg_i0 = g92;
future->arg_i1 = g87; future->arg_i1 = g93;
future->arg_S2 = g88; future->arg_S2 = g94;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -352,8 +352,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g89; future->arg_s0 = g95;
future->arg_s1 = g90; future->arg_s1 = g96;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -378,7 +378,7 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_b0 = g91; future->arg_b0 = g97;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -403,8 +403,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g92; future->arg_s0 = g98;
future->arg_l1 = g93; future->arg_l1 = g99;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -414,7 +414,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -429,8 +429,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_i0 = g94; future->arg_i0 = g100;
future->arg_S1 = g95; future->arg_S1 = g101;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -440,7 +440,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -455,7 +455,7 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_S0 = g96; future->arg_S0 = g102;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -465,7 +465,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -480,8 +480,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g97; future->arg_s0 = g103;
send_special_result(future, g97); send_special_result(future, g103);
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
future = fts->thread->current_ft; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -505,9 +505,9 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_i0 = g98; future->arg_i0 = g104;
future->arg_S1 = g99; future->arg_S1 = g105;
future->arg_i2 = g100; future->arg_i2 = g106;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -517,7 +517,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -532,9 +532,9 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g101; future->arg_s0 = g107;
future->arg_i1 = g102; future->arg_i1 = g108;
future->arg_S2 = g103; future->arg_S2 = g109;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -559,7 +559,7 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_z0 = g104; future->arg_z0 = g110;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -569,7 +569,7 @@
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -584,8 +584,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g105; future->arg_s0 = g111;
future->arg_i1 = g106; future->arg_i1 = g112;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -595,7 +595,7 @@
receive_special_result(future, retval, 1); receive_special_result(future, retval, 1);
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -610,9 +610,9 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g107; future->arg_s0 = g113;
future->arg_i1 = g108; future->arg_i1 = g114;
future->arg_s2 = g109; future->arg_s2 = g115;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -637,8 +637,8 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g110; future->arg_s0 = g116;
future->arg_s1 = g111; future->arg_s1 = g117;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; fts->thread = scheme_current_thread;
@ -648,7 +648,7 @@
return retval; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -663,9 +663,9 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_i0 = g112; future->arg_i0 = g118;
future->arg_S1 = g113; future->arg_S1 = g119;
future->arg_p2 = g114; future->arg_p2 = g120;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; 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 XFORM_SKIP_PROC
{ {
Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_Thread_State *fts = scheme_future_thread_state;
@ -690,9 +690,9 @@
future->time_of_request = tm; future->time_of_request = tm;
future->source_of_request = who; future->source_of_request = who;
future->source_type = src_type; future->source_type = src_type;
future->arg_s0 = g115; future->arg_s0 = g121;
future->arg_s1 = g116; future->arg_s1 = g122;
future->arg_s2 = g117; future->arg_s2 = g123;
future_do_runtimecall(fts, (void*)f, 0, 1, 0); future_do_runtimecall(fts, (void*)f, 0, 1, 0);
fts->thread = scheme_current_thread; 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 #define SIG_siS_s 11
typedef Scheme_Object* (*prim_siS_s)(Scheme_Object*, int, Scheme_Object**); 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 #define SIG_iSs_s 12
typedef Scheme_Object* (*prim_iSs_s)(int, Scheme_Object**, Scheme_Object*); 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 #define SIG_s_s 13
typedef Scheme_Object* (*prim_s_s)(Scheme_Object*); 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 #define SIG_n_s 14
typedef Scheme_Object* (*prim_n_s)(Scheme_Native_Closure_Data*); 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 #define SIG__s 15
typedef Scheme_Object* (*prim__s)(); typedef Scheme_Object* (*prim__s)();
Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f ); Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f );
#define SIG_ss_s 16 #define SIG_ss_s 16
typedef Scheme_Object* (*prim_ss_s)(Scheme_Object*, Scheme_Object*); 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 #define SIG_ssi_s 17
typedef Scheme_Object* (*prim_ssi_s)(Scheme_Object*, Scheme_Object*, int); 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 #define SIG_tt_s 18
typedef Scheme_Object* (*prim_tt_s)(const Scheme_Object*, const Scheme_Object*); 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 #define SIG_ss_m 19
typedef MZ_MARK_STACK_TYPE (*prim_ss_m)(Scheme_Object*, Scheme_Object*); 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 #define SIG_Sl_s 20
typedef Scheme_Object* (*prim_Sl_s)(Scheme_Object**, intptr_t); 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 #define SIG_l_s 21
typedef Scheme_Object* (*prim_l_s)(intptr_t); 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 #define SIG_bsi_v 22
typedef void (*prim_bsi_v)(Scheme_Bucket*, Scheme_Object*, int); 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 #define SIG_iiS_v 23
typedef void (*prim_iiS_v)(int, int, Scheme_Object**); 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 #define SIG_ss_v 24
typedef void (*prim_ss_v)(Scheme_Object*, Scheme_Object*); 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 #define SIG_b_v 25
typedef void (*prim_b_v)(Scheme_Bucket*); 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 #define SIG_sl_s 26
typedef Scheme_Object* (*prim_sl_s)(Scheme_Object*, intptr_t); 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 #define SIG_iS_s 27
typedef Scheme_Object* (*prim_iS_s)(int, Scheme_Object**); 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 #define SIG_S_s 28
typedef Scheme_Object* (*prim_S_s)(Scheme_Object**); 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 #define SIG_s_v 29
typedef void (*prim_s_v)(Scheme_Object*); 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 #define SIG_iSi_s 30
typedef Scheme_Object* (*prim_iSi_s)(int, Scheme_Object**, int); 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 #define SIG_siS_v 31
typedef void (*prim_siS_v)(Scheme_Object*, int, Scheme_Object**); 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 #define SIG_z_p 32
typedef void* (*prim_z_p)(size_t); 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 #define SIG_si_s 33
typedef Scheme_Object* (*prim_si_s)(Scheme_Object*, int); 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 #define SIG_sis_v 34
typedef void (*prim_sis_v)(Scheme_Object*, int, Scheme_Object*); 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 #define SIG_ss_i 35
typedef int (*prim_ss_i)(Scheme_Object*, Scheme_Object*); 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 #define SIG_iSp_v 36
typedef void (*prim_iSp_v)(int, Scheme_Object**, void*); 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 #define SIG_sss_s 37
typedef Scheme_Object* (*prim_sss_s)(Scheme_Object*, Scheme_Object*, Scheme_Object*); 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 #define SIG__v 38
typedef void (*prim__v)(); typedef void (*prim__v)();
void scheme_rtcall__v(const char *who, int src_type, prim__v f ); 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(); 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; 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) int scheme_generate_force_value_same_mark(mz_jit_state *jitter)
{ {
GC_CAN_IGNORE jit_insn *refr USED_ONLY_FOR_FUTURES; 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); mz_prepare(1);
jit_pusharg_p(JIT_R0); jit_pusharg_p(JIT_R0);
(void)mz_finish_lwe(ts_scheme_force_value_same_mark, refr); (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) 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 *** */ /* *** force_value_same_mark_code *** */
/* Helper for futures: a synthetic functon that just forces values, /* Helper for futures: a synthetic functon that just forces values,
which will bounce back to the runtime thread (but with lightweight 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_threadlocal();
mz_pop_locals(); mz_pop_locals();
jit_ret(); jit_ret();
return 1; return 1;
} }
int scheme_do_generate_common(mz_jit_state *jitter, void *_data) int scheme_do_generate_common(mz_jit_state *jitter, void *_data)
{ {
if (!common0(jitter, _data)) return 0; 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; 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) { if (!for_branch) {
int k; int k;
k = inlineable_struct_prim(rator, jitter, 2, 2); 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_rs_inc(5);
mz_runstack_popped(jitter, 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; 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))) : (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_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) \ #define jit_fpu_ldr_ld(rd, rs) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDTm(0, (rs), 0, 0)) \ ((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_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_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_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_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_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_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 */ /* Assume round to near mode */
#define jit_fpu_floorr_d_i(rd, rs) \ #define jit_fpu_floorr_d_i(rd, rs) \
(FLDr (rs), jit_fpu_floor2((rd), ((rd) == _EDX ? _EAX : _EDX))) (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_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_str_d(r0, f0) MOVSDrm(f0, 0, r0, _NOREG, _SCL1)
#define _jit_sti_d(i0, f0) MOVSDrm(f0, (long)i0, _NOREG, _NOREG, _SCL1) #define _jit_sti_d(i0, f0) MOVSDrm(f0, (long)i0, _NOREG, _NOREG, _SCL1)
@ -140,6 +141,7 @@
#endif #endif
# define jit_extr_d_f(f0, f1) CVTSD2SSrr(f1, f0) # 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) \ #define jit_abs_d(f0, f1) \
((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_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(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_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(rd, rs) jit_fpu_ldr_ld(rd, rs)
# define jit_ldr_ld_fppush(rd, rs) jit_fpu_ldr_ld_fppush(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) # 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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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) # define jit_str_ld_fppop(rd, rs) jit_fpu_str_ld_fppop(rd, rs)

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

@ -235,5 +235,7 @@
LFDrri(rd, JIT_SP, -8), \ LFDrri(rd, JIT_SP, -8), \
FSUBDrrr(rd, rd, JIT_FPR(5))) 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 */ #endif /* __lightning_asm_h */

227
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 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 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); 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_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_arg(Optimize_Info *info, int pos, int depth);
static int optimize_is_local_type_valued(Optimize_Info *info, int pos); 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 int env_uses_toplevel(Optimize_Info *frame);
static void env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map); 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) 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. */ to being in tail position. */
{ {
Scheme_Object *rator = NULL; Scheme_Object *rator = NULL;
int num_args = 0;
switch (SCHEME_TYPE(expr)) { switch (SCHEME_TYPE(expr)) {
case scheme_local_type: case scheme_local_type:
@ -1224,31 +1228,29 @@ static int single_valued_noncm_expression(Scheme_Object *expr, int fuel)
return 1; return 1;
case scheme_application_type: case scheme_application_type:
rator = ((Scheme_App_Rec *)expr)->args[0]; rator = ((Scheme_App_Rec *)expr)->args[0];
num_args = ((Scheme_App_Rec *)expr)->num_args;
break; break;
case scheme_application2_type: case scheme_application2_type:
rator = ((Scheme_App2_Rec *)expr)->rator; rator = ((Scheme_App2_Rec *)expr)->rator;
num_args = 1;
break; break;
case scheme_application3_type: case scheme_application3_type:
rator = ((Scheme_App2_Rec *)expr)->rator; rator = ((Scheme_App2_Rec *)expr)->rator;
break; num_args = 2;
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);
}
}
break; break;
case scheme_branch_type: case scheme_branch_type:
if (fuel > 0) { if (fuel > 0) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr; Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr;
return (single_valued_noncm_expression(b->test, fuel - 1) return (single_valued_noncm_expression(b->tbranch, fuel - 1)
&& single_valued_noncm_expression(b->tbranch, fuel - 1)
&& single_valued_noncm_expression(b->fbranch, fuel - 1)); && single_valued_noncm_expression(b->fbranch, fuel - 1));
} }
break; 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_compiled_unclosed_procedure_type:
case scheme_case_lambda_sequence_type: case scheme_case_lambda_sequence_type:
case scheme_set_bang_type: case scheme_set_bang_type:
@ -1256,6 +1258,17 @@ static int single_valued_noncm_expression(Scheme_Object *expr, int fuel)
default: default:
if (SCHEME_TYPE(expr) > _scheme_compiled_values_types_) if (SCHEME_TYPE(expr) > _scheme_compiled_values_types_)
return 1; 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; 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; opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
if (opt >= SCHEME_PRIM_OPT_NONCM) if (opt >= SCHEME_PRIM_OPT_NONCM)
return 1; return 1;
/* special case: (values <expr>) */
if (SAME_OBJ(rator, scheme_values_func) && (num_args == 1))
return 1;
} }
return 0; 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) else if (SAME_OBJ(rator, scheme_box_proc)
|| SAME_OBJ(rator, scheme_box_immutable_proc)) || SAME_OBJ(rator, scheme_box_immutable_proc))
return scheme_box_p_proc; return scheme_box_p_proc;
else if (SAME_OBJ(rator, scheme_void_proc))
return scheme_void_p_proc;
{ {
Scheme_Object *p; Scheme_Object *p;
@ -2456,9 +2475,6 @@ static Scheme_Object *expr_implies_predicate(Scheme_Object *expr, Optimize_Info
Scheme_Object *rator = NULL; Scheme_Object *rator = NULL;
int argc = 0; int argc = 0;
/* Any returned predicate must match only non-#f values, since
that's assumed by optimize_branch(). */
if (fuel <= 0) if (fuel <= 0)
return NULL; return NULL;
@ -2552,6 +2568,20 @@ static Scheme_Object *expr_implies_predicate(Scheme_Object *expr, Optimize_Info
if (SCHEME_INTP(expr) if (SCHEME_INTP(expr)
&& IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(expr))) && IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(expr)))
return scheme_fixnum_p_proc; 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) 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, /* 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. 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 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)) { if (SCHEME_PRIMP(rator) && IS_NAMED_PRIM(rator, who)) {
Scheme_Object *pred; Scheme_Object *pred;
@ -2845,8 +2875,10 @@ static Scheme_Object *finish_optimize_any_application(Scheme_Object *app, Scheme
check_known_rator(info, rator, 0); check_known_rator(info, rator, 0);
if ((context & OPT_CONTEXT_BOOLEAN) && !info->escapes) if ((context & OPT_CONTEXT_BOOLEAN) && !info->escapes)
if (rator_implies_predicate(rator, argc)) if (rator_implies_predicate(rator, argc)){
return make_discarding_sequence(app, scheme_true, info, 0); 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)) if (SAME_OBJ(rator, scheme_void_proc))
return make_discarding_sequence(app, scheme_void, info, 0); 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->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT); info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
if (rator_flags & CLOS_RESULT_TENTATIVE) { 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))) && (!cross_module || (SCHEME_BYTE_STRLEN_VAL(fb) < STR_INLINE_LIMIT)))
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type) || SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type)
|| (SCHEME_NUMBERP(fb) || (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) 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) static int relevant_predicate(Scheme_Object *pred)
{ {
/* Relevant predicates need to be disjoint for try_reduce_predicate(), /* Relevant predicates need to be disjoint for try_reduce_predicate(),
and they need to recognize non-#f values for optimize_branch(). finish_optimize_application3() and add_types_for_t_branch().
list? is recognized in try_reduce_predicate as a special case*/ 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) return (SAME_OBJ(pred, scheme_pair_p_proc)
|| SAME_OBJ(pred, scheme_null_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_fixnum_p_proc)
|| SAME_OBJ(pred, scheme_flonum_p_proc) || SAME_OBJ(pred, scheme_flonum_p_proc)
|| SAME_OBJ(pred, scheme_extflonum_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) if (fuel < 0)
return; 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; Scheme_App2_Rec *app = (Scheme_App2_Rec *)t;
if (SCHEME_PRIMP(app->rator) if (SCHEME_PRIMP(app->rator)
&& SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type) && SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)
&& !optimize_is_mutated(info, SCHEME_LOCAL_POS(app->rand))
&& relevant_predicate(app->rator)) { && relevant_predicate(app->rator)) {
/* Looks like a predicate on a local variable. Record that the /* Looks like a predicate on a local variable. Record that the
predicate succeeded, which may allow conversion of safe predicate succeeded, which may allow conversion of safe
operations to unsafe operations. */ operations to unsafe operations. */
add_type(info, SCHEME_LOCAL_POS(app->rand), app->rator); 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)) { } else if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)t; Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)t;
if (SCHEME_FALSEP(b->fbranch)) { if (SCHEME_FALSEP(b->fbranch)) {
add_types(b->test, info, fuel-1); add_types_for_t_branch(b->test, info, fuel-1);
add_types(b->tbranch, 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_escapes, then_preserves_marks, then_single_result;
int then_vclock, then_kclock, then_sclock; int then_vclock, then_kclock, then_sclock;
Optimize_Info_Sequence info_seq; Optimize_Info_Sequence info_seq;
Scheme_Object *pred;
b = (Scheme_Branch_Rec *)o; b = (Scheme_Branch_Rec *)o;
@ -4101,19 +4205,21 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
break; break;
} }
if (expr_implies_predicate(t2, info, id_offset, 5)) { pred = 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) */ if (pred) {
/* all predicates recognize non-#f things */ /* (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); t2 = optimize_ignored(t2, info, id_offset, 1, 0, 5);
t = replace_tail_inside(t2, inside, t); t = replace_tail_inside(t2, inside, t);
t2 = scheme_true; t2 = test_val;
id_offset = 0; id_offset = 0;
if (scheme_omittable_expr(t, 1, 5, 0, info, NULL, 0, 0, ID_OMIT)) { if (scheme_omittable_expr(t, 1, 5, 0, info, NULL, 0, 0, ID_OMIT)) {
t = scheme_true; t = test_val;
inside = NULL; inside = NULL;
} else { } else {
t = make_sequence_2(t, scheme_true); t = make_sequence_2(t, test_val);
inside = t; inside = t;
} }
} }
@ -4152,7 +4258,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
init_sclock = info->sclock; init_sclock = info->sclock;
init_types = info->types; 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)); 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); 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)); fb = scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context));
if (info->escapes && then_escapes) { 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: case scheme_local_type:
{ {
Scheme_Object *val; Scheme_Object *val;
int pos, delta, is_mutated = 0; int pos, delta, is_mutated = 0, single_use;
info->size += 1; info->size += 1;
pos = SCHEME_LOCAL_POS(expr); 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 & OPT_CONTEXT_NO_SINGLE) ? 0 : 1,
context, NULL, &is_mutated); context, NULL, &is_mutated);
@ -7373,7 +7481,14 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
if (val) if (val)
return val; return val;
} else { } 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; info->size -= 1;
return scheme_optimize_expr(val, info, context); return scheme_optimize_expr(val, info, context);
} }
@ -7385,13 +7500,26 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
delta = optimize_info_get_shift(info, pos); delta = optimize_info_get_shift(info, pos);
if (context & OPT_CONTEXT_BOOLEAN) { if (!optimize_is_mutated(info, pos + delta)) {
Scheme_Object *pred; Scheme_Object *pred;
pred = optimize_get_predicate(pos + delta, info); pred = optimize_get_predicate(pos + delta, info);
if (pred) { if (pred) {
/* all predicates recognize non-#f things */ 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; 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) if (delta)
@ -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); 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) static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
{ {
int j, i; int j, i;

38
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_write_handler;
READ_ONLY static Scheme_Object *default_print_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_default_global_print_handler;
READ_ONLY Scheme_Object *scheme_write_proc; 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("string-port?", string_port_p, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("terminal-port?", scheme_terminal_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_NONCM_PRIM("port-closed?", port_closed_p, 1, 1, env);
GLOBAL_PRIM_W_ARITY("open-input-file", open_input_file, 1, 3, env); GLOBAL_NONCM_PRIM("open-input-file", open_input_file, 1, 3, env);
GLOBAL_PRIM_W_ARITY("open-input-bytes", open_input_byte_string, 1, 2, env); GLOBAL_NONCM_PRIM("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_NONCM_PRIM("open-input-string", open_input_char_string, 1, 2, env);
GLOBAL_PRIM_W_ARITY("open-output-file", open_output_file, 1, 3, env); GLOBAL_NONCM_PRIM("open-output-file", open_output_file, 1, 3, env);
GLOBAL_PRIM_W_ARITY("open-output-bytes", open_output_string, 0, 1, env); GLOBAL_NONCM_PRIM("open-output-bytes", open_output_string, 0, 1, env);
GLOBAL_PRIM_W_ARITY("open-output-string", open_output_string, 0, 1, env); GLOBAL_NONCM_PRIM("open-output-string", open_output_string, 0, 1, env);
GLOBAL_PRIM_W_ARITY("get-output-bytes", get_output_byte_string, 1, 4, env); GLOBAL_NONCM_PRIM("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_NONCM_PRIM("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_NONCM_PRIM("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_NONCM_PRIM("close-input-port", close_input_port, 1, 1, env);
GLOBAL_PRIM_W_ARITY("close-output-port", close_output_port, 1, 1, env); GLOBAL_NONCM_PRIM("close-output-port", close_output_port, 1, 1, env);
GLOBAL_PRIM_W_ARITY("make-input-port", make_input_port, 4, 10, env); GLOBAL_NONCM_PRIM("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("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-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); 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("load", load, 1, 1, 0, -1, env);
GLOBAL_PRIM_W_ARITY2("make-pipe", sch_pipe, 0, 3, 2, 2, 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_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_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); 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-count-lines!", port_count_lines, 1, 1, env);
GLOBAL_NONCM_PRIM("port-counts-lines?", port_counts_lines_p, 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); REGISTER_SO(scheme_eof_object_p_proc);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED 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_PRIM_IS_OMITABLE);
scheme_add_global_constant("eof-object?", p, env); 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("write", scheme_write_proc, env);
scheme_add_global_constant("display", scheme_display_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_p_proc;
extern Scheme_Object *scheme_procedure_arity_includes_proc; extern Scheme_Object *scheme_procedure_arity_includes_proc;
extern Scheme_Object *scheme_void_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_syntax_p_proc;
extern Scheme_Object *scheme_check_not_undefined_proc; extern Scheme_Object *scheme_check_not_undefined_proc;
extern Scheme_Object *scheme_check_assign_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_constant_key scheme_stack_dump_key
#define scheme_fixed_key scheme_default_prompt_tag #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 */ /* hash functions */
/*========================================================================*/ /*========================================================================*/
@ -648,6 +661,9 @@ extern void scheme_check_foreign_work(void);
XFORM_NONGCING extern void *scheme_extract_pointer(Scheme_Object *v); XFORM_NONGCING extern void *scheme_extract_pointer(Scheme_Object *v);
#endif #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); void scheme_kickoff_green_thread_time_slice_timer(intptr_t usec);
#ifdef UNIX_PROCESSES #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_input_port_handler(int argc, Scheme_Object *[]);
Scheme_Object *scheme_default_read_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; extern Scheme_Object *scheme_default_global_print_handler;
/* Type readers & writers for compiled code data */ /* Type readers & writers for compiled code data */