Changeset 12994


Ignore:
Timestamp:
Oct 10, 2009, 5:32:43 PM (10 years ago)
Author:
gz
Message:

Merge watchpoints from trunk

Location:
branches/working-0711/ccl
Files:
15 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/x86-asm.lisp

    r11267 r12994  
    33703370   (def-x86-opcode uuo-error-debug-trap-with-string ()
    33713371     #xcdcd nil nil)
     3372
     3373   (def-x86-opcode uuo-watch-trap ()
     3374     #xcdce nil nil)
    33723375   
    33733376   (def-x86-opcode uuo-error-reg-not-tag ((:reg :insert-opcode-reg4) (:imm8 :insert-imm8))
  • branches/working-0711/ccl/compiler/arch.lisp

    r12198 r12994  
    358358(defconstant gc-trap-function-thaw 130)
    359359
    360 
     360(defconstant watch-trap-function-watch 0)
     361(defconstant watch-trap-function-unwatch 1)
    361362
    362363(provide "ARCH")
  • branches/working-0711/ccl/level-0/X86/x86-utils.lisp

    r12198 r12994  
    445445  (jmp-subprim .SPmakeu64))
    446446
     447(defx86lapfunction %watch ((thing arg_z))
     448  (check-nargs 1)
     449  (movl ($ arch::watch-trap-function-watch) (%l imm0))
     450  (uuo-watch-trap)
     451  (movl ($ nil) (%l arg_z))
     452  (single-value-return))
     453
     454(defx86lapfunction %unwatch ((watched arg_y) (new arg_z))
     455  (check-nargs 2)
     456  (movl ($ arch::watch-trap-function-unwatch) (%l imm0))
     457  (uuo-watch-trap)
     458  (single-value-return))
     459
    447460(defx86lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
    448461  (check-nargs 2)
  • branches/working-0711/ccl/level-1/l1-error-system.lisp

    r12961 r12994  
    104104             (format s "Invalid memory operation."))))
    105105
     106(define-condition write-to-watched-object (storage-condition)
     107  ((address :initarg :address)
     108   (object :initform nil :initarg :object))
     109  (:report (lambda (c s)
     110             (with-slots (object address) c
     111               (if (uvectorp object)
     112                 ;; This is safe only because watched objects are in a
     113                 ;; static GC area and won't be moved around.
     114                 (let* ((size (uvsize object))
     115                        (nbytes (if (ivectorp object)
     116                                  (subtag-bytes (typecode object) size)
     117                                  (* size target::node-size)))
     118                        (bytes-per-element (/ nbytes size))
     119                        (noderef (logandc2 (%address-of object)
     120                                           target::fulltagmask))
     121                        (offset (- address (+ noderef target::node-size)))
     122                        (index (/ offset bytes-per-element)))
     123                   (format s "Write to watched object ~s at address #x~x (uvector index ~d)." object address index))
     124                 (format s "Write to watched object ~s at address #x~x" object address))))))
    106125
    107126(define-condition type-error (error)
  • branches/working-0711/ccl/level-1/x86-trap-support.lisp

    r11947 r12994  
    386386;;; If the signal number is 0, other arguments (besides the exception context XP)
    387387;;; may not be meaningful.
    388 (defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :int)
     388(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int)
    389389  (let* ((frame-ptr (macptr->fixnum xcf)))
    390390    (cond ((zerop signal)               ;thread interrupt
     
    415415                       frame-ptr))))
    416416          ((= signal #$SIGSEGV)
    417            ;; Stack overflow.
    418            (let* ((on-tsp (not (eql 0 code))))
    419              (unwind-protect
    420                   (%error
    421                    (make-condition
    422                     'stack-overflow-condition
    423                     :format-control "Stack overflow on ~a stack."
    424                     :format-arguments (list
    425                                        (if on-tsp "temp" "value"))
    426                     )
    427                    nil frame-ptr)
    428                (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
    429                         :unsigned-fullword code
    430                         :void))))
     417           (cond
     418             ((or (= code 0) (= code 1))
     419              ;; Stack overflow.
     420              (let* ((on-tsp (= code 1)))
     421                (unwind-protect
     422                     (%error
     423                      (make-condition
     424                       'stack-overflow-condition
     425                       :format-control "Stack overflow on ~a stack."
     426                       :format-arguments (list (if on-tsp "temp" "value")))
     427                      nil frame-ptr)
     428                  (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit)
     429                           :unsigned-fullword code
     430                           :void))))
     431             ((= code 2)
     432              ;; Write to a watched object.
     433              (flet ((%int-to-object (i)
     434                       (rlet ((a :address))
     435                         (setf (%get-ptr a) (%int-to-ptr i))
     436                         (%get-object a 0))))
     437                (let ((object (%int-to-object other)))
     438                  (restart-case (%error (make-condition
     439                                         'write-to-watched-object
     440                                         :address addr
     441                                         :object object)
     442                                        nil frame-ptr)
     443                    (unwatch ()
     444                      :report (lambda (s)
     445                                (format s "Unwatch ~s and perform the write." object))
     446                      (unwatch object))))))))
    431447          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
    432448           (if (= code -1)
     
    440456                     frame-ptr)))))
    441457  0)
    442 
  • branches/working-0711/ccl/lib/dumplisp.lisp

    r12941 r12994  
    8383    (when (and kind (not (eq kind :file )))
    8484      (error "~S is not a regular file." filename)))
     85  (let* ((watched (watch)))
     86    (when watched
     87      (cerror "Un-watch them." "There are watched objects.")
     88      (mapc #'unwatch watched)))
    8589  (let* ((ip *initial-process*)
    8690         (cp *current-process*))
  • branches/working-0711/ccl/lib/macros.lisp

    r12980 r12994  
    35503550     (let ((,code (%fixnum-ref ,area  (area-code))))
    35513551       (when (or (eql ,code area-readonly)
     3552                 (eql ,code area-watched)
    35523553                 (eql ,code area-managed-static)
    35533554                 (eql ,code area-static)
  • branches/working-0711/ccl/lib/misc.lisp

    r12949 r12994  
    10511051              (lock-name lock)
    10521052              (%ptr-to-int (%svref lock target::lock._value-cell)))))
     1053
     1054(defun watch (&optional thing)
     1055  (if thing
     1056    (progn
     1057      (require-type thing '(or cons (satisfies uvectorp)))
     1058      (%watch thing))
     1059    (let (result)
     1060      (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
     1061      result)))
     1062
     1063(defun unwatch (thing)
     1064  (%map-areas #'(lambda (x)
     1065                  (when (eq x thing)
     1066                    ;; This is a rather questionable thing to do,
     1067                    ;; since we'll be unlinking an area from the area
     1068                    ;; list while %map-areas iterates over it, but I
     1069                    ;; think we'll get away with it.
     1070                    (let ((new (if (uvectorp thing)
     1071                                 (%alloc-misc (uvsize thing) (typecode thing))
     1072                                 (cons nil nil))))
     1073                      (return-from unwatch (%unwatch thing new)))))
     1074              area-watched area-watched))
     1075     
  • branches/working-0711/ccl/library/lispequ.lisp

    r12978 r12994  
    12851285  tstack                                ; (dynamic-extent) temp stack
    12861286  readonly                              ; readonly section
     1287  watched                               ; static area containing a single object
    12871288  managed-static                        ; growable static area
    12881289  static                                ; static data in application
  • branches/working-0711/ccl/lisp-kernel/area.h

    r11412 r12994  
    3030  AREA_TSTACK = 3<<fixnumshift, /* A temp stack.  It -is- doubleword-aligned */
    3131  AREA_READONLY = 4<<fixnumshift, /* A (cfm) read-only section. */
    32   AREA_MANAGED_STATIC = 5<<fixnumshift, /* A resizable static area */
    33   AREA_STATIC = 6<<fixnumshift, /* A  static section: contains
     32  AREA_WATCHED = 5<<fixnumshift, /* A static area containing a single object. */
     33  AREA_MANAGED_STATIC = 6<<fixnumshift, /* A resizable static area */
     34  AREA_STATIC = 7<<fixnumshift, /* A  static section: contains
    3435                                 roots, but not GCed */
    35   AREA_DYNAMIC = 7<<fixnumshift /* A heap. Only one such area is "the heap."*/
     36  AREA_DYNAMIC = 8<<fixnumshift /* A heap. Only one such area is "the heap."*/
    3637} area_code;
    3738
  • branches/working-0711/ccl/lisp-kernel/gc-common.c

    r12198 r12994  
    11011101
    11021102  install_weak_mark_functions(lisp_global(WEAK_GC_METHOD) >> fixnumshift);
    1103 
    1104 
    1105 
     1103 
    11061104#ifndef FORCE_DWS_MARK
    11071105  if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) {
     
    11631161
    11641162  get_time(start);
     1163
     1164  /* The link-inverting marker might need to write to watched areas */
     1165  unprotect_watched_areas();
     1166
    11651167  lisp_global(IN_GC) = (1<<fixnumshift);
    11661168
     
    12381240
    12391241        case AREA_STATIC:
     1242        case AREA_WATCHED:
    12401243        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
    12411244          /* In both of these cases, we -could- use the area's "markbits"
     
    13731376
    13741377        case AREA_STATIC:
     1378        case AREA_WATCHED:
    13751379        case AREA_DYNAMIC:                  /* some heap that isn't "the" heap */
    13761380          if (next_area->younger == NULL) {
     
    13841388      }
    13851389    }
    1386  
     1390
    13871391    if (GCephemeral_low) {
    13881392      forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low));
     
    14281432 
    14291433  lisp_global(IN_GC) = 0;
     1434 
     1435  protect_watched_areas();
    14301436
    14311437  nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending;
  • branches/working-0711/ccl/lisp-kernel/memory.c

    r12198 r12994  
    290290  return VirtualAlloc(addr, nbytes, MEM_RESERVE|MEM_COMMIT, MEMPROTECT_RWX);
    291291#else
    292   return mmap(addr, nbytes, protection, MAP_PRIVATE|MAP_ANON|MAP_FIXED, -1, 0);
     292  {
     293    int flags = MAP_PRIVATE|MAP_ANON;
     294
     295    if (addr > 0) flags |= MAP_FIXED;
     296    return mmap(addr, nbytes, protection, flags, -1, 0);
     297  }
    293298#endif
    294299}
     
    948953  pure_space_active = pure_space_start;
    949954}
     955
     956void
     957protect_watched_areas()
     958{
     959  area *a = active_dynamic_area;
     960  natural code = a->code;
     961
     962  while (code != AREA_VOID) {
     963    if (code == AREA_WATCHED) {
     964      natural size = a->high - a->low;
     965     
     966      ProtectMemory(a->low, size);
     967    }
     968    a = a->succ;
     969    code = a->code;
     970  }
     971}
     972
     973void
     974unprotect_watched_areas()
     975{
     976  area *a = active_dynamic_area;
     977  natural code = a->code;
     978
     979  while (code != AREA_VOID) {
     980    if (code == AREA_WATCHED) {
     981      natural size = a->high - a->low;
     982     
     983      UnProtectMemory(a->low, size);
     984    }
     985    a = a->succ;
     986    code = a->code;
     987  }
     988}
  • branches/working-0711/ccl/lisp-kernel/x86-exceptions.c

    r12993 r12994  
    499499    return true;
    500500  }
    501   update_bytes_allocated(tcr, (void *)(void *) tcr->save_allocptr);
     501  update_bytes_allocated(tcr, (void *)tcr->save_allocptr);
    502502  if (allocate_object(xp,bytes_needed,bytes_needed-fulltag_cons,tcr)) {
    503503    tcr->save_allocptr -= fulltag_cons;
     
    803803      xpPC(xp) = xpGPR(xp,Ira0);
    804804      return true;
    805     } else {
     805    }
     806   
     807    {
    806808      protected_area *a = find_protected_area(addr);
    807809      protection_handler *handler;
     
    810812        handler = protection_handlers[a->why];
    811813        return handler(xp, a, addr);
    812       } else {
    813         if ((addr >= readonly_area->low) &&
    814             (addr < readonly_area->active)) {
    815           UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)),
    816                           page_size);
    817           return true;
    818         }
    819814      }
    820815    }
    821   }
     816
     817    if ((addr >= readonly_area->low) &&
     818        (addr < readonly_area->active)) {
     819      UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)),
     820                      page_size);
     821      return true;
     822    }
     823
     824    {
     825      area *a = area_containing(addr);
     826
     827      if (a && a->code == AREA_WATCHED && addr < a->high) {
     828        /* caught a write to a watched object */
     829        LispObj *p = (LispObj *)a->low;
     830        LispObj node = *p;
     831        unsigned tag_n = fulltag_of(node);
     832        LispObj cmain = nrs_CMAIN.vcell;
     833        LispObj obj;
     834
     835        if (immheader_tag_p(tag_n) || nodeheader_tag_p(tag_n))
     836          obj = (LispObj)p + fulltag_misc;
     837        else
     838          obj = (LispObj)p + fulltag_cons;
     839
     840        if ((fulltag_of(cmain) == fulltag_misc) &&
     841            (header_subtag(header_of(cmain)) == subtag_macptr)) {
     842          LispObj save_vsp = xpGPR(xp, Isp);
     843          LispObj save_fp = xpGPR(xp, Ifp);
     844          LispObj xcf = create_exception_callback_frame(xp, tcr);
     845          int skip;
     846
     847          /* The magic 2 means this was a write to a watchd object */
     848          skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2, (natural) addr, obj);
     849          xpPC(xp) += skip;
     850          xpGPR(xp, Ifp) = save_fp;
     851          xpGPR(xp, Isp) = save_vsp;
     852          return true;
     853        }
     854      }
     855    }
     856  }
     857
    822858  if (old_valence == TCR_STATE_LISP) {
    823859    LispObj cmain = nrs_CMAIN.vcell,
     
    9931029          }
    9941030          break;
    995            
     1031        case UUO_WATCH_TRAP:
     1032          /* add or remove watched object */
     1033          if (handle_watch_trap(context, tcr)) {
     1034            xpPC(context) += 2;
     1035            return true;
     1036          }
     1037          break;
    9961038        case UUO_DEBUG_TRAP:
    9971039          xpPC(context) = (natural) (program_counter+1);
     
    22682310  case 0x77: return ID_branch_around_alloc_trap_instruction;
    22692311  case 0x48: return ID_set_allocptr_header_instruction;
    2270 #ifdef WINDOWS
     2312#ifdef TCR_IN_GPR
    22712313  case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction;
    22722314  case 0x49:
     
    35853627
    35863628#endif
     3629
     3630/* watchpoint stuff */
     3631
     3632area *
     3633new_watched_area(natural size)
     3634{
     3635  void *p;
     3636
     3637  p = MapMemory(NULL, size, MEMPROTECT_RWX);
     3638  if ((signed_natural)p == -1) {
     3639    allocation_failure(true, size);
     3640  }
     3641  return new_area(p, p + size, AREA_WATCHED);
     3642}
     3643
     3644void
     3645delete_watched_area(area *a, TCR *tcr)
     3646{
     3647  natural nbytes = a->high - a->low;
     3648  char *base = a->low;
     3649
     3650  condemn_area_holding_area_lock(a);
     3651
     3652  if (nbytes) {
     3653    int err;
     3654
     3655/* can't use UnMapMemory() beacuse it only uses MEM_DECOMMIT */
     3656#ifdef WINDOWS
     3657    err = VirtualFree(base, nbytes, MEM_RELEASE);
     3658#else
     3659    err = munmap(base, nbytes);
     3660#endif
     3661    if (err != 0)
     3662      Fatal("munmap in delete_watched_area", "");
     3663  }
     3664}
     3665
     3666natural
     3667uvector_total_size_in_bytes(LispObj *u)
     3668{
     3669  LispObj header = header_of(u);
     3670  natural header_tag = fulltag_of(header);
     3671  natural subtag = header_subtag(header);
     3672  natural element_count = header_element_count(header);
     3673  natural nbytes = 0;
     3674
     3675#ifdef X8632
     3676  if ((nodeheader_tag_p(header_tag)) ||
     3677      (subtag <= max_32_bit_ivector_subtag)) {
     3678    nbytes = element_count << 2;
     3679  } else if (subtag <= max_8_bit_ivector_subtag) {
     3680    nbytes = element_count;
     3681  } else if (subtag <= max_16_bit_ivector_subtag) {
     3682    nbytes = element_count << 1;
     3683  } else if (subtag == subtag_double_float_vector) {
     3684    nbytes = element_count << 3;
     3685  } else {
     3686    nbytes = (element_count + 7) >> 3;
     3687  }
     3688  /* add 4 byte header and round up to multiple of 8 bytes */
     3689  return ~7 & (4 + nbytes + 7);
     3690#endif
     3691#ifdef X8664
     3692  if ((nodeheader_tag_p(header_tag)) || (header_tag == ivector_class_64_bit)) {
     3693    nbytes = element_count << 3;
     3694  } else if (header_tag == ivector_class_32_bit) {
     3695    nbytes = element_count << 2;
     3696  } else {
     3697    /* ivector_class_other_bit contains 8, 16-bit arrays & bit vector */
     3698    if (subtag == subtag_bit_vector) {
     3699      nbytes = (element_count + 7) >> 3;
     3700    } else if (subtag >= min_8_bit_ivector_subtag) {
     3701      nbytes = element_count;
     3702    } else {
     3703      nbytes = element_count << 1;
     3704    }
     3705  }
     3706  /* add 8 byte header and round up to multiple of 16 bytes */
     3707  return ~15 & (8 + nbytes + 15);
     3708#endif
     3709}
     3710
     3711extern void wp_update_references(TCR *, LispObj, LispObj);
     3712
     3713/*
     3714 * Other threads are suspended and pc-lusered.
     3715 *
     3716 * param contains a tagged pointer to a uvector or a cons cell
     3717 */
     3718signed_natural
     3719watch_object(TCR *tcr, signed_natural param)
     3720{
     3721  LispObj object = (LispObj)param;
     3722  unsigned tag = fulltag_of(object);
     3723  LispObj *noderef = (LispObj *)untag(object);
     3724  area *object_area = area_containing((BytePtr)noderef);
     3725  natural size;
     3726
     3727  if (tag == fulltag_cons)
     3728    size = 2 * node_size;
     3729  else
     3730    size = uvector_total_size_in_bytes(noderef);
     3731
     3732  if (object_area && object_area->code != AREA_WATCHED) {
     3733    area *a = new_watched_area(size);
     3734    LispObj old = object;
     3735    LispObj new = (LispObj)((natural)a->low + tag);
     3736
     3737    add_area_holding_area_lock(a);
     3738
     3739    /* move object to watched area */
     3740    memcpy(a->low, noderef, size);
     3741    ProtectMemory(a->low, size);
     3742    memset(noderef, 0, size);
     3743    wp_update_references(tcr, old, new);
     3744    check_all_areas(tcr);
     3745  }
     3746  return 0;
     3747}
     3748
     3749/*
     3750 * We expect the watched object in arg_y, and the new uninitialized
     3751 * object (which is just zeroed) in arg_z.
     3752 */
     3753signed_natural
     3754unwatch_object(TCR *tcr, signed_natural param)
     3755{
     3756  ExceptionInformation *xp = tcr->xframe->curr;
     3757  LispObj old = xpGPR(xp, Iarg_y);
     3758  unsigned tag = fulltag_of(old);
     3759  LispObj new = xpGPR(xp, Iarg_z);
     3760  LispObj *oldnode = (LispObj *)untag(old);
     3761  LispObj *newnode = (LispObj *)untag(new);
     3762  area *a = area_containing((BytePtr)old);
     3763
     3764  if (a && a->code == AREA_WATCHED) {
     3765    natural size;
     3766
     3767    if (tag == fulltag_cons)
     3768      size = 2 * node_size;
     3769    else
     3770      size = uvector_total_size_in_bytes(oldnode);
     3771
     3772    memcpy(newnode, oldnode, size);
     3773    delete_watched_area(a, tcr);
     3774    wp_update_references(tcr, old, new);
     3775    /* because wp_update_references doesn't update refbits */
     3776    tenure_to_area(tenured_area);
     3777    check_all_areas(tcr);
     3778    xpGPR(xp, Iarg_z) = new;
     3779  }
     3780  return 0;
     3781}
     3782
     3783Boolean
     3784handle_watch_trap(ExceptionInformation *xp, TCR *tcr)
     3785{
     3786  LispObj selector = xpGPR(xp,Iimm0);
     3787  LispObj object = xpGPR(xp, Iarg_z);
     3788 
     3789  switch (selector) {
     3790    case WATCH_TRAP_FUNCTION_WATCH:
     3791      gc_like_from_xp(xp, watch_object, object);
     3792      break;
     3793    case WATCH_TRAP_FUNCTION_UNWATCH:
     3794      gc_like_from_xp(xp, unwatch_object, 0);
     3795      break;
     3796    default:
     3797      break;
     3798  }
     3799  return true;
     3800}
     3801
  • branches/working-0711/ccl/lisp-kernel/x86-exceptions.h

    r12198 r12994  
    138138#define UUO_DEBUG_TRAP 0xca
    139139#define UUO_DEBUG_TRAP_WITH_STRING 0xcd
     140#define UUO_WATCH_TRAP 0xce
     141  #define WATCH_TRAP_FUNCTION_WATCH 0
     142  #define WATCH_TRAP_FUNCTION_UNWATCH 1
    140143
    141144#define XUUO_OPCODE_0 0x0f
  • branches/working-0711/ccl/lisp-kernel/x86-gc.c

    r12410 r12994  
    2626#include <sys/time.h>
    2727
     28#ifdef X8632
     29static inline natural
     30imm_word_count(LispObj fn)
     31{
     32  natural w = ((unsigned short *)fn)[-1];
     33
     34  if (w & 0x8000) {
     35    /*
     36     * The low 15 bits encode the number of contants.
     37     * Compute and return the immediate word count.
     38     */
     39    LispObj header = header_of(fn);
     40    natural element_count = header_element_count(header);
     41
     42    return element_count - (w & 0x7fff);
     43  } else {
     44    /* The immediate word count is encoded directly. */
     45    return w;
     46  }
     47}
     48#endif
    2849
    2950/* Heap sanity checking. */
     
    318339    switch (code) {
    319340    case AREA_DYNAMIC:
     341    case AREA_WATCHED:
    320342    case AREA_STATIC:
    321343    case AREA_MANAGED_STATIC:
     
    959981      header = *(natural *)base;
    960982      subtag = header_subtag(header);
    961       boundary = base + (unsigned short)base[1];
    962 
    963       /* XXX bootstrapping */
    964       {
    965         natural word_count = (unsigned short)base[1];
    966         natural element_count = header_element_count(header);
    967 
    968         if (word_count & 0x8000)
    969           boundary = base + element_count - (word_count & 0x7fff);
    970       }
     983      boundary = base + imm_word_count(fn);
    971984
    972985      /*
     
    9911004      subtag = header_subtag(header);
    9921005      if (subtag == subtag_function) {
    993         boundary = base + (unsigned short)base[1];
    994         /* XXX bootstrapping */
    995         {
    996           natural word_count = (unsigned short)base[1];
    997           natural element_count = header_element_count(header);
    998 
    999           if (word_count & 0x8000)
    1000             boundary = base + element_count - (word_count & 0x7fff);
    1001         }
     1006        boundary = base + imm_word_count(this);
    10021007
    10031008        *((int *)boundary) &= 0xff;
     
    19021907  LispObj fn = fulltag_misc + (LispObj)node;
    19031908  unsigned char *p = (unsigned char *)node;
    1904   natural i, offset;
    1905   LispObj header = *node;
    1906 
    1907   i = ((unsigned short *)node)[2];
     1909  natural i = imm_word_count(fn);
     1910
    19081911  if (i) {
    1909     /* XXX bootstrapping for new scheme */
    1910     if (i & 0x8000) {
    1911       i = header_element_count(header) - (i & 0x7fff);
    1912     }
    1913     offset = node[--i];
     1912    natural offset = node[--i];
    19141913
    19151914    while (offset) {
     
    19831982          if (header_subtag(node) == subtag_function) {
    19841983#ifdef X8632
    1985             int skip = *((unsigned short *)src);
    19861984            LispObj *f = dest;
    1987 
    1988             /* XXX bootstrapping for new scheme */
    1989             if (skip & 0x8000)
    1990               skip = elements - (skip & 0x7fff);
     1985            int skip = imm_word_count(fulltag_misc + (LispObj)current);
    19911986#else
    19921987            int skip = *((int *)src);
     
    28112806  return -1;
    28122807}
     2808
     2809/*
     2810 * This stuff is all adapted from the forward_xxx functions for use by
     2811 * the watchpoint code.  It's a lot of duplicated code, and it would
     2812 * be nice to generalize it somehow.
     2813 */
     2814
     2815static inline void
     2816wp_maybe_update(LispObj *p, LispObj old, LispObj new)
     2817{
     2818  if (*p == old) {
     2819    *p = new;
     2820  }
     2821}
     2822
     2823static void
     2824wp_update_headerless_range(LispObj *start, LispObj *end,
     2825                           LispObj old, LispObj new)
     2826{
     2827  LispObj *p = start;
     2828
     2829  while (p < end) {
     2830    wp_maybe_update(p, old, new);
     2831    p++;
     2832  }
     2833}
     2834
     2835static void
     2836wp_update_range(LispObj *start, LispObj *end, LispObj old, LispObj new)
     2837{
     2838  LispObj *p = start, node;
     2839  int tag_n;
     2840  natural nwords;
     2841
     2842  while (p < end) {
     2843    node = *p;
     2844    tag_n = fulltag_of(node);
     2845
     2846    if (immheader_tag_p(tag_n)) {
     2847      p = (LispObj *)skip_over_ivector(ptr_to_lispobj(p), node);
     2848    } else if (nodeheader_tag_p(tag_n)) {
     2849      nwords = header_element_count(node);
     2850     
     2851      nwords += 1 - (nwords & 1);
     2852
     2853      if ((header_subtag(node) == subtag_hash_vector) &&
     2854          ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) {
     2855        natural skip = hash_table_vector_header_count - 1;
     2856        hash_table_vector_header *hashp = (hash_table_vector_header *)p;
     2857
     2858        p++;
     2859        nwords -= skip;
     2860        while(skip--) {
     2861          if (*p == old) *p = new;
     2862          p++;
     2863        }
     2864        /* "nwords" is odd at this point: there are (floor nwords 2)
     2865           key/value pairs to look at, and then an extra word for
     2866           alignment.  Process them two at a time, then bump "p"
     2867           past the alignment word. */
     2868        nwords >>= 1;
     2869        while(nwords--) {
     2870          if (*p == old && hashp) {
     2871            *p = new;
     2872            hashp->flags |= nhash_key_moved_mask;
     2873            hashp = NULL;
     2874          }
     2875          p++;
     2876          if (*p == old) *p = new;
     2877          p++;
     2878        }
     2879        *p++ = 0;
     2880      } else {
     2881        if (header_subtag(node) == subtag_function) {
     2882#ifdef X8632
     2883          int skip = (unsigned short)(p[1]);
     2884
     2885          /* XXX bootstrapping */
     2886          if (skip & 0x8000)
     2887            skip = header_element_count(node) - (skip & 0x7fff);
     2888
     2889#else
     2890          int skip = (int)(p[1]);
     2891#endif
     2892          p += skip;
     2893          nwords -= skip;
     2894        }
     2895        p++;
     2896        while(nwords--) {
     2897          wp_maybe_update(p, old, new);
     2898          p++;
     2899        }
     2900      }
     2901    } else {
     2902      /* a cons cell */
     2903      wp_maybe_update(p, old, new);
     2904      p++;
     2905      wp_maybe_update(p, old, new);
     2906      p++;
     2907    }
     2908  }
     2909}
     2910
     2911#ifdef X8664
     2912static void
     2913wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new)
     2914{
     2915  natural *regs = (natural *)xpGPRvector(xp);
     2916
     2917  wp_maybe_update(&regs[Iarg_z], old, new);
     2918  wp_maybe_update(&regs[Iarg_y], old, new);
     2919  wp_maybe_update(&regs[Iarg_x], old, new);
     2920  wp_maybe_update(&regs[Isave3], old, new);
     2921  wp_maybe_update(&regs[Isave2], old, new);
     2922  wp_maybe_update(&regs[Isave1], old, new);
     2923  wp_maybe_update(&regs[Isave0], old, new);
     2924  wp_maybe_update(&regs[Ifn], old, new);
     2925  wp_maybe_update(&regs[Itemp0], old, new);
     2926  wp_maybe_update(&regs[Itemp1], old, new);
     2927  wp_maybe_update(&regs[Itemp2], old, new);
     2928
     2929#if 0
     2930  /*
     2931   * We don't allow watching functions, so this presumably doesn't
     2932   * matter.
     2933   */
     2934  update_locref(&(regs[Iip]));
     2935#endif
     2936}
     2937#else
     2938static void
     2939wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new, natural node_regs_mask)
     2940{
     2941  natural *regs = (natural *)xpGPRvector(xp);
     2942
     2943  if (node_regs_mask & (1<<0)) wp_maybe_update(&regs[REG_EAX], old, new);
     2944  if (node_regs_mask & (1<<1)) wp_maybe_update(&regs[REG_ECX], old, new);
     2945
     2946  if (regs[REG_EFL] & EFL_DF) {
     2947    /* then EDX is an imm reg */
     2948    ;
     2949  } else
     2950    if (node_regs_mask & (1<<2)) wp_maybe_update(&regs[REG_EDX], old, new);
     2951
     2952  if (node_regs_mask & (1<<3)) wp_maybe_update(&regs[REG_EBX], old, new);
     2953  if (node_regs_mask & (1<<4)) wp_maybe_update(&regs[REG_ESP], old, new);
     2954  if (node_regs_mask & (1<<5)) wp_maybe_update(&regs[REG_EBP], old, new);
     2955  if (node_regs_mask & (1<<6)) wp_maybe_update(&regs[REG_ESI], old, new);
     2956  if (node_regs_mask & (1<<7)) wp_maybe_update(&regs[REG_EDI], old, new);
     2957  /* we shouldn't watch functions, so no need to update PC */
     2958}
     2959#endif
     2960
     2961static void
     2962wp_update_tcr_xframes(TCR *tcr, LispObj old, LispObj new)
     2963{
     2964  xframe_list *xframes;
     2965  ExceptionInformation *xp;
     2966
     2967  xp = tcr->gc_context;
     2968  if (xp) {
     2969#ifdef X8664
     2970    wp_update_xp(xp, old, new);
     2971#else
     2972    wp_update_xp(xp, old, new, tcr->node_regs_mask);
     2973    wp_maybe_update(&tcr->save0, old, new);
     2974    wp_maybe_update(&tcr->save1, old, new);
     2975    wp_maybe_update(&tcr->save2, old, new);
     2976    wp_maybe_update(&tcr->save3, old, new);
     2977    wp_maybe_update(&tcr->next_method_context, old, new);
     2978#endif
     2979  }
     2980  for (xframes = tcr->xframe; xframes; xframes = xframes->prev) {
     2981#ifdef X8664
     2982    wp_update_xp(xframes->curr, old, new);
     2983#else
     2984    wp_update_xp(xframes->curr, old, new, xframes->node_regs_mask);
     2985#endif
     2986  }
     2987}
     2988
     2989/*
     2990 * Scan all pointer-bearing areas, updating all references to
     2991 * "old" to "new".
     2992 */
     2993static void
     2994wp_update_all_areas(LispObj old, LispObj new)
     2995{
     2996  area *a = active_dynamic_area;
     2997  natural code = a->code;
     2998
     2999  while (code != AREA_VOID) {
     3000    switch (code) {
     3001      case AREA_DYNAMIC:
     3002      case AREA_STATIC:
     3003      case AREA_MANAGED_STATIC:
     3004      case AREA_WATCHED:
     3005        wp_update_range((LispObj *)a->low, (LispObj *)a->active, old, new);
     3006        break;
     3007      case AREA_VSTACK:
     3008      {
     3009        LispObj *low = (LispObj *)a->active;
     3010        LispObj *high = (LispObj *)a->high;
     3011       
     3012        wp_update_headerless_range(low, high, old, new);
     3013      }
     3014      break;
     3015      case AREA_TSTACK:
     3016      {
     3017        LispObj *current, *next;
     3018        LispObj *start = (LispObj *)a->active, *end = start;
     3019        LispObj *limit = (LispObj *)a->high;
     3020       
     3021        for (current = start; end != limit; current = next) {
     3022          next = ptr_from_lispobj(*current);
     3023          end = ((next >= start) && (next < limit)) ? next : limit;
     3024          wp_update_range(current+2, end, old, new);
     3025        }
     3026      break;
     3027      }
     3028      default:
     3029        break;
     3030    }
     3031    a = a->succ;
     3032    code = a->code;
     3033  }
     3034}
     3035
     3036static void
     3037wp_update_tcr_tlb(TCR *tcr, LispObj old, LispObj new)
     3038{
     3039  natural n = tcr->tlb_limit;
     3040  LispObj *start = tcr->tlb_pointer;
     3041  LispObj *end = start + (n >> fixnumshift);
     3042
     3043  while (start < end) {
     3044    wp_maybe_update(start, old, new);
     3045    start++;
     3046  }
     3047}
     3048
     3049void
     3050wp_update_references(TCR *tcr, LispObj old, LispObj new)
     3051{
     3052  TCR *other_tcr = tcr;
     3053
     3054  do {
     3055    wp_update_tcr_xframes(other_tcr, old, new);
     3056    wp_update_tcr_tlb(other_tcr, old, new);
     3057    other_tcr = other_tcr->next;
     3058  } while (other_tcr != tcr);
     3059  wp_update_all_areas(old, new);
     3060}
Note: See TracChangeset for help on using the changeset viewer.