? src/assembly/assemfile.trace ? src/assembly/x86/alloc.trace ? src/assembly/x86/arith.trace ? src/assembly/x86/array.trace ? src/assembly/x86/assem-rtns.trace ? src/assembly/x86/support.trace ? src/code/alien-type.trace ? src/code/alloc.trace ? src/code/ansi-stream.trace ? src/code/array.trace ? src/code/backq.trace ? src/code/bignum.trace ? src/code/bit-bash.trace ? src/code/char.trace ? src/code/cl-specials.trace ? src/code/class-init.trace ? src/code/class.trace ? src/code/coerce.trace ? src/code/cold-error.trace ? src/code/cold-init-helper-macros.trace ? src/code/cold-init.trace ? src/code/common-os.trace ? src/code/condition.trace ? src/code/debug-info.trace ? src/code/debug-int.trace ? src/code/debug-var-io.trace ? src/code/debug.trace ? src/code/defbangconstant.trace ? src/code/defbangmacro.trace ? src/code/defbangstruct.trace ? src/code/defbangtype.trace ? src/code/defboot.trace ? src/code/defmacro.trace ? src/code/defpackage.trace ? src/code/defsetfs.trace ? src/code/defstruct.trace ? src/code/deftypes-for-target.trace ? src/code/destructuring-bind.trace ? src/code/early-alieneval.trace ? src/code/early-array.trace ? src/code/early-cl.trace ? src/code/early-defbangmethod.trace ? src/code/early-defstructs.trace ? src/code/early-extensions.trace ? src/code/early-fasl.trace ? src/code/early-float.trace ? src/code/early-format.trace ? src/code/early-full-eval.trace ? src/code/early-impl.trace ? src/code/early-package.trace ? src/code/early-pcounter.trace ? src/code/early-pprint.trace ? src/code/early-print.trace ? src/code/early-setf.trace ? src/code/early-source-location.trace ? src/code/early-step.trace ? src/code/early-thread.trace ? src/code/early-time.trace ? src/code/early-type.trace ? src/code/error-error.trace ? src/code/error.trace ? src/code/eval.trace ? src/code/exhaust.trace ? src/code/fd-stream.trace ? src/code/fdefinition.trace ? src/code/filesys.trace ? src/code/final.trace ? src/code/float-trap.trace ? src/code/float.trace ? src/code/fop.trace ? src/code/force-delayed-defbangconstants.trace ? src/code/force-delayed-defbangmacros.trace ? src/code/force-delayed-defbangstructs.trace ? src/code/foreign-load.trace ? src/code/foreign.trace ? src/code/format-time.trace ? src/code/full-eval.trace ? src/code/function-names.trace ? src/code/funutils.trace ? src/code/gc.trace ? src/code/globals.trace ? src/code/hash-table.trace ? src/code/host-alieneval.trace ? src/code/host-c-call.trace ? src/code/host-pprint.trace ? src/code/huffman.trace ? src/code/interr.trace ? src/code/irrat.trace ? src/code/kernel.trace ? src/code/late-defbangmethod.trace ? src/code/late-deftypes-for-target.trace ? src/code/late-extensions.trace ? src/code/late-format.trace ? src/code/late-setf.trace ? src/code/late-type.trace ? src/code/linkage-table.trace ? src/code/linux-os.trace ? src/code/list.trace ? src/code/load.trace ? src/code/loop.trace ? src/code/macroexpand.trace ? src/code/macros.trace ? src/code/mipsstrops.trace ? src/code/misc-aliens.trace ? src/code/misc.trace ? src/code/module.trace ? src/code/numbers.trace ? src/code/octets.trace ? src/code/package.trace ? src/code/parse-body.trace ? src/code/parse-defmacro-errors.trace ? src/code/parse-defmacro.trace ? src/code/pathname.trace ? src/code/pcounter.trace ? src/code/pp-backq.trace ? src/code/pprint.trace ? src/code/pred.trace ? src/code/primordial-extensions.trace ? src/code/primordial-type.trace ? src/code/print.trace ? src/code/purify.trace ? src/code/query.trace ? src/code/random.trace ? src/code/reader.trace ? src/code/readtable.trace ? src/code/room.trace ? src/code/save.trace ? src/code/sc-offset.trace ? src/code/seq.trace ? src/code/serve-event.trace ? src/code/setf-funs.trace ? src/code/sharpm.trace ? src/code/show.trace ? src/code/signal.trace ? src/code/sort.trace ? src/code/source-location.trace ? src/code/specializable-array.trace ? src/code/stream.trace ? src/code/string.trace ? src/code/stubs.trace ? src/code/sxhash.trace ? src/code/symbol.trace ? src/code/sysmacs.trace ? src/code/target-alieneval.trace ? src/code/target-allocate.trace ? src/code/target-c-call.trace ? src/code/target-char.trace ? src/code/target-defbangmethod.trace ? src/code/target-defstruct.trace ? src/code/target-error.trace ? src/code/target-extensions.trace ? src/code/target-format.trace ? src/code/target-hash-table.trace ? src/code/target-load.trace ? src/code/target-misc.trace ? src/code/target-package.trace ? src/code/target-pathname.trace ? src/code/target-random.trace ? src/code/target-sap.trace ? src/code/target-signal.trace ? src/code/target-stream.trace ? src/code/target-sxhash.trace ? src/code/target-thread.trace ? src/code/target-type.trace ? src/code/thread.trace ? src/code/time.trace ? src/code/timer.trace ? src/code/toplevel.trace ? src/code/type-class.trace ? src/code/type-init.trace ? src/code/typecheckfuns.trace ? src/code/typedefs.trace ? src/code/typep.trace ? src/code/uncross.trace ? src/code/unix-pathname.trace ? src/code/unix.trace ? src/code/unportable-float.trace ? src/code/weak.trace ? src/code/win32-pathname.trace ? src/code/x86-vm.trace ? src/code/external-formats/enc-cn-tbl.trace ? src/code/external-formats/enc-cn.trace ? src/code/external-formats/enc-cyr.trace ? src/code/external-formats/enc-dos.trace ? src/code/external-formats/enc-iso.trace ? src/code/external-formats/enc-jpn-tbl.trace ? src/code/external-formats/enc-jpn.trace ? src/code/external-formats/enc-win.trace ? src/code/external-formats/mb-util.trace ? src/code/external-formats/ucs-2.trace ? src/compiler/aliencomp.trace ? src/compiler/array-tran.trace ? src/compiler/assem.trace ? src/compiler/backend.trace ? src/compiler/bit-util.trace ? src/compiler/checkgen.trace ? src/compiler/codegen.trace ? src/compiler/compiler-deftype.trace ? src/compiler/compiler-error.trace ? src/compiler/constantp.trace ? src/compiler/constraint.trace ? src/compiler/control.trace ? src/compiler/copyprop.trace ? src/compiler/ctype.trace ? src/compiler/debug-dump.trace ? src/compiler/debug.trace ? src/compiler/defconstant.trace ? src/compiler/deftype.trace ? src/compiler/dfo.trace ? src/compiler/disassem.trace ? src/compiler/dump.trace ? src/compiler/early-aliencomp.trace ? src/compiler/early-assem.trace ? src/compiler/early-backend.trace ? src/compiler/early-c.trace ? src/compiler/entry.trace ? src/compiler/fixup-type.trace ? src/compiler/fixup.trace ? src/compiler/float-tran.trace ? src/compiler/fndb.trace ? src/compiler/fopcompile.trace ? src/compiler/fun-info-funs.trace ? src/compiler/globaldb.trace ? src/compiler/gtn.trace ? src/compiler/info-functions.trace ? src/compiler/ir1-translators.trace ? src/compiler/ir1final.trace ? src/compiler/ir1opt.trace ? src/compiler/ir1report.trace ? src/compiler/ir1tran-lambda.trace ? src/compiler/ir1tran.trace ? src/compiler/ir1util.trace ? src/compiler/ir2tran.trace ? src/compiler/knownfun.trace ? src/compiler/late-macros.trace ? src/compiler/late-proclaim.trace ? src/compiler/late-vmdef.trace ? src/compiler/lexenv.trace ? src/compiler/life.trace ? src/compiler/locall.trace ? src/compiler/loop.trace ? src/compiler/ltn.trace ? src/compiler/ltv.trace ? src/compiler/macros.trace ? src/compiler/main.trace ? src/compiler/meta-vmdef.trace ? src/compiler/node.trace ? src/compiler/pack.trace ? src/compiler/parse-lambda-list.trace ? src/compiler/physenvanal.trace ? src/compiler/policies.trace ? src/compiler/policy.trace ? src/compiler/proclaim.trace ? src/compiler/pseudo-vops.trace ? src/compiler/represent.trace ? src/compiler/saptran.trace ? src/compiler/seqtran.trace ? src/compiler/srctran.trace ? src/compiler/sset.trace ? src/compiler/stack.trace ? src/compiler/target-disassem.trace ? src/compiler/target-dump.trace ? src/compiler/target-main.trace ? src/compiler/tn.trace ? src/compiler/trace-table.trace ? src/compiler/typetran.trace ? src/compiler/vmdef.trace ? src/compiler/vop.trace ? src/compiler/xref.trace ? src/compiler/generic/array.trace ? src/compiler/generic/core.trace ? src/compiler/generic/early-objdef.trace ? src/compiler/generic/early-type-vops.trace ? src/compiler/generic/early-vm.trace ? src/compiler/generic/interr.trace ? src/compiler/generic/late-nlx.trace ? src/compiler/generic/late-type-vops.trace ? src/compiler/generic/objdef.trace ? src/compiler/generic/parms.trace ? src/compiler/generic/primtype.trace ? src/compiler/generic/target-core.trace ? src/compiler/generic/utils.trace ? src/compiler/generic/vm-array.trace ? src/compiler/generic/vm-fndb.trace ? src/compiler/generic/vm-ir2tran.trace ? src/compiler/generic/vm-macs.trace ? src/compiler/generic/vm-tran.trace ? src/compiler/generic/vm-type.trace ? src/compiler/generic/vm-typetran.trace ? src/compiler/x86/alloc.trace ? src/compiler/x86/arith.trace ? src/compiler/x86/array.trace ? src/compiler/x86/backend-parms.trace ? src/compiler/x86/c-call.trace ? src/compiler/x86/call.trace ? src/compiler/x86/cell.trace ? src/compiler/x86/char.trace ? src/compiler/x86/debug.trace ? src/compiler/x86/float.trace ? src/compiler/x86/insts.trace ? src/compiler/x86/macros.trace ? src/compiler/x86/memory.trace ? src/compiler/x86/move.trace ? src/compiler/x86/nlx.trace ? src/compiler/x86/parms.trace ? src/compiler/x86/pred.trace ? src/compiler/x86/sanctify.trace ? src/compiler/x86/sap.trace ? src/compiler/x86/show.trace ? src/compiler/x86/static-fn.trace ? src/compiler/x86/subprim.trace ? src/compiler/x86/system.trace ? src/compiler/x86/target-insts.trace ? src/compiler/x86/type-vops.trace ? src/compiler/x86/values.trace ? src/compiler/x86/vm.trace ? src/pcl/walk.trace Index: build-order.lisp-expr =================================================================== RCS file: /cvsroot/sbcl/sbcl/build-order.lisp-expr,v retrieving revision 1.79 diff -u -r1.79 build-order.lisp-expr --- build-order.lisp-expr 28 Mar 2007 17:59:16 -0000 1.79 +++ build-order.lisp-expr 31 Jan 2008 15:42:01 -0000 @@ -348,11 +348,11 @@ ("src/compiler/target/vm") ;; for e.g. SPECIFIER-TYPE, needed by primtype.lisp - ("src/code/early-type") + ("src/code/early-type" :trace-file) ;; FIXME: Classic CMU CL had (OPTIMIZE (SAFETY 2) (DEBUG 2) declared ;; around the compilation of "code/class". Why? - ("src/code/class") + ("src/code/class" :trace-file) ;; The definition of CONDITION-CLASS depends on SLOT-CLASS, defined ;; in class.lisp. @@ -387,7 +387,7 @@ ;; * the function PARSE-DEFMACRO, defined in parse-defmacro.lisp, ;; and because they define ;; * the function SPECIFIER-TYPE, which is used in fndb.lisp. - ("src/code/late-type") + ("src/code/late-type" :trace-file) ("src/code/deftypes-for-target") ;; defines IR1-ATTRIBUTES macro, needed by proclaim.lisp @@ -403,7 +403,7 @@ ("src/compiler/proclaim") ("src/code/class-init") - ("src/code/typecheckfuns") + ("src/code/typecheckfuns" :trace-file) ;; The DEFSTRUCT machinery needs SB!XC:SUBTYPEP, defined in ;; "code/late-type", and SB!XC:TYPEP, defined in "code/cross-type", @@ -443,7 +443,7 @@ ;; These define target types needed by fndb.lisp. ("src/code/package") ("src/code/random") - ("src/code/hash-table") + ("src/code/hash-table" :trace-file) ("src/code/readtable") ("src/code/pathname") ("src/code/host-pprint") @@ -653,7 +653,7 @@ ("src/code/eval" :not-host) ; uses INFO, wants compiler macro ("src/code/target-sap" :not-host) ; uses SAP-INT type - ("src/code/target-package" :not-host) ; needs "code/package" + ("src/code/target-package" :not-host :trace-file) ; needs "code/package" ("src/code/target-random" :not-host) ; needs "code/random" ("src/code/target-hash-table" :not-host) ; needs "code/hash-table" ("src/code/reader" :not-host) ; needs "code/readtable" @@ -670,7 +670,7 @@ ("src/code/early-step") ; target-thread needs *STEP-OUT* - ("src/code/target-thread" :not-host) + ("src/code/target-thread" :not-host :trace-file) ;; defines SB!DI:DO-DEBUG-FUN-BLOCKS, needed by target-disassem.lisp ("src/code/gc" :not-host) @@ -721,7 +721,7 @@ ;; FIXME: Does this really need stuff from compiler/dump.lisp? ("src/compiler/target-dump" :not-host) ; needs stuff from compiler/dump.lisp - ("src/code/cold-init" :not-host) ; needs (SETF EXTERN-ALIEN) macroexpansion + ("src/code/cold-init" :not-host :trace-file) ; needs (SETF EXTERN-ALIEN) macroexpansion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; target macros and DECLAIMs installed at build-the-cross-compiler time Index: src/assembly/x86/arith.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/assembly/x86/arith.lisp,v retrieving revision 1.10 diff -u -r1.10 arith.lisp --- src/assembly/x86/arith.lisp 4 Mar 2006 19:58:28 -0000 1.10 +++ src/assembly/x86/arith.lisp 31 Jan 2008 15:42:02 -0000 @@ -39,13 +39,13 @@ (inst jmp :z DO-BODY) ; yes - doit here DO-STATIC-FUN - (inst pop eax) - (inst push ebp-tn) - (inst lea - ebp-tn - (make-ea :dword :base esp-tn :disp n-word-bytes)) - (inst sub esp-tn (fixnumize 2)) - (inst push eax) ; callers return addr +;; (inst push ebp-tn) +;; (inst lea +;; ebp-tn +;; (make-ea :dword :base esp-tn :disp (* 2 n-word-bytes))) +;; (inst sub esp-tn (fixnumize 1)) + (inst enter (fixnumize 1)) + (inst push (make-ea :dword :base ebp-tn :disp (frame-byte-offset return-pc-save-offset))) ; callers return addr (inst mov ecx (fixnumize 2)) ; arg count (inst jmp (make-ea :dword @@ -132,11 +132,11 @@ (inst test x 3) (inst jmp :z FIXNUM) - (inst pop eax) - (inst push ebp-tn) - (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) - (inst sub esp-tn (fixnumize 2)) - (inst push eax) +;; (inst push ebp-tn) +;; (inst lea ebp-tn (make-ea :dword :base esp-tn :disp (* 2 n-word-bytes))) +;; (inst sub esp-tn (fixnumize 1)) + (inst enter (fixnumize 1)) + (inst push (make-ea :dword :base ebp-tn :disp (frame-byte-offset return-pc-save-offset))) (inst mov ecx (fixnumize 1)) ; arg count (inst jmp (make-ea :dword :disp (+ nil-value (static-fun-offset '%negate)))) @@ -180,14 +180,14 @@ (inst jmp :z INLINE-FIXNUM-COMPARE) TAIL-CALL-TO-STATIC-FN - (inst pop eax) - (inst push ebp-tn) - (inst lea ebp-tn (make-ea :dword - :base esp-tn - :disp n-word-bytes)) - (inst sub esp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, - ; weirdly? - (inst push eax) +;; (inst push ebp-tn) +;; (inst lea ebp-tn (make-ea :dword +;; :base esp-tn +;; :disp (* 2 n-word-bytes))) +;; (inst sub esp-tn (fixnumize 1)) ; FIXME: Push 2 words on stack, +;; ; weirdly? + (inst enter (fixnumize 1)) + (inst push (make-ea :dword :base ebp-tn :disp (frame-byte-offset return-pc-save-offset))) (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and ; SINGLE-FLOAT-BITS are parallel, ; should be named parallelly. @@ -233,11 +233,11 @@ (inst jmp DONE) DO-STATIC-FN - (inst pop eax) - (inst push ebp-tn) - (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) - (inst sub esp-tn (fixnumize 2)) - (inst push eax) +;; (inst push ebp-tn) +;; (inst lea ebp-tn (make-ea :dword :base esp-tn :disp (* 2 n-word-bytes))) +;; (inst sub esp-tn (fixnumize 1)) + (inst enter (fixnumize 1)) + (inst push (make-ea :dword :base ebp-tn :disp (frame-byte-offset return-pc-save-offset))) (inst mov ecx (fixnumize 2)) (inst jmp (make-ea :dword :disp (+ nil-value (static-fun-offset 'eql)))) @@ -272,11 +272,11 @@ (inst jmp DONE) DO-STATIC-FN - (inst pop eax) - (inst push ebp-tn) - (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) - (inst sub esp-tn (fixnumize 2)) - (inst push eax) +;; (inst push ebp-tn) +;; (inst lea ebp-tn (make-ea :dword :base esp-tn :disp (* 2 n-word-bytes))) +;; (inst sub esp-tn (fixnumize 1)) + (inst enter (fixnumize 1)) + (inst push (make-ea :dword :base ebp-tn :disp (frame-byte-offset return-pc-save-offset))) (inst mov ecx (fixnumize 2)) (inst jmp (make-ea :dword :disp (+ nil-value (static-fun-offset 'two-arg-=)))) Index: src/assembly/x86/assem-rtns.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/assembly/x86/assem-rtns.lisp,v retrieving revision 1.15 diff -u -r1.15 assem-rtns.lisp --- src/assembly/x86/assem-rtns.lisp 13 Jan 2007 21:05:34 -0000 1.15 +++ src/assembly/x86/assem-rtns.lisp 31 Jan 2008 15:42:02 -0000 @@ -140,8 +140,8 @@ ;; Save the OLD-FP and RETURN-PC because the blit it going to trash ;; those stack locations. Save the ECX, because the loop is going ;; to trash it. - (pushw ebp-tn -1) - (loadw ebx ebp-tn -2) + (pushw ebp-tn (frame-word-offset ocfp-save-offset)) + (loadw ebx ebp-tn (frame-word-offset return-pc-save-offset)) (inst push ecx) ;; Do the blit. Because we are coping from smaller addresses to @@ -149,7 +149,7 @@ ;; our way down. (inst shr ecx 2) ; fixnum to raw words (inst std) ; count down - (inst lea edi (make-ea :dword :base ebp-tn :disp (- n-word-bytes))) + (inst lea edi (make-ea :dword :base ebp-tn :disp (frame-byte-offset 0))) (inst sub esi (fixnumize 1)) (inst rep) (inst movs :dword) @@ -158,18 +158,19 @@ #!+sunos (inst cld) ;; Load the register arguments carefully. - (loadw edx ebp-tn -1) + (loadw edx ebp-tn (frame-word-offset 1)) ; ocfp-save-offset ;; Restore OLD-FP and ECX. (inst pop ecx) - (popw ebp-tn -1) ; overwrites a0 + (popw ebp-tn (frame-word-offset ocfp-save-offset)) ; overwrites a1 ;; Blow off the stack above the arguments. (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes)) ;; remaining register args - (loadw edi ebp-tn -2) - (loadw esi ebp-tn -3) + (inst mov edi edx) + (loadw edx ebp-tn (frame-word-offset 0)) + (loadw esi ebp-tn (frame-word-offset 2)) ;; Push the (saved) return-pc so it looks like we just called. (inst push ebx) @@ -191,7 +192,7 @@ (make-ea :dword :base ebp-tn :disp (* -3 n-word-bytes))) ;; Push the return-pc so it looks like we just called. - (pushw ebp-tn -2) + (pushw ebp-tn (frame-word-offset return-pc-save-offset)) ;; And away we go. (inst jmp (make-ea :byte :base eax Index: src/cold/compile-cold-sbcl.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/cold/compile-cold-sbcl.lisp,v retrieving revision 1.7 diff -u -r1.7 compile-cold-sbcl.lisp --- src/cold/compile-cold-sbcl.lisp 14 Jul 2005 16:30:41 -0000 1.7 +++ src/cold/compile-cold-sbcl.lisp 31 Jan 2008 15:42:02 -0000 @@ -20,7 +20,7 @@ (do-stems-and-flags (stem flags) (unless (position :not-target flags) (push (target-compile-stem stem - :trace-file (find :trace-file flags) + :trace-file (not (find :assem flags));(find :trace-file flags) :assem-p (find :assem flags) :ignore-failure-p (find :ignore-failure-p flags)) Index: src/compiler/x86/call.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/call.lisp,v retrieving revision 1.36 diff -u -r1.36 call.lisp --- src/compiler/x86/call.lisp 7 Apr 2007 20:00:24 -0000 1.36 +++ src/compiler/x86/call.lisp 31 Jan 2008 15:42:03 -0000 @@ -142,7 +142,7 @@ ;; The args fit within the frame so just allocate the frame. (inst lea esp-tn (make-ea :dword :base ebp-tn - :disp (- (* n-word-bytes + :disp (- 8 (* n-word-bytes (max 3 (sb-allocated-size 'stack))))))) (trace-table-entry trace-table-normal))) @@ -151,12 +151,14 @@ ;;; or a multiple-call-local. All it does is allocate stack space for the ;;; callee (who has the same size stack as us). (define-vop (allocate-frame) - (:results (res :scs (any-reg control-stack)) + (:results (res :scs (any-reg #+(or)control-stack)) (nfp)) (:info callee) (:ignore nfp callee) (:generator 2 - (move res esp-tn) + ;(move res esp-tn) + (inst lea res (make-ea :dword :base esp-tn + :disp (- (frame-byte-offset -1)))) (inst sub esp-tn (* n-word-bytes (sb-allocated-size 'stack))))) ;;; Allocate a partial frame for passing stack arguments in a full @@ -165,9 +167,11 @@ ;;; before it can extend the stack. (define-vop (allocate-full-call-frame) (:info nargs) - (:results (res :scs (any-reg control-stack))) + (:results (res :scs (any-reg #+(or)control-stack))) (:generator 2 - (move res esp-tn) + ;(move res esp-tn) + (inst lea res (make-ea :dword :base esp-tn + :disp (- (frame-byte-offset -1)))) (inst sub esp-tn (* (max nargs 3) n-word-bytes)))) ;;; Emit code needed at the return-point from an unknown-values call @@ -476,11 +480,14 @@ ;; Is the return-pc on the stack or in a register? (sc-case ret-tn ((sap-stack) + (unless (= (tn-offset ret-tn) return-pc-save-offset) + (error "ret-tn ~A in wrong stack slot" ret-tn)) #+nil (format t "*call-local: ret-tn on stack; offset=~S~%" (tn-offset ret-tn)) (storew (make-fixup nil :code-object return) ebp-tn (frame-word-offset (tn-offset ret-tn)))) ((sap-reg) + (error "ret-tn ~A in sap-reg" ret-tn) (inst lea ret-tn (make-fixup nil :code-object return))))) (note-this-location vop :call-site) @@ -642,6 +649,7 @@ ;; return-pc may be either in a register or on the stack. (sc-case return-pc ((sap-reg) + (error "return-local, return-pc not on stack") (sc-case old-fp ((control-stack) @@ -676,13 +684,22 @@ #+nil (format t "*known-return: return-pc ~S on stack; offset=~S~%" return-pc (tn-offset return-pc)) + (unless (and (sc-is old-fp control-stack) + (= (tn-offset old-fp) ocfp-save-offset)) + (error "known-return: ocfp not on stack in standard save location?")) + (unless (and (sc-is return-pc sap-stack) + (= (tn-offset return-pc) return-pc-save-offset)) + (error "known-return: return-pc not on stack in standard save location?")) + + ;; Zot all of the stack except for the old-fp and return-pc. (inst lea esp-tn (make-ea :dword :base ebp-tn - :disp (frame-byte-offset (tn-offset return-pc)))) + :disp (frame-byte-offset (tn-offset old-fp #+(or)return-pc)))) ;; Restore the old fp. old-fp may be either on the stack in its ;; save location or in a register, in either case this restores it. - (move ebp-tn old-fp) + ;(move ebp-tn old-fp) + (inst pop ebp-tn) ;; The return pops the return address (4 bytes), then we need ;; to pop all the slots before the return-pc which includes the ;; 4 bytes for the old-fp. @@ -853,13 +870,13 @@ ;; FIXME: FORMAT T for stale ;; diagnostic output (several of ;; them around here), ick - (format t "** tail-call old-fp not S0~%") + (error "** tail-call old-fp not S0~%") (move old-fp-tmp old-fp) (storew old-fp-tmp ebp-tn (frame-word-offset ocfp-save-offset)))) ((any-reg descriptor-reg) - (format t "** tail-call old-fp in reg not S0~%") + (error "** tail-call old-fp in reg not S0~%") (storew old-fp ebp-tn (frame-word-offset ocfp-save-offset)))) @@ -887,6 +904,10 @@ ,(if variable '(inst sub esp-tn (fixnumize 3))) + ;; Bias the new-fp for use as an fp + ,(if variable + '(inst sub new-fp (fixnumize 2))) + ;; Save the fp (storew ebp-tn new-fp (frame-word-offset ocfp-save-offset)) @@ -983,6 +1004,7 @@ ;; Code structure lifted from known-return. (sc-case return-pc ((sap-reg) + (error "return pc not on stack") ;; return PC in register for some reason (local call?) ;; we jmp to the return pc after fixing the stack and frame. (sc-case old-fp @@ -1020,13 +1042,25 @@ ;; to assert that (in either the weaker or stronger forms). ;; Should this ever not be the case, we should load old-fp ;; into a temp reg while we fix the stack. + ;(unless (sc-is old-fp control-stack) + ; (error "old-fp not on stack")) + (unless (and (sc-is old-fp control-stack) + (= (tn-offset old-fp) ocfp-save-offset)) + (error "ocfp not on stack in standard save location?")) + (unless (and (sc-is return-pc sap-stack) + (= (tn-offset return-pc) return-pc-save-offset)) + (error "return-pc not on stack in standard save location?")) ;; Drop stack above return-pc - (inst lea esp-tn (make-ea :dword :base ebp-tn - :disp (frame-byte-offset (tn-offset return-pc)))) + (if (zerop (frame-byte-offset (tn-offset old-fp))) + ;; This is always true under the new regime. + (inst mov esp-tn ebp-tn) + (inst lea esp-tn (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (tn-offset old-fp #+(or)return-pc))))) ;; Set single-value return flag (inst clc) ;; Restore the old frame pointer - (move ebp-tn old-fp) + ;(move ebp-tn old-fp) + (inst pop ebp-tn) ;; And return, dropping the rest of the stack as we go. (inst ret (* (tn-offset return-pc) n-word-bytes)))))) @@ -1060,9 +1094,18 @@ :from :eval) a2) (:generator 6 + (unless (and (sc-is old-fp control-stack) + (= (tn-offset old-fp) ocfp-save-offset)) + (error "ocfp not on stack in standard save location?")) + (unless (and (sc-is return-pc sap-stack) + (= (tn-offset return-pc) return-pc-save-offset)) + (error "return-pc not on stack in standard save location?")) + (trace-table-entry trace-table-fun-epilogue) ;; Establish the values pointer and values count. - (move ebx ebp-tn) + ;(move ebx ebp-tn) + (inst lea ebx (make-ea :dword :base ebp-tn + :disp (frame-byte-offset -1))) (if (zerop nvals) (inst xor ecx ecx) ; smaller (inst mov ecx (fixnumize nvals))) @@ -1070,8 +1113,9 @@ (move ebp-tn old-fp) ;; Clear as much of the stack as possible, but not past the return ;; address. - (inst lea esp-tn (make-ea :dword :base ebx - :disp (- (* (max nvals 2) n-word-bytes)))) + (inst lea esp-tn + (make-ea :dword :base ebx + :disp (- (frame-byte-offset (max (1- nvals) return-pc-save-offset)) 8))) ;; Pre-default any argument register that need it. (when (< nvals register-arg-count) (let* ((arg-tns (nthcdr nvals (list a0 a1 a2))) @@ -1086,14 +1130,18 @@ ;; tell it to index off of EBX instead of EBP. (cond ((zerop nvals) ;; Return popping the return address and the OCFP. - (inst ret n-word-bytes)) - ((= nvals 1) + ;(inst lea ebx (make-ea :dword :base ebx :disp 8)) + (inst ret (* return-pc-save-offset n-word-bytes))) + #+(or)((= nvals 1) ;; Return popping the return, leaving 1 slot. Can this ;; happen, or is a single value return handled elsewhere? (inst ret)) (t - (inst jmp (make-ea :dword :base ebx - :disp (frame-byte-offset (tn-offset return-pc)))))) + ;; Thou shalt not JMP unto thy return address. + (inst push (make-ea :dword :base ebx + :disp (- (frame-byte-offset (tn-offset return-pc)) 8))) + ;(inst lea ebx (make-ea :dword :base ebx :disp 8)) + (inst ret))) (trace-table-entry trace-table-normal))) @@ -1109,7 +1157,7 @@ ;;; ECX -- number of values to find there. ;;; ESI -- pointer to where to find the values. (define-vop (return-multiple) - (:args (old-fp :to (:eval 1) :target old-fp-temp) + (:args (old-fp :to (:eval 1) #|:target old-fp-temp|#) (return-pc :target eax) (vals :scs (any-reg) :target esi) (nvals :scs (any-reg) :target ecx)) @@ -1120,13 +1168,13 @@ (:temporary (:sc unsigned-reg :offset ebx-offset :from (:eval 0)) ebx) (:temporary (:sc descriptor-reg :offset (first *register-arg-offsets*) :from (:eval 0)) a0) - (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp) + ;(:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp) (:node-var node) (:generator 13 (trace-table-entry trace-table-fun-epilogue) ;; Load the return-pc. - (move eax return-pc) + ;(move eax return-pc) (unless (policy node (> space speed)) ;; Check for the single case. (let ((not-single (gen-label))) @@ -1137,20 +1185,26 @@ (loadw a0 vals -1) ;; Clear the stack. We load old-fp into a register before clearing ;; the stack. - (move old-fp-temp old-fp) - (move esp-tn ebp-tn) - (move ebp-tn old-fp-temp) + ;(move old-fp-temp old-fp) + ;(move esp-tn ebp-tn) + ;(move ebp-tn old-fp-temp) ;; Set the single-value return flag. (inst clc) ;; Out of here. - (inst jmp eax) + ;(inst push eax) + (move esp-tn ebp-tn) + (inst pop ebp-tn) + (inst ret) + #+(or)(inst jmp eax) ;; Nope, not the single case. Jump to the assembly routine. (emit-label not-single))) + (move eax return-pc) (move esi vals) (move ecx nvals) (move ebx ebp-tn) (move ebp-tn old-fp) + ;(inst add ebx 8) (inst jmp (make-fixup 'return-multiple :assembly-routine)) (trace-table-entry trace-table-normal))) @@ -1207,7 +1261,7 @@ ;; stack = ebp - (max 3 frame-size) - (nargs - fixed) (inst lea ebx-tn (make-ea :dword :base ebp-tn - :disp (- (fixnumize fixed) + :disp (- (fixnumize (+ 2 fixed)) (* n-word-bytes (max 3 (sb-allocated-size 'stack)))))) (inst sub ebx-tn ecx-tn) ; Got the new stack in ebx @@ -1237,7 +1291,8 @@ ;; now. ;; Initialize src to be end of args. - (inst mov esi-tn ebp-tn) + ;(inst mov esi-tn ebp-tn) + (inst lea esi-tn (make-ea :dword :base ebp-tn :disp 8)) (inst sub esi-tn ebx-tn) ;; We need to copy from downwards up to avoid overwriting some of @@ -1275,7 +1330,7 @@ ( nil ) ;; Store it relative to ebp (inst mov (make-ea :dword :base ebp-tn - :disp (- (* 4 + :disp (- 8 (* 4 (+ 1 (- i fixed) (max 3 (sb-allocated-size 'stack)))))) (nth i *register-arg-tns*)) @@ -1295,7 +1350,7 @@ JUST-ALLOC-FRAME (inst lea esp-tn (make-ea :dword :base ebp-tn - :disp (- (* n-word-bytes + :disp (- 8 (* n-word-bytes (max 3 (sb-allocated-size 'stack)))))) DONE)) Index: src/compiler/x86/insts.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/insts.lisp,v retrieving revision 1.42 diff -u -r1.42 insts.lisp --- src/compiler/x86/insts.lisp 8 Apr 2007 05:23:49 -0000 1.42 +++ src/compiler/x86/insts.lisp 31 Jan 2008 15:42:03 -0000 @@ -1573,7 +1573,7 @@ y)) ((sc-is x control-stack) (inst test (make-ea :byte :base ebp-tn - :disp (- (* (1+ offset) n-word-bytes))) + :disp (frame-byte-offset offset)) y)) (t (inst test x y))))) @@ -1836,7 +1836,7 @@ (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16)) '(:name :tab imm)) (:emitter - (cond (stack-delta + (cond ((and stack-delta (not (zerop stack-delta))) (emit-byte segment #b11000010) (emit-word segment stack-delta)) (t Index: src/compiler/x86/static-fn.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/static-fn.lisp,v retrieving revision 1.10 diff -u -r1.10 static-fn.lisp --- src/compiler/x86/static-fn.lisp 14 Jul 2005 19:13:48 -0000 1.10 +++ src/compiler/x86/static-fn.lisp 31 Jan 2008 15:42:03 -0000 @@ -16,9 +16,11 @@ (:policy :safe) (:variant-vars function) (:vop-var vop) - (:node-var node) - (:temporary (:sc unsigned-reg :offset ebx-offset - :from (:eval 0) :to (:eval 2)) ebx) + ;(:node-var node) + ;; XXX: May want to be :ignore instead of commented out? + ;; Or may not matter, given :SAVE-P T above. + ;(:temporary (:sc unsigned-reg :offset ebx-offset + ; :from (:eval 0) :to (:eval 2)) ebx) (:temporary (:sc unsigned-reg :offset ecx-offset :from (:eval 0) :to (:eval 2)) ecx)) @@ -78,20 +80,26 @@ ;; If speed not more important than size, duplicate the ;; effect of the ENTER with discrete instructions. Takes ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes. - (cond ((policy node (>= speed space)) - (inst mov ebx esp-tn) + (cond (t ;(policy node (>= speed space)) + ;(inst mov ebx esp-tn) ;; Save the old-fp (inst push ebp-tn) + (inst push ebp-tn) + (move ebp-tn esp-tn) ;; Ensure that at least three slots are available; one ;; above, two more needed. - (inst sub esp-tn (fixnumize 2)) - (inst mov ebp-tn ebx)) + (inst sub esp-tn (fixnumize 1)) + ;(inst mov ebp-tn ebx) + ) (t - (inst enter (fixnumize 2)) + (inst push ebp-tn) + (inst enter (fixnumize 1)) + ;(inst enter (fixnumize 2)) ;; The enter instruction pushes EBP and then copies ;; ESP into EBP. We want the new EBP to be the ;; original ESP, so we fix it up afterwards. - (inst add ebp-tn (fixnumize 1)))) + ;(inst add ebp-tn (fixnumize 1)) + )) ,(if (zerop num-args) '(inst xor ecx ecx) Index: src/compiler/x86/vm.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/vm.lisp,v retrieving revision 1.26 diff -u -r1.26 vm.lisp --- src/compiler/x86/vm.lisp 7 Apr 2007 20:00:25 -0000 1.26 +++ src/compiler/x86/vm.lisp 31 Jan 2008 15:42:03 -0000 @@ -406,12 +406,12 @@ ;;;; miscellaneous function call parameters ;;; offsets of special stack frame locations -(def!constant ocfp-save-offset 0) -(def!constant return-pc-save-offset 1) +(def!constant ocfp-save-offset 1) +(def!constant return-pc-save-offset 0) (declaim (inline frame-word-offset)) (defun frame-word-offset (index) - (- (1+ index))) + (- (1- index))) (declaim (inline frame-byte-offset)) (defun frame-byte-offset (index) Index: src/runtime/backtrace.c =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/runtime/backtrace.c,v retrieving revision 1.30 diff -u -r1.30 backtrace.c --- src/runtime/backtrace.c 27 Oct 2005 21:22:42 -0000 1.30 +++ src/runtime/backtrace.c 31 Jan 2008 15:42:03 -0000 @@ -318,8 +318,8 @@ c_ocfp = *((void **) fp); c_ra = *((void **) fp + 1); - lisp_ocfp = *((void **) fp - 1); - lisp_ra = *((void **) fp - 2); + lisp_ocfp = *((void **) fp - 2); + lisp_ra = *((void **) fp - 1); lisp_valid_p = (lisp_ocfp > fp && stack_pointer_p(lisp_ocfp) Index: src/runtime/interrupt.c =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/runtime/interrupt.c,v retrieving revision 1.128 diff -u -r1.128 interrupt.c --- src/runtime/interrupt.c 4 Apr 2007 14:03:08 -0000 1.128 +++ src/runtime/interrupt.c 31 Jan 2008 15:42:04 -0000 @@ -1308,6 +1308,7 @@ void lisp_memory_fault_error(os_context_t *context, os_vm_address_t addr) { + print_context(context); /* FIXME: This is lossy: if we get another memory fault (eg. from * another thread) before lisp has read this, we the information. * However, since this is mostly informative, we'll live with that for Index: src/runtime/monitor.c =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/runtime/monitor.c,v retrieving revision 1.35 diff -u -r1.35 monitor.c --- src/runtime/monitor.c 3 Jan 2006 09:52:38 -0000 1.35 +++ src/runtime/monitor.c 31 Jan 2008 15:42:04 -0000 @@ -332,7 +332,7 @@ purify(NIL, NIL); } -static void +/*static*/ void print_context(os_context_t *context) { int i; Index: src/runtime/x86-assem.S =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/runtime/x86-assem.S,v retrieving revision 1.40 diff -u -r1.40 x86-assem.S --- src/runtime/x86-assem.S 2 Apr 2007 08:37:37 -0000 1.40 +++ src/runtime/x86-assem.S 31 Jan 2008 15:42:04 -0000 @@ -281,10 +281,13 @@ #endif /* Alloc new frame. */ - mov %esp,%ebx # The current sp marks start of new frame. +# mov %esp,%ebx # The current sp marks start of new frame. + push %ebp push %ebp # fp in save location S0 - sub $8,%esp # Ensure 3 slots are allocated, one above. - mov %ebx,%ebp # Switch to new frame. + mov %esp,%ebp + sub $4,%esp # Ensure 3 slots are allocated, one above. +# mov %ebx,%ebp # Switch to new frame. +# lea -8(%ebx),%ebp # Switch to new frame. call *CLOSURE_FUN_OFFSET(%eax)