/[cmucl]/src/compiler/rt/memory.lisp
ViewVC logotype

Contents of /src/compiler/rt/memory.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Oct 31 04:45:41 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.1: +7 -5 lines
Fix headed boilerplate.
1 ;;; -*- Package: RT; Log: c.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/rt/memory.lisp,v 1.2 1994/10/31 04:45:41 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/rt/memory.lisp,v 1.2 1994/10/31 04:45:41 ram Rel $
13 ;;;
14 ;;; This file contains the IBM RT definitions of some general purpose memory
15 ;;; reference VOPs inherited by basic memory reference operations.
16 ;;;
17 ;;; Written by Rob MacLachlan
18 ;;;
19 ;;; Converted by Bill Chiles.
20 ;;;
21
22 (in-package "RT")
23
24
25 ;;; CELL-REF -- VOP.
26 ;;; CELL-SET -- VOP.
27 ;;; CELL-SETF -- VOP.
28 ;;; CELL-SETF-FUNCTION -- VOP.
29 ;;;
30 ;;; CELL-REF and CELL-SET are used to define VOPs like CAR, where the offset to
31 ;;; be read or written is a property of the VOP used. CELL-SETF is similar to
32 ;;; CELL-SET, but delivers the new value as the result. CELL-SETF-FUNCTION
33 ;;; takes its arguments as if it were a setf function (new value first, as
34 ;;; apposed to a setf macro, which takes the new value last).
35 ;;;
36 (define-vop (cell-ref)
37 (:args (object :scs (descriptor-reg)))
38 (:results (value :scs (word-pointer-reg descriptor-reg any-reg)))
39 (:variant-vars offset lowtag)
40 (:policy :fast-safe)
41 (:generator 4
42 (loadw value object offset lowtag)))
43 ;;;
44 (define-vop (cell-set)
45 (:args (object :scs (descriptor-reg))
46 (value :scs (word-pointer-reg descriptor-reg any-reg)))
47 (:variant-vars offset lowtag)
48 (:policy :fast-safe)
49 (:generator 4
50 (storew value object offset lowtag)))
51 ;;;
52 (define-vop (cell-setf)
53 (:args (object :scs (descriptor-reg))
54 (value :scs (word-pointer-reg descriptor-reg any-reg)
55 :target result))
56 (:results (result :scs (descriptor-reg any-reg)))
57 (:variant-vars offset lowtag)
58 (:policy :fast-safe)
59 (:generator 4
60 (storew value object offset lowtag)
61 (move result value)))
62 ;;;
63 (define-vop (cell-setf-function)
64 (:args (value :scs (word-pointer-reg descriptor-reg any-reg)
65 :target result)
66 (object :scs (descriptor-reg)))
67 (:results (result :scs (descriptor-reg any-reg)))
68 (:variant-vars offset lowtag)
69 (:policy :fast-safe)
70 (:generator 4
71 (storew value object offset lowtag)
72 (move result value)))
73
74 ;;; DEFINE-CELL-ACCESSORS -- Interface.
75 ;;;
76 ;;; Define accessor VOPs for some cells in an object. If the operation name is
77 ;;; NIL, then that operation isn't defined. If the translate function is null,
78 ;;; then we don't define a translation.
79 ;;;
80 (defmacro define-cell-accessors (offset lowtag ref-op ref-trans set-op set-trans)
81 `(progn
82 ,@(when ref-op
83 `((define-vop (,ref-op cell-ref)
84 (:variant ,offset ,lowtag)
85 ,@(when ref-trans
86 `((:translate ,ref-trans))))))
87 ,@(when set-op
88 `((define-vop (,set-op cell-setf)
89 (:variant ,offset ,lowtag)
90 ,@(when set-trans
91 `((:translate ,set-trans))))))))
92
93
94 ;;; SLOT-REF -- VOP.
95 ;;; SLOT-SET -- VOP.
96 ;;;
97 ;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF, where the
98 ;;; offset is constant at compile time, but varies for different uses. We add
99 ;;; in the stardard g-vector overhead.
100 ;;;
101 (define-vop (slot-ref)
102 (:args (object :scs (descriptor-reg)))
103 (:results (value :scs (descriptor-reg any-reg)))
104 (:variant-vars base lowtag)
105 (:info offset)
106 (:generator 4
107 (loadw value object (+ base offset) lowtag)))
108 ;;;
109 (define-vop (slot-set)
110 (:args (object :scs (descriptor-reg))
111 (value :scs (descriptor-reg any-reg)))
112 (:variant-vars base lowtag)
113 (:info offset)
114 (:generator 4
115 (storew value object (+ base offset) lowtag)))
116
117
118
119 ;;;; Indexed references:
120
121 (eval-when (compile eval)
122
123 ;;; DEFINE-INDEXER -- Internal.
124 ;;;
125 ;;; Define some VOPs for indexed memory reference. Unless the index is
126 ;;; constant, we must compute an intermediate result in a boxed temporary,
127 ;;; since the RT doesn't have any indexed addressing modes.
128 ;;;
129 (defmacro define-indexer (name write-p op shift &key gross-hack)
130 `(define-vop (,name)
131 (:args (object :scs (descriptor-reg) :to :eval)
132 (index :scs (any-reg immediate)
133 ,@(unless (zerop shift) '(:target temp)))
134 ,@(when write-p
135 '((value :scs (any-reg descriptor-reg) :target result))))
136 (:arg-types * tagged-num ,@(when write-p '(*)))
137 (:temporary (:scs (interior-reg) :type interior) lip)
138 ,@(unless (zerop shift)
139 `((:temporary (:scs (non-descriptor-reg)
140 :type random :from (:argument 1))
141 temp)))
142 (:results (,(if write-p 'result 'value)
143 :scs (any-reg descriptor-reg)))
144 (:result-types *)
145 (:variant-vars offset lowtag)
146 (:policy :fast-safe)
147 (:generator 5
148 (sc-case index
149 ((immediate)
150 (inst ,op value object
151 (- (+ (if (and (sc-is index immediate) (zerop (tn-value index)))
152 0
153 (ash (tn-value index) (- word-shift ,shift)))
154 (ash offset word-shift))
155 lowtag))
156 ,@(if write-p
157 '((move result value))))
158 (t
159 ,@(if (zerop shift)
160 ;; Object must be the last arg to CAS here since it is cannot
161 ;; be in R0.
162 `((inst cas lip index object))
163 `((move temp index)
164 (inst sr temp ,shift)
165 (inst cas lip temp object)))
166 (inst ,op value lip (- (ash offset word-shift) lowtag))
167 ,@(if write-p
168 '((move result value)))))
169 ;; The RT lacks a signed-byte load instruction, so we have to sign
170 ;; extend this case explicitly. This is gross but obvious and easy.
171 ,@(when gross-hack
172 '((inst sl value 24)
173 (inst sar value 24))))))
174
175 ) ;EVAL-WHEN
176
177 (define-indexer word-index-ref nil l 0)
178 (define-indexer word-index-set t st 0)
179 (define-indexer halfword-index-ref nil lh 1)
180 (define-indexer signed-halfword-index-ref nil lha 1)
181 (define-indexer halfword-index-set t sth 1)
182 (define-indexer byte-index-ref nil lc 2)
183 (define-indexer signed-byte-index-ref nil lc 2 :gross-hack t)
184 (define-indexer byte-index-set t stc 2)

  ViewVC Help
Powered by ViewVC 1.1.5