From 0aa8d4e1f131afbe0b9708354b8645695844e719 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Sat, 20 Jul 2013 15:19:00 +0200
Subject: Experimental pseudo-improvements.

...that cause random MEMORY-FAULT-ERRORs.
---
 sb-eval2.lisp | 31 ++++++++++++++++++++++---------
 1 file changed, 22 insertions(+), 9 deletions(-)

(limited to 'sb-eval2.lisp')

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index 6ad54ed..a08b16d 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -440,6 +440,23 @@
        (incf ,x ,num)
        ,old-x)))
 
+(sb-c:def-ir1-translator current-binding-pointer (() start next result)
+  (sb-c::ir1-convert
+   start next result
+   `(sb-sys:%primitive sb-c:current-binding-pointer)))
+
+(sb-c:def-ir1-translator unbind-to-here ((bs) start next result)
+  (sb-c::ir1-convert
+   start next result
+   `(sb-sys:%primitive sb-c:unbind-to-here ,bs)))
+
+(sb-c:def-ir1-translator bind ((var val) start next result)
+  (sb-c::ir1-convert
+   start next result
+   `(let ((val ,val))
+      (sb-c::about-to-modify-symbol-value ',var 'progv val t)
+      (sb-sys:%primitive sb-c:bind val ,var))))
+
 (declaim (ftype (function * eval-closure) prepare-lambda))
 (defun prepare-lambda (lambda-form context)
   (destructuring-bind (lambda-list &rest exprs) lambda-form
@@ -512,9 +529,7 @@
                           (my-default-values* default-values*)
                           (my-keywords keywords)
                           (my-varspecs varspecs)
-                          (saved-binding-pointer
-                            (sb-c::%primitive
-                             sb-c::current-binding-pointer))
+                          (saved-binding-pointer (current-binding-pointer))
                           (argi 0)  ;how many actual arguments have
                                     ;been processed
                           (vari 0)  ;how many lexical vars have been
@@ -532,12 +547,11 @@
                                       (setf
                                        (environment-value *new-env* 0 (incff vari))
                                        value)
-                                      (progn
+                                      (let ((var (cdr varspec)))
                                         (assert (eq :special
                                                     (car varspec))
                                                 (varspec))
-                                        (sb-c::%primitive
-                                         sb-c::bind value (cdr varspec))))))))
+                                        (bind var value)))))))
                        (declare (inline push-args))
                        (prog ()
                         positional
@@ -623,9 +637,8 @@
                         final-call
                           (return
                             (unwind-protect
-                                 (funcall body* *new-env*)
-                              (sb-c::%primitive
-                               sb-c::unbind-to-here saved-binding-pointer))))))))
+                                 (funcall body* new-env)
+                              (unbind-to-here saved-binding-pointer))))))))
               ;;(declare (inline handle-arguments))
               (if envp
                   (lambda (env)
-- 
cgit v1.2.3