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
current-primitive-locations eval-core)
(import
(ikarus system $fx)
(ikarus system $pairs)
(only (ikarus system $codes) $code->closure)
(only (ikarus system $records) $record-ref $record/rtd?)
(except (ikarus)
@ -2973,6 +2975,8 @@
(define disp-bytevector-length 0)
(define disp-bytevector-data 4)
(define ptag-mask 7)
(define symbol-ptag 5)
(define symbol-record-tag #x5F)
(define disp-symbol-record-string 4)
(define disp-symbol-record-ustring 8)
@ -3128,18 +3132,22 @@
[else (error 'pcb-ref "invalid arg ~s" x)])))
(define (primref-loc op)
(unless (symbol? op) (error 'primref-loc "not a symbol ~s" op))
(define (primref->symbol op)
(unless (symbol? op) (error 'primref->symbol "not a symbol ~s" op))
(cond
[((current-primitive-locations) op) =>
(lambda (x)
(unless (symbol? x)
(error 'primitive-location
"~s is not a valid location for ~s" x op))
(mem (fx- disp-symbol-record-value record-tag) (obj x)))]
x)]
[else
(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 who 'generate-code)
@ -5288,7 +5296,7 @@
(define eval-core
(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)
(export + - * / zero? = < <= > >= add1 sub1 quotient remainder
positive? expt gcd lcm numerator denominator exact-integer-sqrt
quotient+remainder number->string string->number)
quotient+remainder number->string string->number max)
(import
(ikarus system $fx)
(ikarus system $ratnums)
@ -39,7 +39,7 @@
(except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient
remainder quotient+remainder number->string positive?
string->number expt gcd lcm numerator denominator
exact-integer-sqrt))
exact-integer-sqrt max))
(define (fixnum->flonum x)
(foreign-call "ikrt_fixnum_to_flonum" x))

2
src/ikarus.syntax.ss
View File

@ -2319,7 +2319,7 @@
(f (cdr r)
(cons (list* label 'global-macro loc) env)
(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
(error #f "don't know how to export ~s ~s"
(binding-type b) (binding-value b))])))])))

34
src/libaltcogen.ss
View File

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

1
src/makefile.ss
View File

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

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

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

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

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