Return to sharing.sml CVS log

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

Annotation of researchv10no/cmd/sml/src/typing/sharing.sml, revision 1.1

1.1     ! root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
        !             2: (* sharing.sml *)
        !             3: 
        !             4: structure Sharing : SHARING =
        !             5: struct
        !             6: 
        !             7:   structure Basics = Basics
        !             8: 
        !             9:   open ErrorMsg PrintUtil Basics EnvAccess TypesUtil
        !            10: 
        !            11:   (* a couple of useful iterators *)
        !            12: 
        !            13:   fun for a b = app b a
        !            14: 
        !            15:   fun upto (start,finish) f = 
        !            16:       let fun loop i = if i>=finish then () else (f i; loop(i+1))
        !            17:        in loop start
        !            18:       end
        !            19: 
        !            20:   fun getStr([],str) = str
        !            21:     | getStr(id::rest,STRstr{table,env,...}) =
        !            22:        let val STRvar{binding,...} = lookSTRinTable(table,id)
        !            23:            val str = case (binding,env)
        !            24:                       of (INDstr i,REL{s,...}) => s sub i
        !            25:                        | (SHRstr(i::r),REL{s,...}) => getEpath(r, s sub i)
        !            26:                        | (STRstr _, _) => binding
        !            27:                        | _ => impossible "Sharing.getStr"
        !            28:         in getStr(rest,str)
        !            29:        end
        !            30:        handle Env.UnboundTable =>
        !            31:          condemn("unbound structure id in sharing specification: "
        !            32:                  ^ Symbol.name id)
        !            33: 
        !            34:   fun findStr(id::rest,table,env) : Structure =
        !            35:        (let val STRvar{binding,...} = lookSTRinTable(table,id)
        !            36:             val str = case (binding,env)
        !            37:                        of (INDstr i,REL{s,...}) => s sub i
        !            38:                         | (SHRstr(i::r),REL{s,...}) => getEpath(r,s sub i)
        !            39:                         | (STRstr _, _) => binding
        !            40:                         | _ => impossible "Sharing.findStr"
        !            41:         in getStr(rest,str)
        !            42:        end
        !            43:        handle Env.UnboundTable =>  (* look for global structure *)
        !            44:          let val STRvar{binding,...} =
        !            45:                    lookSTR(id) handle Env.Unbound =>
        !            46:                      condemn("unbound structure id in sharing specification: "
        !            47:                              ^ Symbol.name id)
        !            48:           in getStr(rest,binding)
        !            49:          end)
        !            50:     | findStr([],_,_) = impossible "Sharing.findStr with empty path"
        !            51: 
        !            52:   fun findTycon(path,table,env) : tycon =
        !            53:       let val (id::rpath) = rev path 
        !            54:        in case rev rpath
        !            55:            of [] => ((case !(lookTYCinTable(table,id))
        !            56:                         of INDtyc i =>
        !            57:                              (case env
        !            58:                                of REL{t,...} => t sub i
        !            59:                                 | DIR => impossible "Sharing.findTycon")
        !            60:                          | SHRtyc p => getEpathTyc(p,env)
        !            61:                          | tyc => tyc)
        !            62:                      handle Env.UnboundTable =>
        !            63:                      !(lookTYC id) 
        !            64:                      handle Env.Unbound =>
        !            65:                      condemn("unbound type in sharing spec: "^ Symbol.name id))
        !            66:             | path' => !(lookTYCinStr(findStr(path',table,env),id))
        !            67:       end
        !            68: (*
        !            69:   fun sameStructure(STRstr{env,...}, STRstr{env=env',...}) = (env = env')
        !            70:     | sameStructure _ = false  
        !            71: 
        !            72:   (* similar to ModUtil.resetParent except for sameStructure test --
        !            73:      would ModUtil.resetParent suffice? *)
        !            74:   fun resetParent (newparent: Structure, oldparent: Structure) =
        !            75:       fn (STRstr{env=REL{s,...},...}) =>
        !            76:          ((case s sub 0
        !            77:             of NULLstr => update(s,0,newparent)
        !            78:              | _ => if sameStructure(s sub 0, oldparent)
        !            79:                     then update(s,0,newparent)
        !            80:                     else ())
        !            81:           handle Subscript => ())
        !            82:        | NULLstr => ()
        !            83:        | _ => impossible "Sharing.resetParent"
        !            84: *)
        !            85:   fun doSharing(table,env as REL{s=senv,t=tenv},{strStamps,tycStamps},
        !            86:                {s=strShare,t=typeShare}) =
        !            87:       let fun freeStrStamp s = not(Stampset.member(s,strStamps))
        !            88:           fun freeTycStamp s = not(Stampset.member(s,tycStamps))
        !            89:          val {assoc,getassoc,union,find} = Siblings.new(freeStrStamp)
        !            90:                : Structure Siblings.siblingClass
        !            91:          val {union=tunion,find=tfind} = Unionfind.new(freeTycStamp)
        !            92: 
        !            93:          fun strMerge(p' as STRstr{stamp=p,...}, q' as STRstr{stamp=q,...}) =
        !            94:              if (assoc(p,p'); find p) = (assoc(q,q'); find q)
        !            95:              then ()
        !            96:              else let val pclass = getassoc p
        !            97:                       and qclass = getassoc q
        !            98:                    in union(p,q);
        !            99:                       for pclass (fn x =>
        !           100:                         for qclass (fn y =>
        !           101:                           sMerge(x,y)))
        !           102:                   end
        !           103: 
        !           104:          and sMerge(str1 as STRstr{stamp=s1,kind=k1,env=REL{s=senv1,t=tenv1,...},...},
        !           105:                     str2 as STRstr{stamp=s2,kind=k2,
        !           106:                                    env=env2 as REL{s=senv2,t=tenv2,...},
        !           107:                                    table,...}) =
        !           108:              case (k1,k2)
        !           109:                of (STRkind _, STRkind _) =>
        !           110:                      if s1 = s2
        !           111:                      then ()
        !           112:                      else condemn "sharing constraint - \
        !           113:                                   \incompatible fixed structures"
        !           114:                 | (STRkind _, SIGkind _) => sMerge(str2,str1)
        !           115:                 | (SIGkind{bindings,...},  _) =>
        !           116:                     for bindings 
        !           117:                       (fn STRbind(STRvar{name=[id],binding,...}) =>
        !           118:                            (let val STRvar{binding=target,...} =
        !           119:                                       lookSTRinTable(table,id)
        !           120:                              in strMerge((case binding
        !           121:                                             of INDstr i => senv1 sub i 
        !           122:                                              | _ => binding),
        !           123:                                          (case target
        !           124:                                             of INDstr i => senv2 sub i
        !           125:                                              | SHRstr(i::r) => getEpath(r,senv2 sub i)
        !           126:                                              | _ => target))
        !           127:                             end
        !           128:                             handle Env.UnboundTable => ())
        !           129:                         | TYCbind(ref tycon) =>
        !           130:                            (let val tyc1 = case tycon
        !           131:                                              of INDtyc i => tenv1 sub i
        !           132:                                               | _ => tycon
        !           133:                                 val tyc2 =
        !           134:                                       case !(lookTYCinTable(table,tycName tyc1))
        !           135:                                         of INDtyc i => tenv2 sub i 
        !           136:                                          | SHRtyc p => getEpathTyc(p,env2)
        !           137:                                          | tyc => tyc
        !           138:                              in tunion(tycStamp tyc1,tycStamp tyc2);
        !           139:                                 ()
        !           140:                             end
        !           141:                             handle Env.UnboundTable => ())
        !           142:                         | _ => ())
        !           143: 
        !           144:          fun shareSig(REL{s,t}) =
        !           145:              (upto (2, Array.length s) (fn i =>
        !           146:                 let val str as STRstr{stamp,sign,table,env as REL{s=s',...},kind} =
        !           147:                           s sub i
        !           148:                  in case kind
        !           149:                      of SIGkind _ => 
        !           150:                           let val stamp' = find stamp
        !           151:                            in if stamp' = stamp
        !           152:                               then ()
        !           153:                               else let val new =
        !           154:                                           STRstr{stamp=stamp',sign=sign,
        !           155:                                                  table=table,
        !           156:                                                  env=env,kind=kind}
        !           157:                                     in update(s,i,new);
        !           158:                                        ArrayExt.app(ModUtil.resetParent new,s',1)
        !           159:                                    end;
        !           160:                               shareSig env
        !           161:                           end
        !           162:                       | STRkind _ => impossible "Sharing.doSharing.shareSig"
        !           163:                 end);
        !           164:               upto (0,Array.length t) (fn i =>
        !           165:                 let val tycon = t sub i
        !           166:                     val stamp = tycStamp tycon
        !           167:                     val stamp' = tfind stamp
        !           168:                  in if stamp = stamp'
        !           169:                     then ()
        !           170:                     else update(t,i,setTycStamp(stamp',tycon))
        !           171:                 end))
        !           172: 
        !           173:          val strPathPairs = ref [] : (spath*spath) list ref
        !           174:          val typePathPairs = ref [] : (spath*spath) list ref
        !           175: 
        !           176:        in for strShare (fn p as (p1,p2) =>
        !           177:            let val str1 as STRstr{stamp=s1,...} = findStr(p1,table,env)
        !           178:                and str2 as STRstr{stamp=s2,...} = findStr(p2,table,env)
        !           179:             in if freeStrStamp s1 orelse freeStrStamp s2 then ()
        !           180:                  else strPathPairs := p :: !strPathPairs;
        !           181:                strMerge(str1,str2)
        !           182:            end);
        !           183:          for typeShare (fn p as (p1,p2) =>
        !           184:            let val s1 = tycStamp(findTycon(p1,table,env))
        !           185:                and s2 = tycStamp(findTycon(p2,table,env))
        !           186:             in if freeTycStamp(s1) orelse freeTycStamp(s2)
        !           187:                then ()
        !           188:                else typePathPairs := p :: !typePathPairs;
        !           189:                tunion(s1,s2)
        !           190:            end);
        !           191:          shareSig env;
        !           192:          {s= !strPathPairs, t= !typePathPairs}
        !           193:       end  (* doSharing *)
        !           194: 
        !           195:   fun checkSharing(table,env,{s=strShare,t=typeShare}) =
        !           196:       (for strShare (fn p as (p1,p2) =>
        !           197:         let val STRstr{stamp=s1,...} = findStr(p1,table,env)
        !           198:             and STRstr{stamp=s2,...} = findStr(p2,table,env)
        !           199:          in if s1 <> s2
        !           200:             then condemn "structure sharing violation"
        !           201:             else ()
        !           202:         end);
        !           203:        for typeShare (fn (p1,p2) =>
        !           204:         let val tyc1 = findTycon(p1,table,env)
        !           205:             and tyc2 = findTycon(p2,table,env)
        !           206:          in if equalTycon(tyc1,tyc2)
        !           207:             then ()
        !           208:             else (PrintType.printTycon tyc1; print "\n";  (* DEBUGGING *)
        !           209:                   PrintType.printTycon tyc2; print "\n";  (* DEBUGGING *)
        !           210:                   condemn "type sharing violation")
        !           211:         end))
        !           212: 
        !           213: end (* structure Sharing *)

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