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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Sun Aug 3 11:27:47 2003 UTC (10 years, 8 months ago) by gerd
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, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, 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, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, 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, 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, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, 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, 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, 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, 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, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, 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, 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.5: +3 -3 lines
	Remove the function definition of FIXNUM, which it must not
	have according to CLtS.  Found by Paul Dietz.

	Use boot14.lisp to bootstrap.

	* src/compiler/generic/utils.lisp (fixnumize): Renamed from
	fixnum.

	* src/bootfiles/18e/boot14.lisp: New file.

	* src/code/exports.lisp ("VM"): Export fixnumize.

	* src/assembly/alpha/arith.lisp, src/assembly/alpha/array.lisp:
	* src/assembly/alpha/assem-rtns.lisp, src/assembly/hppa/arith.lisp
	* src/assembly/hppa/array.lisp, src/assembly/hppa/assem-rtns.lisp
	* src/assembly/mips/alloc.lisp, src/assembly/mips/arith.lisp
	* src/assembly/mips/array.lisp, src/assembly/mips/assem-rtns.lisp
	* src/assembly/mips/bit-bash.lisp, src/assembly/ppc/arith.lisp
	* src/assembly/ppc/array.lisp, src/assembly/ppc/assem-rtns.lisp
	* src/assembly/rt/alloc.lisp, src/assembly/rt/arith.lisp
	* src/assembly/rt/array.lisp, src/assembly/rt/assem-rtns.lisp
	* src/assembly/sparc/arith.lisp, src/assembly/sparc/array.lisp
	* src/assembly/sparc/assem-rtns.lisp, src/assembly/x86/arith.lisp
	* src/assembly/x86/array.lisp, src/assembly/x86/assem-rtns.lisp
	* src/compiler/alpha/alloc.lisp, src/compiler/alpha/arith.lisp
	* src/compiler/alpha/array.lisp, src/compiler/alpha/call.lisp
	* src/compiler/alpha/move.lisp, src/compiler/alpha/nlx.lisp
	* src/compiler/alpha/static-fn.lisp, src/compiler/alpha/subprim.lisp
	* src/compiler/alpha/values.lisp, src/compiler/generic/utils.lisp
	* src/compiler/hppa/alloc.lisp, src/compiler/hppa/arith.lisp
	* src/compiler/hppa/array.lisp, src/compiler/hppa/call.lisp
	* src/compiler/hppa/move.lisp, src/compiler/hppa/nlx.lisp
	* src/compiler/hppa/static-fn.lisp, src/compiler/hppa/subprim.lisp
	* src/compiler/hppa/values.lisp, src/compiler/mips/alloc.lisp
	* src/compiler/mips/arith.lisp, src/compiler/mips/array.lisp
	* src/compiler/mips/call.lisp, src/compiler/mips/move.lisp
	* src/compiler/mips/nlx.lisp, src/compiler/mips/static-fn.lisp
	* src/compiler/mips/subprim.lisp, src/compiler/mips/values.lisp
	* src/compiler/ppc/alloc.lisp, src/compiler/ppc/arith.lisp
	* src/compiler/ppc/array.lisp, src/compiler/ppc/call.lisp
	* src/compiler/ppc/move.lisp, src/compiler/ppc/nlx.lisp
	* src/compiler/ppc/static-fn.lisp, src/compiler/ppc/subprim.lisp
	* src/compiler/ppc/values.lisp, src/compiler/rt/alloc.lisp
	* src/compiler/rt/arith.lisp, src/compiler/rt/array.lisp
	* src/compiler/rt/call.lisp, src/compiler/rt/move.lisp
	* src/compiler/rt/nlx.lisp, src/compiler/rt/static-fn.lisp
	* src/compiler/rt/subprim.lisp, src/compiler/rt/values.lisp
	* src/compiler/sparc/alloc.lisp, src/compiler/sparc/arith.lisp
	* src/compiler/sparc/array.lisp, src/compiler/sparc/call.lisp
	* src/compiler/sparc/move.lisp, src/compiler/sparc/nlx.lisp
	* src/compiler/sparc/static-fn.lisp, src/compiler/sparc/subprim.lisp
	* src/compiler/sparc/values.lisp, src/compiler/x86/alloc.lisp
	* src/compiler/x86/arith.lisp, src/compiler/x86/array.lisp
	* src/compiler/x86/call.lisp, src/compiler/x86/cell.lisp
	* src/compiler/x86/macros.lisp, src/compiler/x86/memory.lisp
	* src/compiler/x86/move.lisp, src/compiler/x86/nlx.lisp
	* src/compiler/x86/pred.lisp, src/compiler/x86/static-fn.lisp
	* src/compiler/x86/subprim.lisp, src/compiler/x86/values.lisp:
	Use fixnumize instead of fixnum.
1 ;;; -*- Package: rt -*-
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/alloc.lisp,v 1.6 2003/08/03 11:27:47 gerd Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/rt/alloc.lisp,v 1.6 2003/08/03 11:27:47 gerd Rel $
13 ;;;
14 ;;; Allocation VOPs for the IBM RT port.
15 ;;;
16 ;;; Written by William Lott.
17 ;;; Converted by Bill Chiles.
18 ;;;
19
20 (in-package "RT")
21
22
23
24 ;;;; LIST and LIST*
25
26 (define-vop (list-or-list*)
27 (:args (things :more t))
28 (:temporary (:scs (descriptor-reg) :type list) ptr)
29 (:temporary (:scs (descriptor-reg)) temp)
30 (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
31 res)
32 (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
33 (:temporary (:scs (word-pointer-reg)) alloc)
34 (:info num)
35 (:results (result :scs (descriptor-reg)))
36 (:variant-vars star)
37 (:policy :safe)
38 (:generator 0
39 (cond ((zerop num)
40 (move result null-tn))
41 ((and star (= num 1))
42 (move result (tn-ref-tn things)))
43 (t
44 (macrolet
45 ((store-car (tn list &optional (slot cons-car-slot))
46 `(let ((reg
47 (sc-case ,tn
48 ((any-reg descriptor-reg) ,tn)
49 (null null-tn)
50 (control-stack
51 (load-stack-tn temp ,tn)
52 temp))))
53 (storew reg ,list ,slot list-pointer-type))))
54 (let ((cons-cells (if star (1- num) num)))
55 (pseudo-atomic (ndescr)
56 (load-symbol-value alloc *allocation-pointer*)
57 (inst cal res alloc list-pointer-type)
58 (inst cal alloc alloc (* (pad-data-block cons-size)
59 cons-cells))
60 (store-symbol-value alloc *allocation-pointer*)
61 (move ptr res)
62 (dotimes (i (1- cons-cells))
63 (store-car (tn-ref-tn things) ptr)
64 (setf things (tn-ref-across things))
65 (inst cal ptr ptr (pad-data-block cons-size))
66 (storew ptr ptr
67 (- cons-cdr-slot cons-size)
68 list-pointer-type))
69 (store-car (tn-ref-tn things) ptr)
70 (cond (star
71 (setf things (tn-ref-across things))
72 (store-car (tn-ref-tn things) ptr cons-cdr-slot))
73 (t
74 (storew null-tn ptr
75 cons-cdr-slot list-pointer-type)))
76 (assert (null (tn-ref-across things)))
77 (move result res))
78 (load-symbol-value ndescr *internal-gc-trigger*)
79 (inst tlt ndescr alloc)))))))
80
81 (define-vop (list list-or-list*)
82 (:variant nil))
83
84 (define-vop (list* list-or-list*)
85 (:variant t))
86
87
88
89 ;;;; Special purpose inline allocators.
90
91 (define-vop (allocate-code-object)
92 (:args (boxed-arg :scs (any-reg))
93 (unboxed-arg :scs (any-reg) :target unboxed))
94 (:results (result :scs (descriptor-reg)))
95 (:temporary (:scs (non-descriptor-reg)) ndescr)
96 (:temporary (:scs (word-pointer-reg)) alloc)
97 (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
98 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
99 (:generator 100
100 (inst li ndescr (lognot lowtag-mask))
101 (inst cal boxed boxed-arg (fixnumize (1+ vm:code-trace-table-offset-slot)))
102 (inst n boxed ndescr)
103 (move unboxed unboxed-arg)
104 (inst sr unboxed word-shift)
105 (inst a unboxed lowtag-mask)
106 (inst n unboxed ndescr)
107 (pseudo-atomic (ndescr)
108 (load-symbol-value alloc *allocation-pointer*)
109 (inst cal result alloc other-pointer-type)
110 (inst cas alloc boxed alloc)
111 (inst cas alloc unboxed alloc)
112 (store-symbol-value alloc *allocation-pointer*)
113 (move ndescr boxed)
114 (inst sl ndescr (- type-bits word-shift))
115 (inst oil ndescr code-header-type)
116 (storew ndescr result 0 other-pointer-type)
117 (storew unboxed result code-code-size-slot other-pointer-type)
118 (storew null-tn result code-entry-points-slot other-pointer-type)
119 (storew null-tn result code-debug-info-slot other-pointer-type))
120 (load-symbol-value ndescr *internal-gc-trigger*)
121 (inst tlt ndescr alloc)))
122
123 (define-vop (make-symbol)
124 (:args (name :scs (descriptor-reg) :to :eval))
125 (:temporary (:scs (sap-reg)) temp)
126 (:temporary (:scs (word-pointer-reg)) alloc)
127 (:results (result :scs (descriptor-reg) :from :argument))
128 (:policy :fast-safe)
129 (:translate make-symbol)
130 (:generator 37
131 (with-fixed-allocation (result temp alloc symbol-header-type symbol-size)
132 (inst li temp unbound-marker-type)
133 (storew temp result symbol-value-slot other-pointer-type)
134 (storew temp result symbol-function-slot other-pointer-type)
135 (storew temp result symbol-setf-function-slot other-pointer-type)
136 (inst cai temp (make-fixup "undefined_tramp" :foreign))
137 (storew temp result symbol-raw-function-addr-slot
138 other-pointer-type)
139 (storew null-tn result symbol-plist-slot other-pointer-type)
140 (storew name result symbol-name-slot other-pointer-type)
141 (storew null-tn result symbol-package-slot other-pointer-type))))

  ViewVC Help
Powered by ViewVC 1.1.5