Index: /branches/working-0711/ccl/compiler/X86/x86-asm.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x86-asm.lisp (revision 12993) +++ /branches/working-0711/ccl/compiler/X86/x86-asm.lisp (revision 12994) @@ -3370,4 +3370,7 @@ (def-x86-opcode uuo-error-debug-trap-with-string () #xcdcd nil nil) + + (def-x86-opcode uuo-watch-trap () + #xcdce nil nil) (def-x86-opcode uuo-error-reg-not-tag ((:reg :insert-opcode-reg4) (:imm8 :insert-imm8)) Index: /branches/working-0711/ccl/compiler/arch.lisp =================================================================== --- /branches/working-0711/ccl/compiler/arch.lisp (revision 12993) +++ /branches/working-0711/ccl/compiler/arch.lisp (revision 12994) @@ -358,5 +358,6 @@ (defconstant gc-trap-function-thaw 130) - +(defconstant watch-trap-function-watch 0) +(defconstant watch-trap-function-unwatch 1) (provide "ARCH") Index: /branches/working-0711/ccl/level-0/X86/x86-utils.lisp =================================================================== --- /branches/working-0711/ccl/level-0/X86/x86-utils.lisp (revision 12993) +++ /branches/working-0711/ccl/level-0/X86/x86-utils.lisp (revision 12994) @@ -445,4 +445,17 @@ (jmp-subprim .SPmakeu64)) +(defx86lapfunction %watch ((thing arg_z)) + (check-nargs 1) + (movl ($ arch::watch-trap-function-watch) (%l imm0)) + (uuo-watch-trap) + (movl ($ nil) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction %unwatch ((watched arg_y) (new arg_z)) + (check-nargs 2) + (movl ($ arch::watch-trap-function-unwatch) (%l imm0)) + (uuo-watch-trap) + (single-value-return)) + (defx86lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z)) (check-nargs 2) Index: /branches/working-0711/ccl/level-1/l1-error-system.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-error-system.lisp (revision 12993) +++ /branches/working-0711/ccl/level-1/l1-error-system.lisp (revision 12994) @@ -104,4 +104,23 @@ (format s "Invalid memory operation.")))) +(define-condition write-to-watched-object (storage-condition) + ((address :initarg :address) + (object :initform nil :initarg :object)) + (:report (lambda (c s) + (with-slots (object address) c + (if (uvectorp object) + ;; This is safe only because watched objects are in a + ;; static GC area and won't be moved around. + (let* ((size (uvsize object)) + (nbytes (if (ivectorp object) + (subtag-bytes (typecode object) size) + (* size target::node-size))) + (bytes-per-element (/ nbytes size)) + (noderef (logandc2 (%address-of object) + target::fulltagmask)) + (offset (- address (+ noderef target::node-size))) + (index (/ offset bytes-per-element))) + (format s "Write to watched object ~s at address #x~x (uvector index ~d)." object address index)) + (format s "Write to watched object ~s at address #x~x" object address)))))) (define-condition type-error (error) Index: /branches/working-0711/ccl/level-1/x86-trap-support.lisp =================================================================== --- /branches/working-0711/ccl/level-1/x86-trap-support.lisp (revision 12993) +++ /branches/working-0711/ccl/level-1/x86-trap-support.lisp (revision 12994) @@ -386,5 +386,5 @@ ;;; If the signal number is 0, other arguments (besides the exception context XP) ;;; may not be meaningful. -(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :int) +(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int) (let* ((frame-ptr (macptr->fixnum xcf))) (cond ((zerop signal) ;thread interrupt @@ -415,18 +415,34 @@ frame-ptr)))) ((= signal #$SIGSEGV) - ;; Stack overflow. - (let* ((on-tsp (not (eql 0 code)))) - (unwind-protect - (%error - (make-condition - 'stack-overflow-condition - :format-control "Stack overflow on ~a stack." - :format-arguments (list - (if on-tsp "temp" "value")) - ) - nil frame-ptr) - (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit) - :unsigned-fullword code - :void)))) + (cond + ((or (= code 0) (= code 1)) + ;; Stack overflow. + (let* ((on-tsp (= code 1))) + (unwind-protect + (%error + (make-condition + 'stack-overflow-condition + :format-control "Stack overflow on ~a stack." + :format-arguments (list (if on-tsp "temp" "value"))) + nil frame-ptr) + (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit) + :unsigned-fullword code + :void)))) + ((= code 2) + ;; Write to a watched object. + (flet ((%int-to-object (i) + (rlet ((a :address)) + (setf (%get-ptr a) (%int-to-ptr i)) + (%get-object a 0)))) + (let ((object (%int-to-object other))) + (restart-case (%error (make-condition + 'write-to-watched-object + :address addr + :object object) + nil frame-ptr) + (unwatch () + :report (lambda (s) + (format s "Unwatch ~s and perform the write." object)) + (unwatch object)))))))) ((= signal #+win32-target 10 #-win32-target #$SIGBUS) (if (= code -1) @@ -440,3 +456,2 @@ frame-ptr))))) 0) - Index: /branches/working-0711/ccl/lib/dumplisp.lisp =================================================================== --- /branches/working-0711/ccl/lib/dumplisp.lisp (revision 12993) +++ /branches/working-0711/ccl/lib/dumplisp.lisp (revision 12994) @@ -83,4 +83,8 @@ (when (and kind (not (eq kind :file ))) (error "~S is not a regular file." filename))) + (let* ((watched (watch))) + (when watched + (cerror "Un-watch them." "There are watched objects.") + (mapc #'unwatch watched))) (let* ((ip *initial-process*) (cp *current-process*)) Index: /branches/working-0711/ccl/lib/macros.lisp =================================================================== --- /branches/working-0711/ccl/lib/macros.lisp (revision 12993) +++ /branches/working-0711/ccl/lib/macros.lisp (revision 12994) @@ -3550,4 +3550,5 @@ (let ((,code (%fixnum-ref ,area (area-code)))) (when (or (eql ,code area-readonly) + (eql ,code area-watched) (eql ,code area-managed-static) (eql ,code area-static) Index: /branches/working-0711/ccl/lib/misc.lisp =================================================================== --- /branches/working-0711/ccl/lib/misc.lisp (revision 12993) +++ /branches/working-0711/ccl/lib/misc.lisp (revision 12994) @@ -1051,2 +1051,25 @@ (lock-name lock) (%ptr-to-int (%svref lock target::lock._value-cell))))) + +(defun watch (&optional thing) + (if thing + (progn + (require-type thing '(or cons (satisfies uvectorp))) + (%watch thing)) + (let (result) + (%map-areas #'(lambda (x) (push x result)) area-watched area-watched) + result))) + +(defun unwatch (thing) + (%map-areas #'(lambda (x) + (when (eq x thing) + ;; This is a rather questionable thing to do, + ;; since we'll be unlinking an area from the area + ;; list while %map-areas iterates over it, but I + ;; think we'll get away with it. + (let ((new (if (uvectorp thing) + (%alloc-misc (uvsize thing) (typecode thing)) + (cons nil nil)))) + (return-from unwatch (%unwatch thing new))))) + area-watched area-watched)) + Index: /branches/working-0711/ccl/library/lispequ.lisp =================================================================== --- /branches/working-0711/ccl/library/lispequ.lisp (revision 12993) +++ /branches/working-0711/ccl/library/lispequ.lisp (revision 12994) @@ -1285,4 +1285,5 @@ tstack ; (dynamic-extent) temp stack readonly ; readonly section + watched ; static area containing a single object managed-static ; growable static area static ; static data in application Index: /branches/working-0711/ccl/lisp-kernel/area.h =================================================================== --- /branches/working-0711/ccl/lisp-kernel/area.h (revision 12993) +++ /branches/working-0711/ccl/lisp-kernel/area.h (revision 12994) @@ -30,8 +30,9 @@ AREA_TSTACK = 3<> fixnumshift); - - - + #ifndef FORCE_DWS_MARK if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) { @@ -1163,4 +1161,8 @@ get_time(start); + + /* The link-inverting marker might need to write to watched areas */ + unprotect_watched_areas(); + lisp_global(IN_GC) = (1<younger == NULL) { @@ -1384,5 +1388,5 @@ } } - + if (GCephemeral_low) { forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low)); @@ -1428,4 +1432,6 @@ lisp_global(IN_GC) = 0; + + protect_watched_areas(); nrs_GC_EVENT_STATUS_BITS.vcell |= gc_postgc_pending; Index: /branches/working-0711/ccl/lisp-kernel/memory.c =================================================================== --- /branches/working-0711/ccl/lisp-kernel/memory.c (revision 12993) +++ /branches/working-0711/ccl/lisp-kernel/memory.c (revision 12994) @@ -290,5 +290,10 @@ return VirtualAlloc(addr, nbytes, MEM_RESERVE|MEM_COMMIT, MEMPROTECT_RWX); #else - return mmap(addr, nbytes, protection, MAP_PRIVATE|MAP_ANON|MAP_FIXED, -1, 0); + { + int flags = MAP_PRIVATE|MAP_ANON; + + if (addr > 0) flags |= MAP_FIXED; + return mmap(addr, nbytes, protection, flags, -1, 0); + } #endif } @@ -948,2 +953,36 @@ pure_space_active = pure_space_start; } + +void +protect_watched_areas() +{ + area *a = active_dynamic_area; + natural code = a->code; + + while (code != AREA_VOID) { + if (code == AREA_WATCHED) { + natural size = a->high - a->low; + + ProtectMemory(a->low, size); + } + a = a->succ; + code = a->code; + } +} + +void +unprotect_watched_areas() +{ + area *a = active_dynamic_area; + natural code = a->code; + + while (code != AREA_VOID) { + if (code == AREA_WATCHED) { + natural size = a->high - a->low; + + UnProtectMemory(a->low, size); + } + a = a->succ; + code = a->code; + } +} Index: /branches/working-0711/ccl/lisp-kernel/x86-exceptions.c =================================================================== --- /branches/working-0711/ccl/lisp-kernel/x86-exceptions.c (revision 12993) +++ /branches/working-0711/ccl/lisp-kernel/x86-exceptions.c (revision 12994) @@ -499,5 +499,5 @@ return true; } - update_bytes_allocated(tcr, (void *)(void *) tcr->save_allocptr); + update_bytes_allocated(tcr, (void *)tcr->save_allocptr); if (allocate_object(xp,bytes_needed,bytes_needed-fulltag_cons,tcr)) { tcr->save_allocptr -= fulltag_cons; @@ -803,5 +803,7 @@ xpPC(xp) = xpGPR(xp,Ira0); return true; - } else { + } + + { protected_area *a = find_protected_area(addr); protection_handler *handler; @@ -810,14 +812,48 @@ handler = protection_handlers[a->why]; return handler(xp, a, addr); - } else { - if ((addr >= readonly_area->low) && - (addr < readonly_area->active)) { - UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)), - page_size); - return true; - } } } - } + + if ((addr >= readonly_area->low) && + (addr < readonly_area->active)) { + UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)), + page_size); + return true; + } + + { + area *a = area_containing(addr); + + if (a && a->code == AREA_WATCHED && addr < a->high) { + /* caught a write to a watched object */ + LispObj *p = (LispObj *)a->low; + LispObj node = *p; + unsigned tag_n = fulltag_of(node); + LispObj cmain = nrs_CMAIN.vcell; + LispObj obj; + + if (immheader_tag_p(tag_n) || nodeheader_tag_p(tag_n)) + obj = (LispObj)p + fulltag_misc; + else + obj = (LispObj)p + fulltag_cons; + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + LispObj save_vsp = xpGPR(xp, Isp); + LispObj save_fp = xpGPR(xp, Ifp); + LispObj xcf = create_exception_callback_frame(xp, tcr); + int skip; + + /* The magic 2 means this was a write to a watchd object */ + skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2, (natural) addr, obj); + xpPC(xp) += skip; + xpGPR(xp, Ifp) = save_fp; + xpGPR(xp, Isp) = save_vsp; + return true; + } + } + } + } + if (old_valence == TCR_STATE_LISP) { LispObj cmain = nrs_CMAIN.vcell, @@ -993,5 +1029,11 @@ } break; - + case UUO_WATCH_TRAP: + /* add or remove watched object */ + if (handle_watch_trap(context, tcr)) { + xpPC(context) += 2; + return true; + } + break; case UUO_DEBUG_TRAP: xpPC(context) = (natural) (program_counter+1); @@ -2268,5 +2310,5 @@ case 0x77: return ID_branch_around_alloc_trap_instruction; case 0x48: return ID_set_allocptr_header_instruction; -#ifdef WINDOWS +#ifdef TCR_IN_GPR case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction; case 0x49: @@ -3585,2 +3627,175 @@ #endif + +/* watchpoint stuff */ + +area * +new_watched_area(natural size) +{ + void *p; + + p = MapMemory(NULL, size, MEMPROTECT_RWX); + if ((signed_natural)p == -1) { + allocation_failure(true, size); + } + return new_area(p, p + size, AREA_WATCHED); +} + +void +delete_watched_area(area *a, TCR *tcr) +{ + natural nbytes = a->high - a->low; + char *base = a->low; + + condemn_area_holding_area_lock(a); + + if (nbytes) { + int err; + +/* can't use UnMapMemory() beacuse it only uses MEM_DECOMMIT */ +#ifdef WINDOWS + err = VirtualFree(base, nbytes, MEM_RELEASE); +#else + err = munmap(base, nbytes); +#endif + if (err != 0) + Fatal("munmap in delete_watched_area", ""); + } +} + +natural +uvector_total_size_in_bytes(LispObj *u) +{ + LispObj header = header_of(u); + natural header_tag = fulltag_of(header); + natural subtag = header_subtag(header); + natural element_count = header_element_count(header); + natural nbytes = 0; + +#ifdef X8632 + if ((nodeheader_tag_p(header_tag)) || + (subtag <= max_32_bit_ivector_subtag)) { + nbytes = element_count << 2; + } else if (subtag <= max_8_bit_ivector_subtag) { + nbytes = element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + nbytes = element_count << 1; + } else if (subtag == subtag_double_float_vector) { + nbytes = element_count << 3; + } else { + nbytes = (element_count + 7) >> 3; + } + /* add 4 byte header and round up to multiple of 8 bytes */ + return ~7 & (4 + nbytes + 7); +#endif +#ifdef X8664 + if ((nodeheader_tag_p(header_tag)) || (header_tag == ivector_class_64_bit)) { + nbytes = element_count << 3; + } else if (header_tag == ivector_class_32_bit) { + nbytes = element_count << 2; + } else { + /* ivector_class_other_bit contains 8, 16-bit arrays & bit vector */ + if (subtag == subtag_bit_vector) { + nbytes = (element_count + 7) >> 3; + } else if (subtag >= min_8_bit_ivector_subtag) { + nbytes = element_count; + } else { + nbytes = element_count << 1; + } + } + /* add 8 byte header and round up to multiple of 16 bytes */ + return ~15 & (8 + nbytes + 15); +#endif +} + +extern void wp_update_references(TCR *, LispObj, LispObj); + +/* + * Other threads are suspended and pc-lusered. + * + * param contains a tagged pointer to a uvector or a cons cell + */ +signed_natural +watch_object(TCR *tcr, signed_natural param) +{ + LispObj object = (LispObj)param; + unsigned tag = fulltag_of(object); + LispObj *noderef = (LispObj *)untag(object); + area *object_area = area_containing((BytePtr)noderef); + natural size; + + if (tag == fulltag_cons) + size = 2 * node_size; + else + size = uvector_total_size_in_bytes(noderef); + + if (object_area && object_area->code != AREA_WATCHED) { + area *a = new_watched_area(size); + LispObj old = object; + LispObj new = (LispObj)((natural)a->low + tag); + + add_area_holding_area_lock(a); + + /* move object to watched area */ + memcpy(a->low, noderef, size); + ProtectMemory(a->low, size); + memset(noderef, 0, size); + wp_update_references(tcr, old, new); + check_all_areas(tcr); + } + return 0; +} + +/* + * We expect the watched object in arg_y, and the new uninitialized + * object (which is just zeroed) in arg_z. + */ +signed_natural +unwatch_object(TCR *tcr, signed_natural param) +{ + ExceptionInformation *xp = tcr->xframe->curr; + LispObj old = xpGPR(xp, Iarg_y); + unsigned tag = fulltag_of(old); + LispObj new = xpGPR(xp, Iarg_z); + LispObj *oldnode = (LispObj *)untag(old); + LispObj *newnode = (LispObj *)untag(new); + area *a = area_containing((BytePtr)old); + + if (a && a->code == AREA_WATCHED) { + natural size; + + if (tag == fulltag_cons) + size = 2 * node_size; + else + size = uvector_total_size_in_bytes(oldnode); + + memcpy(newnode, oldnode, size); + delete_watched_area(a, tcr); + wp_update_references(tcr, old, new); + /* because wp_update_references doesn't update refbits */ + tenure_to_area(tenured_area); + check_all_areas(tcr); + xpGPR(xp, Iarg_z) = new; + } + return 0; +} + +Boolean +handle_watch_trap(ExceptionInformation *xp, TCR *tcr) +{ + LispObj selector = xpGPR(xp,Iimm0); + LispObj object = xpGPR(xp, Iarg_z); + + switch (selector) { + case WATCH_TRAP_FUNCTION_WATCH: + gc_like_from_xp(xp, watch_object, object); + break; + case WATCH_TRAP_FUNCTION_UNWATCH: + gc_like_from_xp(xp, unwatch_object, 0); + break; + default: + break; + } + return true; +} + Index: /branches/working-0711/ccl/lisp-kernel/x86-exceptions.h =================================================================== --- /branches/working-0711/ccl/lisp-kernel/x86-exceptions.h (revision 12993) +++ /branches/working-0711/ccl/lisp-kernel/x86-exceptions.h (revision 12994) @@ -138,4 +138,7 @@ #define UUO_DEBUG_TRAP 0xca #define UUO_DEBUG_TRAP_WITH_STRING 0xcd +#define UUO_WATCH_TRAP 0xce + #define WATCH_TRAP_FUNCTION_WATCH 0 + #define WATCH_TRAP_FUNCTION_UNWATCH 1 #define XUUO_OPCODE_0 0x0f Index: /branches/working-0711/ccl/lisp-kernel/x86-gc.c =================================================================== --- /branches/working-0711/ccl/lisp-kernel/x86-gc.c (revision 12993) +++ /branches/working-0711/ccl/lisp-kernel/x86-gc.c (revision 12994) @@ -26,4 +26,25 @@ #include +#ifdef X8632 +static inline natural +imm_word_count(LispObj fn) +{ + natural w = ((unsigned short *)fn)[-1]; + + if (w & 0x8000) { + /* + * The low 15 bits encode the number of contants. + * Compute and return the immediate word count. + */ + LispObj header = header_of(fn); + natural element_count = header_element_count(header); + + return element_count - (w & 0x7fff); + } else { + /* The immediate word count is encoded directly. */ + return w; + } +} +#endif /* Heap sanity checking. */ @@ -318,4 +339,5 @@ switch (code) { case AREA_DYNAMIC: + case AREA_WATCHED: case AREA_STATIC: case AREA_MANAGED_STATIC: @@ -959,14 +981,5 @@ header = *(natural *)base; subtag = header_subtag(header); - boundary = base + (unsigned short)base[1]; - - /* XXX bootstrapping */ - { - natural word_count = (unsigned short)base[1]; - natural element_count = header_element_count(header); - - if (word_count & 0x8000) - boundary = base + element_count - (word_count & 0x7fff); - } + boundary = base + imm_word_count(fn); /* @@ -991,13 +1004,5 @@ subtag = header_subtag(header); if (subtag == subtag_function) { - boundary = base + (unsigned short)base[1]; - /* XXX bootstrapping */ - { - natural word_count = (unsigned short)base[1]; - natural element_count = header_element_count(header); - - if (word_count & 0x8000) - boundary = base + element_count - (word_count & 0x7fff); - } + boundary = base + imm_word_count(this); *((int *)boundary) &= 0xff; @@ -1902,14 +1907,8 @@ LispObj fn = fulltag_misc + (LispObj)node; unsigned char *p = (unsigned char *)node; - natural i, offset; - LispObj header = *node; - - i = ((unsigned short *)node)[2]; + natural i = imm_word_count(fn); + if (i) { - /* XXX bootstrapping for new scheme */ - if (i & 0x8000) { - i = header_element_count(header) - (i & 0x7fff); - } - offset = node[--i]; + natural offset = node[--i]; while (offset) { @@ -1983,10 +1982,6 @@ if (header_subtag(node) == subtag_function) { #ifdef X8632 - int skip = *((unsigned short *)src); LispObj *f = dest; - - /* XXX bootstrapping for new scheme */ - if (skip & 0x8000) - skip = elements - (skip & 0x7fff); + int skip = imm_word_count(fulltag_misc + (LispObj)current); #else int skip = *((int *)src); @@ -2811,2 +2806,255 @@ return -1; } + +/* + * This stuff is all adapted from the forward_xxx functions for use by + * the watchpoint code. It's a lot of duplicated code, and it would + * be nice to generalize it somehow. + */ + +static inline void +wp_maybe_update(LispObj *p, LispObj old, LispObj new) +{ + if (*p == old) { + *p = new; + } +} + +static void +wp_update_headerless_range(LispObj *start, LispObj *end, + LispObj old, LispObj new) +{ + LispObj *p = start; + + while (p < end) { + wp_maybe_update(p, old, new); + p++; + } +} + +static void +wp_update_range(LispObj *start, LispObj *end, LispObj old, LispObj new) +{ + LispObj *p = start, node; + int tag_n; + natural nwords; + + while (p < end) { + node = *p; + tag_n = fulltag_of(node); + + if (immheader_tag_p(tag_n)) { + p = (LispObj *)skip_over_ivector(ptr_to_lispobj(p), node); + } else if (nodeheader_tag_p(tag_n)) { + nwords = header_element_count(node); + + nwords += 1 - (nwords & 1); + + if ((header_subtag(node) == subtag_hash_vector) && + ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { + natural skip = hash_table_vector_header_count - 1; + hash_table_vector_header *hashp = (hash_table_vector_header *)p; + + p++; + nwords -= skip; + while(skip--) { + if (*p == old) *p = new; + p++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "p" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (*p == old && hashp) { + *p = new; + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + p++; + if (*p == old) *p = new; + p++; + } + *p++ = 0; + } else { + if (header_subtag(node) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)(p[1]); + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = header_element_count(node) - (skip & 0x7fff); + +#else + int skip = (int)(p[1]); +#endif + p += skip; + nwords -= skip; + } + p++; + while(nwords--) { + wp_maybe_update(p, old, new); + p++; + } + } + } else { + /* a cons cell */ + wp_maybe_update(p, old, new); + p++; + wp_maybe_update(p, old, new); + p++; + } + } +} + +#ifdef X8664 +static void +wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new) +{ + natural *regs = (natural *)xpGPRvector(xp); + + wp_maybe_update(®s[Iarg_z], old, new); + wp_maybe_update(®s[Iarg_y], old, new); + wp_maybe_update(®s[Iarg_x], old, new); + wp_maybe_update(®s[Isave3], old, new); + wp_maybe_update(®s[Isave2], old, new); + wp_maybe_update(®s[Isave1], old, new); + wp_maybe_update(®s[Isave0], old, new); + wp_maybe_update(®s[Ifn], old, new); + wp_maybe_update(®s[Itemp0], old, new); + wp_maybe_update(®s[Itemp1], old, new); + wp_maybe_update(®s[Itemp2], old, new); + +#if 0 + /* + * We don't allow watching functions, so this presumably doesn't + * matter. + */ + update_locref(&(regs[Iip])); +#endif +} +#else +static void +wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new, natural node_regs_mask) +{ + natural *regs = (natural *)xpGPRvector(xp); + + if (node_regs_mask & (1<<0)) wp_maybe_update(®s[REG_EAX], old, new); + if (node_regs_mask & (1<<1)) wp_maybe_update(®s[REG_ECX], old, new); + + if (regs[REG_EFL] & EFL_DF) { + /* then EDX is an imm reg */ + ; + } else + if (node_regs_mask & (1<<2)) wp_maybe_update(®s[REG_EDX], old, new); + + if (node_regs_mask & (1<<3)) wp_maybe_update(®s[REG_EBX], old, new); + if (node_regs_mask & (1<<4)) wp_maybe_update(®s[REG_ESP], old, new); + if (node_regs_mask & (1<<5)) wp_maybe_update(®s[REG_EBP], old, new); + if (node_regs_mask & (1<<6)) wp_maybe_update(®s[REG_ESI], old, new); + if (node_regs_mask & (1<<7)) wp_maybe_update(®s[REG_EDI], old, new); + /* we shouldn't watch functions, so no need to update PC */ +} +#endif + +static void +wp_update_tcr_xframes(TCR *tcr, LispObj old, LispObj new) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { +#ifdef X8664 + wp_update_xp(xp, old, new); +#else + wp_update_xp(xp, old, new, tcr->node_regs_mask); + wp_maybe_update(&tcr->save0, old, new); + wp_maybe_update(&tcr->save1, old, new); + wp_maybe_update(&tcr->save2, old, new); + wp_maybe_update(&tcr->save3, old, new); + wp_maybe_update(&tcr->next_method_context, old, new); +#endif + } + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { +#ifdef X8664 + wp_update_xp(xframes->curr, old, new); +#else + wp_update_xp(xframes->curr, old, new, xframes->node_regs_mask); +#endif + } +} + +/* + * Scan all pointer-bearing areas, updating all references to + * "old" to "new". + */ +static void +wp_update_all_areas(LispObj old, LispObj new) +{ + area *a = active_dynamic_area; + natural code = a->code; + + while (code != AREA_VOID) { + switch (code) { + case AREA_DYNAMIC: + case AREA_STATIC: + case AREA_MANAGED_STATIC: + case AREA_WATCHED: + wp_update_range((LispObj *)a->low, (LispObj *)a->active, old, new); + break; + case AREA_VSTACK: + { + LispObj *low = (LispObj *)a->active; + LispObj *high = (LispObj *)a->high; + + wp_update_headerless_range(low, high, old, new); + } + break; + case AREA_TSTACK: + { + LispObj *current, *next; + LispObj *start = (LispObj *)a->active, *end = start; + LispObj *limit = (LispObj *)a->high; + + for (current = start; end != limit; current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + wp_update_range(current+2, end, old, new); + } + break; + } + default: + break; + } + a = a->succ; + code = a->code; + } +} + +static void +wp_update_tcr_tlb(TCR *tcr, LispObj old, LispObj new) +{ + natural n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer; + LispObj *end = start + (n >> fixnumshift); + + while (start < end) { + wp_maybe_update(start, old, new); + start++; + } +} + +void +wp_update_references(TCR *tcr, LispObj old, LispObj new) +{ + TCR *other_tcr = tcr; + + do { + wp_update_tcr_xframes(other_tcr, old, new); + wp_update_tcr_tlb(other_tcr, old, new); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + wp_update_all_areas(old, new); +}