perform more aggressive optimization

coalton-compiler.asd

@@ -107,9 +107,16 @@
                              (:file "codegen-type-definition")
                              (:file "codegen-expression")
                              (:file "codegen-class")
+
+                             ;; Optimizations
                              (:file "monomorphize")
                              (:file "constant-propagation")
+                             (:file "canonicalizer")
+                             (:file "inliner")
+                             (:file "specializer")
                              (:file "optimizer")
+
+                             ;; Entry points
                              (:file "program")
                              (:file "package")))
                (:file "unlock-package" :if-feature :sb-package-locks)

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/experimental/loops.lisp

@@ -33,7 +33,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
 
 (coalton-toplevel
 
-  (inline) (monomorphize)
+  (inline)
   (declare %repeat (UFix -> (Unit -> :t) -> Unit))
   (define (%repeat n func)
     "Do `func` `n` times."
@@ -45,7 +45,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
          (func)
          (% (1+ i))))))
 
-  (inline) (monomorphize)
+  (inline)
   (declare %dotimes (UFix -> (UFix -> :t) -> Unit))
   (define (%dotimes n func)
     "Apply `func` to every `UFix` in `[0, n)`."
@@ -57,7 +57,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
          (func i)
          (% (1+ i))))))
 
-  (inline) (monomorphize)
+  (inline)
   (declare %everytimes (UFix -> (UFix -> Boolean) -> Boolean))
   (define (%everytimes n pred)
     "Is `pred` `True` for all `UFix`s in `[0, n)`? Returns `True` for `n = 0`."
@@ -68,7 +68,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
               (% (1+ i))
               False))))
 
-  (inline) (monomorphize)
+  (inline)
   (declare %sometimes (UFix -> (UFix -> Boolean) -> Boolean))
   (define (%sometimes n pred)
     "Is `pred` `True` for some `UFix` in `[0, n)`? Returns `False` for `n = 0`."
@@ -79,7 +79,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
               True
               (% (1+ i))))))
 
-  (inline) (monomorphize)
+  (inline)
   (declare %sumtimes (Num :t => UFix -> (UFix -> :t) -> :t))
   (define (%sumtimes n func)
     "Sum the evaluations of `func` applied to every `UFix` in `[0, n)`. Returns 0 for `n = 0`."
@@ -88,7 +88,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
           acc
           (% (1+ i) (+ acc (func i))))))
 
-  (inline) (monomorphize)
+  (inline)
   (declare %prodtimes (Num :t => UFix -> (UFix -> :t) -> :t))
   (define (%prodtimes n func)
     "Multiply the evaluations of `func` applied to every `UFix` in `[0, n)`. Returns 1 for `n = 0`."
@@ -104,7 +104,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
     (lisp (List :t) (xs)
       (cl:nreverse xs)))
 
-  (inline) (monomorphize)
+  (inline)
   (declare %collecttimes (UFix -> (UFix -> :t) -> List :t))
   (define (%collecttimes n func)
     "Collect the applications of `func` to every `UFix` in `[0, n)` as a `List`."
@@ -131,7 +131,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
   ;;     (cl:locally (cl:declare (cl:optimize (cl:safety 0)))
   ;;       (cl:cdr xs))))
 
-  ;; (inline) (monomorphize)
+  ;; (inline)
   ;; (declare %collecttimes (UFix -> (UFix -> :t) -> List :t))
   ;; (define (%collecttimes n func)
   ;;   (let ((res (lisp (List :t) () (cl:cons cl:nil cl:nil))))
@@ -144,7 +144,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
   ;;            (%rplacd! last new-last)
   ;;            (% (1+ i) new-last)))))))
 
-  (inline) (monomorphize)
+  (inline)
   (declare %besttimes (UFix -> (:t -> :t -> Boolean) -> (UFix -> :t) -> :t))
   (define (%besttimes n better? func)
     "Of the applications of `func` to every `UFix` in `[0, n)`, find the one that is `better?` than the rest."
@@ -162,7 +162,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
                   (% (1+ i) candidate)
                   (% (1+ i) best)))))))))
 
-  (inline) (monomorphize)
+  (inline)
   (declare %argbesttimes (UFix -> (:t -> :t -> Boolean) -> (UFix -> :t) -> UFix))
   (define (%argbesttimes n better? func)
     "Find the `UFix` in `[0, n)` whose application of `func` is `better?` than the rest."
@@ -192,7 +192,7 @@ Note: `(return)`, `(break)`, and `(continue)` do not work inside _any_ of these
          (func x)
          (% xs)))))
 
-  (inline) (monomorphize)
+  (inline)
   (declare %dolist-enumerated (List :t1 -> (UFix -> :t1 -> :t2) -> Unit))
   (define (%dolist-enumerated lis func)
     "Apply `func` to every element of `lis` and its index, as `(func index element)`."

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-defining-macros.lisp

@@ -204,7 +204,7 @@
 
 
 ;;; Float Num instances.
-(cl:defmacro define-num-float (type lisp-type)
+(cl:defmacro define-num-float (type lisp-type plus-inf minus-inf)
   "Define `Num' for the float type TYPE."
 
   ;;
@@ -244,8 +244,8 @@
        (lisp ,type (x)
          (cl:or (cl:ignore-errors (cl:coerce x ',lisp-type))
                 (cl:if (cl:< x 0)
-                       (coalton (the ,type negative-infinity))
-                       (coalton (the ,type infinity))))))))
+                       ,minus-inf
+                       ,plus-inf))))))
 
 
 ;;; Utility to define type -> Fraction conversions.

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,15 +75,39 @@
   (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+)))))
 
 
 ;;;
 ;;; Float Num instances
 ;;;
 
-  (define-num-float Single-Float cl:single-float)
-  (define-num-float Double-Float cl:double-float)
+  (define-num-float Single-Float cl:single-float float-features:single-float-positive-infinity float-features:single-float-negative-infinity)
+  (define-num-float Double-Float cl:double-float float-features:double-float-positive-infinity float-features:double-float-negative-infinity)
 
 
 ;;;

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

src/codegen/canonicalizer.lisp

@@ -0,0 +1,39 @@
+(defpackage #:coalton-impl/codegen/canonicalizer
+  (:use
+   #:cl
+   #:coalton-impl/codegen/ast)
+  (:import-from
+   #:coalton-impl/codegen/traverse
+   #:action
+   #:traverse)
+  (:export
+   #:canonicalize))
+
+(in-package #:coalton-impl/codegen/canonicalizer)
+
+(defun canonicalize (node)
+  "Canonicalize the applications of NODE. \"Canonicalize\" means to
+supply as many arguments as possible to nested, partially applied
+functions. For example, the canonicalization of
+
+    ((FOO BAR) BAZ)
+
+would be:
+
+    (FOO BAR BAZ)"
+  (declare (type node node)
+           (values node &optional))
+  (labels ((rewrite-application (node)
+             (let ((rator (node-application-rator node))
+                   (rands (node-application-rands node)))
+               (when (node-application-p rator)
+                 (make-node-application
+                  :type (node-type node)
+                  :rator (node-application-rator rator)
+                  :rands (append
+                          (node-application-rands rator)
+                          rands))))))
+    (traverse
+     node
+     (list
+      (action (:after node-application) #'rewrite-application)))))

src/codegen/constant-propagation.lisp

@@ -9,6 +9,9 @@
    #:action
    #:*traverse*
    #:traverse)
+  (:import-from
+   #:coalton-impl/codegen/monomorphize
+   #:dictionary-node-p)
   (:export
    #:propagate-constants))
 
@@ -47,13 +50,28 @@ If not, returns NIL"
         ((node-lisp-p node)
          (if (cl:constantp (node-lisp-form node))
              node
-             nil))))
+             nil))
+        ;; special support for dictionaries
+        ((dictionary-node-p node env)
+         node)
+        (t
+         nil)))
+
+(defun limit-name (x)
+  (if (< (length x) 16)
+      x
+      (subseq x 0 16)))
 
 (defun propagate-constants (node env)
   (declare (optimize debug))
   (labels ((propagate-constants-node-variable (node constant-bindings)
              (declare (type node-variable node))
-             (constant-node-p env node constant-bindings))
+             (let ((x (constant-node-p env node constant-bindings)))
+               (cond
+                 ((null x)
+                  nil)
+                 (t
+                  x))))
 
            (propagate-constants-node-let (node constant-bindings)
              (declare (type node-let node))
@@ -62,11 +80,13 @@ If not, returns NIL"
                    (nonconstant-bindings nil))
                (loop :for (var . value) :in node-bindings
                      :for propagated-value-node := (funcall *traverse* value constant-bindings)
-                     :do (if (constant-node-p env propagated-value-node constant-bindings)
-                             (push (cons var propagated-value-node)
-                                   new-constant-bindings)
-                             (push (cons var propagated-value-node)
-                                   nonconstant-bindings)))
+                     :do (cond
+                           ((constant-node-p env propagated-value-node constant-bindings)
+                            (push (cons var propagated-value-node)
+                                  new-constant-bindings))
+                           (t
+                            (push (cons var propagated-value-node)
+                                  nonconstant-bindings))))
                (let ((inner-constant-bindings (append new-constant-bindings constant-bindings)))
                  (if nonconstant-bindings
                      (make-node-let
@@ -82,7 +102,7 @@ If not, returns NIL"
                       (loop :for (lisp-var . coalton-var) :in (node-lisp-vars node)
                             :for constant-value := (constant-var-value coalton-var constant-bindings :no-error t)
                             :if constant-value
-                              :collect (let ((new-coalton-var (gentemp (symbol-name coalton-var))))
+                              :collect (let ((new-coalton-var (gentemp (limit-name (symbol-name coalton-var)))))
                                          (push (cons lisp-var new-coalton-var) new-lisp-vars)
                                          (cons new-coalton-var constant-value))
                             :else