imported compiler3

This commit is contained in:
Abdulaziz Ghuloum 2006-11-23 19:42:39 -05:00
parent bd94bedc04
commit 03e9649064
42 changed files with 79264 additions and 534 deletions

View File

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

View File

@ -1 +1 @@
2006-07-28
2006-08-02

View File

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

3185
src/compiler-6.2.ss Normal file

File diff suppressed because it is too large Load Diff

Binary file not shown.

View File

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

Binary file not shown.

36
src/libcollect-6.1.ss Normal file
View File

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

1628
src/libcore-6.2.ss Normal file

File diff suppressed because it is too large Load Diff

Binary file not shown.

Binary file not shown.

1099
src/libexpand-6.2.ss Normal file

File diff suppressed because it is too large Load Diff

Binary file not shown.

View File

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

200
src/libhash-6.2.ss Normal file
View File

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

View File

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

Binary file not shown.

Binary file not shown.

534
src/libsyncase-6.2.ss Normal file
View File

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

373
src/libwriter-6.2.ss Normal file
View File

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

34
src/makepp.ss Normal file
View File

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

10704
src/psyntax-7.1.pp Normal file

File diff suppressed because one or more lines are too long

4424
src/psyntax-7.1.ss Normal file

File diff suppressed because it is too large Load Diff

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

55957
src/xpsyntax.pp Normal file

File diff suppressed because it is too large Load Diff