From d8cd4f0acf9cd0daace043114b086c4fd6388aa7 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Tue, 29 Apr 2008 00:10:49 -0400
Subject: [PATCH] Added engine-handler parameter and a ($swap-engine-counter!
 <neg-fx>) to (ikarus system $interrupts).

---
 scheme/ikarus.compiler.altcogen.ss |  2 +-
 scheme/ikarus.compiler.ss          | 24 ------------------------
 scheme/ikarus.handlers.ss          | 22 +++++++++++++++++-----
 scheme/last-revision               |  2 +-
 scheme/makefile.ss                 |  2 ++
 scheme/pass-specify-rep-primops.ss | 11 ++++++++++-
 src/ikarus-main.c                  |  2 +-
 7 files changed, 32 insertions(+), 33 deletions(-)

diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss
index cf3a814..dbf6cc3 100644
--- a/scheme/ikarus.compiler.altcogen.ss
+++ b/scheme/ikarus.compiler.altcogen.ss
@@ -2650,7 +2650,7 @@
           (let ([l (or (exception-label)
                        (error who "no exception label"))])
             (cons* 
-              `(addl 1 ,(R (make-disp (car rands) (cadr rands))))
+              `(addl ,(D (caddr rands)) ,(R (make-disp (car rands) (cadr rands))))
               `(je ,l)
               ac))]
          [(fl:double->single)
diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss
index e8030b1..ae0d046 100644
--- a/scheme/ikarus.compiler.ss
+++ b/scheme/ikarus.compiler.ss
@@ -2401,30 +2401,6 @@
       v)))
 
 
-
-
-(define (insert-engine-checks x)
-  (define (Tail x)
-    (make-seq
-      (make-interrupt-call 
-        (make-primcall '$engine-check '())
-        (make-funcall (make-primref '$do-event) '()))
-      x))
-  (define (CaseExpr x)
-    (struct-case x 
-      [(clambda-case info body)
-       (make-clambda-case info (Tail body))]))
-  (define (CodeExpr x)
-    (struct-case x
-      [(clambda L cases cp free name)
-       (make-clambda L (map CaseExpr cases) cp free name)]))
-  (define (CodesExpr x)
-    (struct-case x 
-      [(codes list body)
-       (make-codes (map CodeExpr list) (Tail body))]))
-  (CodesExpr x))
-
-
 (begin ;;; DEFINITIONS
   (module (wordsize)
     (include "ikarus.config.ss"))
diff --git a/scheme/ikarus.handlers.ss b/scheme/ikarus.handlers.ss
index 0842806..cedd7a0 100644
--- a/scheme/ikarus.handlers.ss
+++ b/scheme/ikarus.handlers.ss
@@ -38,8 +38,8 @@
     $incorrect-args-error-handler $multiple-values-error $debug
     $underflow-misaligned-error top-level-value-error car-error
     cdr-error fxadd1-error fxsub1-error cadr-error fx+-type-error
-    fx+-types-error fx+-overflow-error $do-event)
-  (import (except (ikarus) interrupt-handler)
+    fx+-types-error fx+-overflow-error $do-event engine-handler)
+  (import (except (ikarus) interrupt-handler engine-handler)
           (only (ikarus system $interrupts) $interrupted? $unset-interrupted!))
 
   (define interrupt-handler
@@ -57,6 +57,14 @@
             x
             (die 'interrupt-handler "not a procedure" x)))))
 
+  (define engine-handler
+    (make-parameter
+      void
+      (lambda (x)
+        (if (procedure? x)
+            x
+            (die 'engine-handler "not a procedure" x)))))
+
   (define $apply-nonprocedure-error-handler
     (lambda (x)
       (die 'apply "not a procedure" x)))
@@ -128,7 +136,11 @@
   
   (define $do-event
     (lambda ()
-      (when ($interrupted?)
-        ($unset-interrupted!)
-        ((interrupt-handler)))))
+      (cond
+        [($interrupted?)
+         ($unset-interrupted!)
+         ((interrupt-handler))]
+        [else
+         ((engine-handler))])))
+
   )
diff --git a/scheme/last-revision b/scheme/last-revision
index 414c7cc..7105d93 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1453
+1455
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 89f9e9d..d2d86b2 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -372,6 +372,7 @@
     [call/cf                                     i]
     [print-error                                 i]
     [interrupt-handler                           i]
+    [engine-handler                              i]
     [assembler-output                            i]
     [new-cafe                                    i]
     [expand                                      i]
@@ -543,6 +544,7 @@
     [$make-values-procedure                      $stack]
     [$interrupted?                               $interrupts]
     [$unset-interrupted!                         $interrupts]
+    [$swap-engine-counter!                       $interrupts]
     [interrupted-condition?                      interrupts]
     [make-interrupted-condition                  interrupts]
     [$apply-nonprocedure-error-handler           ]
diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss
index 0210e20..9170717 100644
--- a/scheme/pass-specify-rep-primops.ss
+++ b/scheme/pass-specify-rep-primops.ss
@@ -2026,7 +2026,16 @@
   [(E) 
    (begin
      (interrupt)
-     (prm 'incr/zero? pcr (K pcb-engine-counter)))])
+     (prm 'incr/zero? pcr (K pcb-engine-counter) 
+          (K (fxsll 1 fx-shift))))])
+
+(define-primop $swap-engine-counter! unsafe
+  [(V x) 
+   ;;; FIXME: should be atomic swap instead of load and set!
+   (with-tmp ([x0 (T x)])
+     (with-tmp ([t (prm 'mref pcr (K pcb-engine-counter))])
+       (prm 'mset pcr (K pcb-engine-counter) x0)
+       t))])
 
 (define-primop $stack-overflow-check unsafe
   [(E) 
diff --git a/src/ikarus-main.c b/src/ikarus-main.c
index aa36789..e9b6864 100644
--- a/src/ikarus-main.c
+++ b/src/ikarus-main.c
@@ -218,7 +218,7 @@ Notice how the bsd manpages have incorrect type for the handler.
 #endif
 
 void handler(int signo, siginfo_t* info, void* uap){
-  the_pcb->engine_counter = -1;
+  the_pcb->engine_counter = fix(-1);
   the_pcb->interrupted = 1;
 }