From 2b2cc7c1c16ee846a8244427f045521c57ae9029 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Mon, 5 Mar 1990 21:07:54 +0000 Subject: [PATCH] Filled in the generators. --- compiler/mips/nlx.lisp | 154 ++++++++++++++++------------------------- 1 file changed, 58 insertions(+), 96 deletions(-) diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp index 45f83087f..f90a6da24 100644 --- a/compiler/mips/nlx.lisp +++ b/compiler/mips/nlx.lisp @@ -7,14 +7,14 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.2 1990/02/27 00:12:10 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.3 1990/03/05 21:07:54 wlott Exp $ ;;; ;;; This file contains the definitions of VOPs used for non-local exit ;;; (throw, lexical exit, etc.) ;;; ;;; Written by Rob MacLachlan ;;; -(in-package 'c) +(in-package "C") ;;; Save and restore dynamic environment. @@ -82,83 +82,6 @@ (:generator 1 (move res csp-tn))) - -;;;; Unwind miscop VOPs: - -(define-vop (unwind) - (:translate %continue-unwind) - (:args (block-arg :target block) - (start :target args) - (count :target nargs)) - (:temporary (:sc any-reg :offset (first register-arg-offsets) - :from (:argument 0)) block) - (:temporary (:sc any-reg :offset args-offset :from (:argument 1)) args) - (:temporary (:sc any-reg :offset nargs-offset :from (:argument 2)) nargs) - (:temporary (:scs (any-reg) :type fixnum) cur-uwp target-uwp next-uwp) - (:temporary (:scs (descriptor-reg)) return-pc) - (:temporary (:scs (interior-reg) :type interior) lip) - (:node-var node) - (:generator 0 - (let ((error (generate-error-code node di:invalid-unwind-error)) - (do-uwp (gen-label)) - (do-exit (gen-label))) - (move block block-arg) - (inst beq block zero-tn error) - - (move args start) - (move nargs count) - - (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) - (loadw target-uwp block vm:unwind-block-current-uwp-slot) - (inst bne cur-uwp target-uwp do-uwp) - (nop) - - (move cur-uwp block) - - (emit-label do-exit) - - (loadw cont-tn cur-uwp vm:unwind-block-current-cont-slot) - (loadw code-tn cur-uwp vm:unwind-block-current-code-slot) - (loadw return-pc cur-uwp vm:unwind-block-entry-pc-slot) - (lisp-return return-pc lip) - - (emit-label do-uwp) - - (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot) - (b do-exit) - (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)))) - - -(define-vop (throw) - (:args (target) - (start) - (count)) - (:temporary (:scs (any-reg) :type fixnum) - catch) - (:temporary (:scs (descriptor-reg)) - tag) - (:node-var node) - (:generator 0 - (let ((loop (gen-label)) - (exit (gen-label)) - (error (generate-error-code node di:unseen-throw-tag-error target))) - (load-symbol-value catch lisp::*current-catch-block*) - - (emit-label loop) - - (inst bne catch zero-tn error) - - (loadw tag catch vm:catch-block-tag-slot) - (inst beq tag target exit) - (nop) - (b loop) - (loadw catch catch vm:catch-block-previous-catch-slot) - - (emit-label exit) - - ;; ### Need to call unwind somehow. - - ))) @@ -168,8 +91,8 @@ ;;; block the current Cont, Env, Unwind-Protect, and the entry PC. ;;; (define-vop (make-unwind-block) - (:args (tn) - (entry-offset :scs (any-reg descriptor-reg))) + (:args (tn)) + (:info entry-label) (:results (block :scs (descriptor-reg))) (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :target block) result) @@ -179,7 +102,8 @@ (storew temp result vm:unwind-block-current-uwp-slot) (storew cont-tn result vm:unwind-block-current-cont-slot) (storew code-tn result vm:unwind-block-current-code-slot) - (storew entry-offset result vm:unwind-block-entry-pc-slot) + (inst compute-lra-from-code temp code-tn entry-label) + (storew temp result vm:catch-block-entry-pc-slot) (move block result))) @@ -188,8 +112,8 @@ ;;; (define-vop (make-catch-block) (:args (tn) - (tag :scs (any-reg descriptor-reg)) - (entry-offset :scs (any-reg descriptor-reg))) + (tag :scs (any-reg descriptor-reg))) + (:info entry-label) (:results (block :scs (descriptor-reg))) (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :target block) result) @@ -199,10 +123,11 @@ (storew temp result vm:catch-block-current-uwp-slot) (storew cont-tn result vm:catch-block-current-cont-slot) (storew code-tn result vm:catch-block-current-code-slot) - (storew entry-offset result vm:catch-block-entry-pc-slot) + (inst compute-lra-from-code temp code-tn entry-label) + (storew temp result vm:catch-block-entry-pc-slot) (storew tag result vm:catch-block-tag-slot) - (load-symbol-value temp lisp::*current-catch-block-slot*) + (load-symbol-value temp lisp::*current-catch-block*) (storew temp result vm:catch-block-previous-catch-slot) (store-symbol-value result lisp::*current-catch-block*) @@ -240,30 +165,67 @@ ;;;; NLX entry VOPs: -;;; -;;; We can't just make these miscop variants, since they take funny wired -;;; operands. -;;; + (define-vop (nlx-entry) - (:args (top :scs (descriptor-reg)) + (:args (sp :scs (descriptor-reg)) (start) (count)) (:results (values :more t)) + (:temporary (:scs (descriptor-reg)) move-temp) (:info nvals) (:save-p :force-to-stack) - #+nil + (:node-var node) (:generator 30 - (unless (location= a0 top) - (inst lr a0 top)) - (inst miscopx 'clc::nlx-entry-default-values) - (inst cal a1 zero-tn nvals))) + (cond ((zerop nvals)) + ((= nvals 1) + (let ((no-values (gen-label))) + (inst beq count zero-tn no-values) + (move (tn-ref-tn values) null-tn) + (loadw (tn-ref-tn values) start) + (emit-label no-values))) + (t + (collect ((defaults)) + (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 beq count zero-tn default-lab) + (inst addiu count count (fixnum -1)) + (sc-case tn + ((descriptor-reg any-reg) + (loadw tn start i)) + (control-stack + (loadw move-temp start i) + (store-stack-tn tn move-temp))))) + + (let ((defaulting-done (gen-label))) + + (emit-label defaulting-done) + + (unassemble + (assemble-elsewhere node + (dolist (def (defaults)) + (emit-label (car def)) + (let ((tn (cdr def))) + (sc-case tn + ((descriptor-reg any-reg) + (move tn null-tn)) + (control-stack + (store-stack-tn tn null-tn))))) + (b defaulting-done) + (nop))))))) + (move csp-tn sp))) (define-vop (nlx-entry-multiple) (:args (top :scs (descriptor-reg)) (start) (count)) + (:results (new-start) (new-count)) (:save-p :force-to-stack) #+nil (:generator 30 -- GitLab