You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
156 lines
5.2 KiB
156 lines
5.2 KiB
include import "./compile.ml"
|
|
module Strings = import "./lib/strings.ml"
|
|
open import "prelude.ml"
|
|
open import "lua/io.ml"
|
|
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
|
|
| Push addr ->
|
|
" stack[sp + 1] = " ^ resolve_addr addr ^ "; sp = sp + 1"
|
|
| Pop n ->
|
|
" sp = sp - " ^ show n
|
|
| Update n ->
|
|
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)"
|
|
| 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 ^ ";\n") "" yes
|
|
^ " else\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
|
|
| Cons (Fd (Fimport {var}), xs) ->
|
|
if i >= 100 then
|
|
s
|
|
else
|
|
go (i + 2) (S.insert (var ^ "_wrapper") (S.insert (var ^ "_combinator") s)) xs
|
|
| Cons (Sc (name, _), xs) ->
|
|
if i >= 100 then
|
|
s
|
|
else
|
|
go (i + 2) (S.insert name (S.insert (name ^ "_combinator") s)) xs
|
|
| Nil -> s
|
|
go 1 S.empty xs
|
|
|
|
let sc2lua (name, arity, body) =
|
|
let body =
|
|
body
|
|
|> 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 ^ " };"
|
|
body ^ "\n" ^ dec
|
|
|
|
let foreign2lua (Fimport { cc, fent = fspec, var, ftype }) =
|
|
let (file, fspec) =
|
|
match Strings.split_on " " fspec with
|
|
| [file, func] -> (Some file, func)
|
|
| [func] -> (None, func)
|
|
| _ -> error @@ "Foreign spec too big: " ^ fspec
|
|
match cc with
|
|
| Prim -> error "primitive definitions are in Gmcode"
|
|
| Lua ->
|
|
let arity = arity ftype
|
|
let args = map (fun i -> ("a" ^ show i, i)) [1..arity]
|
|
let fcall =
|
|
if arity == 0 then
|
|
fspec
|
|
else
|
|
let Cons ((a, _), args) = args
|
|
fspec ^ "(" ^ foldl (fun a (i, _) -> a ^ ", " ^ i) a args ^ ")"
|
|
let wrapper =
|
|
"local function " ^ var ^ "_wrapper(stack, sp)\n"
|
|
^ foldl (fun x (a, i) -> x ^ " local " ^ a ^ " = stack[sp - " ^ show i ^ "][3];\n") "" args
|
|
^ " stack[sp - " ^ show arity ^ "] = " ^ fcall ^ "\n"
|
|
^ " return unwind(stack, sp - " ^ show arity ^ ")\nend"
|
|
let dec =
|
|
var ^ "_combinator = { F, " ^ var ^ "_wrapper, " ^ show arity ^ ", '" ^ fspec ^ "' };"
|
|
let contents =
|
|
match file with
|
|
| Some path ->
|
|
let f = open_for_reading path
|
|
let x = read_all f
|
|
close_file f
|
|
match x with
|
|
| Some s -> "--- " ^ path ^ "\n" ^ s ^ "\n"
|
|
| None -> ""
|
|
| None -> ""
|
|
contents ^ wrapper ^ "\n" ^ dec
|
|
|
|
let codegen = function
|
|
| Sc t -> sc2lua t
|
|
| Fd i -> foreign2lua i
|
|
|
|
let preamble =
|
|
let f = open_for_reading "preamble.lua"
|
|
let x = read_all f
|
|
close_file f
|
|
match x with
|
|
| Some s -> s
|
|
| None -> error "no preamble.lua"
|
|
|
|
let assm_program decs =
|
|
match decs with
|
|
| [] -> error "empty program"
|
|
| _ ->
|
|
let Cons (local1, locals) =
|
|
compute_local_set decs |> S.members
|
|
let local_decs =
|
|
foldl (fun x v -> x ^ ", " ^ v) ("local " ^ local1) locals
|
|
let body = foldl (fun x s -> x ^ codegen s ^ "\n") "" decs
|
|
preamble ^ local_decs ^ "\n" ^ body ^ "unwind({{ A, main_combinator, 123 }}, 1)"
|