Annotation of /sml/trunk/src/MLRISC/mltree/mltree-gen.sml

Parent Directory | Revision Log

---

Revision 1117 - (view) (download)

1 :	jhr	1117	(* mltree-gen.sml
2 :			*
3 :			* COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
4 :			*
5 :	george	546	* This is a generic module for transforming MLTREE expressions:
6 :			* (1) expressions involving non-standard type widths are promoted when
7 :			* necessary.
8 :			* (2) operators that cannot be directly handled are expanded into
9 :			* more complex instruction sequences when necessary.
10 :			*
11 :			* -- Allen
12 :			*)
13 :
14 :	jhr	1117	functor MLTreeGen (
15 :			structure T : MLTREE
16 :			structure Cells : CELLS
17 :			val intTy : T.ty (* size of integer word *)
18 :	george	546
19 :			(* This is a list of possible data widths to promote to.
20 :			* The list must be in increasing sizes.
21 :			* We'll try to promote to the next largest size.
22 :			*)
23 :	jhr	1117	val naturalWidths : T.ty list
24 :	george	546
25 :			(*
26 :			* Are integers of widths less than the size of integer word.
27 :			* automatically sign extended, zero extended, or neither.
28 :			* When in doubt, choose neither since it is conservative.
29 :			*)
30 :	jhr	1117	datatype rep = SE | ZE | NEITHER
31 :			val rep : rep
32 :	george	546
33 :	jhr	1117	) : MLTREEGEN = struct
34 :	george	546
35 :			structure T = T
36 :	leunga	624	structure Size = MLTreeSize(structure T = T val intTy = intTy)
37 :	leunga	744	structure C = CellsBasis
38 :	george	546
39 :			exception Unsupported of string
40 :
41 :			fun error msg = MLRiscErrorMsg.error("MLTreeGen",msg)
42 :
43 :	george	761	val zeroT = T.LI(T.I.int_0)
44 :			fun LI i = T.LI(T.I.fromInt(intTy, i))
45 :
46 :	george	546	fun condOf(T.CC(cc,_)) = cc
47 :			| condOf(T.CMP(_,cc,_,_)) = cc
48 :			| condOf(T.CCMARK(cc,_)) = condOf cc
49 :			| condOf _ = error "condOf"
50 :
51 :			fun fcondOf(T.FCC(fcc,_)) = fcc
52 :			| fcondOf(T.FCMP(_,fcc,_,_)) = fcc
53 :			| fcondOf(T.CCMARK(cc,_)) = fcondOf cc
54 :			| fcondOf _ = error "fcondOf"
55 :
56 :			val W = intTy
57 :
58 :			(* To compute f.ty(a,b)
59 :			*
60 :			* let r1 <- a << (intTy - ty)
61 :			* r2 <- b << (intTy - ty)
62 :			* r3 <- f(a,b)
63 :			* in r3 ~>> (intTy - ty) end
64 :			*
65 :			* Lal showed me this neat trick!
66 :			*)
67 :			fun arith(rightShift,f,ty,a,b) =
68 :	george	761	let val shift = LI(W-ty)
69 :	george	546	in rightShift(W,f(W,T.SLL(W,a,shift),T.SLL(W,b,shift)),shift)
70 :			end
71 :
72 :	leunga	796	fun promoteTy(ty) =
73 :	george	546	let fun loop([]) =
74 :			raise Unsupported("can't promote integer width "^Int.toString ty)
75 :			| loop(t::ts) = if t > ty then t else loop ts
76 :			in loop(naturalWidths) end
77 :
78 :			fun promotable rightShift (e, f, ty, a, b) =
79 :			case naturalWidths of
80 :			[] => arith(rightShift,f,ty,a,b)
81 :	leunga	796	| _ => f(promoteTy(ty), a, b)
82 :	george	546
83 :			(*
84 :			* Translate integer expressions of unknown types into the appropriate
85 :			* term.
86 :			*)
87 :
88 :	george	761	fun compileRexp(exp) =
89 :	george	546	case exp of
90 :	leunga	775	T.CONST c => T.LABEXP exp
91 :	george	546
92 :			(* non overflow trapping ops *)
93 :	george	761	| T.NEG(ty,a) => T.SUB(ty, zeroT, a)
94 :	george	546	| T.ADD(ty,a,b) => promotable T.SRA (exp,T.ADD,ty,a,b)
95 :			| T.SUB(ty,a,b) => promotable T.SRA (exp,T.SUB,ty,a,b)
96 :			| T.MULS(ty,a,b) => promotable T.SRA (exp,T.MULS,ty,a,b)
97 :			| T.DIVS(ty,a,b) => promotable T.SRA (exp,T.DIVS,ty,a,b)
98 :			| T.REMS(ty,a,b) => promotable T.SRA (exp,T.REMS,ty,a,b)
99 :			| T.MULU(ty,a,b) => promotable T.SRL (exp,T.MULU,ty,a,b)
100 :			| T.DIVU(ty,a,b) => promotable T.SRL (exp,T.DIVU,ty,a,b)
101 :			| T.REMU(ty,a,b) => promotable T.SRL (exp,T.REMU,ty,a,b)
102 :
103 :			(* for overflow trapping ops; we have to do the simulation *)
104 :	george	761	| T.NEGT(ty,a) => T.SUBT(ty,zeroT,a)
105 :	george	546	| T.ADDT(ty,a,b) => arith (T.SRA,T.ADDT,ty,a,b)
106 :			| T.SUBT(ty,a,b) => arith (T.SRA,T.SUBT,ty,a,b)
107 :			| T.MULT(ty,a,b) => arith (T.SRA,T.MULT,ty,a,b)
108 :			| T.DIVT(ty,a,b) => arith (T.SRA,T.DIVT,ty,a,b)
109 :			| T.REMT(ty,a,b) => arith (T.SRA,T.REMT,ty,a,b)
110 :
111 :			(* conditional evaluation rules *)
112 :	george	761	(*** XXX: Seems wrong.
113 :	george	546	| T.COND(ty,T.CC(cond,r),x,y) =>
114 :	george	761	T.COND(ty,T.CMP(ty,cond,T.REG(ty,r),zeroT),x,y)
115 :			***)
116 :	george	546	| T.COND(ty,T.CCMARK(cc,a),x,y) => T.MARK(T.COND(ty,cc,x,y),a)
117 :	george	761	(*** XXX: TODO
118 :	george	546	| T.COND(ty,T.CMP(t,cc,e1,e2),x as (T.LI 0 | T.LI32 0w0),y) =>
119 :			T.COND(ty,T.CMP(t,T.Basis.negateCond cc,e1,e2),y,T.LI 0)
120 :			(* we'll let others strength reduce the multiply *)
121 :	jhr	1117	***)
122 :			| T.COND(ty,cc as T.FCMP _, yes, no) => let
123 :			val tmp = Cells.newReg()
124 :			in
125 :			T.LET(
126 :			T.SEQ[T.MV(ty, tmp, no), T.IF(cc, T.MV(ty, tmp, yes), T.SEQ [])],
127 :			T.REG(ty,tmp))
128 :			end
129 :			(*** XXX: TODO
130 :	george	546	| T.COND(ty,cc,e1,(T.LI 0 | T.LI32 0w0)) =>
131 :			T.MULU(ty,T.COND(ty,cc,T.LI 1,T.LI 0),e1)
132 :			| T.COND(ty,cc,T.LI m,T.LI n) =>
133 :			T.ADD(ty,T.MULU(ty,T.COND(ty,cc,T.LI 1,T.LI 0),T.LI(m-n)),T.LI n)
134 :	george	761	***)
135 :	george	546
136 :	george	761	| T.COND(ty,cc,e1,e2) =>
137 :			T.ADD(ty,T.MULU(ty,T.COND(ty,cc,T.LI T.I.int_1,zeroT),T.SUB(ty,e1,e2)),e2)
138 :
139 :	george	546	(* ones-complement.
140 :			* WARNING: we are assuming two's complement architectures here.
141 :			* Are there any architectures in use nowadays that doesn't use
142 :			* two's complement for integer arithmetic?
143 :			*)
144 :	george	761	| T.NOTB(ty,e) => T.XORB(ty,e,T.LI T.I.int_m1)
145 :	george	546
146 :			(*
147 :			* Default ways of converting integers to integers
148 :			*)
149 :	leunga	744	| T.SX(ty,fromTy,e) =>
150 :	george	546	if fromTy = ty then e
151 :			else if rep = SE andalso fromTy < ty andalso
152 :			fromTy >= hd naturalWidths then e
153 :			else
154 :	george	761	let val shift = T.LI(T.I.fromInt(intTy, W - fromTy))
155 :	george	546	in T.SRA(W,T.SLL(W,e,shift),shift)
156 :			end
157 :	leunga	744	| T.ZX(ty,fromTy,e) =>
158 :	george	546	if fromTy <= ty then e else
159 :			(case ty of (* ty < fromTy *)
160 :	george	761	8 => T.ANDB(ty,e,T.LI T.I.int_0xff)
161 :			| 16 => T.ANDB(ty,e,T.LI T.I.int_0xffff)
162 :			| 32 => T.ANDB(ty,e,T.LI T.I.int_0xffffffff)
163 :	george	546	| 64 => e
164 :			| _ => raise Unsupported("unknown expression")
165 :			)
166 :
167 :			(*
168 :			* Converting floating point to integers.
169 :			* The following rule handles the case when ty is not
170 :			* one of the naturally supported widths on the machine.
171 :			*)
172 :			| T.CVTF2I(ty,round,fty,e) =>
173 :	leunga	796	let val ty' = promoteTy(ty)
174 :	leunga	744	in T.SX(ty,ty',T.CVTF2I(ty',round,fty,e))
175 :	george	546	end
176 :
177 :	leunga	796	(* Promote to higher width and zero high bits *)
178 :			| T.SLL(ty, data, shift) =>
179 :			let val ty' = promoteTy(ty)
180 :			in T.ZX(ty, ty', T.SLL(ty', data, shift)) end
181 :
182 :	george	546	| exp => raise Unsupported("unknown expression")
183 :
184 :			fun compileFexp fexp = raise Unsupported("unknown expression")
185 :
186 :			fun mark(s,[]) = s
187 :			| mark(s,a::an) = mark(T.ANNOTATION(s,a),an)
188 :
189 :			fun compileStm (T.SEQ s) = s
190 :	leunga	775	| compileStm (T.IF(cond,T.JMP(T.LABEL L,_),T.SEQ [])) =
191 :	leunga	744	[T.BCC(cond,L)]
192 :			| compileStm (T.IF(cond,yes,no)) =
193 :	george	909	let val L1 = Label.anon()
194 :			val L2 = Label.anon()
195 :	leunga	744	in [T.BCC(cond,L1),
196 :	george	546	no,
197 :	leunga	775	T.JMP(T.LABEL L2,[]),
198 :	george	546	T.DEFINE L1,
199 :			yes,
200 :			T.DEFINE L2
201 :			]
202 :			end
203 :			| compileStm stm = error "compileStm"
204 :
205 :			(*
206 :			* This function translations conditional expressions into a
207 :			* branch sequence.
208 :			* Note: we'll actually take advantage of the fact that
209 :			* e1 and e2 are allowed to be eagerly evaluated.
210 :			*)
211 :			fun compileCond{exp=(ty,ccexp,e1,e2),rd,an} =
212 :	george	909	let val L1 = Label.anon()
213 :	george	546	in [T.MV(ty,rd,e1),
214 :	leunga	744	mark(T.BCC(ccexp,L1),an),
215 :	george	546	T.MV(ty,rd,e2),
216 :			T.DEFINE L1
217 :			]
218 :			end
219 :			fun compileFcond{exp=(fty,ccexp,e1,e2),fd,an} =
220 :	george	909	let val L1 = Label.anon()
221 :	george	546	in [T.FMV(fty,fd,e1),
222 :	leunga	744	mark(T.BCC(ccexp,L1),an),
223 :	george	546	T.FMV(fty,fd,e2),
224 :			T.DEFINE L1
225 :			]
226 :			end
227 :
228 :			end

---

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