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 -g
#CFLAGS = -I/opt/local/include -Wall -DNDEBUG -O3 #-fomit-frame-pointer
CFLAGS = -I/opt/local/include -Wall -g
LDFLAGS = -L/opt/local/lib -g -ldl -lgmp #-rdynamic
CC = gcc
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.

65
src/libaltcogen.ss
View File

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

4
src/libintelasm.ss
View File

@ -501,8 +501,6 @@
[(and (mem? src) (reg? dst))
(CODErd #x03 dst src ac)]
[(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))]
[(and (reg? src) (mem? dst))
(CODErd #x81 src dst ac)]
@ -951,4 +949,6 @@
; (car (list*->code* (list ls)))))
(primitive-set! 'list*->code* list*->code*)
)

20
src/librecord.ss
View File

@ -48,15 +48,21 @@
(lambda (rtd 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
(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)))
($record $base-rtd name (length fields) fields printer symbol)))
(define verify-field
(lambda (x)

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

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