Changeset 14807


Ignore:
Timestamp:
May 23, 2011, 12:25:45 PM (9 years ago)
Author:
gb
Message:

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:/.

Location:
trunk/source
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/arch.lisp

    r13792 r14807  
    6868(defconstant error-cant-call 17)        ; Attempt to funcall something that is not a symbol or function.
    6969(defconstant error-allocate-list 18)
     70(defconstant error-allocation-disabled 19)
    7071
    7172(eval-when (:compile-toplevel :load-toplevel :execute)
     
    356357(defconstant gc-trap-function-get-gc-notification-threshold 20)
    357358(defconstant gc-trap-function-set-gc-notification-threshold 21)
    358 
     359(defconstant gc-trap-function-allocation-control 22)
    359360(defconstant gc-trap-function-egc-control 32)
    360361(defconstant gc-trap-function-configure-egc 64)
  • trunk/source/level-0/ARM/arm-utils.lisp

    r14518 r14807  
    418418  (ba .SPmakeu32))
    419419
     420(defarmlapfunction allow-heap-allocation ((arg arg_z))
     421  "If ARG is true, signal an ALLOCATION-DISABLED condition on attempts
     422at heap allocation."
     423  (:arglist (arg))
     424  (check-nargs 0)
     425  (cmp arg_z (:$ arm::nil-value))
     426  (mov imm0 (:$ arch::gc-trap-function-allocation-control))
     427  (mov imm1 (:$ 0))                     ;disallow
     428  (movne imm1 (:$ 1))                   ;allow if arg non-null
     429  (uuo-gc-trap)
     430  (bx lr))
     431
     432
     433
     434(defarmlapfunction heap-allocation-allowed-p ()
     435  "Return T if heap allocation is allowed, NIL otherwise."
     436  (check-nargs 0)
     437  (mov imm0 (:$ arch::gc-trap-function-allocation-control))
     438  (mov imm1 (:$ 2))                     ;query
     439  (uuo-gc-trap)
     440  (bx lr))
     441
    420442(defun %watch (uvector)
    421443  (declare (ignore uvector))
  • trunk/source/level-1/arm-error-signal.lisp

    r14119 r14807  
    285285               :format-arguments (list (if (eql arg arm::vsp) "value" "control")))
    286286              nil frame-ptr))
     287            ((eql error-number arch::error-allocation-disabled)
     288             (restart-case (%error 'allocation-disabled nil frame-ptr)
     289               (continue ()
     290                         :report (lambda (stream)
     291                                   (format stream "retry the heap allocation.")))))
    287292            (t
    288293             (error "%errdisp callback: error-number = ~d, arg = #x~x, fnreg = ~d, rpc = ~d"
  • trunk/source/level-1/l1-error-system.lisp

    r13878 r14807  
    143143    (when instruction
    144144      (format s "~&Faulting instruction: ~s" instruction))))
     145
     146(define-condition allocation-disabled (storage-condition)
     147  ()
     148  (:report (lambda (c s) (declare (ignore c)) (format s "Attempt to heap-allocate a lisp object when heap allocation is disabled."))))
     149 
    145150
    146151(define-condition type-error (error)
  • trunk/source/lib/ccl-export-syms.lisp

    r14741 r14807  
    737737     add-feature
    738738     remove-feature
     739     ;; Disabling heap allocation (to detect unexpected consing.)
     740     allow-heap-allocaton
     741     heap-allocation-allowed-p
     742     allocation-disabled
    739743
    740744     ) "CCL"
  • trunk/source/lisp-kernel/arm-exceptions.c

    r14791 r14807  
    7878extern Boolean grow_dynamic_area(natural);
    7979
    80 
     80Boolean allocation_enabled = true;
    8181
    8282
     
    326326  unsigned allocptr_tag;
    327327
     328  if (!allocation_enabled) {
     329    /* Back up before the alloc_trap, then let pc_luser_xp() back
     330       up some more. */
     331    xpPC(xp)-=1;
     332    pc_luser_xp(xp,tcr, NULL);
     333    allocation_enabled = true;
     334    tcr->save_allocbase = (void *)VOID_ALLOCPTR;
     335    handle_error(xp, error_allocation_disabled,0,NULL);
     336    return true;
     337  }
     338
    328339  cur_allocptr = xpGPR(xp,allocptr);
    329340
     
    427438    break;
    428439
     440  case GC_TRAP_FUNCTION_ALLOCATION_CONTROL:
     441    switch(arg) {
     442    case 0: /* disable if allocation enabled */
     443      xpGPR(xp, arg_z) = lisp_nil;
     444      if (allocation_enabled) {
     445        TCR *other_tcr;
     446        ExceptionInformation *other_context;
     447        suspend_other_threads(true);
     448        normalize_tcr(xp,tcr,false);
     449        for (other_tcr=tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
     450          other_context = other_tcr->pending_exception_context;
     451          if (other_context == NULL) {
     452            other_context = other_tcr->suspend_context;
     453          }
     454          normalize_tcr(other_context, other_tcr, true);
     455        }
     456        allocation_enabled = false;
     457        xpGPR(xp, arg_z) = t_value;
     458        resume_other_threads(true);
     459      }
     460      break;
     461
     462    case 1:                     /* enable if disabled */
     463      xpGPR(xp, arg_z) = lisp_nil;
     464      if (!allocation_enabled) {
     465        allocation_enabled = true;
     466        xpGPR(xp, arg_z) = t_value;
     467      }
     468      break;
     469
     470    default:
     471      xpGPR(xp, arg_z) = lisp_nil;
     472      if (allocation_enabled) {
     473        xpGPR(xp, arg_z) = t_value;
     474      }
     475      break;
     476    }
     477    break;
     478
     479       
    429480  default:
    430481    update_bytes_allocated(tcr, (void *) ptr_from_lispobj(xpGPR(xp, allocptr)));
     
    648699void
    649700normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
     701
    650702{
    651703  void *cur_allocptr = NULL;
     
    16541706      if (alloc_disp) {
    16551707        *alloc_disp = disp;
    1656         xpGPR(xp,allocptr) += disp;
     1708        xpGPR(xp,allocptr) -= disp;
    16571709        /* Leave the PC at the alloc trap.  When the interrupt
    16581710           handler returns, it'll decrement allocptr by disp
     
    16611713      } else {
    16621714        Boolean ok = false;
    1663         update_bytes_allocated(tcr, (void *) ptr_from_lispobj(cur_allocptr + disp));
     1715        update_bytes_allocated(tcr, (void *) ptr_from_lispobj(cur_allocptr - disp));
    16641716        xpGPR(xp, allocptr) = VOID_ALLOCPTR + disp;
    16651717        instr = program_counter[-1];
     
    16721724        }
    16731725        if (ok) {
    1674         /* Clear the carry bit, so that the trap will be taken. */
    1675         xpPSR(xp) &= ~PSR_C_MASK;
     1726          /* Clear the carry bit, so that the trap will be taken. */
     1727          xpPSR(xp) &= ~PSR_C_MASK;
    16761728        } else {
    16771729          Bug(NULL, "unexpected instruction preceding alloc trap.");
  • trunk/source/lisp-kernel/arm-exceptions.h

    r14515 r14807  
    168168#define ALTSTACK(handler) handler
    169169#endif
     170
     171void
     172normalize_tcr(ExceptionInformation *,TCR *, Boolean);
  • trunk/source/lisp-kernel/gc.h

    r14295 r14807  
    155155#define GC_TRAP_FUNCTION_GET_GC_NOTIFICATION_THRESHOLD 20
    156156#define GC_TRAP_FUNCTION_SET_GC_NOTIFICATION_THRESHOLD 21
     157#define GC_TRAP_FUNCTION_ALLOCATION_CONTROL 22
    157158#define GC_TRAP_FUNCTION_EGC_CONTROL 32
    158159#define GC_TRAP_FUNCTION_CONFIGURE_EGC 64
  • trunk/source/lisp-kernel/lisp-errors.h

    r13067 r14807  
    3737#define error_cant_call 17
    3838#define error_allocate_list 18
     39#define error_allocation_disabled 19
    3940
    4041#define error_type_error 128
Note: See TracChangeset for help on using the changeset viewer.