From 3a0f3612dc2bbf3e4e8e7395bcbbf8cd1791b963 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 21 Feb 2006 22:59:29 +0000 Subject: [PATCH] 0.9.9.36: Merge Cyrus Harmon's 7th gencgc merge candidate ... with the addition of idempotent implementations of arch_clear_pseudo_atomic_interrupted() for sparc, mips, alpha and hppa. (the last three completely untested). ... many, many changes, most of which are documented in doc/internals-notes/GENCGC-PORTING-NOTES (This commit may break horribly. Please read, please test) --- CREDITS | 4 +- NEWS | 6 +- doc/internals-notes/GENCGC-PORTING-NOTES | 639 ++++++++++++++++++++++++++++++ make-config.sh | 4 +- package-data-list.lisp-expr | 2 + src/assembly/ppc/arith.lisp | 7 +- src/assembly/ppc/array.lisp | 19 +- src/code/ppc-vm.lisp | 2 - src/compiler/generic/genesis.lisp | 35 +- src/compiler/ppc/alloc.lisp | 80 ++-- src/compiler/ppc/array.lisp | 7 +- src/compiler/ppc/c-call.lisp | 22 +- src/compiler/ppc/call.lisp | 30 +- src/compiler/ppc/insts.lisp | 2 +- src/compiler/ppc/macros.lisp | 148 +++++-- src/compiler/ppc/move.lisp | 10 +- src/compiler/ppc/parms.lisp | 49 ++- src/runtime/Config.ppc-darwin | 5 +- src/runtime/Config.ppc-linux | 5 +- src/runtime/alloc.c | 32 +- src/runtime/alpha-arch.c | 5 + src/runtime/arch.h | 3 + src/runtime/bsd-os.c | 24 +- src/runtime/cheneygc.c | 1 - src/runtime/gc-common.c | 14 +- src/runtime/gc-internal.h | 5 + src/runtime/gc.h | 50 +++ src/runtime/gencgc.c | 270 +++++++++++-- src/runtime/globals.c | 2 +- src/runtime/globals.h | 13 +- src/runtime/hppa-arch.c | 6 + src/runtime/interrupt.c | 15 +- src/runtime/mips-arch.c | 9 +- src/runtime/parse.c | 9 +- src/runtime/ppc-arch.c | 274 ++++++++++++- src/runtime/ppc-assem.S | 108 ++++- src/runtime/ppc-darwin-spacelist.h | 16 +- src/runtime/ppc-lispregs.h | 3 + src/runtime/purify.c | 32 +- src/runtime/save.c | 18 +- src/runtime/sparc-arch.c | 9 +- version.lisp-expr | 2 +- 42 files changed, 1741 insertions(+), 255 deletions(-) create mode 100644 doc/internals-notes/GENCGC-PORTING-NOTES diff --git a/CREDITS b/CREDITS index 4a730a0..1f707f8 100644 --- a/CREDITS +++ b/CREDITS @@ -588,7 +588,9 @@ Bruno Haible: primordial CMUCL. Cyrus Harmon: - He fixed many PPC FFI and callback bugs. + He fixed many PPC FFI and callback bugs. He ported Raymond Toy's + work on the generational garbage collector for PPC to Linux, finding + and fixing other SBCL bugs in the process. Matthias Hoelzl: He reported and fixed COMPILE's misbehavior on macros. diff --git a/NEWS b/NEWS index fa06808..a309ef7 100644 --- a/NEWS +++ b/NEWS @@ -4,12 +4,16 @@ changes in sbcl-0.9.10 relative to sbcl-0.9.9: be used for bundling the runtime and the core file into one executable binary. This feature is not currently supported on all SBCL platforms. (thanks to James Bielman and NIIMI Satoshi) + * new feature: a generational or ephemeral garbage collector is now + the default on the PowerPC platform (both Linux and Darwin). The + old Cheney (stop and copy) collector is a build-time option. + (thanks to Cyrus Harmon, after Raymond Toy) * minor incompatible change: the method by which SBCL finds its contributed modules has changed; it no longer relies on symbolic links from an $SBCL_HOME/systems directory, but searches directly in the subdirectories of $SBCL_HOME. * enhancement: the dynamic heap size on the Linux/PPC platform is - markedly larger. + markedly larger, even using the older Cheney garbage collector. * fixed bug #399: full call to DATA-VECTOR-REF in accesses to certain complicated string types. (reported by Gary King) * fixed bug: STRING-TO-OCTETS and OCTETS-TO-STRING did not convert diff --git a/doc/internals-notes/GENCGC-PORTING-NOTES b/doc/internals-notes/GENCGC-PORTING-NOTES new file mode 100644 index 0000000..badadaa --- /dev/null +++ b/doc/internals-notes/GENCGC-PORTING-NOTES @@ -0,0 +1,639 @@ + +==================================================== +OPEN GENGC BUGS +==================================================== + +7. OPEN. This isn't really a GENGC bug, but, for completeness, we + should fix ppc-vm.lisp so that the fixup can take an offset a la + x86-64. This was done in generic.lisp, but needs corresponding + changes in pcc-vm.lisp + +==================================================== +CLOSED GENGC BUGS +==================================================== + +1. FIXED. Occasional inline allocation failures? I'm guessing that's + what we're seeing here. Certain operations take a long time and + involve a lot kernel_task CPU activity. It's possible that this is + just I/O, but I don't think so. This seems to have gotten worse + recently. Changing the allocation macro to not use a fixup with an + offset fixes this. + +2. FIXED. Purify fails. Running the core-test.sh test causes a BUS + ERROR. The problem was that calling alien-callbacks loaded from a + saved core was failing. See note in + c-call.lisp/alien-assembler-callback-wrapper for details. + +3. FIXED! cons-madly test (gc.impure.lisp) fails and + drops into LDB. My hunch is that this is related to the + allocation/moving of large objects in gencgc.c. + +4. FIXED. PPC/Linux gencgc fails with a BUS ERROR (SIGSEGV maybe?) + after the first GC. + +5. FIXED. sb-md5 and cltl2 often (but not always) fail to build out of + contrib. Latest gencgc fixes seem to have fixed this. Keep an eye + out for it though. I think the allocation macro fixup changes fixed + this one. + +6. FIXED. finalize-test.sh fails. finalizers weren't being run + properly. removed #ifdef LISP_FEATURE_X86[_64] in + gencgc.c/scav_weak_pointer and now things seem to work. + +8. NOT A BUG. In insts.lisp, we do a lis/addi to load the address of a + fixup. This should really be lis/ori, but the ori instruction + doesn't deal with fixups. This should be fixed, but doesn't seem to + be rearing its ugly head at the moment. This is wrong. The fixup + deals with adjusting the high word such that the the lis/addi + sequence functions correctly here. + +9. FIXED. x86-64 builds busted. they build ok, but then can't do a + full rebuild of themselves. They die after the first purify. + GENCGC_RUNS_1 works, GENCGC_CANDIDATE_1 breaks. Wrongly #ifdef'ed + out an os_zero call in purify.c. Restoring this fixes things. + + + +==================================================== +CVS tag: ALLOCATION_CLEANUP_1 +==================================================== + +File: src/assembly/ppc/arith.lisp +================ + +* Fixed allocation for CONS-BIGNUM. Note that we now always cons 2 words + instead of trying to fit into 1 word first + +File: src/compiler/ppc/alloc.lisp +================ + +* Fixed vop for list-or-list*. Uses the allocation macro instead of + setting alloc-tn directly. Note that the (relatively) recent dynamic + extent support should still work here. In this case, we directly + allocate this by adjusting csp-tn. + +* Fixed vop for make-closure. See note above. Dynamic extent should + still work. + +* TODO: [FUTURE] add stack allocation to the allocate macro. + +File: src/compiler/ppc/macros.lisp + +* Added allocation macro. Note that this is using king nato's version + and may not do everything we need to do for GENCGC. + +* with-fixed-allocation changes. Now takes a keyword argument (:lowtag + other-pointer-lowtag). Removed restriction on having a non-empty + body as we can use this macro just for allocating data. Now uses the + allocation macro instead of adjusting alloc-tn directly. + +* Removed the :extra keyword argument from pseudo-atomic. Don't use + this for allocating memory anymore! Removed the corresponding gensym + and let. This is still King Nato's pseudo-atomic. At some point we + should better understand the differences between rtoy's version and + king nato's version. + + +File: move.lisp +=============== + +* move-from-unsigned vop now uses with-fixed allocation instead of + setting alloc-tn directly. We always allocate two words now instead + of trying to get away with one first. + + +==================================================== +CVS tag: ALLOCATION_CLEANUP_2 +==================================================== + +File: src/assembly/ppc/array.lisp +============================= + +* Fixed allocate-vector assembly-routine to use allocate macro instead + of adjusting alloc-tn directly. + +File: src/compiler/ppc/array.lisp +============================= + +* make-array-header vop now uses allocation macro instead of setting + alloc-tn directly + +File: src/compiler/ppc/call.lisp +============================ + +* listify-rest-args now uses the allocation macro instead of adjusting + alloc-tn directly. For dynamic extent args, we still allocate + directly by adjusting csp-tn. We should implement stack allocation + in the allocation macro. + + +==================================================== +CVS tag: BUILD_CLEANUP_1 +==================================================== + +File: src/code/ppc-vm.lisp + +* Add flag disabling scavenging of read-only space (to be used later) + +File: src/compiler/ppc/parms.lisp + +* Add gencgc-page-size variable. Currently 4096. Bump to 32k later. + +* Added dynamic-space-start and dynamic-space-end constants for linux + and darwin #!+gencgc. Conditionalized dynamic-0 and dynamic-1 + constants for#!-gencgc. + +* Added *restart-lisp-function*, *current-region-end-addr* and + *scavenge-read-only-space* static-symbols. + +File: src/runtime/Config.ppc-darwin + +* Make GC_SRC shell commands that search for LISP_FEATURE_GENCGC in + genesis/config.h and set GC_SRC to gencgc.c or cheneygc.c as + appropriate + +File: src/runtime/Config.ppc-linux + +* Make GC_SRC shell commands that search for LISP_FEATURE_GENCGC in + genesis/config.h and set GC_SRC to gencgc.c or cheneygc.c as + appropriate + +==================================================== +CVS tag: GENCGC_PREP_1 +==================================================== + +File: src/runtime/arch.h + +* Moved extern fpu_save and fpu_restore defintions here + +File: src/runtime/cheneygc.c + +* removed static scavenge_interrupt_contexts prototype + +File: gc-common.c + +* Instead of #ifndef LISP_FEATURE_SPARC for scav_fdefn, use + defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) + +* Instead of #ifndef LISP_FEATURE_GENCGC for scav_fun_header and + scav_return_pc_header scavtab entries, use #if + !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) + +* set scav_tab[FDEFN_WIDETAG] to scav_fdefn on X86 and X86_64 and + scav_boxed for everything else. + +File: gc-internal.h + +* added prototype for scavenge_interrupt_contexts + +==================================================== +CVS tag: GENCGC_PREP_2 +==================================================== + +File: gc-common.c + +* Reverted gc-common.c changes from GENCGC_PREP_1. The problem was + that I was mimicing rtoy's FDEFN changes for PPC, superficially, + without changing the underlying code. He changed the way fdefn's + work on ppc to look more like they do on SPARC. I think we can get + away with leaving this alone, at least for now. + +File: ppc-arch.c + +* Moved PSEUDO_ATOMIC_INTERRUPTED_BIAS to ppc-arch.h + +File: ppc-arch.h + +* Moved PSEUDO_ATOMIC_INTERRUPTED_BIAS to ppc-arch.h + +File: ppc-assem.S + +* Added do_pending_interrupt, fpu_save and fpu_restore. + +File: ppc-darwin-spacelist.h + +* Adjust spaces for #+gencgc and #-gencgc + +File: purify.c + +* #ifdef LISP_FEATURE_GENCGC -> X86{_64} + +File: gencgc.c + +* Remove fpu_save and fpu_restore prototypes + +==================================================== +CVS tag: GENCGC_PREP_3 +==================================================== + +File: src/runtime/gc.h + +* Added xxx_pseudo_atomic_xxx and xxx_alloc_pointer #defines + +File: src/runtime/alloc.c + +* Start using xxx_pseudo_atomic_xxx + +==================================================== +CVS tag: GENCGC_PREP_4 +==================================================== + +File: src/runtime/globals.c + +* Cleaning up GENCGC/X86[_64] ifdefs + +File: src/runtime/globals.h + +* Cleaning up GENCGC/X86[_64] ifdefs + +File: src/runtime/parse.c + +* Use get_alloc_pointer instead of arch specific ways of doing so + +==================================================== +CVS tag: PSEUDO_ATOMIC_REG_ALLOC +==================================================== + +File: compiler/ppc/macros.lisp + +* Pseudo-atomic now uses bits 3 and 1 of reg_ALLOC insetead of using + reg_NL3 for the interrutped part. + +File: src/runtime/gc.h + +* Pseudo-atomic now uses bits 3 and 1 of reg_ALLOC insetead of using + reg_NL3 for the interrutped part. + +File: src/runtime/ppc-arch.c + +* Pseudo-atomic now uses bits 3 and 1 of reg_ALLOC insetead of using + reg_NL3 for the interrutped part. + +* Brought the allocation trap stuff along, but this is untested. + +File: src/runtime/ppc-assem.S + +* Pseudo-atomic now uses bits 3 and 1 of reg_ALLOC insetead of using + reg_NL3 for the interrutped part. + +==================================================== +CVS tag: GENCGC_BUILDS_1 +==================================================== + +File: src/runtime/gencgc.c + +* The big kahuna... + +* Ok, lots of little changes to get things working. Had to fix up the + allocation macro, the uses of it, etc... + + +==================================================== +CVS tag: GENCGC_RUNS_1 +==================================================== + +* Ok, it runs now, but we seem to trap on every allocation. Trying to + figure out why. Works -gencgc/ppc and works on x86-64. + +==================================================== +CVS tag: GENCGC_RUNS_INLINE_ALLOCATION_1 +==================================================== + +File: src/compiler/generic/genesis.lisp + +* do-cold-fixup now looks at the SI portion of PPC instructions in :ha + and :l fixups and uses these as offsets in calculating the address. + +File: src/compiler/ppc/insts.lisp + +* in define-d-si-instruction we now stick the fikup-offset into the si + portion of the opcode instead of always using 0. This allows us to + pass this information on to do-cold-fixup in genesis.lisp. + +File: src/compiler/ppc/macros.lisp + +* gencgc allocation macro now uses fixups to boxed_region.free_pointer + and boxed_region.end_addr to get these values instead of pulling + them out of registers. This removes the need to keep these registers + in sync with the C struct values. And it is more like what we will + eventually need to do if we ever do PPC threads. + +File: src/runtime/gc.h + +* removed set_current_region_free, get_current_free, and + set_current_region_end. + +File: src/runtime/gencgc.c + +* In gc_alloc_new_region, use page_address(last_page) + PAGE_BYTES to + get the end_addr instead of start_addr + bytes_found. + +* removed set_current_region_end calls. + +File: src/runtime/ppc-arch.c + +* include gencgc-alloc-region.h + +* look back 3 instructions instead of 2 to match the new allocation + macro + +* added end_addr variable for debugging. + +* no longer adjust dynamic_space_free_pointer + +==================================================== +CVS TAG: GENCGC_MOSTLY_WORKING_1 +==================================================== + +* Making purify and loading callbacks from cores work for ppc/gengc. + +* Remove *scavenge-read-only-space* + +File: src/compiler/ppc/c-call.lisp + +* Fixed alien-callback-assembler-wrapper to get the address for + enter-alien-callback from the symbol-value slot of + SB-ALIEN::*ENTER-ALIEN-CALLBACK* to ensure that this works even if + the GC moves ENTER-ALIEN-CALLBACK. Thanks to JES for the suggestion + on the fix. callback.impure.lisp now passes. + +File: src/runtime/gencgc.c + +* Removed #ifdef LISP_FEATURE_X86[_64] in + gengcc.c/scav_weak_pointer. Definitely some OOAO violations here, + but now finalize.test.sh passes. + +==================================================== +CVS TAG: GENCGC_MOSTLY_WORKING_2 +==================================================== + +* New allocation macro. Seems to make things better. + +==================================================== +CVS TAG: GENCGC_MOSTLY_WORKING_3 +==================================================== + +* Trying to undo damage done along the way. Lots of little + changes. Please document these in the morning. + +==================================================== +CVS TAG: This stuff never got tagged. I backed it out before I tagged + it. +==================================================== + +* Added ARCH_HAS_CTR_REGISTER and friends. Now we fixup the CTR in + scavenge_interrupt_context. Whoops. Backed this out as it seemed to + be messing things up. + +==================================================== +CVS TAG: GENCGC_ALL_TESTS_PASSED +==================================================== + +File: src/runtime/gc.h + +* set_alloc_pointer now just sets the high bits and leaves the p-a + flags alone. + +File: src/runtime/interrupt.c + +* interrupt_handle_pending clears the p-a-interrupted flag + +* undo_fake_foreign_function_call doesn't zap the p-a bits in + reg_ALLOC + +File: src/runtime/ppc-arch.c + +* handle_allocation_trap doesn't zap the p-a bits in reg_ALLOC + +==================================================== +CVS TAG: GENCGC_ALL_0_9_9_27_MERGE +==================================================== + +* Forward ported to 0.9.9.27 + +==================================================== +CVS TAG: GENCGC_CANDIDATE_1 +==================================================== + +File: src/runtime/ppc-assem.S + +* Massive props to Xophe for finding this. For a long time now, we had + been using lis, addi to load the address of NIL. Turns out this + fails when the high bit of the low word is set. I have no idea how + we missed this for so long, but changing the instruction sequence to + lis, ori fixes the problem of linux/ppc gencgc not working. + +File: src/runtime/ppc-arch.c + +* Turn off the address checking in arch_get_bad_addr. The pointer + arithmetic was wrong and was causing problems. We don't really need + this check (right?). + +File: src/code/toplevel.lisp + +* Fix the way we compute the end-of-stack in scrub-control-stack. + +File: src/runtime/bsd-os.c + +* Use arch_get_bad_addr to get fault address + +==================================================== +CVS TAG: GENCGC_SBCL_0_9_9_34_MERGE +==================================================== + +* Forward ported to 0.9.9.34 + +==================================================== +CVS TAG: GENCGC_CANDIDATE_2 +==================================================== + +File: src/compiler/ppc/macros.lisp + +* cleaned up comments for allocation macro + +* removed commented code that used to throw an error for empty + allocation macro body. Now we call this for its side effect of + allocating memory + +File: src/compiler/ppc/parms.lisp + +* gencgc-page-size -> 4096 + +* added pseudo-atomic-interrupted-flag and pseudo-atomic-flag + +File: src/runtime/alloc.c + +* clr_pseudo_atomic -> clear_pseudo_atomic + +File: src/runtime/gc.h + +* clr_pseudo_atomic -> clear_pseudo_atomic + +* PSEUDO_ATOMIC_[INTERRUPTED_]VALUE -> flag_PseudoAtomic[Interrupted] + +File: src/runtime/interrupt.c + +* clr_pseudo_atomic -> clear_pseudo_atomic + +File: src/runtime/ppc-arch.c + +* whitespace fix + +File: package-data-list.lisp-expr + +* added PSEUDO-ATOMIC-INTERRUPTED-FLAG and PSEUDO-ATOMIC-FLAG to sb-vm + exports + +==================================================== +CVS TAG: GENCGC_SBCL_0_9_9_35_MERGE +==================================================== + +* Forward parted to 0.9.9.35 + +==================================================== +CVS TAG: GENCGC_CANDIDATE_3 +==================================================== + +NOTE: This includes the fix for the problem where x86-64 couldn't +build itself. I erroneously removed an os_zero in purify.c. This has +been restored. + +File: src/runtime/purify.c + +* remove ifndef GENCGC check around os_zero call +* undo recent change to add back in a bit setting the + dynamic_space_free_pointer on x86[_64]. I don't think we need this + +File: src/runtime/parse.c + +* dunamic_space_free_ptr -> dynamic_space_free_pointer + +File: src/runtime/ppc-arch.c + +* Fixing comment text in allocation_trap_p +* arch_clr_pseudo_atomic_interrupted -> + arch_clear_pseudo_atomic_interrupted + +File: src/runtime/gc-common.c + +* restore workaround behvaior for !GENCGC, not !X86[_64] + +* whitespace fix + +File :src/runtime/gencgc.c + +* undoing gratuitous spacing changes and fixing whitespace +* remove bogus comment + +==================================================== +CVS TAG: GENCGC_CANDIDATE_4 +==================================================== + +File: src/runtime/purify.c + +* Use dynamic_space_purify_pointer instead of + dynamic_space_free_pointer to mark the end of the dynamic_space + that we purify +* call gc_free_heap in purify when using GENCGC + +File: src/runtime/interrupt.c + +clear_psuedo_atomic_interrupted -> arch_clear_pseudo_atomic_interrupted + +==================================================== +CVS TAG: GENCGC_CANDIDATE_5 +** Note: not tagged, but patch made +==================================================== + +File: src/runtime/assembly/ppc/array.lisp + +* cleaning up comment + +File: src/code/ppc-vm.lisp + +* removed unused commented-out chunk + +File: src/compiler/generic/genesis.lisp + +* Added FIXME about ppc offset fixups only being half-done + +File: src/compiler/ppc/c-call.lisp + +* Comment cleanup + +File: src/compiler/ppc/macros.lisp + +* Allocation macro comment cleanup + +File: src/runtime/gc.h + +* Whitespace + +* #ifdef GENCGC for the p_a macros + +File: src/runtime/gencgc.c + +* whitespace + +* removed bogus comment + +* restore gc_assert for alignment check on PPC + +File: src/runtime/globals.h + +* updated comment about dyanmic_space_free_pointer + +File: src/runtime/interrupt.c + +* whitespace + +File: src/runtime/ppc-arch.c + +* Remove pc checking stuff + +* remove SIGILL handling and adjust comment + +* whitespace + +* updated comment aboud dynamic_space_free_pointer + +File: src/runtime/ppc-arch.h + +* removed bogus comment + +File: src/runtime/ppc-darwin-spacelist.h + +* removed extraneous space + +==================================================== +CVS TAG: GENCGC_CANDIDATE_6 +==================================================== + +File: src/runtime/ppc-arch.c + +* Removed enable_some_signals and call to it. We don't need these + signals on when we call alloc, but CMUCL does. + +File: src/runtime/alloc.c + +* Put in Xophe's fix against GC moving a newly pointer from moving out + from under us when we handle a pending interrupt. If the C stack is + not scavenged during GC, result needs to be protected against not + being referred to by any roots, so we push it onto the lisp control + stack, and read it back off after any potential GC has finished + +==================================================== +CVS TAG: GENCGC_CANDIDATE_7 +==================================================== + +* Fix mismatched } and #endif in bsd-os.c/memory_fault_handler + +==================================================== +Untagged Changes +==================================================== + + +==================================================== +Uncommited Changes +==================================================== + diff --git a/make-config.sh b/make-config.sh index d4feae3..c117245 100644 --- a/make-config.sh +++ b/make-config.sh @@ -281,11 +281,11 @@ elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "linux" ]; then # versions 2.3.1 and 2.3.2 # # FIXME: integrate to grovel-features., maypahps - printf ' :stack-allocatable-closures :linkage-table' >> $ltf + printf ' :gencgc :stack-allocatable-closures :linkage-table' >> $ltf $GNUMAKE -C tools-for-build where-is-mcontext -I src/runtime tools-for-build/where-is-mcontext > src/runtime/ppc-linux-mcontext.h elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "darwin" ]; then - printf ' :stack-allocatable-closures' >> $ltf + printf ' :gencgc :stack-allocatable-closures' >> $ltf # We provide a dlopen shim, so a little lie won't hurt printf " :os-provides-dlopen :linkage-table :alien-callbacks" >> $ltf # The default stack ulimit under darwin is too small to run PURIFY. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index c266fa7..b5e0026 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2167,6 +2167,8 @@ structure representations" "FUNCALLABLE-INSTANCE-LAYOUT-SLOT" "FUNCALLABLE-INSTANCE-LEXENV-SLOT" "GENCGC-PAGE-SIZE" + #!+ppc "PSEUDO-ATOMIC-INTERRUPTED-FLAG" + #!+ppc "PSEUDO-ATOMIC-FLAG" "GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER" "IMMEDIATE-CHARACTER-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER" "IMMEDIATE-SC-NUMBER" "*INITIAL-DYNAMIC-SPACE-FREE-POINTER*" diff --git a/src/assembly/ppc/arith.lisp b/src/assembly/ppc/arith.lisp index ea9fc11..fd5fad9 100644 --- a/src/assembly/ppc/arith.lisp +++ b/src/assembly/ppc/arith.lisp @@ -153,17 +153,14 @@ CONS-BIGNUM ;; Allocate a BIGNUM for the result. - (pseudo-atomic (pa-flag :extra (pad-data-block (1+ bignum-digits-offset))) + (with-fixed-allocation (res pa-flag temp bignum-widetag + (+ bignum-digits-offset 2)) (let ((one-word (gen-label))) - (inst ori res alloc-tn other-pointer-lowtag) ;; We start out assuming that we need one word. Is that correct? (inst srawi temp lo 31) (inst xor. temp temp hi) (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag)) (inst beq one-word) - ;; Nope, we need two, so allocate the additional space. - (inst addi alloc-tn alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset)) - (pad-data-block (1+ bignum-digits-offset)))) (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) (emit-label one-word) diff --git a/src/assembly/ppc/array.lisp b/src/assembly/ppc/array.lisp index e94fa84..e59c3c0 100644 --- a/src/assembly/ppc/array.lisp +++ b/src/assembly/ppc/array.lisp @@ -25,18 +25,27 @@ (:temp ndescr non-descriptor-reg nl0-offset) (:temp pa-flag non-descriptor-reg nl3-offset) - (:temp vector descriptor-reg a3-offset)) + (:temp vector descriptor-reg a3-offset) + (:temp temp non-descriptor-reg nl2-offset)) (pseudo-atomic (pa-flag) - (inst ori vector alloc-tn other-pointer-lowtag) ;; boxed words == unboxed bytes (inst addi ndescr words (* (1+ vector-data-offset) n-word-bytes)) (inst clrrwi ndescr ndescr n-lowtag-bits) - (inst add alloc-tn alloc-tn ndescr) + (allocation vector ndescr other-pointer-lowtag + :temp-tn temp + :flag-tn pa-flag) (inst srwi ndescr type word-shift) (storew ndescr vector 0 other-pointer-lowtag) (storew length vector vector-length-slot other-pointer-lowtag)) ;; This makes sure the zero byte at the end of a string is paged in so ;; the kernel doesn't bitch if we pass it the string. - (storew zero-tn alloc-tn 0) + ;; + ;; rtoy says to turn this off as it causes problems with CMUCL. + ;; + ;; I don't think we need to do this anymore. It looks like this + ;; inherited from the SPARC port and does not seem to be + ;; necessary. Turning this on worked at some point, but I have not + ;; tested with the final GENGC-related changes. CLH 20060221 + ;; + ;; (storew zero-tn alloc-tn 0) (move result vector)) - diff --git a/src/code/ppc-vm.lisp b/src/code/ppc-vm.lisp index ce78355..c5f7b19 100644 --- a/src/code/ppc-vm.lisp +++ b/src/code/ppc-vm.lisp @@ -179,5 +179,3 @@ (sc-offsets (sb!c:read-var-integer vector index))) (values error-number (sc-offsets)))))) - - diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 803b7af..a381dfd 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1765,20 +1765,29 @@ core and return a descriptor to it." (logior (mask-field (byte 16 16) (bvref-32 gspace-bytes gspace-byte-offset)) (ldb (byte 16 0) value)))))) + ;; FIXME: PowerPC Fixups are not fully implemented. The bit + ;; here starts to set things up to work properly, but there + ;; needs to be corresponding code in ppc-vm.lisp (:ppc - (ecase kind - (:ba - (setf (bvref-32 gspace-bytes gspace-byte-offset) - (dpb (ash value -2) (byte 24 2) - (bvref-32 gspace-bytes gspace-byte-offset)))) - (:ha - (let* ((h (ldb (byte 16 16) value)) - (l (ldb (byte 16 0) value))) - (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2)) - (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) - (:l - (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2)) - (ldb (byte 16 0) value))))) + (ecase kind + (:ba + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (dpb (ash value -2) (byte 24 2) + (bvref-32 gspace-bytes gspace-byte-offset)))) + (:ha + (let* ((un-fixed-up (bvref-16 gspace-bytes + (+ gspace-byte-offset 2))) + (fixed-up (+ un-fixed-up value)) + (h (ldb (byte 16 16) fixed-up)) + (l (ldb (byte 16 0) fixed-up))) + (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2)) + (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) + (:l + (let* ((un-fixed-up (bvref-16 gspace-bytes + (+ gspace-byte-offset 2))) + (fixed-up (+ un-fixed-up value))) + (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2)) + (ldb (byte 16 0) fixed-up)))))) (:sparc (ecase kind (:call diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp index 29be679..4f83b44 100644 --- a/src/compiler/ppc/alloc.lisp +++ b/src/compiler/ppc/alloc.lisp @@ -24,11 +24,13 @@ (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) res) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:temporary (:scs (non-descriptor-reg)) alloc-temp) (:info num) (:results (result :scs (descriptor-reg))) (:variant-vars star) (:policy :safe) (:node-var node) + #!-gencgc (:ignore alloc-temp) (:generator 0 (cond ((zerop num) (move result null-tn)) @@ -47,14 +49,15 @@ (let* ((dx-p (node-stack-allocate-p node)) (cons-cells (if star (1- num) num)) (alloc (* (pad-data-block cons-size) cons-cells))) - (pseudo-atomic (pa-flag :extra (if dx-p 0 alloc)) - (let ((allocation-area-tn (if dx-p csp-tn alloc-tn))) - (when dx-p - (align-csp res)) - (inst clrrwi res allocation-area-tn n-lowtag-bits) - (inst ori res res list-pointer-lowtag) - (when dx-p - (inst addi csp-tn csp-tn alloc))) + (pseudo-atomic (pa-flag) + (if dx-p + (progn + (align-csp res) + (inst clrrwi res csp-tn n-lowtag-bits) + (inst ori res res list-pointer-lowtag) + (inst addi csp-tn csp-tn alloc)) + (allocation res alloc list-pointer-lowtag :temp-tn alloc-temp + :flag-tn pa-flag)) (move ptr res) (dotimes (i (1- cons-cells)) (storew (maybe-load (tn-ref-tn things)) ptr @@ -86,6 +89,7 @@ (unboxed-arg :scs (any-reg))) (:results (result :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:scs (non-descriptor-reg)) size) (:temporary (:scs (any-reg) :from (:argument 0)) boxed) (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) @@ -99,9 +103,8 @@ ;; Note: we don't have to subtract off the 4 that was added by ;; pseudo-atomic, because oring in other-pointer-lowtag just adds ;; it right back. - (inst ori result alloc-tn other-pointer-lowtag) - (inst add alloc-tn alloc-tn boxed) - (inst add alloc-tn alloc-tn unboxed) + (inst add size boxed unboxed) + (allocation result size other-pointer-lowtag :temp-tn ndescr :flag-tn pa-flag) (inst slwi ndescr boxed (- n-widetag-bits word-shift)) (inst ori ndescr ndescr code-header-widetag) (storew ndescr result 0 other-pointer-lowtag) @@ -131,21 +134,23 @@ (:results (result :scs (descriptor-reg))) (:generator 10 (let* ((size (+ length closure-info-offset)) - (alloc-size (pad-data-block size)) - (allocation-area-tn (if stack-allocate-p csp-tn alloc-tn))) - (pseudo-atomic (pa-flag :extra (if stack-allocate-p 0 alloc-size)) - (when stack-allocate-p - (align-csp result)) - (inst clrrwi. result allocation-area-tn n-lowtag-bits) - (when stack-allocate-p - (inst addi csp-tn csp-tn alloc-size)) - (inst ori result result fun-pointer-lowtag) - (inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag)) - (storew temp result 0 fun-pointer-lowtag))) - ;(inst lis temp (ash 18 10)) - ;(storew temp result closure-jump-insn-slot function-pointer-type) - (storew result result closure-self-slot fun-pointer-lowtag) - (storew function result closure-fun-slot fun-pointer-lowtag))) + (alloc-size (pad-data-block size))) + (pseudo-atomic (pa-flag) + (if stack-allocate-p + (progn + (align-csp result) + (inst clrrwi. result csp-tn n-lowtag-bits) + (inst addi csp-tn csp-tn alloc-size) + (inst ori result result fun-pointer-lowtag) + (inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))) + (progn + (allocation result (pad-data-block size) + fun-pointer-lowtag :temp-tn temp :flag-tn pa-flag) + (inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag)))) + ;;; should this be closure-fun-slot instead of 0? + (storew temp result 0 fun-pointer-lowtag) + (storew result result closure-self-slot fun-pointer-lowtag) + (storew function result closure-fun-slot fun-pointer-lowtag))))) ;;; The compiler likes to be able to directly make value cells. ;;; @@ -176,24 +181,18 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:generator 4 - (pseudo-atomic (pa-flag :extra (pad-data-block words)) - (cond ((logbitp 2 lowtag) - (inst ori result alloc-tn lowtag)) - (t - (inst clrrwi result alloc-tn n-lowtag-bits) - (inst ori result result lowtag))) - (when type - (inst lr temp (logior (ash (1- words) n-widetag-bits) type)) - (storew temp result 0 lowtag))))) + (with-fixed-allocation (result pa-flag temp type words :lowtag lowtag) + ))) (define-vop (var-alloc) (:args (extra :scs (any-reg))) (:arg-types positive-fixnum) (:info name words type lowtag) - (:ignore name) + (:ignore name #!-gencgc temp) (:results (result :scs (descriptor-reg))) (:temporary (:scs (any-reg)) bytes) (:temporary (:scs (non-descriptor-reg)) header) + (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:generator 6 (inst addi bytes extra (* (1+ words) n-word-bytes)) @@ -201,10 +200,5 @@ (inst addi header header (+ (ash -2 n-widetag-bits) type)) (inst clrrwi bytes bytes n-lowtag-bits) (pseudo-atomic (pa-flag) - (cond ((logbitp 2 lowtag) - (inst ori result alloc-tn lowtag)) - (t - (inst clrrwi result alloc-tn n-lowtag-bits) - (inst ori result result lowtag))) - (storew header result 0 lowtag) - (inst add alloc-tn alloc-tn bytes)))) + (allocation result bytes lowtag :temp-tn temp :flag-tn pa-flag) + (storew header result 0 lowtag)))) diff --git a/src/compiler/ppc/array.lisp b/src/compiler/ppc/array.lisp index 456a546..6e0aca3 100644 --- a/src/compiler/ppc/array.lisp +++ b/src/compiler/ppc/array.lisp @@ -23,13 +23,16 @@ (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:scs (non-descriptor-reg)) gc-temp) + #!-gencgc (:ignore gc-temp) (:results (result :scs (descriptor-reg))) (:generator 0 (pseudo-atomic (pa-flag) - (inst ori header alloc-tn other-pointer-lowtag) (inst addi ndescr rank (* (1+ array-dimensions-offset) n-word-bytes)) (inst clrrwi ndescr ndescr n-lowtag-bits) - (inst add alloc-tn alloc-tn ndescr) + (allocation header ndescr other-pointer-lowtag + :temp-tn gc-temp + :flag-tn pa-flag) (inst addi ndescr rank (fixnumize (1- array-dimensions-offset))) (inst slwi ndescr ndescr n-widetag-bits) (inst or ndescr ndescr type) diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp index a218792..be7be0e 100644 --- a/src/compiler/ppc/c-call.lisp +++ b/src/compiler/ppc/c-call.lisp @@ -485,7 +485,27 @@ (inst lis reg high) (inst ori reg reg low)))) ;; Setup the args - (load-address-into arg1 (get-lisp-obj-address #'enter-alien-callback)) + + ;; CLH 2006/02/10 -Following JES' logic in + ;; x86-64/c-call.lisp, we need to access + ;; ENTER-ALIEN-CALLBACK through the symbol-value slot + ;; of SB-ALIEN::*ENTER-ALIEN-CALLBACK* to ensure that + ;; it works if GC moves ENTER-ALIEN-CALLBACK. + ;; + ;; old way: + ;; (load-address-into arg1 (get-lisp-obj-address #'enter-alien-callback)) + + ;; new way: + ;; (load-symbol arg1 'sb!alien::*enter-alien-callback*) + ;; + ;; whoops: can't use load-symbol here as null-tn might + ;; not be loaded with the proper value as we are + ;; coming in from C code. Use nil-value constant + ;; instead, following the logic in x86-64/c-call.lisp. + (load-address-into arg1 (+ nil-value (static-symbol-offset + 'sb!alien::*enter-alien-callback*))) + (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag) + (inst li arg2 (fixnumize index)) (inst addi arg3 sp n-foreign-linkage-area-bytes) ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp index ece3e57..8468f3f 100644 --- a/src/compiler/ppc/call.lisp +++ b/src/compiler/ppc/call.lisp @@ -1043,9 +1043,11 @@ default-value-8 (emit-label loop) ;; *--dst = *--src, --count + (inst addi src src (- n-word-bytes)) (inst addic. count count (- (fixnumize 1))) - (inst lwzu temp src (- n-word-bytes)) - (inst stwu temp dst (- n-word-bytes)) + (loadw temp src) + (inst addi dst dst (- n-word-bytes)) + (storew temp dst) (inst bgt loop) (emit-label do-regs) @@ -1090,8 +1092,7 @@ default-value-8 (let* ((enter (gen-label)) (loop (gen-label)) (done (gen-label)) - (dx-p (node-stack-allocate-p node)) - (alloc-area-tn (if dx-p csp-tn alloc-tn))) + (dx-p (node-stack-allocate-p node))) (move context context-arg) (move count count-arg) ;; Check to see if there are any arguments. @@ -1101,14 +1102,21 @@ default-value-8 ;; We need to do this atomically. (pseudo-atomic (pa-flag) - (when dx-p - (align-csp temp)) ;; Allocate a cons (2 words) for each item. - (inst clrrwi result alloc-area-tn n-lowtag-bits) - (inst ori result result list-pointer-lowtag) - (move dst result) - (inst slwi temp count 1) - (inst add alloc-area-tn alloc-area-tn temp) + (if dx-p + (progn + (align-csp temp) + (inst clrrwi result csp-tn n-lowtag-bits) + (inst ori result result list-pointer-lowtag) + (move dst result) + (inst slwi temp count 1) + (inst add csp-tn csp-tn temp)) + (progn + (inst slwi temp count 1) + (allocation result temp list-pointer-lowtag + :temp-tn dst + :flag-tn pa-flag) + (move dst result))) (inst b enter) ;; Compute the next cons and store it in the current one. diff --git a/src/compiler/ppc/insts.lisp b/src/compiler/ppc/insts.lisp index 4bbf5f4..14563c0 100644 --- a/src/compiler/ppc/insts.lisp +++ b/src/compiler/ppc/insts.lisp @@ -869,7 +869,7 @@ (when (typep si 'fixup) (ecase ,fixup ((:ha :l) (note-fixup segment ,fixup si))) - (setq si 0)) + (setq si (or (fixup-offset si) 0))) (emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si))))) (define-d-rs-ui-instruction (name op &key (cost 1) other-dependencies) diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp index 41df39a..4a5d2dc 100644 --- a/src/compiler/ppc/macros.lisp +++ b/src/compiler/ppc/macros.lisp @@ -132,21 +132,113 @@ ;;;; Storage allocation: -(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size) + +;;; This is the main mechanism for allocating memory in the lisp heap. +;;; +;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG +;;; applied. The amount of space to be allocated is SIZE bytes (which +;;; must be a multiple of the lisp object size). +;;; +;;; On other platforms (Non-PPC), if STACK-P is given, then allocation +;;; occurs on the control stack (for dynamic-extent). In this case, +;;; you MUST also specify NODE, so that the appropriate compiler +;;; policy can be used, and TEMP-TN, which is needed for work-space. +;;; TEMP-TN MUST be a non-descriptor reg. FIXME: This is not yet +;;; implemented on PPC. We should implement this and replace the +;;; inline stack-based allocation that presently occurs in the +;;; VOPs. The stack-p argument is ignored on PPC. +;;; +;;; If generational GC is enabled, you MUST supply a value for TEMP-TN +;;; because a temp register is needed to do inline allocation. +;;; TEMP-TN, in this case, can be any register, since it holds a +;;; double-word aligned address (essentially a fixnum). +(defmacro allocation (result-tn size lowtag &key stack-p node temp-tn flag-tn) + ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is + ;; set. If the lowtag also has a 1 bit in the same position, we're all + ;; set. Otherwise, we need to zap out the lowtag from alloc-tn, and + ;; then or in the lowtag. + ;; Normal allocation to the heap. + (declare (ignore stack-p node) + #!-gencgc + (ignore temp-tn flag-tn)) + #!-gencgc + (let ((alloc-size (gensym))) + `(let ((,alloc-size ,size)) + (if (logbitp (1- n-lowtag-bits) ,lowtag) + (progn + (inst ori ,result-tn alloc-tn ,lowtag)) + (progn + (inst clrrwi ,result-tn alloc-tn n-lowtag-bits) + (inst ori ,result-tn ,result-tn ,lowtag))) + (if (numberp ,alloc-size) + (inst addi alloc-tn alloc-tn ,alloc-size) + (inst add alloc-tn alloc-tn ,alloc-size)))) + #!+gencgc + (let ((fix-addr (gensym)) + (inline-alloc (gensym))) + `(let ((,fix-addr (gen-label)) + (,inline-alloc (gen-label))) + ;; Make temp-tn be the size + (cond ((numberp ,size) + (inst lr ,temp-tn ,size)) + (t + (move ,temp-tn ,size))) + + (inst lr ,flag-tn (make-fixup "boxed_region" :foreign)) + (inst lwz ,result-tn ,flag-tn 0) + + ;; we can optimize this to only use one fixup here, once we get + ;; it working + ;; (inst lr ,flag-tn (make-fixup "boxed_region" :foreign 4)) + ;; (inst lwz ,flag-tn ,flag-tn 0) + (inst lwz ,flag-tn ,flag-tn 4) + + (without-scheduling () + ;; CAUTION: The C code depends on the exact order of + ;; instructions here. In particular, three instructions before + ;; the TW instruction must be an ADD or ADDI instruction, so it + ;; can figure out the size of the desired allocation. + ;; Now make result-tn point at the end of the object, to + ;; figure out if we overflowed the current region. + (inst add ,result-tn ,result-tn ,temp-tn) + ;; result-tn points to the new end of the region. Did we go past + ;; the actual end of the region? If so, we need a full alloc. + ;; The C code depends on this exact form of instruction. If + ;; either changes, you have to change the other appropriately! + (inst cmpw ,result-tn ,flag-tn) + + (inst bng ,inline-alloc) + (inst tw :lge ,result-tn ,flag-tn)) + (inst b ,fix-addr) + + (emit-label ,inline-alloc) + (inst lr ,flag-tn (make-fixup "boxed_region" :foreign)) + (inst stw ,result-tn ,flag-tn 0) + + (emit-label ,fix-addr) + ;; At this point, result-tn points at the end of the object. + ;; Adjust to point to the beginning. + (inst sub ,result-tn ,result-tn ,temp-tn) + ;; Set the lowtag appropriately + (inst ori ,result-tn ,result-tn ,lowtag)))) + +(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size + &key (lowtag other-pointer-lowtag)) &body body) "Do stuff to allocate an other-pointer object of fixed Size with a single word header having the specified Type-Code. The result is placed in Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably initializes the object." - (unless body - (bug "empty &body in WITH-FIXED-ALLOCATION")) (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn) - (type-code type-code) (size size)) - `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size)) - (inst ori ,result-tn alloc-tn other-pointer-lowtag) - (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) - (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) + (type-code type-code) (size size) (lowtag lowtag)) + `(pseudo-atomic (,flag-tn) + (allocation ,result-tn (pad-data-block ,size) ,lowtag + :temp-tn ,temp-tn + :flag-tn ,flag-tn) + (when ,type-code + (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code)) + (storew ,temp-tn ,result-tn 0 ,lowtag)) ,@body))) (defun align-csp (temp) @@ -227,26 +319,26 @@ ;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then ;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and ;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN. -(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &body forms) - (let ((n-extra (gensym))) - `(let ((,n-extra ,extra)) - (without-scheduling () - ;; Extra debugging stuff: - #+debug - (progn - (inst andi. ,flag-tn alloc-tn 7) - (inst twi :ne ,flag-tn 0)) - (inst lr ,flag-tn (- ,n-extra 4)) - (inst addi alloc-tn alloc-tn 4)) - ,@forms - (without-scheduling () - (inst add alloc-tn alloc-tn ,flag-tn) - (inst twi :lt alloc-tn 0)) - #+debug - (progn - (inst andi. ,flag-tn alloc-tn 7) - (inst twi :ne ,flag-tn 0))))) - +(defmacro pseudo-atomic ((flag-tn) &body forms) + `(progn + (without-scheduling () + ;; Extra debugging stuff: + #+debug + (progn + (inst andi. ,flag-tn alloc-tn 7) + (inst twi :ne ,flag-tn 0)) + (inst ori alloc-tn alloc-tn 4)) + ,@forms + (without-scheduling () + (inst li ,flag-tn -5) + (inst and alloc-tn alloc-tn ,flag-tn) + ;; Now test to see if the pseudo-atomic interrupted bit is set. + (inst andi. ,flag-tn alloc-tn 1) + (inst twi :ne ,flag-tn 0)) + #+debug + (progn + (inst andi. ,flag-tn alloc-tn 7) + (inst twi :ne ,flag-tn 0)))) diff --git a/src/compiler/ppc/move.lisp b/src/compiler/ppc/move.lisp index 21f330f..b410c4c 100644 --- a/src/compiler/ppc/move.lisp +++ b/src/compiler/ppc/move.lisp @@ -224,20 +224,16 @@ (:generator 20 (move x arg) (let ((done (gen-label)) - (one-word (gen-label)) - (initial-alloc (pad-data-block (1+ bignum-digits-offset)))) + (one-word (gen-label))) (inst srawi. temp x 29) (inst slwi y x 2) (inst beq done) - (pseudo-atomic (pa-flag :extra initial-alloc) + (with-fixed-allocation + (y pa-flag temp bignum-widetag (+ 2 bignum-digits-offset)) (inst cmpwi x 0) - (inst ori y alloc-tn other-pointer-lowtag) (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag)) (inst bge one-word) - (inst addi alloc-tn alloc-tn - (- (pad-data-block (+ bignum-digits-offset 2)) - (pad-data-block (+ bignum-digits-offset 1)))) (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) (emit-label one-word) (storew temp y 0 other-pointer-lowtag) diff --git a/src/compiler/ppc/parms.lisp b/src/compiler/ppc/parms.lisp index 26d2e32..fce1a51 100644 --- a/src/compiler/ppc/parms.lisp +++ b/src/compiler/ppc/parms.lisp @@ -25,6 +25,14 @@ (def!constant n-byte-bits 8) +;;; The size in bytes of the GENCGC pages. Should be a multiple of the +;;; architecture code size. +(def!constant gencgc-page-size 4096) + +;;; flags for the generational garbage collector +(def!constant pseudo-atomic-interrupted-flag 1) +(def!constant pseudo-atomic-flag 4) + (def!constant float-sign-shift 31) (def!constant single-float-bias 126) @@ -92,10 +100,16 @@ #!+linux (progn - (def!constant dynamic-0-space-start #x50000000) - (def!constant dynamic-0-space-end #x67fff000) - (def!constant dynamic-1-space-start #x68000000) - (def!constant dynamic-1-space-end #x7ffff000) + #!+gencgc + (progn + (def!constant dynamic-space-start #x50000000) + (def!constant dynamic-space-end #x7ffff000)) + #!-gencgc + (progn + (def!constant dynamic-0-space-start #x50000000) + (def!constant dynamic-0-space-end #x67fff000) + (def!constant dynamic-1-space-start #x68000000) + (def!constant dynamic-1-space-end #x7ffff000)) (def!constant linkage-table-space-start #x0a000000) (def!constant linkage-table-space-end #x0b000000) @@ -103,11 +117,18 @@ #!+darwin (progn - ;;; nothing _seems_ to be using these addresses - (def!constant dynamic-0-space-start #x10000000) - (def!constant dynamic-0-space-end #x3ffff000) - (def!constant dynamic-1-space-start #x40000000) - (def!constant dynamic-1-space-end #x6ffff000) + #!+gencgc + (progn + (def!constant dynamic-space-start #x10000000) + (def!constant dynamic-space-end #x6ffff000)) + #!-gencgc + (progn + (def!constant dynamic-0-space-start #x10000000) + (def!constant dynamic-0-space-end #x3ffff000) + + (def!constant dynamic-1-space-start #x40000000) + (def!constant dynamic-1-space-end #x6ffff000)) + (def!constant linkage-table-space-start #x0a000000) (def!constant linkage-table-space-end #x0b000000) @@ -180,7 +201,15 @@ sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending* *gc-inhibit* - *gc-pending*)) + *gc-pending* + + *restart-lisp-function* + + ;; CLH: 20060210 Taken from x86-64/parms.lisp per JES' suggestion + ;; Needed for callbacks to work across saving cores. see + ;; ALIEN-CALLBACK-ASSEMBLER-WRAPPER in c-call.lisp for gory + ;; details. + sb!alien::*enter-alien-callback*)) (defparameter *static-funs* '(length diff --git a/src/runtime/Config.ppc-darwin b/src/runtime/Config.ppc-darwin index 2dfdbc9..f9a1db3 100644 --- a/src/runtime/Config.ppc-darwin +++ b/src/runtime/Config.ppc-darwin @@ -28,7 +28,10 @@ CPPFLAGS += -no-cpp-precomp # out of this range. LINKFLAGS += -dynamic `cat ppc-darwin-link-flags` -twolevel_namespace -bind_at_load -GC_SRC = cheneygc.c +GC_SRC = $(shell if grep LISP_FEATURE_GENCGC genesis/config.h \ + > /dev/null 2>&1; \ + then echo "gencgc.c"; \ + else echo "cheneygc.c" ; fi) OS_CLEAN_FILES += ppc-darwin-mkrospace ppc-darwin-fix-rospace ppc-darwin-link-flags diff --git a/src/runtime/Config.ppc-linux b/src/runtime/Config.ppc-linux index a2c5a17..cce5c4c 100644 --- a/src/runtime/Config.ppc-linux +++ b/src/runtime/Config.ppc-linux @@ -19,7 +19,10 @@ ARCH_SRC = ppc-arch.c OS_SRC = linux-os.c ppc-linux-os.c OS_LIBS = -ldl -GC_SRC = cheneygc.c +GC_SRC = $(shell if grep LISP_FEATURE_GENCGC genesis/config.h \ + > /dev/null 2>&1; \ + then echo "gencgc.c"; \ + else echo "cheneygc.c" ; fi) # Nothing to do for after-grovel-headers. .PHONY: after-grovel-headers diff --git a/src/runtime/alloc.c b/src/runtime/alloc.c index 8296947..e10634d 100644 --- a/src/runtime/alloc.c +++ b/src/runtime/alloc.c @@ -43,15 +43,33 @@ pa_alloc(int bytes) struct thread *th = arch_os_get_current_thread(); /* FIXME: OOAO violation: see arch_pseudo_* */ - SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0),th); - SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1),th); + clear_pseudo_atomic_interrupted(th); + set_pseudo_atomic_atomic(th); result = alloc(bytes); - SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0),th); - if (fixnum_value(SymbolValue(PSEUDO_ATOMIC_INTERRUPTED,th))) - /* Even if we gc at this point, the new allocation will be - * protected from being moved, because result is on the c stack - * and points to it. */ + clear_pseudo_atomic_atomic(th); + + if (get_pseudo_atomic_interrupted(th)) { + /* WARNING KLUDGE FIXME: pa_alloc() is not pseudo-atomic on + * anything but x86[-64]. maybe_defer_handler doesn't defer + * interrupts if foreign_function_call_active + * + * If the C stack is not scavenged during GC, result needs to + * be protected against not being referred to by any roots, so + * we push it onto the lisp control stack, and read it back + * off after any potential GC has finished */ +#ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK +#ifdef LISP_FEATURE_STACK_GROWS_DOWNARD_NOT_UPWARD +#error "!C_STACK_IS_CONTROL_STACK and STACK_GROWS_DOWNWARD_NOT_UPWARD is not supported" +#endif + current_control_stack_pointer += 1; + *current_control_stack_pointer = result; +#endif do_pending_interrupt(); +#ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK + result = *current_control_stack_pointer; + current_control_stack_pointer -= 1; +#endif + } #else /* FIXME: this is not pseudo atomic at all, but is called only from * interrupt safe places like interrupt handlers. MG - 2005-08-09 */ diff --git a/src/runtime/alpha-arch.c b/src/runtime/alpha-arch.c index 339ff80..91878cd 100644 --- a/src/runtime/alpha-arch.c +++ b/src/runtime/alpha-arch.c @@ -115,6 +115,11 @@ void arch_set_pseudo_atomic_interrupted(os_context_t *context) *os_context_register_addr(context,reg_ALLOC) |= (1L<<63); } +void arch_clear_pseudo_atomic_interrupted(os_context_t *context) +{ + *os_context_register_addr(context, reg_ALLOC) &= ~(1L<<63); +} + unsigned int arch_install_breakpoint(void *pc) { unsigned int *ptr = (unsigned int *)pc; diff --git a/src/runtime/arch.h b/src/runtime/arch.h index 147bd0f..d94656b 100644 --- a/src/runtime/arch.h +++ b/src/runtime/arch.h @@ -43,4 +43,7 @@ extern lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2); extern lispobj *component_ptr_from_pc(lispobj *pc); +extern void fpu_save(void *); +extern void fpu_restore(void *); + #endif /* __ARCH_H__ */ diff --git a/src/runtime/bsd-os.c b/src/runtime/bsd-os.c index 7e9d51f..9b496c3 100644 --- a/src/runtime/bsd-os.c +++ b/src/runtime/bsd-os.c @@ -188,25 +188,25 @@ is_valid_lisp_addr(os_vm_address_t addr) static void memory_fault_handler(int signal, siginfo_t *siginfo, void *void_context) { - /* The way that we extract low level information like the fault - * address is not specified by POSIX. */ -#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) - void *fault_addr = siginfo->si_addr; -#elif defined LISP_FEATURE_DARWIN - void *fault_addr = siginfo->si_addr; -#else -#error unsupported BSD variant -#endif - os_context_t *context = arch_os_get_context(&void_context); + void *fault_addr = arch_get_bad_addr(signal, siginfo, context); + if (!gencgc_handle_wp_violation(fault_addr)) - if(!handle_guard_page_triggered(context,fault_addr)) + if(!handle_guard_page_triggered(context,fault_addr)) { #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK arrange_return_to_lisp_function(context, SymbolFunction(MEMORY_FAULT_ERROR)); #else - interrupt_handle_now(signal, siginfo, context); + if (!interrupt_maybe_gc_int(signal, siginfo, context)) { + interrupt_handle_now(signal, siginfo, context); + } +#if defined(LISP_FEATURE_DARWIN) + /* Work around G5 bug; fix courtesy gbyers */ + DARWIN_FIX_CONTEXT(context); #endif +#endif + } } + void os_install_interrupt_handlers(void) { diff --git a/src/runtime/cheneygc.c b/src/runtime/cheneygc.c index 68c8004..60bd5af 100644 --- a/src/runtime/cheneygc.c +++ b/src/runtime/cheneygc.c @@ -47,7 +47,6 @@ lispobj *new_space; lispobj *new_space_free_pointer; static void scavenge_newspace(void); -static void scavenge_interrupt_contexts(void); extern unsigned long bytes_consed_between_gcs; diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index cdbefd4..992e365 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -187,8 +187,8 @@ scavenge(lispobj *start, long n_words) (scavtab[widetag_of(object)])(object_ptr, object); } } - gc_assert_verbose(object_ptr == end, "Final object pointer %p, end %p\n", - object_ptr, end); + gc_assert_verbose(object_ptr == end, "Final object pointer %p, start %p, end %p\n", + object_ptr, start, end); } static lispobj trans_fun_header(lispobj object); /* forward decls */ @@ -320,8 +320,12 @@ trans_code(struct code *code) os_flush_icache((os_vm_address_t) (((long *)new_code) + nheader_words), ncode_words * sizeof(long)); +#endif + +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) gencgc_apply_code_fixups(code, new_code); #endif + return new_code; } @@ -698,7 +702,7 @@ size_boxed(lispobj *where) /* Note: on the sparc we don't have to do anything special for fdefns, */ /* 'cause the raw-addr has a function lowtag. */ -#ifndef LISP_FEATURE_SPARC +#if !defined(LISP_FEATURE_SPARC) static long scav_fdefn(lispobj *where, lispobj object) { @@ -1715,7 +1719,7 @@ gc_init_tables(void) scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed; scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed; scavtab[CODE_HEADER_WIDETAG] = scav_code_header; -#ifndef LISP_FEATURE_GENCGC /* FIXME ..._X86 ? */ +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) scavtab[SIMPLE_FUN_HEADER_WIDETAG] = scav_fun_header; scavtab[RETURN_PC_HEADER_WIDETAG] = scav_return_pc_header; #endif @@ -1733,7 +1737,7 @@ gc_init_tables(void) scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate; scavtab[NO_TLS_VALUE_MARKER_WIDETAG] = scav_immediate; scavtab[INSTANCE_HEADER_WIDETAG] = scav_instance; -#ifdef LISP_FEATURE_SPARC +#if defined(LISP_FEATURE_SPARC) scavtab[FDEFN_WIDETAG] = scav_boxed; #else scavtab[FDEFN_WIDETAG] = scav_fdefn; diff --git a/src/runtime/gc-internal.h b/src/runtime/gc-internal.h index f04bf6e..6645871 100644 --- a/src/runtime/gc-internal.h +++ b/src/runtime/gc-internal.h @@ -69,7 +69,11 @@ NWORDS(unsigned long x, unsigned long n_bits) * for SPARC users in that bit */ +#if defined(LISP_FEATURE_SPARC) +#define FUN_RAW_ADDR_OFFSET 0 +#else #define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG) +#endif /* values for the *_alloc_* parameters */ #define FREE_PAGE_FLAG 0 @@ -90,6 +94,7 @@ extern long (*sizetab[256])(lispobj *where); extern struct weak_pointer *weak_pointers; /* in gc-common.c */ extern void scavenge(lispobj *start, long n_words); +extern void scavenge_interrupt_contexts(void); extern void scan_weak_pointers(void); lispobj copy_large_unboxed_object(lispobj object, long nwords); diff --git a/src/runtime/gc.h b/src/runtime/gc.h index 90e94bf..2929013 100644 --- a/src/runtime/gc.h +++ b/src/runtime/gc.h @@ -33,4 +33,54 @@ extern int maybe_gc_pending; #include "fixnump.h" +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) + +#define set_alloc_pointer(value) \ + SetSymbolValue(ALLOCATION_POINTER, value, 0) +#define get_alloc_pointer() \ + SymbolValue(ALLOCATION_POINTER, 0) +#define get_binding_stack_pointer(thread) \ + SymbolValue(BINDING_STACK_POINTER, thread) +#define get_pseudo_atomic_atomic(thread) \ + SymbolValue(PSEUDO_ATOMIC_ATOMIC, thread) +#define set_pseudo_atomic_atomic(thread) \ + SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1), thread); +#define clear_pseudo_atomic_atomic(thread) \ + SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0), thread); +#define get_pseudo_atomic_interrupted(thread) \ + fixnum_value(SymbolValue(PSEUDO_ATOMIC_INTERRUPTED, thread)) +#define clear_pseudo_atomic_interrupted(thread) \ + SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0), thread) +#define set_pseudo_atomic_interrupted(thread) \ + SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1), thread) + +#elif defined(LISP_FEATURE_PPC) && defined(LISP_FEATURE_GENCGC) + +#define set_alloc_pointer(value) \ + (dynamic_space_free_pointer = \ + (value) | (((unsigned long)dynamic_space_free_pointer) & LOWTAG_MASK)) + +#define get_alloc_pointer() \ + ((unsigned long) dynamic_space_free_pointer & ~LOWTAG_MASK) +#define get_binding_stack_pointer(thread) \ + (current_binding_stack_pointer) +#define get_pseudo_atomic_atomic(thread) \ + ((unsigned long)dynamic_space_free_pointer & flag_PseudoAtomic) +#define set_pseudo_atomic_atomic(thread) \ + (dynamic_space_free_pointer \ + = (lispobj*) ((unsigned long)dynamic_space_free_pointer | flag_PseudoAtomic)) +#define clear_pseudo_atomic_atomic(thread) \ + (dynamic_space_free_pointer \ + = (lispobj*) ((unsigned long) dynamic_space_free_pointer & ~flag_PseudoAtomic)) +#define get_pseudo_atomic_interrupted(thread) \ + ((unsigned long) dynamic_space_free_pointer & flag_PseudoAtomicInterrupted) +#define clear_pseudo_atomic_interrupted(thread) \ + (dynamic_space_free_pointer \ + = (lispobj*) ((unsigned long) dynamic_space_free_pointer & ~flag_PseudoAtomicInterrupted)) +#define set_pseudo_atomic_interrupted(thread) \ + (dynamic_space_free_pointer \ + = (lispobj*) ((unsigned long) dynamic_space_free_pointer | flag_PseudoAtomicInterrupted)) + +#endif + #endif /* _GC_H_ */ diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 837ada6..596ebba 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -348,15 +348,20 @@ gen_av_mem_age(generation_index_t gen) / ((double)generations[gen].bytes_allocated); } -void fpu_save(int *); /* defined in x86-assem.S */ -void fpu_restore(int *); /* defined in x86-assem.S */ /* The verbose argument controls how much to print: 0 for normal * level of detail; 1 for debugging. */ static void print_generation_stats(int verbose) /* FIXME: should take FILE argument */ { generation_index_t i, gens; - int fpu_state[27]; + +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) +#define FPU_STATE_SIZE 27 + int fpu_state[FPU_STATE_SIZE]; +#elif defined(LISP_FEATURE_PPC) +#define FPU_STATE_SIZE 32 + long long fpu_state[FPU_STATE_SIZE]; +#endif /* This code uses the FP instructions which may be set up for Lisp * so they need to be saved and reset for C. */ @@ -370,7 +375,7 @@ print_generation_stats(int verbose) /* FIXME: should take FILE argument */ /* Print the heap stats. */ fprintf(stderr, - " Gen Boxed Unboxed LB LUB !move Alloc Waste Trig WP GCs Mem-age\n"); + " Gen StaPg UbSta LaSta LUbSt Boxed Unboxed LB LUB !move Alloc Waste Trig WP GCs Mem-age\n"); for (i = 0; i < gens; i++) { page_index_t j; @@ -405,8 +410,12 @@ print_generation_stats(int verbose) /* FIXME: should take FILE argument */ gc_assert(generations[i].bytes_allocated == count_generation_bytes_allocated(i)); fprintf(stderr, - " %1d: %5ld %5ld %5ld %5ld %5ld %8ld %5ld %8ld %4ld %3d %7.4f\n", + " %1d: %5ld %5ld %5ld %5ld %5ld %5ld %5ld %5ld %8ld %5ld %8ld %4ld %3d %7.4f\n", i, + generations[i].alloc_start_page, + generations[i].alloc_unboxed_start_page, + generations[i].alloc_large_start_page, + generations[i].alloc_large_unboxed_start_page, boxed_cnt, unboxed_cnt, large_boxed_cnt, large_unboxed_cnt, pinned_cnt, generations[i].bytes_allocated, @@ -423,7 +432,9 @@ print_generation_stats(int verbose) /* FIXME: should take FILE argument */ } +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) void fast_bzero(void*, size_t); /* in -assem.S */ +#endif /* Zero the pages from START to END (inclusive), but use mmap/munmap instead * if zeroing it ourselves, i.e. in practice give the memory back to the @@ -456,7 +467,12 @@ zero_pages(page_index_t start, page_index_t end) { if (start > end) return; +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) fast_bzero(page_address(start), PAGE_BYTES*(1+end-start)); +#else + bzero(page_address(start), PAGE_BYTES*(1+end-start)); +#endif + } /* Zero the pages from START to END (inclusive), except for those @@ -633,9 +649,8 @@ gc_alloc_new_region(long nbytes, int unboxed, struct alloc_region *alloc_region) /* Bump up last_free_page. */ if (last_page+1 > last_free_page) { last_free_page = last_page+1; - SetSymbolValue(ALLOCATION_POINTER, - (lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES), - 0); + /* do we only want to call this on special occasions? like for boxed_region? */ + set_alloc_pointer((lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES)); } thread_mutex_unlock(&free_pages_lock); @@ -1010,8 +1025,7 @@ gc_alloc_large(long nbytes, int unboxed, struct alloc_region *alloc_region) /* Bump up last_free_page */ if (last_page+1 > last_free_page) { last_free_page = last_page+1; - SetSymbolValue(ALLOCATION_POINTER, - (lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES),0); + set_alloc_pointer((lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES)); } thread_mutex_unlock(&free_pages_lock); @@ -1804,6 +1818,8 @@ trans_unboxed_large(lispobj object) /* FIXME: What does this mean? */ int gencgc_hash = 1; +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) + static long scav_vector(lispobj *where, lispobj object) { @@ -2010,6 +2026,19 @@ scav_vector(lispobj *where, lispobj object) return (CEILING(kv_length + 2, 2)); } +#else + +static long +scav_vector(lispobj *where, lispobj object) +{ + if (HeaderValue(object) == subtype_VectorValidHashing) { + *where = + (subtype_VectorMustRehash<binding_stack_start; verify_space(th->binding_stack_start, binding_stack_size); } @@ -3611,6 +3665,158 @@ write_protect_generation_pages(generation_index_t generation) } } +static void +scavenge_control_stack() +{ + unsigned long control_stack_size; + + /* This is going to be a big problem when we try to port threads + * to PPC... CLH */ + struct thread *th = arch_os_get_current_thread(); + lispobj *control_stack = + (lispobj *)(th->control_stack_start); + + control_stack_size = current_control_stack_pointer - control_stack; + scavenge(control_stack, control_stack_size); +} + +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) +/* Scavenging Interrupt Contexts */ + +static int boxed_registers[] = BOXED_REGISTERS; + +static void +scavenge_interrupt_context(os_context_t * context) +{ + int i; + +#ifdef reg_LIP + unsigned long lip; + unsigned long lip_offset; + int lip_register_pair; +#endif + unsigned long pc_code_offset; + +#ifdef ARCH_HAS_LINK_REGISTER + unsigned long lr_code_offset; +#endif +#ifdef ARCH_HAS_NPC_REGISTER + unsigned long npc_code_offset; +#endif + +#ifdef reg_LIP + /* Find the LIP's register pair and calculate it's offset */ + /* before we scavenge the context. */ + + /* + * I (RLT) think this is trying to find the boxed register that is + * closest to the LIP address, without going past it. Usually, it's + * reg_CODE or reg_LRA. But sometimes, nothing can be found. + */ + lip = *os_context_register_addr(context, reg_LIP); + lip_offset = 0x7FFFFFFF; + lip_register_pair = -1; + for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) { + unsigned long reg; + long offset; + int index; + + index = boxed_registers[i]; + reg = *os_context_register_addr(context, index); + if ((reg & ~((1L<uc_mcontext.gregs[2]. But gregs[2] is REG_nPC. Is + * that what we really want? My guess is that that is not what we + * want, so if lip_register_pair is -1, we don't touch reg_LIP at + * all. But maybe it doesn't really matter if LIP is trashed? + */ + if (lip_register_pair >= 0) { + *os_context_register_addr(context, reg_LIP) = + *os_context_register_addr(context, lip_register_pair) + lip_offset; + } +#endif /* reg_LIP */ + + /* Fix the PC if it was in from space */ + if (from_space_p(*os_context_pc_addr(context))) + *os_context_pc_addr(context) = *os_context_register_addr(context, reg_CODE) + pc_code_offset; + +#ifdef ARCH_HAS_LINK_REGISTER + /* Fix the LR ditto; important if we're being called from + * an assembly routine that expects to return using blr, otherwise + * harmless */ + if (from_space_p(*os_context_lr_addr(context))) + *os_context_lr_addr(context) = + *os_context_register_addr(context, reg_CODE) + lr_code_offset; +#endif + +#ifdef ARCH_HAS_NPC_REGISTER + if (from_space_p(*os_context_npc_addr(context))) + *os_context_npc_addr(context) = *os_context_register_addr(context, reg_CODE) + npc_code_offset; +#endif /* ARCH_HAS_NPC_REGISTER */ +} + +void +scavenge_interrupt_contexts(void) +{ + int i, index; + os_context_t *context; + + struct thread *th=arch_os_get_current_thread(); + + index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,0)); + +#if defined(DEBUG_PRINT_CONTEXT_INDEX) + printf("Number of active contexts: %d\n", index); +#endif + + for (i = 0; i < index; i++) { + context = th->interrupt_contexts[i]; + scavenge_interrupt_context(context); + } +} + +#endif + /* Garbage collect a generation. If raise is 0 then the remains of the * generation are not raised to the next generation. */ static void @@ -3679,6 +3885,7 @@ garbage_collect_generation(generation_index_t generation, int raise) * initiates GC. If you ever call GC from inside an altstack * handler, you will lose. */ +#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) /* And if we're saving a core, there's no point in being conservative. */ if (conservative_stack) { for_each_thread(th) { @@ -3713,6 +3920,8 @@ garbage_collect_generation(generation_index_t generation, int raise) } } } +#endif + #ifdef QSHOW if (gencgc_verbose > 1) { long num_dont_move_pages = count_dont_move_pages(); @@ -3725,6 +3934,15 @@ garbage_collect_generation(generation_index_t generation, int raise) /* Scavenge all the rest of the roots. */ +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) + /* + * If not x86, we need to scavenge the interrupt context(s) and the + * control stack. + */ + scavenge_interrupt_contexts(); + scavenge_control_stack(); +#endif + /* Scavenge the Lisp functions of the interrupt handlers, taking * care to avoid SIG_DFL and SIG_IGN. */ for (i = 0; i < NSIG; i++) { @@ -3738,7 +3956,7 @@ garbage_collect_generation(generation_index_t generation, int raise) { struct thread *th; for_each_thread(th) { - long len= (lispobj *)SymbolValue(BINDING_STACK_POINTER,th) - + long len= (lispobj *)get_binding_stack_pointer(th) - th->binding_stack_start; scavenge((lispobj *) th->binding_stack_start,len); #ifdef LISP_FEATURE_SB_THREAD @@ -3876,8 +4094,7 @@ update_dynamic_space_free_pointer(void) last_free_page = last_page+1; - SetSymbolValue(ALLOCATION_POINTER, - (lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES),0); + set_alloc_pointer((lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES)); return 0; /* dummy value: return something ... */ } @@ -4028,7 +4245,9 @@ collect_garbage(generation_index_t last_gen) /* Save the high-water mark before updating last_free_page */ if (last_free_page > high_water_mark) high_water_mark = last_free_page; + update_dynamic_space_free_pointer(); + auto_gc_trigger = bytes_allocated + bytes_consed_between_gcs; if(gencgc_verbose) fprintf(stderr,"Next gc when %ld bytes have been consed\n", @@ -4130,7 +4349,7 @@ gc_free_heap(void) gc_set_region_empty(&unboxed_region); last_free_page = 0; - SetSymbolValue(ALLOCATION_POINTER, (lispobj)((char *)heap_base),0); + set_alloc_pointer((lispobj)((char *)heap_base)); if (verify_after_free_heap) { /* Check whether purify has left any bad pointers. */ @@ -4199,7 +4418,7 @@ static void gencgc_pickup_dynamic(void) { page_index_t page = 0; - long alloc_ptr = SymbolValue(ALLOCATION_POINTER,0); + long alloc_ptr = get_alloc_pointer(); lispobj *prev=(lispobj *)page_address(page); generation_index_t gen = PSEUDO_STATIC_GENERATION; @@ -4266,16 +4485,18 @@ alloc(long nbytes) void *new_obj; void *new_free_pointer; gc_assert(nbytes>0); + /* Check for alignment allocation problems. */ gc_assert((((unsigned long)region->free_pointer & LOWTAG_MASK) == 0) && ((nbytes & LOWTAG_MASK) == 0)); + #if 0 if(all_threads) /* there are a few places in the C code that allocate data in the * heap before Lisp starts. This is before interrupts are enabled, * so we don't need to check for pseudo-atomic */ #ifdef LISP_FEATURE_SB_THREAD - if(!SymbolValue(PSEUDO_ATOMIC_ATOMIC,th)) { + if(!get_psuedo_atomic_atomic(th)) { register u32 fs; fprintf(stderr, "fatal error in thread 0x%x, tid=%ld\n", th,th->os_thread); @@ -4285,7 +4506,7 @@ alloc(long nbytes) lose("If you see this message before 2004.01.31, mail details to sbcl-devel\n"); } #else - gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC,th)); + gc_assert(get_pseudo_atomic_atomic(th)); #endif #endif @@ -4301,7 +4522,7 @@ alloc(long nbytes) * we should GC in the near future */ if (auto_gc_trigger && bytes_allocated > auto_gc_trigger) { - gc_assert(fixnum_value(SymbolValue(PSEUDO_ATOMIC_ATOMIC,thread))); + gc_assert(get_pseudo_atomic_atomic(thread)); /* Don't flood the system with interrupts if the need to gc is * already noted. This can happen for example when SUB-GC * allocates or after a gc triggered in a WITHOUT-GCING. */ @@ -4310,7 +4531,7 @@ alloc(long nbytes) * section */ SetSymbolValue(GC_PENDING,T,thread); if (SymbolValue(GC_INHIBIT,thread) == NIL) - arch_set_pseudo_atomic_interrupted(0); + set_pseudo_atomic_interrupted(0); } } new_obj = gc_alloc_with_region(nbytes,0,region,0); @@ -4368,7 +4589,8 @@ gencgc_handle_wp_violation(void* fault_addr) * does this test after the first one has already set wp=0 */ if(page_table[page_index].write_protected_cleared != 1) - lose("fault in heap page not marked as write-protected\n"); + lose("fault in heap page %d not marked as write-protected\nboxed_region.first_page: %d, boxed_region.last_page %d\n", + page_index, boxed_region.first_page, boxed_region.last_page); } /* Don't worry, we can handle it. */ return 1; diff --git a/src/runtime/globals.c b/src/runtime/globals.c index 6c9f88a..3d0139a 100644 --- a/src/runtime/globals.c +++ b/src/runtime/globals.c @@ -32,7 +32,7 @@ lispobj *current_binding_stack_pointer; /* ALLOCATION_POINTER is x86 or RT. Anyone want to do an RT port? */ -#ifndef ALLOCATION_POINTER +# if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) /* The Object Formerly Known As current_dynamic_space_free_pointer */ lispobj *dynamic_space_free_pointer; #endif diff --git a/src/runtime/globals.h b/src/runtime/globals.h index 71f3085..4ffd653 100644 --- a/src/runtime/globals.h +++ b/src/runtime/globals.h @@ -34,9 +34,18 @@ extern lispobj *current_control_frame_pointer; extern lispobj *current_binding_stack_pointer; # endif -# ifndef LISP_FEATURE_GENCGC -/* Beware! gencgc has also a (non-global) dynamic_space_free_pointer. */ +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) +/* This is unused on X86 and X86_64, but is used as the global + * allocation pointer by the cheney GC, and, in some instances, as + * the global allocation pointer on PPC/GENCGC. This should probably + * be cleaned up such that it only needs to exist on cheney. At the + * moment, it is also used by the GENCGC, to hold the pseudo_atomic + * bits, and is tightly coupled to reg_ALLOC by the assembly + * routines. */ extern lispobj *dynamic_space_free_pointer; +#endif + +# ifndef LISP_FEATURE_GENCGC extern lispobj *current_auto_gc_trigger; # endif diff --git a/src/runtime/hppa-arch.c b/src/runtime/hppa-arch.c index 5f81f5e..3d1d934 100644 --- a/src/runtime/hppa-arch.c +++ b/src/runtime/hppa-arch.c @@ -85,6 +85,12 @@ void arch_set_pseudo_atomic_interrupted(os_context_t *context) *os_context_register_addr(context,reg_ALLOC) |= 1; } +/* FIXME: untested */ +void arch_clear_pseudo_atomic_interrupted(os_context_t *context) +{ + *os_context_register_addr(context,reg_ALLOC) &= ~1; +} + void arch_skip_instruction(os_context_t *context) { ((char *) *os_context_pc_addr(context)) = ((char *) *os_context_npc_addr(context)); diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index eca23aa..2344a26 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -254,6 +254,7 @@ fake_foreign_function_call(os_context_t *context) dynamic_space_free_pointer = (lispobj *)(unsigned long) (*os_context_register_addr(context, reg_ALLOC)); + /* fprintf(stderr,"dynamic_space_free_pointer: %p\n", dynamic_space_free_pointer); */ #if defined(LISP_FEATURE_ALPHA) if ((long)dynamic_space_free_pointer & 1) { lose("dead in fake_foreign_function_call, context = %x\n", context); @@ -305,7 +306,13 @@ undo_fake_foreign_function_call(os_context_t *context) #ifdef reg_ALLOC /* Put the dynamic space free pointer back into the context. */ *os_context_register_addr(context, reg_ALLOC) = - (unsigned long) dynamic_space_free_pointer; + (unsigned long) dynamic_space_free_pointer + | (*os_context_register_addr(context, reg_ALLOC) + & LOWTAG_MASK); + /* + ((unsigned long)(*os_context_register_addr(context, reg_ALLOC)) & ~LOWTAG_MASK) + | ((unsigned long) dynamic_space_free_pointer & LOWTAG_MASK); + */ #endif } @@ -360,11 +367,13 @@ interrupt_handle_pending(os_context_t *context) thread=arch_os_get_current_thread(); data=thread->interrupt_data; -#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) /* If pseudo_atomic_interrupted is set then the interrupt is going * to be handled now, ergo it's safe to clear it. */ + + /* CLH: 20060220 FIXME This sould probably be arch_clear_p_a_i but + * the behavior of arch_clear_p_a_i and clear_p_a_i are slightly + * different on PPC. */ arch_clear_pseudo_atomic_interrupted(context); -#endif if (SymbolValue(GC_INHIBIT,thread)==NIL) { #ifdef LISP_FEATURE_SB_THREAD diff --git a/src/runtime/mips-arch.c b/src/runtime/mips-arch.c index 8722021..0cb689c 100644 --- a/src/runtime/mips-arch.c +++ b/src/runtime/mips-arch.c @@ -274,6 +274,12 @@ arch_set_pseudo_atomic_interrupted(os_context_t *context) *os_context_register_addr(context, reg_NL4) |= -1LL<<31; } +void +arch_clear_pseudo_atomic_interrupted(os_context_t *context) +{ + *os_context_register_addr(context, reg_NL4) &= ~(-1LL<<31); +} + unsigned int arch_install_breakpoint(void *pc) { @@ -397,8 +403,7 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) break; case 0x10: - /* Clear the pseudo-atomic flag. */ - *os_context_register_addr(context, reg_NL4) &= ~(-1LL<<31); + arch_clear_pseudo_atomic_interrupted(context) arch_skip_instruction(context); interrupt_handle_pending(context); return; diff --git a/src/runtime/parse.c b/src/runtime/parse.c index a74b11f..954bb0b 100644 --- a/src/runtime/parse.c +++ b/src/runtime/parse.c @@ -259,13 +259,14 @@ static boolean lookup_symbol(char *name, lispobj *result) } /* Search dynamic space. */ -#ifndef LISP_FEATURE_GENCGC +#if defined(LISP_FEATURE_GENCGC) + headerptr = (lispobj *)DYNAMIC_SPACE_START; + count = (lispobj *)get_alloc_pointer() - headerptr; +#else headerptr = (lispobj *)current_dynamic_space; count = dynamic_space_free_pointer - headerptr; -#else - headerptr = (lispobj *)DYNAMIC_SPACE_START; - count = ((lispobj *)SymbolValue(ALLOCATION_POINTER,0)) - headerptr; #endif + if (search_for_symbol(name, &headerptr, &count)) { *result = make_lispobj(headerptr, OTHER_POINTER_LOWTAG); return 1; diff --git a/src/runtime/ppc-arch.c b/src/runtime/ppc-arch.c index 56fefd0..6554971 100644 --- a/src/runtime/ppc-arch.c +++ b/src/runtime/ppc-arch.c @@ -10,6 +10,10 @@ #include "interrupt.h" #include "interr.h" +#if defined(LISP_FEATURE_GENCGC) +#include "gencgc-alloc-region.h" +#endif + /* The header files may not define PT_DAR/PT_DSISR. This definition is correct for all versions of ppc linux >= 2.0.30 @@ -37,20 +41,9 @@ void arch_init() { os_vm_address_t arch_get_bad_addr(int sig, siginfo_t *code, os_context_t *context) { - unsigned int *pc = (unsigned int *)(*os_context_pc_addr(context)); + unsigned long pc = (unsigned long)(*os_context_pc_addr(context)); os_vm_address_t addr; - - /* Make sure it's not the pc thats bogus, and that it was lisp code */ - /* that caused the fault. */ - if ((((unsigned long)pc) & 3) != 0 || - ((pc < READ_ONLY_SPACE_START || - pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) && - ((lispobj *)pc < current_dynamic_space || - (lispobj *)pc >= current_dynamic_space + DYNAMIC_SPACE_SIZE))) - return 0; - - addr = (os_vm_address_t) (*os_context_register_addr(context,PT_DAR)); return addr; } @@ -77,13 +70,16 @@ arch_pseudo_atomic_atomic(os_context_t *context) return ((*os_context_register_addr(context,reg_ALLOC)) & 4); } -#define PSEUDO_ATOMIC_INTERRUPTED_BIAS 0x7f000000 - void arch_set_pseudo_atomic_interrupted(os_context_t *context) { - *os_context_register_addr(context,reg_NL3) - += PSEUDO_ATOMIC_INTERRUPTED_BIAS; + *os_context_register_addr(context,reg_ALLOC) |= 1; +} + +void +arch_clear_pseudo_atomic_interrupted(os_context_t *context) +{ + *os_context_register_addr(context,reg_ALLOC) &= ~1; } unsigned int @@ -138,25 +134,263 @@ arch_do_displaced_inst(os_context_t *context,unsigned int orig_inst) skipped_break_addr = pc; } +#ifdef LISP_FEATURE_GENCGC +/* + * Return non-zero if the current instruction is an allocation trap + */ +static int +allocation_trap_p(os_context_t * context) +{ + int result; + unsigned int *pc; + unsigned inst; + unsigned opcode; + unsigned src; + unsigned dst; + + result = 0; + + /* + * First, the instruction has to be a TWLGE temp, NL3, which has the + * format. + * | 6| 5| 5 | 5 | 10|1| width + * |31|5 |dst|src| 4|0| field + */ + pc = (unsigned int *) (*os_context_pc_addr(context)); + inst = *pc; + +#if 0 + fprintf(stderr, "allocation_trap_p at %p: inst = 0x%08x\n", pc, inst); +#endif + + opcode = inst >> 26; + src = (inst >> 11) & 0x1f; + dst = (inst >> 16) & 0x1f; + if ((opcode == 31) && (src == reg_NL3) && (5 == ((inst >> 21) & 0x1f)) + && (4 == ((inst >> 1) & 0x3ff))) { + /* + * We got the instruction. Now, look back to make sure it was + * proceeded by what we expected. 2 instructions back should be + * an ADD or ADDI instruction. + */ + unsigned int add_inst; + + add_inst = pc[-3]; +#if 0 + fprintf(stderr, " add inst at %p: inst = 0x%08x\n", + pc - 3, add_inst); +#endif + opcode = add_inst >> 26; + if ((opcode == 31) && (266 == ((add_inst >> 1) & 0x1ff))) { + return 1; + } else if ((opcode == 14)) { + return 1; + } else { + fprintf(stderr, + "Whoa! Got allocation trap but could not find ADD or ADDI instruction: 0x%08x in the proper place\n", + add_inst); + } + } + return 0; +} + +extern struct alloc_region boxed_region; + +void +handle_allocation_trap(os_context_t * context) +{ + unsigned int *pc; + unsigned int inst; + unsigned int or_inst; + unsigned int target, target_ptr, end_addr; + unsigned int opcode; + int size; + int immed; + boolean were_in_lisp; + char *memory; + sigset_t block; + + target = 0; + size = 0; + +#if 0 + fprintf(stderr, "In handle_allocation_trap\n"); +#endif + + /* + * I don't think it's possible for us NOT to be in lisp when we get + * here. Remove this later? + */ + were_in_lisp = !foreign_function_call_active; + + if (were_in_lisp) { + fake_foreign_function_call(context); + } else { + fprintf(stderr, "**** Whoa! allocation trap and we weren't in lisp!\n"); + } + + /* + * Look at current instruction: TWNE temp, NL3. We're here because + * temp > NL3 and temp is the end of the allocation, and NL3 is + * current-region-end-addr. + * + * We need to adjust temp and alloc-tn. + */ + + pc = (unsigned int *) (*os_context_pc_addr(context)); + inst = pc[0]; + end_addr = (inst >> 11) & 0x1f; + target = (inst >> 16) & 0x1f; + + target_ptr = *os_context_register_addr(context, target); + +#if 0 + fprintf(stderr, "handle_allocation_trap at %p:\n", pc); + fprintf(stderr, "boxed_region.free_pointer: %p\n", boxed_region.free_pointer); + fprintf(stderr, "boxed_region.end_addr: %p\n", boxed_region.end_addr); + fprintf(stderr, "target reg: %d, end_addr reg: %d\n", target, end_addr); + fprintf(stderr, "target: %x\n", *os_context_register_addr(context, target)); + fprintf(stderr, "end_addr: %x\n", *os_context_register_addr(context, end_addr)); +#endif + +#if 0 + fprintf(stderr, "handle_allocation_trap at %p:\n", pc); + fprintf(stderr, " trap inst = 0x%08x\n", inst); + fprintf(stderr, " target reg = %s\n", lisp_register_names[target]); +#endif + + /* + * Go back and look at the add/addi instruction. The second src arg + * is the size of the allocation. Get it and call alloc to allocate + * new space. + */ + inst = pc[-3]; + opcode = inst >> 26; +#if 0 + fprintf(stderr, " add inst = 0x%08x, opcode = %d\n", inst, opcode); +#endif + if (opcode == 14) { + /* + * ADDI temp-tn, alloc-tn, size + * + * Extract the size + */ + size = (inst & 0xffff); + } else if (opcode == 31) { + /* + * ADD temp-tn, alloc-tn, size-tn + * + * Extract the size + */ + int reg; + + reg = (inst >> 11) & 0x1f; +#if 0 + fprintf(stderr, " add, reg = %s\n", lisp_register_names[reg]); +#endif + size = *os_context_register_addr(context, reg); + + } + +#if 0 + fprintf(stderr, "Alloc %d to %s\n", size, lisp_register_names[target]); +#endif + +#if INLINE_ALLOC_DEBUG + if ((((unsigned long)boxed_region.end_addr + size) / PAGE_SIZE) == + (((unsigned long)boxed_region.end_addr) / PAGE_SIZE)) { + fprintf(stderr,"*** possibly bogus trap allocation of %d bytes at %p\n", + size, target_ptr); + fprintf(stderr, " dynamic_space_free_pointer: %p, boxed_region.end_addr %p\n", + dynamic_space_free_pointer, boxed_region.end_addr); + } +#endif + +#if 0 + fprintf(stderr, "Ready to alloc\n"); + fprintf(stderr, "free_pointer = 0x%08x\n", + dynamic_space_free_pointer); +#endif + + /* + * alloc-tn was incremented by size. Need to decrement it by size + * to restore its original value. This is not true on GENCGC + * anymore. d_s_f_p and reg_alloc get out of sync, but the p_a + * bits stay intact and we set it to the proper value when it + * needs to be. Keep this comment here for the moment in case + * somebody tries to figure out what happened here. + */ + /* dynamic_space_free_pointer = + (lispobj *) ((long) dynamic_space_free_pointer - size); + */ +#if 0 + fprintf(stderr, "free_pointer = 0x%08x new\n", + dynamic_space_free_pointer); +#endif + + memory = (char *) alloc(size); + +#if 0 + fprintf(stderr, "alloc returned %p\n", memory); + fprintf(stderr, "free_pointer = 0x%08x\n", + dynamic_space_free_pointer); +#endif + + /* + * The allocation macro wants the result to point to the end of the + * object! + */ + memory += size; + +#if 0 + fprintf(stderr, "object end at %p\n", memory); +#endif + + *os_context_register_addr(context, target) = (unsigned long) memory; + *os_context_register_addr(context, reg_ALLOC) = + (unsigned long) dynamic_space_free_pointer + | (*os_context_register_addr(context, reg_ALLOC) + & LOWTAG_MASK); + + if (were_in_lisp) { + undo_fake_foreign_function_call(context); + } + + +} +#endif + + static void sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context) { unsigned int code; + #ifdef LISP_FEATURE_LINUX os_restore_fp_control(context); #endif code=*((u32 *)(*os_context_pc_addr(context))); - if (code == ((3 << 26) | (16 << 21) | (reg_ALLOC << 16))) { - /* twlti reg_ALLOC,0 - check for deferred interrupt */ - *os_context_register_addr(context,reg_ALLOC) - -= PSEUDO_ATOMIC_INTERRUPTED_BIAS; + if (code == ((3 << 26) | (0x18 << 21) | (reg_NL3 << 16))) { + arch_clear_pseudo_atomic_interrupted(context); arch_skip_instruction(context); /* interrupt or GC was requested in PA; now we're done with the PA section we may as well get around to it */ interrupt_handle_pending(context); return; + } +#ifdef LISP_FEATURE_GENCGC + /* Is this an allocation trap? */ + if (allocation_trap_p(context)) { + handle_allocation_trap(context); + arch_skip_instruction(context); +#ifdef LISP_FEATURE_DARWIN + DARWIN_FIX_CONTEXT(context); +#endif + return; } +#endif + if ((code >> 16) == ((3 << 10) | (6 << 5))) { /* twllei reg_ZERO,N will always trap if reg_ZERO = 0 */ int trap = code & 0x1f; diff --git a/src/runtime/ppc-assem.S b/src/runtime/ppc-assem.S index b4c79af..c760abb 100644 --- a/src/runtime/ppc-assem.S +++ b/src/runtime/ppc-assem.S @@ -311,7 +311,6 @@ x: #endif /* Turn on pseudo-atomic */ - li reg_NL3,-4 li reg_ALLOC,4 store(reg_ZERO,reg_NL4,CSYMBOL(foreign_function_call_active)) load(reg_NL4,CSYMBOL(dynamic_space_free_pointer)) @@ -321,8 +320,9 @@ x: load(reg_OCFP,CSYMBOL(current_control_frame_pointer)) /* No longer atomic, and check for interrupt */ - add reg_ALLOC,reg_ALLOC,reg_NL3 - twlti reg_ALLOC,0 + andi. reg_NL3, reg_ALLOC, 1 + subi reg_ALLOC,reg_ALLOC,4 + twnei reg_NL3, 0 /* Pass in the arguments */ @@ -363,7 +363,6 @@ lra: mr REG(3),reg_A0 /* Turn on pseudo-atomic */ - li reg_NL3,-4 la reg_ALLOC,4(reg_ALLOC) /* Store lisp state */ @@ -380,9 +379,10 @@ lra: store(reg_NL1,reg_NL2,CSYMBOL(foreign_function_call_active)) /* Check for interrupt */ - add reg_ALLOC,reg_ALLOC,reg_NL3 - twlti reg_ALLOC,0 - + andi. reg_NL3, reg_ALLOC, 1 + subi reg_ALLOC, reg_ALLOC, 4 + twnei reg_NL3,0 + /* Back to C */ C_FULL_EPILOG blr @@ -411,7 +411,6 @@ lra: mr reg_NARGS,reg_NL3 /* Turn on pseudo-atomic */ - li reg_NL3,-4 la reg_ALLOC,4(reg_ALLOC) /* Convert the return address to an offset and save it on the stack. */ @@ -432,8 +431,10 @@ lra: store(reg_CSP,reg_CFUNC,CSYMBOL(foreign_function_call_active)) /* load(reg_POLL,saver2) */ /* Disable pseudo-atomic; check pending interrupt */ - add reg_ALLOC,reg_ALLOC,reg_NL3 - twlti reg_ALLOC,0 + andi. reg_NL3, reg_ALLOC, 1 + subi reg_ALLOC, reg_ALLOC, 4 + twnei reg_NL3, 0 + mr reg_NL3,reg_NARGS #ifdef LISP_FEATURE_DARWIN @@ -474,7 +475,7 @@ lra: li reg_LIP,0 /* Atomic ... */ - li reg_NL3,-4 + li reg_NL3,-4 li reg_ALLOC,4 /* No long in foreign function call. */ @@ -497,8 +498,10 @@ lra: la reg_LIP,-OTHER_POINTER_LOWTAG(reg_LIP) /* No longer atomic */ - add reg_ALLOC,reg_ALLOC,reg_NL3 - twlti reg_ALLOC,0 + andi. reg_NL3, reg_ALLOC, 1 + subi reg_ALLOC, reg_ALLOC, 4 + twnei reg_NL3, 0 + mtlr reg_LIP /* Reset the lisp stack. */ @@ -579,3 +582,82 @@ CSYMBOL(closure_tramp): blr SET_SIZE(ppc_flush_cache_line) + GFUNCDEF(do_pending_interrupt) + twllei reg_ZERO, trap_PendingInterrupt + blr +/* King Nato's branch has a nop here. Do we need this? */ + SET_SIZE(do_pending_interrupt) + +#if defined LISP_FEATURE_GENCGC + + GFUNCDEF(fpu_save) + stfd FREG(1), 0(REG(3)) + stfd FREG(2), 8(REG(3)) + stfd FREG(3), 16(REG(3)) + stfd FREG(4), 24(REG(3)) + stfd FREG(5), 32(REG(3)) + stfd FREG(6), 40(REG(3)) + stfd FREG(7), 48(REG(3)) + stfd FREG(8), 56(REG(3)) + stfd FREG(9), 64(REG(3)) + stfd FREG(10), 72(REG(3)) + stfd FREG(11), 80(REG(3)) + stfd FREG(12), 88(REG(3)) + stfd FREG(13), 96(REG(3)) + stfd FREG(14), 104(REG(3)) + stfd FREG(15), 112(REG(3)) + stfd FREG(16), 120(REG(3)) + stfd FREG(17), 128(REG(3)) + stfd FREG(18), 136(REG(3)) + stfd FREG(19), 144(REG(3)) + stfd FREG(20), 152(REG(3)) + stfd FREG(21), 160(REG(3)) + stfd FREG(22), 168(REG(3)) + stfd FREG(23), 176(REG(3)) + stfd FREG(24), 184(REG(3)) + stfd FREG(25), 192(REG(3)) + stfd FREG(26), 200(REG(3)) + stfd FREG(27), 208(REG(3)) + stfd FREG(28), 216(REG(3)) + stfd FREG(29), 224(REG(3)) + stfd FREG(30), 232(REG(3)) + stfd FREG(31), 240(REG(3)) + blr + SET_SIZE(fpu_save) + + GFUNCDEF(fpu_restore) + lfd FREG(1), 0(REG(3)) + lfd FREG(2), 8(REG(3)) + lfd FREG(3), 16(REG(3)) + lfd FREG(4), 24(REG(3)) + lfd FREG(5), 32(REG(3)) + lfd FREG(6), 40(REG(3)) + lfd FREG(7), 48(REG(3)) + lfd FREG(8), 56(REG(3)) + lfd FREG(9), 64(REG(3)) + lfd FREG(10), 72(REG(3)) + lfd FREG(11), 80(REG(3)) + lfd FREG(12), 88(REG(3)) + lfd FREG(13), 96(REG(3)) + lfd FREG(14), 104(REG(3)) + lfd FREG(15), 112(REG(3)) + lfd FREG(16), 120(REG(3)) + lfd FREG(17), 128(REG(3)) + lfd FREG(18), 136(REG(3)) + lfd FREG(19), 144(REG(3)) + lfd FREG(20), 152(REG(3)) + lfd FREG(21), 160(REG(3)) + lfd FREG(22), 168(REG(3)) + lfd FREG(23), 176(REG(3)) + lfd FREG(24), 184(REG(3)) + lfd FREG(25), 192(REG(3)) + lfd FREG(26), 200(REG(3)) + lfd FREG(27), 208(REG(3)) + lfd FREG(28), 216(REG(3)) + lfd FREG(29), 224(REG(3)) + lfd FREG(30), 232(REG(3)) + lfd FREG(31), 240(REG(3)) + blr + SET_SIZE(fpu_restore) + +#endif diff --git a/src/runtime/ppc-darwin-spacelist.h b/src/runtime/ppc-darwin-spacelist.h index e8b2f39..c1a3026 100644 --- a/src/runtime/ppc-darwin-spacelist.h +++ b/src/runtime/ppc-darwin-spacelist.h @@ -1,16 +1,30 @@ #ifndef PPC_DARWIN_SPACELIST_H #define PPC_DARWIN_SPACELIST_H +#if defined(LISP_FEATURE_GENCGC) +#define N_SEGMENTS_TO_PRODUCE 4 +#else #define N_SEGMENTS_TO_PRODUCE 5 +#endif unsigned int space_start_locations[N_SEGMENTS_TO_PRODUCE] = - { READ_ONLY_SPACE_START, STATIC_SPACE_START, DYNAMIC_0_SPACE_START, DYNAMIC_1_SPACE_START, LINKAGE_TABLE_SPACE_START}; + { READ_ONLY_SPACE_START, STATIC_SPACE_START, +#if defined(LISP_FEATURE_GENCGC) + DYNAMIC_SPACE_START, +#else + DYNAMIC_0_SPACE_START, DYNAMIC_1_SPACE_START, +#endif + LINKAGE_TABLE_SPACE_START}; unsigned int space_sizes[N_SEGMENTS_TO_PRODUCE] = { READ_ONLY_SPACE_END - READ_ONLY_SPACE_START, STATIC_SPACE_END - STATIC_SPACE_START, +#if defined(LISP_FEATURE_GENCGC) + DYNAMIC_SPACE_END - DYNAMIC_SPACE_START, +#else DYNAMIC_0_SPACE_END - DYNAMIC_0_SPACE_START, DYNAMIC_1_SPACE_END - DYNAMIC_1_SPACE_START, +#endif LINKAGE_TABLE_SPACE_END - LINKAGE_TABLE_SPACE_START}; #endif diff --git a/src/runtime/ppc-lispregs.h b/src/runtime/ppc-lispregs.h index ee81a57..9681253 100644 --- a/src/runtime/ppc-lispregs.h +++ b/src/runtime/ppc-lispregs.h @@ -1,11 +1,14 @@ #if defined LISP_FEATURE_DARWIN #if defined LANGUAGE_ASSEMBLY #define REG(num) r##num +#define FREG(num) f##num #else #define REG(num) num +#define FREG(num) num #endif #else #define REG(num) num +#define FREG(num) num #endif #define NREGS 32 diff --git a/src/runtime/purify.c b/src/runtime/purify.c index ba07c21..bedbfd7 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -37,18 +37,10 @@ #define PRINTNOISE -#if defined(LISP_FEATURE_GENCGC) -/* this is another artifact of the poor integration between gencgc and - * the rest of the runtime: on cheney gc there is a global - * dynamic_space_free_pointer which is valid whenever foreign function - * call is active, but in gencgc there's no such variable and we have - * to keep our own - */ -static lispobj *dynamic_space_free_pointer; -#endif - extern unsigned long bytes_consed_between_gcs; +static lispobj *dynamic_space_purify_pointer; + /* These hold the original end of the read_only and static spaces so * we can tell what are forwarding pointers. */ @@ -102,12 +94,12 @@ dynamic_pointer_p(lispobj ptr) #ifndef LISP_FEATURE_GENCGC return (ptr >= (lispobj)current_dynamic_space && - ptr < (lispobj)dynamic_space_free_pointer); + ptr < (lispobj)dynamic_space_purify_pointer); #else /* Be more conservative, and remember, this is a maybe. */ return (ptr >= (lispobj)DYNAMIC_SPACE_START && - ptr < (lispobj)dynamic_space_free_pointer); + ptr < (lispobj)dynamic_space_purify_pointer); #endif } @@ -1453,8 +1445,14 @@ purify(lispobj static_roots, lispobj read_only_roots) } #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64) - dynamic_space_free_pointer = + dynamic_space_purify_pointer = (lispobj*)SymbolValue(ALLOCATION_POINTER,0); +#else +#if defined(LISP_FEATURE_GENCGC) + dynamic_space_purify_pointer = get_alloc_pointer(); +#else + dynamic_space_purify_pointer = dynamic_space_free_pointer; +#endif #endif read_only_end = read_only_free = @@ -1597,15 +1595,11 @@ purify(lispobj static_roots, lispobj read_only_roots) SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0); SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0); -#if !defined(ALLOCATION_POINTER) - dynamic_space_free_pointer = current_dynamic_space; - set_auto_gc_trigger(bytes_consed_between_gcs); -#else #if defined LISP_FEATURE_GENCGC gc_free_heap(); #else -#error unsupported case /* in CMU CL, was "ibmrt using GC" */ -#endif + dynamic_space_free_pointer = current_dynamic_space; + set_auto_gc_trigger(bytes_consed_between_gcs); #endif /* Blast away instruction cache */ diff --git a/src/runtime/save.c b/src/runtime/save.c index 9273ce1..f6742c3 100644 --- a/src/runtime/save.c +++ b/src/runtime/save.c @@ -166,18 +166,26 @@ save_to_filehandle(FILE *file, char *filename, lispobj init_function, (lispobj *)STATIC_SPACE_START, (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0), core_start_pos); +#ifdef LISP_FEATURE_GENCGC + /* Flush the current_region, updating the tables. */ + gc_alloc_update_all_page_tables(); + update_dynamic_space_free_pointer(); +#endif #ifdef reg_ALLOC +#ifdef LISP_FEATURE_GENCGC output_space(file, DYNAMIC_CORE_SPACE_ID, - (lispobj *)current_dynamic_space, + (lispobj *)DYNAMIC_SPACE_START, dynamic_space_free_pointer, core_start_pos); #else -#ifdef LISP_FEATURE_GENCGC - /* Flush the current_region, updating the tables. */ - gc_alloc_update_all_page_tables(); - update_dynamic_space_free_pointer(); + output_space(file, + DYNAMIC_CORE_SPACE_ID, + (lispobj *)current_dynamic_space, + dynamic_space_free_pointer, + core_start_pos); #endif +#else output_space(file, DYNAMIC_CORE_SPACE_ID, (lispobj *)DYNAMIC_SPACE_START, diff --git a/src/runtime/sparc-arch.c b/src/runtime/sparc-arch.c index f941eae..22d2403 100644 --- a/src/runtime/sparc-arch.c +++ b/src/runtime/sparc-arch.c @@ -105,6 +105,11 @@ void arch_set_pseudo_atomic_interrupted(os_context_t *context) *os_context_register_addr(context,reg_ALLOC) |= 1; } +void arch_clear_pseudo_atomic_interrupted(os_context_t *context) +{ + *os_context_register_addr(context,reg_ALLOC) &= ~1; +} + unsigned int arch_install_breakpoint(void *pc) { unsigned int *ptr = (unsigned int *)pc; @@ -266,7 +271,7 @@ static void sigill_handler(int signal, siginfo_t *siginfo, void *void_context) to fixup up alloc-tn to remove the interrupted flag, skip over the trap instruction, and then handle the pending interrupt(s). */ - *os_context_register_addr(context, reg_ALLOC) &= ~7; + arch_clear_pseudo_atomic_interrupted(context); arch_skip_instruction(context); interrupt_handle_pending(context); } @@ -314,6 +319,8 @@ static void sigemt_handler(int signal, siginfo_t *siginfo, void *void_context) result = op1 - op2; else result = op1 + op2; + /* KLUDGE: this & ~7 is a little bit magical but basically + clears pseudo_atomic bits if any */ *os_context_register_addr(context, reg_ALLOC) = result & ~7; arch_skip_instruction(context); interrupt_handle_pending(context); diff --git a/version.lisp-expr b/version.lisp-expr index 80d476f..047b3ac 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.9.35" +"0.9.9.36" -- 1.7.10.4