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/compiler/FLINT/kernel/primop.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log 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