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

* chaitin can now compile the system.

This commit is contained in:
Abdulaziz Ghuloum 2007-02-17 19:22:14 -05:00
parent 0304c85082
commit b6dd620b94
3 changed files with 92 additions and 24 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.

114
src/libaltcogen.ss
View File

@ -747,7 +747,7 @@
[($set-symbol-value!) disp-symbol-value] [($set-symbol-value!) disp-symbol-value]
[($set-symbol-string!) disp-symbol-string] [($set-symbol-string!) disp-symbol-string]
[($set-symbol-unique-string!) disp-symbol-unique-string] [($set-symbol-unique-string!) disp-symbol-unique-string]
[($set-symbol-plist) disp-symbol-plist] [($set-symbol-plist!) disp-symbol-plist]
[else (err x)])]) [else (err x)])])
(tbind ([x (Value (car arg*))] [v (Value (cadr arg*))]) (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x (- off symbol-tag))))] (mem-assign v x (- off symbol-tag))))]
@ -1658,7 +1658,9 @@
frm-args)]) frm-args)])
(let* ([call (let* ([call
(make-ntcall call-targ value-dest (make-ntcall call-targ value-dest
(cons argc-register (append reg-locs frmt*)) (list* argc-register
pcr esp apr
(append reg-locs frmt*))
#f #f)] #f #f)]
[body [body
(make-nframe frmt* #f (make-nframe frmt* #f
@ -1842,10 +1844,15 @@
(cond (cond
[target [target
(make-primcall 'direct-jump (make-primcall 'direct-jump
(cons target (cons argc-register locs)))] (cons target
(list* argc-register
pcr esp apr
locs)))]
[else [else
(make-primcall 'indirect-jump (make-primcall 'indirect-jump
(cons argc-register locs))])))))))) (list* argc-register
pcr esp apr
locs))]))))))))
(define (Tail x) (define (Tail x)
(record-case x (record-case x
[(constant) (VT x)] [(constant) (VT x)]
@ -2075,6 +2082,7 @@
(define (empty-nfv-set) empty-set) (define (empty-nfv-set) empty-set)
(define (empty-var-set) empty-set) (define (empty-var-set) empty-set)
(define (add-var x s) (set-add x s)) (define (add-var x s) (set-add x s))
(define (mem-var? x s) (set-member? x s))
(define (rem-var x s) (set-rem x s)) (define (rem-var x s) (set-rem x s))
(define (union-vars s1 s2) (union s1 s2)) (define (union-vars s1 s2) (union s1 s2))
(define (empty-reg-set) empty-set) (define (empty-reg-set) empty-set)
@ -2083,11 +2091,13 @@
(define (mem-reg? x s) (set-member? x s)) (define (mem-reg? x s) (set-member? x s))
(define (union-regs s1 s2) (union s1 s2)) (define (union-regs s1 s2) (union s1 s2))
(define (add-frm x s) (set-add x s)) (define (add-frm x s) (set-add x s))
(define (mem-frm? x s) (set-member? x s))
(define (rem-frm x s) (set-rem x s)) (define (rem-frm x s) (set-rem x s))
(define (union-frms s1 s2) (union s1 s2)) (define (union-frms s1 s2) (union s1 s2))
(define (for-each-var s f) (for-each f s)) (define (for-each-var s f) (for-each f s))
(define (add-nfv x s) (set-add x s)) (define (add-nfv x s) (set-add x s))
(define (rem-nfv x s) (set-rem x s)) (define (rem-nfv x s) (set-rem x s))
(define (mem-nfv? x s) (set-member? x s))
(define (union-nfvs s1 s2) (union s1 s2)) (define (union-nfvs s1 s2) (union s1 s2))
(define (for-each-nfv s f) (for-each f s))) (define (for-each-nfv s f) (for-each f s)))
;;; ;;;
@ -2201,8 +2211,10 @@
(cond (cond
[(reg? d) [(reg? d)
(cond (cond
[(not (mem-reg? d rs)) (error who "dead register")] [(not (mem-reg? d rs))
[(or (const? s) (disp? s)) (set-asm-instr-op! x 'nop)
(values vs rs fs ns)]
[(or (const? s) (disp? s) (reg? s))
(let ([rs (rem-reg d rs)]) (let ([rs (rem-reg d rs)])
(mark-reg/vars-conf! d vs) (mark-reg/vars-conf! d vs)
(R s vs rs fs ns))] (R s vs rs fs ns))]
@ -2211,9 +2223,12 @@
[vs (rem-var s vs)]) [vs (rem-var s vs)])
(mark-reg/vars-conf! d vs) (mark-reg/vars-conf! d vs)
(values (add-var s vs) rs fs ns))] (values (add-var s vs) rs fs ns))]
[else (error who "invalid rs ~s" s)])] [else (error who "invalid rs ~s" (unparse x))])]
[(fvar? d) [(fvar? d)
(cond (cond
[(not (mem-frm? d fs))
(set-asm-instr-op! x 'nop)
(values vs rs fs ns)]
[(var? s) [(var? s)
(let ([fs (rem-frm d fs)] (let ([fs (rem-frm d fs)]
[vs (rem-var s vs)]) [vs (rem-var s vs)])
@ -2223,6 +2238,9 @@
[else (error who "invalid fs ~s" s)])] [else (error who "invalid fs ~s" s)])]
[(var? d) [(var? d)
(cond (cond
[(not (mem-var? d vs))
(set-asm-instr-op! x 'nop)
(values vs rs fs ns)]
[(or (disp? s) (constant? s)) [(or (disp? s) (constant? s))
(let ([vs (rem-var d vs)]) (let ([vs (rem-var d vs)])
(mark-var/vars-conf! d vs) (mark-var/vars-conf! d vs)
@ -2256,6 +2274,7 @@
[else (error who "invalid vs ~s" s)])] [else (error who "invalid vs ~s" s)])]
[(nfv? d) [(nfv? d)
(cond (cond
[(not (mem-nfv? d ns)) (error who "dead nfv")]
[(var? s) [(var? s)
(let ([ns (rem-nfv d ns)] (let ([ns (rem-nfv d ns)]
[vs (rem-var s vs)]) [vs (rem-var s vs)])
@ -2264,21 +2283,37 @@
(values (add-var s vs) rs fs ns))] (values (add-var s vs) rs fs ns))]
[else (error who "invalid ns ~s" s)])] [else (error who "invalid ns ~s" s)])]
[else (error who "invalid d ~s" d)])] [else (error who "invalid d ~s" d)])]
[(logand logor sll sra int+) [(logand logor logxor sll sra int+ int- int*)
(cond (cond
[(var? d) [(var? d)
(let ([vs (rem-var d vs)]) (cond
(mark-var/vars-conf! d vs) [(not (mem-var? d vs))
(mark-var/frms-conf! d fs) (set-asm-instr-op! x 'nop)
(mark-var/nfvs-conf! d ns) (values vs rs fs ns)]
(mark-var/regs-conf! d rs) [else
(R s (set-add d vs) rs fs ns))] (let ([vs (rem-var d vs)])
(mark-var/vars-conf! d vs)
(mark-var/frms-conf! d fs)
(mark-var/nfvs-conf! d ns)
(mark-var/regs-conf! d rs)
(R s (set-add d vs) rs fs ns))])]
[(reg? d) [(reg? d)
(let ([rs (rem-reg d rs)]) (cond
(mark-reg/vars-conf! d vs) [(not (mem-reg? d rs))
(R s vs (set-add d rs) fs ns))] (values vs rs fs ns)]
[else
(let ([rs (rem-reg d rs)])
(mark-reg/vars-conf! d vs)
(R s vs (set-add d rs) fs ns))])]
[else (error who "invalid op d ~s" (unparse x))])] [else (error who "invalid op d ~s" (unparse x))])]
[(mset) [(idiv)
(mark-reg/vars-conf! eax vs)
(mark-reg/vars-conf! edx vs)
(R s vs (add-reg eax (add-reg edx rs)) fs ns)]
[(cltd)
(mark-reg/vars-conf! edx vs)
(R s vs (rem-reg edx rs) fs ns)]
[(mset bset/c bset/h)
(R* (list s d) vs rs fs ns)] (R* (list s d) vs rs fs ns)]
[else (error who "invalid effect op ~s" (unparse x))])] [else (error who "invalid effect op ~s" (unparse x))])]
[(ntcall target value args mask size) [(ntcall target value args mask size)
@ -2438,8 +2473,10 @@
[(eq? d s) (make-primcall 'nop '())] [(eq? d s) (make-primcall 'nop '())]
[else [else
(make-asm-instr 'move d s)]))] (make-asm-instr 'move d s)]))]
[(logand logor int+ mset sll sra) [(logand logor logxor int+ int- int* mset bset/c bset/h sll sra
cltd idiv)
(make-asm-instr op (R d) (R s))] (make-asm-instr op (R d) (R s))]
[(nop) (make-primcall 'nop '())]
[else (error who "invalid op ~s" op)])] [else (error who "invalid op ~s" op)])]
[(nframe vars live body) [(nframe vars live body)
(let ([live-vars (vector-ref live 0)] (let ([live-vars (vector-ref live 0)]
@ -2892,8 +2929,36 @@
[(and (mem? a) (mem? b)) [(and (mem? a) (mem? b))
(let ([u (mku)]) (let ([u (mku)])
(make-seq (make-seq
(E (make-asm-instr 'move u b)) (E (make-asm-instr 'move u b))
(E (make-asm-instr op a u))))] (E (make-asm-instr op a u))))]
[(disp? a)
(let ([s0 (disp-s0 a)] [s1 (disp-s1 a)])
(cond
[(mem? s0)
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s0))
(E (make-asm-instr op (make-disp u s1) b))))]
[(mem? s1)
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s1))
(E (make-asm-instr op (make-disp s0 u) b))))]
[else x]))]
[(disp? b)
(let ([s0 (disp-s0 b)] [s1 (disp-s1 b)])
(cond
[(mem? s0)
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s0))
(E (make-asm-instr op a (make-disp u s1)))))]
[(mem? s1)
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u s1))
(E (make-asm-instr op a (make-disp s0 u)))))]
[else x]))]
[else x])] [else x])]
[(cltd) [(cltd)
(unless (and (symbol? a) (symbol? b)) (unless (and (symbol? a) (symbol? b))
@ -2916,7 +2981,7 @@
[(mem? b) [(mem? b)
(let ([u (mku)]) (let ([u (mku)])
(make-seq (make-seq
(E (make-asm-instr 'move u b)) (E (make-asm-instr 'move u b))
(E (make-asm-instr op a u))))] (E (make-asm-instr op a u))))]
[else [else
(let ([s1 (disp-s0 a)] [s2 (disp-s1 a)]) (let ([s1 (disp-s0 a)] [s2 (disp-s1 a)])
@ -2934,12 +2999,12 @@
(let ([u (mku)]) (let ([u (mku)])
(make-seq (make-seq
(E (make-asm-instr 'move u s1)) (E (make-asm-instr 'move u s1))
(make-asm-instr op (make-disp u s2) b)))] (E (make-asm-instr op (make-disp u s2) b))))]
[(mem? s2) [(mem? s2)
(let ([u (mku)]) (let ([u (mku)])
(make-seq (make-seq
(E (make-asm-instr 'move u s2)) (E (make-asm-instr 'move u s2))
(make-asm-instr op (make-disp u s1) b)))] (E (make-asm-instr op (make-disp u s1) b))))]
[else x]))])] [else x]))])]
[else (error who "invalid effect ~s" op)])] [else (error who "invalid effect ~s" op)])]
[(primcall op rands) [(primcall op rands)
@ -3365,6 +3430,7 @@
(T body '())) (T body '()))
(map Clambda code*))])) (map Clambda code*))]))
;;; ;;;
;;; (print-code x)
(Program x)) (Program x))
(define (print-code x) (define (print-code x)
@ -3392,7 +3458,7 @@
[foo (printf "6")] [foo (printf "6")]
;[foo (print-code x)] ;[foo (print-code x)]
[ls (flatten-codes x)]) [ls (flatten-codes x)])
(when #t (when #f
(parameterize ([gensym-prefix "L"] (parameterize ([gensym-prefix "L"]
[print-gensym #f]) [print-gensym #f])
(for-each (for-each

2
src/libcompile.ss
View File

@ -472,6 +472,8 @@
[(locals vars body) `(locals ,(map E vars) ,(E body))] [(locals vars body) `(locals ,(map E vars) ,(E body))]
[(asm-instr op d s) [(asm-instr op d s)
`(asm ,op ,(E d) ,(E s))] `(asm ,op ,(E d) ,(E s))]
[(disp s0 s1)
`(disp ,(E s0) ,(E s1))]
[(nframe vars live body) `(nframe ;[vars: ,(map E vars)] [(nframe vars live body) `(nframe ;[vars: ,(map E vars)]
;[live: ,(map E live)] ;[live: ,(map E live)]
,(E body))] ,(E body))]