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

* adding some asm tests in asm-tests.ss

This commit is contained in:
Abdulaziz Ghuloum 2007-02-13 05:08:48 -05:00
parent a123a77bbc
commit 297e47db32
8 changed files with 139 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bin/Makefile
View File

@ -1,6 +1,6 @@
CFLAGS = -I/opt/local/include -Wall -DNDEBUG -O3 #-fomit-frame-pointer #CFLAGS = -I/opt/local/include -Wall -DNDEBUG -O3 #-fomit-frame-pointer
#CFLAGS = -I/opt/local/include -Wall -g CFLAGS = -I/opt/local/include -Wall -g
LDFLAGS = -L/opt/local/lib -g -ldl -lgmp #-rdynamic LDFLAGS = -L/opt/local/lib -g -ldl -lgmp #-rdynamic
CC = gcc CC = gcc
all: ikarus all: ikarus

BIN
bin/ikarus
View File

Binary file not shown.

57
src/asm-tests.ss Normal file
View File

@ -0,0 +1,57 @@
(define (asm-test res ls)
(printf "Testing:\n")
(for-each (lambda (x)
(printf " ~s\n" x))
ls)
(let ([code
(car (#%list*->code*
(lambda (x) #f)
`([0 (label ,(gensym)) . ,ls])))])
(let ([proc (#%$code->closure code)])
(let ([v (proc)])
(unless (equal? v res)
(printf "failed!\n")
(error 'test-asm "expected ~s, got ~s" res v)))))
(printf "OK\n\n"))
(asm-test 12
'([movl 48 %eax]
[ret]))
(asm-test 12
'([movl 16 %eax]
[orl 32 %eax]
[ret]))
(asm-test 12
'([movl 48 %eax]
[movl %eax (disp -4 %esp)]
[movl 0 %eax]
[movl (disp -4 %esp) %eax]
[ret]))
(asm-test 12
'([movl 16 %eax]
[movl %eax (disp -4 %esp)]
[addl 32 (disp -4 %esp)]
[movl (disp -4 %esp) %eax]
[ret]))
(asm-test 1
'([movl 1 (disp -4 %esp)]
[sall 2 (disp -4 %esp)]
[movl (disp -4 %esp) %eax]
[ret]))
(asm-test 1
'([movl 32 (disp -4 %esp)]
[sarl 3 (disp -4 %esp)]
[movl (disp -4 %esp) %eax]
[ret]))
(printf "Happy Happy Joy Joy\n")
(exit)

BIN
src/ikarus.boot
View File

Binary file not shown.

113
src/libaltcogen.ss
View File

@ -143,6 +143,7 @@
[$fx+ v] [$fx+ v]
[$fxadd1 v] [$fxadd1 v]
[$fxsub1 v]
[$fxsll v] [$fxsll v]
[$fxsra v] [$fxsra v]
[$fxlogand v] [$fxlogand v]
@ -595,10 +596,10 @@
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
[(_ ([lhs* rhs*] ...) b b* ...) [(_ ([lhs* rhs*] ...) b b* ...)
#'(let ([lhs* (unique-var 'lhs*)] ...) #'(let ([ls (list rhs* ...)])
(make-bind (list lhs* ...) (let ([lhs* (unique-var 'lhs*)] ...)
(list rhs* ...) (make-bind (list lhs* ...) ls
b b* ...))]))) b b* ...)))])))
(define (Effect x) (define (Effect x)
(define (mem-assign v x i) (define (mem-assign v x i)
(tbind ([q v]) (tbind ([q v])
@ -640,7 +641,7 @@
[($set-symbol-value!) [($set-symbol-value!)
(let ([x (Value (car arg*))] [v (Value (cadr arg*))]) (let ([x (Value (car arg*))] [v (Value (cadr arg*))])
(mem-assign v x (mem-assign v x
(- disp-symbol-value symbol-tag)))] (- disp-symbol-value symbol-tag)))]
[($vector-set! $record-set!) [($vector-set! $record-set!)
(let ([x (Value (car arg*))] (let ([x (Value (car arg*))]
[i (cadr arg*)] [i (cadr arg*)]
@ -718,7 +719,7 @@
(sec-tag-test (Value (car arg*)) (sec-tag-test (Value (car arg*))
vector-mask vector-tag fixnum-mask fixnum-tag)] vector-mask vector-tag fixnum-mask fixnum-tag)]
[($record?) [($record?)
(sec-tag-test (Value (car arg*)) (sec-tag-test (Value (car arg*))
vector-mask vector-tag vector-mask vector-tag)] vector-mask vector-tag vector-mask vector-tag)]
[(input-port?) [(input-port?)
(sec-tag-test (Value (car arg*)) (sec-tag-test (Value (car arg*))
@ -737,9 +738,6 @@
(prm 'mref t (K (- vector-tag))) (prm 'mref t (K (- vector-tag)))
(Value (cadr arg*))) (Value (cadr arg*)))
(make-constant #f)))] (make-constant #f)))]
[(output-port?)
(sec-tag-test (Value (car arg*))
vector-mask vector-tag #f output-port-tag)]
[(immediate?) [(immediate?)
(tbind ([t (Value (car arg*))]) (tbind ([t (Value (car arg*))])
(make-conditional (make-conditional
@ -795,7 +793,7 @@
[($cdr) [($cdr)
(prm 'mref (Value (car arg*)) (K (- disp-cdr pair-tag)))] (prm 'mref (Value (car arg*)) (K (- disp-cdr pair-tag)))]
[(primitive-ref) [(primitive-ref)
(prm 'mref (Value (car arg*)) (prm 'mref (Value (car arg*))
(K (- disp-symbol-system-value symbol-tag)))] (K (- disp-symbol-system-value symbol-tag)))]
[($make-cp) [($make-cp)
(let ([label (car arg*)] [len (cadr arg*)]) (let ([label (car arg*)] [len (cadr arg*)])
@ -814,28 +812,29 @@
[else (err x)]))] [else (err x)]))]
[($record) [($record)
(let ([rtd (car arg*)] [v* (map Value (cdr arg*))]) (let ([rtd (car arg*)] [v* (map Value (cdr arg*))])
(unless (constant? rtd) (tbind ([rtd (Value rtd)])
(error who "invalid rtd ~s for $record" rtd)) (let ([t* (map (lambda (x) (unique-var 'v)) v*)])
(let ([t* (map (lambda (x) (unique-var 'v)) v*)]) (make-bind t* v*
(make-bind t* v* (tbind ([t (prm 'alloc
(tbind ([t (prm 'alloc (K (align
(K (+ disp-record-data (+ disp-record-data
(* (length v*) wordsize))) (* (length v*) wordsize))))
(K vector-tag))]) (K vector-tag))])
(seq* (seq*
(prm 'mset! t (prm 'mset! t
(K (- disp-record-rtd vector-tag)) (K (- disp-record-rtd vector-tag))
(Value rtd)) rtd)
(let f ([t* t*] [i (- disp-record-data vector-tag)]) (let f ([t* t*]
(cond [i (- disp-record-data vector-tag)])
[(null? t*) t] (cond
[else [(null? t*) t]
(make-seq [else
(prm 'mset! t (K i) (car t*)) (make-seq
(f (cdr t*) (+ i wordsize)))])))))))] (prm 'mset! t (K i) (car t*))
(f (cdr t*) (+ i wordsize)))]))))))))]
[($make-record) [($make-record)
(let ([rtd (car arg*)] [len (cadr arg*)]) (let ([rtd (car arg*)] [len (cadr arg*)])
(tbind ([rtd rtd]) (tbind ([rtd (Value rtd)])
(record-case len (record-case len
[(constant i) [(constant i)
(unless (fixnum? i) (unless (fixnum? i)
@ -845,20 +844,20 @@
disp-record-data))) disp-record-data)))
(K vector-tag))]) (K vector-tag))])
(seq* (seq*
(prm 'mset! t (prm 'mset! t
(K (- disp-record-rtd vector-tag)) (K (- disp-record-rtd vector-tag))
rtd) rtd)
t))] t))]
[else [else
(tbind ([len (tbind ([ln
(prm 'sll (prm 'sll
(prm 'sra (prm 'sra
(prm 'int+ (Value len) (prm 'int+ (Value len)
(K (sub1 (K (+ disp-record-data
object-alignment))) (sub1 object-alignment))))
(K align-shift)) (K align-shift))
(K align-shift))]) (K align-shift))])
(tbind ([t (prm 'alloc len (K vector-tag))]) (tbind ([t (prm 'alloc ln (K vector-tag))])
(seq* (seq*
(prm 'mset! t (prm 'mset! t
(K (- disp-record-rtd vector-tag)) (K (- disp-record-rtd vector-tag))
@ -969,17 +968,15 @@
[(constant i) [(constant i)
(unless (fixnum? i) (err x)) (unless (fixnum? i) (err x))
(make-primcall 'mref (make-primcall 'mref
(list (Value a0) (list (Value a0)
(make-constant (K (+ (- disp-vector-data vector-tag)
(+ (- disp-vector-data vector-tag) (* i wordsize)))))]
(* i wordsize)))))]
[else [else
(make-primcall 'mref (make-primcall 'mref
(list (make-primcall 'int+ (list (make-primcall 'int+
(list (Value a0) (list (Value a0)
(Value a1))) (Value a1)))
(make-constant (K (- disp-vector-data vector-tag))))]))]
(- disp-vector-data vector-tag))))]))]
[($closure-code) [($closure-code)
(prm 'int+ (prm 'int+
(prm 'mref (prm 'mref
@ -1029,6 +1026,9 @@
(Program x)) (Program x))
(define parameter-registers '(%edi)) (define parameter-registers '(%edi))
(define return-value-register '%eax) (define return-value-register '%eax)
(define cp-register '%edi) (define cp-register '%edi)
@ -1117,6 +1117,18 @@
(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)))))
(define (alloc-check size)
(E (make-conditional ;;; PCB ALLOC-REDLINE
(make-primcall '<=
(list (make-primcall 'int+ (list apr size))
(make-primcall 'mref (list pcr (make-constant 4)))))
(make-primcall 'nop '())
(make-funcall
(make-primcall 'mref
(list (make-constant (make-object 'do-overflow))
(make-constant (- disp-symbol-system-value
symbol-tag))))
(list size)))))
;;; impose value ;;; impose value
(define (V d x) (define (V d x)
(record-case x (record-case x
@ -1133,13 +1145,15 @@
[(alloc) [(alloc)
(S (car rands) (S (car rands)
(lambda (size) (lambda (size)
(S (cadr rands) (make-seq
(lambda (tag) (alloc-check size)
(make-seq (S (cadr rands)
(make-seq (lambda (tag)
(make-set d apr) (make-seq
(make-asm-instr 'logor d tag)) (make-seq
(make-asm-instr 'int+ apr size))))))] (make-set d apr)
(make-asm-instr 'logor d tag))
(make-asm-instr 'int+ apr size)))))))]
[(mref) [(mref)
(S* rands (S* rands
(lambda (rands) (lambda (rands)
@ -2298,9 +2312,9 @@
;[foo (print-code x)] ;[foo (print-code x)]
[x (specify-representation x)] [x (specify-representation x)]
[foo (printf "4")] [foo (printf "4")]
;[foo (print-code x)]
[x (impose-calling-convention/evaluation-order x)] [x (impose-calling-convention/evaluation-order x)]
[foo (printf "5")] [foo (printf "5")]
;[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)]
@ -2315,6 +2329,7 @@
ls))) ls)))
ls)) ls))
#|module alt-cogen|#) #|module alt-cogen|#)

4
src/libintelasm.ss
View File

@ -501,8 +501,6 @@
[(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))
; (printf "addl ~s ~s\n" src dst)
; (printf "=> ~s\n" ((CODE/r #x81 '/0) dst (IMM32 src '())))
((CODE/r #x81 '/0) dst (IMM32 src ac))] ((CODE/r #x81 '/0) dst (IMM32 src ac))]
[(and (reg? src) (mem? dst)) [(and (reg? src) (mem? dst))
(CODErd #x81 src dst ac)] (CODErd #x81 src dst ac)]
@ -951,4 +949,6 @@
; (car (list*->code* (list ls))))) ; (car (list*->code* (list ls)))))
(primitive-set! 'list*->code* list*->code*) (primitive-set! 'list*->code* list*->code*)
) )

20
src/librecord.ss
View File

@ -48,15 +48,21 @@
(lambda (rtd symbol) (lambda (rtd symbol)
($record-set! rtd 4 symbol))) ($record-set! rtd 4 symbol)))
; (define make-rtd
; (lambda (name fields printer symbol)
; (let ([rtd ($make-record $base-rtd 5)])
; ($record-set! rtd 0 name)
; ($record-set! rtd 1 (length fields))
; ($record-set! rtd 2 fields)
; ($record-set! rtd 3 printer)
; ($record-set! rtd 4 symbol)
; rtd)))
(define make-rtd (define make-rtd
(lambda (name fields printer symbol) (lambda (name fields printer symbol)
(let ([rtd ($make-record $base-rtd 5)]) ($record $base-rtd name (length fields) fields printer symbol)))
($record-set! rtd 0 name)
($record-set! rtd 1 (length fields))
($record-set! rtd 2 fields)
($record-set! rtd 3 printer)
($record-set! rtd 4 symbol)
rtd)))
(define verify-field (define verify-field
(lambda (x) (lambda (x)

2
src/tests/tests-5.2-req.scm
View File

@ -3,7 +3,7 @@
(add-tests-with-string-output "overflow" (add-tests-with-string-output "overflow"
[(letrec ([f [(letrec ([f
(lambda (i) (lambda (i)
(when (fx<= i 1000) (when (fx<= i 10000)
(let ([x (make-list 1000)]) (let ([x (make-list 1000)])
(f (fxadd1 i)))))]) (f (fxadd1 i)))))])
(f 0) (f 0)