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

(int x) is no longer emitted by the cogen. 

assembler handles (int x) and fixnums similarly.
This commit is contained in:
Abdulaziz Ghuloum 2007-01-09 09:24:07 +03:00
parent 63575db860
commit ffc5ef557c
4 changed files with 63 additions and 80 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.

84
src/libcompile.ss
View File

@ -323,7 +323,7 @@
(f (make-seq a (E (car d))) (cdr d))]))]
[(letrec)
(let ([bind* (cadr x)] [body (caddr x)])
(let ([lhs* (map car bind*)]
(let ([lhs* (map (lambda (x) (car x)) bind*)]
[rhs* (map cadr bind*)])
(let ([nlhs* (gen-fml* lhs*)])
(let ([expr (make-recbind nlhs* (map E rhs*) (E body ))])
@ -444,7 +444,6 @@
[base-idx: ,base-idx]
[arg-count: ,arg-count]
[live-mask: ,live-mask])]
[(tailcall-cp convention label arg-count)
`(tailcall-cp ,convention ,label ,arg-count)]
[(foreign-label x) `(foreign-label ,x)]
@ -452,6 +451,7 @@
[else (error 'unparse "invalid record ~s" x)]))
(E x))
(define (optimize-direct-calls x)
(define who 'optimize-direct-calls)
(define (make-conses ls)
@ -3093,7 +3093,11 @@
[(fixnum? off) (list 'disp (int off) val)]
[(register? off) (list 'disp off val)]
[else (error 'mem "invalid disp ~s" off)]))
(define (int x) (list 'int x))
(define (int x)
(cond
[(fixnum? x) x]
[else (error 'int "not a fixnum ~s" x)]))
(define (obj x) (list 'obj x))
(define (byte x) (list 'byte x))
(define (byte-vector x) (list 'byte-vector x))
@ -3108,6 +3112,7 @@
(define (xorl src targ) (list 'xorl src targ))
(define (andl src targ) (list 'andl src targ))
(define (movl src targ) (list 'movl src targ))
(define (leal src targ) (list 'leal src targ))
(define (movb src targ) (list 'movb src targ))
(define (addl src targ) (list 'addl src targ))
(define (imull src targ) (list 'imull src targ))
@ -3178,6 +3183,16 @@
(mem (fx- disp-symbol-system-value symbol-tag)
(obj op)))
(define-syntax car
(syntax-rules ()
[(_ x)
(let ([t x])
(if (pair? t)
(#%car t)
(error '(car x) "~s is not a pair" t)))]))
(define (generate-code x)
(define who 'generate-code)
(define (rp-label x L_multi)
@ -3871,9 +3886,8 @@
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl eax (mem disp-car apr))
(movl apr eax)
(movl ebx (mem disp-cdr apr))
(addl (int pair-tag) eax)
(leal (mem pair-tag apr) eax)
(addl (int (align pair-size)) apr)
ac)]
[(list)
@ -4479,60 +4493,6 @@
(NonTail body ac)]
[(call-cp)
(handle-call-cp x ac NonTail)]
#;[(call-cp call-convention direct-label save-cp? rp-convention offset size mask)
(let ([L_CALL (unique-label)])
(case call-convention
[(normal)
(list* (addl (int (frame-adjustment offset)) fpr)
(movl (int (argc-convention size)) eax)
(jmp L_CALL)
; NEW FRAME
`(byte-vector ,mask)
`(int ,(fx* offset wordsize))
`(current-frame-offset)
(rp-label rp-convention)
`(byte 0) ; padding for indirect calls only
`(byte 0) ; direct calls are ok
L_CALL
(indirect-cpr-call)
(if save-cp? (movl (mem 0 fpr) cpr) '(nop))
(subl (int (frame-adjustment offset)) fpr)
ac)]
[(direct)
(list* (addl (int (frame-adjustment offset)) fpr)
;(movl (int (argc-convention size)) eax)
(jmp L_CALL)
; NEW FRAME
`(byte-vector ,mask)
`(int ,(fx* offset wordsize))
`(current-frame-offset)
(rp-label rp-convention)
;;; no padding for direct calls
L_CALL
(call (label direct-label))
(if save-cp? (movl (mem 0 fpr) cpr) '(nop))
(subl (int (frame-adjustment offset)) fpr)
ac)]
[(foreign)
(list* (addl (int (frame-adjustment offset)) fpr)
(movl (int (argc-convention size)) eax)
(movl '(foreign-label "ik_foreign_call") ebx)
(jmp L_CALL)
; NEW FRAME
(byte-vector mask)
`(int ,(fx* offset wordsize))
`(current-frame-offset)
(rp-label rp-convention) ; should be 0, since C has 1 rv
'(byte 0)
'(byte 0)
'(byte 0)
L_CALL
(call ebx)
(if save-cp? (movl (mem 0 fpr) cpr) '(nop))
(subl (int (frame-adjustment offset)) fpr)
ac)]
[else
(error who "invalid convention ~s for call-cp" call-convention)]))]
[else (error 'NonTail "invalid expression ~s" x)]))
(define (Pred x Lt Lf ac)
(record-case x
@ -4791,9 +4751,9 @@
(movl (primref-loc 'do-vararg-overflow) cpr) ; load handler
(jmp L_CALL) ; go to overflow handler
; NEW FRAME
(int 0) ; if the framesize=0, then the framesize is dynamic
'(int 0) ; if the framesize=0, then the framesize is dynamic
'(current-frame-offset)
(int 0) ; multiarg rp
'(int 0) ; multiarg rp
(byte 0)
(byte 0)
L_CALL
@ -4985,7 +4945,7 @@
(jmp (label L_cwv_call))
; MV NEW FRAME
(byte-vector '#(#b110))
(int (fx* wordsize 3))
`(int ,(fx* wordsize 3))
'(current-frame-offset)
(label-address L_cwv_multi_rp)
(byte 0)

46
src/libintelasm.ss
View File

@ -38,6 +38,13 @@
(let ()
(define-syntax car
(syntax-rules ()
[(_ x)
(let ([t x])
(if (pair? t)
(#%car t)
(error '(car x) "~s is not a pair" t)))]))
(define fold
(lambda (f init ls)
@ -153,13 +160,14 @@
(define mem?
(lambda (x)
(and (list? x)
(fx= (length x) 3)
(and (pair? x)
;(fx= (length x) 3)
(eq? (car x) 'disp)
(or (imm? (cadr x))
(reg? (cadr x)))
(or (imm? (caddr x))
(reg? (caddr x))))))
;(or (imm? (cadr x))
; (reg? (cadr x)))
;(or (imm? (caddr x))
; (reg? (caddr x)))
)))
(define small-disp?
(lambda (x)
@ -186,11 +194,17 @@
(cons (byte #x24) ac)
ac))))
(define (int-val x)
(cond
[(fixnum? x) x]
[(and (pair? x) (eq? (car x) 'int)) (cadr x)]
[else (error 'int-val "not a fixnum ~s" x)]))
(define IMM32
(lambda (n ac)
(cond
[(int? n)
(let ([n (cadr n)])
(let ([n (int-val n)])
(list* (byte n)
(byte (fxsra n 8))
(byte (fxsra n 16))
@ -215,7 +229,7 @@
(lambda (n ac)
(cond
[(int? n)
(let ([n (cadr n)])
(let ([n (int-val n)])
(list* (byte n) ac))]
[else (error 'IMM8 "invalid ~s" n)])))
@ -235,7 +249,7 @@
(define imm8?
(lambda (x)
(and (int? x) (byte? (cadr x)))))
(and (int? x) (byte? (int-val x)))))
(define label?
(lambda (x)
@ -265,7 +279,9 @@
(define int?
(lambda (x)
(and (pair? x) (eq? (car x) 'int))))
(or
(fixnum? x)
(and (pair? x) (eq? (car x) 'int)))))
(define obj?
(lambda (x)
@ -319,7 +335,7 @@
(lambda (i1 i2 ac)
(cond
[(and (int? i1) (obj? i2))
(let ([d (cadr i1)] [v (cadr i2)])
(let ([d (int-val i1)] [v (cadr i2)])
(cons (reloc-word+ v d) ac))]
[else (error 'assemble "IMM32*2 ~s ~s" i1 i2)])))
@ -554,6 +570,11 @@
[(and (mem? src) (reg? dst))
(CODErd #x33 dst src ac)]
[else (error who "invalid ~s" instr)])]
[(leal src dst)
(cond
[(and (mem? src) (reg? dst))
(CODErd #x8D dst src ac)]
[else (error who "invalid ~s" instr)])]
[(cmpl src dst)
(cond
[(and (imm8? src) (reg? dst))
@ -690,6 +711,7 @@
[(current-frame-offset)
(cons '(current-frame-offset) ac)]
[(nop) ac]
))
@ -886,7 +908,7 @@
(define list*->code*
(lambda (thunk?-label ls*)
(let ([closure-size* (map car ls*)]
(let ([closure-size* (map (lambda (x) (car x)) ls*)]
[ls* (map cdr ls*)])
(let* ([ls* (map convert-instructions ls*)]
[ls* (map optimize-local-jumps ls*)])

13
src/makefile.ss
View File

@ -259,13 +259,14 @@
(let ()
#;(let ()
(define (compile-all who)
(for-each
(lambda (x)
(when (eq? who (caddr x))
(compile-library (car x) (cadr x))))
scheme-library-files))
(define (time x) x)
(fork
(lambda (pid)
(time (compile-all 'p1))
@ -275,11 +276,11 @@
(time (compile-all 'p0))
(exit))))
;;; (for-each
;;; (lambda (x)
;;; (when (cadr x)
;;; (compile-library (car x) (cadr x))))
;;; scheme-library-files)
(for-each
(lambda (x)
(when (cadr x)
(compile-library (car x) (cadr x))))
scheme-library-files)
(define (join s ls)
(cond