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

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)"