Changeset 16064


Ignore:
Timestamp:
Apr 19, 2014, 3:51:08 AM (6 years ago)
Author:
gb
Message:

Implement ALLOW-HEAP-ALLOCATION (which has been present in ARM versions of
CCL for a few years) on X86, When heap-allocation is disallowed (via
(ALLOW-HEAP-ALLOCATION NIL)), attempts to heap-allocate lisp objects
signal a storage condition of type CCL:ALLOCATION-DISABLED.

TODO (maybe): make it easier to find the point where the allocation happened
in backtrace, auto-disable allocation if continuing from the break loop.

Location:
trunk/source
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/X86/X8632/x8632-utils.lisp

    r15790 r16064  
    444444  (jmp-subprim .SPmakeu32))
    445445
     446(defx8632lapfunction allow-heap-allocation ((flag arg_z))
     447  (check-nargs 1)
     448  (cmpl ($ (target-nil-value)) (% arg_z))
     449  (setne (%b imm0))
     450  (andl ($ 1) (%l imm0))
     451  (movd (% imm0) (% xmm0))
     452  (movl ($ arch::gc-trap-function-allocation-control) (%l imm0))
     453  (uuo-gc-trap)
     454  (single-value-return))
     455
     456(defx8632lapfunction heap-allocation-allowed-p ()
     457  (check-nargs 0)
     458  (movl ($ 2) (% imm0))
     459  (movd (% imm0) (% xmm0))
     460  (movl ($ arch::gc-trap-function-allocation-control) (%l imm0))
     461  (uuo-gc-trap)
     462  (single-value-return))
     463 
     464
    446465;;; offset is a fixnum, one of the x8632::kernel-import-xxx constants.
    447466;;; Returns that kernel import, a fixnum.
  • trunk/source/level-0/X86/x86-utils.lisp

    r15790 r16064  
    486486 
    487487
     488(defx86lapfunction allow-heap-allocation ((arg_arg_z))
     489  "If ARG is true, signal an ALLOCATION-DISABLED condition on attempts
     490at heap allocation."
     491  (check-nargs 1)
     492  (cmpq ($ (target-nil-value)) (%q arg_z))
     493  (setne (%b imm1))
     494  (andl ($ 1) (%l imm1))
     495  (movl ($ arch::gc-trap-function-allocation-control) (%l imm0))
     496  (uuo-gc-trap)
     497  (single-value-return))
     498
     499(defx86lapfunction heap-allocation-allowed-p ()
     500  (check-nargs 0)
     501  (movl ($ arch::gc-trap-function-allocation-control) (%l imm0))
     502  (movl ($ 2) (%l imm1))                ;query
     503  (uuo-gc-trap)
     504  (single-value-return))
    488505
    489506;;; offset is a fixnum, one of the x8664::kernel-import-xxx constants.
  • trunk/source/level-1/x86-trap-support.lisp

    r15000 r16064  
    468468           (cmain))
    469469          ((< signal 0)
    470            (%err-disp-internal code () frame-ptr))
     470           (if (and (zerop code)
     471                    (eql other arch::error-allocation-disabled))
     472             (restart-case (%error 'allocation-disabled nil frame-ptr)
     473                           (continue ()
     474                                     :report (lambda (stream)
     475                                               (format stream "retry the heap allocation."))))
     476             (%err-disp-internal code () frame-ptr)))
    471477          ((= signal #$SIGFPE)
    472478           (setq code (logand #xffffffff code))
     
    521527                                         :instruction insn)
    522528                                        nil frame-ptr)
    523                     #-windows-target
    524                     (emulate ()
    525                       :test (lambda (c)
    526                               (declare (ignore c))
    527                               (x86-can-emulate-instruction insn))
    528                       :report
    529                       "Emulate this instruction, leaving the object watched."
    530                       (flet ((watchedp (object)
    531                                (%map-areas #'(lambda (x)
    532                                                (when (eq object x)
    533                                                 (return-from watchedp t)))
    534                                            area-watched)))
    535                         (let ((result nil))
    536                           (with-other-threads-suspended
    537                             (when (watchedp object)
    538                               ;; We now trust that the object is in a
    539                               ;; static gc area.
    540                               (let* ((a (+ (%address-of object) offset))
    541                                      (ptr (%int-to-ptr
    542                                            (logandc2 a (1- *host-page-size*)))))
    543                                 (#_mprotect ptr *host-page-size* #$PROT_WRITE)
    544                                 (setq result (x86-emulate-instruction xp insn))
    545                                 (#_mprotect ptr *host-page-size*
    546                                             (logior #$PROT_READ #$PROT_EXEC)))))
    547                           (if result
    548                             (setq skip insn-length)
    549                             (error "could not emulate the instrution")))))
    550                     (skip ()
    551                       :test (lambda (c)
    552                               (declare (ignore c))
    553                               insn)
    554                       :report "Skip over this write instruction."
    555                       (setq skip insn-length))
    556                     (unwatch ()
    557                       :report "Unwatch the object and retry the write."
    558                       (unwatch object))))))))
     529                                #-windows-target
     530                                (emulate ()
     531                                         :test (lambda (c)
     532                                                 (declare (ignore c))
     533                                                 (x86-can-emulate-instruction insn))
     534                                         :report
     535                                         "Emulate this instruction, leaving the object watched."
     536                                         (flet ((watchedp (object)
     537                                                  (%map-areas #'(lambda (x)
     538                                                                  (when (eq object x)
     539                                                                    (return-from watchedp t)))
     540                                                              area-watched)))
     541                                           (let ((result nil))
     542                                             (with-other-threads-suspended
     543                                                 (when (watchedp object)
     544                                                   ;; We now trust that the object is in a
     545                                                   ;; static gc area.
     546                                                   (let* ((a (+ (%address-of object) offset))
     547                                                          (ptr (%int-to-ptr
     548                                                                (logandc2 a (1- *host-page-size*)))))
     549                                                     (#_mprotect ptr *host-page-size* #$PROT_WRITE)
     550                                                     (setq result (x86-emulate-instruction xp insn))
     551                                                     (#_mprotect ptr *host-page-size*
     552                                                                 (logior #$PROT_READ #$PROT_EXEC)))))
     553                                             (if result
     554                                               (setq skip insn-length)
     555                                               (error "could not emulate the instrution")))))
     556                                (skip ()
     557                                      :test (lambda (c)
     558                                              (declare (ignore c))
     559                                              insn)
     560                                      :report "Skip over this write instruction."
     561                                      (setq skip insn-length))
     562                                (unwatch ()
     563                                         :report "Unwatch the object and retry the write."
     564                                         (unwatch object))))))))
    559565          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
    560566           (if (= code -1)
  • trunk/source/lisp-kernel/arm-exceptions.c

    r15842 r16064  
    1 
    2 
    31/*
    42   Copyright (C) 2010 Clozure Associates
  • trunk/source/lisp-kernel/x86-exceptions.c

    r15975 r16064  
    5050#endif
    5151
     52void
     53normalize_tcr(ExceptionInformation *, TCR *, Boolean);
     54
    5255/*
    5356  We do all kinds of funky things to avoid handling a signal on the lisp
     
    119122did_gc_notification_since_last_full_gc = false;
    120123
     124Boolean
     125allocation_enabled = true;
    121126
    122127void
     
    285290    }
    286291    xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift;
     292    break;
     293
     294  case GC_TRAP_FUNCTION_ALLOCATION_CONTROL:
     295    switch(arg) {
     296    case 0: /* disable if allocation enabled */
     297      xpGPR(xp, Iarg_z) = lisp_nil;
     298      if (allocation_enabled) {
     299        TCR *other_tcr;
     300        ExceptionInformation *other_context;
     301        suspend_other_threads(true);
     302        normalize_tcr(xp,tcr,false);
     303        for (other_tcr=tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
     304          other_context = other_tcr->pending_exception_context;
     305          if (other_context == NULL) {
     306            other_context = other_tcr->suspend_context;
     307          }
     308          normalize_tcr(other_context, other_tcr, true);
     309        }
     310        allocation_enabled = false;
     311        xpGPR(xp, Iarg_z) = t_value;
     312        resume_other_threads(true);
     313      }
     314      break;
     315
     316    case 1:                     /* enable if disabled */
     317      xpGPR(xp, Iarg_z) = lisp_nil;
     318      if (!allocation_enabled) {
     319        allocation_enabled = true;
     320        xpGPR(xp, Iarg_z) = t_value;
     321      }
     322      break;
     323
     324    default:
     325      xpGPR(xp, Iarg_z) = lisp_nil;
     326      if (allocation_enabled) {
     327        xpGPR(xp, Iarg_z) = t_value;
     328      }
     329      break;
     330    }
    287331    break;
    288332
     
    588632  unsigned allocptr_tag;
    589633  signed_natural disp;
    590  
     634
     635  if (!allocation_enabled) {
     636    LispObj xcf,
     637      save_sp = xpGPR(xp,Isp),
     638      save_fp = xpGPR(xp,Ifp),
     639      cmain = nrs_CMAIN.vcell;
     640    xcf =create_exception_callback_frame(xp, tcr),
     641    pc_luser_xp(xp,tcr,NULL);
     642    allocation_enabled = true;
     643    tcr->save_allocbase = (void *)VOID_ALLOCPTR;
     644    callback_to_lisp(tcr, cmain, xp, xcf, -1, 0, 0, error_allocation_disabled);
     645    xpGPR(xp,Isp) = save_sp;
     646    xpGPR(xp,Ifp) = save_fp;
     647    return true;
     648  }
    591649  cur_allocptr = xpGPR(xp,Iallocptr);
    592650  allocptr_tag = fulltag_of(cur_allocptr);
     
    11481206          {
    11491207            Boolean did_notify = false,
     1208              allocation_disabled = !allocation_enabled,
    11501209              *notify_ptr = &did_notify;
    11511210            if (did_gc_notification_since_last_full_gc) {
     
    11541213            if (handle_alloc_trap(context, tcr, notify_ptr)) {
    11551214              if (! did_notify) {
    1156                 xpPC(context) += 2;     /* we might have GCed. */
     1215                if (! allocation_disabled) {
     1216                  xpPC(context) += 2;   /* we might have GCed. */
     1217                }
    11571218              }
    11581219              return true;
Note: See TracChangeset for help on using the changeset viewer.