diff --git a/src/geninstr/gen.pl b/src/geninstr/gen.pl index 1543036..dc00356 100755 --- a/src/geninstr/gen.pl +++ b/src/geninstr/gen.pl @@ -48,7 +48,7 @@ sub gen3{ } } -gen1 "addl \$27, 12(r1)\n"; +gen1 "addl \$0x12345678, 7(r1)\n"; #gen1 "movb \$0, 4(r1)\n"; #gen1 "movb -2(r1), %ah\n"; diff --git a/src/geninstr/tmp.s b/src/geninstr/tmp.s index d828601..2824d53 100644 --- a/src/geninstr/tmp.s +++ b/src/geninstr/tmp.s @@ -1,9 +1,9 @@ .text -addl $27, 12(%eax) -addl $27, 12(%ecx) -addl $27, 12(%edx) -addl $27, 12(%ebx) -addl $27, 12(%esp) -addl $27, 12(%ebp) -addl $27, 12(%esi) -addl $27, 12(%edi) +addl $0x12345678, 7(%eax) +addl $0x12345678, 7(%ecx) +addl $0x12345678, 7(%edx) +addl $0x12345678, 7(%ebx) +addl $0x12345678, 7(%esp) +addl $0x12345678, 7(%ebp) +addl $0x12345678, 7(%esi) +addl $0x12345678, 7(%edi) diff --git a/src/ikarus.boot b/src/ikarus.boot index fdf2144..f50f841 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index 4a18d9a..bec930e 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -124,7 +124,7 @@ [vector? p] [null? p] [eof-object? p] - ;[eof-object v] + [eof-object v] [procedure? p] [symbol? p] [boolean? p] @@ -140,6 +140,9 @@ [cons v] [$car v] [$cdr v] + + [$fx+ v] + [$fxadd1 v] [$fxsll v] [$fxsra v] [$fxlogand v] @@ -152,14 +155,23 @@ [$fx= p] - ;[$char<= p] - ;[$char= p] - ;[$char->fixnum v] + [$char<= p] + [$char= p] + [$char->fixnum v] [$vector-ref v] [$vector-set! e] [$set-symbol-value! e] + + [$record v] + [$record/rtd? p] + [$record-ref v] + [$record-set! e] + [$record? p] + [$record-rtd v] + [$make-record v] + ;;; ports [output-port? p] [input-port? p] @@ -184,6 +196,7 @@ list list* not car cdr + top-level-value )) (define (must-open-code? x) (and (assq x core-prims) #t)) @@ -556,6 +569,7 @@ (define who 'specify-representation) ;;; (define fixnum-scale 4) + (define fixnum-shift 2) (define fixnum-tag 0) (define fixnum-mask 3) (define pcb-dirty-vector-offset 28) @@ -627,7 +641,7 @@ (let ([x (Value (car arg*))] [v (Value (cadr arg*))]) (mem-assign v x (- disp-symbol-value symbol-tag)))] - [($vector-set!) + [($vector-set! $record-set!) (let ([x (Value (car arg*))] [i (cadr arg*)] [v (Value (caddr arg*))]) @@ -652,7 +666,7 @@ (error who "appcall not supported yet")] [(mvcall rator x) (make-mvcall (Value rator) (Clambda x Effect))] - [else (error who "invalid pred expr ~s" x)])) + [else (error who "invalid effect expr ~s" x)])) ;;; (define (tag-test x mask tag) (if mask @@ -703,6 +717,26 @@ [(vector?) (sec-tag-test (Value (car arg*)) vector-mask vector-tag fixnum-mask fixnum-tag)] + [($record?) + (sec-tag-test (Value (car arg*)) + vector-mask vector-tag vector-mask vector-tag)] + [(input-port?) + (sec-tag-test (Value (car arg*)) + vector-mask vector-tag #f input-port-tag)] + [(output-port?) + (sec-tag-test (Value (car arg*)) + vector-mask vector-tag #f output-port-tag)] + [(port?) + (sec-tag-test (Value (car arg*)) + vector-mask vector-tag port-mask port-tag)] + [($record/rtd?) + (tbind ([t (Value (car arg*))]) + (make-conditional + (tag-test t vector-mask vector-tag) + (prm '= + (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)] @@ -718,15 +752,15 @@ (prm 'mref pcr (K 12)) ;;; PCB FRAME-BASE (K (- wordsize))) fpr)] - [($fx=) + [($fx= $char=) (prm '= (Value (car arg*)) (Value (cadr arg*)))] - [($fx<) + [($fx< $char<) (prm '< (Value (car arg*)) (Value (cadr arg*)))] - [($fx>) + [($fx> $char>) (prm '> (Value (car arg*)) (Value (cadr arg*)))] - [($fx<=) + [($fx<= $char<=) (prm '<= (Value (car arg*)) (Value (cadr arg*)))] - [($fx>=) + [($fx>= $char>=) (prm '>= (Value (car arg*)) (Value (cadr arg*)))] [else (error who "pred prim ~a not supported" op)])] [(mvcall rator x) @@ -755,6 +789,7 @@ [(primcall op arg*) (case op [(void) (K void-object)] + [(eof-object) (K eof)] [($car) (prm 'mref (Value (car arg*)) (K (- disp-car pair-tag)))] [($cdr) @@ -777,6 +812,61 @@ (Value label)) t))] [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)))])))))))] + [($make-record) + (let ([rtd (car arg*)] [len (cadr arg*)]) + (tbind ([rtd rtd]) + (record-case len + [(constant i) + (unless (fixnum? i) + (error who "invalid make-rec ~s" len)) + (tbind ([t (prm 'alloc + (K (align (+ (* i wordsize) + disp-record-data))) + (K vector-tag))]) + (seq* + (prm 'mset! t + (K (- disp-record-rtd vector-tag)) + rtd) + t))] + [else + (tbind ([len + (prm 'sll + (prm 'sra + (prm 'int+ (Value len) + (K (sub1 + object-alignment))) + (K align-shift)) + (K align-shift))]) + (tbind ([t (prm 'alloc len (K vector-tag))]) + (seq* + (prm 'mset! t + (K (- disp-record-rtd vector-tag)) + rtd) + t)))])))] + [($record-rtd) + (prm 'mref (Value (car arg*)) + (K (- disp-record-rtd vector-tag)))] [(cons) (tbind ([a (Value (car arg*))] [d (Value (cadr arg*))]) @@ -785,6 +875,12 @@ (prm 'mset! t (K (- disp-car pair-tag)) a) (prm 'mset! t (K (- disp-cdr pair-tag)) d) t)))] + [($fxadd1) + (prm 'int+ (Value (car arg*)) (K (* 1 fixnum-scale)))] + [($fxsub1) + (prm 'int+ (Value (car arg*)) (K (* -1 fixnum-scale)))] + [($fx+) + (prm 'int+ (Value (car arg*)) (Value (cadr arg*)))] [($fxmodulo) (tbind ([a (Value (car arg*))] [b (Value (cadr arg*))]) @@ -811,6 +907,10 @@ [else (error who "nonconst arg to fxsra ~s" c)]))] [($fxlogand) (prm 'logand (Value (car arg*)) (Value (cadr arg*)))] + [($char->fixnum) + (prm 'sra + (Value (car arg*)) + (K (- char-shift fixnum-shift)))] [($current-frame) ;; PCB NEXT-CONTINUATION (prm 'mref pcr (K 20))] [($seal-frame-and-call) @@ -863,7 +963,7 @@ (K (+ (- disp-closure-data closure-tag) (* i wordsize))))] [else (err x)]))] - [($vector-ref) + [($vector-ref $record-ref) (let ([a0 (car arg*)] [a1 (cadr arg*)]) (record-case a1 [(constant i) diff --git a/src/libintelasm.ss b/src/libintelasm.ss index 5cd7d89..c0e364a 100644 --- a/src/libintelasm.ss +++ b/src/libintelasm.ss @@ -365,12 +365,41 @@ (error 'CODEdi "unsupported2")] [else (error 'CODEdi "unhandled ~s" disp)]))))) +; 81 /0 id ADD r/m32,imm32 Valid Valid Add imm32 to +(define (CODE/r c /?) + (lambda (dst ac) + (cond + [(mem? dst) + (with-args dst + (lambda (a0 a1) + (cond + [(and (imm8? a0) (reg? a1)) + (CODE c (ModRM 1 /? a1 (IMM8 a0 ac)))] + [else (error 'CODE/r "unhandled ~s ~s" a0 a1)])))] + [else (error 'CODE/r "unhandled ~s" dst)]))) + +(define CODEid + (lambda (c /? n disp ac) + (with-args disp + (lambda (a1 a2) + (cond + [(and (reg? a1) (reg? a2)) + (error 'CODEid "unsupported1 ~s" disp)] + [(and (imm? a1) (reg? a2)) + (error 'CODEid "unsupported2") + (CODErri c /? a2 a1 (IMM32 n ac))] + [(and (imm? a2) (reg? a1)) + (error 'CODEid "unsupported3") + (CODErri c /? a1 a2 (IMM32 n ac))] + [(and (imm? a1) (imm? a2)) + (error 'CODEid "unsupported4")] + [else (error 'CODEid "unhandled ~s" disp)]))))) (define CODEdi8 - (lambda (c disp n ac) + (lambda (c /? disp n ac) (with-args disp (lambda (i r) - (CODErri c '/0 r i (IMM8 n ac)))))) + (CODErri c /? r i (IMM8 n ac)))))) (define *cogen* (gensym "*cogen*")) @@ -411,21 +440,6 @@ (error 'convert-instruction "incorrect args in ~s" a))])))] [else (error 'convert-instruction "unknown instruction in ~s" a)])) -;;; instr/null is for 1-byte instructions that take no arguments -;(define (instr/null code ac) -; (cons code ac)) - -;(define (instr/ir arg1 arg2 ac ircode) -; (CODE+r ircode arg2 (IMM32 arg1 ac))) -; -;(define (instr/im arg1 arg2 ac imcode) -; (error 'instr/im "not implemented")) -; -;(define (instr/rr arg1 arg2 ac rrcode) -; (CODErr rrcode arg1 arg2 ac)) -; -;(define (instr/rm arg1 arg2 ac rmcode) -; (CODErd rmcode arg1 arg2 ac)) (define (instr/2 arg1 arg2 ac ircode imcode rrcode rmcode mrcode) @@ -470,7 +484,7 @@ [(movl src dst) (instr/2 src dst ac #xB8 #xC7 #x89 #x89 #x8B)] [(movb src dst) (cond - [(and (imm8? src) (mem? dst)) (CODEdi8 #xC6 dst src ac)] + [(and (imm8? src) (mem? dst)) (CODEdi8 #xC6 '/0 dst src ac)] [(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)] [(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)] [else (error who "invalid ~s" instr)])] @@ -487,7 +501,11 @@ [(and (mem? src) (reg? dst)) (CODErd #x03 dst src ac)] [(and (imm? src) (mem? dst)) - (CODEdi #x81 '/0 dst src ac)] + ; (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)] [else (error who "invalid ~s" instr)])] [(subl src dst) (cond @@ -508,6 +526,10 @@ (CODE #xD1 (ModRM 3 '/4 dst ac))] [(and (imm8? src) (reg? dst)) (CODE #xC1 (ModRM 3 '/4 dst (IMM8 src ac)))] + [(and (imm8? src) (mem? dst)) + (printf "sall ~s ~s\n" src dst) + (printf "=> ~s\n" ((CODE/r #xC1 '/4) dst (IMM8 src '()))) + ((CODE/r #xC1 '/4) dst (IMM8 src ac))] [(and (eq? src '%cl) (reg? dst)) (CODE #xD3 (ModRM 3 '/4 dst ac))] [else (error who "invalid ~s" instr)])] @@ -526,6 +548,10 @@ (CODE #xD1 (ModRM 3 '/7 dst ac))] [(and (imm8? src) (reg? dst)) (CODE #xC1 (ModRM 3 '/7 dst (IMM8 src ac)))] + [(and (imm8? src) (mem? dst)) + (printf "sarl ~s ~s\n" src dst) + (printf "=> ~s\n" ((CODE/r #xC1 '/7) dst (IMM8 src '()))) + ((CODE/r #xC1 '/7) dst (IMM8 src ac))] [(and (eq? src '%cl) (reg? dst)) (CODE #xD3 (ModRM 3 '/7 dst ac))] [else (error who "invalid ~s" instr)])] @@ -550,8 +576,6 @@ (CODE #x0D (IMM32 src ac))] [(and (imm? src) (reg? dst)) (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)) (CODE #x09 (ModRM 3 src dst ac))] [(and (mem? src) (reg? dst)) diff --git a/src/librecord.ss b/src/librecord.ss index 8cec11a..eb971f8 100644 --- a/src/librecord.ss +++ b/src/librecord.ss @@ -97,7 +97,7 @@ (error 'make-record-type "fields must be a list, got ~s" fields)) (for-each verify-field fields) (cond - [(top-level-bound? g) + [(top-level-bound? g) (let ([rtd (top-level-value g)]) (unless (and (string=? name (record-type-name rtd)) (equal? fields (record-type-field-names rtd)))