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 744 - (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 :     fun condOf(T.CC(cc,_)) = cc
42 :     | condOf(T.CMP(_,cc,_,_)) = cc
43 :     | condOf(T.CCMARK(cc,_)) = condOf cc
44 :     | condOf _ = error "condOf"
45 :    
46 :     fun fcondOf(T.FCC(fcc,_)) = fcc
47 :     | fcondOf(T.FCMP(_,fcc,_,_)) = fcc
48 :     | fcondOf(T.CCMARK(cc,_)) = fcondOf cc
49 :     | fcondOf _ = error "fcondOf"
50 :    
51 :     val W = intTy
52 :    
53 :     (* To compute f.ty(a,b)
54 :     *
55 :     * let r1 <- a << (intTy - ty)
56 :     * r2 <- b << (intTy - ty)
57 :     * r3 <- f(a,b)
58 :     * in r3 ~>> (intTy - ty) end
59 :     *
60 :     * Lal showed me this neat trick!
61 :     *)
62 :     fun arith(rightShift,f,ty,a,b) =
63 :     let val shift = T.LI(W-ty)
64 :     in rightShift(W,f(W,T.SLL(W,a,shift),T.SLL(W,b,shift)),shift)
65 :     end
66 :    
67 :     fun promoteTy(e,ty) =
68 :     let fun loop([]) =
69 :     raise Unsupported("can't promote integer width "^Int.toString ty)
70 :     | loop(t::ts) = if t > ty then t else loop ts
71 :     in loop(naturalWidths) end
72 :    
73 :     fun promotable rightShift (e, f, ty, a, b) =
74 :     case naturalWidths of
75 :     [] => arith(rightShift,f,ty,a,b)
76 :     | _ => f(promoteTy(e, ty), a, b)
77 :    
78 :     (*
79 :     * Translate integer expressions of unknown types into the appropriate
80 :     * term.
81 :     *)
82 :    
83 :     fun compileRexp(exp) =
84 :     case exp of
85 :     T.CONST c => T.LABEL(T.LabelExp.CONST c)
86 :    
87 :     (* non overflow trapping ops *)
88 :     | T.NEG(ty,a) => T.SUB(ty,T.LI 0,a)
89 :     | T.ADD(ty,a,b) => promotable T.SRA (exp,T.ADD,ty,a,b)
90 :     | T.SUB(ty,a,b) => promotable T.SRA (exp,T.SUB,ty,a,b)
91 :     | T.MULS(ty,a,b) => promotable T.SRA (exp,T.MULS,ty,a,b)
92 :     | T.DIVS(ty,a,b) => promotable T.SRA (exp,T.DIVS,ty,a,b)
93 :     | T.REMS(ty,a,b) => promotable T.SRA (exp,T.REMS,ty,a,b)
94 :     | T.MULU(ty,a,b) => promotable T.SRL (exp,T.MULU,ty,a,b)
95 :     | T.DIVU(ty,a,b) => promotable T.SRL (exp,T.DIVU,ty,a,b)
96 :     | T.REMU(ty,a,b) => promotable T.SRL (exp,T.REMU,ty,a,b)
97 :    
98 :     (* for overflow trapping ops; we have to do the simulation *)
99 :     | T.NEGT(ty,a) => T.SUBT(ty,T.LI 0,a)
100 :     | T.ADDT(ty,a,b) => arith (T.SRA,T.ADDT,ty,a,b)
101 :     | T.SUBT(ty,a,b) => arith (T.SRA,T.SUBT,ty,a,b)
102 :     | T.MULT(ty,a,b) => arith (T.SRA,T.MULT,ty,a,b)
103 :     | T.DIVT(ty,a,b) => arith (T.SRA,T.DIVT,ty,a,b)
104 :     | T.REMT(ty,a,b) => arith (T.SRA,T.REMT,ty,a,b)
105 :    
106 :     (* conditional evaluation rules *)
107 :     | T.COND(ty,T.CC(cond,r),x,y) =>
108 :     T.COND(ty,T.CMP(ty,cond,T.REG(ty,r),T.LI 0),x,y)
109 :     | T.COND(ty,T.CCMARK(cc,a),x,y) => T.MARK(T.COND(ty,cc,x,y),a)
110 :     | T.COND(ty,T.CMP(t,cc,e1,e2),x as (T.LI 0 | T.LI32 0w0),y) =>
111 :     T.COND(ty,T.CMP(t,T.Basis.negateCond cc,e1,e2),y,T.LI 0)
112 :     (* we'll let others strength reduce the multiply *)
113 :     | T.COND(ty,cc,e1,(T.LI 0 | T.LI32 0w0)) =>
114 :     T.MULU(ty,T.COND(ty,cc,T.LI 1,T.LI 0),e1)
115 :     | T.COND(ty,cc,T.LI m,T.LI n) =>
116 :     T.ADD(ty,T.MULU(ty,T.COND(ty,cc,T.LI 1,T.LI 0),T.LI(m-n)),T.LI n)
117 :     | T.COND(ty,cc,e1,e2) =>
118 :     T.ADD(ty,T.MULU(ty,T.COND(ty,cc,T.LI 1,T.LI 0),T.SUB(ty,e1,e2)),e2)
119 :    
120 :     (* ones-complement.
121 :     * WARNING: we are assuming two's complement architectures here.
122 :     * Are there any architectures in use nowadays that doesn't use
123 :     * two's complement for integer arithmetic?
124 :     *)
125 :     | T.NOTB(ty,e) => T.XORB(ty,e,T.LI ~1)
126 :    
127 :     (*
128 :     * Default ways of converting integers to integers
129 :     *)
130 : leunga 744 | T.SX(ty,fromTy,e) =>
131 : george 546 if fromTy = ty then e
132 :     else if rep = SE andalso fromTy < ty andalso
133 :     fromTy >= hd naturalWidths then e
134 :     else
135 :     let val shift = T.LI(W - fromTy)
136 :     in T.SRA(W,T.SLL(W,e,shift),shift)
137 :     end
138 : leunga 744 | T.ZX(ty,fromTy,e) =>
139 : george 546 if fromTy <= ty then e else
140 :     (case ty of (* ty < fromTy *)
141 :     8 => T.ANDB(ty,e,T.LI32 0wxff)
142 :     | 16 => T.ANDB(ty,e,T.LI32 0wxffff)
143 :     | 32 => T.ANDB(ty,e,T.LI32 0wxffffffff)
144 :     | 64 => e
145 :     | _ => raise Unsupported("unknown expression")
146 :     )
147 :    
148 :     (*
149 :     * Converting floating point to integers.
150 :     * The following rule handles the case when ty is not
151 :     * one of the naturally supported widths on the machine.
152 :     *)
153 :     | T.CVTF2I(ty,round,fty,e) =>
154 :     let val ty' = promoteTy(exp,ty)
155 : leunga 744 in T.SX(ty,ty',T.CVTF2I(ty',round,fty,e))
156 : george 546 end
157 :    
158 :     | exp => raise Unsupported("unknown expression")
159 :    
160 :     fun compileFexp fexp = raise Unsupported("unknown expression")
161 :    
162 :     fun mark(s,[]) = s
163 :     | mark(s,a::an) = mark(T.ANNOTATION(s,a),an)
164 :    
165 :     fun compileStm (T.SEQ s) = s
166 : leunga 744 | compileStm (T.IF(cond,T.JMP(T.LABEL(LE.LABEL L),_),T.SEQ [])) =
167 :     [T.BCC(cond,L)]
168 :     | compileStm (T.IF(cond,yes,no)) =
169 : george 546 let val L1 = Label.newLabel ""
170 :     val L2 = Label.newLabel ""
171 : leunga 744 in [T.BCC(cond,L1),
172 : george 546 no,
173 : leunga 744 T.JMP(T.LABEL(LE.LABEL L2),[]),
174 : george 546 T.DEFINE L1,
175 :     yes,
176 :     T.DEFINE L2
177 :     ]
178 :     end
179 :     | compileStm stm = error "compileStm"
180 :    
181 :     (*
182 :     * This function translations conditional expressions into a
183 :     * branch sequence.
184 :     * Note: we'll actually take advantage of the fact that
185 :     * e1 and e2 are allowed to be eagerly evaluated.
186 :     *)
187 :     fun compileCond{exp=(ty,ccexp,e1,e2),rd,an} =
188 :     let val L1 = Label.newLabel ""
189 :     in [T.MV(ty,rd,e1),
190 : leunga 744 mark(T.BCC(ccexp,L1),an),
191 : george 546 T.MV(ty,rd,e2),
192 :     T.DEFINE L1
193 :     ]
194 :     end
195 :     fun compileFcond{exp=(fty,ccexp,e1,e2),fd,an} =
196 :     let val L1 = Label.newLabel ""
197 :     in [T.FMV(fty,fd,e1),
198 : leunga 744 mark(T.BCC(ccexp,L1),an),
199 : george 546 T.FMV(fty,fd,e2),
200 :     T.DEFINE L1
201 :     ]
202 :     end
203 :    
204 :     end

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