amelia
/
ahc-old


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 private pasted_files : ref (S.t string) = ref S.empty


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

 if path `S.member` !pasted_files then

 ""

 else

 pasted_files := S.insert path !pasted_files

 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({main_combinator}, 1)"