Annotation of /sml/trunk/src/compiler/FLINT/kernel/primop.sml

Parent Directory | Revision Log

---

Revision 213 - (view) (download)

1 :	monnier	16	(* Copyright 1996 by AT&T Bell Laboratories *)
2 :			(* primop.sml *)
3 :
4 :			structure PrimOp : PRIM_OP =
5 :			struct
6 :
7 :			(* numkind includes kind and number of bits *)
8 :			datatype numkind
9 :			= INT of int
10 :			| UINT of int
11 :			| FLOAT of int
12 :
13 :			datatype arithop
14 :			= + | - | * | / | ~ (* int or float *)
15 :			| ABS (* floating point only *)
16 :			| LSHIFT | RSHIFT | RSHIFTL (* int only *)
17 :			| ANDB | ORB | XORB | NOTB (* int only *)
18 :
19 :			datatype cmpop = > | >= | < | <= | LEU | LTU | GEU | GTU | EQL | NEQ
20 :
21 :			(*
22 :			* Various primitive operations. Those that are designated "inline" are
23 :			* expanded into lambda code in terms of other operators,
24 :			* as is the "checked=true" version of NUMSUBSCRIPT or NUMUPDATE.
25 :			*)
26 :
27 :			datatype primop
28 :			= ARITH of {oper: arithop, overflow: bool, kind: numkind}
29 :			| INLLSHIFT of numkind
30 :			| INLRSHIFT of numkind
31 :			| INLRSHIFTL of numkind
32 :			| CMP of {oper: cmpop, kind: numkind}
33 :
34 :			| TESTU of int * int
35 :			| TEST of int * int
36 :			| TRUNC of int * int
37 :			| EXTEND of int * int
38 :			| COPY of int * int
39 :
40 :			| ROUND of {floor: bool, fromkind: numkind, tokind: numkind}
41 :			| REAL of {fromkind: numkind, tokind: numkind}
42 :
43 :			| NUMSUBSCRIPT of {kind: numkind, checked: bool, immutable: bool}
44 :			| NUMUPDATE of {kind: numkind, checked: bool}
45 :
46 :			| SUBSCRIPT (* polymorphic array subscript *)
47 :			| SUBSCRIPTV (* poly vector subscript *)
48 :			| INLSUBSCRIPT (* inline poly array subscript *)
49 :			| INLSUBSCRIPTV (* inline poly vector subscript *)
50 :			| INLMKARRAY (* inline poly array creation *)
51 :
52 :			| PTREQL | PTRNEQ (* pointer equality *)
53 :			| POLYEQL | POLYNEQ (* polymorphic equality *)
54 :			| BOXED | UNBOXED (* boxity tests *)
55 :			| LENGTH (* vector, string, array, ... length *)
56 :			| OBJLENGTH (* length of arbitrary heap object *)
57 :			| CAST
58 :	monnier	69	| WCAST
59 :	monnier	16	| GETRUNVEC (* get the pointer to the run-vector *)
60 :			| MARKEXN (* mark an exception value with a string *)
61 :			| GETHDLR | SETHDLR (* get/set exn handler pointer *)
62 :			| GETVAR | SETVAR (* get/set var register *)
63 :			| GETPSEUDO | SETPSEUDO (* get/set pseudo registers *)
64 :			| SETMARK | DISPOSE (* capture/dispose frames *)
65 :			| MAKEREF (* allocate a ref cell *)
66 :			| CALLCC | CAPTURE | THROW (* continuation operations *)
67 :			| ISOLATE (* isolating a function *)
68 :			| DEREF (* dereferencing *)
69 :			| ASSIGN (* assignment; shorthand for update(a, 0, v) *)
70 :			| UPDATE (* array or reference update (maybe boxed) *)
71 :			| INLUPDATE (* inline array update (maybe boxed) *)
72 :			| BOXEDUPDATE (* boxed array update *)
73 :			| UNBOXEDUPDATE (* update array of integers WITH tags *)
74 :
75 :			| GETTAG (* extract the tag portion of an *)
76 :			(* object's descriptor as an ML int *)
77 :			| MKSPECIAL (* make a special object *)
78 :			| SETSPECIAL (* set the state of a special object *)
79 :			| GETSPECIAL (* get the state of a special object *)
80 :			| USELVAR | DEFLVAR
81 :			| INLDIV | INLMOD | INLREM (* inline interger arithmetic *)
82 :			| INLMIN |INLMAX | INLABS (* inline interger arithmetic *)
83 :			| INLNOT (* inline bool not operator *)
84 :			| INLCOMPOSE (* inline compose "op o" operator *)
85 :			| INLBEFORE (* inline "before" operator *)
86 :			| INL_ARRAY (* inline polymorphic array allocation *)
87 :			| INL_VECTOR (* inline polymorphic vector allocation *)
88 :			| INL_MONOARRAY of numkind (* inline monomorphic array allocation *)
89 :			| INL_MONOVECTOR of numkind (* inline monomorphic vector allocation *)
90 :
91 :	monnier	45	| MKETAG (* make a new exception tag *)
92 :			| WRAP (* box a value by wrapping it *)
93 :			| UNWRAP (* unbox a value by unwrapping it *)
94 :
95 :
96 :	monnier	16	(** default integer arithmetic and comparison operators *)
97 :			val IADD = ARITH{oper=op +, overflow=true, kind=INT 31}
98 :			val ISUB = ARITH{oper=op -, overflow=true, kind=INT 31}
99 :			val IMUL = ARITH{oper=op *, overflow=true, kind=INT 31}
100 :			val IDIV = ARITH{oper=op /, overflow=true, kind=INT 31}
101 :			val INEG = ARITH{oper=op ~, overflow=true, kind=INT 31}
102 :
103 :			val IEQL = CMP{oper=EQL, kind=INT 31}
104 :			val INEQ = CMP{oper=NEQ, kind=INT 31}
105 :			val IGT = CMP{oper=op >, kind=INT 31}
106 :			val ILT = CMP{oper=op <, kind=INT 31}
107 :			val IGE = CMP{oper=op >=, kind=INT 31}
108 :			val ILE = CMP{oper=op <=, kind=INT 31}
109 :
110 :			(** default floating-point equality operator *)
111 :			val FEQLd = CMP{oper=EQL, kind=FLOAT 64}
112 :
113 :			(**************************************************************************
114 :			* OTHER PRIMOP-RELATED UTILITY FUNCTIONS *
115 :			**************************************************************************)
116 :
117 :			fun prNumkind (INT 31) = ""
118 :			| prNumkind (INT bits) = Int.toString bits
119 :			| prNumkind (UINT 32) = "u"
120 :			| prNumkind (UINT bits) = "u" ^ Int.toString bits
121 :			| prNumkind (FLOAT 64) = "f"
122 :			| prNumkind (FLOAT bits) = "f" ^ Int.toString bits
123 :
124 :
125 :			fun cvtParams(from, to) = Int.toString from ^ "_" ^ Int.toString to
126 :
127 :			fun prPrimop (ARITH{oper,overflow,kind}) =
128 :			((case oper
129 :			of op + => "+" | op - => "-" | op * => "*"
130 :			| op / => "/" | op ~ => "~" | LSHIFT => "lshift"
131 :			| RSHIFT => "rshift" | RSHIFTL => "rshift_l" | ABS => "abs"
132 :			| ANDB => "andb" | ORB => "orb" | XORB => "xorb"
133 :			| NOTB => "notb")
134 :			^ (if overflow then "" else "n")
135 :			^ prNumkind kind)
136 :
137 :			| prPrimop (INLLSHIFT kind) = "inllshift" ^ prNumkind kind
138 :			| prPrimop (INLRSHIFT kind) = "inlrshift" ^ prNumkind kind
139 :			| prPrimop (INLRSHIFTL kind) = "inlrshiftl" ^ prNumkind kind
140 :
141 :			| prPrimop (CMP{oper,kind}) =
142 :			((case oper
143 :			of op > => ">" | op < => "<" | op >= => ">=" | op <= => "<="
144 :			| GEU => ">=U" | GTU => ">U" | LEU => "<=U" | LTU => "<U"
145 :			| EQL => "=" | NEQ => "<>" )
146 :			^ prNumkind kind)
147 :
148 :			| prPrimop(TEST arg) = "test_" ^ cvtParams arg
149 :			| prPrimop(TESTU arg) = "test_" ^ cvtParams arg
150 :			| prPrimop(EXTEND arg) = "extend" ^ cvtParams arg
151 :			| prPrimop(TRUNC arg) = "trunc" ^ cvtParams arg
152 :			| prPrimop(COPY arg) = "copy" ^ cvtParams arg
153 :
154 :			| prPrimop(ROUND{floor=true,fromkind=FLOAT 64,tokind=INT 31}) = "floor"
155 :			| prPrimop(ROUND{floor=false,fromkind=FLOAT 64,tokind=INT 31}) = "round"
156 :			| prPrimop(ROUND{floor,fromkind,tokind}) =
157 :			((if floor then "floor" else "round")
158 :			^ prNumkind fromkind ^ "_" ^ prNumkind tokind)
159 :
160 :			| prPrimop(REAL{fromkind=INT 31,tokind=FLOAT 64}) = "real"
161 :			| prPrimop(REAL{fromkind,tokind}) =
162 :			("real" ^ prNumkind fromkind ^ "_" ^ prNumkind tokind)
163 :
164 :			| prPrimop(NUMSUBSCRIPT{kind,checked,immutable}) =
165 :			("numsubscript" ^ prNumkind kind
166 :			^ (if checked then "c" else "")
167 :			^ (if immutable then "v" else ""))
168 :
169 :			| prPrimop (NUMUPDATE{kind,checked}) =
170 :			("numupdate" ^ prNumkind kind ^ (if checked then "c" else ""))
171 :
172 :			| prPrimop DEREF = "!"
173 :			| prPrimop ASSIGN = ":="
174 :			| prPrimop BOXED = "boxed"
175 :			| prPrimop UNBOXED = "unboxed"
176 :			| prPrimop CAST = "cast"
177 :	monnier	69	| prPrimop WCAST = "wcast"
178 :	monnier	16	| prPrimop PTREQL = "ptreql"
179 :			| prPrimop PTRNEQ = "ptrneq"
180 :			| prPrimop POLYEQL = "polyeql"
181 :			| prPrimop POLYNEQ = "polyneq"
182 :			| prPrimop GETHDLR = "gethdlr"
183 :			| prPrimop MAKEREF = "makeref"
184 :			| prPrimop SETHDLR = "sethdlr"
185 :			| prPrimop LENGTH = "length"
186 :			| prPrimop OBJLENGTH = "objlength"
187 :			| prPrimop CALLCC = "callcc"
188 :			| prPrimop CAPTURE = "capture"
189 :			| prPrimop ISOLATE = "isolate"
190 :			| prPrimop THROW = "throw"
191 :			| prPrimop SUBSCRIPT = "subscript"
192 :			| prPrimop UNBOXEDUPDATE = "unboxedupdate"
193 :			| prPrimop BOXEDUPDATE = "boxedupdate"
194 :			| prPrimop UPDATE = "update"
195 :			| prPrimop INLSUBSCRIPT = "inlsubscript"
196 :			| prPrimop INLSUBSCRIPTV = "inlsubscriptv"
197 :			| prPrimop INLUPDATE = "inlupdate"
198 :			| prPrimop INLMKARRAY = "inlmkarray"
199 :			| prPrimop SUBSCRIPTV = "subscriptv"
200 :			| prPrimop GETRUNVEC = "getrunvec"
201 :			| prPrimop GETVAR = "getvar"
202 :			| prPrimop SETVAR = "setvar"
203 :			| prPrimop GETPSEUDO = "getpseudo"
204 :			| prPrimop SETPSEUDO = "setpseudo"
205 :			| prPrimop SETMARK = "setmark"
206 :			| prPrimop DISPOSE = "dispose"
207 :			| prPrimop GETTAG = "gettag"
208 :			| prPrimop MKSPECIAL = "mkspecial"
209 :			| prPrimop SETSPECIAL = "setspecial"
210 :			| prPrimop GETSPECIAL = "getspecial"
211 :			| prPrimop USELVAR = "uselvar"
212 :			| prPrimop DEFLVAR = "deflvar"
213 :			| prPrimop INLDIV = "inldiv"
214 :			| prPrimop INLMOD = "inlmod"
215 :			| prPrimop INLREM = "inlrem"
216 :			| prPrimop INLMIN = "inlmin"
217 :			| prPrimop INLMAX = "inlmax"
218 :			| prPrimop INLABS = "inlabs"
219 :			| prPrimop INLNOT = "inlnot"
220 :			| prPrimop INLCOMPOSE = "inlcompose"
221 :			| prPrimop INLBEFORE = "inlbefore"
222 :			| prPrimop (INL_ARRAY) = "inl_array"
223 :			| prPrimop (INL_VECTOR) = "inl_vector"
224 :			| prPrimop (INL_MONOARRAY kind) =
225 :			concat ["inl_monoarray(", prNumkind kind, ")"]
226 :			| prPrimop (INL_MONOVECTOR kind) =
227 :			concat ["inl_monovector(", prNumkind kind, ")"]
228 :			| prPrimop (MARKEXN) = "markexn"
229 :
230 :	monnier	45	| prPrimop (MKETAG) = "mketag"
231 :			| prPrimop (WRAP) = "wrap"
232 :			| prPrimop (UNWRAP) = "unwrap"
233 :	monnier	16
234 :			val purePrimop =
235 :			fn DEREF => false
236 :			| ASSIGN => false
237 :			| SUBSCRIPT => false
238 :			| BOXEDUPDATE => false
239 :			| UNBOXEDUPDATE => false
240 :			| UPDATE => false
241 :			| CAPTURE => false
242 :			| CALLCC => false
243 :			| ISOLATE => false
244 :			| ARITH{overflow,...} => not overflow
245 :			| NUMSUBSCRIPT{immutable,...} => immutable
246 :	monnier	202	| NUMUPDATE _ => false
247 :	monnier	16	| GETSPECIAL => false
248 :	monnier	202	| (SETSPECIAL | SETHDLR | SETVAR | SETPSEUDO | SETMARK) => false
249 :			| THROW => false
250 :			| (DISPOSE | MKSPECIAL | DEFLVAR | MARKEXN) => false
251 :	monnier	16	| _ => true
252 :	monnier	204
253 :			(* should return more than just a boolean *)
254 :			val effect =
255 :	monnier	213	fn ARITH{overflow,...} => overflow
256 :	monnier	204	| (INLRSHIFT _ | INLRSHIFTL _) => false
257 :			| CMP _ => false
258 :			| (EXTEND _ | TRUNC _ | COPY _) => false
259 :			| (PTREQL | PTRNEQ | POLYEQL | POLYNEQ) => false
260 :			| (BOXED | UNBOXED) => false
261 :			| (LENGTH | OBJLENGTH) => false
262 :			| (CAST | WCAST) => false
263 :			| (MAKEREF | DEREF) => false
264 :			| (INLMIN | INLMAX | INLNOT | INLCOMPOSE) => false
265 :			| (INL_ARRAY | INL_VECTOR | INL_MONOARRAY _ | INL_MONOVECTOR _) => false
266 :			| (WRAP | UNWRAP) => false
267 :	monnier	213	| _ => true
268 :	monnier	16
269 :			val mayRaise =
270 :			fn ARITH{overflow,...} => overflow
271 :			| ROUND _ => true
272 :			| INLMKARRAY => true
273 :			| INLSUBSCRIPT => true
274 :			| INLUPDATE => true
275 :			| INLSUBSCRIPTV => true
276 :			| NUMSUBSCRIPT{checked,...} => checked
277 :			| NUMUPDATE{checked,...} => checked
278 :			| _ => false
279 :
280 :			end (* structure PrimOp *)
281 :
282 :	monnier	93
283 :			(*
284 :	monnier	113	* $Log$
285 :	monnier	93	*)

---

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