guix-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

01/05: Add (guix memoization).


From: Ludovic CourtŤs
Subject: 01/05: Add (guix memoization).
Date: Sat, 28 Jan 2017 17:58:59 +0000 (UTC)

civodul pushed a commit to branch master
in repository guix.

commit f9704f179a5160013c4a401dce3761714bba8e72
Author: Ludovic Courtès <address@hidden>
Date:   Sat Jan 28 16:33:57 2017 +0100

    Add (guix memoization).
    
    * guix/combinators.scm (memoize): Remove.
    * guix/memoization.scm: New file.
    * Makefile.am (MODULES): Add it.
    * gnu/packages.scm, gnu/packages/bootstrap.scm,
    guix/build-system/gnu.scm, guix/build-system/python.scm,
    guix/derivations.scm, guix/gnu-maintenance.scm,
    guix/import/cran.scm, guix/import/elpa.scm,
    guix/modules.scm, guix/scripts/build.scm,
    guix/scripts/graph.scm, guix/scripts/lint.scm,
    guix/store.scm, guix/utils.scm: Adjust imports accordingly.
---
 .dir-locals.el               |    2 +
 Makefile.am                  |    3 +-
 gnu/packages.scm             |    3 +-
 gnu/packages/bootstrap.scm   |    4 +-
 guix/build-system/gnu.scm    |    4 +-
 guix/build-system/python.scm |    4 +-
 guix/combinators.scm         |   18 +------
 guix/derivations.scm         |    1 +
 guix/gnu-maintenance.scm     |    2 +-
 guix/import/cran.scm         |    4 +-
 guix/import/elpa.scm         |    3 +-
 guix/memoization.scm         |  114 ++++++++++++++++++++++++++++++++++++++++++
 guix/modules.scm             |    4 +-
 guix/scripts/build.scm       |    1 -
 guix/scripts/graph.scm       |    4 +-
 guix/scripts/lint.scm        |    2 +-
 guix/store.scm               |    2 +-
 guix/utils.scm               |    2 +-
 18 files changed, 140 insertions(+), 37 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index adcc50c..917fd30 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -52,6 +52,8 @@
    (eval . (put 'with-derivation-narinfo 'scheme-indent-function 1))
    (eval . (put 'with-derivation-substitute 'scheme-indent-function 2))
 
+   (eval . (put 'mlambda 'scheme-indent-function 1))
+   (eval . (put 'mlambdaq 'scheme-indent-function 1))
    (eval . (put 'syntax-parameterize 'scheme-indent-function 1))
    (eval . (put 'with-monad 'scheme-indent-function 1))
    (eval . (put 'mbegin 'scheme-indent-function 1))
diff --git a/Makefile.am b/Makefile.am
index c13d0df..360c356 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+# Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 # Copyright © 2013 Andreas Enge <address@hidden>
 # Copyright © 2015 Alex Kost <address@hidden>
 # Copyright © 2016 Mathieu Lirzin <address@hidden>
@@ -39,6 +39,7 @@ MODULES =                                     \
   guix/pk-crypto.scm                           \
   guix/pki.scm                                 \
   guix/combinators.scm                         \
+  guix/memoization.scm                         \
   guix/utils.scm                               \
   guix/sets.scm                                        \
   guix/modules.scm                             \
diff --git a/gnu/packages.scm b/gnu/packages.scm
index f55c294..ec24734 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2013 Mark H Weaver <address@hidden>
 ;;; Copyright © 2014 Eric Bavier <address@hidden>
 ;;; Copyright © 2016 Alex Kost <address@hidden>
@@ -24,6 +24,7 @@
   #:use-module (guix packages)
   #:use-module (guix ui)
   #:use-module (guix utils)
+  #:use-module (guix memoization)
   #:use-module (guix combinators)
   #:use-module ((guix build utils)
                 #:select ((package-name->name+version
diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm
index dd922c3..7cde51f 100644
--- a/gnu/packages/bootstrap.scm
+++ b/gnu/packages/bootstrap.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2014, 2015 Mark H Weaver <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -28,7 +28,7 @@
   #:use-module ((guix store) #:select (add-to-store add-text-to-store))
   #:use-module ((guix derivations) #:select (derivation))
   #:use-module ((guix utils) #:select (gnu-triplet->nix-system))
-  #:use-module (guix combinators)
+  #:use-module (guix memoization)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index f6df183..f05ddf9 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,7 +19,7 @@
 (define-module (guix build-system gnu)
   #:use-module (guix store)
   #:use-module (guix utils)
-  #:use-module (guix combinators)
+  #:use-module (guix memoization)
   #:use-module (guix derivations)
   #:use-module (guix search-paths)
   #:use-module (guix build-system)
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index d4d3d28..bfe0eca 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2013 Andreas Enge <address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
 ;;;
@@ -21,7 +21,7 @@
 (define-module (guix build-system python)
   #:use-module (guix store)
   #:use-module (guix utils)
-  #:use-module (guix combinators)
+  #:use-module (guix memoization)
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix search-paths)
diff --git a/guix/combinators.scm b/guix/combinators.scm
index 9e4689b..11cad62 100644
--- a/guix/combinators.scm
+++ b/guix/combinators.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2014 Eric Bavier <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -20,8 +20,7 @@
 (define-module (guix combinators)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
-  #:export (memoize
-            fold2
+  #:export (fold2
             fold-tree
             fold-tree-leaves
             compile-time-value))
@@ -33,19 +32,6 @@
 ;;;
 ;;; Code:
 
-(define (memoize proc)
-  "Return a memoizing version of PROC."
-  (let ((cache (make-hash-table)))
-    (lambda args
-      (let ((results (hash-ref cache args)))
-        (if results
-            (apply values results)
-            (let ((results (call-with-values (lambda ()
-                                               (apply proc args))
-                             list)))
-              (hash-set! cache args results)
-              (apply values results)))))))
-
 (define fold2
   (case-lambda
     ((proc seed1 seed2 lst)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index b712c50..056b116 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -31,6 +31,7 @@
   #:use-module (ice-9 vlist)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:use-module (guix memoization)
   #:use-module (guix combinators)
   #:use-module (guix monads)
   #:use-module (guix hash)
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index e4151c6..05ea192 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -30,7 +30,7 @@
   #:use-module (guix http-client)
   #:use-module (guix ftp-client)
   #:use-module (guix utils)
-  #:use-module (guix combinators)
+  #:use-module (guix memoization)
   #:use-module (guix records)
   #:use-module (guix upstream)
   #:use-module (guix packages)
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 463a255..40cdea0 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2016 Ricardo Wurmus <address@hidden>
-;;; Copyright © 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,7 +27,7 @@
   #:use-module (srfi srfi-41)
   #:use-module (ice-9 receive)
   #:use-module (web uri)
-  #:use-module (guix combinators)
+  #:use-module (guix memoization)
   #:use-module (guix http-client)
   #:use-module (guix hash)
   #:use-module (guix store)
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index 96cf5bb..c0b0c41 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Federico Beffa <address@hidden>
-;;; Copyright © 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,7 +35,6 @@
   #:use-module (guix base32)
   #:use-module (guix upstream)
   #:use-module (guix packages)
-  #:use-module ((guix combinators) #:select (memoize))
   #:use-module ((guix utils) #:select (call-with-temporary-output-file))
   #:export (elpa->guix-package
             %elpa-updater))
diff --git a/guix/memoization.scm b/guix/memoization.scm
new file mode 100644
index 0000000..d64f60f
--- /dev/null
+++ b/guix/memoization.scm
@@ -0,0 +1,114 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix memoization)
+  #:export (memoize
+            mlambda
+            mlambdaq))
+
+(define-syntax-rule (call/mv thunk)
+  (call-with-values thunk list))
+(define-syntax-rule (return/mv lst)
+  (apply values lst))
+
+(define-syntax-rule (call/1 thunk)
+  (thunk))
+(define-syntax-rule (return/1 value)
+  value)
+
+(define %nothing                                  ;nothingness
+  (list 'this 'is 'nothing))
+
+(define-syntax define-cache-procedure
+  (syntax-rules ()
+    "Define a procedure NAME that implements a cache using HASH-REF and
+HASH-SET!.  Use CALL to invoke the thunk and RETURN to return its value; CALL
+and RETURN are used to distinguish between multiple-value and single-value
+returns."
+    ((_ name hash-ref hash-set! call return)
+     (define (name cache key thunk)
+       "Cache the result of THUNK under KEY in CACHE, or return the
+already-cached result."
+       (let ((results (hash-ref cache key %nothing)))
+         (if (eq? results %nothing)
+             (let ((results (call thunk)))
+               (hash-set! cache key results)
+               (return results))
+             (return results)))))
+    ((_ name hash-ref hash-set!)
+     (define-cache-procedure name hash-ref hash-set!
+       call/mv return/mv))))
+
+(define-cache-procedure cached/mv  hash-ref hash-set!)
+(define-cache-procedure cachedq/mv hashq-ref hashq-set!)
+(define-cache-procedure cached  hash-ref hash-set! call/1 return/1)
+(define-cache-procedure cachedq hashq-ref hashq-set! call/1 return/1)
+
+(define (memoize proc)
+  "Return a memoizing version of PROC.
+
+This is a generic version of 'mlambda' what works regardless of the arity of
+'proc'.  It is more expensive since the argument list is always allocated, and
+the result is returned via (apply values results)."
+  (let ((cache (make-hash-table)))
+    (lambda args
+      (cached/mv cache args
+                 (lambda ()
+                   (apply proc args))))))
+
+(define-syntax %mlambda
+  (syntax-rules ()
+    "Return a memoizing lambda.  This is restricted to procedures that return
+exactly one value."
+    ((_ cached () body ...)
+     ;; The zero-argument case is equivalent to a promise.
+     (let ((result #f) (cached? #f))
+       (lambda ()
+         (unless cached?
+           (set! result (begin body ...))
+           (set! cached? #t))
+         result)))
+
+    ;; Optimize the fixed-arity case such that there's no argument list
+    ;; allocated.  XXX: We can't really avoid the closure allocation since
+    ;; Guile 2.0's compiler will always keep it.
+    ((_ cached (arg) body ...)                    ;one argument
+     (let ((cache (make-hash-table))
+           (proc  (lambda (arg) body ...)))
+       (lambda (arg)
+         (cached cache arg (lambda () (proc arg))))))
+    ((_ _ (args ...) body ...)                    ;two or more arguments
+     (let ((cache (make-hash-table))
+           (proc  (lambda (args ...) body ...)))
+       (lambda (args ...)
+         ;; XXX: Always use 'cached', which uses 'equal?', to compare the
+         ;; argument lists.
+         (cached cache (list args ...)
+                 (lambda ()
+                   (proc args ...))))))))
+
+(define-syntax-rule (mlambda formals body ...)
+  "Define a memoizing lambda.  The lambda's arguments are compared with
+'equal?', and BODY is expected to yield a single return value."
+  (%mlambda cached formals body ...))
+
+(define-syntax-rule (mlambdaq formals body ...)
+  "Define a memoizing lambda.  If FORMALS lists a single argument, it is
+compared using 'eq?'; otherwise, the argument list is compared using 'equal?'.
+BODY is expected to yield a single return value."
+  (%mlambda cachedq formals body ...))
diff --git a/guix/modules.scm b/guix/modules.scm
index 24f613f..2ff9400 100644
--- a/guix/modules.scm
+++ b/guix/modules.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016, 2017 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,7 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix modules)
-  #:use-module ((guix utils) #:select (memoize))
+  #:use-module (guix memoization)
   #:use-module (guix sets)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index d7d71b7..68402fd 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -24,7 +24,6 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix grafts)
-  #:use-module (guix combinators)
 
   ;; Use the procedure that destructures "NAME-VERSION" forms.
   #:use-module ((guix utils) #:hide (package-name->name+version))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 79ce503..8c82d89 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,12 +21,12 @@
   #:use-module (guix graph)
   #:use-module (guix grafts)
   #:use-module (guix scripts)
-  #:use-module (guix combinators)
   #:use-module (guix packages)
   #:use-module (guix monads)
   #:use-module (guix store)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
+  #:use-module (guix memoization)
   #:use-module ((guix build-system gnu) #:select (standard-packages))
   #:use-module (gnu packages)
   #:use-module (guix sets)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index afc1369..cb64dc8 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -32,7 +32,7 @@
   #:use-module (guix records)
   #:use-module (guix ui)
   #:use-module (guix utils)
-  #:use-module (guix combinators)
+  #:use-module (guix memoization)
   #:use-module (guix scripts)
   #:use-module (guix gnu-maintenance)
   #:use-module (guix monads)
diff --git a/guix/store.scm b/guix/store.scm
index 7152a55..491cd5a 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -19,7 +19,7 @@
 (define-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix config)
-  #:use-module (guix combinators)
+  #:use-module (guix memoization)
   #:use-module (guix serialization)
   #:use-module (guix monads)
   #:autoload   (guix base32) (bytevector->base32-string)
diff --git a/guix/utils.scm b/guix/utils.scm
index ee06e47..8aa2cb7 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -33,7 +33,7 @@
   #:use-module (ice-9 binary-ports)
   #:autoload   (rnrs io ports) (make-custom-binary-input-port)
   #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
-  #:use-module (guix combinators)
+  #:use-module (guix memoization)
   #:use-module ((guix build utils) #:select (dump-port))
   #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
   #:use-module (ice-9 vlist)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]