![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to hoist.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 hoist.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / cps |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: structure Hoist : sig val hoist : (string->unit)->CPS.cexp->CPS.cexp end = ! 3: struct ! 4: open Access CPS SortedList ! 5: ! 6: type fv = lvar list ! 7: ! 8: datatype cexp' ! 9: = RECORD' of (lvar * accesspath) list * lvar * cexp' * fv ! 10: | SELECT' of int * lvar * lvar * cexp' * fv ! 11: | OFFSET' of int * lvar * lvar * cexp' * fv ! 12: | APP' of lvar * lvar list ! 13: | FIX' of function' list * fv * cexp' * fv ! 14: | SWITCH' of lvar * (cexp' * fv) list ! 15: | PRIMOP' of Access.primop * lvar list * lvar list * (cexp' * fv) list ! 16: withtype function' = lvar * lvar list * cexp' ! 17: ! 18: fun sum f = let fun h [] = 0 ! 19: | h (a::r) = f a + h r ! 20: in h ! 21: end ! 22: ! 23: fun hoist click cexp = ! 24: let (* val _ = CPSprint.show (output std_out) (Intmap.map ctab) cexp *) ! 25: val clicked = ref false ! 26: val click = fn x => (clicked := true; click x) ! 27: infix 6 \/ val op \/ = merge ! 28: infix 7 /\ val op /\ = intersect ! 29: infix 6 -- val op -- = fn(a,b) => remove(b,a) ! 30: val rec hoist = ! 31: fn RECORD(vl, w, e) => ! 32: (case hoist e ! 33: of (e as FIX'(l,v1,e',v2), v3) => ! 34: if member v1 w ! 35: then (RECORD'(vl, w, e, v3), v3--[w]\/uniq(map #1 vl)) ! 36: else let val defined = uniq(map #1 l) ! 37: val v4 = v2--[w]\/uniq(map #1 vl) ! 38: in (FIX'(l,v1,RECORD'(vl,w,e',v2),v4), v1\/(v4--defined)) ! 39: end ! 40: | (e,v1) => (RECORD'(vl, w, e, v1), v1--[w]\/uniq(map #1 vl))) ! 41: | SELECT(i,v,w,e) => ! 42: (case hoist e of ! 43: (e as FIX'(l,v1,e',v2), v3) => if member v1 w ! 44: then (SELECT'(i, v, w, e, v3), v3--[w]\/[v]) ! 45: else let val defined = uniq(map #1 l) ! 46: val v4 = v2--[w]\/[v] ! 47: in (FIX'(l,v1,SELECT'(i,v,w,e',v2),v4),v1\/(v4--defined)) ! 48: end ! 49: | (e,v1) => (SELECT'(i, v, w, e, v1),v1--[w]\/[v])) ! 50: | PRIMOP(i,vl,wl,[e]) => ! 51: (case hoist e ! 52: of(e as FIX'(l,v1,e',v2),v3) => ! 53: (case uniq wl /\ v1 ! 54: of [] => let val v4 = v2--uniq wl\/uniq vl ! 55: val defined = uniq(map #1 l) ! 56: in (FIX'(l,v1,PRIMOP'(i,vl,wl,[(e',v2)]),v4),v1\/(v4--defined)) ! 57: end ! 58: | _ => (PRIMOP'(i, vl, wl, [(e,v3)]),v3--uniq wl\/uniq vl)) ! 59: | (e,v1) => (PRIMOP'(i, vl, wl, [(e,v1)]),v1--uniq wl\/uniq vl)) ! 60: | PRIMOP(i,vl,wl,el) => ! 61: let val el' = map hoist el ! 62: in (PRIMOP'(i,vl,wl,el'), foldmerge(map #2 el')--uniq wl\/uniq vl) ! 63: end ! 64: | APP(f,vl) => (APP'(f,vl), uniq(f::vl)) ! 65: | SWITCH(v,el) => ! 66: let val el' = map hoist el ! 67: in (SWITCH'(v, el'), foldmerge(map #2 el')\/[v]) ! 68: end ! 69: | FIX(l,e) => ! 70: let fun h((f,vl,(e as FIX'(l',v1,e',v2),v3))::r) = ! 71: let val (ll, v4) = h r ! 72: in case uniq vl /\ v1 ! 73: of [] => (click "p"; ! 74: ((f,vl,e')::l'@ll, ! 75: v2--(uniq vl)\/v1\/v4)) ! 76: | _ => ((f,vl,e) :: ll, v3--(uniq vl)\/v4) ! 77: end ! 78: | h((f,vl,(e,v3)):: r) = ! 79: let val (ll, v4) = h r ! 80: in ((f,vl,e) :: ll, v3--(uniq vl)\/v4) ! 81: end ! 82: | h [] = ([],[]) ! 83: val (l,v1) = h (map (fn(f,vl,a)=>(f,vl,hoist a)) l) ! 84: val defined = uniq(map #1 l) ! 85: val v1 = v1 -- defined ! 86: val (e,v2) = hoist e ! 87: exception Down ! 88: fun check vl = case defined /\ uniq vl of [] => () ! 89: | _ => raise Down ! 90: fun present (_,vx) = case defined/\vx ! 91: of []=>0 | _ => 1 ! 92: val rec down' = fn (cexp,vx) => ! 93: case defined /\ vx ! 94: of [] => (cexp,vx) ! 95: | _ => down cexp ! 96: handle Down => (FIX'(l,v1,cexp,vx), ! 97: vx--defined\/v1) ! 98: and down = ! 99: fn RECORD'(vl,w,e,v3) => (check(map #1 vl); ! 100: let val (e',v4) = down e ! 101: in (RECORD'(vl,w,e',v4),v4--[w]\/uniq(map #1 vl)) ! 102: end) ! 103: | SELECT'(i,v,w,e,v3) => ! 104: let val (e',v4) = down e ! 105: in (SELECT'(i,v,w,e',v4), v4--[w]\/[v]) ! 106: end ! 107: | PRIMOP'(i,vl,wl,[(e,_)]) => (check vl; ! 108: let val (e',v4) = down e ! 109: in (PRIMOP'(i,vl,wl,[(e',v4)]), v4--uniq wl\/uniq vl) ! 110: end) ! 111: | PRIMOP'(i,vl,wl,el) => ! 112: (check vl; ! 113: if sum present el < 2 ! 114: then let val el' = map down' el ! 115: in (PRIMOP'(i,vl,wl,el'), foldmerge(map #2 el')--uniq wl\/uniq vl) ! 116: end ! 117: else raise Down) ! 118: | SWITCH'(v,el) => (* can't switch on a function *) ! 119: if sum present el < 2 ! 120: then let val el' = map down' el ! 121: in (SWITCH'(v,el'), foldmerge(map #2 el')\/[v]) ! 122: end ! 123: else raise Down ! 124: | e as APP'(f,vl) => (check(f::vl); click "s"; (e, uniq(f::vl))) ! 125: | FIX'(m,v3,e',v4) => ! 126: let val v5 = v1\/(v3--defined) ! 127: in click "r"; ! 128: (FIX'(l@m,v5,e',v4),v5\/(v4--(defined\/uniq(map #1 m)))) ! 129: end ! 130: in down e handle Down => (FIX'(l,v1,e,v2), ! 131: v2--defined\/v1) ! 132: end ! 133: val rec clean = ! 134: fn RECORD'(vl,w,e,_) => RECORD(vl,w,clean e) ! 135: | SELECT'(i,v,w,e,_) => SELECT(i,v,w, clean e) ! 136: | PRIMOP'(i,vl,wl,el) => PRIMOP(i,vl,wl,map (clean o #1) el) ! 137: | SWITCH'(v,el) => SWITCH(v, map (clean o #1) el) ! 138: | APP'(f,vl) => APP(f,vl) ! 139: | FIX'(l,_,e,_) => FIX(map (fn (f,vl,e)=>(f,vl,clean e)) l, clean e) ! 140: val cexp' = #1(hoist cexp) ! 141: in if !clicked then clean cexp' else cexp ! 142: end ! 143: ! 144: end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.