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

cs & schemify: faster ptr-ref and ptr-set! on primitive types

Browse Source 
Recognize `(ptr-ref <ptr> _uint8)`, etc., and turn it into a more
direct `(ptr-ref/uint8 <ptr>)`, etc. This improvement speeds PNG
loading by a factor of 10 to 20, for example, because the
implementation expects the pattern to be recognized.
This commit is contained in:
Matthew Flatt 2019-05-02 15:39:19 -06:00
parent 03b5a65e0f
commit d5243820f6
8 changed files with 187 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
racket/src/cs/primitive/internal.ss
View File

@ -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)])

11
racket/src/cs/rumble.sls
View File

@ -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!

57
racket/src/cs/rumble/foreign.ss
View File

@ -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))

4
racket/src/cs/rumble/number.ss
View File

@ -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)

13
racket/src/expander/compile/built-in-symbol.rkt
View File

@ -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))))

22
racket/src/racket/src/startup.inc
View File

@ -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))"

48
racket/src/schemify/ptr-ref-set.rkt Normal file
View File

@ -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]))

14
racket/src/schemify/schemify.rkt
View File

@ -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