substantial speedup for new io layer
This commit is contained in:
Abdulaziz Ghuloum
parent
7996ced7c9
commit
23b71cee3c
Binary file not shown.
|
|
@ -1967,22 +1967,21 @@
|
|||
(define transcoder-codec:utf-8 #b010)
|
||||
(define transcoder-codec:utf-16 #b011)
|
||||
|
||||
;(define port-tag #x3F) ;;; 0011_F
|
||||
;(define output-port-tag #x7F) ;;; 0011_F
|
||||
;(define input-port-tag #xBF) ;;; 1011_F
|
||||
;(define port-mask #x3F) ;;; 0011_F
|
||||
;(define port-type-mask #xFF) ;;; 1111_F
|
||||
|
||||
;(define disp-port-buffer 4)
|
||||
;(define disp-port-index 8)
|
||||
;(define disp-port-size 12)
|
||||
;(define disp-port-handler 16)
|
||||
;(define disp-port-attributes 20)
|
||||
;(define disp-port-unused1 24)
|
||||
;(define disp-port-unused2 28)
|
||||
;(define port-size 32)
|
||||
|
||||
|
||||
(define port-tag #x3F)
|
||||
(define port-mask #x3F)
|
||||
(define disp-port-attrs 0)
|
||||
(define disp-port-index 4)
|
||||
(define disp-port-size 8)
|
||||
(define disp-port-buffer 12)
|
||||
(define disp-port-transcoder 16)
|
||||
(define disp-port-id 20)
|
||||
(define disp-port-read! 24)
|
||||
(define disp-port-write! 28)
|
||||
(define disp-port-get-position 32)
|
||||
(define disp-port-set-position! 36)
|
||||
(define disp-port-close 40)
|
||||
(define disp-port-cookie 44)
|
||||
(define port-size 48)
|
||||
|
||||
(define disp-tcbucket-tconc 0)
|
||||
(define disp-tcbucket-key 4)
|
||||
|
|
|
|||
|
|
@ -13,13 +13,14 @@
|
|||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(library (ikarus system $io)
|
||||
#;
|
||||
(library (ikarus system $io tmp)
|
||||
(export $make-port $port-tag $port-id $port-cookie
|
||||
port? $port-transcoder
|
||||
$port-index $port-size $port-buffer
|
||||
$port-get-position $port-set-position! $port-close
|
||||
$port-read! $port-write! $set-port-index! $set-port-size!
|
||||
$port-attrs $set-port-attrs! $port-fast-attrs)
|
||||
$port-attrs $set-port-attrs!)
|
||||
(import (except (ikarus) port?))
|
||||
(define-struct $port
|
||||
(attrs index size buffer transcoder
|
||||
|
|
@ -29,9 +30,7 @@
|
|||
(define $set-port-size! set-$port-size!)
|
||||
(define $set-port-attrs! set-$port-attrs!)
|
||||
(define $make-port make-$port)
|
||||
(define fast-attrs-mask #xFFF)
|
||||
(define ($port-tag x) (if ($port? x) ($port-attrs x) 0))
|
||||
(define ($port-fast-attrs x) (fxand ($port-tag x) fast-attrs-mask)))
|
||||
(define ($port-tag x) (if ($port? x) ($port-attrs x) 0)))
|
||||
|
||||
(library (io-spec)
|
||||
|
||||
|
|
@ -126,6 +125,39 @@
|
|||
port-id
|
||||
))
|
||||
|
||||
(module UNSAFE (fx< fx<= fx> fx>= fx= fx+ fx-
|
||||
fxior fxand fxsra fxsll
|
||||
integer->char char->integer
|
||||
string-ref string-set! string-length
|
||||
bytevector-u8-ref bytevector-u8-set!)
|
||||
(import
|
||||
(rename (ikarus system $strings)
|
||||
($string-length string-length)
|
||||
($string-ref string-ref)
|
||||
($string-set! string-set!))
|
||||
(rename (ikarus system $chars)
|
||||
($char->fixnum char->integer)
|
||||
($fixnum->char integer->char))
|
||||
(rename (ikarus system $bytevectors)
|
||||
($bytevector-set! bytevector-u8-set!)
|
||||
($bytevector-u8-ref bytevector-u8-ref))
|
||||
(rename (ikarus system $fx)
|
||||
($fxsra fxsra)
|
||||
($fxsll fxsll)
|
||||
($fxlogor fxior)
|
||||
($fxlogand fxand)
|
||||
($fx+ fx+)
|
||||
($fx- fx-)
|
||||
($fx< fx<)
|
||||
($fx> fx>)
|
||||
($fx>= fx>=)
|
||||
($fx<= fx<=)
|
||||
($fx= fx=))))
|
||||
|
||||
(define (port? x)
|
||||
(import (only (ikarus) port?))
|
||||
(port? x))
|
||||
|
||||
(define-syntax define-rrr
|
||||
(syntax-rules ()
|
||||
[(_ name)
|
||||
|
|
@ -133,7 +165,14 @@
|
|||
(apply error 'name "not implemented" args))]))
|
||||
|
||||
|
||||
(define (u8? x) (and (fixnum? x) (fx>= x 0) (fx< x 256)))
|
||||
(define-syntax u8?
|
||||
(let ()
|
||||
(import (ikarus system $fx))
|
||||
(syntax-rules ()
|
||||
[(_ x)
|
||||
($fxzero? ($fxlogand x -256))])))
|
||||
|
||||
;(define (u8? x) (and (fixnum? x) (fx>= x 0) (fx< x 256)))
|
||||
|
||||
(define (textual-port? x)
|
||||
(fx= (fxand ($port-tag x) textual-port-tag) textual-port-tag))
|
||||
|
|
@ -176,6 +215,9 @@
|
|||
(define fast-put-utf8-tag #b00000000100110)
|
||||
(define fast-put-latin-tag #b00000001100110)
|
||||
|
||||
(define fast-attrs-mask #xFFF)
|
||||
(define ($port-fast-attrs x) (fxand ($port-tag x) fast-attrs-mask))
|
||||
|
||||
(define (input-port-name p)
|
||||
(if (input-port? p)
|
||||
($port-id p)
|
||||
|
|
@ -578,6 +620,7 @@
|
|||
|
||||
;;; ----------------------------------------------------------
|
||||
(module (get-char lookahead-char)
|
||||
(import UNSAFE)
|
||||
(define (refill-bv-start p who)
|
||||
(when ($port-closed? p) (error who "port is closed" p))
|
||||
(let* ([bv ($port-buffer p)]
|
||||
|
|
@ -673,7 +716,7 @@
|
|||
(fxsll (fxand b1 #b111111) 6)
|
||||
(fxand b2 #b111111))])
|
||||
(cond
|
||||
[(fx<= #xD800 n #xDFFF)
|
||||
[(and (fx<= #xD800 n) (fx<= n #xDFFF))
|
||||
($set-port-index! p (fx+ i 1))
|
||||
(do-error p who)]
|
||||
[else
|
||||
|
|
@ -703,7 +746,7 @@
|
|||
(fxsll (fxand b2 #b111111) 6)
|
||||
(fxand b3 #b111111))])
|
||||
(cond
|
||||
[(fx<= #x10000 n #x10FFFF)
|
||||
[(and (fx<= #x10000 n) (fx<= n #x10FFFF))
|
||||
($set-port-index! p (fx+ i 4))
|
||||
(integer->char n)]
|
||||
[else
|
||||
|
|
@ -772,7 +815,8 @@
|
|||
(fxsll (fxand b1 #b111111) 6)
|
||||
(fxand b2 #b111111))])
|
||||
(cond
|
||||
[(fx<= #xD800 n #xDFFF) (do-error p who)]
|
||||
[(and (fx<= #xD800 n) (fx<= n #xDFFF))
|
||||
(do-error p who)]
|
||||
[else (integer->char n)]))]
|
||||
[else (do-error p who)]))]
|
||||
[else
|
||||
|
|
@ -794,7 +838,7 @@
|
|||
(fxsll (fxand b2 #b111111) 6)
|
||||
(fxand b3 #b111111))])
|
||||
(cond
|
||||
[(fx<= #x10000 n #x10FFFF)
|
||||
[(and (fx<= #x10000 n) (fx<= n #x10FFFF))
|
||||
(integer->char n)]
|
||||
[else
|
||||
(do-error p who)]))]
|
||||
|
|
@ -967,6 +1011,7 @@
|
|||
(error who "port is not an input port" p)))
|
||||
|
||||
(module (get-u8 lookahead-u8)
|
||||
(import UNSAFE)
|
||||
(define (get-u8-byte-mode p who start)
|
||||
(when ($port-closed? p) (error who "port is closed" p))
|
||||
(let* ([bv ($port-buffer p)]
|
||||
|
|
@ -1014,6 +1059,7 @@
|
|||
[else (slow-get-u8 p who 0)]))))
|
||||
|
||||
(define (port-eof? p)
|
||||
(import UNSAFE)
|
||||
(define who 'port-eof?)
|
||||
(let ([m ($port-fast-attrs p)])
|
||||
(cond
|
||||
|
|
@ -1535,6 +1581,7 @@
|
|||
;;; ----------------------------------------------------------
|
||||
|
||||
(module (put-char write-char put-string)
|
||||
(import UNSAFE)
|
||||
(define (put-char-utf8-mode p b who)
|
||||
(cond
|
||||
[(fx< b 128)
|
||||
|
|
@ -1691,6 +1738,7 @@
|
|||
|
||||
|
||||
(module (put-u8)
|
||||
(import UNSAFE)
|
||||
(define (put-u8-byte-mode p b who)
|
||||
(let ([write! ($port-write! p)])
|
||||
(let ([i ($port-index p)]
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1231
|
||||
1233
|
||||
|
|
|
|||
|
|
@ -246,12 +246,13 @@
|
|||
[$rat (ikarus system $ratnums) #f #t]
|
||||
[$symbols (ikarus system $symbols) #f #t]
|
||||
[$structs (ikarus system $structs) #f #t]
|
||||
[$ports (ikarus system $ports) #f #t]
|
||||
;[$ports (ikarus system $ports) #f #t]
|
||||
[$codes (ikarus system $codes) #f #t]
|
||||
[$tcbuckets (ikarus system $tcbuckets) #f #t]
|
||||
[$arg-list (ikarus system $arg-list) #f #t]
|
||||
[$stack (ikarus system $stack) #f #t]
|
||||
[$interrupts (ikarus system $interrupts) #f #t]
|
||||
[$io (ikarus system $io) #f #t]
|
||||
[interrupts (ikarus system interrupts) #f #t]
|
||||
[$all (psyntax system $all) #f #t]
|
||||
[$boot (psyntax system $bootstrap) #f #t]
|
||||
|
|
@ -501,16 +502,6 @@
|
|||
[$struct? $structs]
|
||||
[$struct/rtd? $structs]
|
||||
;;;
|
||||
[$make-port/input $ports]
|
||||
[$make-port/output $ports]
|
||||
[$port-handler $ports]
|
||||
[$port-buffer $ports]
|
||||
[$port-index $ports]
|
||||
[$port-size $ports]
|
||||
[$set-port-index! $ports]
|
||||
[$set-port-size! $ports]
|
||||
[$port-attributes $ports]
|
||||
[$set-port-attributes! $ports]
|
||||
[$closure-code $codes]
|
||||
[$code->closure $codes]
|
||||
[$code-reloc-vector $codes]
|
||||
|
|
@ -1290,6 +1281,24 @@
|
|||
[$data->transcoder $transc]
|
||||
[file-options-spec i]
|
||||
;;;
|
||||
[$make-port $io]
|
||||
[$port-tag $io]
|
||||
[$port-id $io]
|
||||
[$port-cookie $io]
|
||||
[$port-transcoder $io]
|
||||
[$port-index $io]
|
||||
[$port-size $io]
|
||||
[$port-buffer $io]
|
||||
[$port-get-position $io]
|
||||
[$port-set-position! $io]
|
||||
[$port-close $io]
|
||||
[$port-read! $io]
|
||||
[$port-write! $io]
|
||||
[$set-port-index! $io]
|
||||
[$set-port-size! $io]
|
||||
[$port-attrs $io]
|
||||
[$set-port-attrs! $io]
|
||||
;;;
|
||||
[&condition-rtd]
|
||||
[&condition-rcd]
|
||||
[&message-rtd]
|
||||
|
|
|
|||
|
|
@ -1740,60 +1740,83 @@
|
|||
|
||||
/section)
|
||||
|
||||
#;
|
||||
(section ;;; ports
|
||||
|
||||
(define-primop port? safe
|
||||
[(P x) (sec-tag-test (T x) vector-mask vector-tag port-mask port-tag)]
|
||||
[(E x) (nop)])
|
||||
|
||||
(define-primop input-port? safe
|
||||
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f input-port-tag)]
|
||||
[(E x) (nop)])
|
||||
;(define-primop input-port? safe
|
||||
; [(P x) (sec-tag-test (T x) vector-mask vector-tag #f input-port-tag)]
|
||||
; [(E x) (nop)])
|
||||
;
|
||||
;(define-primop output-port? safe
|
||||
; [(P x) (sec-tag-test (T x) vector-mask vector-tag #f output-port-tag)]
|
||||
; [(E x) (nop)])
|
||||
(define port-attrs-shift 6)
|
||||
|
||||
(define-primop output-port? safe
|
||||
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f output-port-tag)]
|
||||
[(E x) (nop)])
|
||||
(define-primop $make-port unsafe
|
||||
[(V attrs idx sz buf tr id read write getp setp cl cookie)
|
||||
(with-tmp ([p (prm 'alloc (K (align port-size)) (K vector-tag))])
|
||||
(prm 'mset p (K (- vector-tag))
|
||||
(prm 'logor (prm 'sll (T attrs) (K port-attrs-shift)) (K port-tag)))
|
||||
(prm 'mset p (K (- disp-port-index vector-tag)) (T idx))
|
||||
(prm 'mset p (K (- disp-port-size vector-tag)) (T sz))
|
||||
(prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf))
|
||||
(prm 'mset p (K (- disp-port-transcoder vector-tag)) (T tr))
|
||||
(prm 'mset p (K (- disp-port-id vector-tag)) (T id))
|
||||
(prm 'mset p (K (- disp-port-read! vector-tag)) (T read))
|
||||
(prm 'mset p (K (- disp-port-write! vector-tag)) (T write))
|
||||
(prm 'mset p (K (- disp-port-get-position vector-tag)) (T getp))
|
||||
(prm 'mset p (K (- disp-port-set-position! vector-tag)) (T setp))
|
||||
(prm 'mset p (K (- disp-port-close vector-tag)) (T cl))
|
||||
(prm 'mset p (K (- disp-port-cookie vector-tag)) (T cookie))
|
||||
p)])
|
||||
|
||||
(define (make-port handler buf/i idx/i sz/i tag)
|
||||
(with-tmp ([p (prm 'alloc (K (align port-size)) (K vector-tag))])
|
||||
(prm 'mset p (K (- vector-tag)) (K tag))
|
||||
(prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf/i))
|
||||
(prm 'mset p (K (- disp-port-index vector-tag)) (T idx/i))
|
||||
(prm 'mset p (K (- disp-port-size vector-tag)) (T sz/i))
|
||||
(prm 'mset p (K (- disp-port-handler vector-tag)) (T handler))
|
||||
(prm 'mset p (K (- disp-port-attributes vector-tag)) (K 0))
|
||||
(prm 'mset p (K (- disp-port-unused1 vector-tag)) (K 0))
|
||||
(prm 'mset p (K (- disp-port-unused2 vector-tag)) (K 0))
|
||||
p))
|
||||
|
||||
(define-primop $make-port/input unsafe
|
||||
[(V handler buf/i idx/i sz/i)
|
||||
(make-port handler buf/i idx/i sz/i input-port-tag)])
|
||||
|
||||
(define-primop $make-port/output unsafe
|
||||
[(V handler buf/o idx/o sz/o)
|
||||
(make-port handler buf/o idx/o sz/o output-port-tag)])
|
||||
|
||||
(define-primop $port-handler unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-handler vector-tag)))])
|
||||
(define-primop $port-buffer unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-buffer vector-tag)))])
|
||||
(define-primop $port-index unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-index vector-tag)))])
|
||||
(define-primop $port-size unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-size vector-tag)))])
|
||||
(define-primop $port-buffer unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-buffer vector-tag)))])
|
||||
(define-primop $port-transcoder unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-transcoder vector-tag)))])
|
||||
(define-primop $port-id unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-id vector-tag)))])
|
||||
(define-primop $port-read! unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-read! vector-tag)))])
|
||||
(define-primop $port-write! unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-write! vector-tag)))])
|
||||
(define-primop $port-get-position unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-get-position vector-tag)))])
|
||||
(define-primop $port-set-position! unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-set-position! vector-tag)))])
|
||||
(define-primop $port-close unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-close vector-tag)))])
|
||||
(define-primop $port-cookie unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-cookie vector-tag)))])
|
||||
(define-primop $port-attrs unsafe
|
||||
[(V x)
|
||||
(prm 'sra
|
||||
(prm 'mref (T x) (K (- disp-port-attrs vector-tag)))
|
||||
(K port-attrs-shift))])
|
||||
(define-primop $port-tag unsafe
|
||||
[(V x)
|
||||
(make-conditional
|
||||
(tag-test (T x) vector-mask vector-tag)
|
||||
(cogen-value-$port-attrs x)
|
||||
(K 0))])
|
||||
|
||||
(define-primop $set-port-index! unsafe
|
||||
[(E x i) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (T i))])
|
||||
(define-primop $set-port-size! unsafe
|
||||
[(E x i) (prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i))])
|
||||
(define-primop $set-port-attrs! unsafe
|
||||
[(E x i)
|
||||
(seq*
|
||||
(prm 'mset (T x) (K (- disp-port-index vector-tag)) (K 0))
|
||||
(prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i)))])
|
||||
(define-primop $port-attributes unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-port-attributes vector-tag)))])
|
||||
(define-primop $set-port-attributes! unsafe
|
||||
[(E x i) (prm 'mset (T x) (K (- disp-port-attributes vector-tag)) (T i))])
|
||||
(prm 'mset (T x)
|
||||
(K (- disp-port-attrs vector-tag))
|
||||
(prm 'logor (prm 'sll (T i) (K port-attrs-shift)) (K port-tag)))])
|
||||
|
||||
|
||||
/section)
|
||||
|
||||
|
|
|
|||
|
|
@ -413,7 +413,7 @@ ikp ik_safe_alloc(ikpcb* pcb, int size);
|
|||
|
||||
#define port_tag 0x3F
|
||||
#define port_mask 0x3F
|
||||
#define port_size 32
|
||||
#define port_size 48
|
||||
|
||||
#define disp_tcbucket_tconc 0
|
||||
#define disp_tcbucket_key 4
|
||||
|
|
|
|||
Loading…
Reference in New Issue