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 46 - (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 :     | GETRUNVEC (* get the pointer to the run-vector *)
59 :     | MARKEXN (* mark an exception value with a string *)
60 :     | GETHDLR | SETHDLR (* get/set exn handler pointer *)
61 :     | GETVAR | SETVAR (* get/set var register *)
62 :     | GETPSEUDO | SETPSEUDO (* get/set pseudo registers *)
63 :     | SETMARK | DISPOSE (* capture/dispose frames *)
64 :     | MAKEREF (* allocate a ref cell *)
65 :     | CALLCC | CAPTURE | THROW (* continuation operations *)
66 :     | ISOLATE (* isolating a function *)
67 :     | DEREF (* dereferencing *)
68 :     | ASSIGN (* assignment; shorthand for update(a, 0, v) *)
69 :     | UPDATE (* array or reference update (maybe boxed) *)
70 :     | INLUPDATE (* inline array update (maybe boxed) *)
71 :     | BOXEDUPDATE (* boxed array update *)
72 :     | UNBOXEDUPDATE (* update array of integers WITH tags *)
73 :    
74 :     | GETTAG (* extract the tag portion of an *)
75 :     (* object's descriptor as an ML int *)
76 :     | MKSPECIAL (* make a special object *)
77 :     | SETSPECIAL (* set the state of a special object *)
78 :     | GETSPECIAL (* get the state of a special object *)
79 :     | USELVAR | DEFLVAR
80 :     | INLDIV | INLMOD | INLREM (* inline interger arithmetic *)
81 :     | INLMIN |INLMAX | INLABS (* inline interger arithmetic *)
82 :     | INLNOT (* inline bool not operator *)
83 :     | INLCOMPOSE (* inline compose "op o" operator *)
84 :     | INLBEFORE (* inline "before" operator *)
85 :     | INL_ARRAY (* inline polymorphic array allocation *)
86 :     | INL_VECTOR (* inline polymorphic vector allocation *)
87 :     | INL_MONOARRAY of numkind (* inline monomorphic array allocation *)
88 :     | INL_MONOVECTOR of numkind (* inline monomorphic vector allocation *)
89 :    
90 : monnier 45 | MKETAG (* make a new exception tag *)
91 :     | WRAP (* box a value by wrapping it *)
92 :     | UNWRAP (* unbox a value by unwrapping it *)
93 :    
94 :    
95 : monnier 16 (** default integer arithmetic and comparison operators *)
96 :     val IADD = ARITH{oper=op +, overflow=true, kind=INT 31}
97 :     val ISUB = ARITH{oper=op -, overflow=true, kind=INT 31}
98 :     val IMUL = ARITH{oper=op *, overflow=true, kind=INT 31}
99 :     val IDIV = ARITH{oper=op /, overflow=true, kind=INT 31}
100 :     val INEG = ARITH{oper=op ~, overflow=true, kind=INT 31}
101 :    
102 :     val IEQL = CMP{oper=EQL, kind=INT 31}
103 :     val INEQ = CMP{oper=NEQ, kind=INT 31}
104 :     val IGT = CMP{oper=op >, kind=INT 31}
105 :     val ILT = CMP{oper=op <, kind=INT 31}
106 :     val IGE = CMP{oper=op >=, kind=INT 31}
107 :     val ILE = CMP{oper=op <=, kind=INT 31}
108 :    
109 :     (** default floating-point equality operator *)
110 :     val FEQLd = CMP{oper=EQL, kind=FLOAT 64}
111 :    
112 :     (**************************************************************************
113 :     * OTHER PRIMOP-RELATED UTILITY FUNCTIONS *
114 :     **************************************************************************)
115 :    
116 :     fun prNumkind (INT 31) = ""
117 :     | prNumkind (INT bits) = Int.toString bits
118 :     | prNumkind (UINT 32) = "u"
119 :     | prNumkind (UINT bits) = "u" ^ Int.toString bits
120 :     | prNumkind (FLOAT 64) = "f"
121 :     | prNumkind (FLOAT bits) = "f" ^ Int.toString bits
122 :    
123 :    
124 :     fun cvtParams(from, to) = Int.toString from ^ "_" ^ Int.toString to
125 :    
126 :     fun prPrimop (ARITH{oper,overflow,kind}) =
127 :     ((case oper
128 :     of op + => "+" | op - => "-" | op * => "*"
129 :     | op / => "/" | op ~ => "~" | LSHIFT => "lshift"
130 :     | RSHIFT => "rshift" | RSHIFTL => "rshift_l" | ABS => "abs"
131 :     | ANDB => "andb" | ORB => "orb" | XORB => "xorb"
132 :     | NOTB => "notb")
133 :     ^ (if overflow then "" else "n")
134 :     ^ prNumkind kind)
135 :    
136 :     | prPrimop (INLLSHIFT kind) = "inllshift" ^ prNumkind kind
137 :     | prPrimop (INLRSHIFT kind) = "inlrshift" ^ prNumkind kind
138 :     | prPrimop (INLRSHIFTL kind) = "inlrshiftl" ^ prNumkind kind
139 :    
140 :     | prPrimop (CMP{oper,kind}) =
141 :     ((case oper
142 :     of op > => ">" | op < => "<" | op >= => ">=" | op <= => "<="
143 :     | GEU => ">=U" | GTU => ">U" | LEU => "<=U" | LTU => "<U"
144 :     | EQL => "=" | NEQ => "<>" )
145 :     ^ prNumkind kind)
146 :    
147 :     | prPrimop(TEST arg) = "test_" ^ cvtParams arg
148 :     | prPrimop(TESTU arg) = "test_" ^ cvtParams arg
149 :     | prPrimop(EXTEND arg) = "extend" ^ cvtParams arg
150 :     | prPrimop(TRUNC arg) = "trunc" ^ cvtParams arg
151 :     | prPrimop(COPY arg) = "copy" ^ cvtParams arg
152 :    
153 :     | prPrimop(ROUND{floor=true,fromkind=FLOAT 64,tokind=INT 31}) = "floor"
154 :     | prPrimop(ROUND{floor=false,fromkind=FLOAT 64,tokind=INT 31}) = "round"
155 :     | prPrimop(ROUND{floor,fromkind,tokind}) =
156 :     ((if floor then "floor" else "round")
157 :     ^ prNumkind fromkind ^ "_" ^ prNumkind tokind)
158 :    
159 :     | prPrimop(REAL{fromkind=INT 31,tokind=FLOAT 64}) = "real"
160 :     | prPrimop(REAL{fromkind,tokind}) =
161 :     ("real" ^ prNumkind fromkind ^ "_" ^ prNumkind tokind)
162 :    
163 :     | prPrimop(NUMSUBSCRIPT{kind,checked,immutable}) =
164 :     ("numsubscript" ^ prNumkind kind
165 :     ^ (if checked then "c" else "")
166 :     ^ (if immutable then "v" else ""))
167 :    
168 :     | prPrimop (NUMUPDATE{kind,checked}) =
169 :     ("numupdate" ^ prNumkind kind ^ (if checked then "c" else ""))
170 :    
171 :     | prPrimop DEREF = "!"
172 :     | prPrimop ASSIGN = ":="
173 :     | prPrimop BOXED = "boxed"
174 :     | prPrimop UNBOXED = "unboxed"
175 :     | prPrimop CAST = "cast"
176 :     | prPrimop PTREQL = "ptreql"
177 :     | prPrimop PTRNEQ = "ptrneq"
178 :     | prPrimop POLYEQL = "polyeql"
179 :     | prPrimop POLYNEQ = "polyneq"
180 :     | prPrimop GETHDLR = "gethdlr"
181 :     | prPrimop MAKEREF = "makeref"
182 :     | prPrimop SETHDLR = "sethdlr"
183 :     | prPrimop LENGTH = "length"
184 :     | prPrimop OBJLENGTH = "objlength"
185 :     | prPrimop CALLCC = "callcc"
186 :     | prPrimop CAPTURE = "capture"
187 :     | prPrimop ISOLATE = "isolate"
188 :     | prPrimop THROW = "throw"
189 :     | prPrimop SUBSCRIPT = "subscript"
190 :     | prPrimop UNBOXEDUPDATE = "unboxedupdate"
191 :     | prPrimop BOXEDUPDATE = "boxedupdate"
192 :     | prPrimop UPDATE = "update"
193 :     | prPrimop INLSUBSCRIPT = "inlsubscript"
194 :     | prPrimop INLSUBSCRIPTV = "inlsubscriptv"
195 :     | prPrimop INLUPDATE = "inlupdate"
196 :     | prPrimop INLMKARRAY = "inlmkarray"
197 :     | prPrimop SUBSCRIPTV = "subscriptv"
198 :     | prPrimop GETRUNVEC = "getrunvec"
199 :     | prPrimop GETVAR = "getvar"
200 :     | prPrimop SETVAR = "setvar"
201 :     | prPrimop GETPSEUDO = "getpseudo"
202 :     | prPrimop SETPSEUDO = "setpseudo"
203 :     | prPrimop SETMARK = "setmark"
204 :     | prPrimop DISPOSE = "dispose"
205 :     | prPrimop GETTAG = "gettag"
206 :     | prPrimop MKSPECIAL = "mkspecial"
207 :     | prPrimop SETSPECIAL = "setspecial"
208 :     | prPrimop GETSPECIAL = "getspecial"
209 :     | prPrimop USELVAR = "uselvar"
210 :     | prPrimop DEFLVAR = "deflvar"
211 :     | prPrimop INLDIV = "inldiv"
212 :     | prPrimop INLMOD = "inlmod"
213 :     | prPrimop INLREM = "inlrem"
214 :     | prPrimop INLMIN = "inlmin"
215 :     | prPrimop INLMAX = "inlmax"
216 :     | prPrimop INLABS = "inlabs"
217 :     | prPrimop INLNOT = "inlnot"
218 :     | prPrimop INLCOMPOSE = "inlcompose"
219 :     | prPrimop INLBEFORE = "inlbefore"
220 :     | prPrimop (INL_ARRAY) = "inl_array"
221 :     | prPrimop (INL_VECTOR) = "inl_vector"
222 :     | prPrimop (INL_MONOARRAY kind) =
223 :     concat ["inl_monoarray(", prNumkind kind, ")"]
224 :     | prPrimop (INL_MONOVECTOR kind) =
225 :     concat ["inl_monovector(", prNumkind kind, ")"]
226 :     | prPrimop (MARKEXN) = "markexn"
227 :    
228 : monnier 45 | prPrimop (MKETAG) = "mketag"
229 :     | prPrimop (WRAP) = "wrap"
230 :     | prPrimop (UNWRAP) = "unwrap"
231 : monnier 16
232 :     val purePrimop =
233 :     fn DEREF => false
234 :     | ASSIGN => false
235 :     (* this should probably should never be called on ASSIGN *)
236 :     | SUBSCRIPT => false
237 :     | BOXEDUPDATE => false
238 :     | UNBOXEDUPDATE => false
239 :     | UPDATE => false
240 :     | CAPTURE => false
241 :     | CALLCC => false
242 :     | ISOLATE => false
243 :     | ARITH{overflow,...} => not overflow
244 :     | NUMSUBSCRIPT{immutable,...} => immutable
245 :     | GETSPECIAL => false
246 :     | SETSPECIAL => false
247 :     | _ => true
248 :    
249 :     val mayRaise =
250 :     fn ARITH{overflow,...} => overflow
251 :     | ROUND _ => true
252 :     | INLMKARRAY => true
253 :     | INLSUBSCRIPT => true
254 :     | INLUPDATE => true
255 :     | INLSUBSCRIPTV => true
256 :     | NUMSUBSCRIPT{checked,...} => checked
257 :     | NUMUPDATE{checked,...} => checked
258 :     | _ => false
259 :    
260 :     end (* structure PrimOp *)
261 :    

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