From e08eae14db4c0d7351dfee3ce62cf86ec62ee694 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Abigail=20Magalh=C3=A3es?= Date: Tue, 19 May 2020 12:29:55 -0300 Subject: [PATCH] support proper case expressions and constructors --- assemble.ml | 50 +++++++++++++++++-- compile.ml | 135 ++++++++++++++++++++++++++++++++++++++++----------- driver.ml | 16 +++--- lang.ml | 48 ++++-------------- parser.ml | 16 +++++- preamble.lua | 16 ++++-- test.hs | 6 --- 7 files changed, 197 insertions(+), 90 deletions(-) delete mode 100644 test.hs diff --git a/assemble.ml b/assemble.ml index 3214961..6abf7b7 100644 --- a/assemble.ml +++ b/assemble.ml @@ -7,6 +7,7 @@ open import "./lang.ml" let resolve_addr = function | Combinator n -> n ^ "_combinator" | Arg i -> "stack[sp - " ^ show (i + 1) ^ "][3]" + | Local i -> "stack[sp - " ^ show i ^ "]" | Int i -> show i let rec gm2lua = function @@ -15,22 +16,61 @@ let rec gm2lua = function | Pop n -> " sp = sp - " ^ show n | Update n -> - " stack[sp - " ^ show (n + 1) ^ "] = { I, stack[sp] }; sp = sp - 1" + let it = "stack[sp - " ^ show (n + 1) ^ "]" + " if type(" ^ it ^ ") == 'table' then\n" + ^ " " ^ it ^ "[1] = I; " ^ it ^ "[2] = stack[sp]\n" + ^ " else " ^ it ^ " = stack[sp] end\n" + ^ " sp = sp - 1" | Mkap -> " stack[sp - 1] = { A, stack[sp - 1], stack[sp] }; sp = sp - 1" | Unwind -> " return unwind(stack, sp)" - | Eval -> " stack[sp] = eval(stack[sp])" + | Eval -> " stack[sp] = eval(stack, sp)" | Add -> " stack[sp - 1] = stack[sp - 1] + stack[sp]; sp = sp - 1" | Sub -> " stack[sp - 1] = stack[sp - 1] - stack[sp]; sp = sp - 1" | Div -> " stack[sp - 1] = stack[sp - 1] / stack[sp]; sp = sp - 1" | Mul -> " stack[sp - 1] = stack[sp - 1] * stack[sp]; sp = sp - 1" + | Alloc lim -> + let rec go acc n = + if n > 0 then + go (acc ^ ";\n stack[sp + " ^ show n ^ "] = {}") (n - 1) + else + acc ^ "; sp = sp + " ^ show lim + go "--" lim + | Slide n -> + " stack[sp - " ^ show n ^ "] = stack[sp]; sp = sp - " ^ show n | Iszero (yes, no) -> " if stack[sp] == 0 then\n" - ^ foldl (fun x i -> x ^ " " ^ gm2lua i) "" yes ^ "\n" + ^ foldl (fun x i -> x ^ " " ^ gm2lua i ^ ";\n") "" yes ^ " else\n" - ^ foldl (fun x i -> x ^ " " ^ gm2lua i) "" no ^ "\n" + ^ foldl (fun x i -> x ^ " " ^ gm2lua i ^ ";\n") "" no ^ " end" + | Pack (arity, tag) -> + let rec go acc i = + if i > 0 then + go (acc ^ ", stack[sp - " ^ show (i - 1) ^ "]") (i - 1) + else + acc + let values = go "" arity + " stack[sp + 1] = {" ^ show tag ^ values ^ "}; sp = sp + 1" + | Casejump alts -> + let rec go con = function + | [] -> " error('unmatched case')" + | Cons ((arity, code : list _), alts) -> + (* Where is the constructor? stack[sp], then it moves to + * stack[sp - 1]. Generally: stack[sp - i], 0 <= i < arity *) + let rec go_arg i = + if i < arity then + " stack[sp + 1] = stack[sp - " ^ show i ^ "][" ^ show (i + 2) ^ "]; sp = sp + 1;\n" + ^ go_arg (i + 1) + else + foldl (fun x i -> x ^ " " ^ gm2lua i ^ ";\n") "" code + " if stack[sp][1] == " ^ show con ^ " then\n" + ^ go_arg 0 + ^ " else" + ^ go (con + 1) alts + ^ " end" + go 0 alts let compute_local_set xs = let rec go i (s : S.t string) = function @@ -50,7 +90,7 @@ let compute_local_set xs = let sc2lua (name, arity, body) = let body = body - |> foldl (fun x s -> x ^ gm2lua s ^ ";\n") (name ^ " = function(stack, sp)\n") + |> foldl (fun x s -> x ^ "-- " ^ show s ^ "\n" ^ gm2lua s ^ ";\n") (name ^ " = function(stack, sp)\n") |> (^ "end") let dec = name ^ "_combinator = { F, " ^ name ^ ", " ^ show arity ^ ", " ^ show name ^ " };" diff --git a/compile.ml b/compile.ml index 20e4942..259a00f 100644 --- a/compile.ml +++ b/compile.ml @@ -7,6 +7,7 @@ open import "./lib/monads.ml" type addr = | Combinator of string + | Local of int | Arg of int | Int of int @@ -14,32 +15,47 @@ type gm_code = | Push of addr | Update of int | Pop of int + | Slide of int + | Alloc of int | Unwind | Mkap | Add | Sub | Mul | Div | Eval | Iszero of list gm_code * list gm_code + | Pack of int * int + | Casejump of list (int * list gm_code) instance show gm_code begin let show = function | Mkap -> "Mkap" | Unwind -> "Unwind" | Push (Combinator k) -> "Push " ^ k - | Push (Arg i) -> "Arg " ^ show i - | Push (Int i) -> "Int " ^ show i + | Push (Arg i) -> "Pusharg " ^ show i + | Push (Local i) -> "Pushlocal " ^ show i + | Push (Int i) -> "Pushint " ^ show i | Update n -> "Update " ^ show n - | Pop n -> "Pop " ^ show n + | Pop n -> "Pop " ^ show n + | Slide n -> "Slide " ^ show n + | Alloc n -> "Alloc " ^ show n | Add -> "Add" | Mul -> "Mul" | Sub -> "Sub" | Div -> "Div" | Eval -> "Eval" - | Iszero p -> "Iszero " ^ show p + | Pack (arity, tag) -> "Pack{" ^ show arity ^ "," ^ show tag ^ "}" + | Casejump xs -> "Casejump " ^ show xs + | Iszero xs -> "Iszero " ^ show xs end type program_item = | Sc of string * int * list gm_code | Fd of fdecl +instance show program_item begin + let show = function + | Sc p -> show p + | Fd _ -> "" +end + let rec lambda_lift = function | Ref v -> pure (Ref v) | Lit v -> pure (Lit v) @@ -60,10 +76,24 @@ let rec lambda_lift = function put (i + 1, Decl def :: defs, known_sc) |> map (const app) | Case (sc, alts) -> - alts - |> map (fun (_, x) -> x) - |> foldl app sc - |> lambda_lift + let! sc = lambda_lift sc + let! alts = traverse (fun (c, args, e) -> (c,args,) <$> lambda_lift e) alts + let case = Case (sc, alts) + let! (i, defs, known_sc) = get + let vars = + case + |> free_vars + |> flip S.difference known_sc + |> S.members + let def = ("Lam" ^ show i, vars, case) + let app = foldl (fun f -> app f # Ref) (Ref ("Lam" ^ show i)) vars + put (i + 1, Decl def :: defs, known_sc) + |> map (const app) + | Let (vs, e) -> + let! vs = flip traverse vs @@ fun (v, e) -> + (v,) <$> lambda_lift e + let! e = lambda_lift e + pure (Let (vs, e)) let rec eta_contract = function | Decl (n, a, e) as dec -> @@ -87,7 +117,9 @@ let rec lambda_lift_sc = function let! _ = modify (fun (a, b, s) -> (a, b, S.insert n s)) pure (Decl (n, a, e)) | Data c -> Data c |> pure - | Foreign i -> Foreign i |> pure + | Foreign (Fimport { var } as i) -> + let! _ = modify (second (second (S.insert var))) + Foreign i |> pure type dlist 'a <- list 'a -> list 'a @@ -99,42 +131,88 @@ let cg_prim (Fimport { var, fent }) = , Push (Arg 2), Eval (* y, x, arg0, arg1, arg2, arg3 *) , Sub (* y - x, arg0, arg1, arg2, arg3 *) , Iszero ([ Push (Arg 3) ], [ Push (Arg 4) ]) - , Push (Int 0), Mkap, Update 4, Pop 4, Unwind ] + , Update 4, Pop 4, Unwind ] match fent with - | "add" -> Sc (var, 2, prim_math_op Add) - | "sub" -> Sc (var, 2, prim_math_op Sub) - | "mul" -> Sc (var, 2, prim_math_op Mul) - | "div" -> Sc (var, 2, prim_math_op Div) - | "equ" -> Sc (var, 4, prim_equality) + | "add" -> (Sc (var, 2, prim_math_op Add), Add) + | "sub" -> (Sc (var, 2, prim_math_op Sub), Sub) + | "mul" -> (Sc (var, 2, prim_math_op Mul), Mul) + | "div" -> (Sc (var, 2, prim_math_op Div), Div) + | "equ" -> (Sc (var, 4, prim_equality), Unwind) + | "seq" -> (Sc (var, 2, [ Push (Arg 0), Eval, Update 0, Push (Arg 2), Update 2, Pop 2, Unwind]), Eval) | e -> error @@ "No such primitive " ^ e -let rec compile (env : M.t string int) = function +type slot = As of int | Ls of int + +let offs n = function + | As x -> As (x + n) + | Ls x -> Ls (x + n) +let incr = offs 1 + +let rec compile (env : M.t string slot) = function | Ref v -> match M.lookup v env with - | Some i -> (Push (Arg i) ::) + | Some (As i) -> (Push (Arg i) ::) + | Some (Ls i) -> (Push (Local i) ::) | None -> (Push (Combinator v) ::) | App (f, x) -> let f = compile env f - let x = compile (map (1 +) env) x + let x = compile (map incr env) x f # x # (Mkap ::) | Lam _ -> error "Can not compile lambda expression, did you forget to lift?" - | Case _ -> - error "Can not compile case expression, did you forget to lift?" + | Case (sc, alts) -> + let rec go_alts = function + | [] -> [] + | Cons ((_, args, exp), rest) -> + let c_arity = length args + let env = + args + |> flip zip [Ls k | with k <- [c_arity - 1, c_arity - 2 .. 0]] + |> M.from_list + |> M.union (offs (c_arity + 1) <$> env) + (c_arity, compile env exp [Slide c_arity]) :: go_alts rest + compile env sc # (Eval ::) # (Casejump (go_alts alts) ::) | Lit i -> (Push (Int i) ::) + | Let (vs, e) -> + let n = length vs + let env = + vs + |> map (fun (x, _) -> x) + |> flip zip [Ls x | with x <- [n - 1, n - 2 .. 0]] + |> M.from_list + |> M.union (offs n <$> env) + let defs = zip [1..n] vs + let rec go : list (int * string * expr) -> dlist gm_code = function + | [] -> id + | Cons ((k, (_, exp)), rest) -> + compile env exp # (Update (n - k) ::) # go rest + (Alloc n ::) # go defs # compile env e # (Slide n ::) let supercomb (_, args, exp) = let env = M.from_list (zip args [0..length args]) - let k = compile (M.from_list (zip args [0..length args])) exp + let k = compile (M.from_list (zip args (As <$> [0..length args]))) exp k [Update (length env), Pop (length env), Unwind] -let known_scs = S.from_list [ "getchar", "putchar" ] +let compile_cons = + let rec go i = function + | [] -> [] + | Cons (Constr (n, args), rest) -> + let arity = length args + let rec pushargs i = + if i < arity then + Push (Arg (2 * i)) :: pushargs (i + 1) + else + [] + Sc (n, arity, pushargs 0 ++ [ Pack (arity, i), Update (2 * arity), Pop (2 * arity), Unwind ]) + :: go (i + 1) rest + go 0 let program decs = let (decs, (_, lams, _)) = - run_state (traverse (lambda_lift_sc # eta_contract) decs) (0, [], known_scs) + run_state (traverse (lambda_lift_sc # eta_contract) decs) + (0, [], S.empty) let define nm = let! x = get if nm `S.member` x then @@ -147,11 +225,12 @@ let program decs = | Decl ((nm, args, _) as sc) -> let! _ = define nm let code = supercomb sc - Sc (nm, length args, code) |> pure - | Data _ -> error "data declaration in compiler" + [Sc (nm, length args, code)] |> pure + | Data (_, _, cs) -> pure (compile_cons cs) | Foreign (Fimport { cc = Prim, var } as fi) -> let! _ = define var - pure (cg_prim fi) - | Foreign f -> pure (Fd f) + let (code, _) = cg_prim fi + pure [code] + | Foreign f -> pure [Fd f] let (out, _) = run_state go S.empty - out + join out diff --git a/driver.ml b/driver.ml index 86207bc..dee5b8e 100644 --- a/driver.ml +++ b/driver.ml @@ -4,6 +4,8 @@ open import "./parser.ml" open import "prelude.ml" open import "lua/io.ml" +external val dofile : string -> () = "dofile" + let printerror (e, { line, col }) = put_line @@ "line " ^ show line ^ ", col " ^ show col ^ ":" print e @@ -16,7 +18,6 @@ let go infile outfile = match lex prog str with | Right (ds, _) -> ds - |> ds_prog |> C.program |> A.assm_program |> write_bytes outfile @@ -25,14 +26,17 @@ let go infile outfile = close_file infile close_file outfile +let go' infile outfile = + go infile outfile + dofile outfile + let test str = match lex prog str with | Right (ds, _) -> - ds - |> ds_prog - |> C.program - |> A.assm_program - |> put_line + let code = ds |> C.program + let lua = code |> A.assm_program + print code + put_line lua | Left e -> printerror e let test_file infile = diff --git a/lang.ml b/lang.ml index de1f5c6..0d7ad15 100644 --- a/lang.ml +++ b/lang.ml @@ -6,8 +6,9 @@ type expr = | Ref of string | App of expr * expr | Lam of string * expr - | Case of expr * list (string * expr) + | Case of expr * list (string * list string * expr) | Lit of int + | Let of list (string * expr) * expr let app = curry App let lam = curry Lam @@ -18,21 +19,18 @@ let rec free_vars = function | Lam (v, x) -> v `S.delete` free_vars x | Case (e, bs) -> bs - |> map (fun (_, e) -> free_vars e) + |> map (fun (_, a, e) -> free_vars e `S.difference` S.from_list a) |> foldl S.union S.empty |> S.union (free_vars e) + | Let (vs, b) -> + let bound = S.from_list (map (fun (x, _) -> x) vs) + vs + |> map (fun (_, e) -> free_vars e) + |> foldl S.union S.empty + |> S.union (free_vars b) + |> flip S.difference bound | Lit _ -> S.empty -let rec subst m = function - | Ref v -> - match M.lookup v m with - | Some s -> s - | None -> Ref v - | App (f, x) -> App (subst m f, subst m x) - | Lam (v, x) -> Lam (v, subst (M.delete v m) x) - | Case (e, xs) -> Case (subst m e, map (second (subst m)) xs) - | Lit x -> Lit x - type hstype = | Tycon of string | Tyvar of string @@ -62,29 +60,3 @@ type decl = | Foreign of fdecl type prog <- list decl - -let rec xs !! i = - match xs, i with - | Cons (x, _), 0 -> x - | Cons (_, xs), i when i > 0 -> xs !! (i - 1) - | _, _ -> error "empty list and/or negative index" - -let ds_data (_, _, cs) = - let ncons = length cs - let alts = map (("c" ^) # show) [1..ncons] - let ds_con i (Constr (n, args)) = - let arity = length args - let alt = alts !! i - let args = map (("x" ^) # show) [1..arity] - Decl (n, args, foldr lam (foldl app (Ref alt) (map Ref args)) alts) - let rec go i = function - | [] -> [] - | Cons (x, xs) -> ds_con i x :: go (i + 1) xs - go 0 cs - -let ds_prog prog = - let! c = prog - match c with - | Data c -> ds_data c - | Decl (n, args, e) -> [Decl (n, args, e)] - | Foreign d -> [Foreign d] diff --git a/parser.ml b/parser.ml index 0c7b40d..bd1e3fa 100644 --- a/parser.ml +++ b/parser.ml @@ -32,10 +32,22 @@ and expr : forall 'm. monad 'm => parser_t 'm expr = let! vs = many (try varid) let! _ = arrow let! e = expr - pure (c, foldr ((Lam #) # curry id) e vs) + pure (c, vs, e) ) pure (Case (e, arms)) - try lam <|> try case <+> fexp + let hslet = + let binding = + let! c = varid + let! vs = many (try varid) + let! _ = equals + let! e = expr + pure (c, foldr ((Lam #) # curry id) e vs) + let! _ = keyword "let" + let! bs = laid_out_block binding + let! _ = keyword "in" + let! b = expr + pure (Let (bs, b)) + try lam <|> try case <|> try hslet <+> fexp let rec ty_atom : forall 'm. monad 'm => parser_t 'm hstype = map Tyvar (try varid) diff --git a/preamble.lua b/preamble.lua index 3b3ab11..207a74f 100644 --- a/preamble.lua +++ b/preamble.lua @@ -16,6 +16,7 @@ local function unwind(stack, sp) error("insufficient arguments for supercombinator " .. x[4]) end end + return x else return x, stack, sp end @@ -24,21 +25,26 @@ end local function repr(x) if type(x) == 'table' then if x[1] == A then - return repr(x[2]) .. '(' .. repr(x[3]) + return repr(x[2]) .. '(' .. repr(x[3]) .. ')' elseif x[1] == F then return x[4] elseif x[1] == I then return '&' .. repr(x[2]) end - return '' + local r = {} + for k, v in pairs(x) do + r[k] = repr(v) + end + return '{' .. table.concat(r, ', ') .. '}' else return tostring(x) end end -local function eval(node) - local stack, sp = { node }, 1 - return (unwind(stack, sp)) +local function eval(stack, sp) + local nf = (unwind({ stack[sp] }, 1)) + stack[sp] = { I, nf } + return nf end local function getchar(stack, sp) diff --git a/test.hs b/test.hs deleted file mode 100644 index 772a3b3..0000000 --- a/test.hs +++ /dev/null @@ -1,6 +0,0 @@ -data List a = Nil | Cons a (List a); -map f xs = case xs of { Nil -> Nil; Cons x xs -> Cons (f x) (map f xs) }; -readall k = getchar (\ch -> readall (\xs -> k (Cons ch xs))) (\ch -> k Nil); -putall x xs = case xs of { Nil -> x; Cons x xs -> putchar x (\ch -> putall x xs) }; -id x = x; -main x = readall (putall x);