[ performance ] Memoise toplevel constants (#1899)

stefan-hoeck · web-flow · commit af5657d23a7f · 2021-09-08T16:46:19.000+01:00
* [ performance ] memoize toplevel constants

* [ test ] memoization tests

* [ fix ] fix blodwen-lazy for racket and gambit
diff --git a/src/Compiler/Scheme/Common.idr b/src/Compiler/Scheme/Common.idr
@@ -659,6 +659,9 @@ parameters (schExtPrim : Int -> ExtPrim -> List NamedCExp -> Core String,
 
   schDef : {auto c : Ref Ctxt Defs} ->
            Name -> NamedDef -> Core String
+  schDef n (MkNmFun [] exp)
+     = pure $ "(define " ++ schName !(getFullName n) ++ "(blodwen-lazy (lambda () "
+                      ++ !(schExp 0 exp) ++ ")))\n"
   schDef n (MkNmFun args exp)
      = pure $ "(define " ++ schName !(getFullName n) ++ " (lambda (" ++ schArglist args ++ ") "
                       ++ !(schExp 0 exp) ++ "))\n"
diff --git a/support/chez/support.ss b/support/chez/support.ss
@@ -8,6 +8,17 @@
     [(i3nt ti3nt a6nt ta6nt) "windows"]
     [else "unknown"]))
 
+(define blodwen-lazy
+  (lambda (f)
+    (let ([evaluated #f] [res void])
+      (lambda ()
+        (if (not evaluated)
+            (begin (set! evaluated #t)
+                   (set! res (f))
+                   (set! f void))
+            (void))
+        res))))
+
 (define blodwen-toSignedInt
   (lambda (x bits)
     (if (logbit? bits x)
@@ -18,6 +29,7 @@
   (lambda (x bits)
     (modulo x (ash 1 bits))))
 
+
 (define bu+ (lambda (x y bits) (blodwen-toUnsignedInt (+ x y) bits)))
 (define bu- (lambda (x y bits) (blodwen-toUnsignedInt (- x y) bits)))
 (define bu* (lambda (x y bits) (blodwen-toUnsignedInt (* x y) bits)))
diff --git a/support/gambit/support.scm b/support/gambit/support.scm
@@ -14,6 +14,17 @@
       (cons (vector-ref desc 2)
             (blodwen-read-args (vector-ref desc 3)))))
 
+(define blodwen-lazy
+  (lambda (f)
+    (let ([evaluated #f] [res void])
+      (lambda ()
+        (if (not evaluated)
+            (begin (set! evaluated #t)
+                   (set! res (f))
+                   (set! f void))
+            (void))
+        res))))
+
 (define blodwen-toSignedInt
   (lambda (x bits)
     (if (bit-set? bits x)
diff --git a/support/racket/support.rkt b/support/racket/support.rkt
@@ -5,6 +5,17 @@
     [(windows) "windows"]
     [else "unknown"]))
 
+(define blodwen-lazy
+  (lambda (f)
+    (let ([evaluated #f] [res void])
+      (lambda ()
+        (if (not evaluated)
+            (begin (set! evaluated #t)
+                   (set! res (f))
+                   (set! f void))
+            (void))
+        res))))
+
 (define blodwen-toSignedInt
   (lambda (x bits)
     (if (bitwise-bit-set? x bits)
diff --git a/tests/Main.idr b/tests/Main.idr
@@ -226,6 +226,7 @@ chezTests = MkTestPool "Chez backend" [] (Just Chez)
     , "futures001"
     , "bitops"
     , "casts"
+    , "memo"
     , "newints"
     , "integers"
     , "semaphores001"
@@ -261,6 +262,7 @@ nodeTests = MkTestPool "Node backend" [] (Just Node)
     , "args"
     , "bitops"
     , "casts"
+    , "memo"
     , "newints"
     , "reg001"
     , "syntax001"
diff --git a/tests/chez/memo/Memo.idr b/tests/chez/memo/Memo.idr
@@ -0,0 +1,69 @@
+-- This tests checks, whether toplevel constants are
+-- properly memoized. If they are not, this test
+-- will perform 10^20 additions and will therefore not
+-- finish in reasonable time.
+n0 : Nat
+n0 = 1
+
+n1 : Nat
+n1 = n0 + n0 + n0 + n0 + n0 + n0 + n0 + n0 + n0 + n0
+
+n2 : Nat
+n2 = n1 + n1 + n1 + n1 + n1 + n1 + n1 + n1 + n1 + n1
+
+n3 : Nat
+n3 = n2 + n2 + n2 + n2 + n2 + n2 + n2 + n2 + n2 + n2
+
+n4 : Nat
+n4 = n3 + n3 + n3 + n3 + n3 + n3 + n3 + n3 + n3 + n3
+
+n5 : Nat
+n5 = n4 + n4 + n4 + n4 + n4 + n4 + n4 + n4 + n4 + n4
+
+n6 : Nat
+n6 = n5 + n5 + n5 + n5 + n5 + n5 + n5 + n5 + n5 + n5
+
+n7 : Nat
+n7 = n6 + n6 + n6 + n6 + n6 + n6 + n6 + n6 + n6 + n6
+
+n8 : Nat
+n8 = n7 + n7 + n7 + n7 + n7 + n7 + n7 + n7 + n7 + n7
+
+n9 : Nat
+n9 = n8 + n8 + n8 + n8 + n8 + n8 + n8 + n8 + n8 + n8
+
+n10 : Nat
+n10 = n9 + n9 + n9 + n9 + n9 + n9 + n9 + n9 + n9 + n9
+
+n11 : Nat
+n11 = n10 + n10 + n10 + n10 + n10 + n10 + n10 + n10 + n10 + n10
+
+n12 : Nat
+n12 = n11 + n11 + n11 + n11 + n11 + n11 + n11 + n11 + n11 + n11
+
+n13 : Nat
+n13 = n12 + n12 + n12 + n12 + n12 + n12 + n12 + n12 + n12 + n12
+
+n14 : Nat
+n14 = n13 + n13 + n13 + n13 + n13 + n13 + n13 + n13 + n13 + n13
+
+n15 : Nat
+n15 = n14 + n14 + n14 + n14 + n14 + n14 + n14 + n14 + n14 + n14
+
+n16 : Nat
+n16 = n15 + n15 + n15 + n15 + n15 + n15 + n15 + n15 + n15 + n15
+
+n17 : Nat
+n17 = n16 + n16 + n16 + n16 + n16 + n16 + n16 + n16 + n16 + n16
+
+n18 : Nat
+n18 = n17 + n17 + n17 + n17 + n17 + n17 + n17 + n17 + n17 + n17
+
+n19 : Nat
+n19 = n18 + n18 + n18 + n18 + n18 + n18 + n18 + n18 + n18 + n18
+
+n20 : Nat
+n20 = n19 + n19 + n19 + n19 + n19 + n19 + n19 + n19 + n19 + n19
+
+main : IO ()
+main = do printLn n20
diff --git a/tests/chez/memo/expected b/tests/chez/memo/expected
@@ -0,0 +1,3 @@
+1/1: Building Memo (Memo.idr)
+Main> 100000000000000000000
+Main> Bye for now!
diff --git a/tests/chez/memo/input b/tests/chez/memo/input
@@ -0,0 +1,2 @@
+:exec main
+:q
diff --git a/tests/chez/memo/run b/tests/chez/memo/run
@@ -0,0 +1,4 @@
+rm -rf build
+
+$1 --no-banner --no-color --console-width 0 Memo.idr < input
+
diff --git a/tests/node/memo/Memo.idr b/tests/node/memo/Memo.idr
@@ -0,0 +1,69 @@
+-- This tests checks, whether toplevel constants are
+-- properly memoized. If they are not, this test
+-- will perform 10^20 additions and will therefore not
+-- finish in reasonable time.
+n0 : Nat
+n0 = 1
+
+n1 : Nat
+n1 = n0 + n0 + n0 + n0 + n0 + n0 + n0 + n0 + n0 + n0
+
+n2 : Nat
+n2 = n1 + n1 + n1 + n1 + n1 + n1 + n1 + n1 + n1 + n1
+
+n3 : Nat
+n3 = n2 + n2 + n2 + n2 + n2 + n2 + n2 + n2 + n2 + n2
+
+n4 : Nat
+n4 = n3 + n3 + n3 + n3 + n3 + n3 + n3 + n3 + n3 + n3
+
+n5 : Nat
+n5 = n4 + n4 + n4 + n4 + n4 + n4 + n4 + n4 + n4 + n4
+
+n6 : Nat
+n6 = n5 + n5 + n5 + n5 + n5 + n5 + n5 + n5 + n5 + n5
+
+n7 : Nat
+n7 = n6 + n6 + n6 + n6 + n6 + n6 + n6 + n6 + n6 + n6
+
+n8 : Nat
+n8 = n7 + n7 + n7 + n7 + n7 + n7 + n7 + n7 + n7 + n7
+
+n9 : Nat
+n9 = n8 + n8 + n8 + n8 + n8 + n8 + n8 + n8 + n8 + n8
+
+n10 : Nat
+n10 = n9 + n9 + n9 + n9 + n9 + n9 + n9 + n9 + n9 + n9
+
+n11 : Nat
+n11 = n10 + n10 + n10 + n10 + n10 + n10 + n10 + n10 + n10 + n10
+
+n12 : Nat
+n12 = n11 + n11 + n11 + n11 + n11 + n11 + n11 + n11 + n11 + n11
+
+n13 : Nat
+n13 = n12 + n12 + n12 + n12 + n12 + n12 + n12 + n12 + n12 + n12
+
+n14 : Nat
+n14 = n13 + n13 + n13 + n13 + n13 + n13 + n13 + n13 + n13 + n13
+
+n15 : Nat
+n15 = n14 + n14 + n14 + n14 + n14 + n14 + n14 + n14 + n14 + n14
+
+n16 : Nat
+n16 = n15 + n15 + n15 + n15 + n15 + n15 + n15 + n15 + n15 + n15
+
+n17 : Nat
+n17 = n16 + n16 + n16 + n16 + n16 + n16 + n16 + n16 + n16 + n16
+
+n18 : Nat
+n18 = n17 + n17 + n17 + n17 + n17 + n17 + n17 + n17 + n17 + n17
+
+n19 : Nat
+n19 = n18 + n18 + n18 + n18 + n18 + n18 + n18 + n18 + n18 + n18
+
+n20 : Nat
+n20 = n19 + n19 + n19 + n19 + n19 + n19 + n19 + n19 + n19 + n19
+
+main : IO ()
+main = do printLn n20
diff --git a/tests/node/memo/expected b/tests/node/memo/expected
@@ -0,0 +1,3 @@
+1/1: Building Memo (Memo.idr)
+Main> 100000000000000000000
+Main> Bye for now!
diff --git a/tests/node/memo/input b/tests/node/memo/input
@@ -0,0 +1,2 @@
+:exec main
+:q
diff --git a/tests/node/memo/run b/tests/node/memo/run
@@ -0,0 +1,4 @@
+rm -rf build
+
+$1 --cg node --no-banner --no-color --console-width 0 Memo.idr < input
+

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+1/1: Building Memo (Memo.idr)`
	`2`	`+Main> 100000000000000000000`
	`3`	`+Main> Bye for now!`
-Original file line number
+Diff line change
@@ @@ -0,0 +1,4 @@ @@
 +rm -rf build
++
 +$1 --no-banner --no-color --console-width 0 Memo.idr < input
++