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/branches/primop-branch-3/compiler/Elaborator/modules/instantiate.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-3/compiler/Elaborator/modules/instantiate.sml

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

revision 3346, Fri May 15 15:20:06 2009 UTC revision 3347, Fri May 15 15:53:19 2009 UTC
# Line 42  Line 42 
42            region   : SourceMap.region,            region   : SourceMap.region,
43            compInfo : ElabUtil.compInfo}            compInfo : ElabUtil.compInfo}
44           -> {rlzn: Modules.strEntity,           -> {rlzn: Modules.strEntity,
45               abstycs: Types.tycon list,               primaries : (Types.tycon list * (Stamps.stamp * Modules.fctsig) list)}
              tyceps: EntPath.entPath list}  
46    
47    (*** instantiation of the structure abstractions ***)    (*** instantiation of the structure abstractions ***)
48    val instAbstr :    val instAbstr :
# Line 54  Line 53 
53            region   : SourceMap.region,            region   : SourceMap.region,
54            compInfo : ElabUtil.compInfo}            compInfo : ElabUtil.compInfo}
55           -> {rlzn: Modules.strEntity,           -> {rlzn: Modules.strEntity,
56               abstycs: Types.tycon list,               primaryTycs : Types.tycon list}
              tyceps: EntPath.entPath list}  
57    
58    val debugging : bool ref    val debugging : bool ref
59    
# Line 686  Line 684 
684      val this_path =      val this_path =
685          case !this_slot          case !this_slot
686            of InitialStr{path,...} => ConvertPaths.invertIPath path            of InitialStr{path,...} => ConvertPaths.invertIPath path
687             | _ => bug "buildTycClass: this_slot not InitialTyc"             | _ => bug "buildStrClass: this_slot not InitialTyc"
688    
689      (* addInst(old,new,depth);      (* addInst(old,new,depth);
690       * (1) Adds new to the current equivalence class in response to a sharing       * (1) Adds new to the current equivalence class in response to a sharing
# Line 947  Line 945 
945  (*************************************************************************  (*************************************************************************
946   * buildTycClass: int * slot * entityEnv * instKind * rpath * (unit->stamp)   * buildTycClass: int * slot * entityEnv * instKind * rpath * (unit->stamp)
947   *                * EM.complainer   *                * EM.complainer
948   *                -> (tycon * entPath) option   *                -> tycon option
949   *   *
950   * This function deals with exploration of type nodes in the instance   * This function deals with exploration of type nodes in the instance
951   * graph.  It is similar to the buildStrClass function above, but it is   * graph.  It is similar to the buildStrClass function above, but it is
# Line 969  Line 967 
967  (* ASSERT: this_slot is an InitialTyc  (* ASSERT: this_slot is an InitialTyc
968   * This is clearly true given that buildTycClass is only called in   * This is clearly true given that buildTycClass is only called in
969   * a case branch (in expandInst) where the pattern is InitialTyc *)   * a case branch (in expandInst) where the pattern is InitialTyc *)
970  fun buildTycClass (cnt, this_slot, instKind, rpath, mkStamp, err) =  fun buildTycClass (this_slot, instKind, rpath, mkStamp, err) =
971    let val class = ref ([] : slot list)    let val class = ref ([] : slot list)
972        val classDef = ref (NONE : (tycInst * int) option)        val classDef = ref (NONE : (tycInst * int) option)
973        val minDepth = ref infinity        val minDepth = ref infinity
# Line 1162  Line 1160 
1160                                              path=IP.append(rpath,path),                                              path=IP.append(rpath,path),
1161                                              kind=knd, eq=ref(eqprop),                                              kind=knd, eq=ref(eqprop),
1162                                              stub = NONE}                                              stub = NONE}
1163                         in (FinalTyc(ref(INST tyc)), SOME(tyc,epath))                         in (FinalTyc(ref(INST tyc)), SOME tyc)
1164                         end                         end
1165                       | DATATYPE _ =>                       | DATATYPE _ =>
1166                         let val tyc = GENtyc{stamp=mkStamp(), kind=kind,                         let val tyc = GENtyc{stamp=mkStamp(), kind=kind,
# Line 1172  Line 1170 
1170                         (* domains of dataconstructors will be instantiated                         (* domains of dataconstructors will be instantiated
1171                          * in instToTyc *)                          * in instToTyc *)
1172                         end                         end
1173                       | _ => bug "scanForRep 9")                       | _ => bug "scanForRep 6")
1174                  | ERRORtyc => (FinalTyc(ref(INST ERRORtyc)), NONE)                  | ERRORtyc => (FinalTyc(ref(INST ERRORtyc)), NONE)
1175                  | DEFtyc _ => bug "scanForRep 6"                  | DEFtyc _ => bug "scanForRep 7"
1176                  | _ => bug "scanForRep 7"                  | _ => bug "scanForRep 8"
1177            end (* fun scanForRep *)            end (* fun scanForRep *)
1178    
1179        fun getSlotEp slot =        fun getSlotEp slot =
# Line 1227  Line 1225 
1225  *)  *)
1226    
1227  fun sigToInst (ERRORsig, instKind, rpath, err, compInfo) =  fun sigToInst (ERRORsig, instKind, rpath, err, compInfo) =
1228        (ErrorStr,[],[])        (ErrorStr,[])
1229    | sigToInst (sign, instKind, rpath, err,    | sigToInst (sign, instKind, rpath, err,
1230                 compInfo as {mkStamp,...}: EU.compInfo) =                 compInfo as {mkStamp,...}: EU.compInfo) =
1231    let val flextycs : T.tycon list ref = ref [] (* the "abstract" tycons *)    let val primaryTycs : T.tycon list ref = ref [] (* the "primary" tycons *)
       val flexeps : EP.entPath list ref = ref []  
           (* the tkind environment *)  
       val cnt = ref 0  
   
       (* addbt: collects tycons and entity path -> tkind bindings  
          produced by calls of buildTycClass below *)  
       fun addbt NONE = ()  
         | addbt (SOME (tyc,ep)) =  
             (flextycs := (tyc::(!flextycs));  
              flexeps := (ep::(!flexeps));  
              cnt := ((!cnt) + 1))  
1232    
1233        fun expand ErrorStr = ()        fun expand ErrorStr = ()
1234          | expand (FinalStr {expanded=ref true,...}) = ()          | expand (FinalStr {expanded=ref true,...}) = ()
# Line 1275  Line 1262 
1262                                     S.name sym);                                     S.name sym);
1263                            expand inst)                            expand inst)
1264                       | InitialTyc _ =>                       | InitialTyc _ =>
1265                           addbt(buildTycClass(!cnt, slot, instKind,                           (case buildTycClass(slot, instKind,
1266                                               rpath, mkStamp, err))                                              rpath, mkStamp, err)
1267                                of NONE => ()
1268                                 | SOME tyc => primaryTycs := (tyc::(!primaryTycs)))
1269                       | _ => ())                       | _ => ())
1270    
1271               in debugmsg ">>expand"; expanded := true;               in debugmsg ">>expand"; expanded := true;
# Line 1295  Line 1284 
1284        val strInst = !baseSlot        val strInst = !baseSlot
1285        val _ = expand strInst        val _ = expand strInst
1286    
1287     in (strInst, !flextycs, !flexeps)     in (strInst, rev(!primaryTycs))
1288    end (* fun sigToInst *)    end (* fun sigToInst *)
1289    
1290  exception Get_Origin  (* who is going to catch it? *)  exception Get_Origin  (* who is going to catch it? *)
# Line 1309  Line 1298 
1298    
1299  fun instToStr (instance, entEnv, instKind, rpath: IP.path, err,  fun instToStr (instance, entEnv, instKind, rpath: IP.path, err,
1300                 compInfo as {mkStamp, ...}: EU.compInfo)                 compInfo as {mkStamp, ...}: EU.compInfo)
1301                : M.strEntity =                : (M.strEntity * (ST.stamp * M.fctsig) list) =
1302  let fun instToStr' (instance as (FinalStr{sign as SIG {closed, elements,... },  let val primFcts : (Stamps.stamp, M.fctsig) list = ref []
1303        fun instToStr' (instance as (FinalStr{sign as SIG {closed, elements,... },
1304                                            slotEnv,finalEnt,stamp,...}),                                            slotEnv,finalEnt,stamp,...}),
1305                      entEnv, rpath: IP.path, failuresSoFar: int)                      entEnv, rpath: IP.path, failuresSoFar: int)
1306                : M.strEntity * int =                : M.strEntity * int =
# Line 1477  Line 1467 
1467    
1468                              | NONE =>                              | NONE =>
1469                                let val stamp = mkStamp()                                let val stamp = mkStamp()
1470                                      val (paramRlzn, primaryTycs, primaryFcts) =
1471                                          instGeneric{sign=paramsig, entEnv=entEnv,
1472                                                      rpath=path,
1473                                                      region=SourceMap.nullRegion,
1474                                                      instKind=INST_FORMAL,
1475                                                      compInfo=compInfo}
1476                                    val (bodyExp) =                                    val (bodyExp) =
1477                                        case instKind                                        case instKind
1478                                         of INST_ABSTR {entities,...} =>                                         of INST_ABSTR {entities,...} =>
# Line 1486  Line 1482 
1482                                                                VARstr [paramvar]))                                                                VARstr [paramvar]))
1483                                            end                                            end
1484                                          | INST_FORMAL => M.FORMstr sign                                          | INST_FORMAL => M.FORMstr sign
1485                                    val (paramRlzn, abstycs, _) =                                    val exp = LAMBDA{param=paramvar,
                                       instGeneric{sign=paramsig, entEnv=entEnv,  
                                                   rpath=path,  
                                                   region=SourceMap.nullRegion,  
                                                   instKind=INST_FORMAL,  
                                                   compInfo=compInfo}  
                                   val nenv = EE.mark(mkStamp,  
                                                      EE.bind(paramvar,  
                                                              STRent paramRlzn,  
                                                              entEnv))  
                                   val cl = CLOSURE{param=paramvar,  
1486                                                     body=bodyExp,                                                     body=bodyExp,
1487                                                     env=entEnv}                                                     primaries=(primaryTycs,primaryFcts)}
1488                                in FCTent {stamp = stamp,                                in primFcts := (stamp,sign)::!primFcts;
1489                                     FCTent {stamp = stamp,
1490                                             exp = exp,
1491                                             env = entEnv,
1492                                           rpath=path,                                           rpath=path,
1493                                           exp=LAMBDA{param=paramvar,                                           stub = NONE,
1494                                                      body=bodyExp,                                           properties = PropList.newHolder ()}
                                                     primaries = abstycs,  
                                                     paramRlzn = paramRlzn},  
                                          closureEnv=entEnv,  
                                          properties = PropList.newHolder (),  
                                          stub=NONE}  
1495                                end                                end
1496    
1497                              | _ => bug "unexpected functor def in instToStr",                              | _ => bug "unexpected functor def in instToStr",
# Line 1609  Line 1593 
1593                           EM.nullErrorBody;                           EM.nullErrorBody;
1594                        strEnt')                        strEnt')
1595               end)               end)
1596   in loop(instToStr'(instance,entEnv,rpath,0))   in (loop(instToStr'(instance,entEnv,rpath,0));
1597        !primFcts)
1598  end (* fun instToStr *)  end (* fun instToStr *)
1599    
1600  (*** fetching the TycKind for a particular functor signature ***)  (*** fetching the TycKind for a particular functor signature ***)
# Line 1624  Line 1609 
1609     compInfo : compInfo  -- for mkStamp and error     compInfo : compInfo  -- for mkStamp and error
1610  ->  ->
1611     strEnt : strEntity (str realization)     strEnt : strEntity (str realization)
1612     abs_tycs : tycon list  -- tycs introduced by instantiation     primaryTycs : tycon list  -- primary tycons
1613     tyceps :  entpath list -- the initial segment of all_eps     primaryFcts : (stamp * fctsig) list  -- primary fcts
                              collected in sigToInst  
1614  *)  *)
1615  and instGeneric{sign, entEnv, instKind, rpath, region,  and instGeneric{sign, entEnv, instKind, rpath, region,
1616                  compInfo as {mkStamp,error,...} : EU.compInfo} =                  compInfo as {mkStamp,error,...} : EU.compInfo} =
# Line 1638  Line 1622 
1622        val baseStamp = mkStamp()        val baseStamp = mkStamp()
1623        *)        *)
1624    
1625        val (inst, abstycs, tyceps) =        val (inst, primaryTycs) =
1626            sigToInst(sign, instKind, rpath, err, compInfo)            sigToInst(sign, instKind, rpath, err, compInfo)
1627    
1628        val strEnt =        val (strEnt, primaryFcts) =
1629            instToStr(inst,entEnv,instKind,rpath,err,compInfo)            instToStr(inst,entEnv,instKind,rpath,err,compInfo)
1630    
1631        val tyceps = rev tyceps  (*  let's not for now ...
   
1632        (* let's memoize the resulting bound tycon entity paths, tyceps *)        (* let's memoize the resulting bound tycon entity paths, tyceps *)
1633        val _ = case sign        val _ = case sign
1634                 of M.SIG sigrec =>                 of M.SIG sigrec =>
# Line 1653  Line 1636 
1636                       of NONE => ModPropList.setSigBoundeps (sigrec, SOME tyceps)                       of NONE => ModPropList.setSigBoundeps (sigrec, SOME tyceps)
1637                        | _ => ())                        | _ => ())
1638                  | _ => ()                  | _ => ()
1639    *)
1640        val _ = debugmsg "<<instantiate"        val _ = debugmsg "<<instantiate"
1641     in (strEnt, rev abstycs, tyceps)     in (strEnt, primaryTycs, primaryFcts)
1642    end    end
1643    
1644  (* debugging wrappers  (* debugging wrappers
# Line 1678  Line 1661 
1661    
1662  (*** instantiation of the formal functor body signatures ***)  (*** instantiation of the formal functor body signatures ***)
1663  fun instFormal{sign, entEnv, rpath, region, compInfo} =  fun instFormal{sign, entEnv, rpath, region, compInfo} =
1664    let val (rlzn, abstycs, tyceps)    let val (rlzn, primaryTycs, primaryFcts)
1665          = instGeneric{sign=sign, entEnv=entEnv, instKind=INST_FORMAL,          = instGeneric{sign=sign, entEnv=entEnv, instKind=INST_FORMAL,
1666                        rpath=rpath, region=region, compInfo=compInfo}                        rpath=rpath, region=region, compInfo=compInfo}
1667     in {rlzn=rlzn, abstycs=abstycs, tyceps=tyceps}     in {rlzn=rlzn, primaries=(primaryTycs,primaryFcts)}
1668    end    end
1669    
1670  (*** instantiation of the structure abstractions **)  (*** instantiation of the structure abstractions **)
1671  fun instAbstr{sign, entEnv, srcRlzn, rpath, region, compInfo} =  fun instAbstr{sign, entEnv, srcRlzn, rpath, region, compInfo} =
1672    let val (rlzn, abstycs, tyceps)    let val (rlzn, primaryTycs, _)
1673          = instGeneric{sign=sign, entEnv=entEnv, instKind=INST_ABSTR srcRlzn,          = instGeneric{sign=sign, entEnv=entEnv, instKind=INST_ABSTR srcRlzn,
1674                        rpath=rpath, region=region, compInfo=compInfo}                        rpath=rpath, region=region, compInfo=compInfo}
1675     in {rlzn=rlzn, abstycs=abstycs, tyceps=tyceps}     in {rlzn=rlzn, primaryTycs=primaryTycs}
1676    end    end
1677    
1678  val instFormal =  val instFormal =

Legend:
Removed from v.3346  
changed lines
  Added in v.3347

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