Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/Semant/types/eqtypes.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/Semant/types/eqtypes.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 586, Thu Mar 30 05:08:07 2000 UTC revision 587, Thu Mar 30 09:01:52 2000 UTC
# Line 98  Line 98 
98   *)   *)
99    
100  fun eqAnalyze(str,localStamp : Stamps.stamp -> bool,err : EM.complainer) =  fun eqAnalyze(str,localStamp : Stamps.stamp -> bool,err : EM.complainer) =
101  let val tycons: tycon list stampMap = newMap UnboundStamp  let val tycons = ref StampMap.empty
102      val depend: stamp list stampMap = newMap UnboundStamp      val depend = ref StampMap.empty
103      val dependr: stamp list stampMap = newMap UnboundStamp      val dependr = ref StampMap.empty
104      val eqprop: eqprop stampMap = newMap UnboundStamp      val eqprop = ref StampMap.empty
105      val dependsInd = ref false      val dependsInd = ref false
106      val tycStampsRef : stamp list ref = ref nil      val tycStampsRef : stamp list ref = ref nil
107    
108      fun applyMap' x = applyMap x handle UnboundStamp => []      fun dflApply dfl (mr, k) =
109      fun applyMap'' x = applyMap x handle UnboundStamp => UNDEF          case StampMap.find (!mr, k) of
110                NONE => dfl
111              | SOME x => x
112    
113        fun applyMap' x = dflApply [] x
114        fun applyMap'' x = dflApply UNDEF x
115    
116        fun updateMap mr (k, v) = mr := StampMap.insert (!mr, k, v)
117    
118      val err = fn s => err EM.COMPLAIN s EM.nullErrorBody      val err = fn s => err EM.COMPLAIN s EM.nullErrorBody
119    
# Line 140  Line 147 
147                                    bug "unexpected freetycs in eqty")                                    bug "unexpected freetycs in eqty")
148                             | _ => tyc)                             | _ => tyc)
149                     in (case ntyc                     in (case ntyc
150                          of GENtyc{eq=ref OBJ,...} => ()                          of GENtyc _ =>
151                           | tyc' as GENtyc _ => (eqtyc tyc'; app eqty args)                             (if objectTyc ntyc then ()
152                                else (eqtyc ntyc; app eqty args))
153                           | DEFtyc{tyfun,...} => eqty(headReduceType ty)                           | DEFtyc{tyfun,...} => eqty(headReduceType ty)
154                           | RECtyc i =>                           | RECtyc i =>
155                              let val stamp = Vector.sub(stamps,i)                              let val stamp = Vector.sub(stamps,i)
# Line 168  Line 176 
176      fun addstr(str as M.STR{sign,rlzn={entities,...},...}) =      fun addstr(str as M.STR{sign,rlzn={entities,...},...}) =
177          let fun addtyc (tyc as (GENtyc{stamp, eq, kind, path, ...})) =          let fun addtyc (tyc as (GENtyc{stamp, eq, kind, path, ...})) =
178                   if localStamp stamp  (* local spec *)                   if localStamp stamp  (* local spec *)
179                   then ((updateMap tycons (stamp,tyc::applyMap'(tycons,stamp));                  then ((updateMap tycons
180                                     (stamp,tyc::applyMap'(tycons,stamp));
181                          tycStampsRef := stamp :: !tycStampsRef;                          tycStampsRef := stamp :: !tycStampsRef;
182                          case kind                          case kind
183                           of DATATYPE{index,stamps,family={members,...},                           of DATATYPE{index,stamps,family={members,...},
# Line 178  Line 187 
187                                   val (eqpCalc,deps) =                                   val (eqpCalc,deps) =
188                                     case eqOrig                                     case eqOrig
189                                      of DATA =>                                      of DATA =>
190                                         checkdcons(stamp,MU.transType entities,                                            checkdcons(stamp,
191                                                    dcons,stamps,members,freetycs)                                                       MU.transType entities,
192                                                         dcons,stamps,members,
193                                                         freetycs)
194                                       | e => (e,[])                                       | e => (e,[])
195                                              (* ASSERT: e = YES or NO *)                                              (* ASSERT: e = YES or NO *)
196                                   val eq' = join(join(eqOrig,                                    val eq' =
197                                          join(join(eqOrig,
198                                                       applyMap''(eqprop,stamp)),                                                       applyMap''(eqprop,stamp)),
199                                                  eqpCalc)                                                  eqpCalc)
200                                in eq := eq';                                in
201                                      eq := eq';
202                                   updateMap eqprop (stamp,eq');                                   updateMap eqprop (stamp,eq');
203                                   app (fn s => updateMap dependr                                   app (fn s => updateMap dependr
204                                       (s, stamp :: applyMap'(dependr,s))) deps;                                       (s, stamp :: applyMap'(dependr,s))) deps;
# Line 194  Line 207 
207                               end                               end
208                            | (FLEXTYC _ | ABSTRACT _ | PRIMITIVE _) =>                            | (FLEXTYC _ | ABSTRACT _ | PRIMITIVE _) =>
209                                let val eq' = join(applyMap''(eqprop,stamp), !eq)                                let val eq' = join(applyMap''(eqprop,stamp), !eq)
210                                 in eq := eq';                                in
211                                      eq := eq';
212                                    updateMap eqprop (stamp,eq')                                    updateMap eqprop (stamp,eq')
213                                end                                end
214                            | _ => bug "eqAnalyze.scan.tscan")                            | _ => bug "eqAnalyze.scan.tscan")
# Line 202  Line 216 
216                                         err "inconsistent equality properties")                                         err "inconsistent equality properties")
217                   else () (* external -- assume eqprop already defined *)                   else () (* external -- assume eqprop already defined *)
218                | addtyc _ = ()                | addtyc _ = ()
219           in if localStamp(MU.getStrStamp str) then           in
220                if localStamp(MU.getStrStamp str) then
221                  (List.app (fn s => addstr s) (MU.getStrs str);                  (List.app (fn s => addstr s) (MU.getStrs str);
222                   List.app (fn t => addtyc t) (MU.getTycs str))                   List.app (fn t => addtyc t) (MU.getTycs str))
223          (* BUG? - why can we get away with ignoring functor elements??? *)          (* BUG? - why can we get away with ignoring functor elements??? *)
# Line 227  Line 242 
242    
243      (* propagate the NO eqprop forward and the YES eqprop backward *)      (* propagate the NO eqprop forward and the YES eqprop backward *)
244      fun propagate_YES_NO(stamp) =      fun propagate_YES_NO(stamp) =
245        let fun earlier s = Stamps.cmp(s,stamp) = LESS        let fun earlier s = Stamps.compare(s,stamp) = LESS
246         in case applyMap''(eqprop,stamp)         in case applyMap''(eqprop,stamp)
247             of YES =>             of YES =>
248                 propagate (YES,(fn s => applyMap'(depend,s)),earlier) stamp                 propagate (YES,(fn s => applyMap'(depend,s)),earlier) stamp
# Line 238  Line 253 
253      (* propagate the IND eqprop *)      (* propagate the IND eqprop *)
254      fun propagate_IND(stamp) =      fun propagate_IND(stamp) =
255        let fun depset s = applyMap'(dependr,s)        let fun depset s = applyMap'(dependr,s)
256            fun earlier s = Stamps.cmp(s,stamp) = LESS            fun earlier s = Stamps.compare(s,stamp) = LESS
257         in case applyMap''(eqprop,stamp)         in case applyMap''(eqprop,stamp)
258             of UNDEF => (updateMap eqprop (stamp,IND);             of UNDEF => (updateMap eqprop (stamp,IND);
259                          propagate (IND,depset,earlier) stamp)                          propagate (IND,depset,earlier) stamp)
# Line 249  Line 264 
264      (* phase 0: scan signature strenv, joining eqprops of shared tycons *)      (* phase 0: scan signature strenv, joining eqprops of shared tycons *)
265      val _ = addstr str      val _ = addstr str
266      val tycStamps =      val tycStamps =
267        ListMergeSort.sort (fn xy => Stamps.cmp xy = GREATER) (!tycStampsRef)        ListMergeSort.sort (fn xy => Stamps.compare xy = GREATER) (!tycStampsRef)
268   in   in
269      (* phase 1: propagate YES backwards and NO forward *)      (* phase 1: propagate YES backwards and NO forward *)
270      app propagate_YES_NO tycStamps;      app propagate_YES_NO tycStamps;
# Line 262  Line 277 
277            let val eqp = case applyMap''(eqprop,s)            let val eqp = case applyMap''(eqprop,s)
278                            of DATA => YES                            of DATA => YES
279                             | e => e                             | e => e
280             in app (fn tyc as GENtyc{eq,...} => eq := eqp) (applyMap(tycons,s))                fun set (GENtyc { eq, ... }) = eq := eqp
281                    | set _ = ()
282               in app set (applyMap'(tycons,s))
283            end)            end)
284      tycStamps      tycStamps
285  end  end
# Line 288  Line 305 
305  let val names = map TU.tycName datatycs  let val names = map TU.tycName datatycs
306      val _ = debugmsg (">>defineEqProps: "^ namesToString names)      val _ = debugmsg (">>defineEqProps: "^ namesToString names)
307      val n = List.length datatycs      val n = List.length datatycs
308      val GENtyc{kind=DATATYPE{family={members,...},      val {family={members,...}, freetycs,...} =
309                 freetycs,...},...}::_ = datatycs          case List.hd datatycs of
310      val eqs = map (fn GENtyc{eq,...} => eq) datatycs              GENtyc { kind = DATATYPE x, ...} => x
311              | _ => bug "defineEqProps (List.hd datatycs)"
312        val eqs =
313            let fun get (GENtyc { eq, ... }) = eq
314                  | get _ = bug "eqs:get"
315            in map get datatycs
316            end
317      fun getEq i =      fun getEq i =
318             !(List.nth(eqs,i))             !(List.nth(eqs,i))
319              handle Subscript =>              handle Subscript =>
# Line 307  Line 330 
330          raise Subscript))          raise Subscript))
331       val visited = ref([]: int list)       val visited = ref([]: int list)
332    
333       fun checkTyc (tyc0 as GENtyc{eq as ref DATA,kind=DATATYPE{index,...},path,       fun checkTyc (tyc0 as GENtyc { eq, kind, path, ... }) =
334                               ...}) =           (case (!eq, kind) of
335         let val _ = debugmsg (">>checkTyc: "^Symbol.name(IP.last path)^" "^                (DATA, DATATYPE { index, ... }) =>
336                  let val _ = debugmsg (">>checkTyc: "^
337                                        Symbol.name(IP.last path)^" "^
338                                    Int.toString index)                                    Int.toString index)
339           fun eqtyc(GENtyc{eq=ref DATA,kind=DATATYPE{index,...},path,...}) =                    fun eqtyc (GENtyc { eq = e', kind = k', path, ... }) =
340                (debugmsg ("eqtyc[GENtyc(DATA)]: " ^ Symbol.name(IP.last path) ^                        (case (!e', k')
341                            of (DATA,DATATYPE{index,...}) =>
342                               (debugmsg ("eqtyc[GENtyc(DATA)]: " ^
343                                          Symbol.name(IP.last path) ^
344                                   " " ^ Int.toString index);                                   " " ^ Int.toString index);
345                         (* ASSERT: argument tycon is a member of datatycs *)                         (* ASSERT: argument tycon is a member of datatycs *)
346                         checkDomains index)                         checkDomains index)
347             | eqtyc(GENtyc{eq=ref UNDEF,path,...}) =                           | (UNDEF,_) =>
348                (debugmsg ("eqtyc[GENtyc(UNDEF)]: " ^ Symbol.name(IP.last path));                             (debugmsg ("eqtyc[GENtyc(UNDEF)]: " ^
349                                          Symbol.name(IP.last path));
350                         IND)                         IND)
351            | eqtyc(GENtyc{eq=ref eqp,path,...}) =                           | (eqp,_) =>
352                    (debugmsg ("eqtyc[GENtyc(_)]: " ^ Symbol.name(IP.last path) ^                             (debugmsg ("eqtyc[GENtyc(_)]: " ^
353                                          Symbol.name(IP.last path) ^
354                                   " " ^ TU.eqpropToString eqp);                                   " " ^ TU.eqpropToString eqp);
355                         eqp)                              eqp))
356            | eqtyc(RECtyc i) =            | eqtyc(RECtyc i) =
357                        (debugmsg ("eqtyc[RECtyc]: " ^ Int.toString i);                        (debugmsg ("eqtyc[RECtyc]: " ^ Int.toString i);
358                         checkDomains i)                         checkDomains i)
# Line 334  Line 364 
364    
365          and checkDomains i =          and checkDomains i =
366              if member(i,!visited) then getEq i              if member(i,!visited) then getEq i
367              else let val _ = visited := i :: !visited                        else let
368                              val _ = visited := i :: !visited
369                       val {tycname,dcons,...} : dtmember                       val {tycname,dcons,...} : dtmember
370                             = Vector.sub(members,i)                             = Vector.sub(members,i)
371                             handle Subscript =>                             handle Subscript =>
372                 (say (String.concat["$getting member ",Int.toString i," from ",                                       (say (String.concat
373                                                   ["$getting member ",
374                                                    Int.toString i,
375                                                    " from ",
376                                          Int.toString(Vector.length members),"\n"]);                                          Int.toString(Vector.length members),"\n"]);
377                       raise Subscript)                       raise Subscript)
378                               val _ = debugmsg("checkDomains: visiting "                               val _ = debugmsg("checkDomains: visiting "
# Line 349  Line 383 
383                                           | {domain=NONE,name,rep} => unitTy)                                           | {domain=NONE,name,rep} => unitTy)
384                                         dcons                                         dcons
385                               val eqp = eqtylist(domains)                               val eqp = eqtylist(domains)
386                            in setEq(i,eqp);                            in
387                               debugmsg ("checkDomains: setting "^Int.toString i^                                setEq(i,eqp);
388                                  debugmsg ("checkDomains: setting "^
389                                            Int.toString i^
390                                         " to "^TU.eqpropToString eqp);                                         " to "^TU.eqpropToString eqp);
391                               eqp                               eqp
392                           end                           end
393    
394          and eqty(VARty(ref(INSTANTIATED ty))) =   (* shouldn't happen *)                    and eqty(VARty(ref(INSTANTIATED ty))) =
395                          (* shouldn't happen *)
396                        eqty ty                        eqty ty
397            | eqty(CONty(tyc,args)) =            | eqty(CONty(tyc,args)) =
398                (case ExpandTycon.expandTycon(tyc,sigContext,sigEntEnv)                (case ExpandTycon.expandTycon(tyc,sigContext,sigEntEnv)
399                   of FREEtyc i =>                   of FREEtyc i =>
400                        let val _ =                        let val _ =
401                              debugmsg ("eqtyc[FREEtyc]: " ^ Int.toString i)                              debugmsg ("eqtyc[FREEtyc]: " ^ Int.toString i)
402                            val tc = (List.nth(freetycs,i) handle _ =>                                 val tc = (List.nth(freetycs,i)
403                                             handle _ =>
404                                            bug "unexpected freetycs 343")                                            bug "unexpected freetycs 343")
405                         in eqty(CONty(tc, args))                             in
406                                   eqty(CONty(tc, args))
407                        end                        end
408                    | DEFtyc{tyfun,...} =>                    | DEFtyc{tyfun,...} =>
409                       (* shouldn't happen - type abbrevs in domains                       (* shouldn't happen - type abbrevs in domains
# Line 399  Line 438 
438               in loop(tys,YES)               in loop(tys,YES)
439              end              end
440    
441       in case eqtyc tyc0                in
442                      case eqtyc tyc0
443            of YES => app (fn i =>            of YES => app (fn i =>
444                            case getEq i                            case getEq i
445                             of DATA => setEq(i,YES)                             of DATA => setEq(i,YES)
# Line 420  Line 460 
460          (* ASSERT: eqprop of tyc0 is YES, NO, or IND *)          (* ASSERT: eqprop of tyc0 is YES, NO, or IND *)
461         case !eq         case !eq
462          of (YES | NO | IND) => ()          of (YES | NO | IND) => ()
463           | DATA => bug ("checkTyc[=>DATA]: "^Symbol.name(IP.last path))                      | DATA =>
464           | UNDEF => bug ("checkTyc[=>other]: "^Symbol.name(IP.last path))          end                        bug ("checkTyc[=>DATA]: "^Symbol.name(IP.last path))
465                        | _ =>
466                          bug ("checkTyc[=>other]: "^Symbol.name(IP.last path))
467                  end
468                | _ => ())
469    | checkTyc _ = ()    | checkTyc _ = ()
470    in List.app checkTyc datatycs  in
471        List.app checkTyc datatycs
472   end   end
473    
474  fun isEqType ty =  fun isEqType ty =

Legend:
Removed from v.586  
changed lines
  Added in v.587

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0