- ikarus interpreter (in lab directory) is now capable of

bootstrapping ikarus
This commit is contained in:
Abdulaziz Ghuloum 2009-05-14 10:18:45 +03:00
parent 3207e14fca
commit fda2817a73
3 changed files with 457 additions and 183 deletions

View File

@ -1,202 +1,468 @@
(import (ikarus) (match)) (import (ikarus))
(define (make-annotated-procedure ann proc) (define (make-annotated-procedure ann proc)
(import (ikarus system $codes)) (import (ikarus system $codes))
($make-annotated-procedure ann proc)) ($make-annotated-procedure ann proc))
(define (compile-expr expr env) (module (click-ring unclick-ring get-traces mark-reduction!
(define who 'compile-expr) last-trace reset-ring)
(define (do-letrec lhs* rhs* body env)
(let-values ([(env n) (extend-env lhs* env)]) (define outer-ring-size 5)
(let ([rhs* (map (lambda (x) (compile-expr x env)) rhs*)] (define inner-ring-size 5)
[body (compile-expr body env)])
(lambda (env) (define-struct cell (prev next content))
(let ([vec (make-vector n)])
(let ([env (cons vec env)]) (define (make-ring n f)
(let f ([i 0] [rhs* rhs*]) (cond
(if (null? rhs*) [(= n 1)
(body env) (let ([cell (make-cell #f #f (f))])
(begin (set-cell-prev! cell cell)
(vector-set! vec i ((car rhs*) env)) (set-cell-next! cell cell)
(f (+ i 1) (cdr rhs*))))))))))) cell)]
(define (do-library-letrec lhs* loc* rhs* body env) [else
(let-values ([(env n) (extend-env lhs* env)]) (let ([ring (make-ring (- n 1) f)])
(let ([rhs* (map (lambda (x) (compile-expr x env)) rhs*)] (let ([next (cell-next ring)])
[body (compile-expr body env)]) (let ([cell (make-cell ring next (f))])
(lambda (env) (set-cell-prev! next cell)
(let ([vec (make-vector n)]) (set-cell-next! ring cell)
(let ([env (cons vec env)]) cell)))]))
(let f ([i 0] [rhs* rhs*] [loc* loc*])
(if (null? rhs*) (define (make-double-ring n m)
(body env) (make-ring n (lambda () (make-ring m (lambda () #f)))))
(let ([v ((car rhs*) env)])
(vector-set! vec i v) (define (ring->list x0)
(global-set! (car loc*) v) (let f ([x x0])
(f (+ i 1) (cdr rhs*) (cdr loc*))))))))))) (cons (cell-content x)
(define (lexical-set! env i j v) (let ([x (cell-prev x)])
(vector-set! (list-ref env i) j v)) (if (eq? x x0)
(define (lexical-ref env i j) '()
(vector-ref (list-ref env i) j)) (f x))))))
(define (global-set! loc v)
(set-symbol-value! loc v)) (define (get-traces)
(define (global-ref loc) (map ring->list (ring->list step-ring)))
(top-level-value loc))
(define (extend-env ls env) (define step-ring #f)
(define (properize x)
(cond (define (reset-ring)
[(null? x) '()] (set! step-ring (make-double-ring outer-ring-size inner-ring-size)))
[(pair? x) (cons (car x) (properize (cdr x)))]
[else (list x)])) (define (last-trace)
(let ([v (list->vector (properize ls))]) (cell-content (cell-content step-ring)))
(values (cons v env) (vector-length v))))
(define (lookup x env) (define (click-ring)
(let f ([i 0] [env env]) (let ([x (cell-next step-ring)])
(cond (set! step-ring x)
[(null? env) `(global ,x)] (let ([y (cell-content x)])
[else (set-cell-content! y #f))))
(let g ([j 0] [rib (car env)])
(cond (define (unclick-ring)
[(= j (vector-length rib)) (set-cell-content! (cell-content step-ring) #f)
(f (+ i 1) (cdr env))] (set! step-ring (cell-prev step-ring)))
[(eq? x (vector-ref rib j)) `(lexical ,i ,j)]
[else (g (+ j 1) rib)]))]))) (define (mark-reduction! x)
(define (compile-case-lambda ae fml* expr* env k) (let ([y (cell-next (cell-content step-ring))])
(define (compile-clause fmls expr k) (set-cell-content! y x)
(cond (set-cell-content! step-ring y)))
[(list? fmls) )
(let-values ([(env n) (extend-env fmls env)])
(let ([expr (compile-expr expr env)]) (define (primitive-value x)
(lambda (env args argcount) (import (ikarus system $codes))
(if (= n argcount) (import (ikarus system $structs))
(expr (cons (list->vector args) env)) (import (ikarus system $flonums))
(k env args argcount)))))] (import (ikarus system $bignums))
[else (case x
(let-values ([(env n) (extend-env fmls env)]) [($code-reloc-vector) (lambda (x) ($code-reloc-vector x))]
(let ([expr (compile-expr expr env)]) [($code-freevars) (lambda (x) ($code-freevars x))]
(lambda (env args argcount) [($code-size) (lambda (x) ($code-size x))]
(if (>= argcount n) [($code-annotation) (lambda (x) ($code-annotation x))]
(let ([vec (make-vector n)]) [($code-ref) (lambda (x i) ($code-ref x i))]
(let f ([ls args] [i 0]) [($code-set!) (lambda (x i v) ($code-set! x i v))]
(cond [($code->closure) (lambda (x) ($code->closure x))]
[(= i (- n 1)) [($closure-code) (lambda (x) ($closure-code x))]
(vector-set! vec i ls)] [($struct)
[else (case-lambda
(vector-set! vec i (car ls)) [(x0)
(f (cdr ls) (+ i 1))])) ($struct x0)]
(expr (cons vec env))) [(x0 x1)
(k env args argcount)))))])) ($struct x0 x1)]
(let ([proc [(x0 x1 x2)
(let f ([fml* fml*] [expr* expr*]) ($struct x0 x1 x2)]
[(x0 x1 x2 x3)
($struct x0 x1 x2 x3)]
[(x0 x1 x2 x3 x4)
($struct x0 x1 x2 x3 x4)]
[(x0 x1 x2 x3 x4 x5)
($struct x0 x1 x2 x3 x4 x5)]
[(x0 x1 x2 x3 x4 x5 x6)
($struct x0 x1 x2 x3 x4 x5 x6)]
[(x0 x1 x2 x3 x4 x5 x6 x7)
($struct x0 x1 x2 x3 x4 x5 x6 x7)]
[(x0 x1 x2 x3 x4 x5 x6 x7 x8)
($struct x0 x1 x2 x3 x4 x5 x6 x7 x8)]
[(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9)
($struct x0 x1 x2 x3 x4 x5 x6 x7 x8 x9)]
[(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)
($struct x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)]
[(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)
($struct x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)]
)]
[($struct-set!) struct-set!]
[($struct-ref) struct-ref]
[($annotated-procedure-annotation)
(lambda (x) ($annotated-procedure-annotation x))]
[($char<=) char<=?]
[($string-ref) string-ref]
[($flonum-u8-ref)
(lambda (x i)
(case i
[(0) ($flonum-u8-ref x 0)]
[(1) ($flonum-u8-ref x 1)]
[(2) ($flonum-u8-ref x 2)]
[(3) ($flonum-u8-ref x 3)]
[(4) ($flonum-u8-ref x 4)]
[(5) ($flonum-u8-ref x 5)]
[(6) ($flonum-u8-ref x 6)]
[(7) ($flonum-u8-ref x 7)]
[else (error 'flonum-u8-ref "invalid index" i)]))]
[($bignum-positive?) positive?]
[($bignum-byte-ref) (lambda (x i) ($bignum-byte-ref x i))]
[($bignum-size) (lambda (x) ($bignum-size x))]
[else (system-value x)]))
(define core-interpret
(let ()
(define who 'interpret)
(define (lexical-set! env i j v)
(vector-set! (list-ref env i) j v))
(define (lexical-ref env i j)
(vector-ref (list-ref env i) j))
(define (global-set! loc v)
(set-symbol-value! loc v))
(define (global-ref loc)
(top-level-value loc))
(define (extend-env ls env)
(define (properize x)
(cond
[(null? x) '()]
[(pair? x) (cons (car x) (properize (cdr x)))]
[else (list x)]))
(let ([v (list->vector (properize ls))])
(values (cons v env) (vector-length v))))
(define (lookup x env)
(let f ([i 0] [env env])
(cond
[(null? env) `(global ,x)]
[else
(let g ([j 0] [rib (car env)])
(cond (cond
[(null? fml*) k] [(= j (vector-length rib))
[else (f (+ i 1) (cdr env))]
(compile-clause (car fml*) (car expr*) [(eq? x (vector-ref rib j)) `(lexical ,i ,j)]
(f (cdr fml*) (cdr expr*)))]))]) [else (g (+ j 1) rib)]))])))
(lambda (env) (define (get-fmls x args)
(make-annotated-procedure (define (matching? fmls args)
(cons #f (cond
(if (annotation? ae) [(null? fmls) (null? args)]
(annotation-source ae) [(pair? fmls) (and (pair? args) (matching? (cdr fmls) (cdr args)))]
'#f)) [else #t]))
(lambda args (define (get-cls* x)
(proc env args (length args))))))) (if (pair? x)
(match expr (case (car x)
[(quote ,x) (lambda (env) x)] [(case-lambda) (cdr x)]
[,var (guard (gensym? var)) [(annotated-case-lambda) (cddr x)]
(let ([var (lookup var env)]) [else '()])
(match var '()))
[(lexical ,i ,j) (let f ([cls* (get-cls* x)])
(lambda (env) (cond
(lexical-ref env i j))] [(null? cls*) #f]
[(global ,loc) [(matching? (caar cls*) args)
(lambda (env) (caar cls*)]
(global-ref loc))] [else (f (cdr cls*))])))
[,_ (die who "invalid variable" var)]))] (define (compile-letrec* binding* body env ctxt tail?)
[(set! ,lhs ,[rhs]) (let ([lhs* (map car binding*)]
(let ([lhs (lookup lhs env)]) [rhs* (map cadr binding*)])
(match lhs (let-values ([(env n) (extend-env lhs* env)])
[(lexical ,i ,j) (let ([rhs* (map (lambda (lhs rhs)
(lambda (env) (compile-expr rhs env lhs #f))
(lexical-set! env i j (rhs env)))] lhs* rhs*)]
[(global ,loc) [body (compile-expr body env ctxt tail?)])
(lambda (env) (lambda (env)
(global-set! loc (rhs env)))] (let ([vec (make-vector n)])
[,_ (die who "invalid set! target" lhs)]))] (let ([env (cons vec env)])
[(if ,[e0] ,[e1] ,[e2]) (let f ([i 0] [rhs* rhs*])
(lambda (env) (if (null? rhs*)
(if (e0 env) (e1 env) (e2 env)))] (body env)
[(begin ,[e] ,[e*] ...) (begin
(let ([e* (cons e e*)]) (vector-set! vec i ((car rhs*) env))
(lambda (env) (f (+ i 1) (cdr rhs*))))))))))))
(for-each (lambda (e) (e env)) e*)))] (define (compile-library-letrec* binding* body env ctxt tail?)
[(annotated-case-lambda ,ae [,fml* ,expr*] ...) (let ([lhs* (map car binding*)]
(compile-case-lambda ae fml* expr* env [loc* (map cadr binding*)]
(lambda (env args argcount) [rhs* (map caddr binding*)])
(assertion-violation 'apply (let-values ([(env n) (extend-env lhs* env)])
"incorrect number of arguments" (let ([rhs* (map (lambda (lhs rhs)
args)))] (compile-expr rhs env lhs #f))
[(case-lambda [,fml* ,expr*] ...) lhs* rhs*)]
(compile-case-lambda #f fml* expr* env [body (compile-expr body env ctxt tail?)])
(lambda (env args argcount) (lambda (env)
(assertion-violation 'apply (let ([vec (make-vector n)])
"incorrect number of arguments" (let ([env (cons vec env)])
args)))] (let f ([i 0] [rhs* rhs*] [loc* loc*])
[(lambda ,fmls ,body) (if (null? rhs*)
(compile-expr `(case-lambda [,fmls ,body]) env)] (body env)
[(letrec ([,lhs* ,rhs*] ...) ,body) (let ([v ((car rhs*) env)])
(do-letrec lhs* rhs* body env)] (vector-set! vec i v)
[(letrec* ([,lhs* ,rhs*] ...) ,body) (global-set! (car loc*) v)
(do-letrec lhs* rhs* body env)] (f (+ i 1) (cdr rhs*) (cdr loc*))))))))))))
[(library-letrec* ([,lhs* ,loc* ,rhs*] ...) ,body) (define (compile-case-lambda ae binding* env ctxt)
(do-library-letrec lhs* loc* rhs* body env)] (define (compile-clause fmls expr k)
[(primitive ,x) (let-values ([(env n) (extend-env fmls env)])
(let ([v (system-value x)]) (let ([expr (compile-expr expr env
(lambda (env) v))] (if (pair? ctxt) (car ctxt) #f)
[(,[e] ,[e*] ...) #t)])
(lambda (env) (cond
(apply (e env) (map (lambda (e) (e env)) e*)))] [(list? fmls)
[,x (die who "invalid expression" x)])) (lambda (env args argcount)
(if (= n argcount)
(expr (cons (list->vector args) env))
(k env args argcount)))]
[else
(lambda (env args argcount)
(let ([n1 (- n 1)])
(if (>= argcount n1)
(let ([vec (make-vector n)])
(let f ([ls args] [i 0])
(cond
[(= i n1)
(vector-set! vec i ls)]
[else
(vector-set! vec i (car ls))
(f (cdr ls) (+ i 1))]))
(expr (cons vec env)))
(k env args argcount))))]))))
(let ([proc
(let f ([binding* binding*])
(cond
[(null? binding*)
(lambda (env args argcount)
(assertion-violation 'apply
"incorrect number of arguments"
args))]
[else
(let ([b (car binding*)])
(compile-clause (car b) (cadr b)
(f (cdr binding*))))]))])
(lambda (env)
(make-annotated-procedure
(cons
(and (symbol? ctxt) ctxt)
(and (annotation? ae) (annotation-source ae)))
(lambda args
(proc env args (length args)))))))
(define (compile-var expr env)
(let ([x (lookup expr env)])
(case (car x)
[(lexical)
(let ([i (cadr x)] [j (caddr x)])
(lambda (env)
(lexical-ref env i j)))]
[(global)
(let ([loc (cadr x)])
(lambda (env)
(global-ref loc)))]
[else (die who "invalid value" x)])))
(define (compile-set! lhs rhs env)
(let ([rhs (compile-expr rhs env lhs #f)]
[x (lookup lhs env)])
(case (car x)
[(lexical)
(let ([i (cadr x)] [j (caddr x)])
(lambda (env)
(lexical-set! env i j (rhs env))))]
[(global)
(let ([loc (cadr x)])
(lambda (env)
(global-set! loc (rhs env))))]
[else (die who "invalid set! target" lhs)])))
(define (compile-if e0 e1 e2 env ctxt tail?)
(let ([e0 (compile-expr e0 env #f #f)]
[e1 (compile-expr e1 env ctxt tail?)]
[e2 (compile-expr e2 env ctxt tail?)])
(lambda (env)
(if (e0 env) (e1 env) (e2 env)))))
(define (compile-begin e e* env ctxt tail?)
(cond
[(null? e*) (compile-expr e env ctxt tail?)]
[else
(let ([e0 (compile-expr e env #f #f)]
[e* (compile-begin (car e*) (cdr e*) env ctxt tail?)])
(lambda (env) (e0 env) (e* env)))]))
(define (get-src/expr ae)
(if (annotation? ae)
(values (annotation-source ae) (annotation-stripped ae))
(values #f (syntax->datum ae))))
(define (compile-tail-call ae e e* env ctxt)
(let ([e (compile-expr e env (list ctxt) #f)]
[fmls (get-fmls e e*)])
(let ([e*
(let f ([e* e*] [fmls fmls])
(cond
[(pair? fmls)
(cons
(compile-expr (car e*) env (car fmls) #f)
(f (cdr e*) (cdr fmls)))]
[else
(map (lambda (x) (compile-expr x env #f #f)) e*)]))])
(if (or #t ae)
(let-values ([(src expr) (get-src/expr ae)])
(lambda (env)
(let ([e (e env)] [e* (map (lambda (e) (e env)) e*)])
(let ([tr (last-trace)])
(mark-reduction!
(make-trace src expr env e e*
(if tr (+ 1 (trace-depth tr)) 0))))
(apply e e*))))
(lambda (env)
(let ([e (e env)] [e* (map (lambda (e) (e env)) e*)])
(apply e e*)))))))
(define (compile-nontail-call ae e e* env ctxt)
(let ([proc (compile-tail-call ae e e* env ctxt)])
(lambda (env)
(dynamic-wind
click-ring
(lambda () (proc env))
unclick-ring))))
(define (compile-call ae e e* env ctxt tail?)
(define (let-pattern? e e*)
(let ([ls (get-fmls e e*)])
(and (list? ls) (= (length ls) (length e*)))))
(define (compile-let e e* env ctxt tail?)
(let ([ls (get-fmls e e*)])
(let ([e (compile-expr e env ctxt env)]
[e* (map (lambda (x e)
(compile-expr e env x env))
ls e*)])
(lambda (env)
(apply (e env)
(map (lambda (e) (e env)) e*))))))
(if (let-pattern? e e*)
(compile-let e e* env ctxt tail?)
(if tail?
(compile-tail-call ae e e* env ctxt)
(compile-nontail-call ae e e* env ctxt))))
(define (compile-expr expr env ctxt tail?)
(cond
[(symbol? expr) (compile-var expr env)]
[(and (pair? expr) (list? expr))
(let ([a (car expr)] [d (cdr expr)])
(case a
[(quote) (let ([v (car d)]) (lambda (env) v))]
[(set!) (compile-set! (car d) (cadr d) env)]
[(if)
(compile-if (car d) (cadr d) (caddr d) env ctxt tail?)]
[(begin)
(compile-begin (car d) (cdr d) env ctxt tail?)]
[(lambda)
(compile-case-lambda #f (list d) env ctxt)]
[(case-lambda)
(compile-case-lambda #f d env ctxt)]
[(annotated-case-lambda)
(compile-case-lambda (car d) (cdr d) env ctxt)]
[(letrec letrec*)
(compile-letrec* (car d) (cadr d) env ctxt tail?)]
[(library-letrec*)
(compile-library-letrec* (car d) (cadr d) env ctxt tail?)]
[(primitive)
(let ([v (primitive-value (car d))])
(lambda (env) v))]
[(annotated-call)
(compile-call (car d) (cadr d) (cddr d) env ctxt tail?)]
[(foreign-call)
(let ([name (car d)] [args (cdr d)])
(let ([ls (map (lambda (x) (gensym)) args)])
(let ([code
(real-eval
`(lambda ,ls (foreign-call ,name . ,ls)))])
(compile-expr `(',code . ,args) env ctxt tail?))))]
[else
(compile-call #f a d env ctxt tail?)]))]
[else
(die who "invalid expression" expr)]))
(lambda (expr)
((compile-expr expr '() #f #t) '()))))
(define-struct trace (src expr env v v* depth))
(define (print-trace x)
(printf " [~a] ~s\n" (trace-depth x) (trace-expr x))
(let ([src (trace-src x)])
(when (pair? src)
(printf " source: char ~a of ~a\n" (cdr src) (car src))))
(printf " operator: ~s\n" (trace-v x))
(printf " operands: ~s\n" (trace-v* x)))
(define (print-step ls)
(let ([ls (let f ([ls ls])
(if (or (null? ls) (not (car ls)))
'()
(cons (car ls) (f (cdr ls)))))])
(unless (null? ls)
(printf "FRAME:\n")
(for-each print-trace (reverse ls)))))
(define (print-all-traces)
(for-each print-step (get-traces)))
(parameterize ([current-core-eval (define (start-repl)
(lambda (expr)
;(display "=================\n")
;(pretty-print expr)
;(display "=================\n")
(let ([proc (compile-expr expr '())])
(proc '())))])
(display "Ikarus Interpreter\n\n") (display "Ikarus Interpreter\n\n")
(new-cafe)) (new-cafe
(lambda (x)
(with-exception-handler
(lambda (con)
(print-all-traces)
(raise-continuable con))
(lambda ()
(reset-ring)
(eval x (interaction-environment)))))))
(define (start-script script-name args)
(command-line-arguments (cons script-name args))
(with-exception-handler
(lambda (con)
(print-all-traces)
(raise-continuable con))
(lambda ()
(reset-ring)
(load-r6rs-script script-name #f #t))))
(define original-eval (current-core-eval))
(define (real-eval x)
(parameterize ([current-core-eval original-eval])
(eval x (environment '(ikarus)))))
(current-core-eval core-interpret)
(apply
(case-lambda
[(interpreter flag script-name . rest)
(if (string=? flag "--r6rs-script")
(start-script script-name rest)
(error interpreter "invalid args" (cons* flag script-name rest)))]
[(interpreter) (start-repl)]
[(interpreter . rest)
(error interpreter "invalid args" rest)])
(command-line-arguments))
#!eof #!eof
(define-struct cell (prev next content))
(define (make-ring n f)
(cond
[(= n 1)
(let ([cell (make-cell #f #f (f))])
(set-cell-prev! cell cell)
(set-cell-next! cell cell)
cell)]
[else
(let ([ring (make-ring (- n 1) f)])
(let ([prev (cell-prev ring)]
[next (cell-next ring)])
(let ([cell (make-cell ring next (f))])
(set-cell-next! prev cell)
(set-cell-prev! ring cell)
cell)))]))
(define (make-double-ring n m)
(make-ring n (lambda () (make-ring m (lambda () #f)))))
(print-graph #t) (print-graph #t)
;(write (make-double-rib 5 5)) ;(write (make-double-rib 5 5))

View File

@ -1 +1 @@
1775 1776

View File

@ -3921,6 +3921,14 @@
(define (syntax-annotation x) (define (syntax-annotation x)
(if (stx? x) (stx-expr x) x)) (if (stx? x) (stx-expr x) x))
; (define (syntax-annotation x)
; (if (stx? x)
; (let ([expr (stx-expr x)])
; (if (annotation? x)
; x
; (stx->datum x)))
; (stx->datum x)))
(define (assertion-error expr pos) (define (assertion-error expr pos)
(raise (raise
(condition (condition