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.
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
--- /dev/null
+
+====================================================
+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
+====================================================
+
# 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.
"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*"
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)
(: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))
-
(sc-offsets (sb!c:read-var-integer vector index)))
(values error-number (sc-offsets))))))
-
-
(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
(: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))
(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
(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)
;; 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)
(: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.
;;;
(: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))
(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))))
(: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)
(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
(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)
(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.
;; 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.
(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)
\f
;;;; 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)
;;; 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))))
(: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)
(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)
#!+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)
#!+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)
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
# 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
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
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 */
*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;
lispobj arg2);
extern lispobj *component_ptr_from_pc(lispobj *pc);
+extern void fpu_save(void *);
+extern void fpu_restore(void *);
+
#endif /* __ARCH_H__ */
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)
{
lispobj *new_space_free_pointer;
static void scavenge_newspace(void);
-static void scavenge_interrupt_contexts(void);
extern unsigned long bytes_consed_between_gcs;
(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 */
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;
}
/* 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)
{
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
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;
* 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
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);
#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_ */
/ ((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. */
/* 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;
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,
}
\f
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
void fast_bzero(void*, size_t); /* in <arch>-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
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
/* 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);
/* 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);
/* 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)
{
return (CEILING(kv_length + 2, 2));
}
+#else
+
+static long
+scav_vector(lispobj *where, lispobj object)
+{
+ if (HeaderValue(object) == subtype_VectorValidHashing) {
+ *where =
+ (subtype_VectorMustRehash<<N_WIDETAG_BITS) | SIMPLE_VECTOR_WIDETAG;
+ }
+ return 1;
+}
+
+#endif
\f
/*
return 1;
}
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
+
/* Adjust large bignum and vector objects. This will adjust the
* allocated region if the size has shrunk, and move unboxed objects
* into unboxed pages. The pages are not promoted here, and the
return;
}
+#endif
+
/* Take a possible pointer to a Lisp object and mark its page in the
* page_table so that it will not be relocated during a GC.
*
*
* It is also assumed that the current gc_alloc() region has been
* flushed and the tables updated. */
+
+#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
+
static void
preserve_pointer(void *addr)
{
/* Check that the page is now static. */
gc_assert(page_table[addr_page_index].dont_move != 0);
}
+
+#endif
+
\f
/* If the given page is not write-protected, then scan it for pointers
* to younger generations or the top temp. generation, if no
}
#endif
-extern long undefined_tramp;
+#if defined(LISP_FEATURE_PPC)
+extern int closure_tramp;
+extern int undefined_tramp;
+#else
+extern int undefined_tramp;
+#endif
static void
verify_space(lispobj *start, size_t words)
*/
} else {
/* Verify that it points to another valid space. */
- if (!to_readonly_space && !to_static_space
- && (thing != (unsigned long)&undefined_tramp)) {
+ if (!to_readonly_space && !to_static_space &&
+#if defined(LISP_FEATURE_PPC)
+ !((thing == &closure_tramp) ||
+ (thing == &undefined_tramp))
+#else
+ thing != (unsigned long)&undefined_tramp
+#endif
+ ) {
lose("Ptr %x @ %x sees junk.\n", thing, start);
}
}
break;
default:
+ FSHOW((stderr,
+ "/Unhandled widetag 0x%x at 0x%x\n",
+ widetag_of(*start), start));
+ fflush(stderr);
gc_abort();
}
}
struct thread *th;
for_each_thread(th) {
long binding_stack_size =
- (lispobj*)SymbolValue(BINDING_STACK_POINTER,th)
+ (lispobj*)get_binding_stack_pointer(th)
- (lispobj*)th->binding_stack_start;
verify_space(th->binding_stack_start, binding_stack_size);
}
}
}
+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<<N_LOWTAG_BITS)-1)) <= lip) {
+ offset = lip - reg;
+ if (offset < lip_offset) {
+ lip_offset = offset;
+ lip_register_pair = index;
+ }
+ }
+ }
+#endif /* reg_LIP */
+
+ /* Compute the PC's offset from the start of the CODE */
+ /* register. */
+ pc_code_offset = *os_context_pc_addr(context) - *os_context_register_addr(context, reg_CODE);
+#ifdef ARCH_HAS_NPC_REGISTER
+ npc_code_offset = *os_context_npc_addr(context) - *os_context_register_addr(context, reg_CODE);
+#endif /* ARCH_HAS_NPC_REGISTER */
+
+#ifdef ARCH_HAS_LINK_REGISTER
+ lr_code_offset =
+ *os_context_lr_addr(context) -
+ *os_context_register_addr(context, reg_CODE);
+#endif
+
+ /* Scanvenge all boxed registers in the context. */
+ for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
+ int index;
+ lispobj foo;
+
+ index = boxed_registers[i];
+ foo = *os_context_register_addr(context, index);
+ scavenge(&foo, 1);
+ *os_context_register_addr(context, index) = foo;
+
+ scavenge((lispobj*) &(*os_context_register_addr(context, index)), 1);
+ }
+
+#ifdef reg_LIP
+ /* Fix the LIP */
+
+ /*
+ * But what happens if lip_register_pair is -1? *os_context_register_addr on Solaris
+ * (see solaris_register_address in solaris-os.c) will return
+ * &context->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
* 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) {
}
}
}
+#endif
+
#ifdef QSHOW
if (gencgc_verbose > 1) {
long num_dont_move_pages = count_dont_move_pages();
/* 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++) {
{
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
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 ... */
}
/* 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",
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. */
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;
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);
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
* 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. */
* 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);
* 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;
/* 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
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
*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));
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);
#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
}
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
*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)
{
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;
}
/* 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;
#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
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;
}
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
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;
#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))
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 */
mr REG(3),reg_A0
/* Turn on pseudo-atomic */
- li reg_NL3,-4
la reg_ALLOC,4(reg_ALLOC)
/* Store lisp state */
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
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. */
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
li reg_LIP,0
/* Atomic ... */
- li reg_NL3,-4
+ li reg_NL3,-4
li reg_ALLOC,4
/* No long in foreign function call. */
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. */
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
#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
#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
#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;
+
\f
/* These hold the original end of the read_only and static spaces so
* we can tell what are forwarding pointers. */
#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
}
}
#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 =
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 */
(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,
*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;
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);
}
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);
;;; 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"
projects / sbcl.git / commitdiff