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 761 - (view) (download)

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

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