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

Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/kernel/primop.sml

Parent Directory Parent Directory | Revision Log Revision Log


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

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