From 49d5d2c5e60e10566b8e87ea7956e8775b1325bc Mon Sep 17 00:00:00 2001
From: nebuli <nebu@kipple>
Date: Sat, 22 Nov 2014 20:13:07 +0100
Subject: [PATCH 3/4] guix: Add schedule module.

* guix/schedule.scm: New file. To handle --cores and --max-jobs
  options in 'guix build'.
* Makefile.am (MODULES): Add *this.
---
 Makefile.am       |   1 +
 guix/schedule.scm | 102 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 103 insertions(+)
 create mode 100644 guix/schedule.scm

diff --git a/Makefile.am b/Makefile.am
index 5c4ce90..1806a05 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -56,6 +56,7 @@ MODULES =					\
   guix/ftp-client.scm				\
   guix/http-client.scm				\
   guix/gnupg.scm				\
+  guix/schedule.scm				\
   guix/store.scm				\
   guix/svn-download.scm				\
   guix/ui.scm					\
diff --git a/guix/schedule.scm b/guix/schedule.scm
new file mode 100644
index 0000000..26c7b6b
--- /dev/null
+++ b/guix/schedule.scm
@@ -0,0 +1,102 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Nebulieu <nebu@kipple>
+;;;
+;;; 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 schedule)
+  #:use-module (guix records)
+  #:export (schedule?
+            schedule
+            schedule-name
+            schedule-max-cores
+            schedule-max-jobs
+            schedule-override-cores?
+            schedule-override-jobs?
+
+            make-schedule-sane))
+
+(define-record-type* <schedule>
+  schedule make-schedule
+  schedule?
+  (name      schedule-name                    ; symbol
+             (default 'serial))
+  (max-cores schedule-max-cores               ; non-negative integer
+             (default 0))                     ; use all available horse-power
+  (max-jobs  schedule-max-jobs                ; non-negative integer
+             (default 1))                     ; there can be only one
+  ;; unused, for now, rethink "unified" override
+  (override-cores?  schedule-override-cores?  ; boolean
+                    (default #t))
+  (override-jobs?   schedule-override-jobs?   ; boolean
+                    (default #t)))
+
+; will rather need one `make-schedule-with-name` and switch on 'symbol
+(define (make-schedule-serial)
+  (schedule))
+; redundant for now...
+
+; macro?
+(define (real-schedule symname cores jobs
+                       override-c override-j)
+  (schedule
+   (name            symname)
+   (max-cores       cores)
+   (max-jobs        jobs)
+   (override-cores? override-c)
+   (override-jobs?  override-j)))
+
+; better name?
+(define (>1 num)
+  (if (< num 1)
+      1
+      num))
+
+;; TODO: increase number of jobs with spare cores??? perhaps in real-schedule
+(define* (make-schedule-sane #:key max-cores max-jobs)
+  (let ((sym-name       'serial-sane)
+        ;; should overriding one override both (think: yes, e.g.
+        ;; setting cores to max with guix-daemon default [max-jobs = 0]
+        ;; will again lead to the N^2 phenomenon...
+        (override-cores (and max-cores #t))
+        (override-jobs  (and max-jobs #t))
+        ;; scheduling needs be centralized (think: override always)
+        (max-threads    (min (current-processor-count)
+                             (total-processor-count))))
+    (let ((default-max-cores (>1 (- max-threads 1)))
+          (default-max-jobs  1)
+          (validate (lambda (arg default)
+                      (if (or (not arg)
+                              (not (integer? arg)))
+                          default
+                          (or (and (= arg 0) max-threads)
+                              (and (< arg 0) default)
+                              arg)))))
+                           ;; perhaps we shouldn't be so symmetrical?
+      (let ((cores (validate max-cores default-max-cores))
+            (jobs  (validate max-jobs  default-max-jobs)))
+                      ;; cut-off
+        (let loop ((c (min cores max-threads))
+                   (j (min jobs max-threads)))
+          (let ((threads (* c j)))     
+            (if (<= threads max-threads)
+                (real-schedule sym-name c j
+                               override-cores override-jobs)
+                ;; maximize cores at the cost of jobs...
+                (let ((j- (>1 (- j 1))))
+                  (if (<= (* c j-) max-threads)
+                      (real-schedule sym-name c j-
+                                     override-cores override-jobs)
+                      (loop (>1 (- c 1)) j-))))))))))
-- 
2.1.2