From 9790e40852da8b5294b09a1431b0af4180b1c6a4 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Sun, 28 Oct 1990 05:59:54 +0000 Subject: [PATCH] Added support for multiple call conventions and chagned the output file extension to ``assem'' --- assembly/assemfile.lisp | 96 +++++++++++++++++++++++++++++++++-------- 1 file changed, 79 insertions(+), 17 deletions(-) diff --git a/assembly/assemfile.lisp b/assembly/assemfile.lisp index 2d6d33c30..fbf0f1863 100644 --- a/assembly/assemfile.lisp +++ b/assembly/assemfile.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/assemfile.lisp,v 1.19 1990/10/23 02:22:30 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/assemfile.lisp,v 1.20 1990/10/28 05:59:54 wlott Exp $ ;;; ;;; This file contains the extra code necessary to feed an entire file of ;;; assembly code to the assembler. @@ -27,7 +27,7 @@ (defun assemble-file (name &key (output-file (make-pathname :defaults name - :type "mips-fasl")) + :type "assem")) trace-file) (let* ((*do-assembly* t) (name (pathname name)) @@ -98,7 +98,7 @@ reg)) -(defun emit-assemble (name regs code) +(defun emit-assemble (name options regs code) (let* ((labels nil) (insts (mapcar #'(lambda (inst) (cond ((symbolp inst) @@ -106,7 +106,8 @@ `(emit-label ,inst)) (t inst))) - code))) + code)) + (return-style (or (cadr (assoc :return-style options)) :raw))) `(let ((,name (gen-label)) ,@(mapcar #'(lambda (label) `(,label (gen-label))) @@ -123,8 +124,19 @@ :offset ,(reg-spec-offset reg)))) regs)) ,@insts - (inst j lip-tn) - (inst nop))) + ,@(ecase vm:target-fasl-file-implementation + (#.vm:pmax-fasl-file-implementation + (ecase return-style + (:raw + `((inst j lip-tn) + (inst nop))) + (:full-call + `((lisp-return (make-random-tn :kind :normal + :sc (sc-or-lose + 'descriptor-reg) + :offset lra-offset) + lip-tn :offset 2))) + (:none)))))) (format *error-output* "~S assembled~%" ',name)))) (defun arg-or-res-spec (reg) @@ -139,7 +151,15 @@ (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq)) (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq)) (results (remove :res vars :key #'reg-spec-kind :test-not #'eq)) - (lip (make-symbol "LIP"))) + (return-style (or (cadr (assoc :return-style options)) :raw)) + (cost (or (cadr (assoc :cost options)) 247)) + (lip (make-symbol "LIP")) + (lra (make-symbol "LRA")) + (temp (make-symbol "TEMP")) + (vop (make-symbol "VOP")) + (nfp-save (make-symbol "NFP-SAVE"))) + (unless (member return-style '(:raw :full-call :none)) + (error "Unknown return-style for ~S: ~S" name return-style)) `(define-vop ,(if (atom name) (list name) name) (:args ,@(mapcar #'arg-or-res-spec args)) ,@(let ((index -1)) @@ -160,6 +180,15 @@ (:temporary (:scs (interior-reg) :type interior :from (:eval 0) :to (:eval 1)) ,lip) + ,@(when (eq return-style :full-call) + `((:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (non-descriptor-reg) + :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc control-stack :offset nfp-save-offset) ,nfp-save) + (:vop-var ,vop))) ,@(let ((index -1)) (mapcar #'(lambda (res) `(:temporary (:sc ,(reg-spec-sc res) @@ -171,22 +200,55 @@ results)) (:results ,@(mapcar #'arg-or-res-spec results)) (:ignore ,lip ,@(mapcar #'reg-spec-name temps)) - ,@options - (:generator 247 + ,@(remove-if #'(lambda (x) + (member x '(:return-style :cost))) + options + :key #'car) + (:generator ,cost ,@(mapcar #'(lambda (arg) `(move ,(reg-spec-temp arg) ,(reg-spec-name arg))) args) - (inst jal (make-fixup ',name :assembly-routine)) - (inst nop) - + ,@(ecase vm:target-fasl-file-implementation + (#.vm:pmax-fasl-file-implementation + (ecase return-style + (:raw + `((inst jal (make-fixup ',name :assembly-routine)) + (inst nop))) + (:full-call + (when (> (length results) 1) + (error "Can't use :full-call in an assembly-routine for ~ + more than one return value.")) + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (inst j (make-fixup ',name :assembly-routine)) + (inst nop) + (emit-return-pc lra-label) + (note-this-location ,vop :unknown-return) + (move csp-tn old-fp-tn) + (inst nop) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save))))) + (:none + `((inst j (make-fixup ',name :assembly-routine)) + (inst nop)))))) ,@(mapcar #'(lambda (res) `(move ,(reg-spec-name res) ,(reg-spec-temp res))) results))))) -(defmacro define-assembly-routine ((name options &rest vars) &rest code) - (let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars))) - (if *do-assembly* - (emit-assemble (if (atom name) name (car name)) regs code) - (emit-vop name options regs)))) +(defmacro define-assembly-routine (name&options vars &rest code) + (multiple-value-bind (name options) + (if (atom name&options) + (values name&options nil) + (values (car name&options) + (cdr name&options))) + (let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars))) + (if *do-assembly* + (emit-assemble name options regs code) + (emit-vop name options regs))))) -- GitLab