* split libcontrol into primitive libcontrol0 and extended
libcontrol1.
This commit is contained in:
Abdulaziz Ghuloum
parent
fad2c4e999
commit
2e477881b6
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -124,6 +124,7 @@
|
||||||
[vector? p]
|
[vector? p]
|
||||||
[null? p]
|
[null? p]
|
||||||
[eof-object? p]
|
[eof-object? p]
|
||||||
|
;[eof-object v]
|
||||||
[procedure? p]
|
[procedure? p]
|
||||||
[symbol? p]
|
[symbol? p]
|
||||||
[boolean? p]
|
[boolean? p]
|
||||||
|
|
@ -139,6 +140,11 @@
|
||||||
[cons v]
|
[cons v]
|
||||||
[$car v]
|
[$car v]
|
||||||
[$cdr v]
|
[$cdr v]
|
||||||
|
|
||||||
|
;[$char<= p]
|
||||||
|
;[$char= p]
|
||||||
|
;[$char->fixnum v]
|
||||||
|
|
||||||
[$vector-ref v]
|
[$vector-ref v]
|
||||||
[$vector-set! e]
|
[$vector-set! e]
|
||||||
|
|
||||||
|
|
@ -153,10 +159,16 @@
|
||||||
[$closure-code v]
|
[$closure-code v]
|
||||||
[$code-freevars v]
|
[$code-freevars v]
|
||||||
[primitive-set! e]
|
[primitive-set! e]
|
||||||
|
|
||||||
|
[$fp-at-base p]
|
||||||
|
[$current-frame v]
|
||||||
|
[$seal-frame-and-call tail]
|
||||||
|
[$frame->continuation v]
|
||||||
|
|
||||||
))
|
))
|
||||||
(define library-prims
|
(define library-prims
|
||||||
'(vector
|
'(vector
|
||||||
list
|
list list*
|
||||||
not
|
not
|
||||||
car cdr
|
car cdr
|
||||||
))
|
))
|
||||||
|
|
@ -486,7 +498,7 @@
|
||||||
(make-jmpcall label (V rator) (map V rand*))]
|
(make-jmpcall label (V rator) (map V rand*))]
|
||||||
[(primcall op rands)
|
[(primcall op rands)
|
||||||
(case (prim-context op)
|
(case (prim-context op)
|
||||||
[(v) (make-primcall op (map V rands))]
|
[(v tail) (make-primcall op (map V rands))]
|
||||||
[(p) (Unpred x)]
|
[(p) (Unpred x)]
|
||||||
[(e)
|
[(e)
|
||||||
(let f ([rands rands])
|
(let f ([rands rands])
|
||||||
|
|
@ -526,6 +538,14 @@
|
||||||
;;;
|
;;;
|
||||||
(Program x))
|
(Program x))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(define-syntax seq*
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ e) e]
|
||||||
|
[(_ e* ... e)
|
||||||
|
(make-seq (seq* e* ...) e)]))
|
||||||
|
|
||||||
(define (specify-representation x)
|
(define (specify-representation x)
|
||||||
(define who 'specify-representation)
|
(define who 'specify-representation)
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -559,11 +579,6 @@
|
||||||
(make-bind (list lhs* ...)
|
(make-bind (list lhs* ...)
|
||||||
(list rhs* ...)
|
(list rhs* ...)
|
||||||
b b* ...))])))
|
b b* ...))])))
|
||||||
(define-syntax seq*
|
|
||||||
(syntax-rules ()
|
|
||||||
[(_ e) e]
|
|
||||||
[(_ e* ... e)
|
|
||||||
(make-seq (seq* e* ...) e)]))
|
|
||||||
(define (Effect x)
|
(define (Effect x)
|
||||||
(define (mem-assign v x i)
|
(define (mem-assign v x i)
|
||||||
(tbind ([q v])
|
(tbind ([q v])
|
||||||
|
|
@ -686,6 +701,12 @@
|
||||||
(tag-test t fixnum-mask fixnum-tag)
|
(tag-test t fixnum-mask fixnum-tag)
|
||||||
(make-constant #t)
|
(make-constant #t)
|
||||||
(tag-test t 7 7)))]
|
(tag-test t 7 7)))]
|
||||||
|
[($fp-at-base)
|
||||||
|
(prm '=
|
||||||
|
(prm 'int+
|
||||||
|
(prm 'mref pcr (K 12)) ;;; PCB FRAME-BASE
|
||||||
|
(K (- wordsize)))
|
||||||
|
fpr)]
|
||||||
[else (error who "pred prim ~a not supported" op)])]
|
[else (error who "pred prim ~a not supported" op)])]
|
||||||
[(mvcall rator x)
|
[(mvcall rator x)
|
||||||
(make-mvcall (Value rator) (Clambda x Pred))]
|
(make-mvcall (Value rator) (Clambda x Pred))]
|
||||||
|
|
@ -693,7 +714,7 @@
|
||||||
;;;
|
;;;
|
||||||
(define (err x)
|
(define (err x)
|
||||||
(error who "invalid form ~s" (unparse x)))
|
(error who "invalid form ~s" (unparse x)))
|
||||||
;;;
|
;;; value
|
||||||
(define (Value x)
|
(define (Value x)
|
||||||
(record-case x
|
(record-case x
|
||||||
[(constant) (constant-rep x)]
|
[(constant) (constant-rep x)]
|
||||||
|
|
@ -740,6 +761,48 @@
|
||||||
(prm 'mset! t (K (- disp-car pair-tag)) a)
|
(prm 'mset! t (K (- disp-car pair-tag)) a)
|
||||||
(prm 'mset! t (K (- disp-cdr pair-tag)) d)
|
(prm 'mset! t (K (- disp-cdr pair-tag)) d)
|
||||||
t)))]
|
t)))]
|
||||||
|
[($current-frame) ;; PCB NEXT-CONTINUATION
|
||||||
|
(prm 'mref pcr (K 12))]
|
||||||
|
[($seal-frame-and-call)
|
||||||
|
(tbind ([proc (Value (car arg*))])
|
||||||
|
(tbind ([k (prm 'alloc
|
||||||
|
(K disp-continuation-size)
|
||||||
|
(K vector-tag))])
|
||||||
|
(tbind ([base (prm 'int+
|
||||||
|
(prm 'mref pcr (K 28))
|
||||||
|
(K (- wordsize)))])
|
||||||
|
(tbind ([underflow-handler
|
||||||
|
(prm 'mref base (K 0))])
|
||||||
|
(seq*
|
||||||
|
(prm 'mset! k
|
||||||
|
(K (- vector-tag))
|
||||||
|
(K continuation-tag))
|
||||||
|
(prm 'mset! k
|
||||||
|
(K (- disp-continuation-top vector-tag))
|
||||||
|
fpr)
|
||||||
|
(prm 'mset! k
|
||||||
|
(K (- disp-continuation-next vector-tag))
|
||||||
|
(prm 'mref pcr (K 12))) ;;; PCB NEXT CONT
|
||||||
|
(prm 'mset! k
|
||||||
|
(K (- disp-continuation-size vector-tag))
|
||||||
|
(prm 'int- base fpr))
|
||||||
|
(prm 'mset! pcr (K 12) k)
|
||||||
|
(make-primcall '$call-with-underflow-handler
|
||||||
|
(list underflow-handler proc k)))))))]
|
||||||
|
[($frame->continuation)
|
||||||
|
(tbind ([arg (Value (car arg*))])
|
||||||
|
(tbind ([t (prm 'alloc
|
||||||
|
(K (align (+ disp-closure-data wordsize)))
|
||||||
|
(K closure-tag))])
|
||||||
|
(seq*
|
||||||
|
(prm 'mset! t
|
||||||
|
(K (- disp-closure-code closure-tag))
|
||||||
|
(make-constant
|
||||||
|
(make-code-loc SL_continuation_code)))
|
||||||
|
(prm 'mset! t
|
||||||
|
(K (- disp-closure-data closure-tag))
|
||||||
|
arg)
|
||||||
|
t)))]
|
||||||
[($cpref)
|
[($cpref)
|
||||||
(let ([a0 (car arg*)] [a1 (cadr arg*)])
|
(let ([a0 (car arg*)] [a1 (cadr arg*)])
|
||||||
(record-case a1
|
(record-case a1
|
||||||
|
|
@ -811,6 +874,7 @@
|
||||||
(Value body))]
|
(Value body))]
|
||||||
[else (error who "invalid program ~s" x)]))
|
[else (error who "invalid program ~s" x)]))
|
||||||
;;;
|
;;;
|
||||||
|
;(print-code x)
|
||||||
(Program x))
|
(Program x))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -928,7 +992,7 @@
|
||||||
(S* rands
|
(S* rands
|
||||||
(lambda (rands)
|
(lambda (rands)
|
||||||
(make-set d (make-disp (car rands) (cadr rands)))))]
|
(make-set d (make-disp (car rands) (cadr rands)))))]
|
||||||
[(logand int+)
|
[(logand int+ int-)
|
||||||
(make-seq
|
(make-seq
|
||||||
(V d (car rands))
|
(V d (car rands))
|
||||||
(S (cadr rands)
|
(S (cadr rands)
|
||||||
|
|
@ -1024,7 +1088,23 @@
|
||||||
(record-case x
|
(record-case x
|
||||||
[(constant) (VT x)]
|
[(constant) (VT x)]
|
||||||
[(var) (VT x)]
|
[(var) (VT x)]
|
||||||
[(primcall) (VT x)]
|
[(primcall op rands)
|
||||||
|
(case op
|
||||||
|
[($call-with-underflow-handler)
|
||||||
|
(let ([handler (car rands)]
|
||||||
|
[proc (cadr rands)]
|
||||||
|
[k (caddr rands)])
|
||||||
|
(seq*
|
||||||
|
(make-set (make-fvar 1) handler)
|
||||||
|
(make-set (make-fvar 2) k)
|
||||||
|
(make-set cpr proc)
|
||||||
|
(make-set argc-register
|
||||||
|
(make-constant (argc-convention 1)))
|
||||||
|
(make-asm-instr 'int- fpr
|
||||||
|
(make-constant wordsize))
|
||||||
|
(make-primcall 'indirect-jump
|
||||||
|
(list cpr (make-fvar 1) (make-fvar 2)))))]
|
||||||
|
[else (VT x)])]
|
||||||
[(bind lhs* rhs* e)
|
[(bind lhs* rhs* e)
|
||||||
(do-bind lhs* rhs* (Tail e))]
|
(do-bind lhs* rhs* (Tail e))]
|
||||||
[(seq e0 e1)
|
[(seq e0 e1)
|
||||||
|
|
@ -1197,7 +1277,7 @@
|
||||||
(cond
|
(cond
|
||||||
[(symbol? x) (if (reg? x) (list x) '())]
|
[(symbol? x) (if (reg? x) (list x) '())]
|
||||||
[else (error who "invalid R ~s" x)])]))
|
[else (error who "invalid R ~s" x)])]))
|
||||||
;;; build-graph effect
|
;;; build effect
|
||||||
(define (E x s)
|
(define (E x s)
|
||||||
(record-case x
|
(record-case x
|
||||||
[(set x v)
|
[(set x v)
|
||||||
|
|
@ -1214,7 +1294,7 @@
|
||||||
(union (R v) s)]))]
|
(union (R v) s)]))]
|
||||||
[(asm-instr op d v)
|
[(asm-instr op d v)
|
||||||
(case op
|
(case op
|
||||||
[(logand int+ logor sll sra)
|
[(logand int+ int- logor sll sra)
|
||||||
(let ([s (set-rem d s)])
|
(let ([s (set-rem d s)])
|
||||||
(record-case d
|
(record-case d
|
||||||
[(nfvar c i)
|
[(nfvar c i)
|
||||||
|
|
@ -1562,7 +1642,7 @@
|
||||||
(make-conditional (P e0) (E e1) (E e2))]
|
(make-conditional (P e0) (E e1) (E e2))]
|
||||||
[(asm-instr op a b)
|
[(asm-instr op a b)
|
||||||
(case op
|
(case op
|
||||||
[(logor logand int+)
|
[(logor logand int+ int-)
|
||||||
(cond
|
(cond
|
||||||
[(and (mem? a) (mem? b))
|
[(and (mem? a) (mem? b))
|
||||||
(let ([u (mku)])
|
(let ([u (mku)])
|
||||||
|
|
@ -1778,6 +1858,7 @@
|
||||||
(case op
|
(case op
|
||||||
[(logand) (cons `(andl ,(R s) ,(R d)) ac)]
|
[(logand) (cons `(andl ,(R s) ,(R d)) ac)]
|
||||||
[(int+) (cons `(addl ,(R s) ,(R d)) ac)]
|
[(int+) (cons `(addl ,(R s) ,(R d)) ac)]
|
||||||
|
[(int-) (cons `(subl ,(R s) ,(R d)) ac)]
|
||||||
[(logor) (cons `(orl ,(R s) ,(R d)) ac)]
|
[(logor) (cons `(orl ,(R s) ,(R d)) ac)]
|
||||||
[(mset) (cons `(movl ,(R s) ,(R d)) ac)]
|
[(mset) (cons `(movl ,(R s) ,(R d)) ac)]
|
||||||
[(sll) (cons `(sall ,(R s) ,(R d)) ac)]
|
[(sll) (cons `(sall ,(R s) ,(R d)) ac)]
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,18 @@
|
||||||
|
|
||||||
|
(let ()
|
||||||
|
(define call-with-current-frame
|
||||||
|
(lambda (f)
|
||||||
|
(if ($fp-at-base)
|
||||||
|
(f ($current-frame))
|
||||||
|
($seal-frame-and-call f))))
|
||||||
|
|
||||||
|
(define primitive-call/cc
|
||||||
|
(lambda (f)
|
||||||
|
(call-with-current-frame
|
||||||
|
(lambda (frm)
|
||||||
|
(f ($frame->continuation frm))))))
|
||||||
|
|
||||||
|
(primitive-set! 'call/cf call-with-current-frame)
|
||||||
|
(primitive-set! '$primitive-call/cc primitive-call/cc))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1,18 +1,6 @@
|
||||||
|
|
||||||
(let ([winders '()])
|
(let ([winders '()])
|
||||||
|
|
||||||
(define call-with-current-frame
|
|
||||||
(lambda (f)
|
|
||||||
(if ($fp-at-base)
|
|
||||||
(f ($current-frame))
|
|
||||||
($seal-frame-and-call f))))
|
|
||||||
|
|
||||||
(define primitive-call/cc
|
|
||||||
(lambda (f)
|
|
||||||
(call-with-current-frame
|
|
||||||
(lambda (frm)
|
|
||||||
(f ($frame->continuation frm))))))
|
|
||||||
|
|
||||||
(define len
|
(define len
|
||||||
(lambda (ls n)
|
(lambda (ls n)
|
||||||
(if (null? ls)
|
(if (null? ls)
|
||||||
|
|
@ -71,7 +59,7 @@
|
||||||
|
|
||||||
(define call/cc
|
(define call/cc
|
||||||
(lambda (f)
|
(lambda (f)
|
||||||
(primitive-call/cc
|
($primitive-call/cc
|
||||||
(lambda (k)
|
(lambda (k)
|
||||||
(let ([save winders])
|
(let ([save winders])
|
||||||
(f (case-lambda
|
(f (case-lambda
|
||||||
|
|
@ -80,7 +68,7 @@
|
||||||
[(v1 v2 . v*)
|
[(v1 v2 . v*)
|
||||||
(unless (eq? save winders) (do-wind save))
|
(unless (eq? save winders) (do-wind save))
|
||||||
(apply k v1 v2 v*)])))))))
|
(apply k v1 v2 v*)])))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; (define dynamic-wind
|
;;; (define dynamic-wind
|
||||||
|
|
@ -119,7 +107,6 @@
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'call/cf call-with-current-frame)
|
|
||||||
(primitive-set! 'call/cc call/cc)
|
(primitive-set! 'call/cc call/cc)
|
||||||
(primitive-set! 'dynamic-wind dynamic-wind)
|
(primitive-set! 'dynamic-wind dynamic-wind)
|
||||||
(void))
|
(void))
|
||||||
|
|
@ -105,6 +105,7 @@
|
||||||
(define system-primitives
|
(define system-primitives
|
||||||
'(
|
'(
|
||||||
|
|
||||||
|
$primitive-call/cc
|
||||||
$closure-code immediate? $unbound-object? $forward-ptr?
|
$closure-code immediate? $unbound-object? $forward-ptr?
|
||||||
pointer-value primitive-ref primitive-set! $fx= $fx< $fx<= $fx>
|
pointer-value primitive-ref primitive-set! $fx= $fx< $fx<= $fx>
|
||||||
$fx>= $fxzero? $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient
|
$fx>= $fxzero? $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient
|
||||||
|
|
@ -227,7 +228,8 @@
|
||||||
|
|
||||||
(define scheme-library-files
|
(define scheme-library-files
|
||||||
'(["libhandlers.ss" "libhandlers.fasl" p0 onepass]
|
'(["libhandlers.ss" "libhandlers.fasl" p0 onepass]
|
||||||
["libcontrol.ss" "libcontrol.fasl" p0 onepass]
|
["libcontrol0.ss" "libcontrol0.fasl" p0 onepass]
|
||||||
|
["libcontrol1.ss" "libcontrol1.fasl" p0 onepass]
|
||||||
["libcollect.ss" "libcollect.fasl" p0 onepass]
|
["libcollect.ss" "libcollect.fasl" p0 onepass]
|
||||||
["librecord.ss" "librecord.fasl" p0 onepass]
|
["librecord.ss" "librecord.fasl" p0 onepass]
|
||||||
;["libcxr.ss" "libcxr.fasl" p0 chaitin]
|
;["libcxr.ss" "libcxr.fasl" p0 chaitin]
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue