imported compiler3
This commit is contained in:
Abdulaziz Ghuloum
parent
bd94bedc04
commit
03e9649064
|
|
@ -2,7 +2,7 @@
|
|||
all: ikarus.fasl
|
||||
|
||||
ikarus.fasl:
|
||||
echo '(load "compiler-6.1.ss")' | petite
|
||||
echo '(load "compiler-6.2.ss")' | petite
|
||||
|
||||
clean:
|
||||
rm -f *.fasl
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
2006-07-28
|
||||
2006-08-02
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@
|
|||
(define scheme-library-files
|
||||
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" "libcontrol.fasl"]
|
||||
["libcollect-6.0.ss" "libcollect.fasl"]
|
||||
["libcollect-6.1.ss" "libcollect.fasl"]
|
||||
["librecord-6.1.ss" "librecord.fasl"]
|
||||
["libcxr-6.0.ss" "libcxr.fasl"]
|
||||
["libcore-6.1.ss" "libcore.fasl"]
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
BIN
src/ikarus.fasl
BIN
src/ikarus.fasl
Binary file not shown.
|
|
@ -7,7 +7,7 @@
|
|||
(let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)])
|
||||
(make-code
|
||||
closure-size
|
||||
(make-string code-size)
|
||||
(make-string code-size (integer->char 0))
|
||||
(make-vector (fxsra reloc-size 2)))))))
|
||||
|
||||
(define set-code-byte!
|
||||
|
|
|
|||
BIN
src/libcafe.fasl
BIN
src/libcafe.fasl
Binary file not shown.
|
|
@ -0,0 +1,36 @@
|
|||
|
||||
;(primitive-set! 'do-overflow
|
||||
; (lambda ()
|
||||
; ($do-overflow 4096)))
|
||||
|
||||
(primitive-set! 'do-overflow
|
||||
(lambda (n)
|
||||
(foreign-call "ik_collect" n)
|
||||
(void)))
|
||||
|
||||
(primitive-set! 'do-overflow-words
|
||||
(lambda (n)
|
||||
(foreign-call "ik_collect" ($fxsll n 2))
|
||||
(void)))
|
||||
|
||||
(primitive-set! 'do-vararg-overflow
|
||||
(lambda (n)
|
||||
(foreign-call "ik_collect_vararg" n)
|
||||
(void)))
|
||||
|
||||
(primitive-set! 'collect
|
||||
(lambda ()
|
||||
(do-overflow 4096)))
|
||||
|
||||
(primitive-set! 'do-stack-overflow
|
||||
(lambda ()
|
||||
(foreign-call "ik_stack_overflow")))
|
||||
|
||||
(primitive-set! 'dump-metatable
|
||||
(lambda ()
|
||||
(foreign-call "ik_dump_metatable")))
|
||||
|
||||
(primitive-set! 'dump-dirty-vector
|
||||
(lambda ()
|
||||
(foreign-call "ik_dump_dirty_vector")))
|
||||
|
||||
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
BIN
src/libcore.fasl
BIN
src/libcore.fasl
Binary file not shown.
BIN
src/libcxr.fasl
BIN
src/libcxr.fasl
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
|
|
@ -189,15 +189,8 @@
|
|||
[else (error 'fasl-write "unrecognized reloc ~s" b)]
|
||||
)))))]
|
||||
[else (error 'fasl-write "~s is not fasl-writable" x)])]))))
|
||||
(primitive-set! 'fasl-write
|
||||
(lambda (x . rest)
|
||||
(let ([port
|
||||
(if (null? rest)
|
||||
(current-output-port)
|
||||
(let ([a (car rest)])
|
||||
(unless (output-port? a)
|
||||
(error 'fasl-write "~s is not an output port" a))
|
||||
a))])
|
||||
(define do-fasl-write
|
||||
(lambda (x port)
|
||||
(let ([h (make-hash-table)])
|
||||
(make-graph x h)
|
||||
(write-char #\# port)
|
||||
|
|
@ -206,5 +199,12 @@
|
|||
(write-char #\K port)
|
||||
(write-char #\0 port)
|
||||
(write-char #\1 port)
|
||||
(fasl-write x port h 1))))))
|
||||
(fasl-write x port h 1))))
|
||||
(primitive-set! 'fasl-write
|
||||
(case-lambda
|
||||
[(x) (do-fasl-write x (current-output-port))]
|
||||
[(x port)
|
||||
(unless (output-port? port)
|
||||
(error 'fasl-write "~s is not an output port" port))
|
||||
(do-fasl-write x port)])))
|
||||
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -0,0 +1,200 @@
|
|||
|
||||
(let ([hash-rtd (make-record-type '"hash-table" '(hash-vec count tc))])
|
||||
;;; accessors
|
||||
(define get-vec (record-field-accessor hash-rtd 0))
|
||||
(define set-vec! (record-field-mutator hash-rtd 0))
|
||||
(define get-count (record-field-accessor hash-rtd 1))
|
||||
(define set-count! (record-field-mutator hash-rtd 1))
|
||||
(define get-tc (record-field-accessor hash-rtd 2))
|
||||
;;; implementation
|
||||
|
||||
;;; directly from Dybvig's
|
||||
(define tc-pop
|
||||
(lambda (tc)
|
||||
(let ([x ($car tc)])
|
||||
(if (eq? x ($cdr tc))
|
||||
#f
|
||||
(let ([v ($car x)])
|
||||
($set-car! tc ($cdr x))
|
||||
($set-car! x #f)
|
||||
($set-cdr! x #f)
|
||||
v)))))
|
||||
|
||||
(define inthash
|
||||
(lambda (key)
|
||||
;static int inthash(int key) {
|
||||
; key += ~(key << 15);
|
||||
; key ^= (key >> 10);
|
||||
; key += (key << 3);
|
||||
; key ^= (key >> 6);
|
||||
; key += ~(key << 11);
|
||||
; key ^= (key >> 16);
|
||||
; return key;
|
||||
;}
|
||||
(let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
|
||||
[key ($fxlogxor key ($fxsra key 10))]
|
||||
[key ($fx+ key ($fxsll key 3))]
|
||||
[key ($fxlogxor key ($fxsra key 6))]
|
||||
[key ($fx+ key ($fxlognot ($fxsll key 11)))]
|
||||
[key ($fxlogxor key ($fxsra key 16))])
|
||||
key)))
|
||||
|
||||
;;; assq-like lookup
|
||||
(define direct-lookup
|
||||
(lambda (x b)
|
||||
(if (fixnum? b)
|
||||
#f
|
||||
(if (eq? x ($tcbucket-key b))
|
||||
b
|
||||
(direct-lookup x ($tcbucket-next b))))))
|
||||
|
||||
(define rehash-lookup
|
||||
(lambda (h tc x)
|
||||
(cond
|
||||
[(tc-pop tc) =>
|
||||
(lambda (b)
|
||||
(re-add! h b)
|
||||
(if (eq? x ($tcbucket-key b))
|
||||
b
|
||||
(rehash-lookup h tc x)))]
|
||||
[else #f])))
|
||||
|
||||
(define get-bucket-index
|
||||
(lambda (b)
|
||||
(let ([next ($tcbucket-next b)])
|
||||
(if (fixnum? next)
|
||||
next
|
||||
(get-bucket-index next)))))
|
||||
|
||||
(define replace!
|
||||
(lambda (lb x y)
|
||||
(let ([n ($tcbucket-next lb)])
|
||||
(cond
|
||||
[(eq? n x)
|
||||
($set-tcbucket-next! lb y)
|
||||
(void)]
|
||||
[else
|
||||
(replace! n x y)]))))
|
||||
|
||||
(define re-add!
|
||||
(lambda (h b)
|
||||
(let ([vec (get-vec h)]
|
||||
[next ($tcbucket-next b)])
|
||||
;;; first remove it from its old place
|
||||
(let ([idx
|
||||
(if (fixnum? next)
|
||||
next
|
||||
(get-bucket-index next))])
|
||||
(let ([fst ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(eq? fst b)
|
||||
($vector-set! vec idx next)]
|
||||
[else
|
||||
(replace! fst b next)])))
|
||||
;;; then add it to the new place
|
||||
(let ([k ($tcbucket-key b)])
|
||||
(let ([ih (inthash (pointer-value k))])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([n ($vector-ref vec idx)])
|
||||
($set-tcbucket-next! b n)
|
||||
($vector-set! vec idx b)
|
||||
($set-tcbucket-tconc! b (get-tc h))
|
||||
(void))))))))
|
||||
|
||||
(define get-hash
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (get-vec h)])
|
||||
(let ([ih (inthash pv)])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([b ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
($tcbucket-val b))]
|
||||
[else v])))))))
|
||||
|
||||
(define put-hash!
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (get-vec h)])
|
||||
(let ([ih (inthash pv)])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([b ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
($set-tcbucket-val! b v)
|
||||
(void))]
|
||||
[else
|
||||
($vector-set! vec idx
|
||||
($make-tcbucket (get-tc h) x v
|
||||
($vector-ref vec idx)))
|
||||
(let ([ct (get-count h)])
|
||||
(set-count! h ($fxadd1 ct))
|
||||
(when ($fx> ct ($vector-length vec))
|
||||
(enlarge-table h)))])))))))
|
||||
|
||||
(define insert-b
|
||||
(lambda (b vec mask)
|
||||
(let* ([x ($tcbucket-key b)]
|
||||
[pv (pointer-value x)]
|
||||
[ih (inthash pv)]
|
||||
[idx ($fxlogand ih mask)]
|
||||
[next ($tcbucket-next b)])
|
||||
($set-tcbucket-next! b ($vector-ref vec idx))
|
||||
($vector-set! vec idx b)
|
||||
(unless (fixnum? next)
|
||||
(insert-b next vec mask)))))
|
||||
|
||||
(define move-all
|
||||
(lambda (vec1 i n vec2 mask)
|
||||
(unless ($fx= i n)
|
||||
(let ([b ($vector-ref vec1 i)])
|
||||
(unless (fixnum? b)
|
||||
(insert-b b vec2 mask))
|
||||
(move-all vec1 ($fxadd1 i) n vec2 mask)))))
|
||||
|
||||
(define enlarge-table
|
||||
(lambda (h)
|
||||
(let* ([vec1 (get-vec h)]
|
||||
[n1 ($vector-length vec1)]
|
||||
[n2 ($fxsll n1 1)]
|
||||
[vec2 (make-base-vec n2)])
|
||||
(move-all vec1 0 n1 vec2 ($fx- n2 1))
|
||||
(set-vec! h vec2))))
|
||||
|
||||
|
||||
|
||||
(define init-vec
|
||||
(lambda (v i n)
|
||||
(if ($fx= i n)
|
||||
v
|
||||
(begin
|
||||
($vector-set! v i i)
|
||||
(init-vec v ($fxadd1 i) n)))))
|
||||
|
||||
(define make-base-vec
|
||||
(lambda (n)
|
||||
(init-vec (make-vector n) 0 n)))
|
||||
|
||||
;;; public interface
|
||||
(primitive-set! 'hash-table? (record-predicate hash-rtd))
|
||||
(primitive-set! 'make-hash-table
|
||||
(let ([make (record-constructor hash-rtd)])
|
||||
(lambda ()
|
||||
(let ([x (cons #f #f)])
|
||||
(let ([tc (cons x x)])
|
||||
(make (make-base-vec 32) 0 tc))))))
|
||||
(primitive-set! 'get-hash-table
|
||||
(lambda (h x v)
|
||||
(if (hash-table? h)
|
||||
(get-hash h x v)
|
||||
(error 'get-hash-table "~s is not a hash table" h))))
|
||||
(primitive-set! 'put-hash-table!
|
||||
(lambda (h x v)
|
||||
(if (hash-table? h)
|
||||
(put-hash! h x v)
|
||||
(error 'put-hash-table! "~s is not a hash table" h)))))
|
||||
|
|
@ -32,6 +32,7 @@
|
|||
;;; ret
|
||||
;;; sall
|
||||
;;; sarl
|
||||
;;; shrl
|
||||
;;; sete
|
||||
;;; setg
|
||||
|
||||
|
|
@ -110,6 +111,7 @@
|
|||
[subl s d]
|
||||
[sall s d]
|
||||
[sarl s d]
|
||||
[shrl s d]
|
||||
[andl s d]
|
||||
[xorl s d]
|
||||
[orl s d]
|
||||
|
|
@ -499,6 +501,17 @@
|
|||
[(and (eq? src '%cl) (reg? dst))
|
||||
(CODE #xD3 (ModRM 3 '/4 dst ac))]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(shrl)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
[(and (equal? '(int 1) src) (reg? dst))
|
||||
(CODE #xD1 (ModRM 3 '/5 dst ac))]
|
||||
[(and (imm8? src) (reg? dst))
|
||||
(CODE #xC1 (ModRM 3 '/5 dst (IMM8 src ac)))]
|
||||
[(and (eq? src '%cl) (reg? dst))
|
||||
(CODE #xD3 (ModRM 3 '/5 dst ac))]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(sarl)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
|
|
|
|||
Binary file not shown.
BIN
src/libio.fasl
BIN
src/libio.fasl
Binary file not shown.
Binary file not shown.
|
|
@ -0,0 +1,534 @@
|
|||
|
||||
;;; 6.2: initial syncase implementation
|
||||
;;;
|
||||
|
||||
|
||||
;;; Expand : Scheme -> Core Scheme
|
||||
;;;
|
||||
;;; <CS> ::= (quote datum)
|
||||
;;; | <gensym>
|
||||
;;; | (if <CS> <CS> <CS>)
|
||||
;;; | (set! <gensym> <CS>)
|
||||
;;; | (begin <CS> <CS> ...)
|
||||
;;; | (letrec ([<gensym> <CS>] ...) <CS> <CS> ...)
|
||||
;;; | (lambda <FMLS> <CS> <CS> ...)
|
||||
;;; | (<prim> <CS> <CS> ...)
|
||||
;;; | (#primitive| <primname>)
|
||||
;;; | (<CS> <CS> ...)
|
||||
;;; <FML> ::= ()
|
||||
;;; | <gensym>
|
||||
;;; | (<gensym> . <FML>)
|
||||
;;; <prim> ::= void | memv | top-level-value | set-top-level-value!
|
||||
;;; | primitive-set! | foreign-call | $apply
|
||||
|
||||
(let ([*stx* (make-record-type "*stx*" '(e marks ribcage))]
|
||||
[*rib* (make-record-type "*rib*" '(sym* marks* lab*))]
|
||||
[*top* (make-record-type "*top*" '())])
|
||||
|
||||
(define stx? (record-predicate *stx*))
|
||||
(define make-stx (record-constructor *stx*))
|
||||
(define stx-e (record-field-accessor *stx* 'e))
|
||||
(define stx-marks (record-field-accessor *stx* 'marks))
|
||||
(define stx-ribcage (record-field-accessor *stx* 'ribcage))
|
||||
(define make-rib (record-constructor *rib*))
|
||||
(define rib-sym* (record-field-accessor *rib* 'sym*))
|
||||
(define rib-marks* (record-field-accessor *rib* 'marks*))
|
||||
(define rib-lab* (record-field-accessor *rib* 'lab*))
|
||||
(define *top-ribcage* ((record-constructor *top*)))
|
||||
(define (top? x) (eq? x *top-ribcage*))
|
||||
(define *syncase-macro* (gensym "*syncase-macro*"))
|
||||
|
||||
(define (build-data x) `(quote ,x))
|
||||
(define (build-global-ref x) `(top-level-value ',x))
|
||||
(define (build-lexical-ref x) x)
|
||||
(define (build-app a d) `(,a . ,d))
|
||||
(define (build-lambda fml* body)
|
||||
(cond
|
||||
[(and (pair? body) (eq? (car body) 'begin))
|
||||
`(lambda ,fml* . ,(cdr body))]
|
||||
[else
|
||||
`(lambda ,fml* ,body)]))
|
||||
(define (build-begin body*) `(begin . ,body*))
|
||||
|
||||
|
||||
(define (build-void) `(void))
|
||||
(define (build-if e0 e1 e2) `(if ,e0 ,e1 ,e2))
|
||||
(define (build-foreign-call e e*) `(foreign-call ,e ,e*))
|
||||
|
||||
|
||||
|
||||
(define (id? x)
|
||||
(and (stx? x)
|
||||
(symbol? (stx-e x))))
|
||||
|
||||
(define (stx->datum x) ;;;; use strip
|
||||
(cond
|
||||
[(stx? x) (stx-e x)]
|
||||
[else x]))
|
||||
|
||||
(define (stx-pair? x)
|
||||
(and (stx? x)
|
||||
(pair? (stx-e x))))
|
||||
|
||||
(define (strip x)
|
||||
(cond
|
||||
[(stx? x) (stx-e x)]
|
||||
[else x]))
|
||||
|
||||
(define label? string?)
|
||||
|
||||
(define (eqmarks? m1* m2*)
|
||||
(cond
|
||||
[(null? m1*) (null? m2*)]
|
||||
[(memq (car m1*) m2*) (eqmarks? (cdr m1*) (remq (car m1*) m2*))]
|
||||
[else #f]))
|
||||
|
||||
(define (rib-lookup sym m* sym* m** lab*)
|
||||
(and (pair? sym*)
|
||||
(if (and (eq? sym (car sym*))
|
||||
(eqmarks? m* (car m**)))
|
||||
(car lab*)
|
||||
(rib-lookup sym m* (cdr sym*) (cdr m**) (cdr lab*)))))
|
||||
|
||||
(define (ribcage-lookup sym m* rc)
|
||||
(cond
|
||||
[(pair? rc)
|
||||
(let ([r (car rc)])
|
||||
(cond
|
||||
[(eq? r 'shift)
|
||||
(ribcage-lookup sym (cdr m*) (cdr rc))]
|
||||
[else
|
||||
(or (rib-lookup sym m* (rib-sym* r) (rib-marks* r) (rib-lab* r))
|
||||
(ribcage-lookup sym m* (cdr rc)))]))]
|
||||
[(top? rc) #f]
|
||||
[else (error "BUG1")]))
|
||||
|
||||
(define (resolve x)
|
||||
(unless (id? x) (error "BUG2"))
|
||||
(let ([sym (stx-e x)]
|
||||
[m* (stx-marks x)]
|
||||
[rc (stx-ribcage x)])
|
||||
(or (ribcage-lookup sym m* rc) ; bound -> label
|
||||
(getprop sym *syncase-macro*) ; top-level-macros -> pair
|
||||
sym ; global -> symbol
|
||||
)))
|
||||
|
||||
(define (remove-last ls)
|
||||
(let ([d (cdr ls)])
|
||||
(cond
|
||||
[(null? d) '()]
|
||||
[else (cons (car ls) (remove-last d))])))
|
||||
|
||||
(define (unshift rc)
|
||||
(cond
|
||||
[(pair? rc)
|
||||
(if (eq? (car rc) 'shift)
|
||||
(cdr rc)
|
||||
(cons (car rc) (unshift (cdr rc))))]
|
||||
[else (error "BUG3: missing shift")]))
|
||||
|
||||
(define (push-wrap m r x)
|
||||
(cond
|
||||
[(stx? x)
|
||||
(let ([xm (stx-marks x)])
|
||||
(cond
|
||||
[(and (pair? xm) (eq? (car xm) #f))
|
||||
(make-stx (stx-e x)
|
||||
(append (remove-last m) (cdr xm))
|
||||
(unshift (append r (stx-ribcage x))))]
|
||||
[else
|
||||
(make-stx (stx-e x)
|
||||
(append m xm)
|
||||
(append r (stx-ribcage x)))]))]
|
||||
[else (make-stx x m r)]))
|
||||
|
||||
(define (push-subst sym* marks* lab* x)
|
||||
(cond
|
||||
[(stx? x)
|
||||
(make-stx (stx-e x)
|
||||
(stx-marks x)
|
||||
(cons (make-rib sym* marks* lab*) (stx-ribcage x)))]
|
||||
[else
|
||||
(make-stx x
|
||||
'()
|
||||
(cons (make-rib sym* marks* lab*) '()))]))
|
||||
|
||||
(define (push-antimark x)
|
||||
(cond
|
||||
[(stx? x)
|
||||
(make-stx (stx-e x)
|
||||
(cons #f (stx-marks x))
|
||||
(stx-ribcage x))]
|
||||
[else (make-stx x (cons #f '()) '())]))
|
||||
|
||||
(define (push-mark m x)
|
||||
(cond
|
||||
[(stx? x)
|
||||
(let ([m* (stx-marks x)])
|
||||
(cond
|
||||
[(and (pair? m*) (eq? (car m*) #f))
|
||||
(make-stx (stx-e x) (cdr m*) (stx-ribcage x))]
|
||||
[else
|
||||
(make-stx (stx-e x) (cons m m*) (cons 'shift (stx-ribcage x)))]))]
|
||||
[else
|
||||
(make-stx x (list m) '(shift))]))
|
||||
|
||||
(define (push-rib rib x)
|
||||
(cond
|
||||
[(stx? x)
|
||||
(make-stx (stx-e x) (stx-marks x) (cons rib (stx-ribcage x)))]
|
||||
[else (make-stx x '() (list rib))]))
|
||||
|
||||
(define (expose-stx x)
|
||||
(let ([e (stx-e x)])
|
||||
(cond
|
||||
[(pair? e)
|
||||
(let ([m (stx-marks x)]
|
||||
[r (stx-ribcage x)])
|
||||
(cons
|
||||
(push-wrap m r (car e))
|
||||
(push-wrap m r (cdr e))))]
|
||||
[(vector? e)
|
||||
(let ([m (stx-marks x)]
|
||||
[r (stx-ribcage x)])
|
||||
(list->vector
|
||||
(map (lambda (x) (push-wrap m r x))
|
||||
(vector->list e))))]
|
||||
[(null? e) e]
|
||||
[else x])))
|
||||
|
||||
(define (expose x)
|
||||
(cond
|
||||
[(stx? x) (expose-stx x)]
|
||||
[else x]))
|
||||
|
||||
(define (expose-ls ox)
|
||||
(let loop ([x (expose ox)])
|
||||
(cond
|
||||
[(pair? x) (cons (car x) (loop (expose (cdr x))))]
|
||||
[(null? x) '()]
|
||||
[else (error 'expose-ls "BUG: not a list: ~s" x)])))
|
||||
|
||||
(define (expose* x)
|
||||
(cond
|
||||
[(id? x) x]
|
||||
[(stx? x) (expose* (expose x))]
|
||||
[(pair? x) (cons (expose* (car x)) (expose* (cdr x)))]
|
||||
[(vector? x)
|
||||
(list->vector (map expose* (vector->list x)))]
|
||||
[else x]))
|
||||
|
||||
(define (lookup lab r)
|
||||
(define (lookup1 lab lab* g*)
|
||||
(cond
|
||||
[(null? lab*) #f]
|
||||
[(eq? lab (car lab*)) (car g*)]
|
||||
[else (lookup1 lab (cdr lab*) (cdr g*))]))
|
||||
(cond
|
||||
[(null? r) #f]
|
||||
[(eq? (car r) 'lexical-barrier)
|
||||
(let ([v (lookup lab (cdr r))])
|
||||
(cond
|
||||
[(not (symbol? v)) v]
|
||||
[else #f]))]
|
||||
[else
|
||||
(or (lookup1 lab (caar r) (cdar r))
|
||||
(lookup lab (cdr r)))]))
|
||||
|
||||
(define (genmark) (gensym "M"))
|
||||
(define (newsym x)
|
||||
(gensym))
|
||||
;(gensym (symbol->string x)))
|
||||
|
||||
(define (apply-macro proc x r)
|
||||
(expand-ctx (push-mark (genmark) (proc (push-antimark x))) r))
|
||||
|
||||
(define (identifier-macro? x r)
|
||||
(and (id? x)
|
||||
(let ([a (resolve x)])
|
||||
(or (and (label? a)
|
||||
(let ([a (lookup a r)])
|
||||
(and (procedure? a) a)))
|
||||
(and (pair? a)
|
||||
(eq? (car a) '*user-macro*)
|
||||
(cdr a))))))
|
||||
|
||||
(define (macro-call? x r)
|
||||
(if (id? x)
|
||||
(identifier-macro? x r)
|
||||
(let ([x (expose x)])
|
||||
(and (pair? x)
|
||||
(identifier-macro? (car x) r)))))
|
||||
|
||||
(define (core? x)
|
||||
(and (pair? x) (eq? (car x) '*core-macro*)))
|
||||
|
||||
(define (apply-core-form a d ctx r)
|
||||
(unless (core? a) (syntax-error ctx))
|
||||
((cdr a) a d ctx r))
|
||||
|
||||
(define (E* d r ctx)
|
||||
(let ([d (expose-ls d)])
|
||||
(map (lambda (x) (E x r)) d)))
|
||||
|
||||
(define (extend-core name proc)
|
||||
(putprop name *syncase-macro* (cons '*core-macro* proc)))
|
||||
|
||||
(define (extend-user-macro name proc)
|
||||
(putprop name *syncase-macro* (cons '*user-macro* proc)))
|
||||
|
||||
(define (E ctx r)
|
||||
(let ([x (expose ctx)])
|
||||
(cond
|
||||
[(macro-call? x r) =>
|
||||
(lambda (proc)
|
||||
(apply-macro proc ctx r))]
|
||||
[(pair? x)
|
||||
(let ([a (car x)] [d (cdr x)])
|
||||
(cond
|
||||
[(id? a)
|
||||
(let ([a (resolve a)])
|
||||
(cond
|
||||
[(label? a)
|
||||
(cond
|
||||
[(lookup a r) =>
|
||||
(lambda (g)
|
||||
(cond
|
||||
[(symbol? g)
|
||||
(build-app (build-lexical-ref g)
|
||||
(E* d r ctx))]
|
||||
[(and (pair? g) (eq? (car g) 'pat))
|
||||
(syntax-error ctx)]
|
||||
[else (error 'expand "BUG4")]))]
|
||||
[else (syntax-error ctx)])]
|
||||
[(core? a)
|
||||
(apply-core-form a d ctx r)]
|
||||
[(symbol? a)
|
||||
(build-app (build-global-ref a)
|
||||
(E* d r ctx))]
|
||||
[else (syntax-error ctx)]))]
|
||||
[else
|
||||
(build-app
|
||||
(E a r)
|
||||
(E* d r ctx))]))]
|
||||
[(id? x)
|
||||
(let ([a (resolve x)])
|
||||
(cond
|
||||
[(label? a)
|
||||
(cond
|
||||
[(lookup a r) =>
|
||||
(lambda (g)
|
||||
(cond
|
||||
[(symbol? g) (build-lexical-ref g)]
|
||||
[(and (pair? g) (eq? (car g) 'pat))
|
||||
(syntax-error ctx)]
|
||||
[else (error 'expand "BUG5")]))]
|
||||
[else (syntax-error ctx)])]
|
||||
[(core? a) (syntax-error ctx)]
|
||||
[(symbol? a)
|
||||
(build-global-ref a)]
|
||||
[else (syntax-error ctx)]))]
|
||||
[else (build-data (strip x))])))
|
||||
|
||||
(define (core-expand x)
|
||||
(E (make-stx x '() *top-ribcage*) '()))
|
||||
|
||||
(define (process-fml* bind* ctx)
|
||||
(define (assert-no-dups s m* s* m**)
|
||||
(unless (null? s*)
|
||||
(when (and (eq? s (car s*))
|
||||
(eqmarks? m* (car m**)))
|
||||
(syntax-error ctx))
|
||||
(assert-no-dups s m* (cdr s*) (cdr m*))))
|
||||
(let loop ([bind* (expose bind*)])
|
||||
(cond
|
||||
[(null? bind*) (values '() '() '() '() '())]
|
||||
[(pair? bind*)
|
||||
(let ([b (car bind*)])
|
||||
(unless (id? b) (syntax-error ctx))
|
||||
(let-values ([(fml* s* m** g* lab*)
|
||||
(loop (expose (cdr bind*)))])
|
||||
(let ([s (stx-e b)] [m* (stx-marks b)])
|
||||
(assert-no-dups s m* s* m**)
|
||||
(let ([lab (string #\i)] [g (newsym s)])
|
||||
(values (cons g fml*)
|
||||
(cons s s*)
|
||||
(cons m* m**)
|
||||
(cons g g*)
|
||||
(cons lab lab*))))))]
|
||||
[else (syntax-error ctx)])))
|
||||
|
||||
(define (top-level-macro? x r sym)
|
||||
(let ([x (expose x)])
|
||||
(and (pair? x)
|
||||
(id? (car x))
|
||||
(let ([loc (resolve (car x))])
|
||||
(and (or (and (pair? loc)
|
||||
(eq? (car loc) '*core-macro*))
|
||||
(symbol? loc))
|
||||
(eq? (stx->datum (car x)) sym))))))
|
||||
|
||||
(define (define? x r)
|
||||
(top-level-macro? x r 'define))
|
||||
|
||||
(define (begin? x r)
|
||||
(top-level-macro? x r 'begin))
|
||||
|
||||
(define (begin-e* x ctx)
|
||||
(let ([x (expose x)])
|
||||
(let loop ([x (expose (cdr x))])
|
||||
(cond
|
||||
[(null? x) '()]
|
||||
[(pair? x) (cons (car x) (loop (expose (cdr x))))]
|
||||
[else (syntax-error ctx)]))))
|
||||
|
||||
(define (expand-body* body* ctx r)
|
||||
(let ([rib (make-rib '() '() '())])
|
||||
(let loop ([body* (expose (push-rib rib body*))]
|
||||
[r r]
|
||||
[lab* '()] [sym* '()] [marks* '()] [vrhs* '()])
|
||||
(cond
|
||||
[(null? body*) (syntax-error ctx)]
|
||||
[(pair? body*)
|
||||
(let ([a (car body*)] [d (cdr body*)])
|
||||
(cond
|
||||
[(macro-call? a r) =>
|
||||
(lambda (proc)
|
||||
(loop (cons (push-mark (genmark) (proc (push-antimark a))) d)
|
||||
r lab* sym* marks* vrhs*))]
|
||||
[(define? a r)
|
||||
(let-values ([(lhs rhs) (extract-define a ctx)])
|
||||
(loop (expose d)
|
||||
r
|
||||
(cons (string #\p) lab*)
|
||||
(cons (stx-e lhs) sym*)
|
||||
(cons (stx-marks lhs) marks*)
|
||||
(cons rhs vrhs*)))]
|
||||
[(begin? a r)
|
||||
(loop (expose (append (begin-e* a ctx) d))
|
||||
r lab* sym* marks* vrhs*)]
|
||||
[else
|
||||
;;; done
|
||||
(cond
|
||||
[(null? sym*)
|
||||
(let ([body* (E* body* r ctx)])
|
||||
(build-begin body*))]
|
||||
[else
|
||||
(let ([g* (map newsym sym*)])
|
||||
(let* ([r (cons (cons lab* g*) r)]
|
||||
[rhs*
|
||||
(E* (push-subst sym* marks* lab* vrhs*)
|
||||
r ctx)]
|
||||
[body*
|
||||
(E* (push-subst sym* marks* lab* body*)
|
||||
r ctx)])
|
||||
(build-letrec g* rhs* (build-begin body*))))])]))]
|
||||
[else (syntax-error ctx)]))))
|
||||
|
||||
(define (extract-bindings bind* ctx)
|
||||
(let ([bind* (expose bind*)])
|
||||
(cond
|
||||
[(null? bind*) (values '() '())]
|
||||
[(not (pair? bind*)) (syntax-error ctx)]
|
||||
[else
|
||||
(let ([a (car bind*)] [d (cdr bind*)])
|
||||
(let ([a (expose-ls a)])
|
||||
(cond
|
||||
[(fx= (length a) 2)
|
||||
(let-values ([(lhs* rhs*)
|
||||
(extract-bindings d ctx)])
|
||||
(values (cons (car a) lhs*)
|
||||
(cons (cadr a) rhs*)))]
|
||||
[else (syntax-error ctx)])))])))
|
||||
|
||||
(define (core-stx x)
|
||||
(make-stx x '() *top-ribcage*))
|
||||
|
||||
(extend-core 'quote
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose-ls d)])
|
||||
(cond
|
||||
[(and (list? d) (fx= (length d) 1))
|
||||
(build-data (strip (car d)))]
|
||||
[else (syntax-error ctx)]))))
|
||||
|
||||
(extend-core 'lambda
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose d)])
|
||||
(cond
|
||||
[(pair? d)
|
||||
(let ([fml* (car d)] [body* (cdr d)])
|
||||
(let-values ([(fml* s* m** g* lab*)
|
||||
(process-fml* fml* ctx)])
|
||||
(let ([body* (push-subst s* m** lab* body*)])
|
||||
(let ([r (cons (cons lab* g*) r)])
|
||||
(build-lambda fml*
|
||||
(expand-body* body* ctx r))))))]
|
||||
[else (syntax-error ctx)]))))
|
||||
|
||||
(extend-core 'if
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose d)])
|
||||
(unless (pair? d) (syntax-error ctx))
|
||||
(let ([test (car d)] [d (expose (cdr d))])
|
||||
(unless (pair? d) (syntax-error ctx))
|
||||
(let ([conseq (car d)] [d (expose (cdr d))])
|
||||
(let ([altern
|
||||
(cond
|
||||
[(null? d) (build-void)]
|
||||
[(pair? d)
|
||||
(let ([altern (car d)] [d (expose (cdr d))])
|
||||
(cond
|
||||
[(null? d) (E altern r)]
|
||||
[else (syntax-error ctx)]))]
|
||||
[else (syntax-error ctx)])])
|
||||
(build-if (E test r) (E conseq r) altern)))))))
|
||||
|
||||
(extend-core 'begin
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose-ls d)])
|
||||
(when (null? d) (syntax-error ctx))
|
||||
(build-begin (E* d r ctx)))))
|
||||
|
||||
|
||||
(extend-core 'define
|
||||
(lambda (a d ctx r) (syntax-error ctx)))
|
||||
|
||||
(extend-core 'foreign-call
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose-ls d)])
|
||||
(unless (fx>= (length d) 1) (syntax-error ctx))
|
||||
(build-foreign-call
|
||||
(E (car d) r)
|
||||
(E* (cdr d) r ctx)))))
|
||||
|
||||
(extend-core 'let
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose d)])
|
||||
(unless (pair? d) (syntax-error ctx))
|
||||
(let ([bind* (car d)] [body* (cdr d)])
|
||||
(let-values ([(lhs* rhs*)
|
||||
(extract-bindings bind* ctx)])
|
||||
(let ([lambda^ (core-stx 'lambda)])
|
||||
(E `((,lambda^ ,lhs* . ,body*) . ,rhs*) r)))))))
|
||||
|
||||
(extend-core 'let*
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose d)])
|
||||
(unless (pair? d) (syntax-error ctx))
|
||||
(let ([bind* (car d)] [body* (cdr d)])
|
||||
(let-values ([(lhs* rhs*)
|
||||
(extract-bindings bind* ctx)])
|
||||
(let ([lambda^ (core-stx 'lambda)])
|
||||
(E (let f ([lhs* lhs*] [rhs* rhs*])
|
||||
(cond
|
||||
[(null? lhs*)
|
||||
`((,lambda^ () . ,body*))]
|
||||
[else
|
||||
`((,lambda^ (,(car lhs*))
|
||||
,(f (cdr lhs*) (cdr rhs*)))
|
||||
,(car rhs*))]))
|
||||
r)))))))
|
||||
|
||||
(set! expand core-expand)
|
||||
)
|
||||
Binary file not shown.
Binary file not shown.
|
|
@ -0,0 +1,373 @@
|
|||
|
||||
;;; 6.2: * added a printer for bwp-objects
|
||||
|
||||
;;; WRITER provides display and write.
|
||||
|
||||
(let ()
|
||||
(define char-table ; first nonprintable chars
|
||||
'#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
|
||||
"vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak"
|
||||
"syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
|
||||
(define write-character
|
||||
(lambda (x p m)
|
||||
(if m
|
||||
(let ([i ($char->fixnum x)])
|
||||
(write-char #\# p)
|
||||
(cond
|
||||
[(fx< i (vector-length char-table))
|
||||
(write-char #\\ p)
|
||||
(write-char* (vector-ref char-table i) p)]
|
||||
[(fx< i 127)
|
||||
(write-char #\\ p)
|
||||
(write-char x p)]
|
||||
[(fx= i 127)
|
||||
(write-char #\\ p)
|
||||
(write-char* "del" p)]
|
||||
[else
|
||||
(write-char #\+ p)
|
||||
(write-fixnum i p)]))
|
||||
(write-char x p))))
|
||||
(define write-list
|
||||
(lambda (x p m)
|
||||
(cond
|
||||
[(pair? x)
|
||||
(write-char #\space p)
|
||||
(writer (car x) p m)
|
||||
(write-list (cdr x) p m)]
|
||||
[(not (null? x))
|
||||
(write-char #\space p)
|
||||
(write-char #\. p)
|
||||
(write-char #\space p)
|
||||
(writer x p m)])))
|
||||
(define write-vector
|
||||
(lambda (x p m)
|
||||
(write-char #\# p)
|
||||
(write-char #\( p)
|
||||
(let ([n (vector-length x)])
|
||||
(when (fx> n 0)
|
||||
(writer (vector-ref x 0) p m)
|
||||
(letrec ([f
|
||||
(lambda (i)
|
||||
(unless (fx= i n)
|
||||
(write-char #\space p)
|
||||
(writer (vector-ref x i) p m)
|
||||
(f (fxadd1 i))))])
|
||||
(f 1))))
|
||||
(write-char #\) p)))
|
||||
(define write-record
|
||||
(lambda (x p m)
|
||||
(write-char #\# p)
|
||||
(write-char #\[ p)
|
||||
(writer (record-name x) p m)
|
||||
(let ([n (record-length x)])
|
||||
(letrec ([f
|
||||
(lambda (i)
|
||||
(unless (fx= i n)
|
||||
(write-char #\space p)
|
||||
(writer (record-ref x i) p m)
|
||||
(f (fxadd1 i))))])
|
||||
(f 0)))
|
||||
(write-char #\] p)))
|
||||
(define initial?
|
||||
(lambda (c)
|
||||
(or (letter? c) (special-initial? c))))
|
||||
(define letter?
|
||||
(lambda (c)
|
||||
(or (and ($char<= #\a c) ($char<= c #\z))
|
||||
(and ($char<= #\A c) ($char<= c #\Z)))))
|
||||
(define digit?
|
||||
(lambda (c)
|
||||
(and ($char<= #\0 c) ($char<= c #\9))))
|
||||
(define special-initial?
|
||||
(lambda (x)
|
||||
(memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
|
||||
(define subsequent?
|
||||
(lambda (x)
|
||||
(or (initial? x)
|
||||
(digit? x)
|
||||
(special-subsequent? x))))
|
||||
(define special-subsequent?
|
||||
(lambda (x)
|
||||
(memq x '(#\+ #\- #\. #\@))))
|
||||
(define subsequent*?
|
||||
(lambda (str i n)
|
||||
(or ($fx= i n)
|
||||
(and (subsequent? ($string-ref str i))
|
||||
(subsequent*? str ($fxadd1 i) n)))))
|
||||
(define valid-symbol-string?
|
||||
(lambda (str)
|
||||
(or (let ([n ($string-length str)])
|
||||
(and ($fx>= n 1)
|
||||
(initial? ($string-ref str 0))
|
||||
(subsequent*? str 1 n)))
|
||||
(string=? str "+")
|
||||
(string=? str "-")
|
||||
(string=? str "..."))))
|
||||
(define write-symbol-esc-loop
|
||||
(lambda (x i n p)
|
||||
(unless ($fx= i n)
|
||||
(let ([c ($string-ref x i)])
|
||||
(when (memq c '(#\\ #\|))
|
||||
(write-char #\\ p))
|
||||
(write-char c p))
|
||||
(write-symbol-esc-loop x ($fxadd1 i) n p))))
|
||||
(define write-symbol-esc
|
||||
(lambda (x p)
|
||||
(write-char #\| p)
|
||||
(write-symbol-esc-loop x 0 ($string-length x) p)
|
||||
(write-char #\| p)))
|
||||
(define write-symbol
|
||||
(lambda (x p m)
|
||||
(let ([str (symbol->string x)])
|
||||
(if m
|
||||
(if (valid-symbol-string? str)
|
||||
(write-char* str p)
|
||||
(write-symbol-esc str p))
|
||||
(write-char* str p)))))
|
||||
(define write-gensym
|
||||
(lambda (x p m)
|
||||
(cond
|
||||
[(and m (print-gensym))
|
||||
(let ([str (symbol->string x)])
|
||||
(write-char #\# p)
|
||||
(write-char #\{ p)
|
||||
(if (valid-symbol-string? str)
|
||||
(write-char* str p)
|
||||
(write-symbol-esc str p))
|
||||
(write-char #\space p)
|
||||
(write-symbol-esc (gensym->unique-string x) p)
|
||||
(write-char #\} p))]
|
||||
[else (write-symbol x p m)])))
|
||||
(define write-string-escape
|
||||
(lambda (x p)
|
||||
(define loop
|
||||
(lambda (x i n p)
|
||||
(unless (fx= i n)
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(or ($char= #\" c) ($char= #\\ c))
|
||||
(write-char #\\ p)
|
||||
(write-char c p)]
|
||||
[($char= #\tab c)
|
||||
(write-char #\\ p)
|
||||
(write-char #\t p)]
|
||||
[else
|
||||
(write-char c p)]))
|
||||
(loop x (fxadd1 i) n p))))
|
||||
(write-char #\" p)
|
||||
(loop x 0 (string-length x) p)
|
||||
(write-char #\" p)))
|
||||
(define write-string
|
||||
(lambda (x p m)
|
||||
(if m
|
||||
(write-string-escape x p)
|
||||
(write-char* x p))))
|
||||
(define write-fixnum
|
||||
(lambda (x p)
|
||||
(define loop
|
||||
(lambda (x p)
|
||||
(unless (fxzero? x)
|
||||
(loop (fxquotient x 10) p)
|
||||
(write-char
|
||||
($fixnum->char
|
||||
($fx+ (fxremainder x 10)
|
||||
($char->fixnum #\0)))
|
||||
p))))
|
||||
(cond
|
||||
[(fxzero? x) (write-char #\0 p)]
|
||||
[(fx< x 0)
|
||||
(write-char #\- p)
|
||||
(if (fx= x -536870912)
|
||||
(write-char* "536870912" p)
|
||||
(loop (fx- 0 x) p))]
|
||||
[else (loop x p)])))
|
||||
(define write-char*
|
||||
(lambda (x p)
|
||||
(define loop
|
||||
(lambda (x i n p)
|
||||
(unless (fx= i n)
|
||||
(write-char (string-ref x i) p)
|
||||
(loop x (fxadd1 i) n p))))
|
||||
(loop x 0 (string-length x) p)))
|
||||
(define macro
|
||||
(lambda (x)
|
||||
(define macro-forms
|
||||
'([quote . "'"]
|
||||
[quasiquote . "`"]
|
||||
[unquote . ","]
|
||||
[unquote-splicing . ",@"]
|
||||
[syntax . "#'"]
|
||||
[|#primitive| . "#%"]))
|
||||
(and (pair? x)
|
||||
(let ([d ($cdr x)])
|
||||
(and (pair? d)
|
||||
(null? ($cdr d))))
|
||||
(assq ($car x) macro-forms))))
|
||||
(define writer
|
||||
(lambda (x p m)
|
||||
(cond
|
||||
[(macro x) =>
|
||||
(lambda (y)
|
||||
(write-char* (cdr y) p)
|
||||
(writer (cadr x) p m))]
|
||||
[(pair? x)
|
||||
(write-char #\( p)
|
||||
(writer (car x) p m)
|
||||
(write-list (cdr x) p m)
|
||||
(write-char #\) p)]
|
||||
[(symbol? x)
|
||||
(if (gensym? x)
|
||||
(write-gensym x p m)
|
||||
(write-symbol x p m))]
|
||||
[(fixnum? x)
|
||||
(write-fixnum x p)]
|
||||
[(string? x)
|
||||
(write-string x p m)]
|
||||
[(boolean? x)
|
||||
(write-char* (if x "#t" "#f") p)]
|
||||
[(char? x)
|
||||
(write-character x p m)]
|
||||
[(procedure? x)
|
||||
(write-char* "#<procedure>" p)]
|
||||
[(output-port? x)
|
||||
(write-char* "#<output-port " p)
|
||||
(writer (output-port-name x) p #t)
|
||||
(write-char #\> p)]
|
||||
[(input-port? x)
|
||||
(write-char* "#<input-port " p)
|
||||
(writer (input-port-name x) p #t)
|
||||
(write-char #\> p)]
|
||||
[(vector? x)
|
||||
(write-vector x p m)]
|
||||
[(null? x)
|
||||
(write-char #\( p)
|
||||
(write-char #\) p)]
|
||||
[(eq? x (void))
|
||||
(write-char* "#<void>" p)]
|
||||
[(eof-object? x)
|
||||
(write-char* "#!eof" p)]
|
||||
[(bwp-object? x)
|
||||
(write-char* "#!bwp" p)]
|
||||
[(record? x)
|
||||
(let ([printer (record-printer x)])
|
||||
(if (procedure? printer)
|
||||
(printer x p)
|
||||
(write-record x p m)))]
|
||||
;[(code? x)
|
||||
; (write-char* "#<code>" p)]
|
||||
[(hash-table? x)
|
||||
(write-char* "#<hash-table>" p)]
|
||||
[($unbound-object? x)
|
||||
(write-char* "#<unbound-object>" p)]
|
||||
[($forward-ptr? x)
|
||||
(write-char* "#<forward-ptr>" p)]
|
||||
[else
|
||||
(write-char* "#<unknown>" p)])))
|
||||
|
||||
(define (write x p)
|
||||
(writer x p #t)
|
||||
(flush-output-port p))
|
||||
(define (display x p)
|
||||
(writer x p #f)
|
||||
(flush-output-port p))
|
||||
;;;
|
||||
(define formatter
|
||||
(lambda (who p fmt args)
|
||||
(let f ([i 0] [args args])
|
||||
(unless (fx= i (string-length fmt))
|
||||
(let ([c (string-ref fmt i)])
|
||||
(cond
|
||||
[($char= c #\~)
|
||||
(let ([i (fxadd1 i)])
|
||||
(when (fx= i (string-length fmt))
|
||||
(error who "invalid ~~ at end of format string ~s" fmt))
|
||||
(let ([c (string-ref fmt i)])
|
||||
(cond
|
||||
[($char= c #\~)
|
||||
(write-char #\~ p)
|
||||
(f (fxadd1 i) args)]
|
||||
[($char= c #\a)
|
||||
(when (null? args)
|
||||
(error who "insufficient arguments"))
|
||||
(display (car args) p)
|
||||
(f (fxadd1 i) (cdr args))]
|
||||
[($char= c #\s)
|
||||
(when (null? args)
|
||||
(error who "insufficient arguments"))
|
||||
(write (car args) p)
|
||||
(f (fxadd1 i) (cdr args))]
|
||||
[else
|
||||
(error who "invalid sequence ~~~a" c)])))]
|
||||
[else
|
||||
(write-char c p)
|
||||
(f (fxadd1 i) args)]))))))
|
||||
|
||||
(define fprintf
|
||||
(lambda (port fmt . args)
|
||||
(unless (output-port? port)
|
||||
(error 'fprintf "~s is not an output port" port))
|
||||
(unless (string? fmt)
|
||||
(error 'fprintf "~s is not a string" fmt))
|
||||
(formatter 'fprintf port fmt args)))
|
||||
|
||||
(define printf
|
||||
(lambda (fmt . args)
|
||||
(unless (string? fmt)
|
||||
(error 'printf "~s is not a string" fmt))
|
||||
(formatter 'printf (current-output-port) fmt args)))
|
||||
|
||||
(define format
|
||||
(lambda (fmt . args)
|
||||
(unless (string? fmt)
|
||||
(error 'format "~s is not a string" fmt))
|
||||
(let ([p (open-output-string)])
|
||||
(formatter 'format p fmt args)
|
||||
(get-output-string p))))
|
||||
|
||||
(define print-error
|
||||
(lambda (who fmt . args)
|
||||
(unless (string? fmt)
|
||||
(error 'print-error "~s is not a string" fmt))
|
||||
(let ([p (standard-error-port)])
|
||||
(if who
|
||||
(fprintf p "Error in ~a: " who)
|
||||
(fprintf p "Error: "))
|
||||
(formatter 'print-error p fmt args)
|
||||
(write-char #\. p)
|
||||
(newline p))))
|
||||
|
||||
|
||||
;;;
|
||||
(primitive-set! 'format format)
|
||||
(primitive-set! 'printf printf)
|
||||
(primitive-set! 'fprintf fprintf)
|
||||
(primitive-set! 'write
|
||||
(case-lambda
|
||||
[(x) (write x (current-output-port))]
|
||||
[(x p)
|
||||
(unless (output-port? p)
|
||||
(error 'write "~s is not an output port" p))
|
||||
(write x p)]))
|
||||
(primitive-set! 'display
|
||||
(case-lambda
|
||||
[(x) (display x (current-output-port))]
|
||||
[(x p)
|
||||
(unless (output-port? p)
|
||||
(error 'display "~s is not an output port" p))
|
||||
(display x p)]))
|
||||
(primitive-set! 'print-error print-error)
|
||||
(primitive-set! 'current-error-handler
|
||||
(make-parameter
|
||||
(lambda args
|
||||
(apply print-error args)
|
||||
(display "exiting\n" (console-output-port))
|
||||
(flush-output-port (console-output-port))
|
||||
(exit -100))
|
||||
(lambda (x)
|
||||
(if (procedure? x)
|
||||
x
|
||||
(error 'current-error-handler "~s is not a procedure" x)))))
|
||||
(primitive-set! 'error
|
||||
(lambda args
|
||||
(apply (current-error-handler) args))))
|
||||
|
||||
Binary file not shown.
|
|
@ -0,0 +1,34 @@
|
|||
(define primitive-set! set-top-level-value!)
|
||||
(define chez-expand sc-expand)
|
||||
(define-syntax |#primitive|
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ n) #'n])))
|
||||
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
|
||||
(current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1.ss")
|
||||
(current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
|
||||
(printf "making xpsyntax.pp ...\n")
|
||||
|
||||
(with-output-to-file "xpsyntax.pp"
|
||||
(lambda ()
|
||||
(load "psyntax-7.1.ss"
|
||||
(lambda (x)
|
||||
(parameterize ([print-gensym #f]
|
||||
[print-graph #f]
|
||||
[expand-mode 'bootstrap]
|
||||
[print-vector-length #f])
|
||||
(pretty-print (sc-expand x))
|
||||
(newline)))))
|
||||
'replace)
|
||||
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because it is too large
Load Diff
|
|
@ -1,37 +1,40 @@
|
|||
|
||||
#CFLAGS = -Wall -DNDEBUG -O3
|
||||
CFLAGS = -Wall -g
|
||||
LDFLAGS = -g -ldl -luuid -rdynamic
|
||||
all: ikarus
|
||||
|
||||
ikarus: ikarus-collect.o ikarus-runtime.o ikarus-main.o ikarus-fasl.o \
|
||||
ikarus-exec.o ikarus-print.o ikarus-enter.s ikarus-symbol-table.o \
|
||||
ikarus-hash-tables.o
|
||||
gcc -g -Wall -ldl -luuid -rdynamic -o ikarus \
|
||||
ikarus-weak-pairs.o
|
||||
gcc $(LDFLAGS) -o ikarus \
|
||||
ikarus-main.o ikarus-runtime.o \
|
||||
ikarus-fasl.o ikarus-exec.o ikarus-print.o ikarus-enter.s \
|
||||
ikarus-symbol-table.o ikarus-collect.o ikarus-hash-tables.o
|
||||
ikarus-symbol-table.o ikarus-collect.o ikarus-weak-pairs.o
|
||||
|
||||
ikarus-main.o: ikarus-main.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-main.c
|
||||
gcc $(CFLAGS) -c ikarus-main.c
|
||||
|
||||
ikarus-runtime.o: ikarus-runtime.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-runtime.c
|
||||
gcc $(CFLAGS) -c ikarus-runtime.c
|
||||
|
||||
ikarus-fasl.o: ikarus-fasl.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-fasl.c
|
||||
gcc $(CFLAGS) -c ikarus-fasl.c
|
||||
|
||||
ikarus-exec.o: ikarus-exec.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-exec.c
|
||||
gcc $(CFLAGS) -c ikarus-exec.c
|
||||
|
||||
ikarus-print.o: ikarus-print.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-print.c
|
||||
gcc $(CFLAGS) -c ikarus-print.c
|
||||
|
||||
ikarus-collect.o: ikarus-collect.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-collect.c
|
||||
gcc $(CFLAGS) -c ikarus-collect.c
|
||||
|
||||
ikarus-weak-pairs.o: ikarus-weak-pairs.c ikarus.h
|
||||
gcc $(CFLAGS) -c ikarus-weak-pairs.c
|
||||
|
||||
ikarus-symbol-table.o: ikarus-symbol-table.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-symbol-table.c
|
||||
|
||||
ikarus-hash-tables.o: ikarus-hash-tables.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-hash-tables.c
|
||||
gcc $(CFLAGS) -c ikarus-symbol-table.c
|
||||
|
||||
ikarus.h: ikarus-data.h
|
||||
touch ikarus.h
|
||||
|
|
|
|||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
|
|
@ -73,6 +73,8 @@
|
|||
|
||||
#define null_object ((ikp)0x4F)
|
||||
#define void_object ((ikp)0x7F)
|
||||
#define bwp_object ((ikp)0x8F)
|
||||
|
||||
#define unbound_object ((ikp)0x6F)
|
||||
#define IK_CHAR_TAG 0x0F
|
||||
#define IK_CHAR_MASK 0xFF
|
||||
|
|
@ -184,4 +186,15 @@
|
|||
#define off_htable_size (disp_htable_size - vector_tag)
|
||||
#define off_htable_mem (disp_htable_mem - vector_tag)
|
||||
|
||||
#define disp_tcbucket_tconc 0
|
||||
#define disp_tcbucket_key 4
|
||||
#define disp_tcbucket_val 8
|
||||
#define disp_tcbucket_next 12
|
||||
#define tcbucket_size 16
|
||||
#define off_tcbucket_tconc (disp_tcbucket_tconc - vector_tag)
|
||||
#define off_tcbucket_key (disp_tcbucket_key - vector_tag)
|
||||
#define off_tcbucket_val (disp_tcbucket_val - vector_tag)
|
||||
#define off_tcbucket_next (disp_tcbucket_next - vector_tag)
|
||||
|
||||
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
|
||||
.text
|
||||
.align 8
|
||||
.globl ik_asm_enter
|
||||
.globl ik_underflow_handler
|
||||
.globl ik_foreign_call
|
||||
.globl ik_asm_reenter
|
||||
.align 8
|
||||
ik_asm_enter:
|
||||
# ignored value is the third arg 12(%esp)
|
||||
# code is the second arg 8(%esp)
|
||||
|
|
@ -46,7 +48,6 @@ L_multivalue_underflow:
|
|||
addl $4, %esp
|
||||
jmp L_do_underflow
|
||||
|
||||
.globl ik_asm_reenter
|
||||
.align 8
|
||||
ik_asm_reenter:
|
||||
# argc is at 12(%esp)
|
||||
|
|
@ -71,4 +72,25 @@ L_multi_reentry:
|
|||
jmp *-9(%ebx)
|
||||
|
||||
|
||||
.align 8
|
||||
ik_foreign_call:
|
||||
movl %esp, 8(%esi) # (movl fpr (pcb-ref 'frame-pointer))
|
||||
movl %ebp, 0(%esi) # (movl apr (pcb-ref 'allocation-pointer))
|
||||
movl %esp, %ebx # (movl fpr ebx)
|
||||
movl 24(%esi), %esp # (movl (pcb-ref 'system-stack) esp)
|
||||
pushl %esi # (pushl pcr)
|
||||
cmpl $0, %eax # (cmpl (int 0) eax)
|
||||
je L_set # (je (label Lset))
|
||||
L_loop: # (label Lloop)
|
||||
movl (%ebx,%eax), %ecx # (movl (mem ebx eax) ecx)
|
||||
pushl %ecx # (pushl ecx)
|
||||
addl $4, %eax # (addl (int 4) eax)
|
||||
cmpl $0, %eax # (cmpl (int 0) eax)
|
||||
jne L_loop # (jne (label Lloop))
|
||||
L_set: # (label Lset)
|
||||
call *%edi # (call cpr)
|
||||
movl 8(%esi), %esp # (movl (pcb-ref 'frame-pointer) fpr)
|
||||
movl 0(%esi), %ebp # (movl (pcb-ref 'allocation-pointer) apr)
|
||||
ret # (ret)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -32,6 +32,9 @@ ikp ik_exec_code(ikpcb* pcb, ikp code_ptr){
|
|||
nk->size = k->size - framesize;
|
||||
k->size = framesize;
|
||||
k->next = vector_tag + (ikp)nk;
|
||||
/* record side effect */
|
||||
unsigned int idx = ((unsigned int)(&k->next)) >> pageshift;
|
||||
pcb->dirty_vector[idx] = -1;
|
||||
}
|
||||
pcb->next_k = k->next;
|
||||
ikp fbase = pcb->frame_base - wordsize;
|
||||
|
|
|
|||
|
|
@ -91,40 +91,18 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
|
|||
}
|
||||
|
||||
|
||||
static void
|
||||
ik_link_dl(ikdl* x, ikdl* target){
|
||||
ikdl* next = target->next;
|
||||
x->next = next;
|
||||
x->prev = target;
|
||||
target->next = x;
|
||||
next->prev = x;
|
||||
}
|
||||
|
||||
static ikp
|
||||
ik_allocate_code(int size, ikpcb* pcb){
|
||||
int memreq = align_to_next_page(size + sizeof(ikcode_preheader));
|
||||
ikp mem = ik_mmap(memreq);
|
||||
ikcodes* p = ik_malloc(sizeof(ikcodes));
|
||||
p->code_object = mem + sizeof(ikcode_preheader);
|
||||
p->attr = ikcode_live;
|
||||
p->base = mem;
|
||||
p->size = memreq;
|
||||
ik_link_dl(&(p->dl), &pcb->codes);
|
||||
ref(mem, 0) = (ikp) p;
|
||||
return mem + sizeof(ikcode_preheader);
|
||||
}
|
||||
|
||||
static ikp
|
||||
ik_make_code(int code_size, int reloc_size, ikp closure_size, ikpcb* pcb){
|
||||
int required_memory =
|
||||
align(code_size + reloc_size + disp_code_data);
|
||||
|
||||
ikp mem = ik_allocate_code(required_memory, pcb);
|
||||
REF(mem, 0) = IK_CODE_SEC_TAG;
|
||||
REF(mem, IK_DISP_CODE_CODE_SIZE) = (ikp) code_size;
|
||||
REF(mem, IK_DISP_CODE_RELOC_SIZE) = (ikp) reloc_size;
|
||||
REF(mem, IK_DISP_CODE_CLOSURE_SIZE) = closure_size;
|
||||
return (ikp)(mem+IK_CODE_PRI_TAG);
|
||||
align_to_next_page(code_size + reloc_size + disp_code_data);
|
||||
ikp mem = ik_mmap_code(required_memory, 0, pcb);
|
||||
ref(mem, 0) = code_tag;
|
||||
ref(mem, disp_code_code_size) = (ikp) code_size;
|
||||
ref(mem, disp_code_reloc_size) = (ikp) reloc_size;
|
||||
ref(mem, disp_code_closure_size) = closure_size;
|
||||
ref(mem,disp_code_data+code_size+reloc_size) = 0;
|
||||
return (ikp)(mem+vector_tag);
|
||||
}
|
||||
|
||||
static char fasl_read_byte(fasl_port* p){
|
||||
|
|
@ -147,26 +125,13 @@ static void fasl_read_buf(fasl_port* p, void* buf, int n){
|
|||
exit(-1);
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
ik_set_car(ikp x, ikp v){
|
||||
REF(x, IK_OFF_CAR) = v;
|
||||
}
|
||||
|
||||
static void
|
||||
ik_set_cdr(ikp x, ikp v){
|
||||
REF(x, IK_OFF_CDR) = v;
|
||||
}
|
||||
|
||||
|
||||
|
||||
typedef struct{
|
||||
int code_size;
|
||||
int reloc_size;
|
||||
ikp closure_size;
|
||||
} code_header;
|
||||
|
||||
#define wordsize 4
|
||||
|
||||
|
||||
static ikp do_read(ikpcb* pcb, fasl_port* p){
|
||||
char c = fasl_read_byte(p);
|
||||
|
|
@ -277,8 +242,8 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
|
|||
if(put_mark_index){
|
||||
p->marks[put_mark_index] = pair;
|
||||
}
|
||||
ik_set_car(pair, do_read(pcb, p));
|
||||
ik_set_cdr(pair, do_read(pcb, p));
|
||||
ref(pair, off_car) = do_read(pcb, p);
|
||||
ref(pair, off_cdr) = do_read(pcb, p);
|
||||
return pair;
|
||||
}
|
||||
else if(c == 'M'){
|
||||
|
|
|
|||
|
|
@ -15,6 +15,111 @@
|
|||
|
||||
int total_allocated_pages = 0;
|
||||
|
||||
#define segment_size (pagesize*pagesize/wordsize)
|
||||
#define segment_shift (pageshift+pageshift-wordshift)
|
||||
#define segment_index(x) (((unsigned int)(x)) >> segment_shift)
|
||||
|
||||
static void
|
||||
extend_table_maybe(unsigned char*p, int size, ikpcb* pcb){
|
||||
assert(size == align_to_next_page(size));
|
||||
unsigned char* q = p + size;
|
||||
if(p < pcb->memory_base){
|
||||
int new_lo = segment_index(p);
|
||||
int old_lo = segment_index(pcb->memory_base);
|
||||
int hi = segment_index(pcb->memory_end);
|
||||
int new_vec_size = (hi - new_lo) * pagesize;
|
||||
int old_vec_size = (hi - old_lo) * pagesize;
|
||||
unsigned char* v = ik_mmap(new_vec_size);
|
||||
bzero(v, new_vec_size - old_vec_size);
|
||||
memcpy(v+new_vec_size-old_vec_size, pcb->dirty_vector_base, old_vec_size);
|
||||
ik_munmap(pcb->dirty_vector_base, old_vec_size);
|
||||
pcb->dirty_vector_base = (unsigned int*) v;
|
||||
pcb->dirty_vector = (unsigned int*)(v - new_lo * pagesize);
|
||||
unsigned char* s = ik_mmap(new_vec_size);
|
||||
bzero(s, new_vec_size - old_vec_size);
|
||||
memcpy(s+new_vec_size-old_vec_size, pcb->segment_vector_base, old_vec_size);
|
||||
ik_munmap(pcb->segment_vector_base, old_vec_size);
|
||||
pcb->segment_vector_base = (unsigned int*) s;
|
||||
pcb->segment_vector = (unsigned int*)(s - new_lo * pagesize);
|
||||
pcb->memory_base = (unsigned char*)(new_lo * segment_size);
|
||||
}
|
||||
else if (q > pcb->memory_end){
|
||||
fprintf(stderr, "must extend segment table upwards!\n");
|
||||
fprintf(stderr, "mem: 0x%08x ... 0x%08x\n",
|
||||
(int)pcb->memory_base, (int)pcb->memory_end-1);
|
||||
fprintf(stderr, "new: 0x%08x ... 0x%08x\n",
|
||||
(int)p, (int)q-1);
|
||||
exit(-1);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
set_segment_type(unsigned char* base, int size, unsigned int type, ikpcb* pcb){
|
||||
assert(base >= pcb->memory_base);
|
||||
assert((base+size) <= pcb->memory_end);
|
||||
assert(size == align_to_next_page(size));
|
||||
unsigned int* p = pcb->segment_vector + page_index(base);
|
||||
unsigned int* q = p + page_index(size);
|
||||
while(p < q){
|
||||
*p = type;
|
||||
p++;
|
||||
}
|
||||
}
|
||||
|
||||
void
|
||||
ik_munmap_from_segment(unsigned char* base, int size, ikpcb* pcb){
|
||||
assert(base >= pcb->memory_base);
|
||||
assert((base+size) <= pcb->memory_end);
|
||||
assert(size == align_to_next_page(size));
|
||||
unsigned int* p = pcb->segment_vector + page_index(base);
|
||||
unsigned int* s = pcb->dirty_vector + page_index(base);
|
||||
unsigned int* q = p + page_index(size);
|
||||
while(p < q){
|
||||
assert(*p != hole_mt);
|
||||
*p = hole_mt; /* holes */
|
||||
*s = 0;
|
||||
p++; s++;
|
||||
}
|
||||
ik_munmap(base, size);
|
||||
}
|
||||
|
||||
|
||||
|
||||
void*
|
||||
ik_mmap_typed(int size, unsigned int type, ikpcb* pcb){
|
||||
unsigned char* p = ik_mmap(size);
|
||||
extend_table_maybe(p, size, pcb);
|
||||
set_segment_type(p, size, type, pcb);
|
||||
return p;
|
||||
}
|
||||
|
||||
void*
|
||||
ik_mmap_ptr(int size, int gen, ikpcb* pcb){
|
||||
return ik_mmap_typed(size, pointers_mt | gen, pcb);
|
||||
}
|
||||
|
||||
void*
|
||||
ik_mmap_data(int size, int gen, ikpcb* pcb){
|
||||
return ik_mmap_typed(size, data_mt | gen, pcb);
|
||||
}
|
||||
|
||||
void*
|
||||
ik_mmap_code(int size, int gen, ikpcb* pcb){
|
||||
return ik_mmap_typed(size, code_mt | gen, pcb);
|
||||
}
|
||||
|
||||
|
||||
void*
|
||||
ik_mmap_mixed(int size, ikpcb* pcb){
|
||||
assert(0);
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
void*
|
||||
ik_mmap(int size){
|
||||
int pages = (size + pagesize - 1) / pagesize;
|
||||
|
|
@ -117,6 +222,40 @@ ikpcb* ik_make_pcb(){
|
|||
codes->next = codes;
|
||||
codes->prev = codes;
|
||||
|
||||
{
|
||||
/* compute extent of heap and stack */
|
||||
unsigned char* lo_mem;
|
||||
unsigned char* hi_mem;
|
||||
if(pcb->heap_base < pcb->stack_base){
|
||||
lo_mem = pcb->heap_base - pagesize;
|
||||
hi_mem = pcb->stack_base + pcb->stack_size + pagesize;
|
||||
} else {
|
||||
lo_mem = pcb->stack_base - pagesize;
|
||||
hi_mem = pcb->heap_base + pcb->heap_size + pagesize;
|
||||
}
|
||||
|
||||
int lo_seg = segment_index(lo_mem);
|
||||
int hi_seg = segment_index(hi_mem+segment_size-1);
|
||||
int vec_size = (hi_seg - lo_seg) * pagesize;
|
||||
char* dvec = ik_mmap(vec_size);
|
||||
bzero(dvec, vec_size);
|
||||
pcb->dirty_vector_base = (unsigned int*) (dvec);
|
||||
pcb->dirty_vector = (unsigned int*) (dvec - lo_seg * pagesize);
|
||||
char* svec = ik_mmap(vec_size);
|
||||
bzero(svec, vec_size);
|
||||
pcb->segment_vector_base = (unsigned int*) (svec);
|
||||
pcb->segment_vector = (unsigned int*) (svec - lo_seg * pagesize);
|
||||
pcb->memory_base = (unsigned char*)(lo_seg * segment_size);
|
||||
pcb->memory_end = (unsigned char*)(hi_seg * segment_size);
|
||||
set_segment_type(pcb->heap_base-pagesize,
|
||||
pcb->heap_size+2*pagesize,
|
||||
mainheap_mt,
|
||||
pcb);
|
||||
set_segment_type(pcb->stack_base-pagesize,
|
||||
pcb->stack_size+2*pagesize,
|
||||
mainstack_mt,
|
||||
pcb);
|
||||
}
|
||||
/* initialize base rtd */
|
||||
{
|
||||
ikp s = ik_cstring_to_symbol("$base-rtd", pcb);
|
||||
|
|
@ -133,6 +272,7 @@ ikpcb* ik_make_pcb(){
|
|||
}
|
||||
|
||||
void ik_delete_pcb(ikpcb* pcb){
|
||||
assert(0);
|
||||
free(pcb);
|
||||
}
|
||||
|
||||
|
|
@ -159,7 +299,7 @@ ik_alloc(ikpcb* pcb, int size){
|
|||
int new_size = (size > IK_HEAP_EXT_SIZE) ? size : IK_HEAP_EXT_SIZE;
|
||||
new_size += 2 * 4096;
|
||||
new_size = align_to_next_page(new_size);
|
||||
ap = ik_mmap(new_size);
|
||||
ap = ik_mmap_mixed(new_size, pcb);
|
||||
pcb->heap_base = ap;
|
||||
pcb->heap_size = new_size;
|
||||
pcb->allocation_redline = ap + new_size - 2 * 4096;
|
||||
|
|
@ -169,6 +309,8 @@ ik_alloc(ikpcb* pcb, int size){
|
|||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
void ik_error(ikp args){
|
||||
fprintf(stderr, "Error: ");
|
||||
ik_fprint(stderr, args);
|
||||
|
|
@ -275,3 +417,59 @@ ikp
|
|||
ik_system(ikp str){
|
||||
return fix(system(string_data(str)));
|
||||
}
|
||||
|
||||
static char*
|
||||
mtname(unsigned int n){
|
||||
if(n == mainheap_type) { return "HEAP_T"; }
|
||||
if(n == mainstack_type) { return "STAK_T"; }
|
||||
if(n == pointers_type) { return "PTER_T"; }
|
||||
if(n == data_type) { return "DATA_T"; }
|
||||
if(n == code_type) { return "CODE_T"; }
|
||||
if(n == hole_type) { return " "; }
|
||||
return "WHAT_T";
|
||||
}
|
||||
|
||||
ikp
|
||||
ik_dump_metatable(ikpcb* pcb){
|
||||
unsigned int* s = pcb->segment_vector_base;
|
||||
unsigned char* p = pcb->memory_base;
|
||||
unsigned char* hi = pcb->memory_end;
|
||||
while(p < hi){
|
||||
unsigned int t = *s & type_mask;
|
||||
unsigned char* start = p;
|
||||
p += pagesize;
|
||||
s++;
|
||||
while((p < hi) && ((*s & type_mask) == t)){
|
||||
p += pagesize;
|
||||
s++;
|
||||
}
|
||||
fprintf(stderr, "0x%08x + %5d pages = %s\n",
|
||||
(int) start,
|
||||
((int)p-(int)start)/pagesize,
|
||||
mtname(t));
|
||||
}
|
||||
return void_object;
|
||||
}
|
||||
|
||||
ikp
|
||||
ik_dump_dirty_vector(ikpcb* pcb){
|
||||
unsigned int* s = pcb->dirty_vector_base;
|
||||
unsigned char* p = pcb->memory_base;
|
||||
unsigned char* hi = pcb->memory_end;
|
||||
while(p < hi){
|
||||
unsigned int t = *s;
|
||||
unsigned char* start = p;
|
||||
p += pagesize;
|
||||
s++;
|
||||
while((p < hi) && (*s == t)){
|
||||
p += pagesize;
|
||||
s++;
|
||||
}
|
||||
fprintf(stderr, "0x%08x + %5d pages = 0x%08x\n",
|
||||
(int) start,
|
||||
((int)p-(int)start)/pagesize,
|
||||
t);
|
||||
}
|
||||
return void_object;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,37 @@
|
|||
|
||||
#include "ikarus.h"
|
||||
|
||||
ikp
|
||||
ikrt_weak_cons(ikp a, ikp d, ikpcb* pcb){
|
||||
ikp ap = pcb->weak_pairs_ap;
|
||||
ikp nap = ap + pair_size;
|
||||
ikp p;
|
||||
if(nap > pcb->weak_pairs_ep){
|
||||
ikp mem = ik_mmap_typed(pagesize, weak_pairs_mt, pcb);
|
||||
pcb->weak_pairs_ap = mem + pair_size;
|
||||
pcb->weak_pairs_ep = mem + pagesize;
|
||||
p = mem + pair_tag;
|
||||
}
|
||||
else {
|
||||
pcb->weak_pairs_ap = nap;
|
||||
p = ap + pair_tag;
|
||||
}
|
||||
ref(p, off_car) = a;
|
||||
ref(p, off_cdr) = d;
|
||||
return p;
|
||||
}
|
||||
|
||||
ikp
|
||||
ikrt_is_weak_pair(ikp x, ikpcb* pcb){
|
||||
if(tagof(x) != pair_tag){
|
||||
return false_object;
|
||||
}
|
||||
unsigned int t = pcb->segment_vector[page_index(x)];
|
||||
if((t & type_mask) == weak_pairs_type){
|
||||
return true_object;
|
||||
} else {
|
||||
return false_object;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -8,6 +8,41 @@ extern int total_allocated_pages;
|
|||
extern int total_malloced;
|
||||
extern int hash_table_count;
|
||||
|
||||
#define cardsize 512
|
||||
#define cards_per_page 8
|
||||
|
||||
#define old_gen_mask 0x00000007
|
||||
#define new_gen_mask 0x00000008
|
||||
#define gen_mask 0x0000000F
|
||||
#define new_gen_tag 0x00000008
|
||||
#define meta_dirty_mask 0x000000F0
|
||||
#define type_mask 0x00000F00
|
||||
#define scannable_mask 0x0000F000
|
||||
#define dealloc_mask 0x000F0000
|
||||
#define meta_dirty_shift 4
|
||||
|
||||
#define hole_type 0x00000000
|
||||
#define mainheap_type 0x00000100
|
||||
#define mainstack_type 0x00000200
|
||||
#define pointers_type 0x00000300
|
||||
#define data_type 0x00000400
|
||||
#define code_type 0x00000500
|
||||
#define weak_pairs_type 0x00000600
|
||||
|
||||
#define scannable_tag 0x00001000
|
||||
#define unscannable_tag 0x00000000
|
||||
|
||||
#define dealloc_tag 0x00010000
|
||||
#define retain_tag 0x00000000
|
||||
|
||||
#define hole_mt (hole_type | unscannable_tag | retain_tag)
|
||||
#define mainheap_mt (mainheap_type | unscannable_tag | retain_tag)
|
||||
#define mainstack_mt (mainstack_type | unscannable_tag | retain_tag)
|
||||
#define pointers_mt (pointers_type | scannable_tag | dealloc_tag)
|
||||
#define data_mt (data_type | unscannable_tag | dealloc_tag)
|
||||
#define code_mt (code_type | scannable_tag | dealloc_tag)
|
||||
#define weak_pairs_mt (weak_pairs_type | scannable_tag | dealloc_tag)
|
||||
|
||||
|
||||
static int
|
||||
inthash(int key) {
|
||||
|
|
@ -37,30 +72,11 @@ typedef struct ikdl{ /* double-link */
|
|||
struct ikdl* next;
|
||||
} ikdl;
|
||||
|
||||
|
||||
#define ikcode_dead ((unsigned int) 0x0000)
|
||||
#define ikcode_live ((unsigned int) 0x0001)
|
||||
#define ikcode_queued ((unsigned int) 0x0002 | ikcode_live)
|
||||
#define ikcode_scanned ((unsigned int) 0x0004 | ikcode_live)
|
||||
|
||||
typedef struct ikcodes{ /* a doubly-linked list of code objects */
|
||||
ikdl dl;
|
||||
ikp code_object;
|
||||
unsigned int attr;
|
||||
ikp base;
|
||||
int size;
|
||||
} ikcodes;
|
||||
|
||||
typedef struct ikhashtables{
|
||||
ikp ht;
|
||||
struct ikhashtables* next;
|
||||
} ikhashtables;
|
||||
|
||||
typedef struct{
|
||||
ikcodes* link;
|
||||
int padding; /* for 8-byte alignment */
|
||||
} ikcode_preheader;
|
||||
|
||||
typedef struct ikbucket{
|
||||
ikp key;
|
||||
ikp val;
|
||||
|
|
@ -82,8 +98,13 @@ typedef struct {
|
|||
ikp frame_redline; /* offset = 16 */
|
||||
ikp next_k; /* offset = 20 */
|
||||
void* system_stack; /* offset = 24 */
|
||||
unsigned int* dirty_vector; /* offset = 28 */
|
||||
|
||||
/* the rest are not used by any scheme code */
|
||||
/* they only support the runtime system (gc, etc.) */
|
||||
unsigned int* segment_vector;
|
||||
ikp weak_pairs_ap;
|
||||
ikp weak_pairs_ep;
|
||||
ikp heap_base;
|
||||
int heap_size;
|
||||
ikp stack_base;
|
||||
|
|
@ -92,6 +113,11 @@ typedef struct {
|
|||
ikdl codes;
|
||||
ikhashtables* hash_tables;
|
||||
ikoblist* oblist;
|
||||
unsigned int* dirty_vector_base;
|
||||
unsigned int* segment_vector_base;
|
||||
unsigned char* memory_base;
|
||||
unsigned char* memory_end;
|
||||
int collection_id;
|
||||
} ikpcb;
|
||||
|
||||
|
||||
|
|
@ -100,7 +126,13 @@ void* ik_malloc(int);
|
|||
void ik_free(void*, int);
|
||||
|
||||
void* ik_mmap(int);
|
||||
void* ik_mmap_typed(int size, unsigned int type, ikpcb*);
|
||||
void* ik_mmap_ptr(int size, int gen, ikpcb*);
|
||||
void* ik_mmap_data(int size, int gen, ikpcb*);
|
||||
void* ik_mmap_code(int size, int gen, ikpcb*);
|
||||
void* ik_mmap_mixed(int size, ikpcb*);
|
||||
void ik_munmap(void*, int);
|
||||
void ik_munmap_from_segment(unsigned char*, int, ikpcb*);
|
||||
ikpcb* ik_make_pcb();
|
||||
void ik_delete_pcb(ikpcb*);
|
||||
|
||||
|
|
@ -120,7 +152,9 @@ ikp ik_underflow_handler(ikpcb*);
|
|||
ikp ik_alloc(ikpcb* pcb, int size);
|
||||
#include "ikarus-data.h"
|
||||
#define wordsize 4
|
||||
#define wordshift 2
|
||||
#define pagesize 4096
|
||||
#define ik_eof_p(x) ((x) == ik_eof_object)
|
||||
#define page_index(x) (((unsigned int)(x)) >> pageshift)
|
||||
|
||||
#endif
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue