Commits

shawnh  committed c11d0df

Converted the typechecker to thread the type judgements through instead of using a mutable hash table.

  • Participants
  • Parent commits 9155937

Comments (0)

Files changed (2)

File blub_typecheck.ml

       printf "Unsupported sval %a\n%!" pp_sval x;
       typevar ()
 
-let tcheck globals env (e:ast) : (ast * type_) list =
-  let typedict = Hashtbl.create 256 in
+let tmap_union map1 map2 =
+  PMap.foldi PMap.add map1 map2
+;;
 
-  let rec tcheck (r:env) (e:ast) : type_ =
+let tcheck globals env (e:ast) : (ast, type_) PMap.t =
+  let rec tcheck (r:env) (e:ast) : (ast, type_) PMap.t =
     (* printf "tcheck: %a\n%!" pp_ast e; *)
-    let t = match e with
-	A_lit l -> type_of_sval l
+    match e with
+	A_lit l -> PMap.add e (type_of_sval l) PMap.empty
       | A_ref var -> begin
 	  try
 	    let t = instantiate (PMap.find var r) in
-	    printf "instantiating fresh type variables  %a\n%!" pp_type t;
-	    t
+	    PMap.add e t PMap.empty
 	  with Not_found ->
 	    printf "Variable %a not found in environment\n%!" pp_var var;
 	    raise (Tcheck_failed "")
       | A_cnd (e1, e2, e3) ->
 	  let t2 = tcheck r e2 in
 	  let t3 = tcheck r e3 in
-	  unify Bool (tcheck r e1);
-	  unify t2 t3;
-	  t2
+	  let t1 = tcheck r e1 in
+	  let tmap = tmap_union t1 t2 in
+	  let tmap = tmap_union tmap t3 in
+
+	  unify Bool (PMap.find e1 tmap);
+	  unify (PMap.find e2 tmap) (PMap.find e3 tmap);
+	  PMap.add e (PMap.find e2 tmap) tmap
 	    
       | A_abs (params, false, body) ->
 	  let tparams = Array.map (fun _ -> typevar ()) params in
 	  let var_ts = Array.mapi (fun i ts -> (params.(i), ts)) ts in
 	  let env = Array.fold_left (fun env (var, ts) ->
 				       PMap.add var ts env) r var_ts in
-	  Fun (tparams, tcheck env body)
+	  let tmap = tcheck env body in
+	  let function_type = Fun (tparams, PMap.find body tmap) in
+	  PMap.add e function_type tmap
 	    
       | A_app (fn, args) -> begin
-	  let args = Array.map (tcheck r) args in
-	  match (tcheck r fn) with
-	      Fun (tparams, tret) as tfun -> 
+	  let tmap = Array.fold_right 
+	    (fun arg acc -> tmap_union (tcheck r arg) acc)
+	    args PMap.empty
+	  in
+	  let tmap = tmap_union (tcheck r fn) tmap in
+	  let fn_type = PMap.find fn tmap in
+
+	  match fn_type with
+	      Fun (tparams, tret) -> 
 		assert ((Array.length tparams) = (Array.length args));
-		if (Array.length tparams) > 0 then
-		Array.iteri (fun i arg -> unify tparams.(i) arg) args;
-		tret
+		Array.iteri 
+		  (fun i arg -> 
+		     let arg_type = PMap.find arg tmap in
+		     unify tparams.(i) arg_type) 
+		  args;
+		PMap.add e tret tmap
+
 	    | t ->
 		printf "App on unexpected type: %a" pp_type t;
 		raise (Tcheck_failed "")
 	end
 
       | A_seq exprs ->
-	  Array.fold_left (fun _ expr -> tcheck r expr) Bool exprs
-
+	  let tmap = Array.fold_right 
+	    (fun expr tmap ->
+	       tmap_union (tcheck r expr) tmap)
+	    exprs PMap.empty
+	  in
+	  let last_expr = exprs.(Array.length exprs - 1) in
+	  PMap.add e (PMap.find last_expr tmap) tmap
+(*
       | A_let ( [| (var, (A_abs (params, false, body) as t)) |], e2, LT_letrec) ->
 	  let tparams = Array.map (fun _ -> typevar ()) params in
 	  let tret = typevar () in
 	  let tbody = tcheck r'' body in
 	  unify tbody tret;
 
-	  printf "HA HA HA   %a   %!" pp_type tf;
-	  (* NOTE the original does this to the original env r, not r'' *)
 	  let env = PMap.add var (schema tf r) r in
 	  tcheck env e2
+*)
 
       | A_let _ | A_set _ | A_callcc _ ->
 	  printf "sorry, Shawn is lazy and hasn't got this stuff working again yet!!";
 	  tcheck (vardeclcheck var e1 r) e2
 *)
 
-    in
-    Hashtbl.add typedict e t;
-    t
+
   and vardeclcheck var e r =
-    PMap.add var (schema (tcheck r e) r) r
+    let tmap = tcheck r e in
+    let typ = PMap.find e tmap in
+    PMap.add var (schema typ r) r
   in
 
   (* Add the types of everything in the environment *)
     globals env
   in
 
-  let t = tcheck env e in
-  Hashtbl.fold (fun ast type_ acc ->
-		  (ast, type_) :: acc) typedict []
-
-
-
+  tcheck env e 
 	  end
     in
     let () = try
-      let type_assoc = Blub_typecheck.tcheck globals env ast in
-      List.iter (fun (ast, typ) ->
-	 printf "type: %a => %a\n%!" pp_ast ast pp_type typ) 
-	type_assoc;
+      let tmap = Blub_typecheck.tcheck globals env ast in
+      PMap.iter (fun ast typ ->
+		    printf "type: %a => %a (%d unsolved typevars)\n%!" pp_ast ast pp_type typ (Blub_typecheck.TypeVarSet.cardinal (Blub_typecheck.unsolved typ)))
+	tmap;
     with Blub_typecheck.Tcheck_failed _ -> 
       printf "Failed to typecheck\n%!"
     in