Fix more bugs with closure conversion. It now appears to work for all

of our standard web examples.

closures.ml

@@ -60,7 +60,10 @@ struct
           else
             o
         else
-          {< free_vars = IntSet.add x free_vars >}
+          begin
+            (* Debug.print ("free var: "^string_of_int x); *)
+            {< free_vars = IntSet.add x free_vars >}
+          end
 
       method private reset =
         {< bound_vars = IntSet.empty; free_vars = IntSet.empty >}
@@ -80,15 +83,23 @@ struct
       method binder ((_, (_, _, scope)) as b) =
         let b, o = super#binder b in
         if toplevel = true then
-          b, o#global (Var.var_of_binder b)
+          begin
+            (* Debug.print("global binder: " ^ string_of_int (Var.var_of_binder b)); *)
+            b, o#global (Var.var_of_binder b)
+          end
         else
-          b, o#bound (Var.var_of_binder b)
+          begin
+            (* Debug.print("local binder: " ^ string_of_int (Var.var_of_binder b)); *)
+            b, o#bound (Var.var_of_binder b)
+          end
         (* match scope with *)
         (* | `Global -> b, o#global (Var.var_of_binder b) *)
         (* | `Local  -> b, o#bound (Var.var_of_binder b) *)
 
       method private super_binding = super#binding
 
+      method private super_binder = super#binder
+
       method binding =
         function
         | `Fun (f, (tyvars, xs, body), None, location) when toplevel = false ->
@@ -101,7 +112,10 @@ struct
                  (x::xs, o))
               xs
               ([], o) in
+          (* Debug.print("Descending into: " ^ string_of_int (Var.var_of_binder f)); *)
           let body, o = o#descend (fun o -> let body, _, o = o#computation body in body, o) in
+          (* Debug.print("Ascended from: " ^ string_of_int (Var.var_of_binder f)); *)
+
           let zs =
             List.rev
               (IntSet.fold
@@ -174,8 +188,67 @@ struct
                  o#register_fun (Var.var_of_binder f) zs) o defs in
           let defs = List.rev defs in
           `Rec defs, o
-        | b ->
-          o#descend (fun o -> o#super_binding b)
+        | `Fun (f, (tyvars, xs, body), None, location) ->
+          let (xs, body), o =
+            o#descend (fun o ->
+                let (xs, o) =
+                  List.fold_right
+                    (fun x (xs, o) ->
+                       let x, o = o#binder x in
+                       (x::xs, o))
+                    xs
+                    ([], o) in
+                let body, _, o = o#computation body in
+                (xs, body), o) in
+            let f, o = o#binder f in
+              (* TODO: check that xs and body match up with f *)
+          `Fun (f, (tyvars, xs, body), None, location), o
+        | `Rec defs ->
+          (* it's important to traverse the function binders first in
+             order to make sure they're in scope for all of the
+             function bodies *)
+          let _, o =
+            List.fold_right
+              (fun (f, _, _, _) (fs, o) ->
+                 let f, o = o#super_binder f in
+                 (f::fs, o))
+              defs
+              ([], o) in
+
+          let defs, o =
+              o#descend (fun o ->
+                  List.fold_left
+                    (fun (defs, (o : 'self_type)) (f, (tyvars, xs, body), None, location) ->
+                       let xs, o =
+                         List.fold_right
+                           (fun x (xs, o) ->
+                              let (x, o) = o#binder x in
+                              (x::xs, o))
+                           xs
+                           ([], o) in
+                       let body, _, o = o#computation body in
+                       (f, (tyvars, xs, body), None, location)::defs, o)
+                    ([], o)
+                    defs) in
+
+            (* we traverse the function binders again in order to
+               treat them as globals *)
+            let _, o =
+              List.fold_right
+                (fun (f, _, _, _) (fs, o) ->
+                   let f, o = o#binder f in
+                   (f::fs, o))
+                defs
+                ([], o) in
+
+            let defs = List.rev defs in
+            `Rec defs, o
+        | `Let (x, (tyvars, tc)) ->
+          let x, o = o#binder x in
+          let (tc, t), o = o#descend (fun o -> let tc, t, o = o#tail_computation tc in (tc, t), o) in
+          `Let (x, (tyvars, tc)), o
+        | `Alien _ as b -> super#binding b
+        | b -> assert false
     end
 
   let bindings tyenv globals e =
@@ -226,7 +299,8 @@ struct
         function
         | `Variable x ->
           let x, t, o = o#var x in
-          let v =
+
+          let rec var_val x =
             if IntSet.mem x cvars then
               `Project (string_of_int x, `Variable parent_env)
             else if IntMap.mem x fenv then
@@ -238,19 +312,17 @@ struct
                   `Closure (x, `Variable parent_env)
                 else
                   let zs =
-                    List.map (fun (z, _) ->
-                        let zname = string_of_int z in
-                        if IntSet.mem z cvars then
-                          (zname, `Project (zname,  `Variable parent_env))
-                        else
-                          (zname, `Variable z))
+                    List.map
+                      (fun (z, _) ->
+                         let v = var_val z in
+                         (string_of_int z, v))
                       zs
                   in
                   close x zs
             else
               `Variable x
           in
-          v, t, o
+          var_val x, t, o
         | v -> super#value v
 
       method private set_context parents parent_env cvars =

links.ml

@@ -343,7 +343,7 @@ let load_prelude () =
 
   let fenv = Closures.ClosureVars.bindings tenv Lib.primitive_vars globals in
   let globals = Closures.ClosureConvert.bindings tenv Lib.primitive_vars fenv globals in
-
+  (* Debug.print ("Prelude after closure conversion: " ^ Ir.Show_program.show (globals, `Return (`Extend (StringMap.empty, None)))); *)
   let closures = Ir.ClosureTable.bindings tenv (Lib.primitive_vars) globals in
 
   let valenv = Evalir.run_defs (Value.empty_env closures) globals in

value.ml

@@ -768,8 +768,8 @@ let marshal_value : t -> string =
       base64encode (save (compress_t v))
 
 let unmarshal_continuation (envs : unmarshal_envs) : string -> continuation =
-    let { load = load } = continuation_serialiser () in assert false
-    (* base64decode ->- load ->- uncompress_continuation envs *)
+    let { load = load } = continuation_serialiser () in
+    base64decode ->- load ->- uncompress_continuation envs
 
 let unmarshal_value envs : string -> t =
   fun s ->

webif.ml

@@ -200,9 +200,12 @@ let parse_expr_eval (valenv, nenv, tyenv) program params =
       | _ -> assert false
 
 let parse_client_return envs program cgi_args =
+  (* Debug.print("parsing client return"); *)
   let continuation =
     decode_continuation envs program (assoc "__continuation" cgi_args) in
+  (* Debug.print("continuation: " ^ Value.Show_continuation.show continuation); *)
   let arg = Json.parse_json_b64 (assoc "__result" cgi_args) in
+  (* Debug.print ("arg: "^Value.Show_t.show arg); *)
     (* FIXME: refactor *)
   let funcmap = Ir.funcmap program in (* FIXME: Quite slow... *)
   let (valenv, _, _) = envs in
@@ -349,21 +352,28 @@ let make_program (_,nenv,tyenv) prelude filename =
                    ^ Types.string_of_datatype t)
   end;
 
-  (* Debug.print ("unclosure-converted IR: " ^ Ir.Show_program.show (prelude@globals@locals, main)); *)
+  Debug.print ("un-closure-converted IR: " ^ Ir.Show_program.show (prelude@globals@locals, main));
 
   let nenv'' = Env.String.extend nenv nenv' in
   let tyenv'' = Types.extend_typing_environment tyenv tyenv' in
 
+  let module Show_IntEnv = Env.Int.Show_t(Deriving_Show.Show_int) in
+
   let tenv0 = Var.varify_env (nenv, tyenv.Types.var_env) in
   let gs0 = Env.String.fold (fun _name var vars -> IntSet.add var vars) nenv IntSet.empty in
+  (* Debug.print("gs0: "^Show_intset.show gs0); *)
   let fenv0 = Closures.ClosureVars.bindings tenv0 gs0 globals in
+  (* Debug.print ("fenv0: " ^ Closures.Show_fenv.show fenv0); *)
   let globals = Closures.ClosureConvert.bindings tenv0 gs0 fenv0 globals in
 
+
   let tenv1 = Var.varify_env (nenv'', tyenv''.Types.var_env) in
   let gs1 = Env.String.fold (fun _name var vars -> IntSet.add var vars) nenv'' IntSet.empty in
   let fenv1 = Closures.ClosureVars.program tenv1 gs1 (locals, main) in
   let (locals, main) = Closures.ClosureConvert.program tenv1 gs1 fenv1 (locals, main) in
 
+  (* Debug.print ("closure-converted locals: " ^ Ir.Show_program.show (locals, main)); *)
+
   let (locals,main), render_cont =
     wrap_with_render_page (nenv, tyenv) (locals,main) in
 
@@ -384,6 +394,7 @@ let make_program (_,nenv,tyenv) prelude filename =
 let serve_request ((valenv,nenv,tyenv) as envs) prelude filename =
 
   let cgi_args = get_cgi_args() in
+  Debug.print ("cgi_args: " ^ mapstrcat "," (fun (k, v) -> k ^ "="  ^ v) cgi_args);
   Lib.cgi_parameters := cgi_args;