Annotation of /sml/trunk/src/system/smlnj/init/core.sml

Parent Directory | Revision Log

---

Revision 651 - (view) (download)

1 :	blume	573	(* core.sml
2 :			*
3 :			* COPYRIGHT 1989 by AT&T Bell Laboratories
4 :			*
5 :			* Core assumes that the following bindings are already in the static
6 :			* environment:
7 :			*
8 :			* 1. Built-in structures, defined in PrimTypes (env/prim.sml):
9 :			* PrimTypes InLine
10 :			*
11 :			* 2. Built-in type constructors, defined in PrimTypes (env/prim.sml):
12 :			* int string bool unit real list array ref exn
13 :			*
14 :			* 3. Built-in data constructors, also from PrimTypes (env/prim.sml):
15 :			* :: nil ref true false
16 :			*
17 :			* 4. Built-in primitive operators, defined in InLine (env/prim.sml).
18 :			* The InLine structure is not typed (all values have type alpha, this
19 :			* will change in the future though !).
20 :			*
21 :			* 5. The Assembly structure: its static semantics is defined by elaborating
22 :			* the boot/dummy.sml file, and its dynamic semantics is directly coming
23 :			* the implementation module provided by the runtime system.
24 :			*
25 :			* In addition, all matches in this file should be exhaustive; the match and
26 :			* bind exceptions are not defined at this stage of bootup, so any uncaught
27 :			* match will cause an unpredictable error.
28 :			*
29 :			*)
30 :
31 :			structure Core =
32 :			struct
33 :			(*
34 :			* We build an Assembly structure from the implementation module provided
35 :			* from the runtime systems. The coercions are implemented via InLine.cast,
36 :			* a primitive operator hardwired inside the compiler. In the future, the
37 :			* linkage should be done safely without using cast (ZHONG).
38 :			*
39 :			* Note: in the future, the Assembly.A substructure will be replaced by
40 :			* a dynamic run vector (JHR).
41 :			*)
42 :			structure Assembly : ASSEMBLY =
43 :			struct
44 :			open Assembly
45 :
46 :			val cast : 'a -> 'b = InLine.cast
47 :			datatype ('a, 'b) pair = PAIR of 'a * 'b
48 :
49 :			structure A =
50 :			struct
51 :			structure AA = Assembly.A
52 :
53 :			type c_function = AA.c_function
54 :			type word8array = AA.word8array
55 :			type real64array = AA.word8array
56 :			type spin_lock = AA.spin_lock
57 :
58 :			val arrayP : (int, 'a) pair -> 'a array = cast AA.array
59 :			val array : int * 'a -> 'a array = fn x => arrayP(PAIR x)
60 :
61 :			val bind_cfunP : (string, string) pair -> c_function =
62 :			cast AA.bind_cfun
63 :			val bind_cfun : (string * string) -> c_function =
64 :			fn x => bind_cfunP (PAIR x)
65 :
66 :			val callcP : (c_function, 'a) pair -> 'c = cast AA.callc
67 :			val callc : (c_function * 'a) -> 'c = fn x => callcP (PAIR x)
68 :
69 :			val create_b : int -> word8array = cast AA.create_b
70 :			val create_r : int -> real64array = cast AA.create_r
71 :			val create_s : int -> string = cast AA.create_s
72 :			val create_vP : (int, 'a list) pair -> 'a vector = cast AA.create_v
73 :			val create_v : int * 'a list -> 'a vector =
74 :			fn x => create_vP(PAIR x)
75 :
76 :			val floor : real -> int = cast AA.floor
77 :			val logb : real -> int = cast AA.logb
78 :			val scalbP : (real, int) pair -> real = cast AA.scalb
79 :			val scalb : real * int -> real = fn x => scalbP(PAIR x)
80 :
81 :			val try_lock : spin_lock -> bool = cast AA.try_lock
82 :			val unlock : spin_lock -> unit = cast AA.unlock
83 :
84 :			end (* structure A *)
85 :
86 :			val vector0 : 'a vector = cast vector0
87 :
88 :			end (* structure Assembly *)
89 :
90 :			infix 7 * / quot mod rem div
91 :			infix 6 ^ + -
92 :			infix 3 := o
93 :			infix 4 > < >= <=
94 :			infixr 5 :: @
95 :			infix 0 before
96 :
97 :			exception Bind
98 :			exception Match
99 :
100 :			exception Range (* for word8array update *)
101 :			exception Subscript (* for all bounds checking *)
102 :			exception Size
103 :
104 :			local exception NoProfiler
105 :			in val profile_register =
106 :			ref(fn s:string => (raise NoProfiler):int*int array*int ref)
107 :			end
108 :
109 :			local val ieql : int * int -> bool = InLine.i31eq
110 :			val peql : 'a * 'a -> bool = InLine.ptreql
111 :			val ineq : int * int -> bool = InLine.i31ne
112 :			val i32eq : int32 * int32 -> bool = InLine.i32eq
113 :			val boxed : 'a -> bool = InLine.boxed
114 :			val op + : int * int -> int = InLine.i31add
115 :			val op - : int * int -> int = InLine.i31sub
116 :			val op * : int * int -> int = InLine.i31mul
117 :			val op := : 'a ref * 'a -> unit = InLine.:=
118 :			val ordof : string * int -> int = InLine.ordof
119 :			val cast : 'a -> 'b = InLine.cast
120 :			val getObjTag : 'a -> int = InLine.gettag
121 :			val getObjLen : 'a -> int = InLine.objlength
122 :			val getData : 'a -> 'b = InLine.getSeqData
123 :			val recSub : ('a * int) -> 'b = InLine.recordSub
124 :			val vecLen : 'a -> int = InLine.length
125 :			val vecSub : 'a vector * int -> 'a = InLine.vecSub
126 :			val andb : int * int -> int = InLine.i31andb
127 :			val lshift : int * int -> int = InLine.i31lshift
128 :
129 :			val width_tags = 7 (* 5 tag bits plus "10" *)
130 :
131 :			(* the type annotation is just to work around an bug - sm *)
132 :			val ltu : int * int -> bool = InLine.i31ltu
133 :
134 :			in
135 :
136 :			(* limit of array, string, etc. element count is one greater than
137 :			* the maximum length field value (sign should be 0).
138 :			*)
139 :			val max_length = lshift(1, 31 - width_tags) - 1
140 :
141 :			fun mkNormArray (n, init) =
142 :			if ieql(n, 0) then InLine.newArray0()
143 :			else if ltu(max_length, n) then raise Size
144 :			else Assembly.A.array (n, init)
145 :
146 :			val mkrarray : int -> real array = InLine.cast Assembly.A.create_r
147 :			fun mkRealArray (n : int, v : real) : real array =
148 :			if ieql(n, 0) then InLine.newArray0()
149 :			else if ltu(max_length, n) then raise Size
150 :			else let val x = mkrarray n
151 :			fun init i =
152 :			if ieql(i,n) then x
153 :			else (InLine.f64Update(x,i,v);
154 :			init ((op +) (i, 1)))
155 :			in init 0
156 :			end
157 :
158 :			val vector0 = Assembly.vector0 (* needed to compile ``#[]'' *)
159 :
160 :
161 :			(* LAZY: The following definitions are essentially stolen from
162 :			* SMLofNJ.Susp. Unfortunately, they had to be copied here in
163 :			* order to implement lazyness (in particular, in order to be
164 :			* able to compute pids for them.) *)
165 :
166 :			(* LAZY: The following is hard-wired and needs to track the object
167 :			* descriptor definitions.
168 :			*)
169 :			val TSUS = 0; (* == ObjectDesc.special_unevaled_susp *)
170 :			val TSES = 1; (* == ObjectDesc.special_evaled_susp *)
171 :
172 :			datatype 'a susp = Something of 'a (* Just a hack for bootstrapping *)
173 :
174 :			fun delay (f : unit -> 'a) = (InLine.mkspecial(TSUS , f)):('a susp)
175 :			fun force (x : 'a susp) =
176 :			if InLine.i31eq((InLine.getspecial x),TSUS)
177 :			then let
178 :			val y : 'a = recSub (InLine.cast x, 0) ()
179 :			in
180 :			(InLine.cast x) := y;
181 :			InLine.setspecial (InLine.cast x, TSES);
182 :			y
183 :			end
184 :			else recSub (InLine.cast x, 0)
185 :
186 :
187 :			(* equality primitives *)
188 :
189 :			fun stringequal (a : string, b : string) =
190 :			if peql(a,b)
191 :			then true
192 :			else let
193 :			val len = vecLen a
194 :			in
195 :			if ieql(len, vecLen b)
196 :			then let
197 :			fun f 0 = true
198 :			| f i = let
199 :			val j = i-1
200 :			in
201 :			ieql(ordof(a,j),ordof(b,j)) andalso f j
202 :			end
203 :			in
204 :			f len
205 :			end
206 :			else false
207 :			end
208 :
209 :			fun polyequal (a : 'a, b : 'a) = peql(a,b)
210 :			orelse (boxed a andalso boxed b
211 :			andalso let
212 :			(* NOTE: since GC may strip the header from the pair in question,
213 :			* we must fetch the length before getting the tag, whenever we
214 :			* might be dealing with a pair.
215 :			*)
216 :			val aLen = getObjLen a
217 :			val aTag = getObjTag a
218 :			fun pairEq () = let
219 :			val bLen = getObjLen b
220 :			val bTag = getObjTag b
221 :			in
222 :			((ieql(bTag, 0x02) andalso ieql(bLen, 2))
223 :			orelse ineq(andb(bTag, 0x3),0x2))
224 :			andalso polyequal(recSub(a, 0), recSub(b, 0))
225 :			andalso polyequal(recSub(a, 1), recSub(b, 1))
226 :			end
227 :			fun eqVecData (len, a, b) = let
228 :			fun f i = ieql(i, len)
229 :			orelse (polyequal(recSub(a, i), recSub(b, i))
230 :			andalso f(i+1))
231 :			in
232 :			f 0
233 :			end
234 :			in
235 :			case aTag
236 :			of 0x02 (* tag_record *) =>
237 :			(ieql(aLen, 2) andalso pairEq())
238 :			orelse (
239 :			ieql(getObjTag b, 0x02) andalso ieql(getObjLen b, aLen)
240 :			andalso eqVecData(aLen, a, b))
241 :			| 0x06 (* tag_vec_hdr *) => (
242 :			(* length encodes element type *)
243 :			case (getObjLen a)
244 :			of 0 (* seq_poly *) => let
245 :			val aLen = vecLen a
246 :			val bLen = vecLen b
247 :			in
248 :			ieql(aLen, bLen)
249 :			andalso eqVecData(aLen, getData a, getData b)
250 :			end
251 :			| 1 (* seq_word8 *) => stringequal(cast a, cast b)
252 :			| _ => raise Match (* shut up compiler *)
253 :			(* end case *))
254 :			| 0x0a (* tag_arr_hdr *) => peql(getData a, getData b)
255 :			| 0x0e (* tag_arr_data and tag_ref *) => false
256 :			| 0x12 (* tag_raw32 *) => i32eq(cast a, cast b)
257 :			| _ (* tagless pair *) => pairEq()
258 :			(* end case *)
259 :			end)
260 :
261 :			end (* local *)
262 :
263 :			val profile_sregister = ref(fn (x:Assembly.object,s:string)=>x)
264 :
265 :			end
266 :
267 :			(*
268 :			* $Log$
269 :	monnier	651	* Revision 1.3 2000/06/01 18:34:02 monnier
270 :			* bring revisions from the vendor branch to the trunk
271 :			*
272 :	blume	573	* Revision 1.2 2000/03/09 15:23:51 blume
273 :			* merging back changes from blume_devel_v110_26_2
274 :			*
275 :			* Revision 1.1.2.1 2000/03/08 09:59:16 blume
276 :			* directories reorganized (system in particular); much fewer anchors
277 :			*
278 :			* Revision 1.3 1998/05/23 14:09:57 george
279 :			* Fixed RCS keyword syntax
280 :			*
281 :			*
282 :			*)

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0