[Openmcl-cvs-notifications] r14807 - in /trunk/source: compiler/ level-0/ARM/ level-1/ lib/ lisp-kernel/
gb at clozure.com
gb at clozure.com
Mon May 23 07:25:45 CDT 2011
Author: gb
Date: Mon May 23 07:25:45 2011
New Revision: 14807
Log:
Define and export the functions ALLOW-HEAP-ALLOCATION and
HEAP-ALLOCATION-ALLOWED-P and the condition type ALLOCATION-DISABLED.
(ALLOW-HEAP-ALLOCATION arg) : when ARG is NIL, causes any subsequent
attempts to heap-allocate lisp memory to signal (as if by CERROR)
an ALLOCATION-DISABLED condition. (Allocaton is enabled globally at
the point where the error is signaled.) Continuing from the CERROR
restarts the allocation attempt.
This is intended to help verify that code that's not expected to
cons doesn't do so.
(This is only implemented on the ARM at the moment, but the intent
is that it be supported on all platforms.)
Note that calling (ALLOW-HEAP-ALLOCATION NIL) in the REPL CERRORs
immediately, since the REPL will cons to create the new value of CL:/.
Modified:
trunk/source/compiler/arch.lisp
trunk/source/level-0/ARM/arm-utils.lisp
trunk/source/level-1/arm-error-signal.lisp
trunk/source/level-1/l1-error-system.lisp
trunk/source/lib/ccl-export-syms.lisp
trunk/source/lisp-kernel/arm-exceptions.c
trunk/source/lisp-kernel/arm-exceptions.h
trunk/source/lisp-kernel/gc.h
trunk/source/lisp-kernel/lisp-errors.h
Modified: trunk/source/compiler/arch.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/arch.lisp (original)
+++ trunk/source/compiler/arch.lisp Mon May 23 07:25:45 2011
@@ -67,6 +67,7 @@
(defconstant error-kill 16)
(defconstant error-cant-call 17) ; Attempt to funcall something tha=
t is not a symbol or function.
(defconstant error-allocate-list 18)
+(defconstant error-allocation-disabled 19)
=
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant error-type-error 128)
@@ -355,7 +356,7 @@
(defconstant gc-trap-function-ensure-static-conses 19)
(defconstant gc-trap-function-get-gc-notification-threshold 20)
(defconstant gc-trap-function-set-gc-notification-threshold 21)
-
+(defconstant gc-trap-function-allocation-control 22)
(defconstant gc-trap-function-egc-control 32)
(defconstant gc-trap-function-configure-egc 64)
(defconstant gc-trap-function-freeze 129)
Modified: trunk/source/level-0/ARM/arm-utils.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-0/ARM/arm-utils.lisp (original)
+++ trunk/source/level-0/ARM/arm-utils.lisp Mon May 23 07:25:45 2011
@@ -417,6 +417,28 @@
(uuo-gc-trap)
(ba .SPmakeu32))
=
+(defarmlapfunction allow-heap-allocation ((arg arg_z))
+ "If ARG is true, signal an ALLOCATION-DISABLED condition on attempts
+at heap allocation."
+ (:arglist (arg))
+ (check-nargs 0)
+ (cmp arg_z (:$ arm::nil-value))
+ (mov imm0 (:$ arch::gc-trap-function-allocation-control))
+ (mov imm1 (:$ 0)) ;disallow
+ (movne imm1 (:$ 1)) ;allow if arg non-null
+ (uuo-gc-trap)
+ (bx lr))
+
+
+
+(defarmlapfunction heap-allocation-allowed-p ()
+ "Return T if heap allocation is allowed, NIL otherwise."
+ (check-nargs 0)
+ (mov imm0 (:$ arch::gc-trap-function-allocation-control))
+ (mov imm1 (:$ 2)) ;query
+ (uuo-gc-trap)
+ (bx lr))
+
(defun %watch (uvector)
(declare (ignore uvector))
(error "watching objects not supported on ARM yet"))
Modified: trunk/source/level-1/arm-error-signal.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/arm-error-signal.lisp (original)
+++ trunk/source/level-1/arm-error-signal.lisp Mon May 23 07:25:45 2011
@@ -284,6 +284,11 @@
:format-control "Stack overflow on ~a stack."
:format-arguments (list (if (eql arg arm::vsp) "value" "con=
trol")))
nil frame-ptr))
+ ((eql error-number arch::error-allocation-disabled)
+ (restart-case (%error 'allocation-disabled nil frame-ptr)
+ (continue ()
+ :report (lambda (stream)
+ (format stream "retry the heap allocati=
on.")))))
(t
(error "%errdisp callback: error-number =3D ~d, arg =3D #x~x,=
fnreg =3D ~d, rpc =3D ~d"
error-number arg fnreg relative-pc)))))
Modified: trunk/source/level-1/l1-error-system.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-error-system.lisp (original)
+++ trunk/source/level-1/l1-error-system.lisp Mon May 23 07:25:45 2011
@@ -142,6 +142,11 @@
object offset)))
(when instruction
(format s "~&Faulting instruction: ~s" instruction))))
+
+(define-condition allocation-disabled (storage-condition)
+ ()
+ (:report (lambda (c s) (declare (ignore c)) (format s "Attempt to heap-a=
llocate a lisp object when heap allocation is disabled."))))
+ =
=
(define-condition type-error (error)
((datum :initarg :datum)
Modified: trunk/source/lib/ccl-export-syms.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/ccl-export-syms.lisp (original)
+++ trunk/source/lib/ccl-export-syms.lisp Mon May 23 07:25:45 2011
@@ -736,6 +736,10 @@
object-direct-size
add-feature
remove-feature
+ ;; Disabling heap allocation (to detect unexpected consing.)
+ allow-heap-allocaton
+ heap-allocation-allowed-p
+ allocation-disabled
=
) "CCL"
)
Modified: trunk/source/lisp-kernel/arm-exceptions.c
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/arm-exceptions.c (original)
+++ trunk/source/lisp-kernel/arm-exceptions.c Mon May 23 07:25:45 2011
@@ -77,7 +77,7 @@
extern natural lisp_heap_gc_threshold;
extern Boolean grow_dynamic_area(natural);
=
-
+Boolean allocation_enabled =3D true;
=
=
=
@@ -325,6 +325,17 @@
signed_natural disp =3D 0;
unsigned allocptr_tag;
=
+ if (!allocation_enabled) {
+ /* Back up before the alloc_trap, then let pc_luser_xp() back
+ up some more. */
+ xpPC(xp)-=3D1;
+ pc_luser_xp(xp,tcr, NULL);
+ allocation_enabled =3D true;
+ tcr->save_allocbase =3D (void *)VOID_ALLOCPTR;
+ handle_error(xp, error_allocation_disabled,0,NULL);
+ return true;
+ }
+
cur_allocptr =3D xpGPR(xp,allocptr);
=
allocptr_tag =3D fulltag_of(cur_allocptr);
@@ -426,6 +437,46 @@
xpGPR(xp, imm0) =3D tenured_area->static_dnodes << dnode_shift;
break;
=
+ case GC_TRAP_FUNCTION_ALLOCATION_CONTROL:
+ switch(arg) {
+ case 0: /* disable if allocation enabled */
+ xpGPR(xp, arg_z) =3D lisp_nil;
+ if (allocation_enabled) {
+ TCR *other_tcr;
+ ExceptionInformation *other_context;
+ suspend_other_threads(true);
+ normalize_tcr(xp,tcr,false);
+ for (other_tcr=3Dtcr->next; other_tcr !=3D tcr; other_tcr =3D othe=
r_tcr->next) {
+ other_context =3D other_tcr->pending_exception_context;
+ if (other_context =3D=3D NULL) {
+ other_context =3D other_tcr->suspend_context;
+ }
+ normalize_tcr(other_context, other_tcr, true);
+ }
+ allocation_enabled =3D false;
+ xpGPR(xp, arg_z) =3D t_value;
+ resume_other_threads(true);
+ }
+ break;
+
+ case 1: /* enable if disabled */
+ xpGPR(xp, arg_z) =3D lisp_nil;
+ if (!allocation_enabled) {
+ allocation_enabled =3D true;
+ xpGPR(xp, arg_z) =3D t_value;
+ }
+ break;
+
+ default:
+ xpGPR(xp, arg_z) =3D lisp_nil;
+ if (allocation_enabled) {
+ xpGPR(xp, arg_z) =3D t_value;
+ }
+ break;
+ }
+ break;
+
+ =
default:
update_bytes_allocated(tcr, (void *) ptr_from_lispobj(xpGPR(xp, allocp=
tr)));
=
@@ -647,6 +698,7 @@
=
void
normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
+
{
void *cur_allocptr =3D NULL;
LispObj freeptr =3D 0;
@@ -1653,14 +1705,14 @@
=
if (alloc_disp) {
*alloc_disp =3D disp;
- xpGPR(xp,allocptr) +=3D disp;
+ xpGPR(xp,allocptr) -=3D disp;
/* Leave the PC at the alloc trap. When the interrupt
handler returns, it'll decrement allocptr by disp
and the trap may or may not be taken.
*/
} else {
Boolean ok =3D false;
- update_bytes_allocated(tcr, (void *) ptr_from_lispobj(cur_allocptr=
+ disp));
+ update_bytes_allocated(tcr, (void *) ptr_from_lispobj(cur_allocptr=
- disp));
xpGPR(xp, allocptr) =3D VOID_ALLOCPTR + disp;
instr =3D program_counter[-1];
if (IS_BRANCH_AROUND_ALLOC_TRAP(instr)) {
@@ -1671,8 +1723,8 @@
}
}
if (ok) {
- /* Clear the carry bit, so that the trap will be taken. */
- xpPSR(xp) &=3D ~PSR_C_MASK;
+ /* Clear the carry bit, so that the trap will be taken. */
+ xpPSR(xp) &=3D ~PSR_C_MASK;
} else {
Bug(NULL, "unexpected instruction preceding alloc trap.");
}
Modified: trunk/source/lisp-kernel/arm-exceptions.h
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/arm-exceptions.h (original)
+++ trunk/source/lisp-kernel/arm-exceptions.h Mon May 23 07:25:45 2011
@@ -167,3 +167,6 @@
#else
#define ALTSTACK(handler) handler
#endif
+
+void
+normalize_tcr(ExceptionInformation *,TCR *, Boolean);
Modified: trunk/source/lisp-kernel/gc.h
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/gc.h (original)
+++ trunk/source/lisp-kernel/gc.h Mon May 23 07:25:45 2011
@@ -154,6 +154,7 @@
#define GC_TRAP_FUNCTION_ENSURE_STATIC_CONSES 19
#define GC_TRAP_FUNCTION_GET_GC_NOTIFICATION_THRESHOLD 20
#define GC_TRAP_FUNCTION_SET_GC_NOTIFICATION_THRESHOLD 21
+#define GC_TRAP_FUNCTION_ALLOCATION_CONTROL 22
#define GC_TRAP_FUNCTION_EGC_CONTROL 32
#define GC_TRAP_FUNCTION_CONFIGURE_EGC 64
#define GC_TRAP_FUNCTION_FREEZE 129
Modified: trunk/source/lisp-kernel/lisp-errors.h
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lisp-kernel/lisp-errors.h (original)
+++ trunk/source/lisp-kernel/lisp-errors.h Mon May 23 07:25:45 2011
@@ -36,6 +36,7 @@
#define error_kill 16
#define error_cant_call 17
#define error_allocate_list 18
+#define error_allocation_disabled 19
=
#define error_type_error 128
=
More information about the Openmcl-cvs-notifications
mailing list