add typename nonces, regain speed

--HG--
branch : com.mozilla.es4.smlnj.new-type-normalizer
extra : convert_revision : 54d9a64ef63d57f8264dd50bfafeb5fdbc68e0da

ast.sml

@@ -41,7 +41,7 @@ type LOC = { file: string, span: SOURCE_POS * SOURCE_POS, post_newline: bool }
 
 type IDENT = Ustring.STRING
 
-type RIB_ID = int
+type AST_NONCE = int
 
 type TYPEVAR_NONCE = int
 
@@ -231,7 +231,7 @@ datatype PRAGMA =
          SpecialType of SPECIAL_TY
        | UnionType of TYPE_EXPR list
        | ArrayType of TYPE_EXPR list
-       | TypeName of IDENT_EXPR
+       | TypeName of (IDENT_EXPR * AST_NONCE option)
        | ElementTypeRef of (TYPE_EXPR * int)
        | FieldTypeRef of (TYPE_EXPR * IDENT)
        | FunctionType of FUNC_TYPE

defn.sml

@@ -1077,7 +1077,7 @@ and classInstanceType (cfxtr:Ast.FIXTURE)
  * TYPE_EXPRs of a simple form: those which name a 0-parameter interface. 
  * Generalize later. 
  *)
-and extractIdentExprFromTypeName (Ast.TypeName ie) : Ast.IDENT_EXPR = ie
+and extractIdentExprFromTypeName (Ast.TypeName (ie, _)) : Ast.IDENT_EXPR = ie
   | extractIdentExprFromTypeName _ = 
     error ["can only presently handle inheriting from simple named interfaces"]
 
@@ -2032,7 +2032,7 @@ and defTypeExpr (env:ENV)
     case typeExpr of
         Ast.FunctionType t =>
         Ast.FunctionType (defFuncTy env t)
-      | Ast.TypeName n =>
+      | Ast.TypeName (n,nonce) =>
         let
         in
             case n of
@@ -2042,12 +2042,12 @@ and defTypeExpr (env:ENV)
                 in case (base,i) of
                    (Ast.LiteralExpr _,Ast.Identifier {ident=id,...}) =>
                    Ast.TypeName (Ast.QualifiedIdentifier {qual=(defExpr env base),
-                                                          ident=id})
+                                                          ident=id}, NONE)
                  | (_,_) =>
                        LogErr.defnError ["invalid type expr ", Ustring.toAscii (hd p)]
                 end
               | _ =>
-                Ast.TypeName (defIdentExpr env n)
+                Ast.TypeName ((defIdentExpr env n), nonce)
          end
       | Ast.UnionType tys =>
         Ast.UnionType (map (defTypeExpr env) tys)

eval.sml

@@ -3006,7 +3006,7 @@ and evalTypeExpr (regs:Mach.REGS)
         Ast.SpecialType st => Mach.Null (* FIXME *)
       | Ast.UnionType ut => Mach.Null (* FIXME *)
       | Ast.ArrayType a => Mach.Null (* FIXME *)
-      | Ast.TypeName tn => evalExpr regs (Ast.LexicalRef { ident=tn, loc=NONE })
+      | Ast.TypeName (tn, _) => evalExpr regs (Ast.LexicalRef { ident=tn, loc=NONE })
       | Ast.FunctionType ft => Mach.Null (* FIXME *)
       | Ast.ObjectType ot => Mach.Null (* FIXME *)
       | Ast.LikeType lt => Mach.Null (* FIXME *)
@@ -5583,7 +5583,7 @@ and evalFragment (regs:Mach.REGS)
                    val exnStr = Ustring.toAscii (toUstring regs v)
                in
                    LogErr.setLoc loc;
-                   error regs ["uncaught exception: ", Ustring.toAscii (toUstring regs v)]
+                   error regs ["uncaught exception: ", exnStr]
                end
     end
 

fixture.sml

@@ -38,6 +38,7 @@ fun log ss = LogErr.log ("[fixture] " :: ss)
 fun error ss = LogErr.fixtureError ss
 fun trace ss = if (!doTrace) then log ss else ()
 
+(*
 fun cmpMname (a:Ast.MULTINAME, b:Ast.MULTINAME) 
     : order = 
     case Ustring.compare (#id a) (#id b) of
@@ -64,34 +65,10 @@ structure IntKey = struct type ord_key = Int.int val compare = Int.compare end
 structure IntMap = SplayMapFn (IntKey);
 
 
-(* 
- * Rib records have a lifecycle. 
- *
- * There is always exactly one root rib, and it never closes.
- * 
- * Under the root rib, there are a variety of other ribs: 
- * 
- *   - open top unit ribs, which are placeholders with no content.
- * 
- *   - closed top unit ribs, which store a snapshot of the root rib at
- *     the moment they closed.
- * 
- *   - general ribs, which may be children of either form of top rib
- *     *or* direct children of the root.
- * 
- * If a general rib has no parent, or has an open top-unit rib as its
- * parent, it's implicitly a child of the root rib and is implicitly open.
- * 
- * If any rib has a closed top-unit rib as a parent, the rib is closed by 
- * extension and all type reasoning in it should actually resolve; there should
- * never be partial-evaluation stalls. Failure to find a fixture name
- * (say a type) under a closed top-unit rib is always a hard error.
- * 
- *)
-
 datatype RIB_RECORD = 
          GeneralRib of { parent: Ast.RIB_ID option,
                          rib: Ast.RIB }
+*)
 
 
 (* -----------------------------------------------------------------------------

logerr.sml

@@ -141,13 +141,13 @@ fun ty t =
           | Ast.SpecialType Ast.VoidType => "<VoidType>"
           | Ast.UnionType tys => "(" ^ (typeOrList tys) ^ ")"
           | Ast.ArrayType tys => "[" ^ (typeList tys) ^ "]"
-          | Ast.TypeName (Ast.Identifier {ident, openNamespaces}) => 
+          | Ast.TypeName (Ast.Identifier {ident, openNamespaces}, _) => 
 	    "<TypeName: {" 
 	    ^ (nsssToString openNamespaces) 
 	    ^ "}::" 
 	    ^ (Ustring.toAscii ident) 
 	    ^ ">"
-          | Ast.TypeName (Ast.QualifiedIdentifier { qual, ident }) => 
+          | Ast.TypeName (Ast.QualifiedIdentifier { qual, ident }, _) => 
 	    "<TypeName: " 
 	    ^ (nsExprToString qual) 
 	    ^ "::" 

mach.sml

@@ -58,10 +58,13 @@ structure StrMap = SplayMapFn (StrKey);
 
 structure Real64Key = struct type ord_key = Real64.real val compare = Real64.compare end
 structure Real64Map = SplayMapFn (Real64Key);
+
+structure IntKey = struct type ord_key = Int.int val compare = Int.compare end
+structure IntMap = SplayMapFn (IntKey);
 
 fun nameEq (a:Ast.NAME) (b:Ast.NAME) = ((#id a) = (#id b) andalso (#ns a) = (#ns b))
 
-val cachesz = 1024
+val cachesz = 4096
 
 type ATTRS = { dontDelete: bool,
                dontEnum: bool,
@@ -100,7 +103,8 @@ datatype VAL = Object of OBJ
           uintCache: (OBJ Real64Map.map) ref,
           nsCache: (OBJ NsMap.map) ref,
           nmCache: (OBJ NmMap.map) ref,
-          strCache: (OBJ StrMap.map) ref
+          strCache: (OBJ StrMap.map) ref,
+          tyCache: (Ast.TYPE_EXPR IntMap.map) ref (* well, mostly objs *)
          }
 
      and PROFILER =
@@ -1171,27 +1175,31 @@ fun updateCache cacheGetter
         then ((c := cacheInsert ((!c), k, v)); v)
         else v
     end
+
 
 fun getDoubleCache (regs:REGS) = (#doubleCache (getCaches regs)) 
 fun getUIntCache (regs:REGS) = (#uintCache (getCaches regs)) 
 fun getIntCache (regs:REGS) = (#intCache (getCaches regs)) 
 fun getNsCache (regs:REGS) = (#nsCache (getCaches regs)) 
 fun getNmCache (regs:REGS) = (#nmCache (getCaches regs)) 
 fun getStrCache (regs:REGS) = (#strCache (getCaches regs)) 
+fun getTyCache (regs:REGS) = (#tyCache (getCaches regs)) 
 
 val findInDoubleCache = findInCache getDoubleCache Real64Map.find
 val findInUIntCache = findInCache getUIntCache Real64Map.find
 val findInIntCache = findInCache getIntCache Real64Map.find
 val findInNsCache = findInCache getNsCache NsMap.find
 val findInNmCache = findInCache getNmCache NmMap.find
 val findInStrCache = findInCache getStrCache StrMap.find
+val findInTyCache = findInCache getTyCache IntMap.find
 
 val updateDoubleCache = updateCache getDoubleCache Real64Map.numItems Real64Map.insert
 val updateUIntCache = updateCache getUIntCache Real64Map.numItems Real64Map.insert
 val updateIntCache = updateCache getIntCache Real64Map.numItems Real64Map.insert
 val updateNsCache = updateCache getNsCache NsMap.numItems NsMap.insert
 val updateNmCache = updateCache getNmCache NmMap.numItems NmMap.insert
 val updateStrCache = updateCache getStrCache StrMap.numItems StrMap.insert
+val updateTyCache = updateCache getTyCache IntMap.numItems IntMap.insert
 
 val defaultDecimalContext = 
 	{ precision = 34,
@@ -1218,7 +1226,8 @@ fun makeInitialRegs (prog:Fixture.PROGRAM)
                        intCache = ref Real64Map.empty,
                        nsCache = ref NsMap.empty,
                        nmCache = ref NmMap.empty,
-                       strCache = ref StrMap.empty }
+                       strCache = ref StrMap.empty,
+                       tyCache = ref IntMap.empty }
         val specials = SpecialObjs 
                        { classClass = ref NONE,
                          interfaceClass = ref NONE,

main.sml

@@ -207,6 +207,16 @@ fun verify prog argvRest =
         f prog [] frags
     end
 
+(* BEGIN SPEED HACK *)
+(* 
+ * This wins a factor of 60 in performance. It's worth it.
+ * Just don't copy this nonsense to the spec. 
+ *)
+fun installTypeCache regs = 
+    ((Type.cacheLoad := SOME (fn i => Mach.findInTyCache regs i));
+     (Type.cacheSave := SOME (fn i => fn t => (Mach.updateTyCache regs (i, t); ()))))
+(* END SPEED HACK *)
+
 fun eval regs argvRest =
     let
         val (prog, frags) = verify (#prog regs) argvRest
@@ -215,6 +225,7 @@ fun eval regs argvRest =
         Mach.setLangEd regs (!langEd);
         Posix.Process.alarm (Time.fromReal 300.0);
 	    TextIO.print "evaluating ... \n";
+        installTypeCache regs;
         withHandlers (fn () => map (Eval.evalTopFragment regs) frags)
     end
 
@@ -325,6 +336,7 @@ fun repl (regs:Mach.REGS)
                                 val regs = !regsCell
 					            val _ = Mach.resetStack regs
                                 val _ = Mach.setLangEd regs (!langEd)
+                                val _ = installTypeCache regs
                                 val res = (Eval.evalTopFragment regs frag)
 						            handle Eval.ThrowException v => (tidyUp (); v)
                             in

name.sml

@@ -73,10 +73,10 @@ fun uint32ops (id:Ast.IDENT) : Ast.NAME = { id = id, ns = uint32opsNS }
 
 fun typename (n:Ast.NAME) =
     Ast.TypeName (Ast.QualifiedIdentifier
-		      { ident = (#id n),
-			qual = Ast.LiteralExpr
-				   (Ast.LiteralNamespace (#ns n)) })
-
+					  { ident = (#id n),
+						qual = Ast.LiteralExpr
+								   (Ast.LiteralNamespace (#ns n)) }, NONE)
+																		   
 (*
  * Names that are supposed to be present in the global scope
  * once we finish booting.

parser.sml

@@ -45,6 +45,10 @@ val doTrace = ref false
 fun trace ss = if (!doTrace) then LogErr.log ("[parse] " :: ss) else ()
 fun error ss = LogErr.parseError ss
 
+val astNonceCounter = ref 0
+fun nextAstNonce _ = ( astNonceCounter := (!astNonceCounter) + 1;
+                       !astNonceCounter)
+
 exception ParseError = LogErr.ParseError
 exception LexError = LogErr.LexError
 exception EofError = LogErr.EofError
@@ -5968,14 +5972,14 @@ and needType (nd:Ast.IDENT_EXPR,nullable:bool option) =
     case nd of
         Ast.Identifier {ident,...} =>
                 if( ident=Ustring.Object_ )  (* FIXME: check for *the* object name *)
-                then Ast.TypeName nd
-                else Ast.TypeName nd
+                then Ast.TypeName (nd, SOME (nextAstNonce()))
+                else Ast.TypeName (nd, SOME (nextAstNonce()))
 (* Don't convert to Ast.Any so we can distinguish from un-anno'd defs
    for handling compatibility cases, such as writable functions
         Ast.WildcardIdentifier =>
                 Ast.SpecialType Ast.Any
 *)
-      | _ => Ast.TypeName nd
+      | _ => Ast.TypeName (nd, SOME (nextAstNonce()))
 
 and functionSignature (ts) : ((TOKEN * Ast.LOC) list * Ast.FUNC_SIG) =
     let val _ = trace([">> functionSignature with next=",tokenname(hd(ts))])