diff --git a/assembly/hppa/alloc.lisp b/assembly/hppa/alloc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b4dc39007dc0aeb8088fcc44d8b2d9906c09d9dc --- /dev/null +++ b/assembly/hppa/alloc.lisp @@ -0,0 +1,24 @@ +;;; -*- Package: HPPA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/alloc.lisp,v 1.1 1992/06/12 04:00:00 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Stuff to handle allocation of stuff we don't want to do inline. +;;; +;;; Written by William Lott. +;;; + +(in-package "HPPA") + +;;; Given that the pseudo-atomic sequence is so short, there is +;;; nothing that qualifies. But we want to keep the file around +;;; in case we decide to add something later. + diff --git a/assembly/hppa/arith.lisp b/assembly/hppa/arith.lisp new file mode 100644 index 0000000000000000000000000000000000000000..9a5eee42d02db166a1e2649749db6eef15d62be9 --- /dev/null +++ b/assembly/hppa/arith.lisp @@ -0,0 +1,252 @@ +;;; -*- Package: HPPA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/arith.lisp,v 1.1 1992/06/12 03:59:11 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Stuff to handle simple cases for generic arithmetic. +;;; +;;; Written by William Lott. +;;; + +(in-package "HPPA") + + +;;;; Multiplication and Division helping routines. + +#+assembler +(define-assembly-routine + multiply + ((:arg x (signed-reg) nl0-offset) + (:arg y (signed-reg) nl1-offset) + + (:res res (signed-reg) nl2-offset) + + (:temp tmp (unsigned-reg) nl3-offset) + (:temp sign (unsigned-reg) nl4-offset)) + + ;; Determine the sign of the result. + (inst extrs x 0 1 sign :=) + (inst sub zero-tn x x) + (inst extrs y 0 1 tmp :=) + (inst sub zero-tn y y) + (inst xor sign tmp sign) + + ;; Make sure X is less then Y. + (inst comclr x y tmp :<<) + (inst xor x y tmp) + (inst xor x tmp x) + (inst xor y tmp y) + ;; Blow out of here if the result is zero. + (inst comb := x zero-tn done) + (inst li 0 res) + + LOOP + (inst extru x 31 1 zero-tn :ev) + (inst add res y res) + (inst extru x 30 1 zero-tn :ev) + (inst sh1add res y res) + (inst extru x 29 1 zero-tn :ev) + (inst sh2add res y res) + (inst extru x 28 1 zero-tn :ev) + (inst sh3add res y res) + + (inst srl x 4 x) + (inst comb :<> x zero-tn loop) + (inst sll y 4 y) + + DONE + (inst xor res sign res) + (inst add res sign res)) + + +#+assembly +(define-assembly-routine + (truncate) + () + ...) + + + +;;;; Generic arithmetic. + +(define-assembly-routine (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst extru x 31 2 zero-tn :<>) + (inst b do-static-fun :nullify t) + (inst extru y 31 2 zero-tn :<>) + (inst b do-static-fun :nullify t) + (inst addo x y res) + (lisp-return lra :offset 2) + + DO-STATIC-FUN + (inst ldw (static-function-offset 'two-arg-+) null-tn lip) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn)) + +(define-assembly-routine (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst extru x 31 2 zero-tn :<>) + (inst b do-static-fun :nullify t) + (inst extru y 31 2 zero-tn :<>) + (inst b do-static-fun :nullify t) + (inst subo x y res) + (lisp-return lra :offset 2) + + DO-STATIC-FUN + (inst ldw (static-function-offset 'two-arg--) null-tn lip) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn)) + + + +;;;; Comparison routines. + +(macrolet + ((define-cond-assem-rtn (name translate static-fn cond) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst extru x 31 2 zero-tn :<>) + (inst b do-static-fn :nullify t) + (inst extru y 31 2 zero-tn :<>) + (inst b do-static-fn :nullify t) + + (inst comclr x y zero-tn ,cond) + (inst move null-tn res :tr) + (load-symbol res t) + (lisp-return lra :offset 2) + + DO-STATIC-FN + (inst ldw (static-function-offset ',static-fn) null-tn lip) + (inst li (fixnum 2) nargs) + (inst move ocfp cfp-tn) + (inst bv lip) + (inst move cfp-tn csp-tn)))) + + (define-cond-assem-rtn generic-< < two-arg-< :<) + (define-cond-assem-rtn generic-> > two-arg-> :>)) + + +(define-assembly-routine + (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + (inst comb := x y return-t) + (inst extru x 31 2 zero-tn :<>) + (inst b return-nil :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + + RETURN-NIL + (inst move null-tn res) + (lisp-return lra :offset 2) + + DO-STATIC-FN + (inst ldw (static-function-offset 'eql) null-tn lip) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine + (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + (inst comb := x y return-t :nullify t) + (inst extru x 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + + (inst move null-tn res) + (lisp-return lra :offset 2) + + DO-STATIC-FN + (inst ldw (static-function-offset 'two-arg-=) null-tn lip) + (inst li (fixnum 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn) + + RETURN-T + (load-symbol res t)) + diff --git a/assembly/hppa/array.lisp b/assembly/hppa/array.lisp new file mode 100644 index 0000000000000000000000000000000000000000..bf6699c0bca883abd64687d223bd58d2091b0924 --- /dev/null +++ b/assembly/hppa/array.lisp @@ -0,0 +1,111 @@ +;;; -*- Package: HPPA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/array.lisp,v 1.1 1992/06/12 03:58:40 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the support routines for arrays and vectors. +;;; +;;; Written by William Lott. +;;; +(in-package "HPPA") + +(define-assembly-routine + (allocate-vector + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp vector descriptor-reg a3-offset)) + (pseudo-atomic () + (move alloc-tn vector) + (inst dep other-pointer-type 31 3 vector) + (inst addi (* (1+ vector-data-offset) word-bytes) words ndescr) + (inst dep 0 31 3 ndescr) + (inst add ndescr alloc-tn alloc-tn) + (inst srl type word-shift ndescr) + (storew ndescr vector 0 other-pointer-type) + (storew length vector vector-length-slot other-pointer-type)) + (move vector result)) + + + +;;;; Hash primitives + +#+assembler +(defparameter *sxhash-simple-substring-entry* (gen-label)) + +(define-assembly-routine + (sxhash-simple-string + (:translate %sxhash-simple-string) + (:policy :fast-safe) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:res result any-reg a0-offset) + + (:temp length any-reg a1-offset) + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp offset non-descriptor-reg nl2-offset)) + + (declare (ignore result accum data offset)) + + ;; Save the return address. + (inst b *sxhash-simple-substring-entry*) + (loadw length string vector-length-slot other-pointer-type)) + +(define-assembly-routine + (sxhash-simple-substring + (:translate %sxhash-simple-substring) + (:policy :fast-safe) + (:arg-types * positive-fixnum) + (:result-types positive-fixnum)) + + ((:arg string descriptor-reg a0-offset) + (:arg length any-reg a1-offset) + (:res result any-reg a0-offset) + + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp offset non-descriptor-reg nl2-offset)) + + (emit-label *sxhash-simple-substring-entry*) + + (inst li (- (* vector-data-offset word-bytes) other-pointer-type) offset) + (inst b test) + (move zero-tn accum) + + LOOP + (inst xor accum data accum) + (inst shd accum accum 5 accum) + + TEST + (inst addib :< (fixnum -4) length loop) + (inst ldwx string offset data :modify t) + + (inst addi (fixnum 4) length length) + (inst comb := length zero-tn done :nullify t) + (inst uaddcm zero-tn length length) + (inst sll length 1 length) + (inst mtctl length :sar) + (inst shd zero-tn data :variable data) + (inst xor accum data accum) + + DONE + + (inst sll accum 5 result) + (inst srl result 3 result)) diff --git a/assembly/hppa/assem-rtns.lisp b/assembly/hppa/assem-rtns.lisp new file mode 100644 index 0000000000000000000000000000000000000000..86a519fdf0b974adb163f29ea79314d0e1976b3a --- /dev/null +++ b/assembly/hppa/assem-rtns.lisp @@ -0,0 +1,218 @@ +;;; -*- Package: HPPA -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/hppa/assem-rtns.lisp,v 1.1 1992/06/12 03:58:24 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains a handful of random assembly routines. +;;; +;;; Written by William Lott. +;;; +(in-package "HPPA") + + +;;;; Return-multiple with other than one value + +#+assembler ;; we don't want a vop for this one. +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These four are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl0-offset) + (:temp old-fp any-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp count any-reg nl2-offset) + (:temp src any-reg nl3-offset) + (:temp dst any-reg nl4-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + (inst movb := nvals count default-a0-and-on :nullify t) + (loadw a0 vals 0) + (inst addib := (fixnum -1) count default-a1-and-on :nullify t) + (loadw a1 vals 1) + (inst addib := (fixnum -1) count default-a2-and-on :nullify t) + (loadw a2 vals 2) + (inst addib := (fixnum -1) count default-a3-and-on :nullify t) + (loadw a3 vals 3) + (inst addib := (fixnum -1) count default-a4-and-on :nullify t) + (loadw a4 vals 4) + (inst addib := (fixnum -1) count default-a5-and-on :nullify t) + (loadw a5 vals 5) + + ;; Copy the remaining args to the top of the stack. + (inst addi (* 6 word-bytes) src vals) + (inst addi (* 6 word-bytes) dst cfp-tn) + + LOOP + (inst ldwm 4 src temp) + (inst addib :< (fixnum -1) count loop) + (inst stwm temp 4 dst) + + (inst b done :nullify t) + + DEFAULT-A0-AND-ON + (inst move a0 null-tn) + DEFAULT-A1-AND-ON + (inst move a1 null-tn) + DEFAULT-A2-AND-ON + (inst move a2 null-tn) + DEFAULT-A3-AND-ON + (inst move a3 null-tn) + DEFAULT-A4-AND-ON + (inst move a4 null-tn) + DEFAULT-A5-AND-ON + (inst move a5 null-tn) + + DONE + ;; Clear the stack. + (move ocfp-tn cfp-tn) + (move cfp-tn old-fp) + (inst add ocfp-tn nvals csp-tn) + + ;; Return. + (lisp-return lra)) + + + +;;;; tail-call-variable. + +#+assembler ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg nl3-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst sub csp-tn args nargs) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (loadw a0 args 0) + (loadw a1 args 1) + (loadw a2 args 2) + (loadw a3 args 3) + (loadw a4 args 4) + (loadw a5 args 5) + + ;; Calc SRC, DST, and COUNT + (inst addi (fixnum (- register-arg-count)) nargs count) + (inst comb :<= count zero-tn done :nullify t) + (inst addi (* word-bytes register-arg-count) args src) + (inst addi (* word-bytes register-arg-count) dst cfp-tn) + + LOOP + ;; Copy one arg. + (inst ldwm 4 src temp) + (inst addib :< (fixnum -1) count loop) + (inst stwm temp 4 dst) + + DONE + ;; We are done. Do the jump. + (loadw temp lexenv closure-function-slot function-pointer-type) + (lisp-jump temp)) + + + +;;;; Non-local exit noise. + +#+assembler +(defparameter *unwind-entry-point* (gen-label)) + +(define-assembly-routine + (unwind + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lra descriptor-reg lra-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) + (declare (ignore start count)) + + (emit-label *unwind-entry-point*) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst bc := nil block zero-tn error)) + + (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*) + (loadw target-uwp block unwind-block-current-uwp-slot) + (inst bc :<> nil cur-uwp target-uwp do-uwp) + + (move block cur-uwp) + + DO-EXIT + + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) + (loadw code-tn cur-uwp unwind-block-current-code-slot) + (loadw lra cur-uwp unwind-block-entry-pc-slot) + (lisp-return lra :frob-code nil) + + DO-UWP + + (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) + (inst b do-exit) + (store-symbol-value next-uwp lisp::*current-unwind-protect-block*)) + + +(define-assembly-routine + throw + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset)) + (declare (ignore start count)) ; We just need them in the registers. + + (load-symbol-value catch lisp::*current-catch-block*) + + LOOP + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst bc := nil catch zero-tn error)) + (loadw tag catch catch-block-tag-slot) + (inst comb :<> tag target loop :nullify t) + (loadw catch catch catch-block-previous-catch-slot) + + (inst b *unwind-entry-point*) + (inst move catch target))