diff --git a/racket/src/cs/primitive/internal.ss b/racket/src/cs/primitive/internal.ss index 5a9b82aee1..54aabd258a 100644 --- a/racket/src/cs/primitive/internal.ss +++ b/racket/src/cs/primitive/internal.ss @@ -36,4 +36,26 @@ [break-enabled-key (known-constant)] [engine-block (known-procedure 1)] - [force-unfasl (known-procedure 2)]) + [force-unfasl (known-procedure 2)] + + [ptr-ref/int8 (known-procedure 8)] + [ptr-ref/uint8 (known-procedure 8)] + [ptr-ref/int16 (known-procedure 8)] + [ptr-ref/uint16 (known-procedure 8)] + [ptr-ref/int32 (known-procedure 8)] + [ptr-ref/uint32 (known-procedure 8)] + [ptr-ref/int64 (known-procedure 8)] + [ptr-ref/uint64 (known-procedure 8)] + [ptr-ref/double (known-procedure 8)] + [ptr-ref/float (known-procedure 8)] + + [ptr-set!/int8 (known-procedure 16)] + [ptr-set!/uint8 (known-procedure 16)] + [ptr-set!/int16 (known-procedure 16)] + [ptr-set!/uint16 (known-procedure 16)] + [ptr-set!/int32 (known-procedure 16)] + [ptr-set!/uint32 (known-procedure 16)] + [ptr-set!/int64 (known-procedure 16)] + [ptr-set!/uint64 (known-procedure 16)] + [ptr-set!/double (known-procedure 16)] + [ptr-set!/float (known-procedure 16)]) diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index d99787ec93..f0bf4a36fd 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -622,6 +622,17 @@ set-make-async-callback-poll-wakeup! ; not exported to Racket set-foreign-eval! ; not exported to Racket + ptr-ref/int8 ptr-set!/int8 ; not exported to Racket + ptr-ref/uint8 ptr-set!/uint8 ; not exported to Racket + ptr-ref/int16 ptr-set!/int16 ; not exported to Racket + ptr-ref/uint16 ptr-set!/uint16 ; not exported to Racket + ptr-ref/int32 ptr-set!/int32 ; not exported to Racket + ptr-ref/uint32 ptr-set!/uint32 ; not exported to Racket + ptr-ref/int64 ptr-set!/int64 ; not exported to Racket + ptr-ref/uint64 ptr-set!/uint64 ; not exported to Racket + ptr-ref/double ptr-set!/double ; not exported to Racket + ptr-ref/float ptr-set!/float ; not exported to Racket + unsafe-unbox unsafe-unbox* unsafe-set-box! diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index 7ea924c82c..6b535840e5 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -936,6 +936,63 @@ offset v)])) +(define-syntax-rule (define-fast-ptr-ops ref set _type ok-v? bytes-ref bytes-set foreign-type type-bits) + (begin + (define (ref p offset abs?) + (let ([simple-p (if (bytevector? p) + p + (and (authentic-cpointer? p) + (let ([m (cpointer-memory p)]) + (and (or (bytevector? m) + (exact-integer? m)) + m))))]) + (cond + [(and simple-p + (fixnum? offset) + (or (not abs?) (fx= 0 (fxand offset (fx- (fxsll 1 type-bits) 1))))) + (if (bytevector? simple-p) + (bytes-ref simple-p (if abs? offset (fxsrl offset type-bits))) + (foreign-ref 'foreign-type simple-p (if abs? offset (fxsll offset type-bits))))] + [else + (if abs? + (ptr-ref p _type 'abs offset) + (ptr-ref p _type offset))]))) + (define (set p offset v abs?) + (let ([simple-p (if (bytevector? p) + p + (and (authentic-cpointer? p) + (let ([m (cpointer-memory p)]) + (and (or (bytevector? m) + (exact-integer? m)) + m))))]) + (cond + [(and simple-p + (fixnum? offset) + (or (not abs?) (fx= 0 (fxand offset (fx- (fxsll 1 type-bits) 1)))) + (ok-v? v)) + (if (bytevector? simple-p) + (bytes-set simple-p (if abs? offset (fxsrl offset type-bits)) v) + (foreign-set! 'foreign-type simple-p (if abs? offset (fxsll offset type-bits)) v))] + [else + (if abs? + (ptr-set! p _type 'abs offset v) + (ptr-set! p _type offset v))]))))) + +(define (fixnum-in-range? lo hi) (lambda (v) (and (fixnum? v) (fx>= v lo) (fx>= v hi)))) +(define (in-range? lo hi) (lambda (v) (and (exact-integer? v) (fx>= v lo) (fx>= v hi)))) + +;; Schemify optimizes `(ptr-ref p _uint16 offset v)` to `(ptr-set!/uint16 p (fxlshift offset 1) v #f)`, etc. +(define-fast-ptr-ops ptr-ref/int8 ptr-set!/int8 _int8 (fixnum-in-range? -128 127) bytevector-s8-ref bytevector-s8-set! integer-8 0) +(define-fast-ptr-ops ptr-ref/uint8 ptr-set!/uint8 _uint8 byte? bytevector-u8-ref bytevector-u8-set! unsigned-8 0) +(define-fast-ptr-ops ptr-ref/int16 ptr-set!/int16 _int16 (fixnum-in-range? -32768 32767) bytevector-s16-native-ref bytevector-s16-native-set! integer-16 1) +(define-fast-ptr-ops ptr-ref/uint16 ptr-set!/uint16 _uint16 (fixnum-in-range? 0 65535) bytevector-u16-native-ref bytevector-u16-native-set! unsigned-16 1) +(define-fast-ptr-ops ptr-ref/int32 ptr-set!/int32 _int32 (in-range? -2147483648 2147483647) bytevector-s32-native-ref bytevector-s32-native-set! integer-32 2) +(define-fast-ptr-ops ptr-ref/uint32 ptr-set!/uint32 _uint32 (in-range? 0 4294967296) bytevector-u32-native-ref bytevector-u32-native-set! unsigned-32 2) +(define-fast-ptr-ops ptr-ref/int64 ptr-set!/int64 _int64 (in-range? -9223372036854775808 9223372036854775807) bytevector-s64-native-ref bytevector-s64-native-set! integer-64 3) +(define-fast-ptr-ops ptr-ref/uint64 ptr-set!/uint64 _uint64 (in-range? 0 18446744073709551616) bytevector-u64-native-ref bytevector-u64-native-set! unsigned-64 3) +(define-fast-ptr-ops ptr-ref/double ptr-set!/double _double flonum? bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! double 3) +(define-fast-ptr-ops ptr-ref/float ptr-set!/float _float flonum? bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! float 3) + (define ptr-size-in-bytes (foreign-sizeof 'void*)) (define log-ptr-size-in-bytes (- (integer-length ptr-size-in-bytes) 1)) diff --git a/racket/src/cs/rumble/number.ss b/racket/src/cs/rumble/number.ss index 90ce2469f1..5a35f3a1e0 100644 --- a/racket/src/cs/rumble/number.ss +++ b/racket/src/cs/rumble/number.ss @@ -1,11 +1,11 @@ (define (nonnegative-fixnum? n) (and (fixnum? n) (fx>= n 0))) -(define (exact-integer? n) (and (integer? n) (exact? n))) +(define (exact-integer? n) (or (fixnum? n) (bignum? n))) (define (exact-nonnegative-integer? n) (and (exact-integer? n) (>= n 0))) (define (exact-positive-integer? n) (and (exact-integer? n) (> n 0))) (define (inexact-real? n) (and (real? n) (inexact? n))) -(define (byte? n) (and (exact-integer? n) (>= n 0) (<= n 255))) +(define (byte? n) (and (fixnum? n) (fx>= n 0) (fx<= n 255))) (define (double-flonum? x) (flonum? x)) (define (single-flonum? x) #f) diff --git a/racket/src/expander/compile/built-in-symbol.rkt b/racket/src/expander/compile/built-in-symbol.rkt index 1122701260..87c18347cf 100644 --- a/racket/src/expander/compile/built-in-symbol.rkt +++ b/racket/src/expander/compile/built-in-symbol.rkt @@ -82,4 +82,15 @@ register-struct-predicate! register-struct-field-accessor! register-struct-field-mutator! - raise-binding-result-arity-error)))) + raise-binding-result-arity-error + + ptr-ref/int8 ptr-set!/int8 + ptr-ref/uint8 ptr-set!/uint8 + ptr-ref/int16 ptr-set!/int16 + ptr-ref/uint16 ptr-set!/uint16 + ptr-ref/int32 ptr-set!/int32 + ptr-ref/uint32 ptr-set!/uint32 + ptr-ref/int64 ptr-set!/int64 + ptr-ref/uint64 ptr-set!/uint64 + ptr-ref/double ptr-set!/double + ptr-ref/float ptr-set!/float)))) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 3ab32ba29b..166fd137a5 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -19848,7 +19848,27 @@ static const char *startup_source = " register-struct-predicate!" " register-struct-field-accessor!" " register-struct-field-mutator!" -" raise-binding-result-arity-error))))" +" raise-binding-result-arity-error" +" ptr-ref/int8" +" ptr-set!/int8" +" ptr-ref/uint8" +" ptr-set!/uint8" +" ptr-ref/int16" +" ptr-set!/int16" +" ptr-ref/uint16" +" ptr-set!/uint16" +" ptr-ref/int32" +" ptr-set!/int32" +" ptr-ref/uint32" +" ptr-set!/uint32" +" ptr-ref/int64" +" ptr-set!/int64" +" ptr-ref/uint64" +" ptr-set!/uint64" +" ptr-ref/double" +" ptr-set!/double" +" ptr-ref/float" +" ptr-set!/float))))" "(define-values(phase-shift-id)(make-built-in-symbol! 'phase))" "(define-values(dest-phase-id)(make-built-in-symbol! 'dest-phase))" "(define-values(ns-id)(make-built-in-symbol! 'namespace))" diff --git a/racket/src/schemify/ptr-ref-set.rkt b/racket/src/schemify/ptr-ref-set.rkt new file mode 100644 index 0000000000..29df21fa46 --- /dev/null +++ b/racket/src/schemify/ptr-ref-set.rkt @@ -0,0 +1,48 @@ +#lang racket/base +(require "match.rkt" + "wrap.rkt") + +(provide inline-ptr-ref + inline-ptr-set) + +(define (inline-ptr-ref args) + (match args + [`(,ptr-e ,type-e (quote abs) ,offset-e) + (type->direct type-e ptr-e offset-e #t make-ref #f)] + [`(,ptr-e ,type-e ,offset-e) + (type->direct type-e ptr-e offset-e #f make-ref #f)] + [`(,ptr-e ,type-e) + (type->direct type-e ptr-e 0 #f make-ref #f)] + [`,_ #f])) + +(define (make-ref ref set ptr-e offset-e val-e abs?) + `(,ref ,ptr-e ,offset-e ,abs?)) + +(define (inline-ptr-set args) + (match args + [`(,ptr-e ,type-e (quote abs) ,offset-e ,val-e) + (type->direct type-e ptr-e offset-e #t make-set val-e)] + [`(,ptr-e ,type-e ,offset-e, val-e) + (type->direct type-e ptr-e offset-e #f make-set val-e)] + [`(,ptr-e ,type-e ,val-e) + (type->direct type-e ptr-e 0 #f make-set val-e)] + [`,_ #f])) + +(define (make-set ref set ptr-e offset-e val-e abs?) + `(,set ,ptr-e ,offset-e ,val-e ,abs?)) + +(define (type->direct type-e ptr-e offset-e abs? make val-e) + (define (do-make ref set) + (make ref set ptr-e offset-e val-e abs?)) + (case (unwrap type-e) + [(_int8) (do-make 'ptr-ref/int8 'ptr-set!/int8)] + [(_uint8) (do-make 'ptr-ref/uint8 'ptr-set!/uint8)] + [(_int16) (do-make 'ptr-ref/int16 'ptr-set!/int16)] + [(_uint16) (do-make 'ptr-ref/uint16 'ptr-set!/uint16)] + [(_int32) (do-make 'ptr-ref/int32 'ptr-set!/int32)] + [(_uint32) (do-make 'ptr-ref/uint32 'ptr-set!/uint32)] + [(_int64) (do-make 'ptr-ref/int64 'ptr-set!/int64)] + [(_uint64) (do-make 'ptr-ref/uint64 'ptr-set!/uint64)] + [(_double) (do-make 'ptr-ref/double 'ptr-set!/double)] + [(_float) (do-make 'ptr-ref/float 'ptr-set!/float)] + [else #f])) diff --git a/racket/src/schemify/schemify.rkt b/racket/src/schemify/schemify.rkt index 90e7082d89..1e76926a9a 100644 --- a/racket/src/schemify/schemify.rkt +++ b/racket/src/schemify/schemify.rkt @@ -19,7 +19,8 @@ "infer-known.rkt" "inline.rkt" "letrec.rkt" - "infer-name.rkt") + "infer-name.rkt" + "ptr-ref-set.rkt") (provide schemify-linklet schemify-body) @@ -770,6 +771,13 @@ [u-rator (unwrap rator)]) (define-values (k im) (find-known+import u-rator prim-knowns knowns imports mutated)) (cond + [(or (and (eq? rator 'ptr-ref) (inline-ptr-ref args)) + (and (eq? rator 'ptr-set!) (inline-ptr-set args))) + => (lambda (e) + (left-to-right/app (car e) + (cdr e) + #t for-cify? + prim-knowns knowns imports mutated))] [(and (not for-cify?) (known-field-accessor? k) (inline-field-access k s-rator im args)) @@ -812,6 +820,10 @@ ;; need to handle it here before generating a ;; reference to the renamed identifier (known-literal-expr k)] + [(and (known-copy? k) + (hash-ref prim-knowns (known-copy-id k) #f)) + ;; Directly reference primitive + (known-copy-id k)] [else (import-id im)]) ;; Will be boxed, but won't be undefined (because the