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

* Libraries can export modules now. 

* libaltcogen can now be loaded.
This commit is contained in:
Abdulaziz Ghuloum 2007-06-02 10:21:05 +03:00
parent b7b3709f69
commit ca248be49a
8 changed files with 108 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

16
src/ikarus.compiler.ss
View File

@ -3,6 +3,8 @@
(export compile-core-expr-to-port assembler-output (export compile-core-expr-to-port assembler-output
current-primitive-locations eval-core) current-primitive-locations eval-core)
(import (import
(ikarus system $fx)
(ikarus system $pairs)
(only (ikarus system $codes) $code->closure) (only (ikarus system $codes) $code->closure)
(only (ikarus system $records) $record-ref $record/rtd?) (only (ikarus system $records) $record-ref $record/rtd?)
(except (ikarus) (except (ikarus)
@ -2973,6 +2975,8 @@
(define disp-bytevector-length 0) (define disp-bytevector-length 0)
(define disp-bytevector-data 4) (define disp-bytevector-data 4)
(define ptag-mask 7)
(define symbol-ptag 5)
(define symbol-record-tag #x5F) (define symbol-record-tag #x5F)
(define disp-symbol-record-string 4) (define disp-symbol-record-string 4)
(define disp-symbol-record-ustring 8) (define disp-symbol-record-ustring 8)
@ -3128,18 +3132,22 @@
[else (error 'pcb-ref "invalid arg ~s" x)]))) [else (error 'pcb-ref "invalid arg ~s" x)])))
(define (primref-loc op) (define (primref->symbol op)
(unless (symbol? op) (error 'primref-loc "not a symbol ~s" op)) (unless (symbol? op) (error 'primref->symbol "not a symbol ~s" op))
(cond (cond
[((current-primitive-locations) op) => [((current-primitive-locations) op) =>
(lambda (x) (lambda (x)
(unless (symbol? x) (unless (symbol? x)
(error 'primitive-location (error 'primitive-location
"~s is not a valid location for ~s" x op)) "~s is not a valid location for ~s" x op))
(mem (fx- disp-symbol-record-value record-tag) (obj x)))] x)]
[else [else
(error 'compile "cannot find location of primitive ~s" op)])) (error 'compile "cannot find location of primitive ~s" op)]))
(define (primref-loc op)
(mem (fx- disp-symbol-record-value record-tag)
(obj (primref->symbol op))))
(define (generate-code x) (define (generate-code x)
(define who 'generate-code) (define who 'generate-code)
@ -5288,7 +5296,7 @@
(define eval-core (define eval-core
(lambda (x) ((compile-core-expr x)))) (lambda (x) ((compile-core-expr x))))
;(include "libaltcogen.ss") (include "libaltcogen.ss")
) )

4
src/ikarus.numerics.ss
View File

@ -29,7 +29,7 @@
(library (ikarus generic-arithmetic) (library (ikarus generic-arithmetic)
(export + - * / zero? = < <= > >= add1 sub1 quotient remainder (export + - * / zero? = < <= > >= add1 sub1 quotient remainder
positive? expt gcd lcm numerator denominator exact-integer-sqrt positive? expt gcd lcm numerator denominator exact-integer-sqrt
quotient+remainder number->string string->number) quotient+remainder number->string string->number max)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $ratnums) (ikarus system $ratnums)
@ -39,7 +39,7 @@
(except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient (except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient
remainder quotient+remainder number->string positive? remainder quotient+remainder number->string positive?
string->number expt gcd lcm numerator denominator string->number expt gcd lcm numerator denominator
exact-integer-sqrt)) exact-integer-sqrt max))
(define (fixnum->flonum x) (define (fixnum->flonum x)
(foreign-call "ikrt_fixnum_to_flonum" x)) (foreign-call "ikrt_fixnum_to_flonum" x))

2
src/ikarus.syntax.ss
View File

@ -2319,7 +2319,7 @@
(f (cdr r) (f (cdr r)
(cons (list* label 'global-macro loc) env) (cons (list* label 'global-macro loc) env)
(cons (cons loc (binding-value b)) macro*)))] (cons (cons loc (binding-value b)) macro*)))]
[($rtd) (f (cdr r) (cons x env) macro*)] [($rtd $module) (f (cdr r) (cons x env) macro*)]
[else [else
(error #f "don't know how to export ~s ~s" (error #f "don't know how to export ~s ~s"
(binding-type b) (binding-value b))])))]))) (binding-type b) (binding-value b))])))])))

34
src/libaltcogen.ss
View File

@ -587,9 +587,11 @@
(make-primcall 'nop '()) (make-primcall 'nop '())
(make-funcall (make-funcall
(make-primcall 'mref (make-primcall 'mref
(list (make-constant (make-object 'do-overflow)) (list (make-constant
(make-constant (- disp-symbol-system-value (make-object
symbol-tag)))) (primref->symbol
'do-overflow)))
(make-constant (- disp-symbol-record-value symbol-ptag))))
(list size))))) (list size)))))
;;; impose value ;;; impose value
(define (V d x) (define (V d x)
@ -969,18 +971,18 @@
) )
(begin (begin
(define-syntax car (identifier-syntax #%$car)) (define-syntax car (identifier-syntax $car))
(define-syntax cdr (identifier-syntax #%$cdr)) (define-syntax cdr (identifier-syntax $cdr))
(define-syntax fxsll (identifier-syntax #%$fxsll)) (define-syntax fxsll (identifier-syntax $fxsll))
(define-syntax fxsra (identifier-syntax #%$fxsra)) (define-syntax fxsra (identifier-syntax $fxsra))
(define-syntax fxlogor (identifier-syntax #%$fxlogor)) (define-syntax fxlogor (identifier-syntax $fxlogor))
(define-syntax fxlogand (identifier-syntax #%$fxlogand)) (define-syntax fxlogand (identifier-syntax $fxlogand))
(define-syntax fxlognot (identifier-syntax #%$fxlognot)) (define-syntax fxlognot (identifier-syntax $fxlognot))
(define-syntax fx+ (identifier-syntax #%$fx+)) (define-syntax fx+ (identifier-syntax $fx+))
(define-syntax fxzero? (identifier-syntax #%$fxzero?)) (define-syntax fxzero? (identifier-syntax $fxzero?))
(define-syntax fxeven? (define-syntax fxeven?
(syntax-rules () (syntax-rules ()
[(_ x) (#%$fxzero? (#%$fxlogand x 1))]))) [(_ x) ($fxzero? ($fxlogand x 1))])))
(define bits 28) (define bits 28)
(define (index-of n) (fxquotient n bits)) (define (index-of n) (fxquotient n bits))
@ -2579,8 +2581,8 @@
(let ([LCALL (unique-label)]) (let ([LCALL (unique-label)])
(define (rp-label value) (define (rp-label value)
(if value (if value
(label-address SL_multiple_values_error_rp) (label-address (sl-mv-error-rp-label))
(label-address SL_multiple_values_ignore_rp))) (label-address (sl-mv-ignore-rp-label))))
(cond (cond
[(string? target) ;; foreign call [(string? target) ;; foreign call
(list* `(subl ,(* (fxsub1 size) wordsize) ,fpr) (list* `(subl ,(* (fxsub1 size) wordsize) ,fpr)
@ -2887,7 +2889,7 @@
(let f ([case* case*]) (let f ([case* case*])
(cond (cond
[(null? case*) [(null? case*)
(cons `(jmp (label ,SL_invalid_args)) ac)] (cons `(jmp (label ,(sl-invalid-args-label))) ac)]
[else [else
(ClambdaCase (car case*) (f (cdr case*)))])))))])) (ClambdaCase (car case*) (f (cdr case*)))])))))]))
;;; ;;;

1
src/makefile.ss
View File

@ -390,6 +390,7 @@
[flonum->string i] [flonum->string i]
[gcd i r] [gcd i r]
[lcm i r] [lcm i r]
[max i r]
[numerator i r] [numerator i r]
[denominator i r] [denominator i r]
[exact-integer-sqrt i r] [exact-integer-sqrt i r]

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

@ -284,28 +284,28 @@
/section) /section)
(section ;;; vectors (section ;;; vectors
(section ;;; helpers (section ;;; helpers
(define (vector-range-check x idx) (define (vector-range-check x idx)
(define (check-fx i) (define (check-fx i)
(seq* (seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag)) (interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([len (cogen-value-$vector-length x)]) (with-tmp ([len (cogen-value-$vector-length x)])
(interrupt-unless (prm 'u< (K (* i wordsize)) len)) (interrupt-unless (prm 'u< (K (* i wordsize)) len))
(interrupt-unless-fixnum len)))) (interrupt-unless-fixnum len))))
(define (check-? idx) (define (check-? idx)
(seq* (seq*
(interrupt-unless (tag-test (T x) vector-mask vector-tag)) (interrupt-unless (tag-test (T x) vector-mask vector-tag))
(with-tmp ([len (cogen-value-$vector-length x)]) (with-tmp ([len (cogen-value-$vector-length x)])
(interrupt-unless (prm 'u< (T idx) len)) (interrupt-unless (prm 'u< (T idx) len))
(with-tmp ([t (prm 'logor len (T idx))]) (with-tmp ([t (prm 'logor len (T idx))])
(interrupt-unless-fixnum t))))) (interrupt-unless-fixnum t)))))
(record-case idx (record-case idx
[(constant i) [(constant i)
(if (and (fixnum? i) (fx>= i 0)) (if (and (fixnum? i) (fx>= i 0))
(check-fx i) (check-fx i)
(check-? idx))] (check-? idx))]
[else (check-? idx)])) [else (check-? idx)]))
/section) /section)
(define-primop vector? unsafe (define-primop vector? unsafe
[(P x) (sec-tag-test (T x) vector-mask vector-tag fixnum-mask fixnum-tag)] [(P x) (sec-tag-test (T x) vector-mask vector-tag fixnum-mask fixnum-tag)]
@ -434,62 +434,64 @@
(section ;;; symbols (section ;;; symbols
(define-primop symbol? safe (define-primop symbol? safe
[(P x) (tag-test (T x) symbol-mask symbol-tag)] [(P x) (tag-test (T x) ptag-mask symbol-ptag)]
[(E x) (nop)]) [(E x) (nop)])
(define-primop $make-symbol unsafe (define-primop $make-symbol unsafe
[(V str) [(V str)
(with-tmp ([x (prm 'alloc (K (align symbol-size)) (K symbol-tag))]) (with-tmp ([x (prm 'alloc (K (align symbol-record-size)) (K symbol-ptag))])
(prm 'mset x (K (- disp-symbol-string symbol-tag)) (T str)) (prm 'mset x (K (- symbol-ptag)) (K symbol-record-tag))
(prm 'mset x (K (- disp-symbol-unique-string symbol-tag)) (K 0)) (prm 'mset x (K (- disp-symbol-record-string symbol-ptag)) (T str))
(prm 'mset x (K (- disp-symbol-value symbol-tag)) (K unbound)) (prm 'mset x (K (- disp-symbol-record-ustring symbol-ptag)) (K 0))
(prm 'mset x (K (- disp-symbol-plist symbol-tag)) (K nil)) (prm 'mset x (K (- disp-symbol-record-value symbol-ptag)) (K unbound))
(prm 'mset x (K (- disp-symbol-system-value symbol-tag)) (K unbound)) (prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) (K unbound))
(prm 'mset x (K (- disp-symbol-function symbol-tag)) (K 0)) (prm 'mset x (K (- disp-symbol-record-plist symbol-ptag)) (K nil))
(prm 'mset x (K (- disp-symbol-error-function symbol-tag)) (K 0)) ;(prm 'mset x (K (- disp-symbol-system-value symbol-tag)) (K unbound))
(prm 'mset x (K (- disp-symbol-unused symbol-tag)) (K 0)) ;(prm 'mset x (K (- disp-symbol-function symbol-ptag)) (K 0))
;(prm 'mset x (K (- disp-symbol-error-function symbol-ptag)) (K 0))
;(prm 'mset x (K (- disp-symbol-unused symbol-tag)) (K 0))
x)] x)]
[(P str) (K #t)] [(P str) (K #t)]
[(E str) (nop)]) [(E str) (nop)])
(define-primop primitive-set! unsafe ;(define-primop primitive-set! unsafe
[(E x v) (mem-assign v (T x) (- disp-symbol-system-value symbol-tag))]) ; [(E x v) (mem-assign v (T x) (- disp-symbol-system-value symbol-tag))])
;
(define-primop primitive-ref unsafe ;(define-primop primitive-ref unsafe
[(V x) (prm 'mref (T x) (K (- disp-symbol-system-value symbol-tag)))] ; [(V x) (prm 'mref (T x) (K (- disp-symbol-system-value symbol-tag)))]
[(E x) (nop)]) ; [(E x) (nop)])
(define-primop $symbol-string unsafe (define-primop $symbol-string unsafe
[(V x) (prm 'mref (T x) (K (- disp-symbol-string symbol-tag)))] [(V x) (prm 'mref (T x) (K (- disp-symbol-record-string symbol-ptag)))]
[(E x) (nop)]) [(E x) (nop)])
(define-primop $set-symbol-string! unsafe (define-primop $set-symbol-string! unsafe
[(E x v) (mem-assign v (T x) (- disp-symbol-string symbol-tag))]) [(E x v) (mem-assign v (T x) (- disp-symbol-record-string symbol-ptag))])
(define-primop $symbol-unique-string unsafe (define-primop $symbol-unique-string unsafe
[(V x) (prm 'mref (T x) (K (- disp-symbol-unique-string symbol-tag)))] [(V x) (prm 'mref (T x) (K (- disp-symbol-record-ustring symbol-ptag)))]
[(E x) (nop)]) [(E x) (nop)])
(define-primop $set-symbol-unique-string! unsafe (define-primop $set-symbol-unique-string! unsafe
[(E x v) (mem-assign v (T x) (- disp-symbol-unique-string symbol-tag))]) [(E x v) (mem-assign v (T x) (- disp-symbol-record-ustring symbol-ptag))])
(define-primop $symbol-plist unsafe (define-primop $symbol-plist unsafe
[(V x) (prm 'mref (T x) (K (- disp-symbol-plist symbol-tag)))] [(V x) (prm 'mref (T x) (K (- disp-symbol-record-plist symbol-ptag)))]
[(E x) (nop)]) [(E x) (nop)])
(define-primop $set-symbol-plist! unsafe (define-primop $set-symbol-plist! unsafe
[(E x v) (mem-assign v (T x) (- disp-symbol-plist symbol-tag))]) [(E x v) (mem-assign v (T x) (- disp-symbol-record-plist symbol-ptag))])
(define-primop $symbol-value unsafe (define-primop $symbol-value unsafe
[(V x) (prm 'mref (T x) (K (- disp-symbol-value symbol-tag)))] [(V x) (prm 'mref (T x) (K (- disp-symbol-record-value symbol-ptag)))]
[(E x) (nop)]) [(E x) (nop)])
(define-primop $set-symbol-value! unsafe (define-primop $set-symbol-value! unsafe
[(E x v) [(E x v)
(with-tmp ([x (T x)]) (with-tmp ([x (T x)])
(prm 'mset x (K (- disp-symbol-value symbol-tag)) (T v)) (prm 'mset x (K (- disp-symbol-record-value symbol-ptag)) (T v))
(prm 'mset x (K (- disp-symbol-function symbol-tag)) ;(prm 'mset x (K (- disp-symbol-function symbol-tag))
(prm 'mref x (K (- disp-symbol-error-function symbol-tag)))) ; (prm 'mref x (K (- disp-symbol-error-function symbol-tag))))
(dirty-vector-set x))]) (dirty-vector-set x))])
(define-primop top-level-value safe (define-primop top-level-value safe
@ -524,8 +526,8 @@
(define-primop $init-symbol-function! unsafe (define-primop $init-symbol-function! unsafe
[(E x v) [(E x v)
(with-tmp ([x (T x)] [v (T v)]) (with-tmp ([x (T x)] [v (T v)])
(prm 'mset x (K (- disp-symbol-function symbol-tag)) v) (prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) v)
(prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v) ;(prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v)
(dirty-vector-set x))]) (dirty-vector-set x))])
@ -1236,7 +1238,7 @@
(K (align (+ disp-closure-data wordsize))) (K (align (+ disp-closure-data wordsize)))
(K closure-tag))]) (K closure-tag))])
(prm 'mset t (K (- disp-closure-code closure-tag)) (prm 'mset t (K (- disp-closure-code closure-tag))
(K (make-code-loc SL_continuation_code))) (K (make-code-loc (sl-continuation-code-label))))
(prm 'mset t (K (- disp-closure-data closure-tag)) (prm 'mset t (K (- disp-closure-data closure-tag))
(T x)) (T x))
t)] t)]
@ -1244,12 +1246,12 @@
[(E x) (nop)]) [(E x) (nop)])
(define-primop $make-call-with-values-procedure unsafe (define-primop $make-call-with-values-procedure unsafe
[(V) (K (make-closure (make-code-loc SL_call_with_values) '()))] [(V) (K (make-closure (make-code-loc (sl-cwv-label)) '()))]
[(P) (interrupt)] [(P) (interrupt)]
[(E) (interrupt)]) [(E) (interrupt)])
(define-primop $make-values-procedure unsafe (define-primop $make-values-procedure unsafe
[(V) (K (make-closure (make-code-loc SL_values) '()))] [(V) (K (make-closure (make-code-loc (sl-values-label)) '()))]
[(P) (interrupt)] [(P) (interrupt)]
[(E) (interrupt)]) [(E) (interrupt)])

37
src/pass-specify-rep.ss
View File

@ -180,8 +180,9 @@
(define (cogen-name stx name suffix) (define (cogen-name stx name suffix)
(datum->syntax stx (datum->syntax stx
(string->symbol (string->symbol
(format "cogen-~a-~a" suffix (format "cogen-~a-~a"
(syntax->datum name))))) suffix
(syntax->datum name)))))
(define (generate-handler name ctxt case*) (define (generate-handler name ctxt case*)
(define (filter-cases case*) (define (filter-cases case*)
(syntax-case case* () (syntax-case case* ()
@ -199,10 +200,10 @@
[args (interrupt)]) [args (interrupt)])
handled?]))) handled?])))
(syntax-case x () (syntax-case x ()
[(_ name int? case* ...) [(stx name int? case* ...)
(with-syntax ([cogen-p (cogen-name #'_ #'name "pred")] (with-syntax ([cogen-p (cogen-name #'stx #'name "pred")]
[cogen-e (cogen-name #'_ #'name "effect")] [cogen-e (cogen-name #'stx #'name "effect")]
[cogen-v (cogen-name #'_ #'name "value")] [cogen-v (cogen-name #'stx #'name "value")]
[interruptable? [interruptable?
(syntax-case #'int? (safe unsafe) (syntax-case #'int? (safe unsafe)
[safe #t] [unsafe #f])] [safe #t] [unsafe #f])]
@ -321,8 +322,8 @@
[(var) x] [(var) x]
[(primref name) [(primref name)
(prm 'mref (prm 'mref
(K (make-object name)) (K (make-object (primref->symbol name)))
(K (- disp-symbol-system-value symbol-tag)))] (K (- disp-symbol-record-value symbol-ptag)))]
[(code-loc) (make-constant x)] [(code-loc) (make-constant x)]
[(closure) (make-constant x)] [(closure) (make-constant x)]
[(bind lhs* rhs* body) [(bind lhs* rhs* body)
@ -414,7 +415,7 @@
(lambda (sym) (lambda (sym)
(record-symbol-call! sym) (record-symbol-call! sym)
(prm 'mref (T (K sym)) (prm 'mref (T (K sym))
(K (- disp-symbol-function symbol-tag))))] (K (- disp-symbol-record-proc symbol-ptag))))]
[else (nonproc x)])] [else (nonproc x)])]
[(primref op) (V x)] [(primref op) (V x)]
[else (nonproc x)])) [else (nonproc x)]))
@ -462,35 +463,35 @@
(define L1 (gensym)) (define L1 (gensym))
(define L2 (gensym)) (define L2 (gensym))
`(0 `(0
[movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) ,cp-register] [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) ,cp-register]
[andl ,closure-mask ,cp-register] [andl ,closure-mask ,cp-register]
[cmpl ,closure-tag ,cp-register] [cmpl ,closure-tag ,cp-register]
[jne (label ,L1)] [jne (label ,L1)]
[movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) ,cp-register] [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) ,cp-register]
[movl ,cp-register (disp ,(- disp-symbol-function symbol-tag) (obj ,symbol))] [movl ,cp-register (disp ,(- disp-symbol-record-proc symbol-ptag) (obj ,symbol))]
[jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)] [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
[label ,L1] [label ,L1]
[movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) %eax] [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) %eax]
[cmpl ,unbound %eax] [cmpl ,unbound %eax]
[je (label ,L2)] [je (label ,L2)]
[movl (obj apply) (disp -4 %esp)] [movl (obj apply) (disp -4 %esp)]
[movl (obj "~s is not a procedure") (disp -8 %esp)] [movl (obj "~s is not a procedure") (disp -8 %esp)]
[movl %eax (disp -12 %esp)] [movl %eax (disp -12 %esp)]
[movl (obj error) ,cp-register] [movl (obj ,(primref->symbol 'error)) ,cp-register]
[movl (disp ,(- disp-symbol-system-value symbol-tag) [movl (disp ,(- disp-symbol-record-value symbol-ptag)
,cp-register) ,cp-register] ,cp-register) ,cp-register]
[movl ,(argc-convention 3) %eax] [movl ,(argc-convention 3) %eax]
[jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)] [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
[label ,L2] [label ,L2]
[movl (obj ,symbol) (disp -4 %esp)] [movl (obj ,symbol) (disp -4 %esp)]
[movl (obj top-level-value) ,cp-register] [movl (obj ,(primref->symbol 'top-level-value)) ,cp-register]
[movl (disp ,(- disp-symbol-system-value symbol-tag) [movl (disp ,(- disp-symbol-record-value symbol-ptag)
,cp-register) ,cp-register] ,cp-register) ,cp-register]
[movl ,(argc-convention 1) %eax] [movl ,(argc-convention 1) %eax]
[jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)])) [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]))
(let ([ls encountered-symbol-calls]) (let ([ls encountered-symbol-calls])
(let ([c* (map code-list ls)]) (let ([c* (map code-list ls)])
(let ([c* (list*->code* (lambda (x) #f) c*)]) (let ([c* (assemble-sources (lambda (x) #f) c*)])
(let ([p* (map (lambda (x) ($code->closure x)) c*)]) (let ([p* (map (lambda (x) ($code->closure x)) c*)])
(let f ([ls ls] [p* p*]) (let f ([ls ls] [p* p*])
(cond (cond