* nothing much

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";

src/geninstr/tmp.s

@@ -1,9 +1,9 @@
 .text
-addl $27, 12(%eax)
+addl $0x12345678, 7(%eax)
-addl $27, 12(%ecx)
+addl $0x12345678, 7(%ecx)
-addl $27, 12(%edx)
+addl $0x12345678, 7(%edx)
-addl $27, 12(%ebx)
+addl $0x12345678, 7(%ebx)
-addl $27, 12(%esp)
+addl $0x12345678, 7(%esp)
-addl $27, 12(%ebp)
+addl $0x12345678, 7(%ebp)
-addl $27, 12(%esi)
+addl $0x12345678, 7(%esi)
-addl $27, 12(%edi)
+addl $0x12345678, 7(%edi)

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=            p]
+      [$char=            p]
-      ;[$char->fixnum     v]
+      [$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) 

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))

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)))