Skip to content
Snippets Groups Projects
Commit 0f7afc92 authored by wlott's avatar wlott
Browse files

Initial revision

parent a74f76bf
No related branches found
No related tags found
No related merge requests found
Showing
with 8711 additions and 0 deletions
;;; -*- 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/support.lisp,v 1.1 1992/07/13 03:49:21 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the machine specific support routines needed by
;;; the file assembler.
;;;
;;; Written by William Lott.
;;;
(in-package "HPPA")
(def-vm-support-routine generate-call-sequence (name style vop)
(ecase style
(:raw
(let ((fixup (gensym "FIXUP-")))
(values
`((let ((fixup (make-fixup ',name :assembly-routine)))
(inst ldil fixup ,fixup)
(inst ble fixup lisp-heap-space ,fixup :nullify t))
(inst nop))
`((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
,fixup)))))
(:full-call
(let ((temp (make-symbol "TEMP"))
(nfp-save (make-symbol "NFP-SAVE"))
(lra (make-symbol "LRA")))
(values
`((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 code-tn lra-label ,temp ,lra)
(note-this-location ,vop :call-site)
(let ((fixup (make-fixup ',name :assembly-routine)))
(inst ldil fixup ,temp)
(inst be fixup lisp-heap-space ,temp :nullify t))
(emit-return-pc lra-label)
(note-this-location ,vop :single-value-return)
(move ocfp-tn csp-tn)
(inst compute-code-from-lra code-tn lra-label ,temp code-tn)
(when cur-nfp
(load-stack-tn cur-nfp ,nfp-save))))
`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
,temp)
(:temporary (:sc descriptor-reg :offset lra-offset
:from (:eval 0) :to (:eval 1))
,lra)
(:temporary (:scs (control-stack) :offset nfp-save-offset)
,nfp-save)
(:save-p :compute-only)))))
(:none
(let ((fixup (gensym "FIXUP-")))
(values
`((let ((fixup (make-fixup ',name :assembly-routine)))
(inst ldil fixup ,fixup)
(inst be fixup lisp-heap-space ,fixup :nullify t)))
`((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1))
,fixup)))))))
(def-vm-support-routine generate-return-sequence (style)
(ecase style
(:raw
`((inst bv lip-tn :nullify t)))
(:full-call
`((lisp-return (make-random-tn :kind :normal
:sc (sc-or-lose 'descriptor-reg)
:offset lra-offset)
:offset 1)))
(:none)))
This diff is collapsed.
;;; -*- 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/compiler/hppa/alloc.lisp,v 1.1 1992/07/13 03:48:14 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; Allocation VOPs for the HPPA port.
;;;
;;; Written by William Lott.
;;;
(in-package "HPPA")
;;;; LIST and LIST*
(define-vop (list-or-list*)
(:args (things :more t))
(:temporary (:scs (descriptor-reg) :type list) ptr)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
res)
(:info num)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:policy :safe)
(:generator 0
(cond
((zerop num)
(move null-tn result))
((and star (= num 1))
(move (tn-ref-tn things) result))
(t
(macrolet
((maybe-load (tn)
(once-only ((tn tn))
`(sc-case ,tn
((any-reg descriptor-reg zero null)
,tn)
(control-stack
(load-stack-tn temp ,tn)
temp)))))
(let* ((cons-cells (if star (1- num) num))
(alloc (* (pad-data-block cons-size) cons-cells)))
(pseudo-atomic (:extra alloc)
(move alloc-tn res)
(inst dep list-pointer-type 31 3 res)
(move res ptr)
(dotimes (i (1- cons-cells))
(storew (maybe-load (tn-ref-tn things)) ptr
cons-car-slot list-pointer-type)
(setf things (tn-ref-across things))
(inst addi (pad-data-block cons-size) ptr ptr)
(storew ptr ptr
(- cons-cdr-slot cons-size)
list-pointer-type))
(storew (maybe-load (tn-ref-tn things)) ptr
cons-car-slot list-pointer-type)
(storew (if star
(maybe-load (tn-ref-tn (tn-ref-across things)))
null-tn)
ptr cons-cdr-slot list-pointer-type))
(move res result)))))))
(define-vop (list list-or-list*)
(:variant nil))
(define-vop (list* list-or-list*)
(:variant t))
;;;; Special purpose inline allocators.
(define-vop (allocate-code-object)
(:args (boxed-arg :scs (any-reg))
(unboxed-arg :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (any-reg) :from (:argument 0)) boxed)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
(:generator 100
(inst addi (fixnum (1+ code-trace-table-offset-slot)) boxed-arg boxed)
(inst dep 0 31 3 boxed)
(inst srl unboxed-arg word-shift unboxed)
(inst addi lowtag-mask unboxed unboxed)
(inst dep 0 31 3 unboxed)
(pseudo-atomic ()
;; Note: we don't have to subtract off the 4 that was added by
;; pseudo-atomic, because depositing other-pointer-type just adds
;; it right back.
(inst move alloc-tn result)
(inst dep other-pointer-type 31 3 result)
(inst add alloc-tn boxed alloc-tn)
(inst add alloc-tn unboxed alloc-tn)
(inst sll boxed (- type-bits word-shift) ndescr)
(inst addi code-header-type ndescr ndescr)
(storew ndescr result 0 other-pointer-type)
(storew unboxed result code-code-size-slot other-pointer-type)
(storew null-tn result code-entry-points-slot other-pointer-type)
(storew null-tn result code-debug-info-slot other-pointer-type))))
(define-vop (make-fdefn)
(:args (name :scs (descriptor-reg) :to :eval))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (result :scs (descriptor-reg) :from :argument))
(:policy :fast-safe)
(:translate make-fdefn)
(:generator 37
(with-fixed-allocation (result temp fdefn-type fdefn-size)
(inst li (make-fixup "undefined_tramp" :foreign) temp)
(storew name result fdefn-name-slot other-pointer-type)
(storew null-tn result fdefn-function-slot other-pointer-type)
(storew temp result fdefn-raw-addr-slot other-pointer-type))))
;;;; Automatic allocators for primitive objects.
(define-for-each-primitive-object (obj)
(collect ((forms))
(let* ((options (primitive-object-options obj))
(alloc-trans (getf options :alloc-trans))
(alloc-vop (getf options :alloc-vop alloc-trans))
(header (primitive-object-header obj))
(lowtag (primitive-object-lowtag obj))
(size (primitive-object-size obj))
(variable-length (primitive-object-variable-length obj))
(need-unbound-marker nil))
(collect ((args) (init-forms))
(when (and alloc-vop variable-length)
(args 'extra-words))
(dolist (slot (primitive-object-slots obj))
(let* ((name (slot-name slot))
(offset (slot-offset slot)))
(ecase (getf (slot-options slot) :init :zero)
(:zero)
(:null
(init-forms `(storew null-tn result ,offset ,lowtag)))
(:unbound
(setf need-unbound-marker t)
(init-forms `(storew temp result ,offset ,lowtag)))
(:arg
(args name)
(init-forms `(storew ,name result ,offset ,lowtag))))))
(when (and (null alloc-vop) (args))
(error "Slots ~S want to be initialized, but there is no alloc vop ~
defined for ~S."
(args) (primitive-object-name obj)))
(when alloc-vop
(forms
`(define-vop (,alloc-vop)
(:args ,@(mapcar #'(lambda (name)
`(,name :scs (any-reg descriptor-reg)))
(args)))
,@(when (or need-unbound-marker header variable-length)
`((:temporary (:scs (non-descriptor-reg)) temp)))
(:results (result :scs (descriptor-reg) :from :load))
(:policy :fast-safe)
,@(when alloc-trans
`((:translate ,alloc-trans)))
(:generator 37
(pseudo-atomic (,@(unless variable-length
`(:extra (pad-data-block ,size))))
(move alloc-tn result)
(inst dep ,lowtag 31 3 result)
,@(cond
((and header variable-length)
`((inst addi (* (1+ ,size) word-bytes) extra-words temp)
(inst dep 0 31 3 temp)
(inst add temp alloc-tn alloc-tn)
(inst sll extra-words (- type-bits word-shift) temp)
(inst addi (+ (ash (1- ,size) type-bits) ,header)
temp temp)
(storew temp result 0 ,lowtag)))
(variable-length
(error ":REST-P T with no header in ~S?"
(primitive-object-name obj)))
(header
`((inst li ,(logior (ash (1- size) type-bits)
(symbol-value header))
temp)
(storew temp result 0 ,lowtag)))
(t
nil))
,@(when need-unbound-marker
`((inst li unbound-marker-type temp)))
,@(init-forms))))))))
(when (forms)
`(progn
,@(forms)))))
This diff is collapsed.
;;; -*- 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/compiler/hppa/array.lisp,v 1.1 1992/07/13 03:48:16 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the SPARC definitions for array operations.
;;;
;;; Written by William Lott
;;;
(in-package "HPPA")
;;;; Allocator for the array header.
(define-vop (make-array-header)
(:translate make-array-header)
(:policy :fast-safe)
(:args (type :scs (any-reg))
(rank :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
(:temporary (:scs (non-descriptor-reg) :type random) ndescr)
(:results (result :scs (descriptor-reg)))
(:generator 0
(pseudo-atomic ()
(inst move alloc-tn header)
(inst dep other-pointer-type 31 3 header)
(inst addi (* (1+ array-dimensions-offset) word-bytes) ndescr rank)
(inst dep 0 31 3 ndescr)
(inst add alloc-tn ndescr alloc-tn)
(inst addi (fixnum (1- array-dimensions-offset)) rank ndescr)
(inst sll ndescr type-bits ndescr)
(inst or ndescr type ndescr)
(inst srl ndescr 2 ndescr)
(storew ndescr header 0 vm:other-pointer-type))
(move header result)))
;;;; Additional accessors and setters for the array header.
(defknown lisp::%array-dimension (t index) index
(flushable))
(defknown lisp::%set-array-dimension (t index index) index
())
(define-full-reffer %array-dimension *
array-dimensions-offset other-pointer-type
(any-reg) positive-fixnum lisp::%array-dimension)
(define-full-setter %set-array-dimension *
array-dimensions-offset other-pointer-type
(any-reg) positive-fixnum lisp::%set-array-dimension)
(defknown lisp::%array-rank (t) index (flushable))
(define-vop (array-rank-vop)
(:translate lisp::%array-rank)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
(loadw res x 0 vm:other-pointer-type)
(inst srl res type-bits res)
(inst addi (- (1- vm:array-dimensions-offset)) res res)))
;;;; Bounds checking routine.
(define-vop (check-bound)
(:translate %check-bound)
(:policy :fast-safe)
(:args (array :scs (descriptor-reg))
(bound :scs (any-reg descriptor-reg))
(index :scs (any-reg descriptor-reg) :target result))
(:results (result :scs (any-reg descriptor-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(let ((error (generate-error-code vop invalid-array-index-error
array bound index)))
(inst bc :>= nil index bound error))
(move index result)))
;;;; Accessors/Setters
;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
;;; elements are represented in integer registers and are built out of
;;; 8, 16, or 32 bit elements.
(eval-when (compile eval)
(defmacro def-full-data-vector-frobs (type element-type &rest scs)
`(progn
(define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
vector-data-offset other-pointer-type ,scs ,element-type
data-vector-ref)
(define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
vector-data-offset other-pointer-type ,scs ,element-type
data-vector-set)))
(defmacro def-partial-data-vector-frobs
(type element-type size signed &rest scs)
`(progn
(define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
,size ,signed vector-data-offset other-pointer-type ,scs
,element-type data-vector-ref)
(define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
,size vector-data-offset other-pointer-type ,scs
,element-type data-vector-set)))
); eval-when (compile eval)
(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
(def-partial-data-vector-frobs simple-string base-char :byte :leave-alone
base-char-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
:byte nil unsigned-reg signed-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
:short nil unsigned-reg signed-reg)
(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
unsigned-reg)
;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
;;; and 4-bit vectors.
;;;
(eval-when (compile eval)
(defmacro def-small-data-vector-frobs (type bits)
(let* ((elements-per-word (floor vm:word-bits bits))
(bit-shift (1- (integer-length elements-per-word))))
`(progn
(define-vop (,(symbolicate 'data-vector-ref/ type))
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (unsigned-reg)))
(:arg-types ,type positive-fixnum)
(:results (result :scs (unsigned-reg) :from (:argument 0)))
(:result-types positive-fixnum)
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:scs (interior-reg)) lip)
(:generator 20
(inst srl index ,bit-shift temp)
(inst sh2add temp object lip)
(loadw result lip vector-data-offset other-pointer-type)
(inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
,@(unless (= bits 1)
`((inst addi ,(1- bits) temp temp)))
(inst mtctl temp :sar)
(inst extru result :variable ,bits result)))
(define-vop (,(symbolicate 'data-vector-ref-c/ type))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:arg-types ,type (:constant index))
(:info index)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 15
(multiple-value-bind (word extra) (floor index ,elements-per-word)
(let ((offset (- (* (+ word vm:vector-data-offset) vm:word-bytes)
vm:other-pointer-type)))
(cond ((typep offset '(signed-byte 14))
(inst ldw offset object result))
(t
(inst ldil (ldb (byte 21 11) offset) temp)
(inst ldw (ldb (byte 11 0) offset) temp result))))
(inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result))))
(define-vop (,(symbolicate 'data-vector-set/ type))
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (unsigned-reg))
(value :scs (unsigned-reg zero immediate) :target result))
(:arg-types ,type positive-fixnum positive-fixnum)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:temporary (:scs (non-descriptor-reg)) temp old)
(:temporary (:scs (interior-reg)) lip)
(:generator 25
(inst srl index ,bit-shift temp)
(inst sh2add temp object lip)
(loadw old lip vector-data-offset other-pointer-type)
(inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
,@(unless (= bits 1)
`((inst addi ,(1- bits) temp temp)))
(inst mtctl temp :sar)
(inst dep (sc-case value (immediate (tn-value value)) (t value))
:variable ,bits old)
(storew old lip vector-data-offset other-pointer-type)
(sc-case value
(immediate
(inst li (tn-value value) result))
(t
(move value result)))))
(define-vop (,(symbolicate 'data-vector-set-c/ type))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(value :scs (unsigned-reg zero immediate) :target result))
(:arg-types ,type
(:constant index)
positive-fixnum)
(:info index)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:temporary (:scs (non-descriptor-reg)) old)
(:temporary (:scs (interior-reg)) lip)
(:generator 20
(multiple-value-bind (word extra) (floor index ,elements-per-word)
(let ((offset (- (* (+ word vector-data-offset) word-bytes)
other-pointer-type)))
(cond ((typep offset '(signed-byte 14))
(inst ldw offset object old))
(t
(inst move object lip)
(inst addil (ldb (byte 21 11) offset) lip)
(inst ldw (ldb (byte 11 0) offset) lip old)))
(inst dep (sc-case value
(immediate (tn-value value))
(t value))
(+ (* extra ,bits) ,(1- bits))
,bits
old)
(if (typep offset '(signed-byte 14))
(inst stw old offset object)
(inst stw old (ldb (byte 11 0) offset) lip)))
(sc-case value
(immediate
(inst li (tn-value value) result))
(t
(move value result)))))))))
); eval-when (compile eval)
(def-small-data-vector-frobs simple-bit-vector 1)
(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
(def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
;;; And the float variants.
;;;
(define-vop (data-vector-ref/simple-array-single-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:argument 1))
(index :scs (any-reg) :to (:argument 0) :target offset))
(:arg-types simple-array-single-float positive-fixnum)
(:results (value :scs (single-reg)))
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
(:result-types single-float)
(:generator 5
(inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
index offset)
(inst fldx offset object value)))
(define-vop (data-vector-set/simple-array-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:argument 1))
(index :scs (any-reg) :to (:argument 0) :target offset)
(value :scs (single-reg) :target result))
(:arg-types simple-array-single-float positive-fixnum single-float)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
(:generator 5
(inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
index offset)
(inst fstx value offset object)
(unless (location= result value)
(inst funop :copy value result))))
(define-vop (data-vector-ref/simple-array-double-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:argument 1))
(index :scs (any-reg) :to (:argument 0) :target offset))
(:arg-types simple-array-double-float positive-fixnum)
(:results (value :scs (double-reg)))
(:result-types double-float)
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
(:generator 7
(inst sll index 1 offset)
(inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
offset offset)
(inst fldx offset object value)))
(define-vop (data-vector-set/simple-array-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:argument 1))
(index :scs (any-reg) :to (:argument 0) :target offset)
(value :scs (double-reg) :target result))
(:arg-types simple-array-double-float positive-fixnum double-float)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
(:generator 20
(inst sll index 1 offset)
(inst addi (- (* vector-data-offset word-bytes) other-pointer-type)
offset offset)
(inst fstx value offset object)
(unless (location= result value)
(inst funop :copy value result))))
;;; These vops are useful for accessing the bits of a vector irrespective of
;;; what type of vector it is.
;;;
(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num
%raw-bits)
(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
unsigned-num %set-raw-bits)
;;;; Misc. Array VOPs.
(define-vop (get-vector-subtype get-header-data))
(define-vop (set-vector-subtype set-header-data))
;;; -*- 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/compiler/hppa/c-call.lisp,v 1.1 1992/07/13 03:48:17 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the VOPs and other necessary machine specific support
;;; routines for call-out to C.
;;;
;;; Written by William Lott.
;;;
(in-package "HPPA")
(use-package "ALIEN")
(use-package "ALIEN-INTERNALS")
(defun my-make-wired-tn (prim-type-name sc-name offset)
(make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
(sc-number-or-lose sc-name *backend*)
offset))
(defstruct arg-state
(args 0))
(defstruct (arg-info
(:constructor make-arg-info (offset prim-type reg-sc stack-sc)))
offset
prim-type
reg-sc
stack-sc)
(def-alien-type-method (integer :arg-tn) (type state)
(let ((args (arg-state-args state)))
(setf (arg-state-args state) (1+ args))
(if (alien-integer-type-signed type)
(make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack)
(make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))))
(def-alien-type-method (system-area-pointer :arg-tn) (type state)
(declare (ignore type))
(let ((args (arg-state-args state)))
(setf (arg-state-args state) (1+ args))
(make-arg-info args 'system-area-pointer 'sap-reg 'sap-stack)))
(def-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let ((args (arg-state-args state)))
(setf (arg-state-args state) (1+ args))
(make-arg-info args 'single-float 'single-reg 'single-stack)))
(def-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((args (logior (1+ (arg-state-args state)) 1)))
(setf (arg-state-args state) (1+ args))
(make-arg-info args 'double-float 'double-reg 'double-stack)))
(def-alien-type-method (integer :result-tn) (type)
(if (alien-integer-type-signed type)
(my-make-wired-tn 'signed-byte-32 'signed-reg nl4-offset)
(my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl4-offset)))
(def-alien-type-method (system-area-pointer :result-tn) (type)
(declare (ignore type))
(my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset))
(def-alien-type-method (single-float :result-tn) (type)
(declare (ignore type))
(my-make-wired-tn 'single-float 'single-reg 4))
(def-alien-type-method (double-float :result-tn) (type)
(declare (ignore type))
(my-make-wired-tn 'double-float 'double-reg 4))
(def-alien-type-method (values :result-tn) (type)
(let ((values (alien-values-type-values type)))
(when values
(assert (null (cdr values)))
(invoke-alien-type-method :result-tn (car values)))))
(defun make-argument-tns (type)
(let* ((state (make-arg-state))
(args (mapcar #'(lambda (arg-type)
(invoke-alien-type-method :arg-tn arg-type state))
(alien-function-type-arg-types type)))
;; We need 8 words of cruft, and we need to round up to a multiple
;; of 16 words.
(frame-size (logandc2 (+ (arg-state-args state) 8 15) 15)))
(values
(mapcar #'(lambda (arg)
(declare (type arg-info arg))
(let ((offset (arg-info-offset arg))
(prim-type (arg-info-prim-type arg)))
(cond ((>= offset 4)
(my-make-wired-tn prim-type (arg-info-stack-sc arg)
(- frame-size offset 8 1)))
((or (eq prim-type 'single-float)
(eq prim-type 'double-float))
(my-make-wired-tn prim-type (arg-info-reg-sc arg)
(+ offset 4)))
(t
(my-make-wired-tn prim-type (arg-info-reg-sc arg)
(- nl0-offset offset))))))
args)
(* frame-size word-bytes))))
(def-vm-support-routine make-call-out-tns (type)
(declare (type alien-function-type type))
(multiple-value-bind
(arg-tns stack-size)
(make-argument-tns type)
(values (make-normal-tn *fixnum-primitive-type*)
stack-size
arg-tns
(invoke-alien-type-method
:result-tn
(alien-function-type-result-type type)))))
(define-vop (foreign-symbol-address)
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
(inst li (make-fixup foreign-symbol :foreign) res)))
(define-vop (call-out)
(:args (function :scs (sap-reg) :target cfunc)
(args :more t))
(:results (results :more t))
(:ignore args results)
(:save-p t)
(:temporary (:sc any-reg :offset cfunc-offset
:from (:argument 0) :to (:result 0)) cfunc)
(:temporary (:scs (any-reg) :to (:result 0)) temp)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:vop-var vop)
(:generator 0
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
(move function cfunc)
(let ((fixup (make-fixup "call_into_c" :foreign)))
(inst ldil fixup temp)
(inst ble fixup c-text-space temp :nullify t))
(inst nop)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save)))))
(define-vop (alloc-number-stack-space)
(:info amount)
(:results (result :scs (sap-reg any-reg)))
(:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:generator 0
(move nsp-tn result)
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 63) 63)))
(cond ((< delta (ash 1 10))
(inst addi delta nsp-tn nsp-tn))
(t
(inst li delta temp)
(inst add temp nsp-tn nsp-tn)))))))
(define-vop (dealloc-number-stack-space)
(:info amount)
(:policy :fast-safe)
(:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:generator 0
(unless (zerop amount)
(let ((delta (- (logandc2 (+ amount 63) 63))))
(cond ((<= (- (ash 1 10)) delta)
(inst addi delta nsp-tn nsp-tn))
(t
(inst li delta temp)
(inst add temp nsp-tn nsp-tn)))))))
This diff is collapsed.
This diff is collapsed.
;;; -*- 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/compiler/hppa/char.lisp,v 1.1 1992/07/13 03:48:20 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the HPPA VM definition of character operations.
;;;
;;; Written by William Lott
;;;
(in-package "HPPA")
;;;; Moves and coercions:
;;; Move a tagged char to an untagged representation.
;;;
(define-vop (move-to-base-char)
(:args (x :scs (any-reg descriptor-reg)))
(:results (y :scs (base-char-reg)))
(:generator 1
(inst srl x type-bits y)))
;;;
(define-move-vop move-to-base-char :move
(any-reg descriptor-reg) (base-char-reg))
;;; Move an untagged char to a tagged representation.
;;;
(define-vop (move-from-base-char)
(:args (x :scs (base-char-reg)))
(:results (y :scs (any-reg descriptor-reg)))
(:generator 1
(inst sll x type-bits y)
(inst addi base-char-type y y)))
;;;
(define-move-vop move-from-base-char :move
(base-char-reg) (any-reg descriptor-reg))
;;; Move untagged base-char values.
;;;
(define-vop (base-char-move)
(:args (x :target y
:scs (base-char-reg)
:load-if (not (location= x y))))
(:results (y :scs (base-char-reg)
:load-if (not (location= x y))))
(:effects)
(:affected)
(:generator 0
(move x y)))
;;;
(define-move-vop base-char-move :move
(base-char-reg) (base-char-reg))
;;; Move untagged base-char arguments/return-values.
;;;
(define-vop (move-base-char-argument)
(:args (x :target y
:scs (base-char-reg))
(fp :scs (any-reg)
:load-if (not (sc-is y base-char-reg))))
(:results (y))
(:generator 0
(sc-case y
(base-char-reg
(move x y))
(base-char-stack
(storew x fp (tn-offset y))))))
;;;
(define-move-vop move-base-char-argument :move-argument
(any-reg base-char-reg) (base-char-reg))
;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
;;; to a descriptor passing location.
;;;
(define-move-vop move-argument :move-argument
(base-char-reg) (any-reg descriptor-reg))
;;;; Other operations:
(define-vop (char-code)
(:translate char-code)
(:policy :fast-safe)
(:args (ch :scs (base-char-reg) :target res))
(:arg-types base-char)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 1
(move ch res)))
(define-vop (code-char)
(:translate code-char)
(:policy :fast-safe)
(:args (code :scs (unsigned-reg) :target res))
(:arg-types positive-fixnum)
(:results (res :scs (base-char-reg)))
(:result-types base-char)
(:generator 1
(move code res)))
;;; Comparison of base-chars.
;;;
(define-vop (base-char-compare)
(:args (x :scs (base-char-reg))
(y :scs (base-char-reg)))
(:arg-types base-char base-char)
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(:note "inline comparison")
(:variant-vars cond)
(:generator 3
(inst bc cond not-p x y target)))
(define-vop (fast-char=/base-char base-char-compare)
(:translate char=)
(:variant :=))
(define-vop (fast-char</base-char base-char-compare)
(:translate char<)
(:variant :<<))
(define-vop (fast-char>/base-char base-char-compare)
(:translate char>)
(:variant :>>))
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment