Return to insert.sml CVS log

Up to [Research Unix] / researchv10no / cmd / sml / src / cps

Annotation of researchv10no/cmd/sml/src/cps/insert.sml, revision 1.1.1.1

1.1       root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
                      2: structure Insert : sig val insert : (CPS.function * bool) list ->
                      3:                                    (CPS.function * bool) list
                      4:                   end =
                      5: struct
                      6:   open Access CPS
                      7:   fun makecallers (arg : (CPS.function * bool) list) =
                      8:     let local open Intmap
                      9:           in exception Body
                     10:              val bodymap: (function * lvar list ref) intmap =
                     11:                                                 Intmap.new(32, Body)
                     12:              val getbody = map bodymap
                     13:              val setbody = add bodymap
                     14: 
                     15:              exception Caller
                     16:              val callermap : function list intmap = Intmap.new(32, Caller)
                     17:              val callers = map callermap
                     18:              val setcallers = add callermap
                     19:         end
                     20:         fun initcalled(func as (f,vl,e)) = setbody(f, (func,ref nil))
                     21: 
                     22:        fun findcalled(f,vl,e) =
                     23:          let fun g(RECORD(_,_,e)) = g e
                     24:                | g(SELECT(_,_,_,e)) = g e
                     25:                | g(OFFSET(_,_,_,e)) = g e
                     26:                | g(SWITCH(_,el)) = app g el
                     27:                | g(PRIMOP(_,_,_,el)) = app g el
                     28:                | g(APP(f',_)) = let val (_,r) = getbody f'
                     29:                                  in r := f :: !r
                     30:                                 end handle Body => ()
                     31:           in g e
                     32:          end
                     33: 
                     34:        val sort = Sort.sort (op > : int * int -> bool)
                     35:        fun mashcallers (f,vl,e) =
                     36:          let val (_, ref callers) = getbody f
                     37:           in setcallers(f, map (#1 o getbody) (SortedList.uniq(sort callers)))
                     38:          end
                     39: 
                     40:      in app (initcalled o #1) arg;
                     41:        app (findcalled o #1) arg;
                     42:        app (mashcallers o #1) arg;
                     43:        callers
                     44:     end
                     45: 
                     46: fun insert(arg : (CPS.function * bool) list) =
                     47:  let val callers = makecallers arg
                     48:      
                     49:      val OKset = Intset.new()
                     50:      val markOK = Intset.add OKset
                     51:      val isOK = Intset.mem OKset
                     52: 
                     53:      fun dfs(f,vl,e) =
                     54:       let fun bad(RECORD(_,_,e)) = false
                     55:            | bad(SELECT(_,_,_,e)) = bad e
                     56:            | bad(OFFSET(_,_,_,e)) = bad e
                     57:            | bad(SWITCH(_,el)) = exists bad el
                     58:            | bad(PRIMOP(P.:=,_,_,_)) = false
                     59:            | bad(PRIMOP(P.update,_,_,_)) = false
                     60:            | bad(PRIMOP(_,_,_,el)) = exists bad el
                     61:            | bad(APP(f,_)) = not(isOK f)
                     62:        in if isOK f orelse bad e
                     63:            then ()
                     64:            else (markOK f; app dfs (callers f))
                     65:       end
                     66: 
                     67:      fun makeOK(func as (f,vl,e)) =
                     68:       let fun g(e as RECORD _) = e
                     69:            | g(SELECT(i,v,w,e)) = SELECT(i,v,w,g e)
                     70:            | g(OFFSET(i,v,w,e)) = OFFSET(i,v,w,g e)
                     71:            | g(SWITCH(v,el)) = SWITCH(v, map g el)
                     72:            | g(e as PRIMOP(P.:=,_,_,_)) = e
                     73:            | g(e as PRIMOP(P.update,_,_,_)) = e
                     74:            | g(PRIMOP(p,vl,wl,el)) = PRIMOP(p,vl,wl, map g el)
                     75:            | g(e as APP(f',v::_)) = if isOK f' then e
                     76:                                     else RECORD([(v,OFFp 0)],mkLvar(),e)
                     77:        in if isOK f then func
                     78:          else let val func' = (f,vl,g e)
                     79:                in dfs func'; func'
                     80:               end
                     81:       end
                     82: 
                     83:   in app (dfs o #1) arg;
                     84:      map (fn (func,known) => (makeOK func, known)) arg
                     85:  end
                     86: end

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.