? src/code/early-type.trace ? src/code/typecheckfuns.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 10 Apr 2007 19:34:09 -0000 @@ -348,7 +348,7 @@ ("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? @@ -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", 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 10 Apr 2007 19:34:09 -0000 @@ -39,13 +39,12 @@ (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 + (make-ea :dword :base esp-tn :disp (* 2 n-word-bytes))) + (inst sub esp-tn (fixnumize 1)) + (inst push (make-ea :dword :base ebp-tn :disp (- n-word-bytes))) ; callers return addr (inst mov ecx (fixnumize 2)) ; arg count (inst jmp (make-ea :dword @@ -132,11 +131,10 @@ (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 lea ebp-tn (make-ea :dword :base esp-tn :disp (* 2 n-word-bytes))) + (inst sub esp-tn (fixnumize 1)) + (inst push (make-ea :dword :base ebp-tn :disp (- n-word-bytes))) (inst mov ecx (fixnumize 1)) ; arg count (inst jmp (make-ea :dword :disp (+ nil-value (static-fun-offset '%negate)))) @@ -180,14 +178,13 @@ (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, + :disp (* 2 n-word-bytes))) + (inst sub esp-tn (fixnumize 1)) ; FIXME: Push 2 words on stack, ; weirdly? - (inst push eax) + (inst push (make-ea :dword :base ebp-tn :disp (- n-word-bytes))) (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and ; SINGLE-FLOAT-BITS are parallel, ; should be named parallelly. @@ -233,11 +230,10 @@ (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 lea ebp-tn (make-ea :dword :base esp-tn :disp (* 2 n-word-bytes))) + (inst sub esp-tn (fixnumize 1)) + (inst push (make-ea :dword :base ebp-tn :disp (- n-word-bytes))) (inst mov ecx (fixnumize 2)) (inst jmp (make-ea :dword :disp (+ nil-value (static-fun-offset 'eql)))) @@ -272,11 +268,10 @@ (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 lea ebp-tn (make-ea :dword :base esp-tn :disp (* 2 n-word-bytes))) + (inst sub esp-tn (fixnumize 1)) + (inst push (make-ea :dword :base ebp-tn :disp (- n-word-bytes))) (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 10 Apr 2007 19:34:10 -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 -2) + (loadw ebx ebp-tn -1) (inst push ecx) ;; Do the blit. Because we are coping from smaller addresses to @@ -158,17 +158,18 @@ #!+sunos (inst cld) ;; Load the register arguments carefully. - (loadw edx ebp-tn -1) + (loadw edx ebp-tn -2) ;; Restore OLD-FP and ECX. (inst pop ecx) - (popw ebp-tn -1) ; overwrites a0 + (popw ebp-tn -2) ; 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) + (inst mov edi edx) + (loadw edx ebp-tn -1) (loadw esi ebp-tn -3) ;; Push the (saved) return-pc so it looks like we just called. @@ -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 -1) ;; And away we go. (inst jmp (make-ea :byte :base eax 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 10 Apr 2007 19:34:10 -0000 @@ -476,11 +476,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 +645,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 +680,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 +866,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)))) @@ -983,6 +996,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 +1034,22 @@ ;; 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)))) + :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,6 +1083,13 @@ :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) @@ -1070,8 +1100,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)))) ;; Pre-default any argument register that need it. (when (< nvals register-arg-count) (let* ((arg-tns (nthcdr nvals (list a0 a1 a2))) @@ -1086,14 +1117,16 @@ ;; 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 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)))) + (inst ret))) (trace-table-entry trace-table-normal))) @@ -1143,7 +1176,9 @@ ;; Set the single-value return flag. (inst clc) ;; Out of here. - (inst jmp eax) + (inst push eax) + (inst ret) + #+(or)(inst jmp eax) ;; Nope, not the single case. Jump to the assembly routine. (emit-label not-single))) 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 10 Apr 2007 19:34:11 -0000 @@ -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 10 Apr 2007 19:34:11 -0000 @@ -16,7 +16,7 @@ (:policy :safe) (:variant-vars function) (:vop-var vop) - (:node-var node) + ;(:node-var node) (:temporary (:sc unsigned-reg :offset ebx-offset :from (:eval 0) :to (:eval 2)) ebx) (:temporary (:sc unsigned-reg :offset ecx-offset @@ -78,15 +78,16 @@ ;; 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)) + (cond (t ;(policy node (>= speed space)) (inst mov ebx esp-tn) ;; Save the old-fp (inst push ebp-tn) + (inst push ebp-tn) ;; Ensure that at least three slots are available; one ;; above, two more needed. - (inst sub esp-tn (fixnumize 2)) + (inst sub esp-tn (fixnumize 1)) (inst mov ebp-tn ebx)) - (t + #+(or) (t (inst enter (fixnumize 2)) ;; The enter instruction pushes EBP and then copies ;; ESP into EBP. We want the new EBP to be the 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 10 Apr 2007 19:34:11 -0000 @@ -406,8 +406,8 @@ ;;;; 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) 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 10 Apr 2007 19:34:11 -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 10 Apr 2007 19:34:11 -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 10 Apr 2007 19:34:11 -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 10 Apr 2007 19:34:12 -0000 @@ -282,8 +282,9 @@ /* Alloc 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. + sub $4,%esp # Ensure 3 slots are allocated, one above. mov %ebx,%ebp # Switch to new frame. call *CLOSURE_FUN_OFFSET(%eax)