make UFix arithmetic processor-native

This commit also fixes UFix underflow issues

- make RANGE-DECREASING handle unsigned types gracefully
- fix Seq's CST-SEARCH
- fix use of DECREMENT! in Brainfold example

Author: stylewarning

examples/small-coalton-programs/src/brainfold.lisp

@@ -78,7 +78,7 @@
   (define (value-at-pointer bfs)
     "Returns the value at the current pointer."
     (vec:index-unsafe (cell:read (.pointer bfs))
-		                (.memory bfs))))
+		      (.memory bfs))))
 
 ;;;
 ;;; Commands (Functions called by Brainfold Cmds)
@@ -98,12 +98,18 @@
      (pure (cell:increment! (.pointer bfs)))
       (state:put bfs)))
 
+  (define (dec! cell)
+    (let ((value (cell:read cell)))
+      (if (arith:zero? value)
+          0
+          (cell:write! cell (1- value)))))
+
   (declare move-left (Unit -> (state:ST BF-State Unit)))
   (define (move-left)
     "Moves the pointer one bf-cell to the left."
     (do
      (bfs <- state:get)
-     (pure (cell:decrement! (.pointer bfs)))
+     (pure (dec! (.pointer bfs)))
       (state:put bfs)))
 
   ;;

library/iterator.lisp

@@ -191,6 +191,17 @@ iterator is empty."
     "An iterator which begins at zero and counts up through and including LIMIT."
     (up-to (+ 1 limit)))
 
+
+  ;; All the haranguing below is so that we don't overflow a bounded
+  ;; type in a range-decreasing call. We generally assume a lower
+  ;; bound (e.g., 0 for unsigned types) is more common than an upper
+  ;; bound.
+  (repr :enum)
+  (define-type RangeStatus
+    RangeContinue
+    RangeLast
+    RangeDone)
+
   (declare range-decreasing ((Num :num) (Ord :num) =>
                              :num ->
                              :num ->
@@ -201,16 +212,36 @@ iterator is empty."
 
 Equivalent to reversing `range-increasing`"
     (assert (<= end start)
-        "END ~a should be less than or equal to START ~a in RANGE-INCREASING"
+        "END ~a should be less than or equal to START ~a in RANGE-DECREASING"
         end start)
     (assert (> step 0)
-        "STEP ~a should be positive and non-zero in RANGE-INCREASING"
+        "STEP ~a should be positive and non-zero in RANGE-DECREASING"
         step)
-    ;; FIXME: avoid underflow in the DONE? test
-    (recursive-iter ((flip -) step)
-                    (fn (n) (>= end (+ n step))) ; like (>= (- end step)), but without potential underflow
-                    (- start step)               ; begin after START
-                    ))
+    (let ((end+step (+ end step)))
+      (if (< start end+step)
+          empty
+          (let ((start-step (- start step))
+                (next (cell:new start-step))
+                (status (cell:new (if (< start-step end+step)
+                                      RangeLast
+                                      RangeContinue))))
+            (%Iterator
+             (fn ()
+               (match (cell:read status)
+                 ((RangeDone)
+                  None)
+                 ((RangeLast)
+                  (cell:write! status RangeDone)
+                  (Some (cell:read next)))
+                 ((RangeContinue)
+                  (let ((this (cell:read next))
+                        (next-next (- this step)))
+                    (cell:write! status (if (< next-next end+step)
+                                            RangeLast
+                                            RangeContinue))
+                    (cell:write! next next-next)
+                    (Some this)))))
+             None)))))
 
   (declare down-from ((Num :num) (Ord :num) => :num -> Iterator :num))
   (define (down-from limit)

library/math/num.lisp

@@ -6,6 +6,8 @@
   (:use
    #:coalton
    #:coalton-library/math/num-defining-macros)
+  (:local-nicknames
+   (#:cls #:coalton-library/classes))
   (:import-from
    #:coalton-library/hash
    #:define-sxhash-hasher))
@@ -73,7 +75,31 @@
   (define-num-wrapping U16 16)
   (define-num-wrapping U32 32)
   (define-num-wrapping U64 64)
-  (define-num-wrapping UFix #.+unsigned-fixnum-bits+)
+
+  ;; UFixes are unsafe and depend on implementation.
+  (define-instance (cls:Num UFix)
+    (inline)
+    (define (cls:+ a b)
+      (lisp UFix (a b)
+        (cl:locally (cl:declare (cl:optimize cl:speed (cl:safety 0)))
+          (cl:+ a b))))
+
+    (inline)
+    (define (cls:- a b)
+      (lisp UFix (a b)
+        (cl:locally (cl:declare (cl:optimize cl:speed (cl:safety 0)))
+          (cl:- a b))))
+
+    (inline)
+    (define (cls:* a b)
+      (lisp UFix (a b)
+        (cl:locally (cl:declare (cl:optimize cl:speed (cl:safety 0)))
+          (cl:* a b))))
+
+    (inline)
+    (define (cls:fromInt x)
+      (lisp UFix (x)
+        (cl:mod x #.(cl:expt 2 +fixnum-bits+)))))
 
 
 ;;;

library/seq.lisp

@@ -284,7 +284,9 @@ a new `Seq` instance."
                   (if (< idx cumulative)
                       (pure (Tuple gs last-cumulative))
                       (search-forward (+ 1 gs) cumulative)))))) 
-      (>>= (alt (vector:index (- guess 1) cst) ; Note, 0 <= guess <= 31
+      (>>= (alt (if (math:zero? guess)  ; avoid UFix underflow
+                    None
+                    (vector:index (- guess 1) cst)) ; Note, 0 < guess <= 31
                 (pure 0))
            (search-forward guess))))  
 

tests/iterator-tests.lisp

@@ -100,6 +100,12 @@
                       (iter:repeat-for "foo" 10)))))
 
 (define-test iter-downfrom ()
+  (is (== (the (List UFix) Nil)
+          (iter:collect! (iter:down-from 0))))
+  (is (== (the (List UFix) (make-list 0))
+          (iter:collect! (iter:down-from 1))))
+  (is (== (the (List UFix) (make-list 9 8 7 6 5 4 3 2 1 0))
+          (iter:collect! (iter:down-from 10))))
   (is (== (the (List Integer) (make-list 9 8 7 6 5 4 3 2 1 0))
           (iter:collect! (iter:down-from 10))))
   (is (== (the (List Integer) (make-list 9 8 7 6 5 4 3 2 1 0))
@@ -120,10 +126,10 @@
                                   (iter:up-to 10)))))
   (is (== (Some (the Integer 0))
           (iter:maximize-by! negate (iter:chain! (iter:up-to 10)
-                                                (iter:down-from 10)))))
+                                                 (iter:down-from 10)))))
   (is (== (Some (the Integer 10))
           (iter:minimize-by! negate (iter:chain! (iter:down-from 10)
-                                                (iter:up-through 10))))))
+                                                 (iter:up-through 10))))))
 
 (define-test iter-optimize-string-length ()
   (let ((longer? (fn (long short)