conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

substantial speedup for new io layer

This commit is contained in:
Abdulaziz Ghuloum 2007-12-12 21:22:05 -05:00
parent 7996ced7c9
commit 23b71cee3c
7 changed files with 156 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

31
scheme/ikarus.compiler.ss
View File

@ -1967,22 +1967,21 @@
(define transcoder-codec:utf-8 #b010) (define transcoder-codec:utf-8 #b010)
(define transcoder-codec:utf-16 #b011) (define transcoder-codec:utf-16 #b011)
;(define port-tag #x3F) ;;; 0011_F (define port-tag #x3F)
;(define output-port-tag #x7F) ;;; 0011_F (define port-mask #x3F)
;(define input-port-tag #xBF) ;;; 1011_F (define disp-port-attrs 0)
;(define port-mask #x3F) ;;; 0011_F (define disp-port-index 4)
;(define port-type-mask #xFF) ;;; 1111_F (define disp-port-size 8)
(define disp-port-buffer 12)
;(define disp-port-buffer 4) (define disp-port-transcoder 16)
;(define disp-port-index 8) (define disp-port-id 20)
;(define disp-port-size 12) (define disp-port-read! 24)
;(define disp-port-handler 16) (define disp-port-write! 28)
;(define disp-port-attributes 20) (define disp-port-get-position 32)
;(define disp-port-unused1 24) (define disp-port-set-position! 36)
;(define disp-port-unused2 28) (define disp-port-close 40)
;(define port-size 32) (define disp-port-cookie 44)
(define port-size 48)
(define disp-tcbucket-tconc 0) (define disp-tcbucket-tconc 0)
(define disp-tcbucket-key 4) (define disp-tcbucket-key 4)

68
scheme/ikarus.io.ss
View File

@ -13,13 +13,14 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; 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 (export $make-port $port-tag $port-id $port-cookie
port? $port-transcoder port? $port-transcoder
$port-index $port-size $port-buffer $port-index $port-size $port-buffer
$port-get-position $port-set-position! $port-close $port-get-position $port-set-position! $port-close
$port-read! $port-write! $set-port-index! $set-port-size! $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?)) (import (except (ikarus) port?))
(define-struct $port (define-struct $port
(attrs index size buffer transcoder (attrs index size buffer transcoder
@ -29,9 +30,7 @@
(define $set-port-size! set-$port-size!) (define $set-port-size! set-$port-size!)
(define $set-port-attrs! set-$port-attrs!) (define $set-port-attrs! set-$port-attrs!)
(define $make-port make-$port) (define $make-port make-$port)
(define fast-attrs-mask #xFFF) (define ($port-tag x) (if ($port? x) ($port-attrs x) 0)))
(define ($port-tag x) (if ($port? x) ($port-attrs x) 0))
(define ($port-fast-attrs x) (fxand ($port-tag x) fast-attrs-mask)))
(library (io-spec) (library (io-spec)
@ -126,6 +125,39 @@
port-id 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 (define-syntax define-rrr
(syntax-rules () (syntax-rules ()
[(_ name) [(_ name)
@ -133,7 +165,14 @@
(apply error 'name "not implemented" args))])) (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) (define (textual-port? x)
(fx= (fxand ($port-tag x) textual-port-tag) textual-port-tag)) (fx= (fxand ($port-tag x) textual-port-tag) textual-port-tag))
@ -176,6 +215,9 @@
(define fast-put-utf8-tag #b00000000100110) (define fast-put-utf8-tag #b00000000100110)
(define fast-put-latin-tag #b00000001100110) (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) (define (input-port-name p)
(if (input-port? p) (if (input-port? p)
($port-id p) ($port-id p)
@ -578,6 +620,7 @@
;;; ---------------------------------------------------------- ;;; ----------------------------------------------------------
(module (get-char lookahead-char) (module (get-char lookahead-char)
(import UNSAFE)
(define (refill-bv-start p who) (define (refill-bv-start p who)
(when ($port-closed? p) (error who "port is closed" p)) (when ($port-closed? p) (error who "port is closed" p))
(let* ([bv ($port-buffer p)] (let* ([bv ($port-buffer p)]
@ -673,7 +716,7 @@
(fxsll (fxand b1 #b111111) 6) (fxsll (fxand b1 #b111111) 6)
(fxand b2 #b111111))]) (fxand b2 #b111111))])
(cond (cond
[(fx<= #xD800 n #xDFFF) [(and (fx<= #xD800 n) (fx<= n #xDFFF))
($set-port-index! p (fx+ i 1)) ($set-port-index! p (fx+ i 1))
(do-error p who)] (do-error p who)]
[else [else
@ -703,7 +746,7 @@
(fxsll (fxand b2 #b111111) 6) (fxsll (fxand b2 #b111111) 6)
(fxand b3 #b111111))]) (fxand b3 #b111111))])
(cond (cond
[(fx<= #x10000 n #x10FFFF) [(and (fx<= #x10000 n) (fx<= n #x10FFFF))
($set-port-index! p (fx+ i 4)) ($set-port-index! p (fx+ i 4))
(integer->char n)] (integer->char n)]
[else [else
@ -772,7 +815,8 @@
(fxsll (fxand b1 #b111111) 6) (fxsll (fxand b1 #b111111) 6)
(fxand b2 #b111111))]) (fxand b2 #b111111))])
(cond (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 (integer->char n)]))]
[else (do-error p who)]))] [else (do-error p who)]))]
[else [else
@ -794,7 +838,7 @@
(fxsll (fxand b2 #b111111) 6) (fxsll (fxand b2 #b111111) 6)
(fxand b3 #b111111))]) (fxand b3 #b111111))])
(cond (cond
[(fx<= #x10000 n #x10FFFF) [(and (fx<= #x10000 n) (fx<= n #x10FFFF))
(integer->char n)] (integer->char n)]
[else [else
(do-error p who)]))] (do-error p who)]))]
@ -967,6 +1011,7 @@
(error who "port is not an input port" p))) (error who "port is not an input port" p)))
(module (get-u8 lookahead-u8) (module (get-u8 lookahead-u8)
(import UNSAFE)
(define (get-u8-byte-mode p who start) (define (get-u8-byte-mode p who start)
(when ($port-closed? p) (error who "port is closed" p)) (when ($port-closed? p) (error who "port is closed" p))
(let* ([bv ($port-buffer p)] (let* ([bv ($port-buffer p)]
@ -1014,6 +1059,7 @@
[else (slow-get-u8 p who 0)])))) [else (slow-get-u8 p who 0)]))))
(define (port-eof? p) (define (port-eof? p)
(import UNSAFE)
(define who 'port-eof?) (define who 'port-eof?)
(let ([m ($port-fast-attrs p)]) (let ([m ($port-fast-attrs p)])
(cond (cond
@ -1535,6 +1581,7 @@
;;; ---------------------------------------------------------- ;;; ----------------------------------------------------------
(module (put-char write-char put-string) (module (put-char write-char put-string)
(import UNSAFE)
(define (put-char-utf8-mode p b who) (define (put-char-utf8-mode p b who)
(cond (cond
[(fx< b 128) [(fx< b 128)
@ -1691,6 +1738,7 @@
(module (put-u8) (module (put-u8)
(import UNSAFE)
(define (put-u8-byte-mode p b who) (define (put-u8-byte-mode p b who)
(let ([write! ($port-write! p)]) (let ([write! ($port-write! p)])
(let ([i ($port-index p)] (let ([i ($port-index p)]

2
scheme/last-revision
View File

@ -1 +1 @@
1231 1233

31
scheme/makefile.ss
View File

@ -246,12 +246,13 @@
[$rat (ikarus system $ratnums) #f #t] [$rat (ikarus system $ratnums) #f #t]
[$symbols (ikarus system $symbols) #f #t] [$symbols (ikarus system $symbols) #f #t]
[$structs (ikarus system $structs) #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] [$codes (ikarus system $codes) #f #t]
[$tcbuckets (ikarus system $tcbuckets) #f #t] [$tcbuckets (ikarus system $tcbuckets) #f #t]
[$arg-list (ikarus system $arg-list) #f #t] [$arg-list (ikarus system $arg-list) #f #t]
[$stack (ikarus system $stack) #f #t] [$stack (ikarus system $stack) #f #t]
[$interrupts (ikarus system $interrupts) #f #t] [$interrupts (ikarus system $interrupts) #f #t]
[$io (ikarus system $io) #f #t]
[interrupts (ikarus system interrupts) #f #t] [interrupts (ikarus system interrupts) #f #t]
[$all (psyntax system $all) #f #t] [$all (psyntax system $all) #f #t]
[$boot (psyntax system $bootstrap) #f #t] [$boot (psyntax system $bootstrap) #f #t]
@ -501,16 +502,6 @@
[$struct? $structs] [$struct? $structs]
[$struct/rtd? $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] [$closure-code $codes]
[$code->closure $codes] [$code->closure $codes]
[$code-reloc-vector $codes] [$code-reloc-vector $codes]
@ -1290,6 +1281,24 @@
[$data->transcoder $transc] [$data->transcoder $transc]
[file-options-spec i] [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-rtd]
[&condition-rcd] [&condition-rcd]
[&message-rtd] [&message-rtd]

97
scheme/pass-specify-rep-primops.ss
View File

@ -1740,60 +1740,83 @@
/section) /section)
#;
(section ;;; ports (section ;;; ports
(define-primop port? safe (define-primop port? safe
[(P x) (sec-tag-test (T x) vector-mask vector-tag port-mask port-tag)] [(P x) (sec-tag-test (T x) vector-mask vector-tag port-mask port-tag)]
[(E x) (nop)]) [(E x) (nop)])
(define-primop input-port? safe ;(define-primop input-port? safe
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f input-port-tag)] ; [(P x) (sec-tag-test (T x) vector-mask vector-tag #f input-port-tag)]
[(E x) (nop)]) ; [(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 (define-primop $make-port unsafe
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f output-port-tag)] [(V attrs idx sz buf tr id read write getp setp cl cookie)
[(E x) (nop)])
(define (make-port handler buf/i idx/i sz/i tag)
(with-tmp ([p (prm 'alloc (K (align port-size)) (K vector-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 (- vector-tag))
(prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf/i)) (prm 'logor (prm 'sll (T attrs) (K port-attrs-shift)) (K port-tag)))
(prm 'mset p (K (- disp-port-index vector-tag)) (T idx/i)) (prm 'mset p (K (- disp-port-index vector-tag)) (T idx))
(prm 'mset p (K (- disp-port-size vector-tag)) (T sz/i)) (prm 'mset p (K (- disp-port-size vector-tag)) (T sz))
(prm 'mset p (K (- disp-port-handler vector-tag)) (T handler)) (prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf))
(prm 'mset p (K (- disp-port-attributes vector-tag)) (K 0)) (prm 'mset p (K (- disp-port-transcoder vector-tag)) (T tr))
(prm 'mset p (K (- disp-port-unused1 vector-tag)) (K 0)) (prm 'mset p (K (- disp-port-id vector-tag)) (T id))
(prm 'mset p (K (- disp-port-unused2 vector-tag)) (K 0)) (prm 'mset p (K (- disp-port-read! vector-tag)) (T read))
p)) (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-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 (define-primop $port-index unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-index vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-index vector-tag)))])
(define-primop $port-size unsafe (define-primop $port-size unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-size vector-tag)))]) [(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 (define-primop $set-port-index! unsafe
[(E x i) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (T i))]) [(E x i) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (T i))])
(define-primop $set-port-size! unsafe (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) [(E x i)
(seq* (prm 'mset (T x)
(prm 'mset (T x) (K (- disp-port-index vector-tag)) (K 0)) (K (- disp-port-attrs vector-tag))
(prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i)))]) (prm 'logor (prm 'sll (T i) (K port-attrs-shift)) (K port-tag)))])
(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))])
/section) /section)

2
src/ikarus-data.h
View File

@ -413,7 +413,7 @@ ikp ik_safe_alloc(ikpcb* pcb, int size);
#define port_tag 0x3F #define port_tag 0x3F
#define port_mask 0x3F #define port_mask 0x3F
#define port_size 32 #define port_size 48
#define disp_tcbucket_tconc 0 #define disp_tcbucket_tconc 0
#define disp_tcbucket_key 4 #define disp_tcbucket_key 4