Fix bug in code generation for the HEAP-AVAILABLE? primitive. The

primitive compares addresses using an unsigned comparison, but the
compiled code was using a signed comparison.  This was the cause of
sporadic failures that have been seen while running Edwin with a large
heap on OS/2; it could have happened on any operating system when
Edwin was run with a sufficiently large heap.  This fix changes the
compiled code to use an unsigned comparison.

diff --git a/v7/src/compiler/base/make.scm b/v7/src/compiler/base/make.scm
index 09ac9bd30c34d1a2b05522d3464107217e3a4290..56a51a3812ded5505d1f987196e609a1fd30395d 100644 (file)
--- a/v7/src/compiler/base/make.scm
+++ b/v7/src/compiler/base/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 4.106 1994/02/02 03:26:21 gjr Exp $
+$Id: make.scm,v 4.107 1997/03/30 23:33:24 cph Exp $
 
-Copyright (c) 1988-1994 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -54,5 +54,5 @@ MIT in each case. |#
     (initialize-package! '(COMPILER DECLARATIONS)))
   (add-system!
    (make-system (string-append "Liar (" architecture-name ")")
-               4 106
+               4 107
                '())))
\ No newline at end of file

diff --git a/v7/src/compiler/machines/mips/lapgen.scm b/v7/src/compiler/machines/mips/lapgen.scm
index 09d5ae3c82841b6b7783959fc94a3d4e979f3463..3a5085db277c51c72a49c76e2cb8530b474afc59 100644 (file)
--- a/v7/src/compiler/machines/mips/lapgen.scm
+++ b/v7/src/compiler/machines/mips/lapgen.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: lapgen.scm,v 1.13 1993/12/18 08:49:05 cph Exp $
+$Id: lapgen.scm,v 1.14 1997/03/30 23:33:17 cph Exp $
 
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -396,13 +396,20 @@ MIT in each case. |#
   ; Branch if immediate <comp> source
   (let ((cc (invert-condition-noncommutative comp)))
     ;; This machine does register <op> immediate; you can
-    ;; now think of cc in this way
+    ;; now think of cc in this way.
     (if (zero? immediate)
-       (begin
-         (branch-generator! cc
-           `(BEQ 0 ,source) `(BLTZ ,source) `(BGTZ ,source)
-           `(BNE 0 ,source) `(BGEZ ,source) `(BLEZ ,source))
-         (LAP))
+       (let ((use-cc
+              (lambda (cc)
+                (branch-generator! cc
+                  `(BEQ 0 ,source) `(BLTZ ,source) `(BGTZ ,source)
+                  `(BNE 0 ,source) `(BGEZ ,source) `(BLEZ ,source))
+                (LAP))))
+         (case cc
+           ((<<) (compare-false))
+           ((>>=) (compare-true))
+           ((<<=) (use-cc '=))
+           ((>>) (use-cc '<>))
+           (else (use-cc cc))))
        (with-values (lambda () (immediate->register immediate))
          (lambda (prefix alias)
            (LAP ,@prefix
@@ -411,32 +418,51 @@ MIT in each case. |#
 (define (compare condition r1 r2)
   ; Branch if r1 <cc> r2
   (if (= r1 r2)
-      (let ((branch
-            (lambda (label) (LAP (BGEZ 0 (@PCR ,label)) (NOP))))
-           (dont-branch
-            (lambda (label) label (LAP))))
-       (if (memq condition '(< > <>))
-           (set-current-branches! dont-branch branch)
-           (set-current-branches! branch dont-branch))
-       (LAP))
-      (let ((temp (and (memq condition '(< > <= >=)) (standard-temporary!))))
+      (if (memq condition '(< > <> << >>))
+         (compare-false)
+         (compare-true))
+      (let ((temp
+            (and (memq condition '(< > <= >= << >> <<= >>=))
+                 (standard-temporary!))))
        (branch-generator! condition
          `(BEQ ,r1 ,r2) `(BNE ,temp 0) `(BNE ,temp 0)
          `(BNE ,r1 ,r2) `(BEQ ,temp 0) `(BEQ ,temp 0))
        (case condition
          ((= <>) (LAP))
          ((< >=) (LAP (SLT ,temp ,r1 ,r2)))
-         ((> <=) (LAP (SLT ,temp ,r2 ,r1)))))))
-
+         ((> <=) (LAP (SLT ,temp ,r2 ,r1)))
+         ((<< >>=) (LAP (SLTU ,temp ,r1 ,r2)))
+         ((>> <<=) (LAP (SLTU ,temp ,r2 ,r1)))))))
+
+(define (compare-true)
+  (set-current-branches!
+   (lambda (label) (LAP (BGEZ 0 (@PCR ,label)) (NOP)))
+   (lambda (label) label (LAP)))
+  (LAP))
+
+(define (compare-false)
+  (set-current-branches!
+   (lambda (label) label (LAP))
+   (lambda (label) (LAP (BGEZ 0 (@PCR ,label)) (NOP))))
+  (LAP))
+\f
 (define (branch-generator! cc = < > <> >= <=)
   (let ((forward
         (case cc
-          ((=)   =) ((<)  <)  ((>)  >)
-          ((<>) <>) ((>=) >=) ((<=) <=)))
+          ((=) =)
+          ((< <<) <)
+          ((> >>) >)
+          ((<>) <>)
+          ((>= >>=) >=)
+          ((<= <<=) <=)))
        (inverse
         (case cc
-          ((=)  <>) ((<)  >=) ((>)  <=)
-          ((<>) =)  ((>=) <)  ((<=) >))))
+          ((=) <>)
+          ((< <<) >=)
+          ((> >>) <=)
+          ((<>) =)
+          ((>= >>=) <)
+          ((<= <<=) >))))
     (set-current-branches!
      (lambda (label)
        (LAP (,@forward (@PCR ,label)) (NOP)))
@@ -463,7 +489,11 @@ MIT in each case. |#
     (>         <=              <)
     (<>                =               <>)
     (<=                >               >=)
-    (>=                <               <=)))
+    (>=                <               <=)
+    (<<                >>=             >>)
+    (>>                <<=             <<)
+    (<<=       >>              >>=)
+    (>>=       <<              <<=)))
 \f
 ;;;; Miscellaneous
 
@@ -624,7 +654,7 @@ MIT in each case. |#
   ;; Jump to scheme-to-interface
   (LAP (JR ,regnum:scheme-to-interface)
        (ADDI ,regnum:interface-index 0 ,(* 4 code))))
-
+\f
 (define (load-interface-args! first second third fourth)
   (let ((clear-regs
         (apply clear-registers!

diff --git a/v7/src/compiler/machines/mips/rulfix.scm b/v7/src/compiler/machines/mips/rulfix.scm
index 647c093e963591c4ce7d252432f64c6444d7f760..fee8c27f0c3d8b86dd5c8d5ae4840246b3c1d464 100644 (file)
--- a/v7/src/compiler/machines/mips/rulfix.scm
+++ b/v7/src/compiler/machines/mips/rulfix.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rulfix.scm,v 1.9 1993/01/08 00:04:44 cph Exp $
+$Id: rulfix.scm,v 1.10 1997/03/30 23:33:06 cph Exp $
 
-Copyright (c) 1989-1993 Massachusetts Institute of Technology
+Copyright (c) 1989-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -612,4 +612,6 @@ MIT in each case. |#
     ((EQUAL-FIXNUM?) '=)
     ((LESS-THAN-FIXNUM?) '<)
     ((GREATER-THAN-FIXNUM?) '>)
+    ((UNSIGNED-LESS-THAN-FIXNUM?) '<<)
+    ((UNSIGNED-GREATER-THAN-FIXNUM?) '>>)
     (else (error "unknown fixnum predicate" predicate))))
\ No newline at end of file