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/MLRISC/mltree/mltree-gen.sml
ViewVC logotype

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

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