![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to convert.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / cps|
Return to convert.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / cps |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* notes:
3: OFFSET should not be generated by this module
4: RECORD fields should contain only empty paths (pure variables)
5: *)
6:
7: (* xgrep '[^a-z]n[^a-z]' cps/convert.sml *)
8: structure Convert =
9: struct
10:
11: open CPS Access
12: fun sublist test =
13: let fun subl(a::r) = if test a then a::(subl r) else subl r
14: | subl x = x
15: in subl
16: end
17:
18: local open Lambda Basics
19: in
20: fun translatepath [v] = VAR v
21: | translatepath (x::p) = SELECT(x,translatepath p)
22: | translatepath nil = ErrorMsg.impossible "convert.translatepath nil"
23:
24: fun isboxedRep(CONSTANT _) = false
25: | isboxedRep(TRANSU) = false
26: | isboxedRep(_) = true
27:
28: fun isboxed (DATAcon(DATACON{rep,...})) = isboxedRep(rep)
29: | isboxed (REALcon _) = true
30: | isboxed (STRINGcon s) = (size s <> 1)
31: | isboxed _ = false
32: end
33:
34: fun mk f = f (mkLvar())
35:
36: val sortcases = Sort.sort (fn ((i:int,_),(j,_)) => i>j)
37:
38: val calling =
39: fn P.boxed => (1,0,2)
40: | P.< => (2,0,2)
41: | P.<= => (2,0,2)
42: | P.> => (2,0,2)
43: | P.>= => (2,0,2)
44: | P.ieql => (2,0,2)
45: | P.ineq => (2,0,2)
46: | P.feql => (2,0,2)
47: | P.fge => (2,0,2)
48: | P.fgt => (2,0,2)
49: | P.fle => (2,0,2)
50: | P.flt => (2,0,2)
51: | P.fneq => (2,0,2)
52: | P.gethdlr => (0,1,1)
53: | P.* => (2,1,1)
54: | P.+ => (2,1,1)
55: | P.- => (2,1,1)
56: | P.div => (2,1,1)
57: | P.orb => (2,1,1)
58: | P.andb => (2,1,1)
59: | P.xorb => (2,1,1)
60: | P.rshift => (2,1,1)
61: | P.lshift => (2,1,1)
62: | P.fadd => (2,1,1)
63: | P.fdiv => (2,1,1)
64: | P.fmul => (2,1,1)
65: | P.fsub => (2,1,1)
66: | P.subscript => (2,1,1)
67: | P.ordof => (2,1,1)
68: | P.! => (1,1,1)
69: | P.alength => (1,1,1)
70: | P.fneg => (1,1,1)
71: | P.makeref => (1,1,1)
72: | P.delay => (2,1,1)
73: | P.slength => (1,1,1)
74: | P.~ => (1,1,1)
75: | P.notb => (1,1,1)
76: | P.sethdlr => (1,0,1)
77: | P.:= => (2,0,1)
78: | P.unboxedassign => (2,0,1)
79: | P.store => (3,0,1)
80: | P.unboxedupdate => (3,0,1)
81: | P.update => (3,0,1)
82: | _ => ErrorMsg.impossible "calling with bad primop"
83:
84: fun nthcdr(l, 0) = l
85: | nthcdr(a::r, n) = nthcdr(r, n-1)
86: | nthcdr _ = ErrorMsg.impossible "nthcdr in convert"
87:
88: fun count test =
89: let fun subl acc (a::r) = subl(if test a then 1+acc else acc) r
90: | subl acc nil = acc
91: in subl 0
92: end
93:
94: fun convert lexp =
95: let
96: local open Intmap
97: val m : const intmap = new(32, Ctable)
98: val enter = add m
99: in fun bindconst(c,cont) = mk(fn v => (enter(v,c); cont v))
100: val ctable = m
101: end
102:
103: local open Intmap
104: exception Rename
105: val m : lvar intmap = new(32, Rename)
106: val rename = map m
107: in fun ren v = rename v handle Rename => v
108: val newname = add m
109: end
110:
111: fun switch1(e : lvar, cases : (int*cexp) list, d : lvar, (lo,hi)) =
112: let val delta = 2
113: fun collapse (l as (li,ui,ni,xi)::(lj,uj,nj,xj)::r ) =
114: if ((ni+nj) * delta > ui-lj)
115: then collapse((lj,ui,ni+nj,xj)::r)
116: else l
117: | collapse l = l
118: fun f (z, x as (i,_)::r) = f(collapse((i,i,1,x)::z), r)
119: | f (z, nil) = z
120: fun tackon (stuff as (l,u,n,x)::r) =
121: if n*delta > u-l andalso n>4 andalso hi>u
122: then tackon((l,u+1,n+1,x@[(u+1,APP(d,nil))])::r)
123: else stuff
124: fun separate((z as (l,u,n,x))::r) =
125: if n<4 andalso n>1
126: then let val ix as (i,_) = nth(x, (n-1))
127: in (i,i,1,[ix])::separate((l,l,n-1,x)::r)
128: end
129: else z :: separate r
130: | separate nil = nil
131: val chunks = rev (separate (tackon (f (nil,cases))))
132: fun g(1,(l,h,1,(i,b)::_)::_,(lo,hi)) =
133: if lo=i andalso hi=i then b
134: else bindconst(INTconst i, fn i' =>
135: PRIMOP(P.ineq,[e, i'], nil, [APP(d,nil), b]))
136: | g(1,(l,h,n,x)::_,(lo,hi)) =
137: let fun f(0,_,_) = nil
138: | f(n,i,l as (j,b)::r) =
139: if i+lo = j then b::f(n-1,i+1,r)
140: else (APP(d,nil))::f(n,i+1,l)
141: val list = f(n,0,x)
142: val body = if lo=0 then SWITCH(e,list)
143: else bindconst(INTconst lo, fn lo' =>
144: mk(fn e' =>
145: PRIMOP(P.-,[e, lo'], [e'],
146: [SWITCH(e', list)])))
147: val a = if (lo<l)
148: then bindconst(INTconst l, fn l' =>
149: PRIMOP(P.<,[e, l'], nil, [APP(d,nil), body]))
150: else body
151: val b = if (hi > h)
152: then bindconst(INTconst h, fn h' =>
153: PRIMOP(P.>,[e, h'], nil, [APP(d,nil), a]))
154: else a
155: in b
156: end
157: | g(n,cases,(lo,hi)) =
158: let val n2 = n div 2
159: val c2 as (l,_,_,_)::r = nthcdr(cases, n2)
160: in bindconst(INTconst l, fn l' =>
161: PRIMOP(P.<,[e,l'],nil, [g(n2,cases,(lo,l-1)),
162: g(n-n2,c2,(l,hi))]))
163: end
164: in g (length chunks, chunks, (lo, hi))
165: end
166:
167: fun switch(e, l, d, inrange) =
168: let val len = List.length l
169: val d' = case d of SOME d' => d' | NONE => mkLvar()
170: fun ifelse nil = APP(d',nil)
171: | ifelse ((i,b)::r) =
172: bindconst(INTconst i, fn v =>
173: PRIMOP(P.ineq,[v, e], nil, [ifelse r, b]))
174: fun ifelseN [(i,b)] = b
175: | ifelseN ((i,b)::r) =
176: bindconst(INTconst i, fn v =>
177: PRIMOP(P.ineq,[v, e], nil, [ifelseN r, b]))
178: | ifelseN _ = ErrorMsg.impossible "convert.224"
179: val l = sortcases l
180: in case (len<4, inrange)
181: of (true, NONE) => ifelse l
182: | (true, SOME n) => if n+1=len then ifelseN l else ifelse l
183: | (false, NONE) =>
184: let fun last [x] = x | last (_::r) = last r
185: val (hi,_) = last l and (low,_)::r = l
186: in bindconst(INTconst low, fn low' =>
187: bindconst(INTconst hi, fn hi' =>
188: PRIMOP(P.>,[low', e], nil, [APP(d',[]),
189: PRIMOP(P.<,[hi', e], nil, [APP(d',[]),
190: switch1(e, l, d', (low,hi))])])))
191: end
192: | (false, SOME n) => switch1(e, l, d', (0,n))
193: end
194:
195: val zero = bindconst(INTconst 0, fn x => x)
196: val one = bindconst(INTconst 1, fn x => x)
197: val neg1 = bindconst(INTconst ~1, fn x => x)
198: val unevaled = bindconst(INTconst (System.Tags.tag_suspension div 2), fn x => x)
199: val evaled = bindconst(INTconst((System.Tags.tag_suspension
200: +System.Tags.power_tags)div 2), fn x => x)
201:
202: fun convlist (el,c) =
203: let fun f(le::r, vl) = conv(le, fn v => f(r,v::vl))
204: | f(nil, vl) = c (rev vl)
205: in f (el,nil)
206: end
207:
208: and getargs(1,a,g) = conv(a, fn z => g[z])
209: | getargs(n,Lambda.RECORD l,g) = convlist(l,g)
210: | getargs(n, a, g) = conv(a, fn v =>
211: let fun f (j,wl) = if j=n
212: then g(rev wl)
213: else mk(fn w => SELECT(j,v,w,f(j+1,w::wl)))
214: in f(0,nil)
215: end)
216:
217: and conv (le, c) =
218: case le of
219: Lambda.APP(Lambda.PRIM P.callcc, f) =>
220: let val k = mkLvar() and k' = mkLvar() and k'' = mkLvar()
221: and x = mkLvar() and y = mkLvar() and h = mkLvar()
222: in FIX([(k,[x],c x)],
223: PRIMOP(P.gethdlr,[],[h],
224: [FIX([(k',[y,k''],PRIMOP(P.sethdlr,[h],[],[APP(k,[y])]))],
225: conv(f, fn vf => APP(vf,[k',k])))]))
226: end
227: | Lambda.APP(Lambda.PRIM P.throw, k) => conv(k,c)
228: | Lambda.APP(Lambda.PRIM P.cast, k) => conv(k,c)
229: | Lambda.APP(Lambda.PRIM P.force, k) =>
230: let val c0=mkLvar() and c0v=mkLvar() and w=mkLvar() and x=mkLvar()
231: and y=mkLvar() and c1=mkLvar() and c1v=mkLvar()
232: in conv(k, fn v =>
233: FIX([(c0,[c0v],c c0v)],
234: PRIMOP(P.boxed,[v],[],[PRIMOP(P.subscript,[v,neg1],[w],[
235: PRIMOP(P.ieql,[w,evaled],[],[PRIMOP(P.!,[v],[x],[APP(c0,[x])]),
236: PRIMOP(P.ineq,[w,unevaled],[],[APP(c0,[v]),
237: FIX([(c1,[c1v],
238: PRIMOP(P.:=,[v,c1v],[],[
239: PRIMOP(P.update,[v,neg1,evaled],[],[
240: APP(c0,[c1v])])]))],
241: PRIMOP(P.!,[v],[y],[APP(y,[zero,c1])]))])])]),
242: APP(c0,[v])])))
243: end
244: | Lambda.APP(Lambda.PRIM i, a) =>
245: (case calling i of
246: (n,1,1) => getargs(n,a,fn vl => mk(fn w => PRIMOP(i,vl,[w],[c w])))
247: | (n,0,1) => getargs(n,a,fn vl => PRIMOP(i,vl,[],[c zero]))
248: | (n,0,2) => getargs(n,a,fn vl =>
249: let val cv = mkLvar() and v = mkLvar()
250: in FIX([(cv,[v],c v)],PRIMOP(i,vl,[],[APP(cv,[one]),APP(cv,[zero])]))
251: end))
252: | Lambda.PRIM i => mk(fn v => conv(Lambda.FN(v,Lambda.APP(le,Lambda.VAR v)),c))
253: | Lambda.VAR v => c (ren v)
254: | Lambda.APP(Lambda.FN(v,e),a) =>
255: conv(a, fn w => (newname(v,w);Access.sameName(v,w); conv(e, c)))
256: | Lambda.FN (v,e) => let val f = mkLvar() and w = mkLvar()
257: in FIX([(f,[v,w],conv(e, fn z => APP(w,[z])))], c f)
258: end
259: | Lambda.APP (f,a) =>
260: let val fc = mkLvar() and x = mkLvar()
261: in FIX([(fc,[x],c x)], conv(f,fn vf => conv(a,fn va => APP(vf,[va,fc]))))
262: end
263: | Lambda.FIX (fl, el, body) =>
264: let fun g(f::fl, Lambda.FN(v,b)::el) =
265: mk(fn w => (f,[v,w], conv(b, fn z => APP(w,[z])))) :: g(fl,el)
266: | g(nil,nil) = nil
267: in FIX(g(fl,el), conv(body,c))
268: end
269: | Lambda.INT i =>
270: ((i+i; bindconst(INTconst i, c))
271: handle Overflow =>
272: let open Lambda
273: in conv(APP(PRIM P.+, RECORD[INT(i div 2), INT(i - i div 2)]),c)
274: end)
275: | Lambda.REAL i => bindconst(REALconst i, c)
276: | Lambda.STRING i => (case size i
277: of 1 => bindconst(INTconst(ord i),c)
278: | _ => bindconst(STRINGconst i, c))
279: | Lambda.RECORD nil => c zero
280: | Lambda.RECORD l => convlist(l,fn vl => mk(fn x => RECORD(recordpath vl,x,c x)))
281: | Lambda.SELECT(i, e) => mk(fn w => conv(e, fn v => SELECT(i, v, w, c w)))
282: | Lambda.SWITCH(e,l as (Lambda.DATAcon(Basics.DATACON{
283: rep=Basics.VARIABLE _,...}), _)::_, SOME d) =>
284: let val cf = mkLvar() and vf = mkLvar()
285: in FIX([(cf, [vf], c vf)],
286: conv(Lambda.SELECT(1,e), fn w =>
287: let fun g((Lambda.DATAcon(Basics.DATACON{
288: rep=Basics.VARIABLE(Access.PATH p),const=true,...}), x)::r) =
289: conv(translatepath(1::p), fn v =>
290: PRIMOP(P.ineq, [w,v], [], [g r, conv(x, fn z => APP(cf,[z]))]))
291: | g((Lambda.DATAcon(Basics.DATACON{
292: rep=Basics.VARIABLE(Access.PATH p),...}), x)::r) =
293: conv(translatepath p, fn v =>
294: PRIMOP(P.ineq, [w,v], [], [g r, conv(x, fn z => APP(cf,[z]))]))
295: | g nil = conv(d, fn z => APP(cf,[z]))
296: | g _ = ErrorMsg.impossible "convert.21"
297: in g l
298: end))
299: end
300: | Lambda.SWITCH(e,l as (Lambda.REALcon _, _)::_, SOME d) =>
301: let val cf = mkLvar() and vf = mkLvar()
302: in FIX([(cf, [vf], c vf)],
303: conv(e, fn w =>
304: let fun g((Lambda.REALcon rval, x)::r) =
305: bindconst(REALconst rval, fn v =>
306: PRIMOP(P.fneq, [w,v],[], [g r, conv(x,fn z => APP(cf,[z]))]))
307: | g nil = conv(d, fn z => APP(cf,[z]))
308: | g _ = ErrorMsg.impossible "convert.81"
309: in g l
310: end))
311: end
312: | Lambda.SWITCH(e,l as (Lambda.INTcon _, _)::_, SOME d) =>
313: let val cf = mkLvar() and vf = mkLvar() and df = mkLvar()
314: in FIX([(cf, [vf], c vf), (df, [], conv(d, fn z => APP(cf,[z])))],
315: conv(e, fn w =>
316: let fun g (Lambda.INTcon j, a) = (j,conv(a, fn z => APP(cf,[z])))
317: in switch(w, map g l, SOME df, NONE)
318: end))
319: end
320: | Lambda.SWITCH(e,l as (Lambda.STRINGcon _, _)::_, SOME d) =>
321: let val cf = mkLvar() and vf = mkLvar() and df = mkLvar() and vd = mkLvar()
322: val cont = fn z => APP(cf,[z])
323: fun isboxed (Lambda.STRINGcon s, _) = size s <> 1
324: val b = sublist isboxed l
325: val u = sublist (not o isboxed) l
326: fun g(Lambda.STRINGcon j, e) = (ord j, conv(e,cont))
327: val z = map g u
328: val [p1,p2] = !CoreInfo.stringequalPath
329: in FIX([(cf, [vf], c vf), (df, [], conv(d, cont))],
330: conv(e, fn w =>
331: let val genu = switch(w, z, SOME df, NONE)
332: fun genb [] = APP(df,[])
333: | genb cases =
334: let val len1 = mkLvar()
335: fun g((Lambda.STRINGcon s, x)::r) =
336: let val ssize = size s
337: val k = mkLvar() and seq = mkLvar() and pair = mkLvar()
338: and c2 = mkLvar() and ans = mkLvar()
339: in FIX((k,[], g r)::
340: if ssize=0 then []
341: else [(c2,[ans],PRIMOP(P.ieql,[ans,zero],[],
342: [APP(k,[]), conv(x,cont)]))],
343: bindconst(STRINGconst s, fn v =>
344: bindconst(INTconst ssize, fn len0 =>
345: bindconst(INTconst((ssize + 3) div 4 - 1), fn len0' =>
346: PRIMOP(P.ineq,[len0,len1],[],
347: [APP(k,[]),
348: if ssize=0 then conv(x,cont)
349: else SELECT(p1,ren p2,seq,
350: RECORD([(w,OFFp 0),(v,OFFp 0)],
351: pair, APP(seq,[pair,c2])))])))))
352: end
353: | g nil = APP(df, [])
354: in PRIMOP(P.slength,[w],[len1], [g cases])
355: end
356: in PRIMOP(P.boxed,[w],[],[genb b, genu])
357: end))
358: end
359: | Lambda.SWITCH
360: (x as (Lambda.APP(Lambda.PRIM i, args),
361: [(Lambda.DATAcon(Basics.DATACON{rep=(Basics.CONSTANT c1),...}),e1),
362: (Lambda.DATAcon(Basics.DATACON{rep=(Basics.CONSTANT c2),...}),e2)],
363: NONE)) =>
364: let fun g(n,a,b) =
365: let val cf = mkLvar() and v = mkLvar()
366: val cont = (fn w => APP(cf,[w]))
367: in FIX([(cf,[v],c v)],
368: getargs(n,args,fn vl => PRIMOP(i,vl,[],[conv(a,cont),conv(b,cont)])))
369: end
370: in case (calling i, c1, c2) of
371: ((n,0,2), 1, 0) => g(n,e1,e2)
372: | ((n,0,2), 0, 1) => g(n,e2,e1)
373: | _ => genswitch(x,c)
374: end
375: | Lambda.SWITCH x => genswitch(x,c)
376: | Lambda.RAISE(e) =>
377: conv(e,fn w => mk(fn h => PRIMOP(P.gethdlr,[],[h],[APP(h,[w])])))
378: | Lambda.HANDLE(a,b) =>
379: let val h = mkLvar() and vb = mkLvar() and vc = mkLvar()
380: and x = mkLvar() and v = mkLvar ()
381: in FIX([(vc,[x],c x)],
382: PRIMOP(P.gethdlr,[],[h],
383: [FIX([(vb,[v],PRIMOP(P.sethdlr,[h],[],[conv(b,fn f => APP(f,[v,vc]))]))],
384: PRIMOP(P.sethdlr,[vb],[],
385: [conv(a, fn va => PRIMOP(P.sethdlr,[h],[], [APP(vc,[va])]))]))]))
386: end
387:
388: and genswitch ((e, l as (Lambda.DATAcon(Basics.DATACON{sign,...}),_)::_, d),c) =
389: let val cf = mkLvar() and cv = mkLvar() and df = mkLvar()
390: val cont = fn z => APP(cf,[z])
391: val boxed = sublist (isboxed o #1) l
392: val unboxed = sublist (not o isboxed o #1) l
393: val w = mkLvar() and t = mkLvar()
394: fun tag (Lambda.DATAcon(Basics.DATACON{rep=Basics.CONSTANT i,...}), e) =
395: (i, conv(e,cont))
396: | tag (Lambda.DATAcon(Basics.DATACON{rep=Basics.TAGGED i,...}), e) =
397: (i, conv(e,cont))
398: | tag (c,e) = (0, conv(e,cont))
399: in FIX((cf,[cv],c cv) ::
400: case d of NONE => [] | SOME d' => [(df,[],conv(d',cont))],
401: conv(e, fn w =>
402: case (count isboxedRep sign, count (not o isboxedRep) sign)
403: of (0, n) => switch(w, map tag l, SOME df, SOME(n-1))
404: | (n, 0) => SELECT(1, w, t, switch(t, map tag l, SOME df, SOME(n-1)))
405: | (1, nu) =>
406: PRIMOP(P.boxed, [w], [],
407: [switch(zero, map tag boxed, SOME df, SOME 0),
408: switch(w, map tag unboxed, SOME df, SOME(nu-1))])
409: | (nb,nu) =>
410: PRIMOP(P.boxed, [w], [],
411: [SELECT(1,w,t, switch(t, map tag boxed, SOME df, SOME(nb-1))),
412: switch(w, map tag unboxed, SOME df, SOME(nu-1))])))
413: end
414: val v = mkLvar() and x = mkLvar() and f = mkLvar()
415: in ((f, [v,x], conv(lexp, fn w => APP(w,[v,x]))), ctable)
416: end
417:
418: end
419:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.