diff --git a/bin/Makefile b/bin/Makefile index 9f6baf6..0f39307 100644 --- a/bin/Makefile +++ b/bin/Makefile @@ -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 diff --git a/bin/ikarus b/bin/ikarus index 2148ad4..650b888 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/src/asm-tests.ss b/src/asm-tests.ss new file mode 100644 index 0000000..26218af --- /dev/null +++ b/src/asm-tests.ss @@ -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) diff --git a/src/ikarus.boot b/src/ikarus.boot index f50f841..3cf7f21 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index bec930e..acf1920 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -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]) @@ -640,7 +641,7 @@ [($set-symbol-value!) (let ([x (Value (car arg*))] [v (Value (cadr arg*))]) (mem-assign v x - (- disp-symbol-value symbol-tag)))] + (- disp-symbol-value symbol-tag)))] [($vector-set! $record-set!) (let ([x (Value (car arg*))] [i (cadr arg*)] @@ -718,7 +719,7 @@ (sec-tag-test (Value (car arg*)) vector-mask vector-tag fixnum-mask fixnum-tag)] [($record?) - (sec-tag-test (Value (car arg*)) + (sec-tag-test (Value (car arg*)) vector-mask vector-tag vector-mask vector-tag)] [(input-port?) (sec-tag-test (Value (car arg*)) @@ -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 @@ -795,7 +793,7 @@ [($cdr) (prm 'mref (Value (car arg*)) (K (- disp-cdr pair-tag)))] [(primitive-ref) - (prm 'mref (Value (car arg*)) + (prm 'mref (Value (car arg*)) (K (- disp-symbol-system-value symbol-tag)))] [($make-cp) (let ([label (car arg*)] [len (cadr arg*)]) @@ -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)) - (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 vector-tag))]) - (seq* - (prm 'mset! t - (K (- disp-record-rtd vector-tag)) - (Value 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)))])))))))] + (tbind ([rtd (Value rtd)]) + (let ([t* (map (lambda (x) (unique-var 'v)) v*)]) + (make-bind t* v* + (tbind ([t (prm 'alloc + (K (align + (+ disp-record-data + (* (length v*) wordsize)))) + (K vector-tag))]) + (seq* + (prm 'mset! t + (K (- disp-record-rtd 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)))]))))))))] [($make-record) (let ([rtd (car arg*)] [len (cadr arg*)]) - (tbind ([rtd rtd]) + (tbind ([rtd (Value rtd)]) (record-case len [(constant i) (unless (fixnum? i) @@ -845,20 +844,20 @@ disp-record-data))) (K vector-tag))]) (seq* - (prm 'mset! t + (prm 'mset! t (K (- disp-record-rtd vector-tag)) 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)) @@ -969,17 +968,15 @@ [(constant i) (unless (fixnum? i) (err x)) (make-primcall 'mref - (list (Value a0) - (make-constant - (+ (- disp-vector-data vector-tag) - (* i wordsize)))))] + (list (Value a0) + (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) - (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-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)))))))] [(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|#) diff --git a/src/libintelasm.ss b/src/libintelasm.ss index c0e364a..d543a1a 100644 --- a/src/libintelasm.ss +++ b/src/libintelasm.ss @@ -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*) + ) + diff --git a/src/librecord.ss b/src/librecord.ss index eb971f8..17f7a92 100644 --- a/src/librecord.ss +++ b/src/librecord.ss @@ -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) diff --git a/src/tests/tests-5.2-req.scm b/src/tests/tests-5.2-req.scm index 03283df..edf8123 100644 --- a/src/tests/tests-5.2-req.scm +++ b/src/tests/tests-5.2-req.scm @@ -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)