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

Changed function-header-code-offset to function-code-offset.

Added stuff for new var-alloc and fixed-alloc vops.
parent 7bcb4239
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/cell.lisp,v 1.2 1992/10/28 00:32:43 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/cell.lisp,v 1.3 1993/01/15 01:33:53 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -20,63 +20,34 @@ ...@@ -20,63 +20,34 @@
(in-package "HPPA") (in-package "HPPA")
;;;; Data object definition macros. ;;;; Data object ref/set stuff.
(define-for-each-primitive-object (obj) (define-vop (slot)
(collect ((forms)) (:args (object :scs (descriptor-reg)))
(let ((lowtag (primitive-object-lowtag obj))) (:info name offset lowtag)
(dolist (slot (primitive-object-slots obj)) (:ignore name)
(let* ((name (slot-name slot)) (:results (result :scs (descriptor-reg any-reg)))
(offset (slot-offset slot)) (:generator 1
(rest-p (slot-rest-p slot)) (loadw result object offset lowtag)))
(slot-opts (slot-options slot))
(ref-trans (getf slot-opts :ref-trans)) (define-vop (set-slot)
(ref-vop (getf slot-opts :ref-vop ref-trans)) (:args (object :scs (descriptor-reg))
(set-trans (getf slot-opts :set-trans)) (value :scs (descriptor-reg any-reg)))
(setf-function-p (and (listp set-trans) (:info name offset lowtag)
(= (length set-trans) 2) (:ignore name)
(eq (car set-trans) 'setf))) (:results)
(setf-vop (getf slot-opts :setf-vop (:generator 1
(when setf-function-p (storew value object offset lowtag)))
(intern (concatenate
'simple-string
"SET-"
(string (cadr set-trans)))))))
(set-vop (getf slot-opts :set-vop
(if setf-vop nil set-trans))))
(when ref-vop
(forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
(:variant ,offset ,lowtag)
,@(when ref-trans
`((:translate ,ref-trans))))))
(when (or set-vop setf-vop)
(forms `(define-vop ,(cond ((and rest-p setf-vop)
(error "Can't automatically generate ~
a setf VOP for :rest-p ~
slots: ~S in ~S"
name
(primitive-object-name obj)))
(rest-p `(,set-vop slot-set))
((and set-vop setf-function-p)
(error "Setf functions (list ~S) must ~
use :setf-vops."
set-trans))
(set-vop `(,set-vop cell-set))
(setf-function-p
`(,setf-vop cell-setf-function))
(t
`(,setf-vop cell-setf)))
(:variant ,offset ,lowtag)
,@(when set-trans
`((:translate ,set-trans)))))))))
(when (forms)
`(progn
,@(forms)))))
;;;; Symbol hacking VOPs: ;;;; Symbol hacking VOPs:
;;; The compiler likes to be able to directly SET symbols.
;;;
(define-vop (set cell-set)
(:variant symbol-value-slot other-pointer-type))
;;; Do a cell ref with an error check for being unbound. ;;; Do a cell ref with an error check for being unbound.
;;; ;;;
(define-vop (checked-cell-ref) (define-vop (checked-cell-ref)
...@@ -125,6 +96,9 @@ ...@@ -125,6 +96,9 @@
;;;; Fdefinition (fdefn) objects. ;;;; Fdefinition (fdefn) objects.
(define-vop (fdefn-function cell-ref)
(:variant fdefn-function-slot other-pointer-type))
(define-vop (safe-fdefn-function) (define-vop (safe-fdefn-function)
(:args (object :scs (descriptor-reg) :target obj-temp)) (:args (object :scs (descriptor-reg) :target obj-temp))
(:results (value :scs (descriptor-reg any-reg))) (:results (value :scs (descriptor-reg any-reg)))
...@@ -149,8 +123,7 @@ ...@@ -149,8 +123,7 @@
(load-type type function (- function-pointer-type)) (load-type type function (- function-pointer-type))
(inst addi (- function-header-type) type type) (inst addi (- function-header-type) type type)
(inst comb := type zero-tn normal-fn) (inst comb := type zero-tn normal-fn)
(inst addi (- (ash function-header-code-offset word-shift) (inst addi (- (ash function-code-offset word-shift) function-pointer-type)
function-pointer-type)
function lip) function lip)
(inst li (make-fixup "closure_tramp" :foreign) lip) (inst li (make-fixup "closure_tramp" :foreign) lip)
NORMAL-FN NORMAL-FN
...@@ -231,6 +204,23 @@ ...@@ -231,6 +204,23 @@
(descriptor-reg any-reg) * %set-funcallable-instance-info) (descriptor-reg any-reg) * %set-funcallable-instance-info)
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset function-pointer-type))
(define-vop (closure-init slot-set)
(:variant closure-info-offset function-pointer-type))
;;;; Value Cell hackery.
(define-vop (value-cell-ref cell-ref)
(:variant value-cell-value-slot other-pointer-type))
(define-vop (value-cell-set cell-set)
(:variant value-cell-value-slot other-pointer-type))
;;;; Structure hackery: ;;;; Structure hackery:
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment