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

* Added $port-buffer, $port-index, $port-size, $set-port-index!, and 

$set-port-size!.  Next step is removing the input/output-specific
  accessors and mutators.
This commit is contained in:
Abdulaziz Ghuloum 2007-08-25 10:49:39 -04:00
parent 33c087a867
commit c5530973d0
6 changed files with 81 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
benchmarks.larceny/results.Larceny-r6rs
View File

@ -8190,3 +8190,23 @@ Words allocated: 551809361
Words reclaimed: 0 Words reclaimed: 0
Elapsed time...: 2246 ms (User: 2230 ms; System: 15 ms) Elapsed time...: 2246 ms (User: 2230 ms; System: 15 ms)
Elapsed GC time: 753 ms (CPU: 762 in 2105 collections.) Elapsed GC time: 753 ms (CPU: 762 in 2105 collections.)
****************************
Benchmarking Larceny-r6rs on Sat Jul 14 07:09:21 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing fibfp under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 358610884
Words reclaimed: 0
Elapsed time...: 3289 ms (User: 3248 ms; System: 39 ms)
Elapsed GC time: 486 ms (CPU: 489 in 1368 collections.)

BIN
src/ikarus.boot
View File

Binary file not shown.

18
src/ikarus.compiler.ss
View File

@ -1796,19 +1796,23 @@
(define disp-code-relocsize 8) (define disp-code-relocsize 8)
(define disp-code-freevars 12) (define disp-code-freevars 12)
(define disp-code-data 16) (define disp-code-data 16)
(define port-tag #x3F) (define port-tag #x3F)
(define input-port-tag #x7F) (define output-port-tag #x7F)
(define output-port-tag #xBF) (define input-port-tag #xBF)
(define input/output-port-tag #xFF) ;(define input/output-port-tag #xFF)
(define port-mask #x3F) (define port-mask #x3F)
(define disp-port-handler 4) (define disp-port-buffer 4)
(define disp-port-input-buffer 8) (define disp-port-index 8)
(define disp-port-input-index 12) (define disp-port-size 12)
(define disp-port-input-size 16) (define disp-port-handler 16)
(define disp-port-output-buffer 20) (define disp-port-output-buffer 20)
(define disp-port-output-index 24) (define disp-port-output-index 24)
(define disp-port-output-size 28) (define disp-port-output-size 28)
(define port-size 32) (define port-size 32)
(define disp-tcbucket-tconc 0) (define disp-tcbucket-tconc 0)
(define disp-tcbucket-key 4) (define disp-tcbucket-key 4)
(define disp-tcbucket-val 8) (define disp-tcbucket-val 8)

36
src/ikarus.io-ports.ss
View File

@ -1,6 +1,6 @@
(library (ikarus io-ports) (library (ikarus io-ports)
(export make-input-port make-output-port make-input/output-port (export make-input-port make-output-port ;make-input/output-port
port-handler port-handler
port-input-buffer port-output-buffer port-input-buffer port-output-buffer
port-input-index set-port-input-index! port-input-index set-port-input-index!
@ -12,8 +12,10 @@
(ikarus system $strings) (ikarus system $strings)
(ikarus system $bytevectors) (ikarus system $bytevectors)
(ikarus system $fx) (ikarus system $fx)
(except (ikarus) make-input-port make-output-port (except (ikarus)
make-input/output-port port-handler make-input-port make-output-port
;make-input/output-port
port-handler
port-input-buffer port-output-buffer port-input-buffer port-output-buffer
port-input-index set-port-input-index! port-input-index set-port-input-index!
port-input-size set-port-input-size! port-input-size set-port-input-size!
@ -75,21 +77,21 @@
(error 'make-output-port "~s is not a bytevector" buffer)) (error 'make-output-port "~s is not a bytevector" buffer))
(error 'make-output-port "~s is not a procedure" handler)))) (error 'make-output-port "~s is not a procedure" handler))))
;;; ;;;
(define $make-input/output-port ;(define $make-input/output-port
(lambda (handler input-buffer output-buffer) ; (lambda (handler input-buffer output-buffer)
($make-port/both handler ; ($make-port/both handler
input-buffer 0 ($bytevector-length input-buffer) ; input-buffer 0 ($bytevector-length input-buffer)
output-buffer 0 ($bytevector-length output-buffer)))) ; output-buffer 0 ($bytevector-length output-buffer))))
;;; ;;;
(define make-input/output-port ;(define make-input/output-port
(lambda (handler input-buffer output-buffer) ; (lambda (handler input-buffer output-buffer)
(if (procedure? handler) ; (if (procedure? handler)
(if (bytevector? input-buffer) ; (if (bytevector? input-buffer)
(if (bytevector? output-buffer) ; (if (bytevector? output-buffer)
($make-input/output-port handler input-buffer output-buffer) ; ($make-input/output-port handler input-buffer output-buffer)
(error 'make-input/output-port "~s is not a bytevector" output-buffer)) ; (error 'make-input/output-port "~s is not a bytevector" output-buffer))
(error 'make-input/output-port "~s is not a bytevector" input-buffer)) ; (error 'make-input/output-port "~s is not a bytevector" input-buffer))
(error 'make-input/output-port "~s is not a procedure" handler)))) ; (error 'make-input/output-port "~s is not a procedure" handler))))
;;; ;;;
(define port-handler (define port-handler
(lambda (x) (lambda (x)

8
src/makefile.ss
View File

@ -692,8 +692,13 @@
[$make-port/input $ports] [$make-port/input $ports]
[$make-port/output $ports] [$make-port/output $ports]
[$make-port/both $ports]
[$port-handler $ports] [$port-handler $ports]
[$port-buffer $ports]
[$port-index $ports]
[$port-size $ports]
[$set-port-index! $ports]
[$set-port-size! $ports]
[$port-input-buffer $ports] [$port-input-buffer $ports]
[$port-input-index $ports] [$port-input-index $ports]
[$port-input-size $ports] [$port-input-size $ports]
@ -705,6 +710,7 @@
[$set-port-output-index! $ports] [$set-port-output-index! $ports]
[$set-port-output-size! $ports] [$set-port-output-size! $ports]
[$closure-code $codes] [$closure-code $codes]
[$code->closure $codes] [$code->closure $codes]
[$code-reloc-vector $codes] [$code-reloc-vector $codes]

41
src/pass-specify-rep-primops.ss
View File

@ -1424,10 +1424,10 @@
(define (make-port handler buf/i idx/i sz/i buf/o idx/o sz/o tag) (define (make-port handler buf/i idx/i sz/i buf/o idx/o sz/o 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)) (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-handler vector-tag)) (T handler))
(prm 'mset p (K (- disp-port-input-buffer vector-tag)) (T buf/i))
(prm 'mset p (K (- disp-port-input-index vector-tag)) (T idx/i))
(prm 'mset p (K (- disp-port-input-size vector-tag)) (T sz/i))
(prm 'mset p (K (- disp-port-output-buffer vector-tag)) (T buf/o)) (prm 'mset p (K (- disp-port-output-buffer vector-tag)) (T buf/o))
(prm 'mset p (K (- disp-port-output-index vector-tag)) (T idx/o)) (prm 'mset p (K (- disp-port-output-index vector-tag)) (T idx/o))
(prm 'mset p (K (- disp-port-output-size vector-tag)) (T sz/o)) (prm 'mset p (K (- disp-port-output-size vector-tag)) (T sz/o))
@ -1437,48 +1437,55 @@
[(V handler buf/i idx/i sz/i buf/o idx/o sz/o) [(V handler buf/i idx/i sz/i buf/o idx/o sz/o)
(make-port handler buf/i idx/i sz/i buf/o idx/o sz/o (make-port handler buf/i idx/i sz/i buf/o idx/o sz/o
input-port-tag)]) input-port-tag)])
(define-primop $make-port/output unsafe (define-primop $make-port/output unsafe
[(V handler buf/i idx/i sz/i buf/o idx/o sz/o) [(V handler buf/i idx/i sz/i buf/o idx/o sz/o)
(make-port handler buf/i idx/i sz/i buf/o idx/o sz/o (make-port handler buf/i idx/i sz/i buf/o idx/o sz/o
output-port-tag)]) output-port-tag)])
(define-primop $make-port/both unsafe
[(V handler buf/i idx/i sz/i buf/o idx/o sz/o)
(make-port handler buf/i idx/i sz/i buf/o idx/o sz/o
input/output-port-tag)])
(define-primop $port-handler unsafe (define-primop $port-handler unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-handler vector-tag)))]) [(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 $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)
(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-input-buffer unsafe (define-primop $port-input-buffer unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-input-buffer vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-buffer vector-tag)))])
(define-primop $port-input-index unsafe (define-primop $port-input-index unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-input-index vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-index vector-tag)))])
(define-primop $port-input-size unsafe (define-primop $port-input-size unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-input-size vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-size vector-tag)))])
(define-primop $port-output-buffer unsafe (define-primop $port-output-buffer unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-output-buffer vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-output-buffer vector-tag)))])
(define-primop $port-output-index unsafe (define-primop $port-output-index unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-output-index vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-output-index vector-tag)))])
(define-primop $port-output-size unsafe (define-primop $port-output-size unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-output-size vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-output-size vector-tag)))])
(define-primop $set-port-input-index! unsafe (define-primop $set-port-input-index! unsafe
[(E x i) (prm 'mset (T x) (K (- disp-port-input-index vector-tag)) (T i))]) [(E x i) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (T i))])
(define-primop $set-port-output-index! unsafe (define-primop $set-port-output-index! unsafe
[(E x i) (prm 'mset (T x) (K (- disp-port-output-index vector-tag)) (T i))]) [(E x i) (prm 'mset (T x) (K (- disp-port-output-index vector-tag)) (T i))])
(define-primop $set-port-input-size! unsafe (define-primop $set-port-input-size! unsafe
[(E x i) [(E x i)
(seq* (seq*
(prm 'mset (T x) (K (- disp-port-input-index vector-tag)) (K 0)) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (K 0))
(prm 'mset (T x) (K (- disp-port-input-size vector-tag)) (T i)))]) (prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i)))])
(define-primop $set-port-output-size! unsafe (define-primop $set-port-output-size! unsafe
[(E x i) [(E x i)
(seq* (seq*
(prm 'mset (T x) (K (- disp-port-output-index vector-tag)) (K 0)) (prm 'mset (T x) (K (- disp-port-output-index vector-tag)) (K 0))
(prm 'mset (T x) (K (- disp-port-output-size vector-tag)) (T i)))]) (prm 'mset (T x) (K (- disp-port-output-size vector-tag)) (T i)))])
/section) /section)
(section ;;; interrupts-and-engines (section ;;; interrupts-and-engines