diff --git a/compiler/mips/sap.lisp b/compiler/mips/sap.lisp new file mode 100644 index 0000000000000000000000000000000000000000..8a331a699aecacb8d015566af7b1159d68c83a95 --- /dev/null +++ b/compiler/mips/sap.lisp @@ -0,0 +1,277 @@ +;;; -*- Package: C; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/sap.lisp,v 1.1 1990/03/12 23:48:56 wlott Exp $ +;;; +;;; This file contains the MIPS VM definition of SAP operations. +;;; +;;; Written by William Lott. +;;; +(in-package "C") + + + +;;;; The SAP-MOVE vop. + +(define-vop (sap-move) + (:args (x :target y :scs (sap-reg) :load nil)) + (:results (y :scs (sap-reg) :load nil)) + (:temporary (:scs (sap-reg) :type system-area-pointer + :from :argument :to :result) sap) + (:temporary (:scs (descriptor-reg) :from :argument :to :result) temp) + (:temporary (:scs (non-descriptor-reg) :type random) ndescr) + (:effects) + (:affected) + (:generator 0 + (sc-case x ((sap-reg sap-stack immediate-sap descriptor-reg control-stack))) + (sc-case y ((sap-reg sap-stack descriptor-reg control-stack))) + + (let* ((x-sap-p (sc-is x sap-reg sap-stack immediate-sap)) + (y-sap-p (sc-is y sap-reg sap-stack)) + (src (cond ((sc-is x sap-reg descriptor-reg) x) + (x-sap-p sap) + (t temp))) + (dst (cond ((sc-is y sap-reg descriptor-reg) y) + (y-sap-p sap) + (t temp)))) + + (sc-case x + ((control-stack sap-stack) + (load-stack-tn src x)) + ((descriptor-reg sap-reg)) + (immediate-sap + (loadi src (tn-value x)))) + (cond ((and x-sap-p (not y-sap-p)) + (pseudo-atomic (ndescr) + (inst addiu dst alloc-tn vm:other-pointer-type) + (inst addiu alloc-tn alloc-tn (pad-data-block vm:sap-size)) + (loadi ndescr (logior (ash vm:sap-size vm:type-bits) + vm:sap-type)) + (storew ndescr dst 0 vm:other-pointer-type) + (storew src dst vm:sap-pointer-slot vm:other-pointer-type))) + ((and y-sap-p (not x-sap-p)) + (loadw sap src vm:sap-pointer-slot vm:other-pointer-type)) + (t + (move dst src))) + (sc-case y + ((control-stack sap-stack) + (store-stack-tn y dst)) + ((sap-reg descriptor-reg)))))) + +(primitive-type-vop sap-move + (:coerce-to-t :coerce-from-t :move) + system-area-pointer) + + + +;;;; SAP-INT and INT-SAP + +(define-vop (sap-int) + (:args (sap :scs (sap-reg) :target int)) + (:results (int :scs (any-reg descriptor-reg))) + (:arg-types system-area-pointer) + (:translate char-code) + (:policy :fast-safe) + (:generator 0 + ;; ### Need to check for fixnum overflow. + (inst sll int sap 2))) + +(define-vop (int-sap) + (:args (int :scs (any-reg descriptor-reg) :target sap)) + (:results (sap :scs (sap-reg))) + (:translate code-char) + (:policy :fast-safe) + (:generator 0 + ;; ### Need to check to see if it is a bignum. + (inst srl sap int 2))) + + + +;;;; POINTER+ and POINTER- + +(define-vop (pointer+) + (:translate sap+) + (:args (ptr :scs (sap-reg)) + (offset :scs (any-reg descriptor-reg))) + (:arg-types system-area-pointer fixnum) + (:results (res :scs (sap-reg))) + (:policy :fast-safe) + (:generator 1 + (inst addu res ptr offset))) + +(define-vop (pointer-) + (:args (ptr1 :scs (sap-reg)) + (ptr2 :scs (sap-reg))) + (:arg-types system-area-pointer system-area-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (inst subu res ptr1 ptr2))) + + + +;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET + +(define-vop (sap-ref) + (:variant-vars size signed) + (:args (object :scs (sap-reg) :target sap) + (offset :scs (descriptor-reg any-reg))) + (:arg-types system-area-pointer fixnum) + (:results (result :scs (descriptor-reg any-reg))) + (:temporary (:scs (sap-reg) :type system-area-pointer :from (:argument 0)) + sap) + (:temporary (:scs (non-descriptor-reg) :type random + :to (:result 0) :target result) + temp) + (:generator 5 + (move sap object) + (ecase size + (:byte + (inst sra temp offset 2) + (inst addu sap sap temp) + (if signed + (inst lb temp sap 0) + (inst lbu temp sap 0)) + (inst sll result temp 2)) + (:short + (inst sra temp offset 1) + (inst addu sap sap temp) + (if signed + (inst lh temp sap 0) + (inst lhu temp sap 0)) + (inst sll result temp 2)) + (:long + (inst addu sap sap offset) + (inst lw temp sap 0) + ;; ### Need to assure that it doesn't overflow + (inst sll result temp 2)) + (:pointer + (inst addu sap sap offset) + (inst lw temp sap 0) + (sc-case result + (sap-reg + (move result temp))))))) + + +(define-vop (sap-set) + (:variant-vars size) + (:args (object :scs (sap-reg) :target sap) + (offset :scs (descriptor-reg any-reg)) + (value :scs (descriptor-reg sap-reg any-reg) :target temp)) + (:temporary (:scs (sap-reg) :type system-area-pointer :from (:argument 0)) + sap) + (:temporary (:scs (non-descriptor-reg) :type random :from (:result 3)) temp) + (:generator 5 + (move sap object) + (ecase size + (:byte + (inst sra temp offset 2) + (inst addu sap sap temp)) + (:short + (inst sra temp offset 1) + (inst addu sap sap temp)) + ((:long :pointer) + (inst addu sap sap offset))) + (ecase size + ((:byte :short) + (inst sra temp value 2)) + (:long + ;; ### Need to see if it's a fixnum or bignum + (inst sra temp value 2)) + (:pointer + (sc-case value + (sap-reg + (move temp value)) + (descriptor-reg + (loadw temp value vm:sap-pointer-slot vm:other-pointer-type))))) + (ecase size + (:byte + (inst sb temp sap 0)) + (:short + (inst sh temp sap 0)) + ((:long :pointer) + (inst sw temp sap 0))))) + + + +(define-vop (sap-system-ref sap-ref) + (:translate sap-ref-sap) + (:results (result :scs (sap-reg))) + (:variant :pointer nil)) + +(define-vop (sap-system-set sap-set) + (:translate (setf sap-ref-sap)) + (:arg-types system-area-pointer fixnum system-area-pointer) + (:variant :pointer)) + + + +(define-vop (32bit-system-ref sap-ref) + (:translate sap-ref-32) + (:variant :long nil)) + +(define-vop (signed-32bit-system-ref sap-ref) + (:translate signed-sap-ref-32) + (:variant :long t)) + +(define-vop (32bit-system-set sap-set) + (:translate (setf sap-ref-32)) + (:arg-types system-area-pointer fixnum t) + (:variant :long)) + + +(define-vop (16bit-system-ref sap-ref) + (:translate sap-ref-16) + (:variant :short nil)) + +(define-vop (signed-16bit-system-ref sap-ref) + (:translate signed-sap-ref-16) + (:variant :short t)) + +(define-vop (16bit-system-set sap-set) + (:translate (setf sap-ref-16)) + (:arg-types system-area-pointer fixnum fixnum) + (:variant :short)) + + +(define-vop (8bit-system-ref sap-ref) + (:translate sap-ref-8) + (:variant :byte nil)) + +(define-vop (signed-8bit-system-ref sap-ref) + (:translate signed-sap-ref-8) + (:variant :byte t)) + +(define-vop (8bit-system-set sap-set) + (:translate (setf sap-ref-8)) + (:arg-types system-area-pointer fixnum fixnum) + (:variant :byte)) + + + +;;;; ### Noise to allow old forms to continue to work until they are gone. + +(macrolet ((frob (prim func) + `(def-primitive-translator ,prim (&rest args) + (warn "Someone used %primitive ~S -- should be ~S." + ',prim ',func) + `(,',func ,@args)))) + (frob 32bit-system-ref sap-ref-32) + (frob unsigned-32bit-system-ref sap-ref-32) + (frob 16bit-system-ref sap-ref-16) + (frob 8bit-system-ref sap-ref-8)) + +(macrolet ((frob (prim func) + `(def-primitive-translator ,prim (&rest args) + (warn "Someone used %primitive ~S -- should be ~S." + ',prim (list 'setf ',func)) + `(setf ,',func ,@args)))) + (frob 32bit-system-set sap-ref-32) + (frob signed-32bit-system-set sap-ref-32) + (frob 16bit-system-set sap-ref-16) + (frob 8bit-system-set sap-ref-8))