Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/system/Init/core.sml
ViewVC logotype

Annotation of /sml/trunk/src/system/Init/core.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 416 - (view) (download)

1 : monnier 416 (* 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 :     val aTag = getObjTag a
213 :     fun pairEq () = let
214 :     val bTag = getObjTag b
215 :     in
216 :     ((ieql(bTag, 0x02) andalso ieql(getObjLen b, 2))
217 :     orelse ineq(andb(bTag, 0x3),0x2))
218 :     andalso polyequal(recSub(a, 0), recSub(b, 0))
219 :     andalso polyequal(recSub(a, 1), recSub(b, 1))
220 :     end
221 :     fun eqVecData (len, a, b) = let
222 :     fun f i = ieql(i, len)
223 :     orelse (polyequal(recSub(a, i), recSub(b, i))
224 :     andalso f(i+1))
225 :     in
226 :     f 0
227 :     end
228 :     in
229 :     case aTag
230 :     of 0x02 (* tag_record *) => let
231 :     val aLen = getObjLen a
232 :     in
233 :     (ieql(aLen, 2) andalso pairEq())
234 :     orelse (
235 :     ieql(getObjTag b, 0x02) andalso ieql(getObjLen b, aLen)
236 :     andalso eqVecData(aLen, a, b))
237 :     end
238 :     | 0x06 (* tag_vec_hdr *) => (
239 :     (* length encodes element type *)
240 :     case (getObjLen a)
241 :     of 0 (* seq_poly *) => let
242 :     val aLen = vecLen a
243 :     val bLen = vecLen b
244 :     in
245 :     ieql(aLen, bLen)
246 :     andalso eqVecData(aLen, getData a, getData b)
247 :     end
248 :     | 1 (* seq_word8 *) => stringequal(cast a, cast b)
249 :     (* end case *))
250 :     | 0x0a (* tag_arr_hdr *) => peql(getData a, getData b)
251 :     | 0x0e (* tag_arr_data and tag_ref *) => false
252 :     | 0x12 (* tag_raw32 *) => i32eq(cast a, cast b)
253 :     | _ (* tagless pair *) => pairEq()
254 :     (* end case *)
255 :     end)
256 :    
257 :     end (* local *)
258 :    
259 :     val profile_sregister = ref(fn (x:Assembly.object,s:string)=>x)
260 :    
261 :     end
262 :    

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