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

4 years ago
4 years ago
4 years ago
4 years ago
4 years ago
4 years ago
4 years ago
4 years ago
  1. include import "./compile.ml"
  2. module Strings = import "./lib/strings.ml"
  3. open import "prelude.ml"
  4. open import "lua/io.ml"
  5. open import "./lang.ml"
  6. let resolve_addr = function
  7. | Combinator n -> n ^ "_combinator"
  8. | Arg i -> "stack[sp - " ^ show (i + 1) ^ "][3]"
  9. | Local i -> "stack[sp - " ^ show i ^ "]"
  10. | Int i -> show i
  11. let rec gm2lua = function
  12. | Push addr ->
  13. " stack[sp + 1] = " ^ resolve_addr addr ^ "; sp = sp + 1"
  14. | Pop n ->
  15. " sp = sp - " ^ show n
  16. | Update n ->
  17. let it = "stack[sp - " ^ show (n + 1) ^ "]"
  18. " if type(" ^ it ^ ") == 'table' then\n"
  19. ^ " " ^ it ^ "[1] = I; " ^ it ^ "[2] = stack[sp]\n"
  20. ^ " else " ^ it ^ " = stack[sp] end\n"
  21. ^ " sp = sp - 1"
  22. | Mkap ->
  23. " stack[sp - 1] = { A, stack[sp - 1], stack[sp] }; sp = sp - 1"
  24. | Unwind ->
  25. " return unwind(stack, sp)"
  26. | Eval -> " stack[sp] = eval(stack, sp)"
  27. | Add -> " stack[sp - 1] = stack[sp - 1] + stack[sp]; sp = sp - 1"
  28. | Sub -> " stack[sp - 1] = stack[sp - 1] - stack[sp]; sp = sp - 1"
  29. | Div -> " stack[sp - 1] = stack[sp - 1] / stack[sp]; sp = sp - 1"
  30. | Mul -> " stack[sp - 1] = stack[sp - 1] * stack[sp]; sp = sp - 1"
  31. | Alloc lim ->
  32. let rec go acc n =
  33. if n > 0 then
  34. go (acc ^ ";\n stack[sp + " ^ show n ^ "] = {}") (n - 1)
  35. else
  36. acc ^ "; sp = sp + " ^ show lim
  37. go "--" lim
  38. | Slide n ->
  39. " stack[sp - " ^ show n ^ "] = stack[sp]; sp = sp - " ^ show n
  40. | Iszero (yes, no) ->
  41. " if stack[sp] == 0 then\n"
  42. ^ foldl (fun x i -> x ^ " " ^ gm2lua i ^ ";\n") "" yes
  43. ^ " else\n"
  44. ^ foldl (fun x i -> x ^ " " ^ gm2lua i ^ ";\n") "" no
  45. ^ " end"
  46. | Pack (arity, tag) ->
  47. let rec go acc i =
  48. if i > 0 then
  49. go (acc ^ ", stack[sp - " ^ show (i - 1) ^ "]") (i - 1)
  50. else
  51. acc
  52. let values = go "" arity
  53. " stack[sp + 1] = {" ^ show tag ^ values ^ "}; sp = sp + 1"
  54. | Casejump alts ->
  55. let rec go con = function
  56. | [] -> " error('unmatched case')"
  57. | Cons ((arity, code : list _), alts) ->
  58. (* Where is the constructor? stack[sp], then it moves to
  59. * stack[sp - 1]. Generally: stack[sp - i], 0 <= i < arity *)
  60. let rec go_arg i =
  61. if i < arity then
  62. " stack[sp + 1] = stack[sp - " ^ show i ^ "][" ^ show (i + 2) ^ "]; sp = sp + 1;\n"
  63. ^ go_arg (i + 1)
  64. else
  65. foldl (fun x i -> x ^ " " ^ gm2lua i ^ ";\n") "" code
  66. " if stack[sp][1] == " ^ show con ^ " then\n"
  67. ^ go_arg 0
  68. ^ " else"
  69. ^ go (con + 1) alts
  70. ^ " end"
  71. go 0 alts
  72. let compute_local_set xs =
  73. let rec go i (s : S.t string) = function
  74. | Cons (Fd (Fimport {var}), xs) ->
  75. if i >= 100 then
  76. s
  77. else
  78. go (i + 2) (S.insert (var ^ "_wrapper") (S.insert (var ^ "_combinator") s)) xs
  79. | Cons (Sc (name, _), xs) ->
  80. if i >= 100 then
  81. s
  82. else
  83. go (i + 2) (S.insert name (S.insert (name ^ "_combinator") s)) xs
  84. | Nil -> s
  85. go 1 S.empty xs
  86. let sc2lua (name, arity, body) =
  87. let body =
  88. body
  89. |> foldl (fun x s -> x ^ "-- " ^ show s ^ "\n" ^ gm2lua s ^ ";\n") (name ^ " = function(stack, sp)\n")
  90. |> (^ "end")
  91. let dec =
  92. name ^ "_combinator = { F, " ^ name ^ ", " ^ show arity ^ ", " ^ show name ^ " };"
  93. body ^ "\n" ^ dec
  94. let foreign2lua (Fimport { cc, fent = fspec, var, ftype }) =
  95. let (file, fspec) =
  96. match Strings.split_on " " fspec with
  97. | [file, func] -> (Some file, func)
  98. | [func] -> (None, func)
  99. | _ -> error @@ "Foreign spec too big: " ^ fspec
  100. match cc with
  101. | Prim -> error "primitive definitions are in Gmcode"
  102. | Lua ->
  103. let arity = arity ftype
  104. let args = map (fun i -> ("a" ^ show i, i)) [1..arity]
  105. let fcall =
  106. if arity == 0 then
  107. fspec
  108. else
  109. let Cons ((a, _), args) = args
  110. fspec ^ "(" ^ foldl (fun a (i, _) -> a ^ ", " ^ i) a args ^ ")"
  111. let wrapper =
  112. "local function " ^ var ^ "_wrapper(stack, sp)\n"
  113. ^ foldl (fun x (a, i) -> x ^ " local " ^ a ^ " = stack[sp - " ^ show i ^ "][3];\n") "" args
  114. ^ " stack[sp - " ^ show arity ^ "] = " ^ fcall ^ "\n"
  115. ^ " return unwind(stack, sp - " ^ show arity ^ ")\nend"
  116. let dec =
  117. var ^ "_combinator = { F, " ^ var ^ "_wrapper, " ^ show arity ^ ", '" ^ fspec ^ "' };"
  118. let contents =
  119. match file with
  120. | Some path ->
  121. let f = open_for_reading path
  122. let x = read_all f
  123. close_file f
  124. match x with
  125. | Some s -> "--- " ^ path ^ "\n" ^ s ^ "\n"
  126. | None -> ""
  127. | None -> ""
  128. contents ^ wrapper ^ "\n" ^ dec
  129. let codegen = function
  130. | Sc t -> sc2lua t
  131. | Fd i -> foreign2lua i
  132. let preamble =
  133. let f = open_for_reading "preamble.lua"
  134. let x = read_all f
  135. close_file f
  136. match x with
  137. | Some s -> s
  138. | None -> error "no preamble.lua"
  139. let assm_program decs =
  140. match decs with
  141. | [] -> error "empty program"
  142. | _ ->
  143. let Cons (local1, locals) =
  144. compute_local_set decs |> S.members
  145. let local_decs =
  146. foldl (fun x v -> x ^ ", " ^ v) ("local " ^ local1) locals
  147. let body = foldl (fun x s -> x ^ codegen s ^ "\n") "" decs
  148. preamble ^ local_decs ^ "\n" ^ body ^ "unwind({{ A, main_combinator, 123 }}, 1)"