Added engine-handler parameter and a ($swap-engine-counter! <neg-fx>)

to (ikarus system $interrupts).

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)

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

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

scheme/last-revision

@@ -1 +1 @@
-1453
+1455

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           ]

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) 

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;
 }