From da0d498419324586dd8fd0964315214f824ee409 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Abigail=20Magalh=C3=A3es?= Date: Wed, 20 May 2020 13:25:53 -0300 Subject: [PATCH] small improvements to compilation * don't eval the root of the updated graph when building a supercombinator * fix type-checking order resolution --- compile.ml | 16 +++++++++++++--- driver.ml | 9 +++++++-- lang.ml | 3 +++ lib/graph.ml | 11 ++++++++++- tc.ml | 16 +++++++++------- 5 files changed, 42 insertions(+), 13 deletions(-) diff --git a/compile.ml b/compile.ml index 5c534dc..e99c3fc 100644 --- a/compile.ml +++ b/compile.ml @@ -194,13 +194,24 @@ and compile_strict (env : M.t string slot) = function | App (App (Ref f, x), y) as e -> match M.lookup f !prim_scs with | Some op when is_arith_op op -> - print ("compiling", f, "specially") compile_strict env x # compile_strict (incr <$> env) y # (op ::) | _ -> compile_lazy env e # (Eval ::) | e -> compile_lazy env e # (Eval ::) +and compile_tail (env : M.t string slot) = function + | Ref v -> + match M.lookup v env with + | Some (As i) -> (Push (Arg i) ::) + | Some (Ls i) -> (Push (Local i) ::) + | None -> (Push (Combinator v) ::) + | App (f, x) -> + let f = compile_tail env f + let x = compile_lazy (map incr env) x + f # x # (Mkap ::) + | e -> compile_strict env e + and compile_let cont env vs e = let n = length vs let env = @@ -218,7 +229,7 @@ and compile_let cont env vs e = let supercomb (_, args, exp) = let env = M.from_list (zip args [0..length args]) - let k = compile_strict (M.from_list (zip args (As <$> [0..length args]))) exp + let k = compile_tail (M.from_list (zip args (As <$> [0..length args]))) exp k [Update (length env), Pop (length env), Unwind] let compile_cons = @@ -267,7 +278,6 @@ let program decs = | Foreign (Fimport { cc = Prim, var } as fi) -> define var ( let (code, h) = cg_prim fi - print h prim_scs := M.insert var h !prim_scs pure [code] ) diff --git a/driver.ml b/driver.ml index 847101a..3adbc06 100644 --- a/driver.ml +++ b/driver.ml @@ -19,7 +19,8 @@ let go infile outfile = match lex prog str with | Right (ds, _) -> ds - |> T.tc_program + |> T.tc_program [] [] + |> fun (_, _, z) -> z |> C.program |> A.assm_program |> write_bytes outfile @@ -35,7 +36,11 @@ let go' infile outfile = let test str = match lex prog str with | Right (ds, _) -> - let code = ds |> T.tc_program |> C.program + let code = + ds + |> T.tc_program [] [] + |> fun (_, _, z) -> z + |> C.program let lua = code |> A.assm_program print code put_line lua diff --git a/lang.ml b/lang.ml index aeabba8..ecfbbc2 100644 --- a/lang.ml +++ b/lang.ml @@ -7,6 +7,7 @@ type expr = | App of expr * expr | Lam of string * expr | Case of expr * list (string * list string * expr) + | If of expr * expr * expr | Lit of int | Let of list (string * expr) * expr @@ -29,6 +30,8 @@ let rec free_vars = function |> foldl S.union S.empty |> S.union (free_vars b) |> flip S.difference bound + | If (f, x, y) -> + S.union (free_vars f) (S.union (free_vars x) (free_vars y)) | Lit _ -> S.empty type hstype = diff --git a/lib/graph.ml b/lib/graph.ml index c14fd53..063bc3d 100644 --- a/lib/graph.ml +++ b/lib/graph.ml @@ -61,6 +61,13 @@ let toposort (graph : t 'a) : list 'a = iter visit nodes reverse !l +let dot_of_graph (graph : t 'a) = + let mk node = + S.foldr (fun edge r -> show node ^ " -> " ^ show edge ^ "\n" ^ r) "\n" + "strict digraph {" + ^ M.foldr_with_key (fun node edges r -> mk node edges ^ r) "" graph + ^ "}" + let groups_of_sccs (graph : t 'a) = let sccs = sccs graph let edges_of n = @@ -72,10 +79,12 @@ let groups_of_sccs (graph : t 'a) = |> M.assocs |> map (fun (k, s) -> M.singleton s (S.singleton k)) |> foldl (M.union_by (fun _ -> S.union)) M.empty + let atd nodes = + S.foldr (fun n -> S.union (edges_of n)) S.empty nodes `S.difference` nodes let comp_deps = components |> M.assocs - |> map (fun (node, edges) -> (node, edges_of node `S.difference` edges)) + |> map (fun (node, edges) -> (node, atd edges)) |> M.from_list let ordering = toposort comp_deps [ x | with k <- ordering, with Some x <- [M.lookup k components] ] diff --git a/tc.ml b/tc.ml index 5dbb3fa..d06fef6 100644 --- a/tc.ml +++ b/tc.ml @@ -383,6 +383,7 @@ let dependency_graph defs = |> M.insert name S.empty |> (, define name x defs) let (graph, defs) = foldl go (M.empty, M.empty) defs + G.dot_of_graph graph |> put_line (G.groups_of_sccs graph, defs) let mk_lam args body = foldr (curry Lam) body args @@ -410,17 +411,16 @@ let rec add_missing_vars scope = function | Tyarr (a, b) -> add_missing_vars (add_missing_vars scope b) a | Tytup xs -> foldl add_missing_vars scope xs -let tc_program (prog : list decl) = +let tc_program value_exports type_exports (prog : list decl) = let (plan, defs) = dependency_graph prog + let tc_one (dt_info, val_scope, ty_scope, out) group = - print (length out, length (S.members group)) let defs = [ x | with name <- S.members group, with Some x <- [M.lookup name defs] ] match defs with | [] -> (dt_info, val_scope, ty_scope, out) | [Foreign (Fimport {var, ftype}) as def] -> let ty_scope' = add_missing_vars M.empty ftype let t = check_is_type (M.union ty_scope' ty_scope) ftype - print var (dt_info, M.insert var (Forall { vars = M.keys ty_scope', body = t } |> Poly) val_scope, ty_scope, def :: out) | Cons (Foreign (Fimport {var}), _) -> error @@ "Foreign definition " ^ var ^ " is part of a group. How?" @@ -431,13 +431,11 @@ let tc_program (prog : list decl) = let (bindings, scope') = infer_binding_group dt_info -1 val_scope bindings let decs = [ Decl (name, unlambda expr) | with (name, expr) <- bindings ] - print name (dt_info, M.union (map force scope') val_scope, ty_scope, foldr (::) decs out) | Cons (Data d, ds) -> let datas = d :: [ d | with Data d <- ds ] let r = infer_data_group_kind ty_scope datas let fix_constr (name, rhos : list tc_rho) = - print name Constr (name, replicate (length rhos) (Tycon "#")) let rec go dt ty (vl : M.t string (scheme tc_rho)) ds = function | [] -> (dt, vl, ty, ds) @@ -452,5 +450,9 @@ let tc_program (prog : list decl) = (Data (name, [], fix_constr <$> constrs) :: ds) rest go dt_info ty_scope val_scope out r - let (_, _, _, p) = foldl tc_one (M.empty, M.empty, M.empty, []) plan - p + let (_, vals, types, p) = foldl tc_one (M.empty, M.empty, M.empty, []) plan + ( + [x | with k <- value_exports, with Some x <- [M.lookup k vals]], + [x | with k <- type_exports, with Some x <- [M.lookup k types]], + p + )