Skip to content
Snippets Groups Projects
Commit 7ba077bf authored by dtc's avatar dtc
Browse files

Clean up the NLX entry VOPs so that the argument start is passed in

the EBX register rather than in stack slot 0 where it corrupts the
OCFP. New vm-support-routine make-nlx-entry-argument-start-location.
No longer need to save/restore the OCFP with the dynamic state as it
isn't corrupted.
parent f36752df
No related branches found
No related tags found
No related merge requests found
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.2 1997/11/18 10:48:01 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.3 1997/11/21 12:26:48 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -17,6 +17,7 @@
;;; Written by William Lott
;;;
;;; Debugged by Paul F. Werkowski -- Spring/Summer 1995.
;;; Enhancements/debugging by Douglas T. Crosher 1997.
;;;
(in-package :x86)
......@@ -195,10 +196,6 @@
(pushw ebp-tn -2)
;; And away we go.
; (inst jmp-indirect
; (make-ea :byte :base eax :disp (- (* closure-function-slot word-bytes)
; function-pointer-type)))
;; -- jrd
(inst jmp
(make-ea :byte :base eax :disp (- (* closure-function-slot word-bytes)
function-pointer-type)))
......@@ -248,7 +245,7 @@
(:arg start (any-reg descriptor-reg) ebx-offset)
(:arg count (any-reg descriptor-reg) ecx-offset)
(:temp uwp dword-reg esi-offset))
(declare (ignore count))
(declare (ignore start count))
(let ((error (generate-error-code nil invalid-unwind-error)))
(inst or block block) ; check for NULL pointer
......@@ -256,8 +253,9 @@
(load-symbol-value uwp lisp::*current-unwind-protect-block*)
(inst;; does *cuwpb* match value stored in argument cuwp slot?
cmp uwp (make-ea-for-object-slot block unwind-block-current-uwp-slot 0))
;; Does *cuwpb* match value stored in argument cuwp slot?
(inst cmp uwp
(make-ea-for-object-slot block unwind-block-current-uwp-slot 0))
;; If a match, return to context in arg block.
(inst jmp :e do-exit)
......@@ -273,18 +271,9 @@
(loadw ebp-tn block unwind-block-current-cont-slot)
;; apparently a carefully held secret is that uwp-entry expects
;; some things in known locations so that they can be saved on
;; the stack! Jeesh!
;;(move edx-tn block) ; gets shoved into 'block'
;;(move ecx-tn count) ; a noop
;; This seems needed to properly save the 'start' value so that the
;; correct thing gets passed into the various nlx entry points although
;; I think the compiler really ought to do it.
(storew start ebp-tn (- (1+ ocfp-save-offset)))
;; Uwp-entry expects some things in known locations so that they can
;; be saved on the stack: the block in edx-tn; start in ebx-tn; and
;; count in ecx-tn
(inst jmp (make-ea :byte :base block
:disp (* unwind-block-entry-pc-slot word-bytes))))
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/backend.lisp,v 1.28 1994/10/31 04:27:28 ram Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/backend.lisp,v 1.29 1997/11/21 12:26:50 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -85,6 +85,7 @@
;; From NLX.LISP
make-nlx-sp-tn
make-dynamic-state-tns
#+x86 make-nlx-entry-argument-start-location
;; From SUPPORT.LISP
generate-call-sequence
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.61 1997/04/16 18:06:20 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.62 1997/11/21 12:26:52 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -1601,7 +1601,8 @@
(2cont (continuation-info cont))
(2info (nlx-info-info info))
(top-loc (ir2-nlx-info-save-sp 2info))
(start-loc (make-old-fp-passing-location t))
(start-loc #-x86 (make-old-fp-passing-location t)
#+x86 (make-nlx-entry-argument-start-location))
(count-loc (make-argument-count-location))
(target (ir2-nlx-info-target 2info)))
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/nlx.lisp,v 1.7 1997/11/18 10:53:24 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/nlx.lisp,v 1.8 1997/11/21 12:26:46 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -29,6 +29,14 @@
(make-representation-tn *fixnum-primitive-type* any-reg-sc-number)
env))
;;; Make-NLX-Entry-Argument-Start-Location -- Interface
;;;
;;; Make a TN for the argument count passing location for a
;;; non-local entry.
;;;
(def-vm-support-routine make-nlx-entry-argument-start-location ()
(make-wired-tn *fixnum-primitive-type* any-reg-sc-number ebx-offset))
(defun catch-block-ea (tn)
(assert (sc-is tn catch-block))
(make-ea :dword :base ebp-tn
......@@ -37,10 +45,13 @@
;;; Save and restore dynamic environment.
;;;
;;; These VOPs are used in the reentered function to restore the appropriate
;;; dynamic environment. Currently we only save the Current-Catch and eval
;;; stack pointer. We don't need to save/restore the current unwind-protect,
;;; since unwind-protects are implicitly processed during unwinding.
;;; These VOPs are used in the reentered function to restore the
;;; appropriate dynamic environment. Currently we only save the
;;; Current-Catch, the eval stack pointer, and the alien stack
;;; pointer.
;;;
;;; We don't need to save/restore the current unwind-protect, since
;;; unwind-protects are implicitly processed during unwinding.
;;;
;;; We don't need to save the BSP, because that is handled automatically.
......@@ -50,30 +61,25 @@
;;; use with the Save/Restore-Dynamic-Environment VOPs.
;;;
(def-vm-support-routine make-dynamic-state-tns ()
(make-n-tns 4 *any-primitive-type*))
(make-n-tns 3 *any-primitive-type*))
(define-vop (save-dynamic-state)
(:results (catch :scs (descriptor-reg))
(eval :scs (descriptor-reg))
(oldfp :scs (descriptor-reg))
(alien-stack :scs (descriptor-reg)))
(:generator 13
(load-symbol-value catch lisp::*current-catch-block*)
(load-symbol-value eval lisp::*eval-stack-top*)
(load-symbol-value alien-stack *alien-stack*)
(loadw oldfp ebp-tn (- (1+ ocfp-save-offset)))))
(load-symbol-value alien-stack *alien-stack*)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
(eval :scs (descriptor-reg))
(oldfp :scs (descriptor-reg))
(alien-stack :scs (descriptor-reg)))
(:generator 10
(store-symbol-value catch lisp::*current-catch-block*)
(store-symbol-value eval lisp::*eval-stack-top*)
(store-symbol-value alien-stack *alien-stack*)
(storew oldfp ebp-tn (- (1+ ocfp-save-offset)))))
(store-symbol-value alien-stack *alien-stack*)))
(define-vop (current-stack-pointer)
(:results (res :scs (any-reg control-stack)))
......@@ -160,76 +166,14 @@
;;;; NLX entry VOPs:
#+nil ;; this is bogus?
(define-vop (nlx-entry)
(:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
; would be inserted before the return-pc label.
(start)
(count))
(:results (values :more t))
(:temporary (:sc descriptor-reg) nil-temp move-temp)
(:info label nvals)
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-label label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
((= nvals 1)
(let ((no-values (gen-label)))
;; (move (tn-ref-tn values) nil-value) -- jrd
(inst mov (tn-ref-tn values) nil-value)
(inst jecxz no-values)
;; jrd rewrote this piece. because we can't issue an sc-restriction,
;; as above, we generate a bogus EA here (see the expansion of LOADW)
;; and croak. Do the move by hand.
;; (loadw (tn-ref-tn values) start -1)
(inst mov move-temp start)
(loadw (tn-ref-tn values) move-temp -1)
(emit-label no-values)))
(t
(collect ((defaults))
(inst mov nil-temp nil-value)
(do ((i 0 (1+ i))
(tn-ref values (tn-ref-across tn-ref)))
((null tn-ref))
(let ((default-lab (gen-label))
(tn (tn-ref-tn tn-ref)))
(defaults (cons default-lab tn))
(inst cmp count (fixnum i))
(inst jmp :le default-lab)
(sc-case tn
((descriptor-reg any-reg)
;; see above -- jrd
;; (loadw tn start (- (1+ i)))
(inst mov move-temp start)
(loadw tn move-temp (- (1+ i))))
((control-stack immediate-stack)
;; (loadw move-temp start (- (1+ i)))
(inst mov move-temp start)
(loadw move-temp move-temp (- (1+ i)))
(move tn move-temp)))))
(let ((defaulting-done (gen-label)))
(emit-label defaulting-done)
(assemble (*elsewhere*)
(dolist (def (defaults))
(emit-label (car def))
(move (cdr def) nil-temp))
(inst jmp defaulting-done))))))
(inst mov esp-tn sp)))
;;; see comments below regarding start arg to nlx-entry-multiple
(define-vop (nlx-entry)
(:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
; would be inserted before the return-pc label.
;; Note: we can't list an sc-restriction, 'cause any load vops would
;; be inserted before the return-pc label.
(:args (sp)
(start)
(count))
(:results (values :more t))
(:temporary (:sc descriptor-reg) nil-temp move-temp)
(:temporary (:sc descriptor-reg) move-temp)
(:info label nvals)
(:save-p :force-to-stack)
(:vop-var vop)
......@@ -239,18 +183,12 @@
(cond ((zerop nvals))
((= nvals 1)
(let ((no-values (gen-label)))
;; (move (tn-ref-tn values) nil-value) -- jrd
(inst mov (tn-ref-tn values) nil-value)
(inst jecxz no-values)
(move move-temp start)
(loadw (tn-ref-tn values) move-temp -1)
(loadw (tn-ref-tn values) start -1)
(emit-label no-values)))
(t
(collect ((defaults))
(inst mov nil-temp nil-value)
(do ((i 0 (1+ i))
(tn-ref values (tn-ref-across tn-ref)))
((null tn-ref))
......@@ -262,79 +200,19 @@
(inst jmp :le default-lab)
(sc-case tn
((descriptor-reg any-reg)
;; see above -- jrd
;; (loadw tn start (- (1+ i)))
(move move-temp start)
(loadw tn move-temp (- (1+ i))))
(loadw tn start (- (1+ i))))
((control-stack)
;; (loadw move-temp start (- (1+ i)))
(move move-temp start)
(loadw move-temp move-temp (- (1+ i)))
(move tn move-temp)))))
(loadw move-temp start (- (1+ i)))
(inst mov tn move-temp)))))
(let ((defaulting-done (gen-label)))
(emit-label defaulting-done)
(assemble (*elsewhere*)
(dolist (def (defaults))
(emit-label (car def))
(move (cdr def) nil-temp))
(inst mov (cdr def) nil-value))
(inst jmp defaulting-done))))))
(inst mov esp-tn sp)))
#+nil ;;; this is badly broken and just kept here for reference -pw
;;; actually maybe it's not so broken -- check later
(define-vop (nlx-entry-multiple)
(:args (top)
(source)
(count :target ecx))
;; Again, no SC restrictions for the args, 'cause the loading would
;; happen before the entry label.
(:info label)
;;(:temporary (:sc dword-reg :offset esi-offset) esi)
(:temporary (:sc dword-reg :offset ecx-offset :from (:argument 2)) ecx)
(:temporary (:sc dword-reg :offset esi-offset) esi)
(:temporary (:sc dword-reg :offset edi-offset) edi)
(:results (result :scs (any-reg) :from (:argument 0))
(num :scs (any-reg immediate-stack)))
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
#+x86-lra
(progn
(align lowtag-bits #x90)
(inst lra-header-word)
(inst nop)
(inst nop)
(inst nop))
(emit-label label)
(note-this-location vop :non-local-entry)
;; Set up the result values and copy the arguments.
(move result top)
;; -- jrd. see comments above. need to do extra moves by hand, to
;; get the ea's into registers
;; (inst lea esi (make-ea :dword :base source :disp (- word-bytes)))
(inst lea edi (make-ea :dword :base result :disp (- word-bytes)))
(inst mov esi source)
(inst lea esi (make-ea :dword :base esi :disp (- word-bytes)))
(inst mov edi result)
(inst lea edi (make-ea :dword :base edi :disp (- word-bytes)))
(move ecx count) ; fixnum words == bytes
(move num ecx)
(inst shr ecx word-shift) ; word count for <rep movs>
;; If we got zero, we be done.
(inst jecxz done)
;; Copy them down.
(inst std)
(inst rep)
(inst movs :dword)
;; Reset the CSP.
DONE
(inst lea esp-tn (make-ea :dword :base edi :disp word-bytes))))
(define-vop (nlx-entry-multiple)
(:args (top)
(source)
......@@ -360,26 +238,14 @@
(emit-label label)
(note-this-location vop :non-local-entry)
;; The RISC implementations have ocfp-save wired to a register.
;; ir2tran calls (make-old-fp-save-location) to retrieve that tn
;; as the source address for the thrown results. Doing that here
;; provides the S0 slot as that source which is the wrong end of
;; the stack. Examination of the throw-catch-unwind process shows
;; that %ebx is the analog of OCFP here and at least in testing so
;; far does actually point (1 above) the values.
;; Actually, now it seems that 'unwind' is supposed to set up
;; edx and ocfp with certain values so that the compiler can
;; call these nlx entry points correctly. NOT.
(move esi source) ; ocfp
(inst lea esi (make-ea :dword :base esi :disp (- word-bytes)))
;; The 'top' arg contains the %esp value saved prior to creating
;; the catch block and dynamic save structures and points to where
;; the thrown values should sit.
(inst lea esi (make-ea :dword :base source :disp (- word-bytes)))
;; The 'top' arg contains the %esp value saved at the time the
;; catch block was created and and points to where the thrown
;; values should sit.
(move edi top)
(move result edi)
;; not too sure here -- yes! this seems to be correct
(inst lea edi (make-ea :dword :base edi :disp (- word-bytes)))
(inst sub edi word-bytes)
(move ecx count) ; fixnum words == bytes
(move num ecx)
(inst shr ecx word-shift) ; word count for <rep movs>
......@@ -390,16 +256,14 @@
(inst rep)
(inst movs :dword)
;; Reset the CSP (at last moved arg??)
DONE
;; Reset the CSP at last moved arg.
(inst lea esp-tn (make-ea :dword :base edi :disp word-bytes))))
;;; This VOP is just to force the TNs used in the cleanup onto the stack.
;;;
(define-vop (uwp-entry)
#+info-only
(:args (target)(block)(start)(count))
(:info label)
(:save-p :force-to-stack)
(:results (block) (start) (count))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment