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

* fixed bug in assembler 

* assembler now handles  orl imm, mem
This commit is contained in:
Abdulaziz Ghuloum 2007-02-12 17:59:58 -05:00
parent f766ca1148
commit fad2c4e999
4 changed files with 308 additions and 204 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.

485
src/libaltcogen.ss
View File

@ -570,7 +570,12 @@
(tbind ([t (prm 'int+ x (K i))]) (tbind ([t (prm 'int+ x (K i))])
(make-seq (make-seq
(prm 'mset! t (K 0) q) (prm 'mset! t (K 0) q)
(prm 'record-effect t))))) (prm 'mset!
(prm 'int+
(prm 'mref pcr (K 28))
(prm 'sll (prm 'sra t (K pageshift)) (K wordshift)))
(K 0)
(K dirty-word))))))
(record-case x (record-case x
[(bind lhs* rhs* body) [(bind lhs* rhs* body)
(make-bind lhs* (map Value rhs*) (Effect body))] (make-bind lhs* (map Value rhs*) (Effect body))]
@ -837,7 +842,7 @@
(make-seq (E e0) (S e1 k))] (make-seq (E e0) (S e1 k))]
[else [else
(cond (cond
[(or (constant? x) (var? x)) (k x)] [(or (constant? x) (var? x) (symbol? x)) (k x)]
[(or (funcall? x) (primcall? x) (jmpcall? x) [(or (funcall? x) (primcall? x) (jmpcall? x)
(conditional? x)) (conditional? x))
(let ([t (unique-var 'tmp)]) (let ([t (unique-var 'tmp)])
@ -878,7 +883,7 @@
(let-values ([(reg-locs reg-args frm-args) (let-values ([(reg-locs reg-args frm-args)
(nontail-locations (cons rator rands))]) (nontail-locations (cons rator rands))])
(let ([regt* (map (lambda (x) (unique-var 'rt)) reg-args)] (let ([regt* (map (lambda (x) (unique-var 'rt)) reg-args)]
[frmt* (map (lambda (x) (make-nfvar #f #f)) frm-args)]) [frmt* (map (lambda (x) (make-nfvar 'unset-conflicts #f)) 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*)) (cons argc-register (append reg-locs frmt*))
@ -896,6 +901,7 @@
(if value-dest (if value-dest
(make-seq body (make-set value-dest return-value-register)) (make-seq body (make-set value-dest return-value-register))
body))))) body)))))
;;; impose value
(define (V d x) (define (V d x)
(record-case x (record-case x
[(constant) (make-set d x)] [(constant) (make-set d x)]
@ -907,9 +913,36 @@
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(make-conditional (P e0) (V d e1) (V d e2))] (make-conditional (P e0) (V d e1) (V d e2))]
[(primcall op rands) [(primcall op rands)
(S* rands (case op
(lambda (rands) [(alloc)
(make-set d (make-primcall op rands))))] (S (car rands)
(lambda (size)
(S (cadr rands)
(lambda (tag)
(make-seq
(make-seq
(make-set d apr)
(make-asm-instr 'logor d tag))
(make-asm-instr 'int+ apr size))))))]
[(mref)
(S* rands
(lambda (rands)
(make-set d (make-disp (car rands) (cadr rands)))))]
[(logand int+)
(make-seq
(V d (car rands))
(S (cadr rands)
(lambda (s)
(make-asm-instr op d s))))]
[(sll sra)
(let ([a (car rands)] [b (cadr rands)])
(cond
[(constant? b)
(make-seq
(V d a)
(make-asm-instr op d b))]
[else (error who "invalid shift ~s" x)]))]
[else (error who "invalid value op ~s" op)])]
[(funcall rator rands) [(funcall rator rands)
(handle-nontail-call rator rands d #f)] (handle-nontail-call rator rands d #f)]
[(jmpcall label rator rands) [(jmpcall label rator rands)
@ -928,7 +961,7 @@
(make-seq (make-seq
(V return-value-register x) (V return-value-register x)
(make-primcall 'return (list return-value-register)))) (make-primcall 'return (list return-value-register))))
;;; ;;; impose effect
(define (E x) (define (E x)
(record-case x (record-case x
[(seq e0 e1) (make-seq (E e0) (E e1))] [(seq e0 e1) (make-seq (E e0) (E e1))]
@ -937,15 +970,24 @@
[(bind lhs* rhs* e) [(bind lhs* rhs* e)
(do-bind lhs* rhs* (E e))] (do-bind lhs* rhs* (E e))]
[(primcall op rands) [(primcall op rands)
(S* rands (case op
(lambda (rands) [(mset!)
(make-primcall op rands)))] (S* rands
(lambda (s*)
(make-asm-instr 'mset
(make-disp (car s*) (cadr s*))
(caddr s*))))]
[(nop) x]
[else (error 'impose-effect "invalid instr ~s" x)])]
; (S* rands
; (lambda (rands)
; (make-primcall op rands)))]
[(funcall rator rands) [(funcall rator rands)
(handle-nontail-call rator rands #f #f)] (handle-nontail-call rator rands #f #f)]
[(jmpcall label rator rands) [(jmpcall label rator rands)
(handle-nontail-call rator rands #f label)] (handle-nontail-call rator rands #f label)]
[else (error who "invalid effect ~s" x)])) [else (error who "invalid effect ~s" x)]))
;;; ;;; impose pred
(define (P x) (define (P x)
(record-case x (record-case x
[(constant) x] [(constant) x]
@ -957,7 +999,7 @@
[(primcall op rands) [(primcall op rands)
(S* rands (S* rands
(lambda (rands) (lambda (rands)
(make-primcall op rands)))] (make-asm-instr op (car rands) (cadr rands))))]
[else (error who "invalid pred ~s" x)])) [else (error who "invalid pred ~s" x)]))
;;; ;;;
(define (handle-tail-call target rator rands) (define (handle-tail-call target rator rands)
@ -1109,27 +1151,28 @@
;;; ;;;
#|ListyGraphs|#) #|ListyGraphs|#)
(define (set-add x s) (begin
(cond (define (set-add x s)
[(memq x s) s] (cond
[else (cons x s)])) [(memq x s) s]
[else (cons x s)]))
(define (set-rem x s)
(cond (define (set-rem x s)
[(null? s) '()] (cond
[(eq? x (car s)) (cdr s)] [(null? s) '()]
[else (cons (car s) (set-rem x (cdr s)))])) [(eq? x (car s)) (cdr s)]
[else (cons (car s) (set-rem x (cdr s)))]))
(define (set-difference s1 s2)
(cond (define (set-difference s1 s2)
[(null? s2) s1] (cond
[else (set-difference (set-rem (car s2) s1) (cdr s2))])) [(null? s2) s1]
[else (set-difference (set-rem (car s2) s1) (cdr s2))]))
(define (set-union s1 s2)
(cond (define (set-union s1 s2)
[(null? s1) s2] (cond
[(memq (car s1) s2) (set-union (cdr s1) s2)] [(null? s1) s2]
[else (cons (car s1) (set-union (cdr s1) s2))])) [(memq (car s1) s2) (set-union (cdr s1) s2)]
[else (cons (car s1) (set-union (cdr s1) s2))])))
(module (color-by-chaitin) (module (color-by-chaitin)
@ -1138,49 +1181,58 @@
(define (build-graph x reg?) (define (build-graph x reg?)
(define who 'build-graph) (define who 'build-graph)
(define g (empty-graph)) (define g (empty-graph))
(define (add-rands ls s) (define (R* ls)
(cond (cond
[(null? ls) s] [(null? ls) '()]
[(or (reg? (car ls)) (var? (car ls)) (nfvar? (car ls))) [else (union (R (car ls)) (R* (cdr ls)))]))
(add-rands (cdr ls) (set-add (car ls) s))] (define (R x)
[else (add-rands (cdr ls) s)]))
(define (Rhs x s)
(record-case x (record-case x
[(primcall op rand*) (add-rands rand* s)] [(constant) '()]
[else [(var) (list x)]
(if (or (var? x) (reg? x) (nfvar? x)) [(disp s0 s1) (union (R s0) (R s1))]
(set-add x s) [(nfvar) (list x)]
s)])) [(fvar) (if (reg? x) (list x) '())]
[(code-loc) '()]
[else
(cond
[(symbol? x) (if (reg? x) (list x) '())]
[else (error who "invalid R ~s" x)])]))
;;; build-graph effect
(define (E x s) (define (E x s)
(record-case x (record-case x
[(set lhs rhs) [(set x v)
(cond (let ([s (set-rem x s)])
[(or (var? lhs) (reg? lhs)) (record-case x
(cond [(nfvar c i)
[(or (var? rhs) (reg? rhs)) (if (list? c)
(let ([s (set-rem rhs (set-rem lhs s))]) (set-nfvar-conf! x
(for-each (lambda (x) (set-union c s))
(when (or (var? x) (reg? x)) (set-nfvar-conf! x s))
(add-edge! g lhs x))) (union (R v) s)]
s) [else
(cons rhs s))] (for-each (lambda (y) (add-edge! g x y)) s)
[else (union (R v) s)]))]
(let ([s (set-rem lhs s)]) [(asm-instr op d v)
(for-each (lambda (x) (case op
(when (or (var? x) (reg? x)) [(logand int+ logor sll sra)
(add-edge! g lhs x))) (let ([s (set-rem d s)])
s) (record-case d
(Rhs rhs s))])] [(nfvar c i)
[(nfvar? lhs) (if (list? c)
(let ([s (set-rem lhs s)]) (set-nfvar-conf! d
(set-nfvar-conf! lhs s) (set-union c s))
(Rhs rhs s))] (set-nfvar-conf! d s))
[else (Rhs rhs s)])] (union (union (R v) (R d)) s)]
[else
(for-each (lambda (y) (add-edge! g d y)) s)
(union (union (R v) (R d)) s)]))]
[(mset)
(union (R v) (union (R d) s))]
[else (error who "invalid effect ~s" x)])]
[(seq e0 e1) (E e0 (E e1 s))] [(seq e0 e1) (E e0 (E e1 s))]
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(let ([s1 (E e1 s)] [s2 (E e2 s)]) (let ([s1 (E e1 s)] [s2 (E e2 s)])
(P e0 s1 s2 (set-union s1 s2)))] (P e0 s1 s2 (set-union s1 s2)))]
[(primcall op rands) (add-rands rands s)]
[(nframe vars live body) [(nframe vars live body)
(when (reg? return-value-register) (when (reg? return-value-register)
(for-each (for-each
@ -1189,10 +1241,15 @@
(add-edge! g x r)) (add-edge! g x r))
all-registers)) all-registers))
s)) s))
(set-nframe-live! x s) (let ([s (set-difference s all-registers)])
(E body s)] (set-nframe-live! x s)
(E body s))]
[(ntcall targ value args mask size) [(ntcall targ value args mask size)
(add-rands args s)] (union (R* args) s)]
[(primcall op arg*)
(case op
[(nop) s]
[else (error who "invalid effect primcall ~s" op)])]
[else (error who "invalid effect ~s" x)])) [else (error who "invalid effect ~s" x)]))
(define (P x st sf su) (define (P x st sf su)
(record-case x (record-case x
@ -1202,8 +1259,8 @@
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(let ([s1 (P e1 st sf su)] [s2 (P e2 st sf su)]) (let ([s1 (P e1 st sf su)] [s2 (P e2 st sf su)])
(P e0 s1 s2 (set-union s1 s2)))] (P e0 s1 s2 (set-union s1 s2)))]
[(primcall op rands) [(asm-instr op s0 s1)
(add-rands rands su)] (union (union (R s0) (R s1)) su)]
[else (error who "invalid pred ~s" x)])) [else (error who "invalid pred ~s" x)]))
(define (T x) (define (T x)
(record-case x (record-case x
@ -1211,7 +1268,7 @@
(let ([s1 (T e1)] [s2 (T e2)]) (let ([s1 (T e1)] [s2 (T e2)])
(P e0 s1 s2 (set-union s1 s2)))] (P e0 s1 s2 (set-union s1 s2)))]
[(primcall op rands) [(primcall op rands)
(add-rands rands '())] (R* rands)]
[(seq e0 e1) (E e0 (T e1))] [(seq e0 e1) (E e0 (T e1))]
[else (error who "invalid tail ~s" x)])) [else (error who "invalid tail ~s" x)]))
(let ([s (T x)]) (let ([s (T x)])
@ -1358,10 +1415,28 @@
[else (void)])) [else (void)]))
live*) live*)
v)) v))
(define (D x)
(record-case x
[(constant) x]
[(var) (Var x)]
[(fvar) x]
[else
(if (symbol? x) x (error who "invalid D ~s" x))]))
(define (R x)
(record-case x
[(constant) x]
[(var) (Var x)]
[(fvar) x]
[(nfvar c loc)
(or loc (error who "unset nfvar ~s in R" x))]
[(disp s0 s1) (make-disp (D s0) (D s1))]
[else
(if (symbol? x) x (error who "invalid R ~s" x))]))
;;; substitute effect
(define (E x) (define (E x)
(record-case x (record-case x
[(set lhs rhs) [(set lhs rhs)
(let ([lhs (Lhs lhs)] [rhs (Rhs rhs)]) (let ([lhs (R lhs)] [rhs (R rhs)])
(cond (cond
[(or (eq? lhs rhs) [(or (eq? lhs rhs)
(and (fvar? lhs) (fvar? rhs) (and (fvar? lhs) (fvar? rhs)
@ -1373,10 +1448,25 @@
[(seq e0 e1) (make-seq (E e0) (E e1))] [(seq e0 e1) (make-seq (E e0) (E e1))]
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(make-conditional (P e0) (E e1) (E e2))] (make-conditional (P e0) (E e1) (E e2))]
[(asm-instr op x v)
(make-asm-instr op (R x) (R v))]
[(primcall op rands) [(primcall op rands)
(make-primcall op (map Rand rands))] (make-primcall op (map R rands))]
[(nframe vars live body) [(nframe vars live body)
(let ([live-fv* (map Lhs live)]) (let ([live-fv*
(map (lambda (x)
(record-case x
[(var)
(let ([l (Var x)])
(if (fvar? l)
l
(error who "unspilled live-after ~s"
x)))]
[(nfvar c loc)
(or loc (error who "unspilled live-after ~s" x))]
[else
(error who "invalid live-after ~s" x)]))
live)])
(let ([i (actual-frame-size vars (let ([i (actual-frame-size vars
(fx+ 2 (max-live live-fv* 0)))]) (fx+ 2 (max-live live-fv* 0)))])
(assign-frame-vars! vars i) (assign-frame-vars! vars i)
@ -1386,8 +1476,8 @@
(define (P x) (define (P x)
(record-case x (record-case x
[(constant) x] [(constant) x]
[(primcall op rands) [(asm-instr op x v)
(make-primcall op (map Rand rands))] (make-asm-instr op (R x) (R v))]
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(make-conditional (P e0) (P e1) (P e2))] (make-conditional (P e0) (P e1) (P e2))]
[(seq e0 e1) (make-seq (E e0) (P e1))] [(seq e0 e1) (make-seq (E e0) (P e1))]
@ -1428,23 +1518,25 @@
(let ([u (unique-var 'u)]) (let ([u (unique-var 'u)])
(set! un* (cons u un*)) (set! un* (cons u un*))
u)) u))
(define (S x k)
(cond
[(or (constant? x) (var? x) (symbol? x))
(k x)]
[else
(let ([u (mku)])
(make-seq (E (make-set u x)) (k u)))]))
(define (S* ls k) (define (S* ls k)
(cond (cond
[(null? ls) (k '())] [(null? ls) (k '())]
[else [else
(let ([a (car ls)]) (S (car ls)
(S* (cdr ls) (lambda (a)
(lambda (d) (S* (cdr ls)
(cond (lambda (d)
[(or (constant? a) (k (cons a d))))))]))
(var? a) (define (mem? x)
(symbol? a)) (or (disp? x) (fvar? x)))
(k (cons a d))] ;;; unspillable effect
[else
(let ([u (mku)])
(make-seq
(E (make-set u a))
(k (cons u d))))]))))]))
(define (E x) (define (E x)
(record-case x (record-case x
[(set lhs rhs) [(set lhs rhs)
@ -1458,19 +1550,64 @@
(E (make-set u rhs)) (E (make-set u rhs))
(make-set lhs u)))])] (make-set lhs u)))])]
[(fvar? rhs) x] [(fvar? rhs) x]
[(primcall? rhs) [(disp? rhs)
(S* (primcall-arg* rhs) (S (disp-s0 rhs)
(lambda (s*) (lambda (s0)
(make-set lhs (S (disp-s1 rhs)
(make-primcall (primcall-op rhs) s*))))] (lambda (s1)
(make-set lhs (make-disp s0 s1))))))]
[else (error who "invalid set in ~s" x)])] [else (error who "invalid set in ~s" x)])]
[(seq e0 e1) (make-seq (E e0) (E e1))] [(seq e0 e1) (make-seq (E e0) (E e1))]
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(make-conditional (P e0) (E e1) (E e2))] (make-conditional (P e0) (E e1) (E e2))]
[(asm-instr op a b)
(case op
[(logor logand int+)
(cond
[(and (mem? a) (mem? b))
(let ([u (mku)])
(make-seq
(E (make-set u b))
(E (make-asm-instr op a u))))]
[else x])]
[(sll sra)
(unless (constant? b) (error who "invalid shift ~s" b))
x]
[(mset)
(cond
[(mem? b)
(let ([u (mku)])
(make-seq
(E (make-set u b))
(E (make-asm-instr op a u))))]
[else
(let ([s1 (disp-s0 a)] [s2 (disp-s1 a)])
(cond
[(and (mem? s1) (mem? s2))
(let ([u (mku)])
(make-seq
(make-seq
(E (make-set u s1))
(E (make-asm-instr 'int+ u s2)))
(make-asm-instr 'mset
(make-disp u (make-constant 0))
b)))]
[(mem? s1)
(let ([u (mku)])
(make-seq
(E (make-set u s1))
(make-asm-instr 'mset (make-disp u s2) b)))]
[(mem? s2)
(let ([u (mku)])
(make-seq
(E (make-set u s2))
(make-asm-instr 'mset (make-disp u s1) b)))]
[else x]))])]
[else (error who "invalid effect ~s" op)])]
[(primcall op rands) [(primcall op rands)
(case op (case op
[(nop) x] [(nop) x]
[(mset! record-effect) [(record-effect)
(S* rands (S* rands
(lambda (s*) (lambda (s*)
(make-primcall op s*)))] (make-primcall op s*)))]
@ -1492,6 +1629,14 @@
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(make-conditional (P e0) (P e1) (P e2))] (make-conditional (P e0) (P e1) (P e2))]
[(seq e0 e1) (make-seq (E e0) (P e1))] [(seq e0 e1) (make-seq (E e0) (P e1))]
[(asm-instr op a b)
(cond
[(and (mem? a) (mem? b))
(let ([u (mku)])
(make-seq
(E (make-set u b))
(make-asm-instr op a u)))]
[else x])]
[else (error who "invalid pred ~s" x)])) [else (error who "invalid pred ~s" x)]))
(define (T x) (define (T x)
(record-case x (record-case x
@ -1509,24 +1654,27 @@
[(locals sp* body) [(locals sp* body)
(let ([frame-g (build-graph body fvar?)]) (let ([frame-g (build-graph body fvar?)])
(let loop ([sp* sp*] [un* '()] [body body]) (let loop ([sp* sp*] [un* '()] [body body])
; (printf "a") (printf "a")
(let ([g (build-graph body symbol?)]) (let ([g (build-graph body
(lambda (x)
(and (symbol? x)
(memq x all-registers))))])
; (printf "loop:\n") ; (printf "loop:\n")
; (print-code body) ; (print-code body)
;(print-graph g) ;(print-graph g)
; (printf "b") (printf "b")
(let-values ([(spills sp* env) (color-graph sp* un* g)]) (let-values ([(spills sp* env) (color-graph sp* un* g)])
; (printf "c") (printf "c")
(cond (cond
[(null? spills) (substitute env body frame-g)] [(null? spills) (substitute env body frame-g)]
[else [else
; (printf "d") (printf "d")
(let* ([env (do-spill spills frame-g)] (let* ([env (do-spill spills frame-g)]
[body (substitute env body frame-g)]) [body (substitute env body frame-g)])
; (printf "e") (printf "e")
(let-values ([(un* body) (let-values ([(un* body)
(add-unspillables un* body)]) (add-unspillables un* body)])
; (printf "f") (printf "f")
(loop sp* un* body)))])))))])) (loop sp* un* body)))])))))]))
;;; ;;;
(define (color-by-chaitin x) (define (color-by-chaitin x)
@ -1556,88 +1704,39 @@
;;; ;;;
(define (FVar i) (define (FVar i)
`(disp ,(* i (- wordsize)) ,fpr)) `(disp ,(* i (- wordsize)) ,fpr))
(define (Rand x) ;;;
(define (C x)
(record-case x (record-case x
[(constant c) [(code-loc label) (label-address label)]
(record-case c [(closure label free*)
[(code-loc label) (label-address label)] (unless (null? free*) (error who "nonempty closure"))
[(closure label free*) `(obj ,x)]
(unless (null? free*) [(object o)
(error who "nonempty closure")) `(obj ,o)]
`(obj ,c)]
[(object o)
`(obj ,o)]
[else
(if (integer? c)
c
(error who "invalid constant rand ~s" c))])]
[(fvar i) (FVar i)]
[(primcall op rands)
(case op
[(mem) `(disp . ,(map Rand rands))]
[else (error who "invalid rand ~s" x)])]
[else [else
(if (symbol? x) (if (integer? x)
x x
(error who "invalid rand ~s" x))])) (error who "invalid constant C ~s" x))]))
;;; (define (D x)
(define (indep? x y)
(define (reg-not-in x y)
(cond
[(symbol? y) (not (eq? x y))]
[(primcall? y)
(andmap (lambda (y) (reg-not-in x y)) (primcall-arg* y))]
[else #t]))
(cond
[(symbol? x) (reg-not-in x y)]
[(symbol? y) (reg-not-in y x)]
[else #t]))
(define (Rhs x d ac)
(define (UNARG op d a1 a2 ac)
(cond
[(eq? a1 d)
`([,op ,(Rand a2) ,d] . ,ac)]
[(eq? a2 d)
`([,op ,(Rand a1) ,d] . ,ac)]
[(indep? d a1)
`([movl ,(Rand a2) ,(Rand d)] [,op ,(Rand a1) ,(Rand d)] . ,ac)]
[(indep? d a2)
`([movl ,(Rand a1) ,(Rand d)] [,op ,(Rand a2) ,(Rand d)] . ,ac)]
[else (error 'UNARG "cannot handle ~s ~s ~s" d a1 a2)]))
(record-case x (record-case x
[(constant c) [(constant c) (C c)]
(cons `(movl ,(Rand x) ,d) ac)] [else
[(fvar i) (if (symbol? x) x (error who "invalid D ~s" x))]))
(cons `(movl ,(FVar i) ,d) ac)] (define (R x)
[(primcall op rands) (record-case x
(case op [(constant c) (C c)]
[(mref) [(fvar i) (FVar i)]
(cons `(movl (disp ,(Rand (car rands)) [(disp s0 s1)
,(Rand (cadr rands))) (let ([s0 (D s0)] [s1 (D s1)])
,d) `(disp ,s0 ,s1))]
ac)] [else
[(logand) (if (symbol? x) x (error who "invalid R ~s" x))]))
(UNARG 'andl d (car rands) (cadr rands) ac)] ;;; flatten effect
[(int+)
(UNARG 'addl d (car rands) (cadr rands) ac)]
[(alloc)
(let ([sz (Rand (car rands))]
[tag (Rand (cadr rands))])
(list* `(movl ,apr ,d)
`(addl ,tag ,d)
`(addl ,sz ,apr)
ac))]
[else (error who "invalid rhs ~s" x)])]
[else
(if (symbol? x)
(cons `(movl ,x ,d) ac)
(error who "invalid rhs ~s" x))]))
;;;
(define (E x ac) (define (E x ac)
(record-case x (record-case x
[(seq e0 e1) (E e0 (E e1 ac))] [(seq e0 e1) (E e0 (E e1 ac))]
[(set lhs rhs) [(set lhs rhs)
(Rhs rhs (Rand lhs) ac)] (cons `(movl ,(R rhs) ,(R lhs)) ac)]
[(conditional e0 e1 e2) [(conditional e0 e1 e2)
(let ([lf (unique-label)] [le (unique-label)]) (let ([lf (unique-label)] [le (unique-label)])
(P e0 #f lf (P e0 #f lf
@ -1675,6 +1774,15 @@
`(call (disp ,(fx- disp-closure-code closure-tag) ,cp-register)) `(call (disp ,(fx- disp-closure-code closure-tag) ,cp-register))
`(addl ,(* (fxsub1 size) wordsize) ,fpr) `(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)]))] ac)]))]
[(asm-instr op d s)
(case op
[(logand) (cons `(andl ,(R s) ,(R d)) ac)]
[(int+) (cons `(addl ,(R s) ,(R d)) ac)]
[(logor) (cons `(orl ,(R s) ,(R d)) ac)]
[(mset) (cons `(movl ,(R s) ,(R d)) ac)]
[(sll) (cons `(sall ,(R s) ,(R d)) ac)]
[(sra) (cons `(sarl ,(R s) ,(R d)) ac)]
[else (error who "invalid instr ~s" x)])]
[(primcall op rands) [(primcall op rands)
(case op (case op
[(nop) ac] [(nop) ac]
@ -1687,11 +1795,6 @@
`(addl ,(pcb-ref 'dirty-vector) ,a) `(addl ,(pcb-ref 'dirty-vector) ,a)
`(movl ,dirty-word (disp 0 ,a)) `(movl ,dirty-word (disp 0 ,a))
ac))] ac))]
[(mset!)
(cons `(movl ,(Rand (caddr rands))
(disp ,(Rand (car rands))
,(Rand (cadr rands))))
ac)]
[else (error who "invalid effect ~s" x)])] [else (error who "invalid effect ~s" x)])]
[else (error who "invalid effect ~s" x)])) [else (error who "invalid effect ~s" x)]))
;;; ;;;
@ -1729,8 +1832,8 @@
(P e1 #f #f (P e1 #f #f
(cons `(jmp ,lf) (cons `(jmp ,lf)
(cons l (P e2 #f #f (cons lf ac)))))))])] (cons l (P e2 #f #f (cons lf ac)))))))])]
[(primcall op rands) [(asm-instr op a0 a1)
(let ([a0 (car rands)] [a1 (cadr rands)]) (let ()
(define (notop x) (define (notop x)
(cond (cond
[(assq x '([= !=] [!= =] [< >=] [<= >] [> <=] [>= <])) [(assq x '([= !=] [!= =] [< >=] [<= >] [> <=] [>= <]))
@ -1749,11 +1852,11 @@
(define (cmp op a0 a1 lab ac) (define (cmp op a0 a1 lab ac)
(cond (cond
[(or (symbol? a0) (constant? a1)) [(or (symbol? a0) (constant? a1))
(list* `(cmpl ,(Rand a1) ,(Rand a0)) (list* `(cmpl ,(R a1) ,(R a0))
`(,(jmpname op) ,lab) `(,(jmpname op) ,lab)
ac)] ac)]
[(or (symbol? a1) (constant? a0)) [(or (symbol? a1) (constant? a0))
(list* `(cmpl ,(Rand a0) ,(Rand a1)) (list* `(cmpl ,(R a0) ,(R a1))
`(,(revjmpname op) ,lab) `(,(revjmpname op) ,lab)
ac)] ac)]
[else (error who "invalid ops ~s ~s" a0 a1)])) [else (error who "invalid ops ~s ~s" a0 a1)]))
@ -1908,12 +2011,12 @@
;[foo (printf "3")] ;[foo (printf "3")]
;[foo (print-code x)] ;[foo (print-code x)]
[x (specify-representation x)] [x (specify-representation x)]
;[foo (printf "4")] [foo (printf "4")]
[x (impose-calling-convention/evaluation-order x)] [x (impose-calling-convention/evaluation-order x)]
;[foo (printf "5")] [foo (printf "5")]
;[foo (print-code x)] ;[foo (print-code x)]
[x (color-by-chaitin x)] [x (color-by-chaitin x)]
;[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 #t

6
src/libcompile.ss
View File

@ -261,6 +261,8 @@
(define-record nframe (vars live body)) (define-record nframe (vars live body))
(define-record nfvar (conf loc)) (define-record nfvar (conf loc))
(define-record ntcall (target value args mask size)) (define-record ntcall (target value args mask size))
(define-record asm-instr (op dst src))
(define-record disp (s0 s1))
(define mkfvar (define mkfvar
(let ([cache '()]) (let ([cache '()])
@ -476,7 +478,9 @@
[(set lhs rhs) `(set ,(E lhs) ,(E rhs))] [(set lhs rhs) `(set ,(E lhs) ,(E rhs))]
[(fvar idx) (string->symbol (format "fv.~a" idx))] [(fvar idx) (string->symbol (format "fv.~a" idx))]
[(locals vars body) `(locals ,(map E vars) ,(E body))] [(locals vars body) `(locals ,(map E vars) ,(E body))]
[(nframe vars live body) `(nframe ,(map E vars) ,(E body))] [(nframe vars live body) `(nframe [vars: ,(map E vars)]
[live: ,(map E live)]
,(E body))]
[else x])) [else x]))
(E x)) (E x))

21
src/libintelasm.ss
View File

@ -350,23 +350,17 @@
(IMM32*2 a1 a2 ac)))] (IMM32*2 a1 a2 ac)))]
[else (error 'CODErd "unhandled ~s" disp)]))))) [else (error 'CODErd "unhandled ~s" disp)])))))
;;; (define CODEdi
;;; (lambda (c disp n ac)
;;; (with-args disp
;;; (lambda (i r)
;;; (CODErri c '/0 r i (IMM32 n ac))))))
(define CODEdi (define CODEdi
(lambda (c disp n ac) (lambda (c /? disp n ac)
(with-args disp (with-args disp
(lambda (a1 a2) (lambda (a1 a2)
(cond (cond
[(and (reg? a1) (reg? a2)) [(and (reg? a1) (reg? a2))
(error 'CODEdi "unsupported1")] (error 'CODEdi "unsupported1 ~s" disp)]
[(and (imm? a1) (reg? a2)) [(and (imm? a1) (reg? a2))
(CODErri c '/0 a2 a1 (IMM32 n ac))] (CODErri c /? a2 a1 (IMM32 n ac))]
[(and (imm? a2) (reg? a1)) [(and (imm? a2) (reg? a1))
(CODErri c '/0 a1 a2 (IMM32 n ac))] (CODErri c /? a1 a2 (IMM32 n ac))]
[(and (imm? a1) (imm? a2)) [(and (imm? a1) (imm? a2))
(error 'CODEdi "unsupported2")] (error 'CODEdi "unsupported2")]
[else (error 'CODEdi "unhandled ~s" disp)]))))) [else (error 'CODEdi "unhandled ~s" disp)])))))
@ -439,7 +433,7 @@
[(imm? arg1) [(imm? arg1)
(cond (cond
[(reg? arg2) (CODEri ircode arg2 arg1 ac)] [(reg? arg2) (CODEri ircode arg2 arg1 ac)]
[(mem? arg2) (CODEdi imcode arg2 arg1 ac)] [(mem? arg2) (CODEdi imcode '/0 arg2 arg1 ac)]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)])] [else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)])]
[(reg? arg1) [(reg? arg1)
(cond (cond
@ -472,6 +466,7 @@
(add-instructions instr ac (add-instructions instr ac
[(ret) (CODE #xC3 ac)] [(ret) (CODE #xC3 ac)]
[(cltd) (CODE #x99 ac)] [(cltd) (CODE #x99 ac)]
; ircode imcode rrcode rmcode mrcode)
[(movl src dst) (instr/2 src dst ac #xB8 #xC7 #x89 #x89 #x8B)] [(movl src dst) (instr/2 src dst ac #xB8 #xC7 #x89 #x89 #x8B)]
[(movb src dst) [(movb src dst)
(cond (cond
@ -492,7 +487,7 @@
[(and (mem? src) (reg? dst)) [(and (mem? src) (reg? dst))
(CODErd #x03 dst src ac)] (CODErd #x03 dst src ac)]
[(and (imm? src) (mem? dst)) [(and (imm? src) (mem? dst))
(CODEdi #x81 dst src ac)] (CODEdi #x81 '/0 dst src ac)]
[else (error who "invalid ~s" instr)])] [else (error who "invalid ~s" instr)])]
[(subl src dst) [(subl src dst)
(cond (cond
@ -555,6 +550,8 @@
(CODE #x0D (IMM32 src ac))] (CODE #x0D (IMM32 src ac))]
[(and (imm? src) (reg? dst)) [(and (imm? src) (reg? dst))
(CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))] (CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))]
[(and (imm? src) (mem? dst))
(CODEdi #x81 '/1 dst src ac)]
[(and (reg? src) (reg? dst)) [(and (reg? src) (reg? dst))
(CODE #x09 (ModRM 3 src dst ac))] (CODE #x09 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst)) [(and (mem? src) (reg? dst))