Re: Special variables to relax boxing

[Stefan Israelsson Tampe <stefan.itampe@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 3228 bytes --]

Hi list, Mark and Noah,

Yesterday I noticed that the sematics for special variables are quite
close to fluids and decied to see if I could model special variables
ontop of that with-fluids semantics. That was pretty easy. The basic
difference between fluid and special variables is that with fluids one
swaps between the storages at the with-fluids point, both backwards
and forwards. in the case of special variables one bascially takes on
half of the swap at the wind and the other half at the unwind. So it
become quite easy to just copy the fluid logic and then slightly
modify that source. The scheme compilation part is a little hacky but
it was not that hard to plumb an acceptable solution for testing. I
did verify that it manages the value as said and noticed a 10x
increase of speed when it comes to code passing into a with-fluids
without any prompts compared to any possible setup using dynamic-wind
and fluids. The system is still pretty rough though but there are some
significant optimization implemented.

a preliminary git diff is attached for you to play with.

I did try to implement special variables in current guile. I found
that it is pretty difficult to get the correct semantics working
anyone able to spot it. I use,


(define guards (make-vector 10))
(let lp ((i 0))
  (when (< i 10) (vector-set! guards i (make-fluid))))

(define-syntax with-special-soft 
  (lambda (x)
    (syntax-case x ()
      ((_ (x ...) code ...)
       (with-syntax (((((a k) ...) (y ...))
                      (let loop ((i 0) (l #'(x ...)) (r '()))
                        (if (or (= i 10) (null? l))
                            (list (reverse r) l)
                            (loop (+ i 1) (cdr l) (cons (car l) r))))))
        (with-syntax (((i ...) (iota (length #'(a ...)))))                    
            (if (null? #'(y ...))
            #'(with-fluids (((vector-ref guards i) a) ...)
                (with-special* ((i a k) ...)
                 code ...))
            #'(with-fluids (((vector-ref guards i) a) ...)
                (with-special* ((i a k) ...)
                   (with-special-soft (y ...) code ...))))))))))

(define special-wind-guard (make-fluid (lambda (x) #t)))
(define-syntax-rule (with-special* ((i a k) ...) code ...)
  (dynamic-wind
      (lambda () 
        (set! a (fluid-ref (vector-ref guards i)))
        ...)
      (lambda () 
        code ...)
      (lambda y
        (fluid-set! (vector-ref guards i) a)
        ...)))

(define (f x) 
  (let ((s 0)) 
    (with-special-soft ((s 0)) 
       (let lp ((i 0)) 
          (cond 
             ((>= i 100) s) 
             ((= i 50) (abort-to-prompt 'tag) (lp (+ i 1))) 
             (else (set! s (+ s i)) (lp (+ i 1))))))))

(define k (call-with-prompt 'tag (lambda () (f 1)) (lambda (k . l)
k)))

scheme@(guile-user)> (k)
$1 = 4900
scheme@(guile-user)> (k)
$2 = 8575

Can you spot the bug?

The example works very well with my hardcoded version code and is as
fast as this logic can get, much better than 10x faster because this
case can be very well optimized.

To note here also is that with this code we might get into stack
issues due to the with-special can spoil tail call stack features just
as with-fluids.

WDYT?

/Stefan

[-- Attachment #2: special.diff --]
[-- Type: text/x-patch, Size: 27750 bytes --]

diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index 14dd861..76c4889 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -244,6 +244,11 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
           scm_i_swap_with_fluids (wind_elt,
                                   SCM_I_CURRENT_THREAD->dynamic_state);
 	}
+      else if (SCM_WITH_SPECIAL_P (wind_elt))
+	{
+          scm_i_with_special_from_guard (wind_elt,
+				       SCM_I_CURRENT_THREAD->dynamic_state);
+	}
       else if (SCM_PROMPT_P (wind_elt))
         ; /* pass -- see vm_reinstate_partial_continuation */
       else if (scm_is_pair (wind_elt))
@@ -277,6 +282,11 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
           scm_i_swap_with_fluids (wind_elt,
                                   SCM_I_CURRENT_THREAD->dynamic_state);
 	}
+      else if (SCM_WITH_SPECIAL_P (wind_elt))
+	{
+          scm_i_with_special_to_guard (wind_elt,
+				       SCM_I_CURRENT_THREAD->dynamic_state);
+	}
       else if (SCM_PROMPT_P (wind_elt))
         ; /* pass -- though we could invalidate the prompt */
       else if (scm_is_pair (wind_elt))
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 327d12f..c43011d 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -346,6 +346,47 @@ scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals)
 
   return ret;
 }
+
+const int nguards = 10;
+SCM guards[10];
+SCM scm_i_make_with_special (size_t n, SCM *fluids, SCM *vals)
+{
+  SCM ret;
+  if(n > nguards)
+    scm_misc_error ("with-special", 
+		    "VM with-special can maximally be called with 10 slots",
+                    SCM_EOL);
+
+  /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
+     but N will usually be small, so perhaps that's OK. */
+  {
+    size_t i, j;
+
+    for (j = n; j--;)
+      for (i = j; i--;)
+        if (scm_is_eq (fluids[i], fluids[j]))
+          {
+            vals[i] = vals[j]; /* later bindings win */
+            n--;
+            fluids[j] = fluids[n];
+            vals[j] = vals[n];
+            break;
+          }
+  }
+        
+  ret = scm_words (scm_tc7_with_special | (n << 8), 1 + n*2);
+  SCM_SET_CELL_WORD_1 (ret, n);
+
+  while (n--)
+    {
+      if (SCM_UNLIKELY ( !SCM_VARIABLEP (fluids[n])))
+        scm_wrong_type_arg ("with-special need a box as input", 0, fluids[n]);
+      SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]);
+      SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]);
+    }
+
+  return ret;
+}
   
 void
 scm_i_swap_with_fluids (SCM wf, SCM dynstate)
@@ -385,6 +426,80 @@ scm_i_swap_with_fluids (SCM wf, SCM dynstate)
       SCM_WITH_FLUIDS_SET_NTH_VAL (wf, i, x);
     }
 }
+
+void
+scm_i_with_special_to_guard (SCM wf, SCM dynstate)
+{
+  SCM fluids;
+  size_t i, max = 0;
+
+  fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+
+  /* We could cache the max in the with-fluids, but that would take more mem,
+     and we're touching all the fluids anyway, so this per-swap traversal should
+     be OK. */
+  for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++)
+    {
+      size_t num = FLUID_NUM (guards[i]);
+      max = (max > num) ? max : num;
+    }
+
+  if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+    {
+      /* Lazily grow the current thread's dynamic state.  */
+      grow_dynamic_state (dynstate);
+
+      fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+    }
+
+  /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
+  for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++)
+    {
+      size_t fluid_num;
+      
+      fluid_num = FLUID_NUM (guards[i]);
+      SCM_SIMPLE_VECTOR_SET 
+	(fluids, fluid_num,
+	 SCM_VARIABLE_REF (SCM_WITH_SPECIAL_NTH_VAR (wf, i)));
+    }
+}
+
+void
+scm_i_with_special_from_guard (SCM wf, SCM dynstate)
+{
+  SCM fluids;
+  size_t i, max = 0;
+
+  fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+
+  /* We could cache the max in the with-fluids, but that would take more mem,
+     and we're touching all the fluids anyway, so this per-swap traversal should
+     be OK. */
+  for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++)
+    {
+      size_t num = FLUID_NUM ( guards[i]);
+      max = (max > num) ? max : num;
+    }
+
+  if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+    {
+      /* Lazily grow the current thread's dynamic state.  */
+      grow_dynamic_state (dynstate);
+
+      fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+    }
+
+  /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
+  for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++)
+    {
+      size_t fluid_num;
+      SCM x;
+      
+      fluid_num = FLUID_NUM (guards[i]);
+      x = SCM_SIMPLE_VECTOR_REF (fluids, fluid_num);
+      SCM_VARIABLE_SET (SCM_WITH_SPECIAL_NTH_VAR (wf, i), x);
+    }
+}
   
 SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, 
 	    (SCM fluids, SCM values, SCM thunk),
@@ -592,6 +707,12 @@ SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state", 2, 0, 0,
 void
 scm_init_fluids ()
 {
+  int i;
+  for(i = 0; i < nguards; i++)
+  {
+    guards[i] = scm_make_fluid();
+  }
+
 #include "libguile/fluids.x"
 }
 
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 2b91ff3..6a593a7 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -38,6 +38,12 @@
 #define SCM_WITH_FLUIDS_NTH_VAL(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2))
 #define SCM_WITH_FLUIDS_SET_NTH_VAL(x,n,v) (SCM_SET_CELL_OBJECT ((x), 2 + (n)*2, (v)))
 
+#define SCM_WITH_SPECIAL_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_with_special)
+#define SCM_WITH_SPECIAL_LEN(x) (SCM_CELL_WORD ((x), 0) >> 8)
+#define SCM_WITH_SPECIAL_NTH_VAR(x,n) (SCM_CELL_OBJECT ((x), 1 + (n)*2))
+#define SCM_WITH_SPECIAL_NTH_KIND(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2))
+
+
 
 /* Fluids.
 
@@ -73,6 +79,12 @@ SCM_API SCM scm_fluid_bound_p (SCM fluid);
 SCM_INTERNAL SCM scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals);
 SCM_INTERNAL void scm_i_swap_with_fluids (SCM with_fluids, SCM dynamic_state);
 
+SCM_INTERNAL SCM scm_i_make_with_special (size_t n, SCM *fluids, SCM *vals);
+SCM_INTERNAL void scm_i_with_special_from_guard 
+(SCM with_fluids, SCM dynamic_state);
+SCM_INTERNAL void scm_i_with_special_to_guard
+(SCM with_fluids, SCM dynamic_state);
+
 SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals,
 			       SCM (*cproc)(void *), void *cdata);
 SCM_API SCM scm_c_with_fluid (SCM fluid, SCM val,
diff --git a/libguile/tags.h b/libguile/tags.h
index a3032bf..869a9d4 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -426,7 +426,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
 #define scm_tc7_program		79
 #define scm_tc7_array		85
 #define scm_tc7_bitvector	87
-#define scm_tc7_unused_20	93
+#define scm_tc7_with_special	93
 #define scm_tc7_unused_11	95
 #define scm_tc7_unused_12	101
 #define scm_tc7_unused_18	103
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 34545dd..f9e8151 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1556,6 +1556,7 @@ VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
   NEXT;
 }
 
+
 VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
 {
   SCM wf;
@@ -1565,6 +1566,30 @@ VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
   NEXT;
 }
 
+
+VM_DEFINE_INSTRUCTION (99, wind_special, "wind-special", 1, -1, 0)
+{
+  unsigned n = FETCH ();
+  SCM wf;
+  
+  SYNC_REGISTER ();
+  sp -= 2 * n;
+  CHECK_UNDERFLOW ();
+  wf = scm_i_make_with_special (n, sp + 1, sp + 1 + n);
+  NULLSTACK (2 * n);
+
+  //This is not nessesary
+  //scm_i_swap_with_special (wf, current_thread->dynamic_state);
+  scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (100, unwind_special, "unwind-special", 0, 0, 0)
+{
+  scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+  NEXT;
+}
+
 VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
 {
   size_t num;
diff --git a/module/Makefile.am b/module/Makefile.am
index c47d0b4..b07c342 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -101,6 +101,7 @@ SCHEME_LANG_SOURCES =						\
   language/scheme/decompile-tree-il.scm
 
 TREE_IL_LANG_SOURCES =						\
+  language/tree-il/special.scm					\
   language/tree-il/primitives.scm				\
   language/tree-il/effects.scm                                 	\
   language/tree-il/fix-letrec.scm                               \
@@ -337,6 +338,7 @@ OOP_SOURCES = \
   oop/goops/simple.scm
 
 SYSTEM_SOURCES =				\
+  system/vm/special-variable.scm                \
   system/vm/inspect.scm				\
   system/vm/coverage.scm			\
   system/vm/frame.scm				\
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index badce9f..50d64b8 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -151,7 +151,7 @@
     (hashq-set! res k v)
     res))
 
-(define (analyze-lexicals x)
+(define* (analyze-lexicals x #:optional (special-vars #f))
   ;; bound-vars: lambda -> (sym ...)
   ;;  all identifiers bound within a lambda
   (define bound-vars (make-hash-table))
@@ -159,6 +159,9 @@
   ;;  all identifiers referenced in a lambda, but not bound
   ;;  NB, this includes identifiers referenced by contained lambdas
   (define free-vars (make-hash-table))
+  ;; free-syms: sym -> #t
+  ;;   All variables that is free with respect to a lambda.
+  (define free-syms (make-hash-table))
   ;; assigned: sym -> #t
   ;;  variables that are assigned
   (define assigned (make-hash-table))
@@ -180,7 +183,7 @@
       (analyze! x new-proc (append labels labels-in-proc) #t #f))
     (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
     (record-case x
-      ((<application> proc args)
+      ((<application> proc args)                              
        (apply lset-union eq? (step-tail-call proc args)
               (map step args)))
 
@@ -236,6 +239,9 @@
        (let ((free (recur body x)))
          (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
          (hashq-set! free-vars x free)
+         (for-each (lambda (var)
+                     (hashq-set! free-syms var #t))
+                   free)
          free))
       
       ((<lambda-case> opt kw inits gensyms body alternate)
@@ -286,7 +292,8 @@
                      ;; recur/labels instead of recur
                      (hashq-set! bound-vars x '())
                      (let ((free (recur/labels body x gensyms)))
-                       (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
+                       (hashq-set! bound-vars x 
+                                   (reverse! (hashq-ref bound-vars x)))
                        (hashq-set! free-vars x free)
                        free))))
                 vals))
@@ -330,7 +337,11 @@
                               (append (hashq-ref bound-vars val)
                                       (hashq-ref bound-vars proc)))
                   (hashq-remove! bound-vars val)
-                  (hashq-remove! free-vars val))))
+                  (hashq-remove! free-vars val))
+                ;; Else we will allocate a closure; register the free-syms
+                (for-each (lambda (sym)
+                            (hashq-set! free-syms sym #t))
+                          (hashq-ref free-vars val))))
           gensyms vals)
          (lset-difference eq?
                           (apply lset-union eq? body-refs var-refs)
@@ -395,7 +406,12 @@
              (begin
                (hashq-set! (hashq-ref allocation (car c))
                            x
-                           `(#f ,(hashq-ref assigned (car c)) . ,n))
+                           `(#f ,(and (hashq-ref assigned (car c))
+                                      (not (and special-vars
+                                                (hashq-ref special-vars (car c))
+                                                (not (hashq-ref free-syms 
+                                                                (car c))))))
+                                . ,n))
                (lp (cdr c) (1+ n)))))
       
        (let ((nlocs (allocate! body x 0))
@@ -427,7 +443,15 @@
               (begin
                 (hashq-set! allocation (car gensyms)
                             (make-hashq
-                             proc `(#t ,(hashq-ref assigned (car gensyms)) . ,n)))
+                             proc `(#t 
+                                    ,(and (hashq-ref assigned (car gensyms))
+                                          (not (and special-vars
+                                                    (hashq-ref special-vars 
+                                                               (car gensyms))
+                                                    (not (hashq-ref 
+                                                          free-syms 
+                                                          (car gensyms))))))
+                                       . ,n)))
                 (lp (cdr gensyms) (1+ n)))))
         (if alternate (allocate! alternate proc n) n)))
       
@@ -456,7 +480,12 @@
                    (hashq-set!
                     allocation v
                     (make-hashq proc
-                                `(#t ,(hashq-ref assigned v) . ,n)))
+                                `(#t ,(and (hashq-ref assigned v)
+                                      (not (and special-vars
+                                                (hashq-ref special-vars v)
+                                                (not (hashq-ref free-syms 
+                                                                v)))))
+                                     . ,n)))
                    (lp (cdr gensyms) (1+ n)))))))))
       
       ((<letrec> gensyms vals body)
@@ -471,7 +500,12 @@
                (hashq-set!
                 allocation v
                 (make-hashq proc
-                            `(#t ,(hashq-ref assigned v) . ,n)))
+                            `(#t ,(and (hashq-ref assigned v)
+                                      (not (and special-vars
+                                                (hashq-ref special-vars v)
+                                                (not (hashq-ref free-syms 
+                                                                v)))))
+                                 . ,n)))
                (lp (cdr gensyms) (1+ n))))))
 
       ((<fix> gensyms vals body)
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index e4df6e1..b4d3836 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -29,6 +29,7 @@
   #:use-module (language tree-il optimize)
   #:use-module (language tree-il canonicalize)
   #:use-module (language tree-il analyze)
+  #:use-module (language tree-il special)
   #:use-module ((srfi srfi-1) #:select (filter-map))
   #:export (compile-glil))
 
@@ -64,9 +65,10 @@
 
   (let* ((x (make-lambda (tree-il-src x) '()
                          (make-lambda-case #f '() #f #f #f '() '() x #f)))
-         (x (optimize! x e opts))
+         (x (optimize! (optimize! x e opts) e opts))
          (x (canonicalize! x))
-         (allocation (analyze-lexicals x)))
+         (special-vars (register-special-vars x))
+         (allocation (analyze-lexicals x special-vars)))
 
     (with-fluids ((*comp-module* e))
       (values (flatten-lambda x #f allocation)
@@ -199,6 +201,19 @@
     (proc emit-code)
     (reverse out)))
 
+(define (with-special? x)
+  (record-case x
+    ((<application> src proc args)
+     (record-case proc
+       ((<module-ref> src mod name public?)
+        (and (equal? mod '(system vm special-variable))
+             (eq?    name 'w-special)
+             (= (length args) 1)
+             (car args)))
+       (else #f)))
+    (else #f)))
+
+
 (define (flatten-lambda x self-label allocation)
   (record-case x
     ((<lambda> src meta body)
@@ -229,6 +244,7 @@
     (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
     (define (comp-fix tree RA) (comp tree context RA MVRA))
 
+    ;; Use this helper to guard some syms
     ;; A couple of helpers. Note that if we are in tail context, we
     ;; won't have an RA.
     (define (maybe-emit-return)
@@ -236,6 +252,15 @@
           (emit-branch #f 'br RA)
           (if (eq? context 'tail)
               (emit-code #f (make-glil-call 'return 1)))))
+
+    (define (is-boxed? x)
+      (record-case x
+        ((<lexical-ref> src gensym)
+         (pmatch (hashq-ref (hashq-ref allocation gensym) self)
+                 ((,local? ,boxed? . ,index)
+                  boxed?)
+                 (_ #f)))
+        (else #f)))
     
     ;; After lexical binding forms in non-tail context, call this
     ;; function to clear stack slots, allowing their previous values to
@@ -255,7 +280,25 @@
                           (,loc (error "bad let var allocation" x loc))))))
                    syms))))
 
-    (record-case x
+    (if (pair? x)
+        (case (car x)
+          ((raw-ref)
+           (record-case (cdr x)
+            ((<lexical-ref> src gensym)
+             (case context
+               ((push)
+                (pmatch (hashq-ref (hashq-ref allocation gensym) self)
+                        ((,local? ,boxed? . ,index)
+                         (emit-code src 
+                                    (make-glil-lexical local? #f 'ref index)))
+                        (,loc
+                         (error "bad lexical allocation" x loc))))
+               (else
+                (error "Bad raw-ref"))))))
+          (else
+           (error "Bad pair tree-il")))
+
+     (record-case x
       ((<void>)
        (case context
          ((push vals tail)
@@ -277,7 +320,7 @@
                (comp-drop (car exps))
                (lp (cdr exps))))))
 
-      ((<application> src proc args)
+      ((<application> src proc args)       
        ;; FIXME: need a better pattern-matcher here
        (cond
         ((and (primitive-ref? proc)
@@ -1037,11 +1080,38 @@
           (if RA
               (emit-branch #f 'br RA)))))
 
-      ((<dynlet> src fluids vals body)
-       (for-each comp-push fluids)
-       (for-each comp-push vals)
-       (emit-code #f (make-glil-call 'wind-fluids (length fluids)))
-
+      ((<dynlet> src fluids vals body)             
+       (define spc  (let lp ((l (map (lambda (sym val)
+                                       (let ((sp (with-special? val)))
+                                         (and (is-boxed? sym)
+                                              sp)))
+                                     fluids vals)))
+                      (if (pair? l)
+                          (if (car l)
+                              (cons (car l) (lp (cdr l)))
+                              (lp (cdr l)))
+                          '())))
+       (define id   (lambda (x) x))
+       (define spc? (or-map with-special? vals))
+       (if (and spc? (null? spc))
+           (comp-tail body)
+           (begin
+             (if spc?           
+                 (for-each (lambda (ref)
+                             (when (is-boxed? ref)
+                                   (comp-push (cons 'raw-ref ref))))
+                           fluids)
+                 (for-each comp-push fluids))
+             
+             (if spc?
+                 (for-each comp-push spc)
+                 (for-each comp-push vals))
+       
+             (if spc?
+                 (emit-code #f (make-glil-call 'wind-special (length spc)))
+                 (emit-code #f (make-glil-call 'wind-fluids (length fluids))))
+         
+       (begin
        (case context
          ((tail)
           (let ((MV (make-label)))
@@ -1052,17 +1122,23 @@
             ;; ourselves).
             (comp-vals body MV)
             ;; one value: unwind and return
-            (emit-code #f (make-glil-call 'unwind-fluids 0))
+            (if spc?
+                (emit-code #f (make-glil-call 'unwind-special 0))
+                (emit-code #f (make-glil-call 'unwind-fluids 0)))
             (emit-code #f (make-glil-call 'return 1))
             
             (emit-label MV)
             ;; multiple values: unwind and return values
-            (emit-code #f (make-glil-call 'unwind-fluids 0))
+            (if spc?
+                (emit-code #f (make-glil-call 'unwind-special 0))
+                (emit-code #f (make-glil-call 'unwind-fluids 0)))
             (emit-code #f (make-glil-call 'return/nvalues 1))))
          
          ((push)
           (comp-push body)
-          (emit-code #f (make-glil-call 'unwind-fluids 0)))
+          (if spc?
+              (emit-code #f (make-glil-call 'unwind-special 0))
+              (emit-code #f (make-glil-call 'unwind-fluids 0))))
          
          ((vals)
           (let ((MV (make-label)))
@@ -1072,16 +1148,20 @@
             
             (emit-label MV)
             ;; multiple values: unwind and goto MVRA
-            (emit-code #f (make-glil-call 'unwind-fluids 0))
+            (if spc?
+                (emit-code #f (make-glil-call 'unwind-special 0))
+                (emit-code #f (make-glil-call 'unwind-fluids 0)))
             (emit-branch #f 'br MVRA)))
          
          ((drop)
           ;; compile body, discarding values. then unwind...
           (comp-drop body)
-          (emit-code #f (make-glil-call 'unwind-fluids 0))
+            (if spc?
+                (emit-code #f (make-glil-call 'unwind-special 0))
+                (emit-code #f (make-glil-call 'unwind-fluids 0)))
           ;; and fall through, or goto RA if there is one.
           (if RA
-              (emit-branch #f 'br RA)))))
+              (emit-branch #f 'br RA))))))))
 
       ((<dynref> src fluid)
        (case context
@@ -1202,4 +1282,4 @@
           (emit-code #f (make-glil-mv-bind 1 #f)))
          ((vals)
           ;; Go to MVRA.
-          (emit-branch #f 'br MVRA)))))))
+          (emit-branch #f 'br MVRA))))))))
diff --git a/module/language/tree-il/special.scm b/module/language/tree-il/special.scm
new file mode 100644
index 0000000..0e38084
--- /dev/null
+++ b/module/language/tree-il/special.scm
@@ -0,0 +1,104 @@
+(define-module (language tree-il special)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:use-module (system base syntax)
+  #:use-module (system base message)
+  #:use-module (system vm program)
+  #:use-module (language tree-il)
+  #:use-module (system base pmatch)
+  #:export (register-special-vars))
+
+
+(define (register-special-vars x)
+  (define register (make-hash-table))
+  (let lp ((x x))
+    (record-case x
+      ((<application> proc args)                              
+       (record-case proc
+         ((<module-ref> src mod name public?)
+          (if (and (equal? mod '(system vm special-variable))
+                   (eq?    name 'special)
+                   (= (length args) 1))
+              (record-case (car args)
+                ((<lexical-ref> src gensym)
+                 (hashq-set! register gensym #t))
+                (else #t))))
+         (else #f))
+       (lp proc)
+       (for-each lp args))
+
+      ((<conditional> test consequent alternate)
+       (lp test)
+       (lp consequent)
+       (lp alternate))
+
+          
+      ((<lexical-set> gensym exp)
+       (lp exp))
+
+      ((<module-set> exp)
+       (lp exp))
+      
+      ((<toplevel-set> exp)
+       (lp exp))
+      
+      ((<toplevel-define> exp)
+       (lp exp))
+      
+      ((<sequence> exps)
+       (for-each lp exps))
+
+      ((<lambda> body)
+       (lp body))
+      
+      ((<lambda-case> opt kw inits gensyms body alternate)
+       (for-each lp inits)
+       (lp body)
+       (if alternate (lp alternate)))
+      
+      ((<let> gensyms vals body)
+       (for-each lp vals)
+       (lp body))
+
+      ((<letrec> gensyms vals body)
+       (for-each lp vals)
+       (lp body))
+      
+      ((<fix> gensyms vals body)
+       (for-each lp vals)
+       (lp body))
+
+      ((<let-values> exp body)
+       (lp exp)
+       (lp body))
+      
+      ((<dynwind> body winder unwinder)
+       (lp body)
+       (lp winder)
+       (lp unwinder))
+      
+      ((<dynlet> fluids vals body)
+       (lp body)
+       (for-each lp (append fluids vals)))
+          
+      ((<dynref> fluid)
+       (lp fluid))
+      
+      ((<dynset> fluid exp)
+       (lp fluid) (lp exp))
+      
+      ((<prompt> tag body handler)
+       (lp tag) 
+       (lp body) 
+       (lp handler))
+      
+      ((<abort> tag args tail)
+       (lp tag) (lp tail) (for-each lp args))
+      
+      (else #t)))
+  register)
+
diff --git a/module/system/vm/special-variable.scm b/module/system/vm/special-variable.scm
new file mode 100644
index 0000000..99cc497
--- /dev/null
+++ b/module/system/vm/special-variable.scm
@@ -0,0 +1,85 @@
+(define-module (system vm special-variable)
+  #:export (with-special with-special-soft special-wind-guard))
+
+(define special      (lambda (x) x))
+(define w-special (lambda (x) x))
+
+(define-syntax-rule (mark-as-special v ...)
+  (begin
+    (special v)
+    ...
+    (if #f #f)))
+
+;; This will allocate guard on the stack as a boxed value
+(define (make-winder l)
+  (lambda ()
+    (let loop ((l l))
+      (if (pair? l)
+          (let ((c (car l)))
+            (variable-set! (cdr c) (car c))
+            (loop (cdr l)))
+          (if #f #f)))))
+
+(define (make-unwinder l)
+  (lambda ()
+    (let loop ((l l))
+      (if (pair? l)
+          (let ((c (car l)))
+            (set-car! c (variable-ref (cdr c)))
+            (loop (cdr l)))
+          (if #f #f)))))
+
+(define-syntax with-special 
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (x ...) code ...)
+       (with-syntax (((((a k) ...) (y ...))
+                      (let loop ((i 0) (l #'(x ...)) (r '()))
+                        (if (or (= i 10) (null? l))
+                            (list (reverse r) l)
+                            (loop (+ i 1) (cdr l) (cons (car l) r))))))
+        (if (null? #'(y ...))
+            #'(with-fluids ((a (w-special k)) ...)
+                 (mark-as-special a) ...
+                 code ...)
+            #'(with-fluids ((a (w-special k)) ...)
+                 (mark-as-special a) ...
+                 (with-special (y ...) code ...))))))))
+
+(define guards (make-vector 10))
+(let lp ((i 0))
+  (when (< i 10) (vector-set! guards i (make-fluid))))
+
+(define-syntax with-special-soft 
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (x ...) code ...)
+       (with-syntax (((((a k) ...) (y ...))
+                      (let loop ((i 0) (l #'(x ...)) (r '()))
+                        (if (or (= i 10) (null? l))
+                            (list (reverse r) l)
+                            (loop (+ i 1) (cdr l) (cons (car l) r))))))
+        (with-syntax (((i ...) (iota (length #'(a ...)))))                    
+            (if (null? #'(y ...))
+            #'(with-fluids (((vector-ref guards i) a) ...)
+                (with-special* ((i a k) ...)
+                 code ...))
+            #'(with-fluids (((vector-ref guards i) a) ...)
+                (with-special* ((i a k) ...)
+                   (with-special-soft (y ...) code ...))))))))))
+
+(define special-wind-guard (make-fluid (lambda (x) #t)))
+(define-syntax-rule (with-special* ((i a k) ...) code ...)
+  (dynamic-wind
+      (lambda () 
+        (when ((fluid-ref special-wind-guard) k)            
+              (set! a (fluid-ref (vector-ref guards i))))
+        ...)
+      (lambda () 
+        code ...)
+      (lambda y
+        (fluid-set! (vector-ref guards i) a)
+        ...)))
+
+
+