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     ! 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.