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

unsafe ops (v4.2.1.8)

Browse Source 
svn: r15899
This commit is contained in:
Matthew Flatt 2009-09-06 18:24:46 +00:00
parent d2ecc840a9
commit 8ae0ea9d14
34 changed files with 1954 additions and 620 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/compiler/decompile.ss
View File

@ -13,6 +13,7 @@
(let ([ns (make-base-empty-namespace)]) (let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(namespace-require ''#%kernel) (namespace-require ''#%kernel)
(namespace-require ''#%unsafe)
(for/list ([l (namespace-mapped-symbols)]) (for/list ([l (namespace-mapped-symbols)])
(cons l (with-handlers ([exn:fail? (lambda (x) #f)]) (cons l (with-handlers ([exn:fail? (lambda (x) #f)])
(compile l))))))] (compile l))))))]
@ -320,7 +321,7 @@
list list* vector vector-immutable box))] list list* vector vector-immutable box))]
[(3) (memq (car a) '(eq? = <= < >= > [(3) (memq (car a) '(eq? = <= < >= >
bitwise-bit-set? char=? bitwise-bit-set? char=?
+ - * / min max bitwise-and bitwise-ior + - * / quotient remainder min max bitwise-and bitwise-ior
arithmetic-shift vector-ref string-ref bytes-ref arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons set-mcar! set-mcdr! cons mcons
list list* vector vector-immutable))] list list* vector vector-immutable))]

5
collects/compiler/zo-parse.ss
View File

@ -113,9 +113,12 @@
(make-compilation-top ld prefix code)])) (make-compilation-top ld prefix code)]))
(define (read-resolve-prefix v) (define (read-resolve-prefix v)
(let-values ([(v unsafe?) (if (integer? (car v))
(values v #f)
(values (cdr v) #t))])
(match v (match v
[`(,i ,tv . ,sv) [`(,i ,tv . ,sv)
(make-prefix i (vector->list tv) (vector->list sv))])) (make-prefix i (vector->list tv) (vector->list sv))])))
(define (read-unclosed-procedure v) (define (read-unclosed-procedure v)
(define CLOS_HAS_REST 1) (define CLOS_HAS_REST 1)

62
collects/scheme/private/for.ss
View File

@ -4,6 +4,7 @@
"misc.ss" "misc.ss"
"define.ss" "define.ss"
"letstx-scheme.ss" "letstx-scheme.ss"
'#%unsafe
(for-syntax '#%kernel (for-syntax '#%kernel
"stx.ss" "stx.ss"
"qqstx.ss" "qqstx.ss"
@ -410,7 +411,7 @@
(define (:vector-gen v start stop step) (define (:vector-gen v start stop step)
(values (values
;; pos->element ;; pos->element
(lambda (i) (vector-ref v i)) (lambda (i) (unsafe-vector-ref v i))
;; next-pos ;; next-pos
;; Minor optimisation. I assume add1 is faster than \x.x+1 ;; Minor optimisation. I assume add1 is faster than \x.x+1
(if (= step 1) add1 (lambda (i) (+ i step))) (if (= step 1) add1 (lambda (i) (+ i step)))
@ -953,7 +954,11 @@
(lambda (stx) (lambda (stx)
(let loop ([stx stx]) (let loop ([stx stx])
(syntax-case stx () (syntax-case stx ()
[[(id) (_ a b step)] #`[(id) [[(id) (_ a b step)] (let ([all-fx?
(and (fixnum? (syntax-e #'a))
(fixnum? (syntax-e #'b))
(memq (syntax-e #'step) '(1 -1)))])
#`[(id)
(:do-in (:do-in
;; outer bindings: ;; outer bindings:
([(start) a] [(end) b] [(inc) step]) ([(start) a] [(end) b] [(inc) step])
@ -964,13 +969,21 @@
;; loop bindings: ;; loop bindings:
([pos start]) ([pos start])
;; pos check ;; pos check
#,(cond #,(if all-fx?
;; Special case, can use unsafe ops:
(cond
[((syntax-e #'step) . >= . 0)
#'(unsafe-fx< pos end)]
[else
#'(unsafe-fx> pos end)])
;; General case:
(cond
[(not (number? (syntax-e #'step))) [(not (number? (syntax-e #'step)))
#`(if (step . >= . 0) (< pos end) (> pos end))] #`(if (step . >= . 0) (< pos end) (> pos end))]
[((syntax-e #'step) . >= . 0) [((syntax-e #'step) . >= . 0)
#'(< pos end)] #'(< pos end)]
[else [else
#'(> pos end)]) #'(> pos end)]))
;; inner bindings ;; inner bindings
([(id) pos]) ([(id) pos])
;; pre guard ;; pre guard
@ -978,7 +991,7 @@
;; post guard ;; post guard
#t #t
;; loop args ;; loop args
((+ pos inc)))]] ((#,(if all-fx? #'unsafe-fx+ #'+) pos inc)))])]
[[(id) (_ a b)] (loop #'[(id) (_ a b 1)])] [[(id) (_ a b)] (loop #'[(id) (_ a b 1)])]
[[(id) (_ b)] (loop #'[(id) (_ 0 b 1)])] [[(id) (_ b)] (loop #'[(id) (_ 0 b 1)])]
[_ #f])))) [_ #f]))))
@ -1035,19 +1048,19 @@
#t #t
;; post guard ;; post guard
#t #t
;; loop args ;; loop args -- ok to use unsafe-cdr, since car passed
((cdr lst)))]] ((unsafe-cdr lst)))]]
[_ #f]))) [_ #f])))
(define-for-syntax (vector-like-gen vector?-id (define-for-syntax (vector-like-gen vector?-id
vector-length-id unsafe-vector-length-id
in-vector-id in-vector-id
vector-ref-id) unsafe-vector-ref-id)
(define (in-vector-like stx) (define (in-vector-like stx)
(with-syntax ([vector? vector?-id] (with-syntax ([vector? vector?-id]
[in-vector in-vector-id] [in-vector in-vector-id]
[vector-length vector-length-id] [unsafe-vector-length unsafe-vector-length-id]
[vector-ref vector-ref-id]) [unsafe-vector-ref unsafe-vector-ref-id])
(syntax-case stx () (syntax-case stx ()
;; Fast case ;; Fast case
[((id) (_ vec-expr)) [((id) (_ vec-expr))
@ -1057,27 +1070,28 @@
([(vec len) (let ([vec vec-expr]) ([(vec len) (let ([vec vec-expr])
(unless (vector? vec) (unless (vector? vec)
(in-vector vec)) (in-vector vec))
(values vec (vector-length vec)))]) (values vec (unsafe-vector-length vec)))])
;; outer check ;; outer check
#f #f
;; loop bindings ;; loop bindings
([pos 0]) ([pos 0])
;; pos check ;; pos check
(pos . < . len) (pos . unsafe-fx< . len)
;; inner bindings ;; inner bindings
([(id) (vector-ref vec pos)]) ([(id) (unsafe-vector-ref vec pos)])
;; pre guard ;; pre guard
#t #t
;; post guard ;; post guard
#t #t
;; loop args ;; loop args
((add1 pos)))]] ((unsafe-fx+ 1 pos)))]]
;; General case ;; General case
[((id) (_ vec-expr start)) [((id) (_ vec-expr start))
(in-vector-like (syntax ((id) (_ vec-expr start #f 1))))] (in-vector-like (syntax ((id) (_ vec-expr start #f 1))))]
[((id) (_ vec-expr start stop)) [((id) (_ vec-expr start stop))
(in-vector-like (syntax ((id) (_ vec-expr start stop 1))))] (in-vector-like (syntax ((id) (_ vec-expr start stop 1))))]
[((id) (_ vec-expr start stop step)) [((id) (_ vec-expr start stop step))
(let ([all-fx? (memq (syntax-e #'step) '(1 -1))])
#`[(id) #`[(id)
(:do-in (:do-in
;; Outer bindings ;; Outer bindings
@ -1085,7 +1099,7 @@
([(v* stop*) (let ([vec vec-expr] ([(v* stop*) (let ([vec vec-expr]
[stop* stop]) [stop* stop])
(if (and (not stop*) (vector? vec)) (if (and (not stop*) (vector? vec))
(values vec (vector-length vec)) (values vec (unsafe-vector-length vec))
(values vec stop*)))] (values vec stop*)))]
[(start*) start] [(start*) start]
[(step*) step]) [(step*) step])
@ -1106,26 +1120,30 @@
[(not (number? (syntax-e #'step))) [(not (number? (syntax-e #'step)))
#`(if (step* . >= . 0) (< idx stop*) (> idx stop*))] #`(if (step* . >= . 0) (< idx stop*) (> idx stop*))]
[((syntax-e #'step) . >= . 0) [((syntax-e #'step) . >= . 0)
#'(< idx stop*)] (if all-fx?
#'(unsafe-fx< idx stop*)
#'(< idx stop*))]
[else [else
#'(> idx stop*)]) (if all-fx?
#'(unsafe-fx> idx stop*)
#'(> idx stop*))])
;; Inner bindings ;; Inner bindings
([(id) (vector-ref v* idx)]) ([(id) (unsafe-vector-ref v* idx)])
;; Pre guard ;; Pre guard
#t #t
;; Post guard ;; Post guard
#t #t
;; Loop args ;; Loop args
((+ idx step)))]] ((#,(if all-fx? #'unsafe-fx+ #'+) idx step)))])]
[_ #f]))) [_ #f])))
in-vector-like) in-vector-like)
(define-sequence-syntax *in-vector (define-sequence-syntax *in-vector
(lambda () #'in-vector) (lambda () #'in-vector)
(vector-like-gen #'vector? (vector-like-gen #'vector?
#'vector-length #'unsafe-vector-length
#'in-vector #'in-vector
#'vector-ref)) #'unsafe-vector-ref))
(define-sequence-syntax *in-string (define-sequence-syntax *in-string
(lambda () #'in-string) (lambda () #'in-string)

5
collects/scheme/unsafe/ops.ss Normal file
View File

@ -0,0 +1,5 @@
#lang scheme/base
(require '#%unsafe)
(provide (all-from-out '#%unsafe))

4
collects/scribblings/mzc/decompile.scrbl
View File

@ -76,7 +76,9 @@ Many forms in the decompiled code, such as @scheme[module],
@schemeidfont{#%in}, which indicates that the JIT compiler will @schemeidfont{#%in}, which indicates that the JIT compiler will
inline the operation. (Inlining information is not part of the inline the operation. (Inlining information is not part of the
bytecode, but is instead based on an enumeration of primitives that bytecode, but is instead based on an enumeration of primitives that
the JIT is known to handle specially.)} the JIT is known to handle specially.) Operations from
@schememodname[scheme/unsafe/ops] are always inlined, so
@schemeidfont{#%in} is not shown for them.}
@item{A form @scheme[(#%apply-values _proc _expr)] is equivalent to @item{A form @scheme[(#%apply-values _proc _expr)] is equivalent to
@scheme[(call-with-values (lambda () _expr) _proc)], but the run-time @scheme[(call-with-values (lambda () _expr) _proc)], but the run-time

1
collects/scribblings/reference/reference.scrbl
View File

@ -70,6 +70,7 @@ languages.}
@include-section["security.scrbl"] @include-section["security.scrbl"]
@include-section["os.scrbl"] @include-section["os.scrbl"]
@include-section["memory.scrbl"] @include-section["memory.scrbl"]
@include-section["unsafe.scrbl"]
@include-section["running.scrbl"] @include-section["running.scrbl"]
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------

144
collects/scribblings/reference/unsafe.scrbl Normal file
View File

@ -0,0 +1,144 @@
#lang scribble/doc
@(require "mz.ss"
(for-label scheme/unsafe/ops))
@title[#:tag "unsafe"]{Unsafe Operations}
@defmodule[scheme/unsafe/ops]
All fuctions and forms provided by @schememodname[scheme/base] and
@schememodname[scheme] check their arguments to ensure that the
arguments conform to contracts and other constraints. For example,
@scheme[vector-ref] checks its arguments to ensure that the first
argument is a vector, that the second argument is an exact integer,
and that the second argument is between @scheme[0] and one less than
the vector's length, inclusive.
Functions provided by @schememodname[scheme/unsafe/ops] are
@deftech{unsafe}. They have certain constraints, but the constraints
are not checked, which allows the system to generate and execute
faster code. If arguments violate an unsafe function's constraints,
the function's behavior and result is unpredictable, and the entire
system can crash or become corrupted.
All of the exported bindings of @schememodname[scheme] are protected
in the sense of @scheme[protect-out], so access to unsafe operations
can be prevented by adjusting the code inspector (see
@secref["modprotect"]).
@section{Unsafe Numeric Operations}
@deftogether[(
@defproc[(unsafe-fx+ [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fx- [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fx* [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxquotient [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxremainder [a fixnum?][b fixnum?]) fixnum?]
)]{
For @tech{fixnums}: Like @scheme[+], @scheme[-], @scheme[*],
@scheme[quotient], and @scheme[remainder], but constrained to consume
@tech{fixnums} and produce a @tech{fixnum} result. The mathematical
operation on @scheme[a] and @scheme[b] must be representable as a
@tech{fixnum}. In the case of @scheme[unsafe-fxquotient] and
@scheme[unsafe-fxremainder], @scheme[b] must not be @scheme[0].}
@deftogether[(
@defproc[(unsafe-fxand [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxior [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxxor [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxnot [a fixnum?]) fixnum?]
@defproc[(unsafe-fxlshift [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxrshift [a fixnum?][b fixnum?]) fixnum?]
)]{
For @tech{fixnums}: Like @scheme[bitwise-and], @scheme[bitwise-ior],
@scheme[bitwise-xor], @scheme[bitwise-not], and
@scheme[arithmetic-shift], but constrained to consume @tech{fixnums};
the result is always a @tech{fixnum}. The @scheme[unsafe-fxlshift] and
@scheme[unsafe-fxrshift] operations correspond to
@scheme[arithmetic-shift], but require non-negative arguments;
@scheme[unsafe-fxlshift] is a positive (i.e., left) shift, and
@scheme[unsafe-fxrshift] is a negative (i.e., right) shift, where the
number of bits to shift must be less than the number of bits used to
represent a @tech{fixnum}, and the result is effectively
@scheme[bitwise-and]ed with the most negative @tech{fixnum}.}
@deftogether[(
@defproc[(unsafe-fx= [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fx< [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fx> [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fx<= [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fx>= [a fixnum?][b fixnum?]) boolean?]
)]{
For @tech{fixnums}: Like @scheme[=], @scheme[<], @scheme[>],
@scheme[<=], and @scheme[>=], but constrained to consume
@tech{fixnums}.}
@deftogether[(
@defproc[(unsafe-fl+ [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(unsafe-fl- [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(unsafe-fl* [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(unsafe-fl/ [a inexact-real?][b inexact-real?]) inexact-real?]
)]{
For real @tech{inexact numbers}: Like @scheme[+], @scheme[-],
@scheme[*], and @scheme[/], but constrained to consume real @tech{inexact
numbers}. The result is always a real @tech{inexact number}.}
@deftogether[(
@defproc[(unsafe-fl= [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-fl< [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-fl> [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-fl<= [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-fl>= [a inexact-real?][b inexact-real?]) boolean?]
)]{
For real @tech{inexact numbers}: Like @scheme[=], @scheme[<],
@scheme[>], @scheme[<=], and @scheme[>=], but constrained to consume
real @tech{inexact numbers}.}
@section{Unsafe Data Extraction}
@deftogether[(
@defproc[(unsafe-car [p pair?]) any/c]
@defproc[(unsafe-cdr [p pair?]) any/c]
@defproc[(unsafe-mcar [p mpair?]) any/c]
@defproc[(unsafe-mcdr [p mpair?]) any/c]
@defproc[(unsafe-set-mcar! [p mpair?] [v any/c]) void?]
@defproc[(unsafe-set-mcdr! [p mpair?] [v any/c]) void?]
)]{
Unsafe variants of @scheme[car], @scheme[cdr], @scheme[mcar],
@scheme[mcdr], @scheme[set-mcar!], and @scheme[set-mcdr!].}
@deftogether[(
@defproc[(unsafe-vector-length [v vector?]) fixnum?]
@defproc[(unsafe-vector-ref [v vector?][k fixnum?]) any/c]
@defproc[(unsafe-vector-set! [v vector?][k fixnum?][val any/c]) any/c]
)]{
Unsafe versions of @scheme[vector-length], @scheme[vector-ref], and
@scheme[vector-set!]. A vector's size can never be larger than a
@tech{fixnum} (so even @scheme[vector-length] always returns a
fixnum).}
@deftogether[(
@defproc[(unsafe-struct-ref [v any/c][k fixnum?]) any/c]
@defproc[(unsafe-struct-set! [v any/c][k fixnum?][val any/c]) any/c]
)]{
Unsafe field access and update for an instance of a structure
type. The index @scheme[k] must be between @scheme[0] (inclusive) and
the number of fields in the struture (exclusive). In the case of
@scheme[unsafe-struct-set!], the field must be mutable.}

1
collects/tests/mzscheme/mz-tests.ss
View File

@ -11,6 +11,7 @@
(load-relative "stx.ss") (load-relative "stx.ss")
(load-relative "module.ss") (load-relative "module.ss")
(load-relative "number.ss") (load-relative "number.ss")
(load-relative "unsafe.ss")
(load-relative "object.ss") (load-relative "object.ss")
(load-relative "struct.ss") (load-relative "struct.ss")
(load-relative "unit.ss") (load-relative "unit.ss")

18
collects/tests/mzscheme/optimize.ss
View File

@ -63,7 +63,7 @@
(check-error-message op (eval `(lambda (x) (,op x ,arg2)))) (check-error-message op (eval `(lambda (x) (,op x ,arg2))))
(check-error-message op (eval `(lambda (x) (,op ,arg1 x)))) (check-error-message op (eval `(lambda (x) (,op ,arg1 x))))
(bin0 v op arg1 arg2))] (bin0 v op arg1 arg2))]
[bin (lambda (v op arg1 arg2) [bin-int (lambda (v op arg1 arg2)
(bin-exact v op arg1 arg2) (bin-exact v op arg1 arg2)
(let* ([iv (if (number? v) (let* ([iv (if (number? v)
(exact->inexact v) (exact->inexact v)
@ -73,7 +73,9 @@
iv)]) iv)])
(bin0 iv op (exact->inexact arg1) arg2) (bin0 iv op (exact->inexact arg1) arg2)
(bin0 iv0 op arg1 (exact->inexact arg2)) (bin0 iv0 op arg1 (exact->inexact arg2))
(bin0 iv op (exact->inexact arg1) (exact->inexact arg2))) (bin0 iv op (exact->inexact arg1) (exact->inexact arg2))))]
[bin (lambda (v op arg1 arg2)
(bin-int v op arg1 arg2)
(let ([iv (if (number? v) (let ([iv (if (number? v)
(if (eq? op '*) (if (eq? op '*)
(/ v (* 33333 33333)) (/ v (* 33333 33333))
@ -266,6 +268,18 @@
(bin -4 '/ 16 -4) (bin -4 '/ 16 -4)
(bin 4 '/ -16 -4) (bin 4 '/ -16 -4)
(bin-int 3 'quotient 10 3)
(bin-int -3 'quotient 10 -3)
(bin-int 3 'quotient -10 -3)
(bin-int -3 'quotient -10 3)
(bin-exact 7 'quotient (* 7 (expt 2 100)) (expt 2 100))
(bin-int 1 'remainder 10 3)
(bin-int 1 'remainder 10 -3)
(bin-int -1 'remainder -10 -3)
(bin-int -1 'remainder -10 3)
(bin-exact 7 'remainder (+ 7 (expt 2 100)) (expt 2 100))
(bin 3 'min 3 300) (bin 3 'min 3 300)
(bin -300 'min 3 -300) (bin -300 'min 3 -300)
(bin -400 'min -400 -300) (bin -400 'min -400 -300)

156
collects/tests/mzscheme/unsafe.ss Normal file
View File

@ -0,0 +1,156 @@
(load-relative "loadtest.ss")
(Section 'unsafe)
(require '#%unsafe)
(let ()
(define (test-tri result proc x y z
#:pre [pre void]
#:post [post (lambda (x) x)]
#:literal-ok? [lit-ok? #t])
(pre)
(test result (compose post (eval proc)) x y z)
(pre)
(test result (compose post (eval `(lambda (x y z) (,proc x y z)))) x y z)
(when lit-ok?
(pre)
(test result (compose post (eval `(lambda (y z) (,proc ,x y z)))) y z))
(pre)
(test result (compose post (eval `(lambda (x z) (,proc x ,y z)))) x z)
(pre)
(test result (compose post (eval `(lambda (x y) (,proc x y ,z)))) x y)
(pre)
(test result (compose post (eval `(lambda (x) (,proc x ,y ,z)))) x)
(when lit-ok?
(pre)
(test result (compose post (eval `(lambda (y) (,proc ,x y ,z)))) y)
(pre)
(test result (compose post (eval `(lambda (z) (,proc ,x ,y z)))) z)))
(define (test-bin result proc x y
#:pre [pre void]
#:post [post (lambda (x) x)]
#:literal-ok? [lit-ok? #t])
(pre)
(test result (compose post (eval proc)) x y)
(pre)
(test result (compose post (eval `(lambda (x y) (,proc x y)))) x y)
(when lit-ok?
(pre)
(test result (compose post (eval `(lambda (y) (,proc ,x y)))) y))
(pre)
(test result (compose post (eval `(lambda (x) (,proc x ,y)))) x))
(define (test-un result proc x)
(test result (eval proc) x)
(test result (eval `(lambda (x) (,proc x))) x))
(test-bin 3 'unsafe-fx+ 1 2)
(test-bin -1 'unsafe-fx+ 1 -2)
(test-bin 8 'unsafe-fx- 10 2)
(test-bin 3 'unsafe-fx- 1 -2)
(test-bin 20 'unsafe-fx* 10 2)
(test-bin -20 'unsafe-fx* 10 -2)
(test-bin 3 'unsafe-fxquotient 17 5)
(test-bin -3 'unsafe-fxquotient 17 -5)
(test-bin 2 'unsafe-fxremainder 17 5)
(test-bin 2 'unsafe-fxremainder 17 -5)
(test-bin 3.4 'unsafe-fl+ 1.4 2.0)
(test-bin -1.1 'unsafe-fl+ 1.0 -2.1)
(test-bin +inf.0 'unsafe-fl+ 1.0 +inf.0)
(test-bin -inf.0 'unsafe-fl+ 1.0 -inf.0)
(test-bin +nan.0 'unsafe-fl+ +nan.0 -inf.0)
(test-bin #f unsafe-fx= 1 2)
(test-bin #t unsafe-fx= 2 2)
(test-bin #f unsafe-fx= 2 1)
(test-bin #t unsafe-fx< 1 2)
(test-bin #f unsafe-fx< 2 2)
(test-bin #f unsafe-fx< 2 1)
(test-bin #f unsafe-fx> 1 2)
(test-bin #f unsafe-fx> 2 2)
(test-bin #t unsafe-fx> 2 1)
(test-bin #t unsafe-fx<= 1 2)
(test-bin #t unsafe-fx<= 2 2)
(test-bin #f unsafe-fx<= 2 1)
(test-bin #f unsafe-fx>= 1 2)
(test-bin #t unsafe-fx>= 2 2)
(test-bin #t unsafe-fx>= 2 1)
(test-bin 7.9 'unsafe-fl- 10.0 2.1)
(test-bin 3.7 'unsafe-fl- 1.0 -2.7)
(test-bin 20.02 'unsafe-fl* 10.01 2.0)
(test-bin -20.02 'unsafe-fl* 10.01 -2.0)
(test-bin (exact->inexact 17/5) 'unsafe-fl/ 17.0 5.0)
(test-bin +inf.0 'unsafe-fl/ 17.0 0.0)
(test-bin -inf.0 'unsafe-fl/ -17.0 0.0)
(test-bin 3 'unsafe-fxand 7 3)
(test-bin 2 'unsafe-fxand 6 3)
(test-bin 3 'unsafe-fxand -1 3)
(test-bin 7 'unsafe-fxior 7 3)
(test-bin 7 'unsafe-fxior 6 3)
(test-bin -1 'unsafe-fxior -1 3)
(test-bin 4 'unsafe-fxxor 7 3)
(test-bin 5 'unsafe-fxxor 6 3)
(test-bin -4 'unsafe-fxxor -1 3)
(test-un -1 'unsafe-fxnot 0)
(test-un -4 'unsafe-fxnot 3)
(test-bin 32 'unsafe-fxlshift 2 4)
(test-bin 32 'unsafe-fxlshift 8 2)
(test-bin 8 'unsafe-fxlshift 8 0)
(test-bin 2 'unsafe-fxrshift 32 4)
(test-bin 8 'unsafe-fxrshift 32 2)
(test-bin 8 'unsafe-fxrshift 8 0)
(test-un 5 'unsafe-car (cons 5 9))
(test-un 9 'unsafe-cdr (cons 5 9))
(test-un 15 'unsafe-mcar (mcons 15 19))
(test-un 19 'unsafe-mcdr (mcons 15 19))
(let ([v (mcons 3 7)])
(test-bin 8 'unsafe-set-mcar! v 8
#:pre (lambda () (set-mcar! v 0))
#:post (lambda (x) (mcar v))
#:literal-ok? #f)
(test-bin 9 'unsafe-set-mcdr! v 9
#:pre (lambda () (set-mcdr! v 0))
#:post (lambda (x) (mcdr v))
#:literal-ok? #f))
(test-bin 5 'unsafe-vector-ref #(1 5 7) 1)
(test-un 3 'unsafe-vector-length #(1 5 7))
(let ([v (vector 0 3 7)])
(test-tri 5 'unsafe-vector-set! v 2 5
#:pre (lambda () (vector-set! v 2 0))
#:post (lambda (x) (vector-ref v 2))
#:literal-ok? #f))
(let ()
(define-struct posn (x [y #:mutable] z))
(test-bin 'a unsafe-struct-ref (make-posn 'a 'b 'c) 0 #:literal-ok? #f)
(test-bin 'b unsafe-struct-ref (make-posn 'a 'b 'c) 1 #:literal-ok? #f)
(let ([p (make-posn 100 200 300)])
(test-tri 500 'unsafe-struct-set! p 1 500
#:pre (lambda () (set-posn-y! p 0))
#:post (lambda (x) (posn-y p))
#:literal-ok? #f)))
(void))
(report-errs)

19
collects/typed-scheme/utils/syntax-traversal.ss
View File

@ -14,7 +14,7 @@
stx stx
(loop (list-ref (syntax->list stx) (car locs)) (cdr locs))))) (loop (list-ref (syntax->list stx) (car locs)) (cdr locs)))))
(define (syntax-loc stx) (list (syntax-position stx) (syntax-span stx))) (define (syntax-loc stx) (list (syntax-source stx) (syntax-position stx) (syntax-span stx)))
;; -------------------- the real stuff ;; -------------------- the real stuff
@ -35,16 +35,23 @@
(and (pair? stx) (and (pair? stx)
(or (loop (car stx)) (loop (cdr stx))))))))) (or (loop (car stx)) (loop (cdr stx)))))))))
(define (unwind p)
(if (syntax? p)
(vector (vector (syntax-source p) (syntax-line p)) (unwind (syntax-e p)))
(if (pair? p)
(cons (unwind (car p)) (unwind (cdr p)))
p)))
;; Look for (the outermost) syntax in `orig' that has the same ;; Look for (the outermost) syntax in `orig' that has the same
;; location as `lookfor' which is coming from the expanded `orig', ;; location as `lookfor' which is coming from the expanded `orig',
;; given in `expanded'. ;; given in `expanded'.
(define (look-for-in-orig orig expanded lookfor) (define (look-for-in-orig orig expanded lookfor) lookfor)
#|
(define src (syntax-source orig)) (define src (syntax-source orig))
;(printf "orig : ~a~n" orig) ;(printf "orig : ~a~n" (unwind orig))
;(printf "expanded : ~a~n" expanded) ;(printf "expanded : ~a~n" expanded)
;(printf "lookfor : ~a~n" lookfor) ;(printf "lookfor : ~a~n" (unwind lookfor))
;(printf "src : ~a~n" src) ;(printf "src : ~a~n" src)
(let ([enclosing (enclosing-syntaxes-with-source expanded lookfor src)] (let ([enclosing (enclosing-syntaxes-with-source expanded lookfor src)]
[syntax-locs (make-hash)]) [syntax-locs (make-hash)])
@ -67,4 +74,6 @@
#;(printf "chose branch two ~a~n" enclosing)))))) #;(printf "chose branch two ~a~n" enclosing))))))
;(trace look-for-in-orig) ;(trace look-for-in-orig)
|#

3
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 4.2.1.8
Added scheme/unsafe/ops
Version 4.2.1.7 Version 4.2.1.7
Inside: embedding applications should call scheme_seal_parameters Inside: embedding applications should call scheme_seal_parameters
after initializing parameter values (currently used by Planet) after initializing parameter values (currently used by Planet)

76
src/mzscheme/src/cstartup.inc
View File

@ -1,42 +1,42 @@
{ {
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,55,50,0,0,0,1,0,0,3,0,12,0, static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,56,50,0,0,0,1,0,0,3,0,12,0,
19,0,32,0,36,0,41,0,44,0,49,0,56,0,63,0,67,0,72,0,78, 19,0,23,0,28,0,31,0,36,0,49,0,56,0,63,0,67,0,72,0,78,
0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
177,0,179,0,193,0,1,1,27,1,35,1,43,1,53,1,89,1,122,1,155, 177,0,179,0,193,0,1,1,27,1,35,1,43,1,53,1,89,1,122,1,155,
1,214,1,24,2,102,2,168,2,173,2,193,2,84,3,104,3,155,3,221,3, 1,214,1,24,2,102,2,168,2,173,2,193,2,84,3,104,3,155,3,221,3,
106,4,248,4,44,5,67,5,146,5,0,0,93,7,0,0,29,11,11,68,104, 106,4,248,4,44,5,67,5,146,5,0,0,93,7,0,0,29,11,11,68,104,
101,114,101,45,115,116,120,66,100,101,102,105,110,101,72,112,97,114,97,109,101, 101,114,101,45,115,116,120,66,100,101,102,105,110,101,63,97,110,100,64,108,101,
116,101,114,105,122,101,63,97,110,100,64,108,101,116,42,62,111,114,64,99,111, 116,42,62,111,114,64,99,111,110,100,72,112,97,114,97,109,101,116,101,114,105,
110,100,66,108,101,116,114,101,99,66,117,110,108,101,115,115,63,108,101,116,64, 122,101,66,108,101,116,114,101,99,66,117,110,108,101,115,115,63,108,101,116,64,
119,104,101,110,65,113,117,111,116,101,29,94,2,13,68,35,37,107,101,114,110, 119,104,101,110,65,113,117,111,116,101,29,94,2,13,68,35,37,107,101,114,110,
101,108,11,29,94,2,13,68,35,37,112,97,114,97,109,122,11,62,105,102,65, 101,108,11,29,94,2,13,68,35,37,112,97,114,97,109,122,11,62,105,102,65,
98,101,103,105,110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101, 98,101,103,105,110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101,
115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109, 115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109,
98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97, 45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97,
35,11,8,170,244,95,159,2,15,35,35,159,2,14,35,35,159,2,14,35,35, 35,11,8,162,246,95,159,2,15,35,35,159,2,14,35,35,159,2,14,35,35,
16,20,2,3,2,1,2,4,2,1,2,7,2,1,2,5,2,1,2,6,2, 16,20,2,3,2,1,2,6,2,1,2,4,2,1,2,5,2,1,2,9,2,
1,2,9,2,1,2,8,2,1,2,10,2,1,2,11,2,1,2,12,2,1, 1,2,7,2,1,2,8,2,1,2,10,2,1,2,11,2,1,2,12,2,1,
97,36,11,8,170,244,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2, 97,36,11,8,162,246,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2,
2,2,1,2,2,96,11,11,8,170,244,16,0,96,37,11,8,170,244,16,0, 2,2,1,2,2,96,11,11,8,162,246,16,0,96,37,11,8,162,246,16,0,
13,16,4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31, 13,16,4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31,
8,30,8,29,8,28,8,27,93,8,224,49,61,0,0,95,9,8,224,49,61, 8,30,8,29,8,28,8,27,93,8,224,169,61,0,0,95,9,8,224,169,61,
0,0,2,1,27,248,22,137,4,195,249,22,130,4,80,158,38,35,251,22,77, 0,0,2,1,27,248,22,137,4,195,249,22,130,4,80,158,38,35,251,22,77,
2,16,248,22,92,199,12,249,22,67,2,17,248,22,94,201,27,248,22,137,4, 2,16,248,22,92,199,12,249,22,67,2,17,248,22,94,201,27,248,22,137,4,
195,249,22,130,4,80,158,38,35,251,22,77,2,16,248,22,92,199,249,22,67, 195,249,22,130,4,80,158,38,35,251,22,77,2,16,248,22,92,199,249,22,67,
2,17,248,22,94,201,12,27,248,22,69,248,22,137,4,196,28,248,22,75,193, 2,17,248,22,94,201,12,27,248,22,69,248,22,137,4,196,28,248,22,75,193,
20,15,159,36,35,36,28,248,22,75,248,22,69,194,248,22,68,193,249,22,130, 20,15,159,36,35,36,28,248,22,75,248,22,69,194,248,22,68,193,249,22,130,
4,80,158,38,35,251,22,77,2,16,248,22,68,199,249,22,67,2,5,248,22, 4,80,158,38,35,251,22,77,2,16,248,22,68,199,249,22,67,2,4,248,22,
69,201,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11, 69,201,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,
11,2,18,3,1,8,101,110,118,49,48,51,50,48,16,4,11,11,2,19,3, 11,2,18,3,1,8,101,110,118,49,48,52,49,54,16,4,11,11,2,19,3,
1,8,101,110,118,49,48,51,50,49,93,8,224,50,61,0,0,95,9,8,224, 1,8,101,110,118,49,48,52,49,55,93,8,224,170,61,0,0,95,9,8,224,
50,61,0,0,2,1,27,248,22,69,248,22,137,4,196,28,248,22,75,193,20, 170,61,0,0,2,1,27,248,22,69,248,22,137,4,196,28,248,22,75,193,20,
15,159,36,35,36,28,248,22,75,248,22,69,194,248,22,68,193,249,22,130,4, 15,159,36,35,36,28,248,22,75,248,22,69,194,248,22,68,193,249,22,130,4,
80,158,38,35,250,22,77,2,20,248,22,77,249,22,77,248,22,77,2,21,248, 80,158,38,35,250,22,77,2,20,248,22,77,249,22,77,248,22,77,2,21,248,
22,68,201,251,22,77,2,16,2,21,2,21,249,22,67,2,7,248,22,69,204, 22,68,201,251,22,77,2,16,2,21,2,21,249,22,67,2,6,248,22,69,204,
18,16,2,101,11,8,31,8,30,8,29,8,28,8,27,16,4,11,11,2,18, 18,16,2,101,11,8,31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,
3,1,8,101,110,118,49,48,51,50,51,16,4,11,11,2,19,3,1,8,101, 3,1,8,101,110,118,49,48,52,49,57,16,4,11,11,2,19,3,1,8,101,
110,118,49,48,51,50,52,93,8,224,51,61,0,0,95,9,8,224,51,61,0, 110,118,49,48,52,50,48,93,8,224,171,61,0,0,95,9,8,224,171,61,0,
0,2,1,248,22,137,4,193,27,248,22,137,4,194,249,22,67,248,22,77,248, 0,2,1,248,22,137,4,193,27,248,22,137,4,194,249,22,67,248,22,77,248,
22,68,196,248,22,69,195,27,248,22,69,248,22,137,4,23,197,1,249,22,130, 22,68,196,248,22,69,195,27,248,22,69,248,22,137,4,23,197,1,249,22,130,
4,80,158,38,35,28,248,22,53,248,22,131,4,248,22,68,23,198,2,27,249, 4,80,158,38,35,28,248,22,53,248,22,131,4,248,22,68,23,198,2,27,249,
@ -51,7 +51,7 @@
222,33,42,248,22,137,4,248,22,68,201,248,22,69,198,27,248,22,69,248,22, 222,33,42,248,22,137,4,248,22,68,201,248,22,69,198,27,248,22,69,248,22,
137,4,196,27,248,22,137,4,248,22,68,195,249,22,130,4,80,158,39,35,28, 137,4,196,27,248,22,137,4,248,22,68,195,249,22,130,4,80,158,39,35,28,
248,22,75,195,250,22,78,2,20,9,248,22,69,199,250,22,77,2,11,248,22, 248,22,75,195,250,22,78,2,20,9,248,22,69,199,250,22,77,2,11,248,22,
77,248,22,68,199,250,22,78,2,6,248,22,69,201,248,22,69,202,27,248,22, 77,248,22,68,199,250,22,78,2,5,248,22,69,201,248,22,69,202,27,248,22,
69,248,22,137,4,23,197,1,27,249,22,1,22,81,249,22,2,22,137,4,248, 69,248,22,137,4,23,197,1,27,249,22,1,22,81,249,22,2,22,137,4,248,
22,137,4,248,22,68,199,249,22,130,4,80,158,39,35,251,22,77,1,22,119, 22,137,4,248,22,68,199,249,22,130,4,80,158,39,35,251,22,77,1,22,119,
105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107, 105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,
@ -62,13 +62,13 @@
28,248,22,75,193,20,15,159,36,35,36,249,22,130,4,80,158,38,35,27,248, 28,248,22,75,193,20,15,159,36,35,36,249,22,130,4,80,158,38,35,27,248,
22,137,4,248,22,68,197,28,249,22,167,8,62,61,62,248,22,131,4,248,22, 22,137,4,248,22,68,197,28,249,22,167,8,62,61,62,248,22,131,4,248,22,
92,196,250,22,77,2,20,248,22,77,249,22,77,21,93,2,25,248,22,68,199, 92,196,250,22,77,2,20,248,22,77,249,22,77,21,93,2,25,248,22,68,199,
250,22,78,2,8,249,22,77,2,25,249,22,77,248,22,101,203,2,25,248,22, 250,22,78,2,7,249,22,77,2,25,249,22,77,248,22,101,203,2,25,248,22,
69,202,251,22,77,2,16,28,249,22,167,8,248,22,131,4,248,22,68,200,64, 69,202,251,22,77,2,16,28,249,22,167,8,248,22,131,4,248,22,68,200,64,
101,108,115,101,10,248,22,68,197,250,22,78,2,20,9,248,22,69,200,249,22, 101,108,115,101,10,248,22,68,197,250,22,78,2,20,9,248,22,69,200,249,22,
67,2,8,248,22,69,202,100,8,31,8,30,8,29,8,28,8,27,16,4,11, 67,2,7,248,22,69,202,100,8,31,8,30,8,29,8,28,8,27,16,4,11,
11,2,18,3,1,8,101,110,118,49,48,51,52,54,16,4,11,11,2,19,3, 11,2,18,3,1,8,101,110,118,49,48,52,52,50,16,4,11,11,2,19,3,
1,8,101,110,118,49,48,51,52,55,93,8,224,52,61,0,0,18,16,2,158, 1,8,101,110,118,49,48,52,52,51,93,8,224,172,61,0,0,18,16,2,158,
94,10,64,118,111,105,100,8,47,95,9,8,224,52,61,0,0,2,1,27,248, 94,10,64,118,111,105,100,8,47,95,9,8,224,172,61,0,0,2,1,27,248,
22,69,248,22,137,4,196,249,22,130,4,80,158,38,35,28,248,22,53,248,22, 22,69,248,22,137,4,196,249,22,130,4,80,158,38,35,28,248,22,53,248,22,
131,4,248,22,68,197,250,22,77,2,26,248,22,77,248,22,68,199,248,22,92, 131,4,248,22,68,197,250,22,77,2,26,248,22,77,248,22,68,199,248,22,92,
198,27,248,22,131,4,248,22,68,197,250,22,77,2,26,248,22,77,248,22,68, 198,27,248,22,131,4,248,22,68,197,250,22,77,2,26,248,22,77,248,22,68,
@ -83,22 +83,22 @@
159,35,35,35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,2,10,89, 159,35,35,35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,2,10,89,
162,8,44,36,52,9,223,0,33,33,35,20,103,159,35,16,1,2,2,16,0, 162,8,44,36,52,9,223,0,33,33,35,20,103,159,35,16,1,2,2,16,0,
11,16,5,2,12,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35, 11,16,5,2,12,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35,
16,1,2,2,16,0,11,16,5,2,5,89,162,8,44,36,52,9,223,0,33, 16,1,2,2,16,0,11,16,5,2,4,89,162,8,44,36,52,9,223,0,33,
35,35,20,103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,7,89,162, 35,35,20,103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,6,89,162,
8,44,36,55,9,223,0,33,37,35,20,103,159,35,16,1,2,2,16,1,33, 8,44,36,55,9,223,0,33,37,35,20,103,159,35,16,1,2,2,16,1,33,
38,11,16,5,2,11,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159, 38,11,16,5,2,11,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159,
35,16,1,2,2,16,0,11,16,5,2,9,89,162,8,44,36,52,9,223,0, 35,16,1,2,2,16,0,11,16,5,2,9,89,162,8,44,36,52,9,223,0,
33,43,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,6,89,162,8, 33,43,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,5,89,162,8,
44,36,53,9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16, 44,36,53,9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16,
5,2,4,89,162,8,44,36,54,9,223,0,33,45,35,20,103,159,35,16,1, 5,2,8,89,162,8,44,36,54,9,223,0,33,45,35,20,103,159,35,16,1,
2,2,16,0,11,16,5,2,8,89,162,8,44,36,57,9,223,0,33,46,35, 2,2,16,0,11,16,5,2,7,89,162,8,44,36,57,9,223,0,33,46,35,
20,103,159,35,16,1,2,2,16,1,33,48,11,16,5,2,3,89,162,8,44, 20,103,159,35,16,1,2,2,16,1,33,48,11,16,5,2,3,89,162,8,44,
36,53,9,223,0,33,49,35,20,103,159,35,16,1,2,2,16,0,11,16,0, 36,53,9,223,0,33,49,35,20,103,159,35,16,1,2,2,16,0,11,16,0,
94,2,14,2,15,93,2,14,9,9,35,0}; 94,2,14,2,15,93,2,14,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 2006); EVAL_ONE_SIZED_STR((char *)expr, 2006);
} }
{ {
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,55,59,0,0,0,1,0,0,13,0,18,0, static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,56,59,0,0,0,1,0,0,13,0,18,0,
35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226, 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226,
0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1, 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1,
199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100, 199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100,
@ -340,25 +340,25 @@
EVAL_ONE_SIZED_STR((char *)expr, 5006); EVAL_ONE_SIZED_STR((char *)expr, 5006);
} }
{ {
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,55,8,0,0,0,1,0,0,6,0,19,0, static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,56,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,115,0,0,0,6,1,0,0,65,113,117,111,116, 34,0,48,0,62,0,76,0,115,0,0,0,20,1,0,0,65,113,117,111,116,
101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35, 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35,
37,107,101,114,110,101,108,11,97,35,11,8,176,246,98,159,2,2,35,35,159, 37,107,101,114,110,101,108,11,97,35,11,8,168,248,98,159,2,2,35,35,159,
2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,159,2, 2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,159,2,
6,35,35,16,0,159,35,20,103,159,35,16,1,11,16,0,83,158,41,20,100, 6,35,35,16,0,159,35,20,103,159,35,16,1,11,16,0,83,158,41,20,100,
144,69,35,37,98,117,105,108,116,105,110,29,11,11,11,11,11,18,96,11,42, 144,69,35,37,98,117,105,108,116,105,110,29,11,11,11,11,11,18,96,11,42,
42,42,35,80,158,35,35,20,103,159,35,16,0,16,0,16,0,35,16,0,35, 42,42,35,80,158,35,35,20,103,159,35,16,0,16,0,16,0,35,16,0,35,
16,0,35,11,11,38,35,11,11,11,16,0,16,0,16,0,35,35,36,11,11, 16,0,35,11,11,38,35,11,11,11,16,0,16,0,16,0,35,35,36,11,11,
11,16,0,16,0,16,0,35,35,11,11,11,11,16,0,16,0,16,0,35,35, 11,16,0,16,0,16,0,35,35,11,11,11,11,16,0,16,0,16,0,35,35,
16,0,16,0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105, 16,0,16,0,100,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,
103,110,11,2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101, 103,110,11,29,94,2,1,68,35,37,117,110,115,97,102,101,11,2,4,2,3,
11,9,9,9,35,0}; 2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 299); EVAL_ONE_SIZED_STR((char *)expr, 313);
} }
{ {
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,55,56,0,0,0,1,0,0,11,0,38,0, static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,56,56,0,0,0,1,0,0,11,0,38,0,
44,0,57,0,66,0,73,0,95,0,117,0,143,0,155,0,173,0,193,0,205, 44,0,57,0,66,0,73,0,95,0,117,0,143,0,155,0,173,0,193,0,205,
0,221,0,244,0,0,1,31,1,38,1,43,1,48,1,53,1,58,1,67,1, 0,221,0,244,0,0,1,31,1,38,1,43,1,48,1,53,1,58,1,67,1,
72,1,76,1,84,1,93,1,101,1,204,1,249,1,13,2,42,2,73,2,129, 72,1,76,1,84,1,93,1,101,1,204,1,249,1,13,2,42,2,73,2,129,

121
src/mzscheme/src/env.c
View File

@ -52,6 +52,7 @@ static int env_uid_counter = 0;
/* globals READ-ONLY SHARED */ /* globals READ-ONLY SHARED */
static Scheme_Object *kernel_symbol; static Scheme_Object *kernel_symbol;
static Scheme_Env *kernel_env; static Scheme_Env *kernel_env;
static Scheme_Env *unsafe_env;
#define MAX_CONST_LOCAL_POS 64 #define MAX_CONST_LOCAL_POS 64
#define MAX_CONST_LOCAL_TYPES 2 #define MAX_CONST_LOCAL_TYPES 2
@ -393,6 +394,39 @@ static void place_instance_init_pre_kernel(void *stack_base) {
#endif #endif
} }
static void init_unsafe(Scheme_Env *env)
{
scheme_defining_primitives = 1;
REGISTER_SO(unsafe_env);
unsafe_env = scheme_primitive_module(scheme_intern_symbol("#%unsafe"), env);
scheme_init_unsafe_number(unsafe_env);
scheme_init_unsafe_numarith(unsafe_env);
scheme_init_unsafe_numcomp(unsafe_env);
scheme_init_unsafe_list(unsafe_env);
scheme_init_unsafe_vector(unsafe_env);
scheme_finish_primitive_module(unsafe_env);
scheme_protect_primitive_provide(unsafe_env, NULL);
scheme_defining_primitives = 0;
#if USE_COMPILED_STARTUP
if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT)) {
printf("Unsafe count %d doesn't match expected count %d\n",
builtin_ref_counter - EXPECTED_PRIM_COUNT, EXPECTED_UNSAFE_COUNT);
abort();
}
#endif
}
Scheme_Env *scheme_get_unsafe_env() {
return unsafe_env;
}
static Scheme_Env *place_instance_init_post_kernel() { static Scheme_Env *place_instance_init_post_kernel() {
Scheme_Env *env; Scheme_Env *env;
/* error handling and buffers */ /* error handling and buffers */
@ -432,6 +466,8 @@ static Scheme_Env *place_instance_init_post_kernel() {
init_dummy_foreign(env); init_dummy_foreign(env);
#endif #endif
init_unsafe(env);
scheme_add_embedded_builtins(env); scheme_add_embedded_builtins(env);
boot_module_resolver(); boot_module_resolver();
@ -608,7 +644,7 @@ static void make_kernel_env(void)
printf("Primitive count %d doesn't match expected count %d\n" printf("Primitive count %d doesn't match expected count %d\n"
"Turn off USE_COMPILED_STARTUP in src/schminc.h\n", "Turn off USE_COMPILED_STARTUP in src/schminc.h\n",
builtin_ref_counter, EXPECTED_PRIM_COUNT); builtin_ref_counter, EXPECTED_PRIM_COUNT);
exit(1); abort();
} }
#endif #endif
@ -1248,13 +1284,18 @@ Scheme_Object **scheme_make_builtin_references_table(void)
Scheme_Bucket **bs; Scheme_Bucket **bs;
Scheme_Env *kenv; Scheme_Env *kenv;
long i; long i;
int j;
t = MALLOC_N(Scheme_Object *, (builtin_ref_counter + 1)); t = MALLOC_N(Scheme_Object *, (builtin_ref_counter + 1));
#ifdef MEMORY_COUNTING_ON #ifdef MEMORY_COUNTING_ON
scheme_misc_count += sizeof(Scheme_Object *) * (builtin_ref_counter + 1); scheme_misc_count += sizeof(Scheme_Object *) * (builtin_ref_counter + 1);
#endif #endif
for (j = 0; j < 2; j++) {
if (!j)
kenv = scheme_get_kernel_env(); kenv = scheme_get_kernel_env();
else
kenv = unsafe_env;
ht = kenv->toplevel; ht = kenv->toplevel;
@ -1265,6 +1306,7 @@ Scheme_Object **scheme_make_builtin_references_table(void)
if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_HAS_REF_ID)) if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_HAS_REF_ID))
t[((Scheme_Bucket_With_Ref_Id *)b)->id] = (Scheme_Object *)b->val; t[((Scheme_Bucket_With_Ref_Id *)b)->id] = (Scheme_Object *)b->val;
} }
}
return t; return t;
} }
@ -1276,20 +1318,26 @@ Scheme_Hash_Table *scheme_map_constants_to_globals(void)
Scheme_Bucket **bs; Scheme_Bucket **bs;
Scheme_Env *kenv; Scheme_Env *kenv;
long i; long i;
int j;
result = scheme_make_hash_table(SCHEME_hash_ptr);
for (j = 0; j < 2; j++) {
if (!j)
kenv = scheme_get_kernel_env(); kenv = scheme_get_kernel_env();
else
kenv = unsafe_env;
ht = kenv->toplevel; ht = kenv->toplevel;
bs = ht->buckets; bs = ht->buckets;
result = scheme_make_hash_table(SCHEME_hash_ptr);
for (i = ht->size; i--; ) { for (i = ht->size; i--; ) {
Scheme_Bucket *b = bs[i]; Scheme_Bucket *b = bs[i];
if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST)) { if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST)) {
scheme_hash_set(result, b->val, (Scheme_Object *)b); scheme_hash_set(result, b->val, (Scheme_Object *)b);
} }
} }
}
return result; return result;
} }
@ -1713,6 +1761,38 @@ Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env
return o; return o;
} }
void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec,
Scheme_Env *menv)
{
Scheme_Object *v, *insp;
if (rec && rec[drec].dont_mark_local_use) {
return;
}
insp = menv->module->insp;
v = env->prefix->uses_unsafe;
if (!v)
v = insp;
else if (!SAME_OBJ(v, insp)) {
Scheme_Hash_Tree *ht;
if (SCHEME_HASHTRP(v)) {
ht = (Scheme_Hash_Tree *)v;
} else {
ht = scheme_make_hash_tree(0);
ht = scheme_hash_tree_set(ht, v, scheme_true);
}
if (!scheme_hash_tree_get(ht, insp)) {
ht = scheme_hash_tree_set(ht, insp, scheme_true);
env->prefix->uses_unsafe = (Scheme_Object *)ht;
}
}
}
/*========================================================================*/ /*========================================================================*/
/* compile-time env, lookup bindings */ /* compile-time env, lookup bindings */
/*========================================================================*/ /*========================================================================*/
@ -2864,7 +2944,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
/* Used to have `&& !SAME_OBJ(modidx, modname)' below, but that was a bad /* Used to have `&& !SAME_OBJ(modidx, modname)' below, but that was a bad
idea, because it causes module instances to be preserved. */ idea, because it causes module instances to be preserved. */
if (modname && !(flags & SCHEME_RESOLVE_MODIDS) if (modname && !(flags & SCHEME_RESOLVE_MODIDS)
&& (!scheme_is_kernel_modname(modname) || (flags & SCHEME_REFERENCING))) { && (!(scheme_is_kernel_modname(modname) || scheme_is_unsafe_modname(modname))
|| (flags & SCHEME_REFERENCING))) {
/* Create a module variable reference, so that idx is preserved: */ /* Create a module variable reference, so that idx is preserved: */
return scheme_hash_module_variable(env->genv, modidx, find_id, return scheme_hash_module_variable(env->genv, modidx, find_id,
genv->module->insp, genv->module->insp,
@ -2882,7 +2963,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if ((flags & SCHEME_ELIM_CONST) && b && b->val if ((flags & SCHEME_ELIM_CONST) && b && b->val
&& (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST) && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST)
&& !(flags & SCHEME_GLOB_ALWAYS_REFERENCE)) && !(flags & SCHEME_GLOB_ALWAYS_REFERENCE)
&& (!modname || scheme_is_kernel_modname(modname)))
return (Scheme_Object *)b->val; return (Scheme_Object *)b->val;
ASSERT_IS_VARIABLE_BUCKET(b); ASSERT_IS_VARIABLE_BUCKET(b);
@ -2892,6 +2974,15 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
return (Scheme_Object *)b; return (Scheme_Object *)b;
} }
Scheme_Object *scheme_extract_unsafe(Scheme_Object *o)
{
Scheme_Env *home = ((Scheme_Bucket_With_Home *)o)->home;
if (home && home->module && scheme_is_unsafe_modname(home->module->modname))
return (Scheme_Object *)((Scheme_Bucket *)o)->val;
else
return NULL;
}
int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count) int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count)
{ {
int *v, i; int *v, i;
@ -3447,6 +3538,7 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify)
rp->so.type = scheme_resolve_prefix_type; rp->so.type = scheme_resolve_prefix_type;
rp->num_toplevels = cp->num_toplevels; rp->num_toplevels = cp->num_toplevels;
rp->num_stxes = cp->num_stxes; rp->num_stxes = cp->num_stxes;
rp->uses_unsafe = cp->uses_unsafe;
if (rp->num_toplevels) if (rp->num_toplevels)
tls = MALLOC_N(Scheme_Object*, rp->num_toplevels); tls = MALLOC_N(Scheme_Object*, rp->num_toplevels);
@ -5407,14 +5499,27 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
SCHEME_VEC_ELS(sv)[i] = ds; SCHEME_VEC_ELS(sv)[i] = ds;
} }
return scheme_make_pair(scheme_make_integer(rp->num_lifts), scheme_make_pair(tv, sv)); tv = scheme_make_pair(scheme_make_integer(rp->num_lifts),
scheme_make_pair(tv, sv));
if (rp->uses_unsafe)
tv = scheme_make_pair(scheme_true, tv);
return tv;
} }
static Scheme_Object *read_resolve_prefix(Scheme_Object *obj) static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
{ {
Resolve_Prefix *rp; Resolve_Prefix *rp;
Scheme_Object *tv, *sv, **a, *stx; Scheme_Object *tv, *sv, **a, *stx;
int i; int i, uses_unsafe = 0;
if (!SCHEME_PAIRP(obj)) return NULL;
if (!SCHEME_INTP(SCHEME_CAR(obj))) {
uses_unsafe = 1;
obj = SCHEME_CDR(obj);
}
if (!SCHEME_PAIRP(obj)) return NULL; if (!SCHEME_PAIRP(obj)) return NULL;
@ -5435,6 +5540,8 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
rp->num_toplevels = SCHEME_VEC_SIZE(tv); rp->num_toplevels = SCHEME_VEC_SIZE(tv);
rp->num_stxes = SCHEME_VEC_SIZE(sv); rp->num_stxes = SCHEME_VEC_SIZE(sv);
rp->num_lifts = i; rp->num_lifts = i;
if (uses_unsafe)
rp->uses_unsafe = scheme_true; /* reset in read_marshalled */
i = rp->num_toplevels; i = rp->num_toplevels;
a = MALLOC_N(Scheme_Object *, i); a = MALLOC_N(Scheme_Object *, i);

8
src/mzscheme/src/eval.c
View File

@ -5548,6 +5548,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].comp) { if (rec[drec].comp) {
scheme_compile_rec_done_local(rec, drec); scheme_compile_rec_done_local(rec, drec);
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
&& scheme_extract_unsafe(var)) {
scheme_register_unsafe_in_prefix(env, rec, drec, menv);
return scheme_extract_unsafe(var);
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type))
return scheme_register_toplevel_in_prefix(var, env, rec, drec); return scheme_register_toplevel_in_prefix(var, env, rec, drec);
else else
@ -10205,6 +10209,10 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
rs_save = rs = MZ_RUNSTACK; rs_save = rs = MZ_RUNSTACK;
if (rp->uses_unsafe) {
scheme_check_unsafe_accessible(rp->uses_unsafe, genv);
}
if (rp->num_toplevels || rp->num_stxes || rp->num_lifts) { if (rp->num_toplevels || rp->num_stxes || rp->num_lifts) {
i = rp->num_toplevels; i = rp->num_toplevels;
if (rp->num_stxes) { if (rp->num_stxes) {

448
src/mzscheme/src/jit.c
View File

@ -1339,6 +1339,24 @@ static int inline_alloc(mz_jit_state *jitter, int amt, Scheme_Type ty, int immut
# endif # endif
#endif #endif
int scheme_can_inline_fp_op()
{
#ifdef INLINE_FP_OPS
return 1;
#else
return 0;
#endif
}
int scheme_can_inline_fp_comp()
{
#ifdef INLINE_FP_COMP
return 1;
#else
return 0;
#endif
}
#if defined(INLINE_FP_OPS) && !defined(CAN_INLINE_ALLOC) #if defined(INLINE_FP_OPS) && !defined(CAN_INLINE_ALLOC)
static double double_result; static double double_result;
static void *malloc_double(void) static void *malloc_double(void)
@ -2281,7 +2299,7 @@ static int generate_clear_slow_previous_args(mz_jit_state *jitter)
mz_prepare(2); mz_prepare(2);
jit_pusharg_p(JIT_R0); jit_pusharg_p(JIT_R0);
jit_pusharg_l(JIT_V1); jit_pusharg_l(JIT_V1);
mz_finish(clear_runstack); (void)mz_finish(clear_runstack);
jit_retval(JIT_R0); jit_retval(JIT_R0);
return 1; return 1;
} }
@ -3292,12 +3310,13 @@ static int can_fast_double(int arith, int cmp, int two_args)
static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int reversed, int two_args, int second_const, static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int reversed, int two_args, int second_const,
jit_insn **_refd, jit_insn **_refdt, jit_insn **_refd, jit_insn **_refdt,
int branch_short) int branch_short, int unsafe_fl)
{ {
#if defined(INLINE_FP_OPS) || defined(INLINE_FP_COMP) #if defined(INLINE_FP_OPS) || defined(INLINE_FP_COMP)
GC_CAN_IGNORE jit_insn *ref8, *ref9, *ref10, *refd, *refdt; GC_CAN_IGNORE jit_insn *ref8, *ref9, *ref10, *refd, *refdt;
int no_alloc = 0; int no_alloc = 0;
if (!unsafe_fl) {
/* Maybe they're doubles */ /* Maybe they're doubles */
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
if (two_args) { if (two_args) {
@ -3314,6 +3333,9 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
ref10 = NULL; ref10 = NULL;
CHECK_LIMIT(); CHECK_LIMIT();
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
} else {
ref8 = ref9 = ref10 = NULL;
}
if (!two_args && !second_const && ((arith == 2) || ((arith == -2) && reversed))) { if (!two_args && !second_const && ((arith == 2) || ((arith == -2) && reversed))) {
/* Special case: multiplication by exact 0 */ /* Special case: multiplication by exact 0 */
@ -3434,12 +3456,15 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
} }
} }
if (!unsafe_fl) {
/* Jump to return result or true branch: */ /* Jump to return result or true branch: */
__START_SHORT_JUMPS__(branch_short); __START_SHORT_JUMPS__(branch_short);
refdt = jit_jmpi(jit_forward()); refdt = jit_jmpi(jit_forward());
*_refdt = refdt; *_refdt = refdt;
__END_SHORT_JUMPS__(branch_short); __END_SHORT_JUMPS__(branch_short);
}
if (!unsafe_fl) {
/* No, they're not both doubles. */ /* No, they're not both doubles. */
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
if (two_args) { if (two_args) {
@ -3448,22 +3473,28 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
} }
mz_patch_branch(ref9); mz_patch_branch(ref9);
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
}
#endif #endif
return 1; return 1;
} }
static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2, static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2,
int orig_args, int arith, int cmp, int v, jit_insn **for_branch, int branch_short) int orig_args, int arith, int cmp, int v, jit_insn **for_branch, int branch_short,
int unsafe_fx, int unsafe_fl)
/* needs de-sync */ /* needs de-sync */
/* Either arith is non-zero or it's a cmp; the value of each determines the operation: /* Either arith is non-zero or it's a cmp; the value of each determines the operation:
arith = 1 -> + or add1 (if !rand2) arith = 1 -> + or add1 (if !rand2)
arith = -1 -> - or sub1 arith = -1 -> - or sub1
arith = 2 -> * arith = 2 -> *
arith = -2 -> /
arith = -3 -> quotient
arith = -4 -> remainder
arith = 3 -> bitwise-and arith = 3 -> bitwise-and
arith = 4 -> bitwise-ior arith = 4 -> bitwise-ior
arith = 5 -> bitwise-xor arith = 5 -> bitwise-xor
arith = 6 -> arithmetic-shift arith = 6 -> arithmetic-shift, fxlshift
arith = -6 -> fxrshift
arith = 7 -> bitwise-not arith = 7 -> bitwise-not
arith = 9 -> min arith = 9 -> min
arith = 10 -> max arith = 10 -> max
@ -3495,7 +3526,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
rand2 = NULL; rand2 = NULL;
} else if (SCHEME_INTP(rand) } else if (SCHEME_INTP(rand)
&& SCHEME_INT_SMALL_ENOUGH(rand) && SCHEME_INT_SMALL_ENOUGH(rand)
&& (arith != 6) && (arith != 6) && (arith != -6)
&& (cmp != 3)) { && (cmp != 3)) {
/* First is constant; swap argument order and use constant mode. */ /* First is constant; swap argument order and use constant mode. */
v = SCHEME_INT_VAL(rand); v = SCHEME_INT_VAL(rand);
@ -3588,23 +3619,31 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
pos = mz_remap(SCHEME_LOCAL_POS(rand)); pos = mz_remap(SCHEME_LOCAL_POS(rand));
mz_rs_ldxi(JIT_R1, pos); mz_rs_ldxi(JIT_R1, pos);
} }
if (!unsafe_fx && !unsafe_fl) {
/* check both fixnum bits at once by ANDing into R2: */ /* check both fixnum bits at once by ANDing into R2: */
jit_andr_ul(JIT_R2, JIT_R0, JIT_R1); jit_andr_ul(JIT_R2, JIT_R0, JIT_R1);
va = JIT_R2; va = JIT_R2;
} }
}
if (!unsafe_fx && !unsafe_fl) {
mz_rs_sync(); mz_rs_sync();
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
ref2 = jit_bmsi_ul(jit_forward(), va, 0x1); ref2 = jit_bmsi_ul(jit_forward(), va, 0x1);
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
} else {
ref2 = NULL;
if (for_branch) mz_rs_sync();
}
if (!SCHEME_INTP(rand) && can_fast_double(arith, cmp, 1)) { if (unsafe_fl || (!SCHEME_INTP(rand) && can_fast_double(arith, cmp, 1))) {
/* Maybe they're both doubles... */ /* Maybe they're both doubles... */
generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short); generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl);
CHECK_LIMIT(); CHECK_LIMIT();
} }
if (!unsafe_fx && !unsafe_fl) {
if (!has_fixnum_fast) { if (!has_fixnum_fast) {
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
mz_patch_branch(ref2); mz_patch_branch(ref2);
@ -3619,6 +3658,11 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
mz_patch_branch(ref2); mz_patch_branch(ref2);
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
} }
} else {
refslow = NULL;
ref = NULL;
ref4 = NULL;
}
CHECK_LIMIT(); CHECK_LIMIT();
} else if (rand2) { } else if (rand2) {
/* Move rand result back into R1 */ /* Move rand result back into R1 */
@ -3626,6 +3670,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
mz_rs_inc(1); mz_rs_inc(1);
mz_runstack_popped(jitter, 1); mz_runstack_popped(jitter, 1);
if (!unsafe_fx && !unsafe_fl) {
mz_rs_sync(); mz_rs_sync();
/* check both fixnum bits at once by ANDing into R2: */ /* check both fixnum bits at once by ANDing into R2: */
@ -3634,13 +3679,19 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
ref2 = jit_bmsi_ul(jit_forward(), JIT_R2, 0x1); ref2 = jit_bmsi_ul(jit_forward(), JIT_R2, 0x1);
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
CHECK_LIMIT(); CHECK_LIMIT();
} else {
if (can_fast_double(arith, cmp, 1)) { if (for_branch) mz_rs_sync();
/* Maybe they're both doubles... */ ref2 = NULL;
generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short);
CHECK_LIMIT(); CHECK_LIMIT();
} }
if (unsafe_fl || can_fast_double(arith, cmp, 1)) {
/* Maybe they're both doubles... */
generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl);
CHECK_LIMIT();
}
if (!unsafe_fx && !unsafe_fl) {
if (!has_fixnum_fast) { if (!has_fixnum_fast) {
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
mz_patch_branch(ref2); mz_patch_branch(ref2);
@ -3658,22 +3709,34 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
} }
CHECK_LIMIT(); CHECK_LIMIT();
} else { } else {
mz_rs_sync(); refslow = NULL;
ref = NULL;
ref4 = NULL;
}
} else {
/* Only one argument: */ /* Only one argument: */
if (!unsafe_fx && !unsafe_fl) {
mz_rs_sync();
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
ref2 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); ref2 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
} else {
if (for_branch) mz_rs_sync();
ref2 = NULL;
}
if ((orig_args != 2) /* <- heuristic: we could generate code when an exact argument is if (unsafe_fl
|| ((orig_args != 2) /* <- heuristic: we could generate code when an exact argument is
given, but the extra FP code is probably not worthwhile. */ given, but the extra FP code is probably not worthwhile. */
&& can_fast_double(arith, cmp, 0) && can_fast_double(arith, cmp, 0)
/* watch out: divide by 0 is special: */ /* watch out: divide by 0 is special: */
&& ((arith != -2) || v || reversed)) { && ((arith != -2) || v || reversed))) {
/* Maybe it's a double... */ /* Maybe it's a double... */
generate_double_arith(jitter, arith, cmp, reversed, 0, v, &refd, &refdt, branch_short); generate_double_arith(jitter, arith, cmp, reversed, 0, v, &refd, &refdt, branch_short, unsafe_fl);
CHECK_LIMIT(); CHECK_LIMIT();
} }
if (!unsafe_fx && !unsafe_fl) {
if (!has_fixnum_fast) { if (!has_fixnum_fast) {
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
mz_patch_branch(ref2); mz_patch_branch(ref2);
@ -3688,6 +3751,11 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
mz_patch_branch(ref2); mz_patch_branch(ref2);
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
} }
} else {
refslow = NULL;
ref = NULL;
ref4 = NULL;
}
} }
CHECK_LIMIT(); CHECK_LIMIT();
@ -3696,25 +3764,44 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
__START_SHORT_JUMPS__(branch_short); __START_SHORT_JUMPS__(branch_short);
if (!unsafe_fl) {
if (arith) { if (arith) {
if (((arith == -3) || (arith == -4)) && !rand2) {
(void)jit_movi_p(JIT_R1, scheme_make_integer(v));
rand2 = scheme_true;
reversed = !reversed;
}
if (rand2) { if (rand2) {
/* First arg is in JIT_R1, second is in JIT_R0 */ /* First arg is in JIT_R1, second is in JIT_R0 */
if (arith == 1) { if (arith == 1) {
jit_andi_ul(JIT_R2, JIT_R1, (~0x1)); jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
if (unsafe_fx)
jit_addr_l(JIT_R2, JIT_R2, JIT_R0);
else
(void)jit_boaddr_l(refslow, JIT_R2, JIT_R0); (void)jit_boaddr_l(refslow, JIT_R2, JIT_R0);
jit_movr_p(JIT_R0, JIT_R2); jit_movr_p(JIT_R0, JIT_R2);
} else if (arith == -1) { } else if (arith == -1) {
if (reversed) { if (reversed) {
jit_movr_p(JIT_R2, JIT_R0); jit_movr_p(JIT_R2, JIT_R0);
if (unsafe_fx)
jit_subr_l(JIT_R2, JIT_R2, JIT_R1);
else
(void)jit_bosubr_l(refslow, JIT_R2, JIT_R1); (void)jit_bosubr_l(refslow, JIT_R2, JIT_R1);
} else { } else {
jit_movr_p(JIT_R2, JIT_R1); jit_movr_p(JIT_R2, JIT_R1);
if (unsafe_fx)
(void)jit_subr_l(JIT_R2, JIT_R2, JIT_R0);
else
(void)jit_bosubr_l(refslow, JIT_R2, JIT_R0); (void)jit_bosubr_l(refslow, JIT_R2, JIT_R0);
} }
jit_ori_ul(JIT_R0, JIT_R2, 0x1); jit_ori_ul(JIT_R0, JIT_R2, 0x1);
} else if (arith == 2) { } else if (arith == 2) {
jit_andi_ul(JIT_R2, JIT_R1, (~0x1)); jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
jit_rshi_l(JIT_V1, JIT_R0, 0x1); jit_rshi_l(JIT_V1, JIT_R0, 0x1);
if (unsafe_fx)
jit_mulr_l(JIT_V1, JIT_V1, JIT_R2);
else
(void)jit_bomulr_l(refslow, JIT_V1, JIT_R2); (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2);
jit_ori_ul(JIT_R0, JIT_V1, 0x1); jit_ori_ul(JIT_R0, JIT_V1, 0x1);
} else if (arith == -2) { } else if (arith == -2) {
@ -3722,6 +3809,27 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
/* No fast path for fixnum division, yet */ /* No fast path for fixnum division, yet */
(void)jit_jmpi(refslow); (void)jit_jmpi(refslow);
} }
} else if ((arith == -3) || (arith == -4)) {
/* -3 : quotient -4 : remainder */
jit_rshi_l(JIT_V1, JIT_R0, 0x1);
jit_rshi_l(JIT_R2, JIT_R1, 0x1);
if (reversed) {
if (!unsafe_fx)
(void)jit_beqi_l(refslow, JIT_R2, 0);
if (arith == -3)
jit_divr_l(JIT_R0, JIT_V1, JIT_R2);
else
jit_modr_l(JIT_R0, JIT_V1, JIT_R2);
} else {
if (!unsafe_fx)
(void)jit_beqi_l(refslow, JIT_V1, 0);
if (arith == -3)
jit_divr_l(JIT_R0, JIT_R2, JIT_V1);
else
jit_modr_l(JIT_R0, JIT_R2, JIT_V1);
}
jit_lshi_l(JIT_R0, JIT_R0, 1);
jit_ori_l(JIT_R0, JIT_R0, 0x1);
} else if (arith == 3) { } else if (arith == 3) {
/* and */ /* and */
jit_andr_ul(JIT_R0, JIT_R1, JIT_R0); jit_andr_ul(JIT_R0, JIT_R1, JIT_R0);
@ -3732,7 +3840,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
/* xor */ /* xor */
jit_andi_ul(JIT_R0, JIT_R0, (~0x1)); jit_andi_ul(JIT_R0, JIT_R0, (~0x1));
jit_xorr_ul(JIT_R0, JIT_R1, JIT_R0); jit_xorr_ul(JIT_R0, JIT_R1, JIT_R0);
} else if (arith == 6) { } else if ((arith == 6) || (arith == -6)) {
/* arithmetic-shift /* arithmetic-shift
This is a lot of code, but if you're using This is a lot of code, but if you're using
arihtmetic-shift, then you probably want it. */ arihtmetic-shift, then you probably want it. */
@ -3740,12 +3848,22 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
int v2 = (reversed ? JIT_R1 : JIT_R0); int v2 = (reversed ? JIT_R1 : JIT_R0);
jit_insn *refi, *refc; jit_insn *refi, *refc;
refi = jit_bgei_l(refslow, v2, (long)scheme_make_integer(0)); if (!unsafe_fx)
refi = jit_bgei_l(jit_forward(), v2, (long)scheme_make_integer(0));
else
refi = NULL;
/* Right shift (always works for a small enough shift) */ if (!unsafe_fx || (arith == -6)) {
/* Right shift */
if (!unsafe_fx) {
/* check for a small enough shift */
(void)jit_blti_l(refslow, v2, scheme_make_integer(-MAX_TRY_SHIFT)); (void)jit_blti_l(refslow, v2, scheme_make_integer(-MAX_TRY_SHIFT));
jit_notr_l(JIT_V1, v2); jit_notr_l(JIT_V1, v2);
jit_rshi_l(JIT_V1, JIT_V1, 0x1); jit_rshi_l(JIT_V1, JIT_V1, 0x1);
} else {
jit_rshi_l(JIT_V1, v2, 0x1);
}
if (!unsafe_fx)
jit_addi_l(JIT_V1, JIT_V1, 0x1); jit_addi_l(JIT_V1, JIT_V1, 0x1);
CHECK_LIMIT(); CHECK_LIMIT();
#ifdef MZ_USE_JIT_I386 #ifdef MZ_USE_JIT_I386
@ -3756,11 +3874,19 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
jit_rshr_l(JIT_R2, v1, JIT_V1); jit_rshr_l(JIT_R2, v1, JIT_V1);
#endif #endif
jit_ori_l(JIT_R0, JIT_R2, 0x1); jit_ori_l(JIT_R0, JIT_R2, 0x1);
if (!unsafe_fx)
refc = jit_jmpi(jit_forward()); refc = jit_jmpi(jit_forward());
else
refc = NULL;
CHECK_LIMIT(); CHECK_LIMIT();
} else
refc = NULL;
/* Left shift */ /* Left shift */
if (!unsafe_fx || (arith == 6)) {
if (refi)
mz_patch_branch(refi); mz_patch_branch(refi);
if (!unsafe_fx)
(void)jit_bgti_l(refslow, v2, (long)scheme_make_integer(MAX_TRY_SHIFT)); (void)jit_bgti_l(refslow, v2, (long)scheme_make_integer(MAX_TRY_SHIFT));
jit_rshi_l(JIT_V1, v2, 0x1); jit_rshi_l(JIT_V1, v2, 0x1);
jit_andi_l(v1, v1, (~0x1)); jit_andi_l(v1, v1, (~0x1));
@ -3775,10 +3901,13 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
/* If shifting back right produces a different result, that's overflow... */ /* If shifting back right produces a different result, that's overflow... */
jit_rshr_l(JIT_V1, JIT_R2, JIT_V1); jit_rshr_l(JIT_V1, JIT_R2, JIT_V1);
/* !! In case we go refslow, it nseed to add back tag to v1 !! */ /* !! In case we go refslow, it nseed to add back tag to v1 !! */
if (!unsafe_fx)
(void)jit_bner_p(refslow, JIT_V1, v1); (void)jit_bner_p(refslow, JIT_V1, v1);
/* No overflow. */ /* No overflow. */
jit_ori_l(JIT_R0, JIT_R2, 0x1); jit_ori_l(JIT_R0, JIT_R2, 0x1);
}
if (refc)
mz_patch_ucbranch(refc); mz_patch_ucbranch(refc);
} else if (arith == 9) { } else if (arith == 9) {
/* min */ /* min */
@ -3801,15 +3930,24 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
/* Non-constant arg is in JIT_R0 */ /* Non-constant arg is in JIT_R0 */
if (arith == 1) { if (arith == 1) {
jit_movr_p(JIT_R2, JIT_R0); jit_movr_p(JIT_R2, JIT_R0);
if (unsafe_fx)
jit_addi_l(JIT_R2, JIT_R2, v << 1);
else
(void)jit_boaddi_l(refslow, JIT_R2, v << 1); (void)jit_boaddi_l(refslow, JIT_R2, v << 1);
jit_movr_p(JIT_R0, JIT_R2); jit_movr_p(JIT_R0, JIT_R2);
} else if (arith == -1) { } else if (arith == -1) {
if (reversed) { if (reversed) {
(void)jit_movi_p(JIT_R2, scheme_make_integer(v)); (void)jit_movi_p(JIT_R2, scheme_make_integer(v));
if (unsafe_fx)
jit_subr_l(JIT_R2, JIT_R2, JIT_R0);
else
(void)jit_bosubr_l(refslow, JIT_R2, JIT_R0); (void)jit_bosubr_l(refslow, JIT_R2, JIT_R0);
jit_addi_ul(JIT_R0, JIT_R2, 0x1); jit_addi_ul(JIT_R0, JIT_R2, 0x1);
} else { } else {
jit_movr_p(JIT_R2, JIT_R0); jit_movr_p(JIT_R2, JIT_R0);
if (unsafe_fx)
jit_subi_l(JIT_R2, JIT_R2, v << 1);
else
(void)jit_bosubi_l(refslow, JIT_R2, v << 1); (void)jit_bosubi_l(refslow, JIT_R2, v << 1);
jit_movr_p(JIT_R0, JIT_R2); jit_movr_p(JIT_R0, JIT_R2);
} }
@ -3822,6 +3960,9 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
(void)jit_movi_p(JIT_R1, scheme_make_integer(v)); (void)jit_movi_p(JIT_R1, scheme_make_integer(v));
jit_andi_ul(JIT_R2, JIT_R1, (~0x1)); jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
jit_rshi_l(JIT_V1, JIT_R0, 0x1); jit_rshi_l(JIT_V1, JIT_R0, 0x1);
if (unsafe_fx)
jit_mulr_l(JIT_V1, JIT_V1, JIT_R2);
else
(void)jit_bomulr_l(refslow, JIT_V1, JIT_R2); (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2);
jit_ori_ul(JIT_R0, JIT_V1, 0x1); jit_ori_ul(JIT_R0, JIT_V1, 0x1);
} }
@ -3847,19 +3988,24 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
} else if (arith == 5) { } else if (arith == 5) {
/* xor */ /* xor */
jit_xori_ul(JIT_R0, JIT_R0, v << 1); jit_xori_ul(JIT_R0, JIT_R0, v << 1);
} else if (arith == 6) { } else if ((arith == 6) || (arith == -6)) {
/* arithmetic-shift */ /* arithmetic-shift */
/* We only get here when v is between -MAX_TRY_SHIFT and MAX_TRY_SHIFT, inclusive */ /* We only get here when v is between -MAX_TRY_SHIFT and MAX_TRY_SHIFT, inclusive */
if (v <= 0) { if ((v <= 0) || (arith == -6)) {
jit_rshi_l(JIT_R0, JIT_R0, -v); int amt = v;
if (arith != -6)
amt = -amt;
jit_rshi_l(JIT_R0, JIT_R0, amt);
jit_ori_l(JIT_R0, JIT_R0, 0x1); jit_ori_l(JIT_R0, JIT_R0, 0x1);
} else { } else {
jit_andi_l(JIT_R0, JIT_R0, (~0x1)); jit_andi_l(JIT_R0, JIT_R0, (~0x1));
jit_lshi_l(JIT_R2, JIT_R0, v); jit_lshi_l(JIT_R2, JIT_R0, v);
if (!unsafe_fx) {
/* If shifting back right produces a different result, that's overflow... */ /* If shifting back right produces a different result, that's overflow... */
jit_rshi_l(JIT_V1, JIT_R2, v); jit_rshi_l(JIT_V1, JIT_R2, v);
/* !! In case we go refslow, it nseed to add back tag to JIT_R0 !! */ /* !! In case we go refslow, it nseed to add back tag to JIT_R0 !! */
(void)jit_bner_p(refslow, JIT_V1, JIT_R0); (void)jit_bner_p(refslow, JIT_V1, JIT_R0);
}
/* No overflow. */ /* No overflow. */
jit_ori_l(JIT_R0, JIT_R2, 0x1); jit_ori_l(JIT_R0, JIT_R2, 0x1);
} }
@ -3889,6 +4035,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
refc = jit_bgei_l(jit_forward(), JIT_R0, (long)scheme_make_integer(0)); refc = jit_bgei_l(jit_forward(), JIT_R0, (long)scheme_make_integer(0));
__END_INNER_TINY__(branch_short); __END_INNER_TINY__(branch_short);
/* watch out for most negative fixnum! */ /* watch out for most negative fixnum! */
if (!unsafe_fx)
(void)jit_beqi_p(refslow, JIT_R0, (void *)(((long)1 << ((8 * JIT_WORD_SIZE) - 1)) | 0x1)); (void)jit_beqi_p(refslow, JIT_R0, (void *)(((long)1 << ((8 * JIT_WORD_SIZE) - 1)) | 0x1));
jit_rshi_l(JIT_R0, JIT_R0, 1); jit_rshi_l(JIT_R0, JIT_R0, 1);
jit_movi_l(JIT_R1, 0); jit_movi_l(JIT_R1, 0);
@ -3904,7 +4051,9 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
} }
if (refdt) if (refdt)
mz_patch_ucbranch(refdt); mz_patch_ucbranch(refdt);
if (!unsafe_fx && !unsafe_fl)
jit_patch_movi(ref, (_jit.x.pc)); jit_patch_movi(ref, (_jit.x.pc));
ref3 = NULL;
} else { } else {
/* If second is constant, first arg is in JIT_R0. */ /* If second is constant, first arg is in JIT_R0. */
/* Otherwise, first arg is in JIT_R1, second is in JIT_R0 */ /* Otherwise, first arg is in JIT_R1, second is in JIT_R0 */
@ -3912,8 +4061,10 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
switch (cmp) { switch (cmp) {
case -3: case -3:
if (rand2) { if (rand2) {
if (!unsafe_fx) {
(void)jit_blti_l(refslow, JIT_R1, 0); (void)jit_blti_l(refslow, JIT_R1, 0);
(void)jit_bgti_l(refslow, JIT_R1, (long)scheme_make_integer(MAX_TRY_SHIFT)); (void)jit_bgti_l(refslow, JIT_R1, (long)scheme_make_integer(MAX_TRY_SHIFT));
}
jit_rshi_l(JIT_R1, JIT_R1, 1); jit_rshi_l(JIT_R1, JIT_R1, 1);
jit_addi_l(JIT_V1, JIT_R1, 1); jit_addi_l(JIT_V1, JIT_R1, 1);
jit_movi_l(JIT_R2, 1); jit_movi_l(JIT_R2, 1);
@ -3963,8 +4114,10 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
default: default:
case 3: case 3:
if (rand2) { if (rand2) {
if (!unsafe_fx) {
(void)jit_blti_l(refslow, JIT_R0, 0); (void)jit_blti_l(refslow, JIT_R0, 0);
(void)jit_bgti_l(refslow, JIT_R0, (long)scheme_make_integer(MAX_TRY_SHIFT)); (void)jit_bgti_l(refslow, JIT_R0, (long)scheme_make_integer(MAX_TRY_SHIFT));
}
jit_rshi_l(JIT_R0, JIT_R0, 1); jit_rshi_l(JIT_R0, JIT_R0, 1);
jit_addi_l(JIT_R0, JIT_R0, 1); jit_addi_l(JIT_R0, JIT_R0, 1);
jit_movi_l(JIT_V1, 1); jit_movi_l(JIT_V1, 1);
@ -3975,7 +4128,12 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
} }
break; break;
} }
}
} else {
ref3 = NULL;
}
if (!arith) {
if (refdt) if (refdt)
mz_patch_ucbranch(refdt); mz_patch_ucbranch(refdt);
@ -3983,15 +4141,18 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
for_branch[0] = ref3; for_branch[0] = ref3;
for_branch[1] = refd; for_branch[1] = refd;
for_branch[2] = ref; for_branch[2] = ref;
if (ref4)
jit_patch_movi(ref4, (_jit.x.pc)); jit_patch_movi(ref4, (_jit.x.pc));
} else { } else {
(void)jit_movi_p(JIT_R0, scheme_true); (void)jit_movi_p(JIT_R0, scheme_true);
ref2 = jit_jmpi(jit_forward()); ref2 = jit_jmpi(jit_forward());
if (ref3)
mz_patch_branch(ref3); mz_patch_branch(ref3);
if (refd) if (refd)
mz_patch_branch(refd); mz_patch_branch(refd);
(void)jit_movi_p(JIT_R0, scheme_false); (void)jit_movi_p(JIT_R0, scheme_false);
mz_patch_ucbranch(ref2); mz_patch_ucbranch(ref2);
if (!unsafe_fx && !unsafe_fl)
jit_patch_movi(ref, (_jit.x.pc)); jit_patch_movi(ref, (_jit.x.pc));
} }
} }
@ -4251,13 +4412,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
generate_inlined_constant_test(jitter, app, scheme_eof, NULL, for_branch, branch_short, need_sync); generate_inlined_constant_test(jitter, app, scheme_eof, NULL, for_branch, branch_short, need_sync);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "zero?")) { } else if (IS_NAMED_PRIM(rator, "zero?")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 0, 0, 0, for_branch, branch_short); generate_arith(jitter, rator, app->rand, NULL, 1, 0, 0, 0, for_branch, branch_short, 0, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "negative?")) { } else if (IS_NAMED_PRIM(rator, "negative?")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 0, -2, 0, for_branch, branch_short); generate_arith(jitter, rator, app->rand, NULL, 1, 0, -2, 0, for_branch, branch_short, 0, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "positive?")) { } else if (IS_NAMED_PRIM(rator, "positive?")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 0, 2, 0, for_branch, branch_short); generate_arith(jitter, rator, app->rand, NULL, 1, 0, 2, 0, for_branch, branch_short, 0, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "exact-nonnegative-integer?") } else if (IS_NAMED_PRIM(rator, "exact-nonnegative-integer?")
|| IS_NAMED_PRIM(rator, "exact-positive-integer?")) { || IS_NAMED_PRIM(rator, "exact-positive-integer?")) {
@ -4440,7 +4601,31 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "vector-length")) { } else if (IS_NAMED_PRIM(rator, "unsafe-car")
|| IS_NAMED_PRIM(rator, "unsafe-mcar")
|| IS_NAMED_PRIM(rator, "unsafe-cdr")
|| IS_NAMED_PRIM(rator, "unsafe-mcdr")) {
const char *name = ((Scheme_Primitive_Proc *)rator)->name;
LOG_IT(("inlined %s\n", ((Scheme_Primitive_Proc *)rator)->name));
mz_runstack_skipped(jitter, 1);
generate_non_tail(app->rand, jitter, 0, 1);
CHECK_LIMIT();
mz_runstack_unskipped(jitter, 1);
if (!strcmp(name, "unsafe-car") || !strcmp(name, "unsafe-mcar")) {
(void)jit_ldxi_p(JIT_R0, JIT_R0, &((Scheme_Simple_Object *)0x0)->u.pair_val.car);
} else {
(void)jit_ldxi_p(JIT_R0, JIT_R0, &((Scheme_Simple_Object *)0x0)->u.pair_val.cdr);
}
CHECK_LIMIT();
return 1;
} else if (IS_NAMED_PRIM(rator, "vector-length")
|| IS_NAMED_PRIM(rator, "unsafe-vector-length")) {
GC_CAN_IGNORE jit_insn *reffail, *ref; GC_CAN_IGNORE jit_insn *reffail, *ref;
LOG_IT(("inlined vector-length\n")); LOG_IT(("inlined vector-length\n"));
@ -4452,6 +4637,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
mz_runstack_unskipped(jitter, 1); mz_runstack_unskipped(jitter, 1);
if (!IS_NAMED_PRIM(rator, "unsafe-vector-length")) {
mz_rs_sync_fail_branch(); mz_rs_sync_fail_branch();
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
@ -4466,6 +4652,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type); jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
(void)jit_bnei_i(reffail, JIT_R1, scheme_vector_type); (void)jit_bnei_i(reffail, JIT_R1, scheme_vector_type);
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
}
(void)jit_ldxi_i(JIT_R0, JIT_R0, &SCHEME_VEC_SIZE(0x0)); (void)jit_ldxi_i(JIT_R0, JIT_R0, &SCHEME_VEC_SIZE(0x0));
jit_lshi_l(JIT_R0, JIT_R0, 1); jit_lshi_l(JIT_R0, JIT_R0, 1);
@ -4501,6 +4688,19 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
(void)jit_ldxi_p(JIT_R0, JIT_R0, &SCHEME_BOX_VAL(0x0)); (void)jit_ldxi_p(JIT_R0, JIT_R0, &SCHEME_BOX_VAL(0x0));
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-unbox")) {
LOG_IT(("inlined unbox\n"));
mz_runstack_skipped(jitter, 1);
generate_non_tail(app->rand, jitter, 0, 1);
CHECK_LIMIT();
mz_runstack_unskipped(jitter, 1);
(void)jit_ldxi_p(JIT_R0, JIT_R0, &SCHEME_BOX_VAL(0x0));
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "syntax-e")) { } else if (IS_NAMED_PRIM(rator, "syntax-e")) {
LOG_IT(("inlined syntax-e\n")); LOG_IT(("inlined syntax-e\n"));
@ -4518,19 +4718,22 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "add1")) { } else if (IS_NAMED_PRIM(rator, "add1")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 1, 0, 1, NULL, 1); generate_arith(jitter, rator, app->rand, NULL, 1, 1, 0, 1, NULL, 1, 0, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "sub1")) { } else if (IS_NAMED_PRIM(rator, "sub1")) {
generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 1, NULL, 1); generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 1, NULL, 1, 0, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "-")) { } else if (IS_NAMED_PRIM(rator, "-")) {
generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 0, NULL, 1, 0, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "abs")) { } else if (IS_NAMED_PRIM(rator, "abs")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 0, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "bitwise-not")) { } else if (IS_NAMED_PRIM(rator, "bitwise-not")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1); generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxnot")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1, 1, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "vector-immutable") } else if (IS_NAMED_PRIM(rator, "vector-immutable")
|| IS_NAMED_PRIM(rator, "vector")) { || IS_NAMED_PRIM(rator, "vector")) {
@ -4751,13 +4954,13 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app,
return 1; return 1;
} }
static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready) static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int base_offset, int unsafe)
/* if int_ready, JIT_R1 has num index and JIT_V1 has pre-computed offset, /* if int_ready, JIT_R1 has num index (for safe mode) and JIT_V1 has pre-computed offset,
otherwise JIT_R1 has fixnum index */ otherwise JIT_R1 has fixnum index */
{ {
GC_CAN_IGNORE jit_insn *ref, *reffail; GC_CAN_IGNORE jit_insn *ref, *reffail;
if (!skip_checks) { if (!skip_checks && !unsafe) {
__START_TINY_JUMPS__(1); __START_TINY_JUMPS__(1);
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
__END_TINY_JUMPS__(1); __END_TINY_JUMPS__(1);
@ -4797,7 +5000,7 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready)
if (!int_ready) { if (!int_ready) {
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
jit_addi_p(JIT_V1, JIT_V1, (int)&SCHEME_VEC_ELS(0x0)); jit_addi_p(JIT_V1, JIT_V1, base_offset);
} }
if (set) { if (set) {
jit_ldr_p(JIT_R2, JIT_RUNSTACK); jit_ldr_p(JIT_R2, JIT_RUNSTACK);
@ -4912,66 +5115,153 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "=")) { } else if (IS_NAMED_PRIM(rator, "=")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx=")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 1, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl=")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 0, 1);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "<=")) { } else if (IS_NAMED_PRIM(rator, "<=")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx<=")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 1, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl<=")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 0, 1);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "<")) { } else if (IS_NAMED_PRIM(rator, "<")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx<")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 1, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl<")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 0, 1);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, ">=")) { } else if (IS_NAMED_PRIM(rator, ">=")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx>=")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 1, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl>=")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 0, 1);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, ">")) { } else if (IS_NAMED_PRIM(rator, ">")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx>")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 1, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl>")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 0, 1);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "bitwise-bit-set?")) { } else if (IS_NAMED_PRIM(rator, "bitwise-bit-set?")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 3, 0, for_branch, branch_short); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 3, 0, for_branch, branch_short, 0, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "char=?")) { } else if (IS_NAMED_PRIM(rator, "char=?")) {
generate_binary_char(jitter, app, for_branch, branch_short); generate_binary_char(jitter, app, for_branch, branch_short);
return 1; return 1;
} else if (!for_branch) { } else if (!for_branch) {
if (IS_NAMED_PRIM(rator, "+")) { if (IS_NAMED_PRIM(rator, "+")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx+")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 1, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl+")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 0, 1);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "-")) { } else if (IS_NAMED_PRIM(rator, "-")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx-")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 1, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl-")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 0, 1);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "*")) { } else if (IS_NAMED_PRIM(rator, "*")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx*")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 1, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl*")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 0, 1);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "/")) { } else if (IS_NAMED_PRIM(rator, "/")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fl/")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1, 0, 1);
return 1;
} else if (IS_NAMED_PRIM(rator, "quotient")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -3, 0, 0, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxquotient")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -3, 0, 0, NULL, 1, 1, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "remainder")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxremainder")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 1, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "min")) { } else if (IS_NAMED_PRIM(rator, "min")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1, 0, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "max")) { } else if (IS_NAMED_PRIM(rator, "max")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1, 0, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "bitwise-and")) { } else if (IS_NAMED_PRIM(rator, "bitwise-and")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxand")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 1, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "bitwise-ior")) { } else if (IS_NAMED_PRIM(rator, "bitwise-ior")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxior")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1, 1, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "bitwise-xor")) { } else if (IS_NAMED_PRIM(rator, "bitwise-xor")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxxor")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1, 1, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "arithmetic-shift")) { } else if (IS_NAMED_PRIM(rator, "arithmetic-shift")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1, 0, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxlshift")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1, 1, 0);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxrshift")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -6, 0, 0, NULL, 1, 1, 0);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "vector-ref") } else if (IS_NAMED_PRIM(rator, "vector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-vector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-struct-ref")
|| IS_NAMED_PRIM(rator, "string-ref") || IS_NAMED_PRIM(rator, "string-ref")
|| IS_NAMED_PRIM(rator, "bytes-ref")) { || IS_NAMED_PRIM(rator, "bytes-ref")) {
int simple; int simple;
int which; int which, unsafe = 0, base_offset = ((int)&SCHEME_VEC_ELS(0x0));
if (IS_NAMED_PRIM(rator, "vector-ref")) if (IS_NAMED_PRIM(rator, "vector-ref"))
which = 0; which = 0;
else if (IS_NAMED_PRIM(rator, "string-ref")) else if (IS_NAMED_PRIM(rator, "unsafe-vector-ref")) {
which = 0;
unsafe = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-struct-ref")) {
which = 0;
unsafe = 1;
base_offset = ((int)&((Scheme_Structure *)0x0)->slots);
} else if (IS_NAMED_PRIM(rator, "string-ref"))
which = 1; which = 1;
else else
which = 2; which = 2;
@ -4989,7 +5279,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
if (!which) { if (!which) {
/* vector-ref is relatively simple and worth inlining */ /* vector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 0); generate_vector_op(jitter, 0, 0, base_offset, unsafe);
CHECK_LIMIT(); CHECK_LIMIT();
} else if (which == 1) { } else if (which == 1) {
(void)jit_calli(string_ref_check_index_code); (void)jit_calli(string_ref_check_index_code);
@ -5007,15 +5297,16 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
mz_rs_sync(); mz_rs_sync();
offset = SCHEME_INT_VAL(app->rand2); offset = SCHEME_INT_VAL(app->rand2);
if (!unsafe)
(void)jit_movi_p(JIT_R1, offset); (void)jit_movi_p(JIT_R1, offset);
if (!which) if (!which)
offset = ((int)&SCHEME_VEC_ELS(0x0)) + WORDS_TO_BYTES(offset); offset = base_offset + WORDS_TO_BYTES(offset);
else if (which == 1) else if (which == 1)
offset = offset << LOG_MZCHAR_SIZE; offset = offset << LOG_MZCHAR_SIZE;
jit_movi_l(JIT_V1, offset); jit_movi_l(JIT_V1, offset);
if (!which) { if (!which) {
/* vector-ref is relatively simple and worth inlining */ /* vector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 1); generate_vector_op(jitter, 0, 1, base_offset, unsafe);
CHECK_LIMIT(); CHECK_LIMIT();
} else if (which == 1) { } else if (which == 1) {
(void)jit_calli(string_ref_code); (void)jit_calli(string_ref_code);
@ -5062,6 +5353,34 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
(void)jit_movi_p(JIT_R0, scheme_void); (void)jit_movi_p(JIT_R0, scheme_void);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-set-mcar!")
|| IS_NAMED_PRIM(rator, "unsafe-set-mcdr!")) {
int set_mcar;
set_mcar = IS_NAMED_PRIM(rator, "unsafe-set-mcar!");
LOG_IT(("inlined unsafe-set-mcar!\n"));
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
CHECK_LIMIT();
if (set_mcar)
(void)jit_stxi_p(&((Scheme_Simple_Object *)0x0)->u.pair_val.car, JIT_R0, JIT_R1);
else
(void)jit_stxi_p(&((Scheme_Simple_Object *)0x0)->u.pair_val.cdr, JIT_R0, JIT_R1);
(void)jit_movi_p(JIT_R0, scheme_void);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-set-box!")) {
LOG_IT(("inlined unsafe-set-box!\n"));
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
CHECK_LIMIT();
(void)jit_stxi_p(&SCHEME_BOX_VAL(0x0), JIT_R0, JIT_R1);
(void)jit_movi_p(JIT_R0, scheme_void);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "cons") } else if (IS_NAMED_PRIM(rator, "cons")
|| IS_NAMED_PRIM(rator, "list*")) { || IS_NAMED_PRIM(rator, "list*")) {
@ -5158,15 +5477,24 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!for_branch) { if (!for_branch) {
if (IS_NAMED_PRIM(rator, "vector-set!") if (IS_NAMED_PRIM(rator, "vector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-vector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-struct-set!")
|| IS_NAMED_PRIM(rator, "string-set!") || IS_NAMED_PRIM(rator, "string-set!")
|| IS_NAMED_PRIM(rator, "bytes-set!")) { || IS_NAMED_PRIM(rator, "bytes-set!")) {
int simple, constval; int simple, constval;
int which; int which, unsafe = 0, base_offset = ((int)&SCHEME_VEC_ELS(0x0));
int pushed; int pushed;
if (IS_NAMED_PRIM(rator, "vector-set!")) if (IS_NAMED_PRIM(rator, "vector-set!"))
which = 0; which = 0;
else if (IS_NAMED_PRIM(rator, "string-set!")) else if (IS_NAMED_PRIM(rator, "unsafe-vector-set!")) {
which = 0;
unsafe = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-struct-set!")) {
which = 0;
unsafe = 1;
base_offset = ((int)&((Scheme_Structure *)0x0)->slots);
} else if (IS_NAMED_PRIM(rator, "string-set!"))
which = 1; which = 1;
else else
which = 2; which = 2;
@ -5230,7 +5558,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!simple) { if (!simple) {
if (!which) { if (!which) {
/* vector-set! is relatively simple and worth inlining */ /* vector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 0); generate_vector_op(jitter, 1, 0, base_offset, unsafe);
CHECK_LIMIT(); CHECK_LIMIT();
} else if (which == 1) { } else if (which == 1) {
(void)jit_calli(string_set_check_index_code); (void)jit_calli(string_set_check_index_code);
@ -5242,13 +5570,13 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
offset = SCHEME_INT_VAL(app->args[2]); offset = SCHEME_INT_VAL(app->args[2]);
(void)jit_movi_p(JIT_R1, offset); (void)jit_movi_p(JIT_R1, offset);
if (!which) if (!which)
offset = ((int)&SCHEME_VEC_ELS(0x0)) + WORDS_TO_BYTES(offset); offset = base_offset + WORDS_TO_BYTES(offset);
else if (which == 1) else if (which == 1)
offset = offset << LOG_MZCHAR_SIZE; offset = offset << LOG_MZCHAR_SIZE;
jit_movi_l(JIT_V1, offset); jit_movi_l(JIT_V1, offset);
if (!which) { if (!which) {
/* vector-set! is relatively simple and worth inlining */ /* vector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 1); generate_vector_op(jitter, 1, 1, base_offset, unsafe);
CHECK_LIMIT(); CHECK_LIMIT();
} else if (which == 1) { } else if (which == 1) {
(void)jit_calli(string_set_code); (void)jit_calli(string_set_code);

3
src/mzscheme/src/lightning/i386/asm.h
View File

@ -471,6 +471,7 @@ typedef _uc jit_insn;
#define DIVLr(RS) _O_Mrm (0xf7 ,_b11,_b110 ,_r4(RS) ) #define DIVLr(RS) _O_Mrm (0xf7 ,_b11,_b110 ,_r4(RS) )
#define DIVLm(MD,MB,MI,MS) _O_r_X (0xf7 ,_b110 ,MD,MB,MI,MS ) #define DIVLm(MD,MB,MI,MS) _O_r_X (0xf7 ,_b110 ,MD,MB,MI,MS )
#define DIVQr(RS) _qO_Mrm (0xf7 ,_b11,_b110 ,_r8(RS) )
#define ENTERii(W, B) _O_W_B (0xc8 ,_su16(W),_su8(B)) #define ENTERii(W, B) _O_W_B (0xc8 ,_su16(W),_su8(B))
#define HLT_() _O (0xf4 ) #define HLT_() _O (0xf4 )
@ -485,6 +486,8 @@ typedef _uc jit_insn;
#define IDIVLr(RS) _O_Mrm (0xf7 ,_b11,_b111 ,_r4(RS) ) #define IDIVLr(RS) _O_Mrm (0xf7 ,_b11,_b111 ,_r4(RS) )
#define IDIVLm(MD,MB,MI,MS) _O_r_X (0xf7 ,_b111 ,MD,MB,MI,MS ) #define IDIVLm(MD,MB,MI,MS) _O_r_X (0xf7 ,_b111 ,MD,MB,MI,MS )
#define IDIVQr(RS) _qO_Mrm (0xf7 ,_b11,_b111 ,_r8(RS) )
#define IMULBr(RS) _O_Mrm (0xf6 ,_b11,_b101 ,_r1(RS) ) #define IMULBr(RS) _O_Mrm (0xf6 ,_b11,_b101 ,_r1(RS) )
#define IMULBm(MD,MB,MI,MS) _O_r_X (0xf6 ,_b101 ,MD,MB,MI,MS ) #define IMULBm(MD,MB,MI,MS) _O_r_X (0xf6 ,_b101 ,MD,MB,MI,MS )

93
src/mzscheme/src/lightning/i386/core.h
View File

@ -171,64 +171,83 @@ struct jit_local_state {
(MOVLir(is, rs == _EAX ? _EDX : _EAX), \ (MOVLir(is, rs == _EAX ? _EDX : _EAX), \
IMULLr(rs == _EAX ? _EDX : rs)) IMULLr(rs == _EAX ? _EDX : rs))
#define jit_divi_i_(result, d, rs, is) \ #define jit_divi_i_X(result, d, rs, is, MOVr, MOVi, SARi, nbits, IDIVr) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \ (jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \ jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \ jit_might (d, _EDX, PUSHLr(_EDX)), \
jit_might (rs, _EAX, MOVLrr(rs, _EAX)), \ jit_might (rs, _EAX, MOVr(rs, _EAX)), \
jit_might (rs, _EDX, MOVLrr(rs, _EDX)), \ jit_might (rs, _EDX, MOVr(rs, _EDX)), \
MOVLir(is, _ECX), \ MOVr(is, _ECX), \
SARLir(31, _EDX), \ SARi(nbits, _EDX), \
IDIVLr(_ECX), \ IDIVr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \ jit_might(d, result, MOVr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divi_i_(result, d, rs, is) \
jit_divi_i_X(result, d, rs, is, MOVLrr, MOVLir, SARLir, 31, IDIVLr)
#define jit_divi_l_(result, d, rs, is) \
jit_divi_i_X(result, d, rs, is, MOVQrr, MOVQir, SARQir, 31, IDIVQr)
#define jit_divr_i_X(result, d, s1, s2, MOVr, MOVi, SARi, nbits, IDIVr) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \
((s1 == _ECX) ? PUSHLr(_ECX) : 0), \
jit_might (s2, _ECX, MOVr(s2, _ECX)), \
((s1 == _ECX) ? POPLr(_EDX) : \
jit_might (s1, _EDX, MOVr(s1, _EDX))), \
MOVr(_EDX, _EAX), \
SARi(nbits, _EDX), \
IDIVr(_ECX), \
jit_might(d, result, MOVr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \ jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \ jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX))) jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divr_i_(result, d, s1, s2) \ #define jit_divr_i_(result, d, s1, s2) \
jit_divr_i_X(result, d, s1, s2, MOVLrr, MOVLir, SARLir, 31, IDIVLr)
#define jit_divr_l_(result, d, s1, s2) \
jit_divr_i_X(result, d, s1, s2, MOVQrr, MOVQir, SARQir, 63, IDIVQr)
#define jit_divi_ui_X(result, d, rs, is, MOVr, MOVi, XORr, DIVr) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \ (jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \ jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \ jit_might (d, _EDX, PUSHLr(_EDX)), \
((s1 == _ECX) ? PUSHLr(_ECX) : 0), \ jit_might (rs, _EAX, MOVr(rs, _EAX)), \
jit_might (s2, _ECX, MOVLrr(s2, _ECX)), \ MOVi(is, _ECX), \
((s1 == _ECX) ? POPLr(_EDX) : \ XORr(_EDX, _EDX), \
jit_might (s1, _EDX, MOVLrr(s1, _EDX))), \ DIVr(_ECX), \
MOVLrr(_EDX, _EAX), \ jit_might(d, result, MOVr(result, d)), \
SARLir(31, _EDX), \
IDIVLr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \ jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \ jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX))) jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divi_ui_(result, d, rs, is) \ #define jit_divi_ui_(result, d, rs, is) \
jit_divi_ui_X(result, d, rs, is, MOVLrr, MOVLir, XORLrr, DIVLr)
#define jit_divi_ul_(result, d, rs, is) \
jit_divi_ui_X(result, d, rs, is, MOVQrr, MOVQir, XORQrr, DIVQr)
#define jit_divr_ui_X(result, d, s1, s2, MOVr, XORr, DIVr) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \ (jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \ jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \ jit_might (d, _EDX, PUSHLr(_EDX)), \
jit_might (rs, _EAX, MOVLrr(rs, _EAX)), \ ((s1 == _ECX) ? PUSHLr(_ECX) : 0), \
MOVLir(is, _ECX), \ jit_might (s2, _ECX, MOVr(s2, _ECX)), \
XORLrr(_EDX, _EDX), \ ((s1 == _ECX) ? POPLr(_EAX) : \
DIVLr(_ECX), \ jit_might (s1, _EAX, MOVr(s1, _EAX))), \
jit_might(d, result, MOVLrr(result, d)), \ XORr(_EDX, _EDX), \
DIVr(_ECX), \
jit_might(d, result, MOVr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \ jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \ jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX))) jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divr_ui_(result, d, s1, s2) \ #define jit_divr_ui_(result, d, s1, s2) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \ jit_divr_ui_X(result, d, s1, s2, MOVLrr, XORLrr, DIVLr)
jit_might (d, _ECX, PUSHLr(_ECX)), \ #define jit_divr_ul_(result, d, s1, s2) \
jit_might (d, _EDX, PUSHLr(_EDX)), \ jit_divr_ui_X(result, d, s1, s2, MOVQrr, XORQrr, DIVQr)
((s1 == _ECX) ? PUSHLr(_ECX) : 0), \
jit_might (s2, _ECX, MOVLrr(s2, _ECX)), \
((s1 == _ECX) ? POPLr(_EAX) : \
jit_might (s1, _EAX, MOVLrr(s1, _EAX))), \
XORLrr(_EDX, _EDX), \
DIVLr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
/* ALU */ /* ALU */
#define jit_addi_i(d, rs, is) jit_opi_((d), (rs), ADDLir((is), (d)), LEALmr((is), (rs), 0, 0, (d)) ) #define jit_addi_i(d, rs, is) jit_opi_((d), (rs), ADDLir((is), (d)), LEALmr((is), (rs), 0, 0, (d)) )
@ -254,6 +273,8 @@ struct jit_local_state {
#define jit_subr_l(d, s1, s2) jit_qopr_((d), (s1), (s2), (SUBQrr((s1), (d)), NEGQr(d)), SUBQrr((s2), (d)) ) #define jit_subr_l(d, s1, s2) jit_qopr_((d), (s1), (s2), (SUBQrr((s1), (d)), NEGQr(d)), SUBQrr((s2), (d)) )
#define jit_xorr_l(d, s1, s2) jit_qopr_((d), (s1), (s2), XORQrr((s1), (d)), XORQrr((s2), (d)) ) #define jit_xorr_l(d, s1, s2) jit_qopr_((d), (s1), (s2), XORQrr((s1), (d)), XORQrr((s2), (d)) )
#define jit_mulr_l(d, s1, s2) jit_opo_((d), (s1), (s2), IMULQrr((s2), (d)), IMULQrr((s1), (d)), LEAQmr(0, (s1), (s2), 1, (d)) )
/* These can sometimes use byte or word versions! */ /* These can sometimes use byte or word versions! */
#define jit_ori_i(d, rs, is) jit_op_ ((d), (rs), jit_reduce(OR, (is), (d)) ) #define jit_ori_i(d, rs, is) jit_op_ ((d), (rs), jit_reduce(OR, (is), (d)) )
#define jit_xori_i(d, rs, is) jit_op_ ((d), (rs), jit_reduce(XOR, (is), (d)) ) #define jit_xori_i(d, rs, is) jit_op_ ((d), (rs), jit_reduce(XOR, (is), (d)) )
@ -294,8 +315,12 @@ struct jit_local_state {
#define jit_modi_ui(d, rs, is) jit_divi_ui_(_EDX, (d), (rs), (is)) #define jit_modi_ui(d, rs, is) jit_divi_ui_(_EDX, (d), (rs), (is))
#define jit_divr_i(d, s1, s2) jit_divr_i_(_EAX, (d), (s1), (s2)) #define jit_divr_i(d, s1, s2) jit_divr_i_(_EAX, (d), (s1), (s2))
#define jit_divr_ui(d, s1, s2) jit_divr_ui_(_EAX, (d), (s1), (s2)) #define jit_divr_ui(d, s1, s2) jit_divr_ui_(_EAX, (d), (s1), (s2))
#define jit_divr_l(d, s1, s2) jit_divr_l_(_EAX, (d), (s1), (s2))
#define jit_divr_ul(d, s1, s2) jit_divr_ul_(_EAX, (d), (s1), (s2))
#define jit_modr_i(d, s1, s2) jit_divr_i_(_EDX, (d), (s1), (s2)) #define jit_modr_i(d, s1, s2) jit_divr_i_(_EDX, (d), (s1), (s2))
#define jit_modr_ui(d, s1, s2) jit_divr_ui_(_EDX, (d), (s1), (s2)) #define jit_modr_ui(d, s1, s2) jit_divr_ui_(_EDX, (d), (s1), (s2))
#define jit_modr_l(d, s1, s2) jit_divr_l_(_EDX, (d), (s1), (s2))
#define jit_modr_ul(d, s1, s2) jit_divr_ul_(_EDX, (d), (s1), (s2))
/* Shifts */ /* Shifts */

96
src/mzscheme/src/list.c
View File

@ -135,6 +135,15 @@ static Scheme_Object *make_hasheq_placeholder(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_hasheqv_placeholder(int argc, Scheme_Object *argv[]); static Scheme_Object *make_hasheqv_placeholder(int argc, Scheme_Object *argv[]);
static Scheme_Object *table_placeholder_p(int argc, Scheme_Object *argv[]); static Scheme_Object *table_placeholder_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_car (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_cdr (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_mcar (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_mcdr (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_set_mcar (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_set_mcdr (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_unbox (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_set_box (int argc, Scheme_Object *argv[]);
#define BOX "box" #define BOX "box"
#define BOXP "box?" #define BOXP "box?"
#define UNBOX "unbox" #define UNBOX "unbox"
@ -684,6 +693,46 @@ scheme_init_list (Scheme_Env *env)
equal_symbol = scheme_intern_symbol("equal"); equal_symbol = scheme_intern_symbol("equal");
} }
void
scheme_init_unsafe_list (Scheme_Env *env)
{
Scheme_Object *p;
scheme_null->type = scheme_null_type;
p = scheme_make_folding_prim(unsafe_car, "unsafe-car", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("unsafe-car", p, env);
p = scheme_make_folding_prim(unsafe_cdr, "unsafe-cdr", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("unsafe-cdr", p, env);
p = scheme_make_immed_prim(unsafe_mcar, "unsafe-mcar", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("unsafe-mcar", p, env);
p = scheme_make_immed_prim(unsafe_mcdr, "unsafe-mcdr", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("unsafe-mcdr", p, env);
p = scheme_make_immed_prim(unsafe_set_mcar, "unsafe-set-mcar!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant ("unsafe-set-mcar!", p, env);
p = scheme_make_immed_prim(unsafe_set_mcdr, "unsafe-set-mcdr!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant ("unsafe-set-mcdr!", p, env);
p = scheme_make_immed_prim(unsafe_unbox, "unsafe-unbox", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("unsafe-unbox", p, env);
p = scheme_make_immed_prim(unsafe_set_box, "unsafe-set-box!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-set-box!", p, env);
}
Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr) Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
{ {
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
@ -2534,3 +2583,50 @@ void scheme_init_ephemerons(void)
} }
#endif #endif
/************************************************************/
/* unsafe */
/************************************************************/
static Scheme_Object *unsafe_car (int argc, Scheme_Object *argv[])
{
return SCHEME_CAR(argv[0]);
}
static Scheme_Object *unsafe_cdr (int argc, Scheme_Object *argv[])
{
return SCHEME_CDR(argv[0]);
}
static Scheme_Object *unsafe_mcar (int argc, Scheme_Object *argv[])
{
return SCHEME_CAR(argv[0]);
}
static Scheme_Object *unsafe_mcdr (int argc, Scheme_Object *argv[])
{
return SCHEME_CDR(argv[0]);
}
static Scheme_Object *unsafe_set_mcar (int argc, Scheme_Object *argv[])
{
SCHEME_CAR(argv[0]) = argv[1];
return scheme_void;
}
static Scheme_Object *unsafe_set_mcdr (int argc, Scheme_Object *argv[])
{
SCHEME_CDR(argv[0]) = argv[1];
return scheme_void;
}
static Scheme_Object *unsafe_unbox (int argc, Scheme_Object *argv[])
{
return SCHEME_BOX_VAL(argv[0]);
}
static Scheme_Object *unsafe_set_box (int argc, Scheme_Object *argv[])
{
SCHEME_BOX_VAL(argv[0]) = argv[1];
return scheme_void;
}

38
src/mzscheme/src/module.c
View File

@ -132,6 +132,7 @@ static Scheme_Object *kernel_modname;
static Scheme_Object *kernel_symbol; static Scheme_Object *kernel_symbol;
static Scheme_Object *kernel_modidx; static Scheme_Object *kernel_modidx;
static Scheme_Module *kernel; static Scheme_Module *kernel;
static Scheme_Object *unsafe_modname;
/* global read-only symbols */ /* global read-only symbols */
static Scheme_Object *module_symbol; static Scheme_Object *module_symbol;
@ -328,12 +329,14 @@ void scheme_init_module(Scheme_Env *env)
REGISTER_SO(kernel_symbol); REGISTER_SO(kernel_symbol);
REGISTER_SO(kernel_modname); REGISTER_SO(kernel_modname);
REGISTER_SO(kernel_modidx); REGISTER_SO(kernel_modidx);
REGISTER_SO(unsafe_modname);
kernel_symbol = scheme_intern_symbol("#%kernel"); kernel_symbol = scheme_intern_symbol("#%kernel");
kernel_modname = scheme_intern_resolved_module_path(kernel_symbol); kernel_modname = scheme_intern_resolved_module_path(kernel_symbol);
kernel_modidx = scheme_make_modidx(scheme_make_pair(quote_symbol, kernel_modidx = scheme_make_modidx(scheme_make_pair(quote_symbol,
scheme_make_pair(kernel_symbol, scheme_make_pair(kernel_symbol,
scheme_null)), scheme_null)),
scheme_false, kernel_modname); scheme_false, kernel_modname);
unsafe_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%unsafe"));
REGISTER_SO(module_symbol); REGISTER_SO(module_symbol);
REGISTER_SO(module_begin_symbol); REGISTER_SO(module_begin_symbol);
@ -580,6 +583,11 @@ int scheme_is_kernel_modname(Scheme_Object *modname)
return SAME_OBJ(modname, kernel_modname); return SAME_OBJ(modname, kernel_modname);
} }
int scheme_is_unsafe_modname(Scheme_Object *modname)
{
return SAME_OBJ(modname, unsafe_modname);
}
Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env) Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env)
{ {
long phase; long phase;
@ -3480,6 +3488,36 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
return NULL; return NULL;
} }
void scheme_check_unsafe_accessible(Scheme_Object *insp, Scheme_Env *from_env)
{
Scheme_Env *unsafe_env;
unsafe_env = scheme_get_unsafe_env();
if (SCHEME_HASHTRP(insp)) {
Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)insp;
int i;
Scheme_Object *k, *v;
for (i = t->count; i--; ) {
scheme_hash_tree_index(t, i, &k, &v);
insp = k;
if (scheme_module_protected_wrt(unsafe_env->insp, insp)) {
break;
}
}
if (i < 0)
return;
}
if (scheme_module_protected_wrt(unsafe_env->insp, insp)) {
scheme_wrong_syntax("link",
NULL, NULL,
"attempt to access unsafe bindings from an untrusted context");
}
}
int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *varname) int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *varname)
{ {
Scheme_Module *m; Scheme_Module *m;

4
src/mzscheme/src/mzmark.c
View File

@ -2218,6 +2218,7 @@ static int resolve_prefix_val_MARK(void *p) {
gcMARK(rp->toplevels); gcMARK(rp->toplevels);
gcMARK(rp->stxes); gcMARK(rp->stxes);
gcMARK(rp->delay_info_rpair); gcMARK(rp->delay_info_rpair);
gcMARK(rp->uses_unsafe);
return return
gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@ -2228,6 +2229,7 @@ static int resolve_prefix_val_FIXUP(void *p) {
gcFIXUP(rp->toplevels); gcFIXUP(rp->toplevels);
gcFIXUP(rp->stxes); gcFIXUP(rp->stxes);
gcFIXUP(rp->delay_info_rpair); gcFIXUP(rp->delay_info_rpair);
gcFIXUP(rp->uses_unsafe);
return return
gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@ -2246,6 +2248,7 @@ static int comp_prefix_val_MARK(void *p) {
Comp_Prefix *cp = (Comp_Prefix *)p; Comp_Prefix *cp = (Comp_Prefix *)p;
gcMARK(cp->toplevels); gcMARK(cp->toplevels);
gcMARK(cp->stxes); gcMARK(cp->stxes);
gcMARK(cp->uses_unsafe);
return return
gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); gcBYTES_TO_WORDS(sizeof(Comp_Prefix));
@ -2255,6 +2258,7 @@ static int comp_prefix_val_FIXUP(void *p) {
Comp_Prefix *cp = (Comp_Prefix *)p; Comp_Prefix *cp = (Comp_Prefix *)p;
gcFIXUP(cp->toplevels); gcFIXUP(cp->toplevels);
gcFIXUP(cp->stxes); gcFIXUP(cp->stxes);
gcFIXUP(cp->uses_unsafe);
return return
gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); gcBYTES_TO_WORDS(sizeof(Comp_Prefix));

2
src/mzscheme/src/mzmarksrc.c
View File

@ -884,6 +884,7 @@ resolve_prefix_val {
gcMARK(rp->toplevels); gcMARK(rp->toplevels);
gcMARK(rp->stxes); gcMARK(rp->stxes);
gcMARK(rp->delay_info_rpair); gcMARK(rp->delay_info_rpair);
gcMARK(rp->uses_unsafe);
size: size:
gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@ -894,6 +895,7 @@ comp_prefix_val {
Comp_Prefix *cp = (Comp_Prefix *)p; Comp_Prefix *cp = (Comp_Prefix *)p;
gcMARK(cp->toplevels); gcMARK(cp->toplevels);
gcMARK(cp->stxes); gcMARK(cp->stxes);
gcMARK(cp->uses_unsafe);
size: size:
gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); gcBYTES_TO_WORDS(sizeof(Comp_Prefix));

109
src/mzscheme/src/numarith.c
View File

@ -35,6 +35,17 @@ static Scheme_Object *quotient (int argc, Scheme_Object *argv[]);
static Scheme_Object *rem_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *rem_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *quotient_remainder (int argc, Scheme_Object *argv[]); static Scheme_Object *quotient_remainder (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_plus (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_mult (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_div (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_rem (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_plus (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_mult (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_div (int argc, Scheme_Object *argv[]);
#define zeroi scheme_exact_zero #define zeroi scheme_exact_zero
void scheme_init_numarith(Scheme_Env *env) void scheme_init_numarith(Scheme_Env *env)
@ -70,16 +81,14 @@ void scheme_init_numarith(Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("abs", p, env); scheme_add_global_constant("abs", p, env);
scheme_add_global_constant("quotient", p = scheme_make_folding_prim(quotient, "quotient", 2, 2, 1);
scheme_make_folding_prim(quotient, SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
"quotient", scheme_add_global_constant("quotient", p, env);
2, 2, 1),
env); p = scheme_make_folding_prim(rem_prim, "remainder", 2, 2, 1);
scheme_add_global_constant("remainder", SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_make_folding_prim(rem_prim, scheme_add_global_constant("remainder", p, env);
"remainder",
2, 2, 1),
env);
scheme_add_global_constant("quotient/remainder", scheme_add_global_constant("quotient/remainder",
scheme_make_prim_w_arity2(quotient_remainder, scheme_make_prim_w_arity2(quotient_remainder,
"quotient/remainder", "quotient/remainder",
@ -93,6 +102,53 @@ void scheme_init_numarith(Scheme_Env *env)
env); env);
} }
void scheme_init_unsafe_numarith(Scheme_Env *env)
{
Scheme_Object *p;
p = scheme_make_folding_prim(fx_plus, "unsafe-fx+", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx+", p, env);
p = scheme_make_folding_prim(fx_minus, "unsafe-fx-", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNARY_INLINED);
scheme_add_global_constant("unsafe-fx-", p, env);
p = scheme_make_folding_prim(fx_mult, "unsafe-fx*", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx*", p, env);
p = scheme_make_folding_prim(fx_div, "unsafe-fxquotient", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxquotient", p, env);
p = scheme_make_folding_prim(fx_rem, "unsafe-fxremainder", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxremainder", p, env);
p = scheme_make_folding_prim(fl_plus, "unsafe-fl+", 2, 2, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl+", p, env);
p = scheme_make_folding_prim(fl_minus, "unsafe-fl-", 2, 2, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl-", p, env);
p = scheme_make_folding_prim(fl_mult, "unsafe-fl*", 2, 2, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl*", p, env);
p = scheme_make_folding_prim(fl_div, "unsafe-fl/", 2, 2, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl/", p, env);
}
Scheme_Object * Scheme_Object *
scheme_add1 (int argc, Scheme_Object *argv[]) scheme_add1 (int argc, Scheme_Object *argv[])
{ {
@ -707,3 +763,36 @@ quotient_remainder(int argc, Scheme_Object *argv[])
a[1] = rem; a[1] = rem;
return scheme_values(2, a); return scheme_values(2, a);
} }
/************************************************************************/
/* Unsafe */
/************************************************************************/
#define UNSAFE_FX(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long v; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
v = SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1]); \
return scheme_make_integer(v); \
}
UNSAFE_FX(fx_plus, +, plus)
UNSAFE_FX(fx_minus, -, minus)
UNSAFE_FX(fx_mult, *, mult)
UNSAFE_FX(fx_div, /, quotient)
UNSAFE_FX(fx_rem, %, rem_prim)
#define UNSAFE_FL(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
double v; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
v = SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1]); \
return scheme_make_double(v); \
}
UNSAFE_FL(fl_plus, +, plus)
UNSAFE_FL(fl_minus, -, minus)
UNSAFE_FL(fl_mult, *, mult)
UNSAFE_FL(fl_div, /, div_prim)

75
src/mzscheme/src/number.c
View File

@ -98,6 +98,13 @@ static Scheme_Object *angle (int argc, Scheme_Object *argv[]);
static Scheme_Object *int_sqrt (int argc, Scheme_Object *argv[]); static Scheme_Object *int_sqrt (int argc, Scheme_Object *argv[]);
static Scheme_Object *int_sqrt_rem (int argc, Scheme_Object *argv[]); static Scheme_Object *int_sqrt_rem (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_and (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_or (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_xor (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_not (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_lshift (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_rshift (int argc, Scheme_Object *argv[]);
static double not_a_number_val; static double not_a_number_val;
Scheme_Object *scheme_inf_object, *scheme_minus_inf_object, *scheme_nan_object; Scheme_Object *scheme_inf_object, *scheme_minus_inf_object, *scheme_nan_object;
@ -482,6 +489,36 @@ scheme_init_number (Scheme_Env *env)
env); env);
} }
void scheme_init_unsafe_number(Scheme_Env *env)
{
Scheme_Object *p;
p = scheme_make_folding_prim(fx_and, "unsafe-fxand", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxand", p, env);
p = scheme_make_folding_prim(fx_or, "unsafe-fxior", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxior", p, env);
p = scheme_make_folding_prim(fx_xor, "unsafe-fxxor", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxxor", p, env);
p = scheme_make_folding_prim(fx_not, "unsafe-fxnot", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("unsafe-fxnot", p, env);
p = scheme_make_folding_prim(fx_lshift, "unsafe-fxlshift", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxlshift", p, env);
p = scheme_make_folding_prim(fx_rshift, "unsafe-fxrshift", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxrshift", p, env);
}
Scheme_Object * Scheme_Object *
scheme_make_integer_value(long i) scheme_make_integer_value(long i)
@ -2723,3 +2760,41 @@ long scheme_integer_length(Scheme_Object *n)
r = integer_length(1, a); r = integer_length(1, a);
return SCHEME_INT_VAL(r); return SCHEME_INT_VAL(r);
} }
/************************************************************************/
/* Unsafe */
/************************************************************************/
#define UNSAFE_FX(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long v; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
v = SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1]); \
return scheme_make_integer(v); \
}
UNSAFE_FX(fx_and, &, scheme_bitwise_and)
UNSAFE_FX(fx_or, |, bitwise_or)
UNSAFE_FX(fx_xor, ^, bitwise_xor)
UNSAFE_FX(fx_lshift, <<, scheme_bitwise_shift)
static Scheme_Object *neg_bitwise_shift(int argc, Scheme_Object *argv[])
{
Scheme_Object *a[2];
a[0] = argv[0];
a[1] = scheme_bin_minus(scheme_make_integer(0), argv[1]);
return scheme_bitwise_shift(argc, a);
}
UNSAFE_FX(fx_rshift, >>, neg_bitwise_shift)
static Scheme_Object *fx_not (int argc, Scheme_Object *argv[])
{
long v;
if (scheme_current_thread->constant_folding) return bitwise_not(argc, argv);
v = SCHEME_INT_VAL(argv[0]);
v = ~v;
return scheme_make_integer(v);
}

98
src/mzscheme/src/numcomp.c
View File

@ -38,6 +38,18 @@ static Scheme_Object *negative_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *sch_max (int argc, Scheme_Object *argv[]); static Scheme_Object *sch_max (int argc, Scheme_Object *argv[]);
static Scheme_Object *sch_min (int argc, Scheme_Object *argv[]); static Scheme_Object *sch_min (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_gt_eq (int argc, Scheme_Object *argv[]);
#define zeroi scheme_exact_zero #define zeroi scheme_exact_zero
void scheme_init_numcomp(Scheme_Env *env) void scheme_init_numcomp(Scheme_Env *env)
@ -85,6 +97,56 @@ void scheme_init_numcomp(Scheme_Env *env)
scheme_add_global_constant("min", p, env); scheme_add_global_constant("min", p, env);
} }
void scheme_init_unsafe_numcomp(Scheme_Env *env)
{
Scheme_Object *p;
p = scheme_make_folding_prim(fx_eq, "unsafe-fx=", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx=", p, env);
p = scheme_make_folding_prim(fx_lt, "unsafe-fx<", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx<", p, env);
p = scheme_make_folding_prim(fx_gt, "unsafe-fx>", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx>", p, env);
p = scheme_make_folding_prim(fx_lt_eq, "unsafe-fx<=", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx<=", p, env);
p = scheme_make_folding_prim(fx_gt_eq, "unsafe-fx>=", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx>=", p, env);
p = scheme_make_folding_prim(fl_eq, "unsafe-fl=", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl=", p, env);
p = scheme_make_folding_prim(fl_lt, "unsafe-fl<", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl<", p, env);
p = scheme_make_folding_prim(fl_gt, "unsafe-fl>", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl>", p, env);
p = scheme_make_folding_prim(fl_lt_eq, "unsafe-fl<=", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl<=", p, env);
p = scheme_make_folding_prim(fl_gt_eq, "unsafe-fl>=", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl>=", p, env);
}
/* Prototype needed for 3m conversion: */ /* Prototype needed for 3m conversion: */
static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr); static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr);
@ -294,3 +356,39 @@ static GEN_BIN_OP(bin_min, "min", MIN, F_MIN, FS_MIN, scheme_bignum_min, scheme_
GEN_TWOARY_OP(static, sch_max, "max", bin_max, SCHEME_REALP, REAL_NUMBER_STR) GEN_TWOARY_OP(static, sch_max, "max", bin_max, SCHEME_REALP, REAL_NUMBER_STR)
GEN_TWOARY_OP(static, sch_min, "min", bin_min, SCHEME_REALP, REAL_NUMBER_STR) GEN_TWOARY_OP(static, sch_min, "min", bin_min, SCHEME_REALP, REAL_NUMBER_STR)
/************************************************************************/
/* Unsafe */
/************************************************************************/
#define UNSAFE_FX(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1]) ? scheme_true : scheme_false); \
if (SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1])) \
return scheme_true; \
else \
return scheme_false; \
}
UNSAFE_FX(fx_eq, ==, scheme_bin_eq)
UNSAFE_FX(fx_lt, <, scheme_bin_lt)
UNSAFE_FX(fx_gt, >, scheme_bin_gt)
UNSAFE_FX(fx_lt_eq, <=, scheme_bin_lt_eq)
UNSAFE_FX(fx_gt_eq, >=, scheme_bin_gt_eq)
#define UNSAFE_FL(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1]) ? scheme_true : scheme_false); \
if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
return scheme_true; \
else \
return scheme_false; \
}
UNSAFE_FL(fl_eq, ==, scheme_bin_eq)
UNSAFE_FL(fl_lt, <, scheme_bin_lt)
UNSAFE_FL(fl_gt, >, scheme_bin_gt)
UNSAFE_FL(fl_lt_eq, <=, scheme_bin_lt_eq)
UNSAFE_FL(fl_gt_eq, >=, scheme_bin_gt_eq)

1
src/mzscheme/src/print.c
View File

@ -808,6 +808,7 @@ print_to_string(Scheme_Object *obj,
params.case_sens = 1; params.case_sens = 1;
params.honu_mode = 0; params.honu_mode = 0;
params.inspector = scheme_false; params.inspector = scheme_false;
params.print_syntax = -1;
} else { } else {
config = scheme_current_config(); config = scheme_current_config();

8
src/mzscheme/src/read.c
View File

@ -4681,7 +4681,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
break; break;
case CPT_REFERENCE: case CPT_REFERENCE:
l = read_compact_number(port); l = read_compact_number(port);
RANGE_CHECK(l, < EXPECTED_PRIM_COUNT); RANGE_CHECK(l, < (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT));
return variable_references[l]; return variable_references[l];
break; break;
case CPT_LOCAL: case CPT_LOCAL:
@ -5081,6 +5081,12 @@ static Scheme_Object *read_marshalled(int type, CPort *port)
if (!l) if (!l)
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
if (type == scheme_resolve_prefix_type) {
/* If unsafe_insp is set, need to use the one in port: */
if (((Resolve_Prefix *)l)->uses_unsafe)
((Resolve_Prefix *)l)->uses_unsafe = port->insp;
}
return l; return l;
} }

1
src/mzscheme/src/schminc.h
View File

@ -14,6 +14,7 @@
#define USE_COMPILED_STARTUP 1 #define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 959 #define EXPECTED_PRIM_COUNT 959
#define EXPECTED_UNSAFE_COUNT 38
#ifdef MZSCHEME_SOMETHING_OMITTED #ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP # undef USE_COMPILED_STARTUP

19
src/mzscheme/src/schpriv.h
View File

@ -171,6 +171,7 @@ void scheme_init_symbol_table(void);
void scheme_init_symbol_type(Scheme_Env *env); void scheme_init_symbol_type(Scheme_Env *env);
void scheme_init_type(); void scheme_init_type();
void scheme_init_list(Scheme_Env *env); void scheme_init_list(Scheme_Env *env);
void scheme_init_unsafe_list(Scheme_Env *env);
void scheme_init_stx(Scheme_Env *env); void scheme_init_stx(Scheme_Env *env);
void scheme_init_module(Scheme_Env *env); void scheme_init_module(Scheme_Env *env);
void scheme_init_module_path_table(void); void scheme_init_module_path_table(void);
@ -180,10 +181,14 @@ void scheme_init_network(Scheme_Env *env);
void scheme_init_file(Scheme_Env *env); void scheme_init_file(Scheme_Env *env);
void scheme_init_proc(Scheme_Env *env); void scheme_init_proc(Scheme_Env *env);
void scheme_init_vector(Scheme_Env *env); void scheme_init_vector(Scheme_Env *env);
void scheme_init_unsafe_vector(Scheme_Env *env);
void scheme_init_string(Scheme_Env *env); void scheme_init_string(Scheme_Env *env);
void scheme_init_number(Scheme_Env *env); void scheme_init_number(Scheme_Env *env);
void scheme_init_numarith(Scheme_Env *env); void scheme_init_numarith(Scheme_Env *env);
void scheme_init_unsafe_numarith(Scheme_Env *env);
void scheme_init_unsafe_number(Scheme_Env *env);
void scheme_init_numcomp(Scheme_Env *env); void scheme_init_numcomp(Scheme_Env *env);
void scheme_init_unsafe_numcomp(Scheme_Env *env);
void scheme_init_numstr(Scheme_Env *env); void scheme_init_numstr(Scheme_Env *env);
void scheme_init_eval(Scheme_Env *env); void scheme_init_eval(Scheme_Env *env);
void scheme_init_promise(Scheme_Env *env); void scheme_init_promise(Scheme_Env *env);
@ -1828,6 +1833,7 @@ typedef struct Comp_Prefix
int num_toplevels, num_stxes; int num_toplevels, num_stxes;
Scheme_Hash_Table *toplevels; /* buckets for toplevel/module variables */ Scheme_Hash_Table *toplevels; /* buckets for toplevel/module variables */
Scheme_Hash_Table *stxes; /* syntax objects */ Scheme_Hash_Table *stxes; /* syntax objects */
Scheme_Object *uses_unsafe; /* NULL, inspector, or hashtree of inspectors */
} Comp_Prefix; } Comp_Prefix;
typedef struct Scheme_Comp_Env typedef struct Scheme_Comp_Env
@ -1900,6 +1906,7 @@ typedef struct Resolve_Prefix
Scheme_Object **toplevels; Scheme_Object **toplevels;
Scheme_Object **stxes; /* simplified */ Scheme_Object **stxes; /* simplified */
Scheme_Object *delay_info_rpair; /* (rcons refcount Scheme_Load_Delay*) */ Scheme_Object *delay_info_rpair; /* (rcons refcount Scheme_Load_Delay*) */
Scheme_Object *uses_unsafe; /* non-NULL => inspector or hashtree of inspectors for accessing #%unsafe bindings */
} Resolve_Prefix; } Resolve_Prefix;
typedef struct Resolve_Info typedef struct Resolve_Info
@ -2086,6 +2093,8 @@ Scheme_Object *scheme_lookup_binding(Scheme_Object *symbol, Scheme_Comp_Env *env
Scheme_Env **_menv, int *_protected, Scheme_Env **_menv, int *_protected,
Scheme_Object **_lexical_binding_id); Scheme_Object **_lexical_binding_id);
Scheme_Object *scheme_extract_unsafe(Scheme_Object *o);
Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env, Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
Scheme_Comp_Env *upto); Scheme_Comp_Env *upto);
@ -2137,6 +2146,9 @@ Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Com
Scheme_Compile_Info *rec, int drec); Scheme_Compile_Info *rec, int drec);
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec); Scheme_Compile_Info *rec, int drec);
void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec,
Scheme_Env *menv);
void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a,
Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Env *exp_env, Scheme_Object *insp,
@ -2753,6 +2765,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
int position, int want_pos, int position, int want_pos,
int *_protected, int *_unexported, int *_protected, int *_unexported,
Scheme_Env *from_env, int *_would_complain); Scheme_Env *from_env, int *_would_complain);
void scheme_check_unsafe_accessible(Scheme_Object *insp, Scheme_Env *from_env);
Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name); Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name);
Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,
@ -2769,7 +2782,7 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
Scheme_Env *scheme_get_kernel_env(); Scheme_Env *scheme_get_kernel_env();
int scheme_is_kernel_env(); int scheme_is_kernel_env();
Scheme_Env *scheme_get_unsafe_env();
void scheme_install_initial_module_set(Scheme_Env *env); void scheme_install_initial_module_set(Scheme_Env *env);
Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home); Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home);
@ -2781,6 +2794,7 @@ void scheme_clean_dead_env(Scheme_Env *env);
Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o); Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o);
int scheme_is_kernel_modname(Scheme_Object *modname); int scheme_is_kernel_modname(Scheme_Object *modname);
int scheme_is_unsafe_modname(Scheme_Object *modname);
void scheme_clear_modidx_cache(void); void scheme_clear_modidx_cache(void);
void scheme_clear_shift_cache(void); void scheme_clear_shift_cache(void);
@ -3185,6 +3199,9 @@ unsigned short * scheme_ucs4_to_utf16(const mzchar *text, int start, int end,
Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]);
int scheme_can_inline_fp_op();
int scheme_can_inline_fp_comp();
/*========================================================================*/ /*========================================================================*/
/* places */ /* places */
/*========================================================================*/ /*========================================================================*/

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "4.2.1.7" #define MZSCHEME_VERSION "4.2.1.8"
#define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 1 #define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 7 #define MZSCHEME_VERSION_W 8
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

1
src/mzscheme/src/startup.inc
View File

@ -391,6 +391,7 @@
"(module #%builtin '#%kernel" "(module #%builtin '#%kernel"
"(#%require '#%expobs" "(#%require '#%expobs"
"(only '#%foreign) " "(only '#%foreign) "
"(only '#%unsafe) "
" '#%paramz" " '#%paramz"
" '#%network" " '#%network"
" '#%utils" " '#%utils"

1
src/mzscheme/src/startup.ss
View File

@ -465,6 +465,7 @@
(module #%builtin '#%kernel (module #%builtin '#%kernel
(#%require '#%expobs (#%require '#%expobs
(only '#%foreign) ; so it's attached, but doesn't depend on any exports (only '#%foreign) ; so it's attached, but doesn't depend on any exports
(only '#%unsafe) ; ditto
'#%paramz '#%paramz
'#%network '#%network
'#%utils '#%utils

77
src/mzscheme/src/vector.c
View File

@ -42,6 +42,12 @@ static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_struct_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_struct_set (int argc, Scheme_Object *argv[]);
void void
scheme_init_vector (Scheme_Env *env) scheme_init_vector (Scheme_Env *env)
{ {
@ -122,6 +128,45 @@ scheme_init_vector (Scheme_Env *env)
env); env);
} }
void
scheme_init_unsafe_vector (Scheme_Env *env)
{
Scheme_Object *p;
p = scheme_make_immed_prim(unsafe_vector_len,
"unsafe-vector-length",
1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("unsafe-vector-length", p, env);
p = scheme_make_immed_prim(unsafe_vector_ref,
"unsafe-vector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-vector-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_set,
"unsafe-vector-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-vector-set!", p, env);
p = scheme_make_immed_prim(unsafe_vector_ref,
"unsafe-vector-ref",
2, 2);
p = scheme_make_immed_prim(unsafe_struct_ref,
"unsafe-struct-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-struct-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_set,
"unsafe-struct-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-struct-set!", p, env);
}
Scheme_Object * Scheme_Object *
scheme_make_vector (long size, Scheme_Object *fill) scheme_make_vector (long size, Scheme_Object *fill)
{ {
@ -475,3 +520,35 @@ static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
return SCHEME_MULTIPLE_VALUES; return SCHEME_MULTIPLE_VALUES;
} }
/************************************************************/
/* unsafe */
/************************************************************/
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[])
{
long n = SCHEME_VEC_SIZE(argv[0]);
return scheme_make_integer(n);
}
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[])
{
return SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])];
}
static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[])
{
SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])] = argv[2];
return scheme_void;
}
static Scheme_Object *unsafe_struct_ref (int argc, Scheme_Object *argv[])
{
return ((Scheme_Structure *)argv[0])->slots[SCHEME_INT_VAL(argv[1])];
}
static Scheme_Object *unsafe_struct_set (int argc, Scheme_Object *argv[])
{
((Scheme_Structure *)argv[0])->slots[SCHEME_INT_VAL(argv[1])] = argv[2];
return scheme_void;
}