Ticket #993: debug993.lisp

File debug993.lisp, 865 bytes (added by uchida, 2 years ago)
Line 
1(load "quicklisp/setup")
2(ql:quickload :cffi)
3
4(defpackage :debug993
5  (:use :cl :ccl)
6  (:export :begin
7           :end
8           :get-current-tcr-debug993
9           :set-current-tcr-debug993))
10
11(in-package :debug993)
12
13(cffi:define-foreign-library libdebug993
14    (t (:default "libdebug993")))
15
16(cffi:use-foreign-library libdebug993)
17
18(cffi:defcfun ("set_debug993" set-debug993) :int
19  (tcr :int)
20  (v :int))
21
22(cffi:defcfun ("get_debug993" get-debug993) :int
23  (tcr :int))
24
25(defun get-current-tcr-debug993 ()
26  (get-debug993 (ash (ccl::%current-tcr) 2)))
27
28(defun set-current-tcr-debug993 (v)
29  (set-debug993 (ash (ccl::%current-tcr) 2) v))
30
31(defun begin ()
32  (set-current-tcr-debug993 (1+ (get-current-tcr-debug993))))
33
34(defun end ()
35  (set-current-tcr-debug993 (1- (get-current-tcr-debug993))))
36
37(advise ccl::set-hash-key-conditional
38        (prog2 (begin) (:do-it) (end))
39        :when :around)