Update am-compare-jump so it follows specificationcpu

4 files changed, 42 insertions, 31 deletions

diff --git a/gsc/_t-cpu-abstract-machine.scm b/gsc/_t-cpu-abstract-machine.scm
index 96489149..3ada6d40 100644
--- a/gsc/_t-cpu-abstract-machine.scm
+++ b/gsc/_t-cpu-abstract-machine.scm
@@ -388,9 +388,14 @@
       (int-opnd (- (* n (get-word-width cgc)))))))
 
 ;;------------------------------------------------------------------------------
-;;--------------------------------- Conditions ---------------------------------
+;;------------------------------ Tests/Conditions ------------------------------
 ;;------------------------------------------------------------------------------
 
+(define (mk-test operator operand1 operand2) (list operator operand1 operand2))
+(define (test-condition test) (car test))
+(define (test-operand1 test) (cadr test))
+(define (test-operand2 test) (caddr test))
+
 (define condition-equal (list 'equal))
 (define condition-not-equal (list 'not-equal))
 
@@ -413,7 +418,7 @@
     ((greater) (caddr cond))
     ((lesser) (caddr cond))))
 
-(define (inverse-condition cond)
+(define (invert-condition cond)
   (case (car cond)
     ((equal)
       condition-not-equal)
@@ -651,8 +656,7 @@
          (return-lbl3 (make-unique-label cgc "resume-execution")))
 
     (am-compare-jump cgc
-      (condition-lesser #t #t)
-      (get-frame-pointer cgc) stack-trip
+      (mk-test (condition-lesser #t #t) (get-frame-pointer cgc) stack-trip)
       return-lbl1 #f)
 
     (am-lbl cgc return-lbl3)
@@ -690,8 +694,7 @@
     (if (not rest?)
       ;; Without rest argument
       (am-compare-jump cgc
-        condition-not-equal
-        (car narg-field) (int-opnd arg-count)
+        (mk-test condition-not-equal (car narg-field) (int-opnd arg-count))
         error-label #f
         (cdr narg-field))
 
@@ -704,8 +707,7 @@
             (fp (get-frame-pointer cgc)))
 
         (am-compare-jump cgc
-          condition-not-equal
-          (car narg-field) (int-opnd (- arg-count 1))
+          (mk-test condition-not-equal (car narg-field) (int-opnd (- arg-count 1)))
           call-handler-lbl #f
           (cdr narg-field))
         ;; Case with 0 element
@@ -717,8 +719,7 @@
 
         ;; Jump to return-from-handler-lbl if nargs < 0
         (am-compare-jump cgc
-          (condition-lesser #f #t)
-          (car narg-field) (int-opnd 0)
+          (mk-test (condition-lesser #f #t) (car narg-field) (int-opnd 0))
           return-from-handler-lbl #f
           (cdr narg-field))
 
@@ -746,9 +747,9 @@
           ;; Reset bytes allocated count
           (codegen-context-memory-allocated-set! cgc 0)
 
+          ;; Not "or equal", because we can't exceed the fudge
           (am-compare-jump cgc
-            (condition-greater #f #f) ;; Not "or equal", because we can't exceed the fudge
-            (get-heap-pointer cgc) heap-limit
+            (mk-test (condition-greater #f #f) (get-heap-pointer cgc) heap-limit)
             return-lbl1 #f)
 
           (am-lbl cgc return-lbl3)
diff --git a/gsc/_t-cpu-backend-arm.scm b/gsc/_t-cpu-backend-arm.scm
index b3c3f9a9..428c8bb1 100644
--- a/gsc/_t-cpu-backend-arm.scm
+++ b/gsc/_t-cpu-backend-arm.scm
@@ -91,7 +91,7 @@
     arm-sub-instr               ;; am-sub
     arm-jmp-instr               ;; am-jmp
     arm-cmp-jump-instr          ;; am-compare-jump
-    am-compare-move))           ;; am-compare-move
+    arm-cmp-move-instr))        ;; am-compare-move
 
 (define (make-arm-opnd opnd)
   (cond
@@ -338,12 +338,17 @@
           (cons (arm-cond-hs) (arm-cond-lo)))
         ((and (not (cond-is-equal condition)) (not (cond-is-signed condition)))
           (cons (arm-cond-hi) (arm-cond-ls)))))
-    ((not-equal) (flip (arm-get-branch-conditions (inverse-condition condition))))
-    ((lesser) (flip (arm-get-branch-conditions (inverse-condition condition))))
+    ((not-equal) (flip (arm-get-branch-conditions (invert-condition condition))))
+    ((lesser) (flip (arm-get-branch-conditions (invert-condition condition))))
     (else
       (compiler-internal-error "arm-get-branch-conditions - Unknown condition: " condition))))
 
-(define (arm-cmp-jump-instr cgc condition opnd1 opnd2 loc-true loc-false #!optional (opnds-width #f))
+(define (arm-cmp-jump-instr cgc test loc-true loc-false #!optional (opnds-width #f))
+  (let* ((condition (test-condition test))
+         (opnd1 (test-operand1 test))
+         (opnd2 (test-operand2 test))
+         (conds (arm-get-branch-conditions condition)))
+
     ;; In case both jump locations are false, the cmp is unnecessary.
     ;; Todo: Use cmn is necessary
     (if (or loc-true loc-false)
@@ -352,7 +357,6 @@
         (list opnd1 opnd2)
           (lambda (reg1 opnd2) (arm-cmp cgc reg1 (make-arm-opnd opnd2)))))
 
-  (let* ((conds (arm-get-branch-conditions condition)))
     (cond
       ((and loc-false loc-true)
         (arm-b cgc (lbl-opnd-label loc-true) (car conds))
diff --git a/gsc/_t-cpu-backend-x86.scm b/gsc/_t-cpu-backend-x86.scm
index 73de3635..37dcee13 100644
--- a/gsc/_t-cpu-backend-x86.scm
+++ b/gsc/_t-cpu-backend-x86.scm
@@ -274,13 +274,16 @@
           (cons x86-jae x86-jb))
         ((and (not (cond-is-equal condition)) (not (cond-is-signed condition)))
           (cons x86-ja x86-jbe))))
-    ((not-equal) (flip (get-jumps (inverse-condition condition))))
-    ((lesser) (flip (get-jumps (inverse-condition condition))))
+    ((not-equal) (flip (get-jumps (invert-condition condition))))
+    ((lesser) (flip (get-jumps (invert-condition condition))))
     (else
       (compiler-internal-error "get-jumps - Unknown condition: " condition))))
 
-(define (x86-cmp-jump-instr cgc condition opnd1 opnd2 loc-true loc-false #!optional (opnds-width #f))
-  (let* ((jumps (get-jumps condition)))
+(define (x86-cmp-jump-instr cgc test loc-true loc-false #!optional (opnds-width #f))
+  (let* ((condition (test-condition test))
+         (opnd1 (test-operand1 test))
+         (opnd2 (test-operand2 test))
+         (jumps (get-jumps condition)))
     ;; In case both jump locations are false, the cmp is unnecessary.
     (if (or loc-true loc-false)
       (load-multiple-if-necessary cgc '((reg mem) (reg mem int)) (list opnd1 opnd2)
@@ -301,10 +304,14 @@
       (else
         (debug "am-compare-jump: No jump encoded")))))
 
-(define (x86-cmp-move-instr cgc condition dest opnd1 opnd2 true-opnd false-opnd #!optional (opnds-width #f))
-  (let* ((jumps (get-jumps condition))
+(define (x86-cmp-move-instr cgc test dest true-opnd false-opnd #!optional (opnds-width #f))
+  (let* ((condition (test-condition test))
+         (opnd1 (test-operand1 test))
+         (opnd2 (test-operand2 test))
+         (jumps (get-jumps condition))
          (label-true (make-unique-label cgc "mov-true" #f))
          (label-false (make-unique-label cgc "mov-false" #f)))
+
     ;; In case both jump locations are false, the cmp is unnecessary.
     (load-if-necessary cgc '(reg mem) opnd1
       (lambda (opnd1) (x86-cmp cgc opnd1 opnd2 opnds-width)))
@@ -797,8 +804,7 @@
   (foldl-compare-prim
     (lambda (cgc opnd1 opnd2 true-label false-label)
       (am-compare-jump cgc
-        condition
-        opnd1 opnd2
+        (mk-test condition opnd1 opnd2)
         false-label true-label
         (get-word-width-bits cgc)))
     allowed-opnds1: '(reg mem)
diff --git a/gsc/_t-cpu-primitives.scm b/gsc/_t-cpu-primitives.scm
index 5b180c62..8cfadf4a 100644
--- a/gsc/_t-cpu-primitives.scm
+++ b/gsc/_t-cpu-primitives.scm
@@ -54,10 +54,11 @@
 (define (am-if cgc opnd1 opnd2 condition on-true on-false #!optional (actions-return #f) (opnds-width #f))
   (let ((true-label (make-unique-label cgc "if-true" #f))
         (false-label (make-unique-label cgc "if-false" #f))
-        (continue-label (make-unique-label cgc "continue-label" #f)))
+        (continue-label (make-unique-label cgc "continue-label" #f))
+        (test (mk-test condition opnd1 opnd2)))
     (cond
       ((and on-true on-false)
-        (am-compare-jump cgc condition opnd1 opnd2 #f false-label opnds-width)
+        (am-compare-jump cgc test #f false-label opnds-width)
         (on-true cgc)
         (if (not actions-return)
           (am-jmp cgc continue-label))
@@ -65,12 +66,12 @@
         (on-false cgc)
         (am-lbl cgc continue-label))
       (on-true
-        (am-compare-jump cgc condition opnd1 opnd2 #f continue-label opnds-width)
+        (am-compare-jump cgc test #f continue-label opnds-width)
         (on-true cgc)
         (if (not actions-return)
           (am-jmp cgc continue-label)))
       (on-false
-        (am-compare-jump cgc condition opnd1 opnd2 continue-label #f opnds-width)
+        (am-compare-jump cgc test continue-label #f opnds-width)
         (on-false cgc)
         (if (not actions-return)
           (am-jmp cgc continue-label))))))
@@ -126,8 +127,7 @@
           (load-if-necessary cgc '(reg mem) opnd
             (lambda (opnd)
               (am-compare-jump cgc
-                condition-not-equal
-                opnd false-opnd
+                (mk-test condition-not-equal opnd false-opnd)
                 true-jmp false-jmp
                 (get-word-width-bits cgc)))))))
     ((then-move? result-action)