/[cmucl]/src/code/kernel.lisp
ViewVC logotype

Contents of /src/code/kernel.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Mon Apr 19 02:18:03 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.17: +23 -23 lines
Remove _N"" reader macro from docstrings when possible.
1 ;;; -*- Log: code.log; Package: KERNEL -*-
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/code/kernel.lisp,v 1.18 2010/04/19 02:18:03 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;;
13 (in-package "KERNEL")
14
15 (intl:textdomain "cmucl")
16
17 (export '(allocate-vector make-array-header function-subtype))
18
19
20 (defun get-header-data (x)
21 "Return the 24 bits of data in the header of object X, which must be an
22 other-pointer object."
23 (get-header-data x))
24
25 (defun set-header-data (x val)
26 "Sets the 24 bits of data in the header of object X (which must be an
27 other-pointer object) to VAL."
28 (set-header-data x val))
29
30 (defun get-closure-length (x)
31 "Returns the length of the closure X. This is one more than the number
32 of variables closed over."
33 (get-closure-length x))
34
35 (defun get-lowtag (x)
36 "Returns the three-bit lowtag for the object X."
37 (get-lowtag x))
38
39 (defun get-type (x)
40 "Returns the 8-bit header type for the object X."
41 (get-type x))
42
43 (defun vector-sap (x)
44 "Return a System-Area-Pointer pointing to the data for the vector X, which
45 must be simple."
46 (declare (type (simple-unboxed-array (*)) x))
47 (vector-sap x))
48
49
50 (defun c::binding-stack-pointer-sap ()
51 "Return a System-Area-Pointer pointing to the end of the binding stack."
52 (c::binding-stack-pointer-sap))
53
54 (defun c::dynamic-space-free-pointer ()
55 "Returns a System-Area-Pointer pointing to the next free work of the current
56 dynamic space."
57 (c::dynamic-space-free-pointer))
58
59 (defun c::control-stack-pointer-sap ()
60 "Return a System-Area-Pointer pointing to the end of the control stack."
61 (c::control-stack-pointer-sap))
62
63 (defun function-subtype (function)
64 "Return the header typecode for FUNCTION. Can be set with SETF."
65 (function-subtype function))
66
67 (defun (setf function-subtype) (type function)
68 (setf (function-subtype function) type))
69
70 (defun %function-arglist (func)
71 "Extracts the arglist from the function header FUNC."
72 (%function-arglist func))
73
74 (defun %function-name (func)
75 "Extracts the name from the function header FUNC."
76 (%function-name func))
77
78 (defun %function-type (func)
79 "Extracts the type from the function header FUNC."
80 (%function-type func))
81
82 (defun %closure-function (closure)
83 "Extracts the function from CLOSURE."
84 (%closure-function closure))
85
86 (defun c::vector-length (vector)
87 "Return the length of VECTOR. There is no reason to use this, 'cause
88 (length (the vector foo)) is the same."
89 (c::vector-length vector))
90
91 (defun %sxhash-simple-string (string)
92 "Return the SXHASH for the simple-string STRING."
93 (%sxhash-simple-string string))
94
95 (defun %sxhash-simple-substring (string length)
96 "Return the SXHASH for the first LENGTH characters of the simple-string
97 STRING."
98 (%sxhash-simple-substring string length))
99
100 (defun %closure-index-ref (closure index)
101 "Extract the INDEXth slot from CLOSURE."
102 (%closure-index-ref closure index))
103
104
105 (defun allocate-vector (type length words)
106 "Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
107 WORDS words long. Note: it is your responsibility to assure that the
108 relation between LENGTH and WORDS is correct."
109 (allocate-vector type length words))
110
111 (defun make-array-header (type rank)
112 "Allocate an array header with type code TYPE and rank RANK."
113 (make-array-header type rank))
114
115
116 (defun code-instructions (code-obj)
117 "Return a SAP pointing to the instructions part of CODE-OBJ."
118 (code-instructions code-obj))
119
120 (defun code-header-ref (code-obj index)
121 "Extract the INDEXth element from the header of CODE-OBJ. Can be set with
122 setf."
123 (code-header-ref code-obj index))
124
125 (defun code-header-set (code-obj index new)
126 (code-header-set code-obj index new))
127
128 (defsetf code-header-ref code-header-set)
129
130
131 (defun %raw-bits (object offset)
132 (declare (type index offset))
133 (kernel:%raw-bits object offset))
134
135 (defun %set-raw-bits (object offset value)
136 (declare (type index offset) (type (unsigned-byte #.vm:word-bits) value))
137 (setf (kernel:%raw-bits object offset) value))
138
139 (defsetf %raw-bits %set-raw-bits)
140
141 (defun make-single-float (x) (make-single-float x))
142 (defun make-double-float (hi lo) (make-double-float hi lo))
143 #+long-float
144 (defun make-long-float (exp hi #+sparc mid lo)
145 (make-long-float exp hi #+sparc mid lo))
146
147 #+double-double
148 (defun %make-double-double-float (hi lo)
149 (%make-double-double-float hi lo))
150
151 #+double-double
152 (declaim (inline make-double-double-float))
153 #+double-double
154 (defun make-double-double-float (hi lo)
155 ;; Make sure the parts make sense for a double-double
156 (declare (double-float hi lo)
157 (inline float-infinity-p float-nan-p))
158 (if (or (float-infinity-p hi) (float-nan-p hi))
159 (%make-double-double-float hi lo)
160 (multiple-value-bind (s e)
161 (c::two-sum hi lo)
162 (%make-double-double-float s e))))
163
164 #+double-double
165 (defun double-double-hi (x)
166 (double-double-hi x))
167 #+double-double
168 (defun double-double-lo (x)
169 (double-double-lo x))
170
171 (defun single-float-bits (x) (single-float-bits x))
172 (defun double-float-high-bits (x) (double-float-high-bits x))
173 (defun double-float-low-bits (x) (double-float-low-bits x))
174 #+long-float
175 (defun long-float-exp-bits (x) (long-float-exp-bits x))
176 #+long-float
177 (defun long-float-high-bits (x) (long-float-high-bits x))
178 #+(and long-float sparc)
179 (defun long-float-mid-bits (x) (long-float-mid-bits x))
180 #+long-float
181 (defun long-float-low-bits (x) (long-float-low-bits x))
182
183 #+(or sparc ppc)
184 (defun double-float-bits (x) (double-float-bits x))
185
186 #-(or sparc ppc)
187 (defun double-float-bits (x)
188 (values (double-float-high-bits x) (double-float-low-bits x)))
189
190
191 (defun %numerator (x)
192 (declare (type ratio x))
193 (%numerator x))
194
195 (defun %denominator (x)
196 (declare (type ratio x))
197 (%denominator x))

  ViewVC Help
Powered by ViewVC 1.1.5