Oops, something went wrong.
| @@ -0,0 +1,167 @@ | ||
| open Grain | ||
| open Compile | ||
| open Printf | ||
| open Lexing | ||
| open Filename | ||
| open Cmdliner | ||
| let () = | ||
| Printexc.register_printer (fun exc -> | ||
| match Grain_parsing.Location.error_of_exn exc with | ||
| | None -> None | ||
| | Some `Already_displayed -> None | ||
| | Some (`Ok err) -> | ||
| let buf = Buffer.create 512 in | ||
| let formatter = Format.formatter_of_buffer buf in | ||
| Format.fprintf formatter "@[%a@]@." Grain_parsing.Location.report_error err; | ||
| Format.pp_flush_formatter formatter; | ||
| let s = Buffer.contents buf in | ||
| Buffer.reset buf; | ||
| Some (s)) | ||
| open BatPathGen.OfString | ||
| let make_absolute d = | ||
| if is_absolute d then | ||
| d | ||
| else | ||
| normalize @@ concat (of_string (Unix.getcwd())) d | ||
| let could_be_grain_root d = | ||
| let open Infix in | ||
| List.for_all (fun x -> Sys.file_exists (to_string @@ (of_string d) /: x)) | ||
| ["bin"; "lib"] | ||
| let try_infer_grain_root grainc_path = | ||
| if Sys.file_exists grainc_path then begin | ||
| try | ||
| let grainc_dir = parent @@ of_string grainc_path in | ||
| let as_abs = make_absolute grainc_dir in | ||
| let parent = to_string @@ parent as_abs in | ||
| let could_be = could_be_grain_root parent in | ||
| if could_be then | ||
| Grain_utils.Config.grain_root := Some(parent); | ||
| could_be | ||
| with _ -> false | ||
| end | ||
| else | ||
| false | ||
| let path_var_sep = if Sys.os_type = "Win32" then ';' else ':' | ||
| let infer_root_from_argv() = | ||
| match Sys.argv.(0) with | ||
| | x when not(BatString.ends_with x "grainc") -> false | ||
| | exec_path when exec_path <> "grainc" -> | ||
| (* Ends with 'grainc' and isn't 'grainc'. Likely an absolute or relative path *) | ||
| try_infer_grain_root exec_path | ||
| | _ -> (* argv[0] is exactly 'grainc'. Look for it on $PATH *) | ||
| let path_var = Sys.getenv_opt "PATH" in | ||
| match path_var with | ||
| | None -> | ||
| prerr_string "WARNING: When locating grain root, we found that there \ | ||
| is no PATH environment variable. This seems strange!\n"; | ||
| false | ||
| | Some(path) -> | ||
| (* Got the PATH variable. Check all directories *) | ||
| let grainc_path dir = | ||
| let open Infix in | ||
| to_string @@ (of_string dir) /: "grainc" in | ||
| let path_dirs = String.split_on_char path_var_sep path in | ||
| (List.exists try_infer_grain_root (List.map grainc_path path_dirs)) || begin | ||
| (* Last resort. Check if 'grainc' is in the cwd. *) | ||
| let open Infix in | ||
| let cwd = Sys.getcwd() in | ||
| let grainc_path = to_string @@ (of_string cwd) /: "grainc" in | ||
| try_infer_grain_root grainc_path | ||
| end | ||
| let infer_root_from_running_grainc() = | ||
| try | ||
| let pid = Unix.getpid() in | ||
| let grainc_path = Unix.readlink (sprintf "/proc/%d/exe" pid) in | ||
| try_infer_grain_root grainc_path | ||
| with _ -> | ||
| false | ||
| let infer_root() = | ||
| let found = infer_root_from_argv() || infer_root_from_running_grainc() in | ||
| if not found then | ||
| prerr_string "Failed to find Grain installation root. \ | ||
| Please set the GRAIN_ROOT environment variable \ | ||
| in order to use the standard library.\n" | ||
| let infer_root_if_needed() = | ||
| match !Grain_utils.Config.grain_root with | ||
| (* Prefer environment variable over inferred path *) | ||
| | Some(_) -> () | ||
| | None -> | ||
| infer_root() | ||
| (** `remove_extension` new enough that we should just use this *) | ||
| let safe_remove_extension name = | ||
| try | ||
| Filename.chop_extension name | ||
| with | ||
| | Invalid_argument _ -> name | ||
| let default_output_filename name = safe_remove_extension name ^ ".wasm" | ||
| let default_assembly_filename name = safe_remove_extension name ^ ".wast" | ||
| let compile_file name outfile_arg = | ||
| if not (Printexc.backtrace_status()) && !Grain_utils.Config.verbose then | ||
| Printexc.record_backtrace true; | ||
| infer_root_if_needed(); | ||
| begin | ||
| try | ||
| let outfile = Option.default (default_output_filename name) outfile_arg in | ||
| ignore (Compile.compile_file ~outfile name) | ||
| with exn -> | ||
| let bt = if Printexc.backtrace_status() then Some(Printexc.get_backtrace()) else None in | ||
| Grain_parsing.Location.report_exception Format.err_formatter exn; | ||
| Option.may (fun s -> prerr_string "Backtrace:\n"; prerr_string s; prerr_string "\n") bt; | ||
| exit 2 | ||
| end; | ||
| `Ok () | ||
| ;; | ||
| (** Converter which checks that the given output filename is valid *) | ||
| let output_file_conv = | ||
| let parse s = | ||
| let s_dir = dirname s in | ||
| match Sys.file_exists s_dir with | ||
| | true -> if Sys.is_directory s_dir then `Ok s else `Error (sprintf "`%s' is not a directory" s_dir) | ||
| | false -> `Error (sprintf "no `%s' directory" s_dir) in | ||
| parse, Format.pp_print_string | ||
| let input_filename = | ||
| let doc = sprintf "Grain source file to compile" in | ||
| let docv = "FILE" in | ||
| Arg.(required & pos ~rev:true 0 (some non_dir_file) None & info [] ~docv ~doc) | ||
| ;; | ||
| let output_filename = | ||
| let doc = sprintf "Output filename" in | ||
| let docv = "FILE" in | ||
| Arg.(value & opt (some output_file_conv) None & info ["o"] ~docv ~doc) | ||
| ;; | ||
| let help_flag = | ||
| let doc = "Show this help message" in | ||
| Arg.(value & flag & info ["h"] ~doc) | ||
| let help_cmd = | ||
| Term.(ret (const (fun _ -> `Help (`Pager, None)) $ help_flag)), | ||
| Term.info "help" | ||
| let cmd = | ||
| let doc = sprintf "Compile Grain programs" in | ||
| Term.(ret (Grain_utils.Config.with_cli_options compile_file $ input_filename $ output_filename)), | ||
| Term.info (Sys.argv.(0)) ~version:"1.0.0" ~doc | ||
| let () = | ||
| match Term.eval cmd with | ||
| | `Error _ -> exit 1 | ||
| | _ -> exit 0 |
| @@ -0,0 +1,8 @@ | ||
| (jbuild_version 1) | ||
| (executable | ||
| ((name grainc) | ||
| (public_name grainc) | ||
| (package grain) | ||
| (libraries (grain)))) | ||
| @@ -0,0 +1 @@ | ||
| (context ((switch 4.05.0))) |
| @@ -0,0 +1,97 @@ | ||
| import { GrainError } from '../errors/errors'; | ||
| import { grainToJSVal } from '../utils/utils'; | ||
| export class GrainModule { | ||
| constructor(wasmModule, name) { | ||
| this.wasmModule = wasmModule; | ||
| this.name = name; // name is optional | ||
| this._instantiated = null; | ||
| } | ||
| get isInstantiated() { | ||
| return this._instantiated !== null; | ||
| } | ||
| get instantiated() { | ||
| if (!this.isInstantiated) { | ||
| throw new GrainError(-1, `Module${this.name ? (" " + this.name) : ""} must be instantiated before use`); | ||
| } | ||
| return this._instantiated; | ||
| } | ||
| get importSpecs() { | ||
| return WebAssembly.Module.imports(this.wasmModule); | ||
| } | ||
| get exportSpecs() { | ||
| return WebAssembly.Module.exports(this.wasmModule); | ||
| } | ||
| // TODO: This is a low-level function. There should be convenience | ||
| // accessors for runtime-required custom binary sections. | ||
| get customSections() { | ||
| return WebAssembly.Module.customSections(this.wasmModule); | ||
| } | ||
| get exports() { | ||
| return this.instantiated.exports; | ||
| } | ||
| requiredExport(key) { | ||
| let exports = this.exports; | ||
| if (!(key in exports)) { | ||
| throw new Error(`Module ${this.name} missing required export: ${key}`); | ||
| } | ||
| return exports[key]; | ||
| } | ||
| get main() { | ||
| return this.requiredExport("GRAIN$MAIN"); | ||
| } | ||
| get tableSize() { | ||
| return this.requiredExport("GRAIN$TABLE_SIZE"); | ||
| } | ||
| async instantiate(importObj) { | ||
| /*console.log(`Instantiating ${this.name}`); | ||
| console.log(`imports:`); | ||
| Object.keys(importObj).forEach(m => { | ||
| console.log(`\timports[${m}]:`); | ||
| let mod = importObj[m]; | ||
| Object.keys(mod).forEach(v => { | ||
| let val = mod[v]; | ||
| let valstr = (val instanceof Function || typeof val === 'function') ? '<function>' : val; | ||
| console.log(`\t\t${m}.${v}: ${valstr}`); | ||
| }); | ||
| console.log(''); | ||
| });*/ | ||
| this._instantiated = await WebAssembly.instantiate(this.wasmModule, importObj); | ||
| //console.log(`Instantiated: ${this._instantiated}.`); | ||
| //console.log(`fields: ${Object.keys(this._instantiated)}`); | ||
| } | ||
| async run() { | ||
| //console.log(`Running ${this.name}`); | ||
| let res = await this.main(); | ||
| //console.log(`complete.`); | ||
| return grainToJSVal(res); | ||
| } | ||
| } | ||
| export async function readFile(path) { | ||
| const fs = require('fs'); | ||
| let modname = path.replace(/\.gr\(lib\)?$/, '').replace(/.*\/([^/]+)/, '$1'); | ||
| //console.log(`Reading module '${modname}' from file: ${path}`); | ||
| let module = await WebAssembly.compile(fs.readFileSync(path)); | ||
| return new GrainModule(module, modname); | ||
| } | ||
| export async function readURL(url) { | ||
| let modname = url; // FIXME | ||
| console.log(`Reading module at URL: ${url}`); | ||
| let response = await fetch(url); | ||
| if (!response.ok) throw new Error(`[Grain] Could not load ${url} due to a network error.`); | ||
| let module = await WebAssembly.compileStreaming(response); | ||
| return new GrainModule(module, modname); | ||
| } |
| @@ -0,0 +1,96 @@ | ||
| import { GrainError } from '../errors/errors'; | ||
| import { readFile, readURL } from './grain-module'; | ||
| function roundUp(num, multiple) { | ||
| return multiple * (Math.floor((num - 1) / multiple) + 1); | ||
| } | ||
| export class GrainRunner { | ||
| constructor(locator, opts) { | ||
| this.modules = {}; | ||
| this.imports = {}; | ||
| this.locator = locator; | ||
| opts = opts || {}; | ||
| this.opts = opts; | ||
| this.ptr = 0; | ||
| this.ptrZero = 0; | ||
| this.imports['grainRuntime'] = { | ||
| malloc: (bytes) => { | ||
| // Basic malloc implementation for now | ||
| let ret = this.ptr; | ||
| this.ptr += roundUp(bytes, 8); | ||
| return ret; | ||
| }, | ||
| relocBase: 0 | ||
| }; | ||
| } | ||
| addImport(name, obj) { | ||
| this.imports[name] = obj; | ||
| } | ||
| addImports(importObj) { | ||
| Object.keys(importObj).forEach(m => { | ||
| if (m in this.imports) { | ||
| this.imports[m] = Object.assign(this.imports[m], importObj[m]); | ||
| } else { | ||
| this.imports[m] = importObj[m]; | ||
| } | ||
| }); | ||
| } | ||
| async load(name, mod) { | ||
| // Currently, we use a "dumb" linking system, | ||
| // in that the compiled object files do not include | ||
| // any URI for locating their dependencies. | ||
| // This will change in the future. | ||
| let moduleImports = mod.importSpecs; | ||
| // First, load any dependencies which need loading | ||
| for (let imp of moduleImports) { | ||
| if (!(imp.module in this.imports)) { | ||
| // Sanity check | ||
| if (imp.module in this.modules) { | ||
| console.warn(`Ignoring possible cyclic dependency: ${imp.module}`); | ||
| continue; | ||
| } | ||
| // Should return an instance of GrainModule | ||
| let located = await this.locator(imp.module); | ||
| if (!located) { | ||
| throw new GrainError(-1, `Failed to locate required module: ${imp.module}`); | ||
| } | ||
| this.modules[imp.module] = located; | ||
| await this.load(imp.module, located); | ||
| await located.run(); | ||
| this.ptrZero = this.ptr; | ||
| this.imports['grainRuntime']['relocBase'] += located.tableSize; | ||
| this.imports[imp.module] = located.exports; | ||
| } | ||
| } | ||
| // All of the dependencies have been loaded. Now we can instantiate with the import object. | ||
| await mod.instantiate(this.imports); | ||
| if (!(name in this.modules)) { | ||
| this.modules[name] = mod; | ||
| } | ||
| return mod; | ||
| } | ||
| async loadFile(path) { | ||
| let module = await readFile(path); | ||
| return this.load(module.name, module); | ||
| } | ||
| async runFile(path) { | ||
| let module = await this.loadFile(path); | ||
| return module.run(); | ||
| } | ||
| async loadURL(url) { | ||
| let module = await readURL(url); | ||
| return this.load(module.name, module); | ||
| } | ||
| async runURL(path) { | ||
| let module = await this.loadURL(path); | ||
| return module.run(); | ||
| } | ||
| } |
| @@ -1,6 +1,4 @@ | ||
| import GrainRunner from './runtime'; | ||
| if (window.GrainRunner) { | ||
| throw new Error('[Grain] Only one instance of the Grain runtime is allowed!'); | ||
| } | ||
| window.GrainRunner = GrainRunner; | ||
| export default GrainRunner; | ||
| import GrainRunner, { buildGrainRunner } from './runtime'; | ||
| import { defaultURLLocator } from './utils/locators'; | ||
| export { GrainRunner, buildGrainRunner, defaultURLLocator }; |
| @@ -0,0 +1,37 @@ | ||
| import { readFile, readURL } from '../core/grain-module'; | ||
| function normalizeSlash(s) { | ||
| if (s) { | ||
| return s.replace(/\/$/, ''); | ||
| } | ||
| } | ||
| // Default locator definitions. | ||
| export function defaultURLLocator(base) { | ||
| // normalize trailing slash | ||
| base = normalizeSlash(base); | ||
| return async (raw) => { | ||
| if (base === null) { | ||
| return null; | ||
| } | ||
| let module = raw.replace(/^GRAIN\$MODULE\$/, ''); | ||
| return readURL(base + "/" + module + ".wasm"); | ||
| }; | ||
| } | ||
| export function defaultFileLocator(base) { | ||
| const fs = require('fs'); | ||
| // normalize trailing slash | ||
| base = normalizeSlash(base); | ||
| return async (raw) => { | ||
| let module = raw.replace(/^GRAIN\$MODULE\$/, ''); | ||
| if (base === null) { | ||
| return null; | ||
| } | ||
| let fullpath = base + "/" + module + ".wasm"; | ||
| if (!fs.existsSync(fullpath)) { | ||
| return null; | ||
| } | ||
| return readFile(fullpath); | ||
| }; | ||
| } |
| @@ -1,7 +1 @@ | ||
| let x = 3 in | ||
| let y = (1, 2) in | ||
| let z = (3, 4) in | ||
| if x > 1: | ||
| (x - 1) + 5 | ||
| else: | ||
| y | ||
| 3 + 4 |
| @@ -0,0 +1,5 @@ | ||
| let x = (4, 5, 6) in | ||
| let (a, b, c) = x in | ||
| c | ||
| # let a = 5, b = 6 in | ||
| # a |
| @@ -1 +1 @@ | ||
| GrainRunner('examples/conditionals.wasm').then(res => console.log(res)); | ||
| Grain.GrainRunner('examples/adder.wasm').then(res => console.log(res)); |
| @@ -1,157 +0,0 @@ | ||
| open Printf | ||
| open Types | ||
| open Expr | ||
| type 'a anf_bind = | ||
| | BSeq of 'a cexpr | ||
| | BLet of string * 'a cexpr | ||
| | BLetRec of (string * 'a cexpr) list | ||
| let anf (p : tag program) : unit aprogram = | ||
| let rec helpP (p : tag program) : unit aprogram = helpA p | ||
| and helpC (e : tag expr) : (unit cexpr * unit anf_bind list) = | ||
| match e with | ||
| | EPrim1(op, arg, _) -> | ||
| let (arg_imm, arg_setup) = helpI arg in | ||
| (CPrim1(op, arg_imm, ()), arg_setup) | ||
| | EPrim2(op, left, right, _) -> | ||
| let (left_imm, left_setup) = helpI left in | ||
| let (right_imm, right_setup) = helpI right in | ||
| (CPrim2(op, left_imm, right_imm, ()), left_setup @ right_setup) | ||
| | EIf(cond, _then, _else, _) -> | ||
| let (cond_imm, cond_setup) = helpI cond in | ||
| (CIf(cond_imm, helpA _then, helpA _else, ()), cond_setup) | ||
| | ESeq([], _) -> failwith "Impossible by syntax" | ||
| | ESeq([stmt], _) -> helpC stmt | ||
| | ESeq(fst :: rest, tag) -> | ||
| let (fst_ans, fst_setup) = helpC fst in | ||
| let (rest_ans, rest_setup) = helpC (ESeq(rest, tag)) in | ||
| (rest_ans, fst_setup @ [BSeq fst_ans] @ rest_setup) | ||
| | ELet([], body, _) -> helpC body | ||
| | ELet((bind, _, exp, _)::rest, body, pos) -> | ||
| let (exp_ans, exp_setup) = helpC exp in | ||
| let (body_ans, body_setup) = helpC (ELet(rest, body, pos)) in | ||
| (body_ans, exp_setup @ [BLet (bind, exp_ans)] @ body_setup) | ||
| | ELetRec(binds, body, _) -> | ||
| let (names, new_binds_setup) = List.split (List.map (fun (name, _, rhs, _) -> (name, helpC rhs)) binds) in | ||
| let (new_binds, new_setup) = List.split new_binds_setup in | ||
| let (body_ans, body_setup) = helpC body in | ||
| (body_ans, (BLetRec (List.combine names new_binds)) :: body_setup) | ||
| | ELambda(args, body, _) -> | ||
| (CLambda(List.map fst args, helpA body, ()), []) | ||
| | EApp(func, args, _) -> | ||
| let (new_func, func_setup) = helpI func in | ||
| let (new_args, new_setup) = List.split (List.map helpI args) in | ||
| (CApp(new_func, new_args, ()), func_setup @ List.concat new_setup) | ||
| | ETuple(args, _) -> | ||
| let (new_args, new_setup) = List.split (List.map helpI args) in | ||
| (CTuple(new_args, ()), List.concat new_setup) | ||
| | EString(s, _) -> | ||
| (CString(s, ()), []) | ||
| | EEllipsis(_) -> failwith "Cannot ANF library directly." | ||
| | EGetItem(tup, idx, _) -> | ||
| let (tup_imm, tup_setup) = helpI tup in | ||
| let (idx_imm, idx_setup) = helpI idx in | ||
| (CGetItem(tup_imm, idx_imm, ()), tup_setup @ idx_setup) | ||
| | ESetItem(tup, idx, rhs, _) -> | ||
| let (tup_imm, tup_setup) = helpI tup in | ||
| let (idx_imm, idx_setup) = helpI idx in | ||
| let (rhs_imm, rhs_setup) = helpI rhs in | ||
| (CSetItem(tup_imm, idx_imm, rhs_imm, ()), tup_setup @ idx_setup @ rhs_setup) | ||
| | EGetItemExact(tup, idx, _) -> | ||
| let (tup_imm, tup_setup) = helpI tup in | ||
| (CGetItem(tup_imm, ImmNum(idx, ()), ()), tup_setup) | ||
| | ESetItemExact(tup, idx, rhs, _) -> | ||
| let (tup_imm, tup_setup) = helpI tup in | ||
| let (rhs_imm, rhs_setup) = helpI rhs in | ||
| (CSetItem(tup_imm, ImmNum(idx, ()), rhs_imm, ()), tup_setup @ rhs_setup) | ||
| | _ -> let (imm, setup) = helpI e in (CImmExpr imm, setup) | ||
| and helpI (e : tag expr) : (unit immexpr * unit anf_bind list) = | ||
| match e with | ||
| | ENumber(n, _) -> (ImmNum(n, ()), []) | ||
| | EBool(b, _) -> (ImmBool(b, ()), []) | ||
| | EId(name, _) -> (ImmId(name, ()), []) | ||
| | EPrim1(op, arg, tag) -> | ||
| let tmp = sprintf "unary_%d" tag in | ||
| let (arg_imm, arg_setup) = helpI arg in | ||
| (ImmId(tmp, ()), arg_setup @ [BLet(tmp, CPrim1(op, arg_imm, ()))]) | ||
| | EPrim2(op, left, right, tag) -> | ||
| let tmp = sprintf "binop_%d" tag in | ||
| let (left_imm, left_setup) = helpI left in | ||
| let (right_imm, right_setup) = helpI right in | ||
| (ImmId(tmp, ()), left_setup @ right_setup @ [BLet(tmp, CPrim2(op, left_imm, right_imm, ()))]) | ||
| | EIf(cond, _then, _else, tag) -> | ||
| let tmp = sprintf "if_%d" tag in | ||
| let (cond_imm, cond_setup) = helpI cond in | ||
| (ImmId(tmp, ()), cond_setup @ [BLet(tmp, CIf(cond_imm, helpA _then, helpA _else, ()))]) | ||
| | EApp(func, args, tag) -> | ||
| let tmp = sprintf "app_%d" tag in | ||
| let (new_func, func_setup) = helpI func in | ||
| let (new_args, new_setup) = List.split (List.map helpI args) in | ||
| (ImmId(tmp, ()), (func_setup @ List.concat new_setup) @ [BLet(tmp, CApp(new_func, new_args, ()))]) | ||
| | ESeq([], _) -> failwith "Impossible by syntax" | ||
| | ESeq([stmt], _) -> helpI stmt | ||
| | ESeq(fst :: rest, tag) -> | ||
| let (fst_ans, fst_setup) = helpC fst in | ||
| let (rest_ans, rest_setup) = helpI (ESeq(rest, tag)) in | ||
| (rest_ans, fst_setup @ [BSeq fst_ans] @ rest_setup) | ||
| | ELet([], body, _) -> helpI body | ||
| | ELet((bind, _, exp, _)::rest, body, pos) -> | ||
| let (exp_ans, exp_setup) = helpC exp in | ||
| let (body_ans, body_setup) = helpI (ELet(rest, body, pos)) in | ||
| (body_ans, exp_setup @ [BLet(bind, exp_ans)] @ body_setup) | ||
| | ELetRec(binds, body, tag) -> | ||
| let tmp = sprintf "lam_%d" tag in | ||
| let (names, new_binds_setup) = List.split (List.map (fun (name, _, rhs, _) -> (name, helpC rhs)) binds) in | ||
| let (new_binds, new_setup) = List.split new_binds_setup in | ||
| let (body_ans, body_setup) = helpC body in | ||
| (ImmId(tmp, ()), (List.concat new_setup) | ||
| @ [BLetRec (List.combine names new_binds)] | ||
| @ body_setup | ||
| @ [BLet(tmp, body_ans)]) | ||
| | ELambda(args, body, tag) -> | ||
| let tmp = sprintf "lam_%d" tag in | ||
| (ImmId(tmp, ()), [BLet(tmp, CLambda(List.map fst args, helpA body, ()))]) | ||
| | ETuple(args, tag) -> | ||
| let tmp = sprintf "tup_%d" tag in | ||
| let (new_args, new_setup) = List.split (List.map helpI args) in | ||
| (ImmId(tmp, ()), (List.concat new_setup) @ [BLet(tmp, CTuple(new_args, ()))]) | ||
| | EString(s, tag) -> | ||
| let tmp = sprintf "str_%d" tag in | ||
| (ImmId(tmp, ()), [BLet(tmp, CString(s, ()))]) | ||
| | EEllipsis(_) -> failwith "Cannot ANF library directly." | ||
| | EInclude(_, _, _) -> failwith "Cannot ANF include" | ||
| | EGetItem(tup, idx, tag) -> | ||
| let tmp = sprintf "get_%d" tag in | ||
| let (tup_imm, tup_setup) = helpI tup in | ||
| let (idx_imm, idx_setup) = helpI idx in | ||
| (ImmId(tmp, ()), tup_setup @ idx_setup @ [BLet(tmp, CGetItem(tup_imm, idx_imm, ()))]) | ||
| | ESetItem(tup, idx, rhs, tag) -> | ||
| let tmp = sprintf "set_%d" tag in | ||
| let (tup_imm, tup_setup) = helpI tup in | ||
| let (idx_imm, idx_setup) = helpI idx in | ||
| let (rhs_imm, rhs_setup) = helpI rhs in | ||
| (ImmId(tmp, ()), tup_setup @ idx_setup @ rhs_setup @ [BLet(tmp, CSetItem(tup_imm, idx_imm, rhs_imm, ()))]) | ||
| | EGetItemExact(tup, idx, tag) -> | ||
| let tmp = sprintf "get_%d" tag in | ||
| let (tup_imm, tup_setup) = helpI tup in | ||
| (ImmId(tmp, ()), tup_setup @ [BLet(tmp, CGetItem(tup_imm, ImmNum(idx, ()), ()))]) | ||
| | ESetItemExact(tup, idx, rhs, tag) -> | ||
| let tmp = sprintf "set_%d" tag in | ||
| let (tup_imm, tup_setup) = helpI tup in | ||
| let (rhs_imm, rhs_setup) = helpI rhs in | ||
| (ImmId(tmp, ()), tup_setup @ rhs_setup @ [BLet(tmp, CSetItem(tup_imm, ImmNum(idx, ()), rhs_imm, ()))]) | ||
| and helpA e : unit aexpr = | ||
| let (ans, ans_setup) = helpC e in | ||
| List.fold_right | ||
| (fun bind body -> | ||
| match bind with | ||
| | BSeq(exp) -> ASeq(exp, body, ()) | ||
| | BLet(name, exp) -> ALet(name, exp, body, ()) | ||
| | BLetRec(names) -> ALetRec(names, body, ())) | ||
| ans_setup (ACExpr ans) | ||
| in | ||
| helpP p | ||
| ;; |
| @@ -1,61 +0,0 @@ | ||
| open Types | ||
| open Expr | ||
| module BindingSet = Set.Make(struct | ||
| type t = string | ||
| let compare = String.compare | ||
| end) | ||
| let free_vars (e : 'a aexpr) : BindingSet.t = | ||
| let rec helpA (bound : string list) (e : 'a aexpr) : string list = | ||
| match e with | ||
| | ASeq(fst, rest, _) -> | ||
| helpC bound fst @ helpA bound rest | ||
| | ALet(name, binding, body, _) -> | ||
| (helpC bound binding) (* all the free variables in the binding, plus *) | ||
| (* all the free variables in the body, except the name itself *) | ||
| @ (helpA (name :: bound) body) | ||
| | ALetRec(bindings, body, _) -> | ||
| let names = List.map fst bindings in | ||
| let new_bound = (names @ bound) in | ||
| (helpA new_bound body) @ List.flatten (List.map (fun binding -> helpC new_bound (snd binding)) bindings) | ||
| | ACExpr c -> helpC bound c | ||
| and helpC (bound : string list) (e : 'a cexpr) : string list = | ||
| match e with | ||
| | CLambda(args, body, _) -> | ||
| helpA (args @ bound) body | ||
| | CIf(cond, thn, els, _) -> | ||
| helpI bound cond @ helpA bound thn @ helpA bound els | ||
| | CPrim1(_, arg, _) -> helpI bound arg | ||
| | CPrim2(_, left, right, _) -> helpI bound left @ helpI bound right | ||
| | CApp(fn, args, _) -> | ||
| (helpI bound fn) @ (List.flatten (List.map (fun arg -> helpI bound arg) args)) | ||
| | CString(_, _) -> [] | ||
| | CTuple(vals, _) -> List.flatten (List.map (fun v -> helpI bound v) vals) | ||
| | CGetItem(tup, idx, _) -> helpI bound tup @ helpI bound idx | ||
| | CSetItem(tup, idx, rhs, _) -> helpI bound tup @ helpI bound idx @ helpI bound rhs | ||
| | CImmExpr i -> helpI bound i | ||
| and helpI (bound : string list) (e : 'a immexpr) : string list = | ||
| match e with | ||
| | ImmId(name, _) -> | ||
| (* a name is free if it is not bound *) | ||
| if List.mem name bound then [] else [name] | ||
| | _ -> [] | ||
| in BindingSet.of_list @@ List.sort_uniq String.compare (helpA [] e) | ||
| ;; | ||
| let count_vars e = | ||
| let rec helpA e = | ||
| match e with | ||
| | ALet(_, bind, body, _) -> 1 + (max (helpC bind) (helpA body)) | ||
| | ALetRec(binds, body, _) -> | ||
| (List.length binds) + (max (List.fold_left max 0 @@ List.map (fun (x, c) -> helpC c) binds) (helpA body)) | ||
| | ACExpr e -> helpC e | ||
| | ASeq(hd, tl, _) -> max (helpC hd) (helpA tl) | ||
| and helpC e = | ||
| match e with | ||
| | CIf(_, t, f, _) -> max (helpA t) (helpA f) | ||
| | CApp(_, args, _) -> List.length args | ||
| | _ -> 0 | ||
| in helpA e | ||
| ;; |
| @@ -0,0 +1,32 @@ | ||
| open Grain_typed | ||
| open Grain_middle_end | ||
| open Mashtree | ||
| open Wasm | ||
| type codegen_env = { | ||
| (* Pointer to top of heap (needed until GC is implemented) *) | ||
| heap_top: Wasm.Ast.var; | ||
| num_args: int; | ||
| func_offset: int; | ||
| global_offset: int; | ||
| import_global_offset: int; | ||
| import_func_offset: int; | ||
| import_offset: int; | ||
| func_types: Wasm.Types.func_type BatDeque.t ref; | ||
| (* Allocated closures which need backpatching *) | ||
| backpatches: (Wasm.Ast.instr' Concatlist.t * closure_data) list ref; | ||
| imported_funcs: (int32 Ident.tbl) Ident.tbl; | ||
| imported_globals: (int32 Ident.tbl) Ident.tbl; | ||
| } | ||
| val init_codegen_env : unit -> codegen_env | ||
| exception WasmRunnerError of Wasm.Source.region * string * Wasm.Ast.module_ | ||
| val reparse_module : Wasm.Ast.module_ -> Wasm.Ast.module_ | ||
| val validate_module : Wasm.Ast.module_ -> unit | ||
| val compile_wasm_module : ?env:codegen_env -> Mashtree.mash_program -> Wasm.Ast.module_ | ||
| val module_to_string : Wasm.Ast.module_ -> string |
| @@ -0,0 +1,14 @@ | ||
| open Grain_typed | ||
| open Mashtree | ||
| type compiled_program = { | ||
| asm: Wasm.Ast.module_; | ||
| signature: Cmi_format.cmi_infos; | ||
| } | ||
| let compile_wasm_module ({Mashtree.signature; } as mashprog) = | ||
| let asm = Compcore.compile_wasm_module mashprog in | ||
| { | ||
| asm; | ||
| signature; | ||
| } |
| @@ -0,0 +1,179 @@ | ||
| (** Catenable lists. Adapted from Pyret. *) | ||
| open Sexplib.Conv | ||
| type 'a t = | ||
| | Empty | ||
| | Singleton of 'a | ||
| | Append of 'a t * 'a t | ||
| | Cons of 'a * 'a t | ||
| | Snoc of 'a t * 'a | ||
| | Wrapped of 'a list (* <- for faster conversions (will lazily be converted to other forms) *) | ||
| [@@deriving sexp] | ||
| let list_of_t cl = | ||
| let rec to_list_acc cl acc = | ||
| match cl with | ||
| | Empty -> acc | ||
| | Singleton(e) -> e::acc | ||
| | Append(l1, l2) -> to_list_acc l1 (to_list_acc l2 acc) | ||
| | Cons(e, l) -> e::(to_list_acc l acc) | ||
| | Snoc(l, e) -> to_list_acc l (e::acc) | ||
| | Wrapped(l) -> l in | ||
| to_list_acc cl [] | ||
| let mapped_list_of_t f cl = | ||
| let rec map_onto lst acc = | ||
| match lst with | ||
| | [] -> acc | ||
| | hd::tl -> | ||
| let hd = f hd in | ||
| let tl = map_onto tl acc in | ||
| hd::tl in | ||
| let rec to_list_acc cl acc = | ||
| match cl with | ||
| | Empty -> acc | ||
| | Singleton(e) -> (f e)::acc | ||
| | Append(l1, l2) -> to_list_acc l1 (to_list_acc l2 acc) | ||
| | Cons(e, l) -> | ||
| let hd = f e in | ||
| let tl = to_list_acc l acc in | ||
| hd::tl | ||
| | Snoc(l, e) -> to_list_acc l ((f e)::acc) | ||
| | Wrapped(l) -> (map_onto l acc) in | ||
| to_list_acc cl [] | ||
| let left_mapped_list_of_t f cl = | ||
| let rec revmap_to_list_acc f acc cl = | ||
| match cl with | ||
| | Empty -> acc | ||
| | Singleton(e) -> (f e)::acc | ||
| | Append(left, right) -> revmap_to_list_acc f (revmap_to_list_acc f acc left) right | ||
| | Cons(e, l) -> revmap_to_list_acc f ((f e)::acc) l | ||
| | Snoc(l, e) -> | ||
| let newhead = revmap_to_list_acc f acc l in | ||
| (f e)::newhead | ||
| | Wrapped(l) -> List.rev_map f l in | ||
| List.rev (revmap_to_list_acc f [] cl) | ||
| let rec map f cl = | ||
| match cl with | ||
| | Empty -> Empty | ||
| | Singleton(e) -> Singleton(f e) | ||
| | Append(l1, l2) -> Append(map f l1, map f l2) | ||
| | Cons(e, l) -> Cons(f e, map f l) | ||
| | Snoc(l, e) -> Snoc(map f l, f e) | ||
| | Wrapped([]) -> Empty | ||
| | Wrapped(hd::tl) -> Cons(f hd, map f (Wrapped tl)) | ||
| let rec iter : 'a. ('a -> unit) -> 'a t -> unit = fun f cl -> | ||
| match cl with | ||
| | Empty -> () | ||
| | Singleton(e) -> f e | ||
| | Append(l1, l2) -> iter f l1; iter f l2 | ||
| | Cons(e, l) -> f e; iter f l | ||
| | Snoc(l, e) -> iter f l; f e | ||
| | Wrapped(l) -> List.iter f l | ||
| let rec fold_left f base cl = | ||
| match cl with | ||
| | Empty -> base | ||
| | Singleton e -> f base e | ||
| | Append(l1, l2) -> fold_left f (fold_left f base l1) l2 | ||
| | Cons(e, l) -> fold_left f (f base e) l | ||
| | Snoc(l, e) -> f (fold_left f base l) e | ||
| | Wrapped(l) -> List.fold_left f base l | ||
| let rec fold_right f cl base = | ||
| match cl with | ||
| | Empty -> base | ||
| | Singleton e -> f e base | ||
| | Append(l1, l2) -> fold_right f l1 (fold_right f l2 base) | ||
| | Cons(e, l) -> f e (fold_right f l base) | ||
| | Snoc(l, e) -> fold_right f l (f e base) | ||
| | Wrapped(l) -> List.fold_right f l base | ||
| let length cl = fold_left (fun acc _ -> acc + 1) 0 cl | ||
| let rec is_empty cl = | ||
| match cl with | ||
| | Empty | ||
| | Wrapped([]) -> true | ||
| | Append(l1, l2) -> (is_empty l1) && (is_empty l2) | ||
| | _ -> false | ||
| let rec rev cl = | ||
| match cl with | ||
| | Empty | ||
| | Singleton _ | ||
| | Wrapped([]) -> cl | ||
| | Append(l1, l2) -> Append(rev l2, rev l1) | ||
| | Cons(e, l) -> Snoc(rev l, e) | ||
| | Snoc(l, e) -> Cons(e, rev l) | ||
| | Wrapped(hd::tl) -> Snoc(rev (Wrapped tl), hd) | ||
| let rec hd cl = | ||
| match cl with | ||
| | Singleton(e) | ||
| | Cons(e, _) -> e | ||
| | Snoc(l, e) when is_empty l -> e | ||
| | Snoc(l, _) -> hd l | ||
| | Append(l1, _) when not(is_empty l1) -> hd l1 | ||
| | Append(_, l2) -> hd l2 | ||
| | Wrapped(hd::_) -> hd | ||
| | Wrapped([]) | ||
| | Empty -> raise Not_found | ||
| let rec tl cl = | ||
| match cl with | ||
| | Singleton(_) | ||
| | Empty | ||
| | Wrapped([]) -> raise (Failure "tl") | ||
| | Cons(_, rest) -> rest | ||
| | Wrapped(_::rest) -> Wrapped(rest) | ||
| | Append(l1, rest) when (is_empty l1) -> rest | ||
| | Append(l1, l2) -> Append(tl l1, l2) | ||
| | Snoc(l, e) when is_empty l -> Singleton(e) | ||
| | Snoc(l, e) -> Snoc(tl l, e) | ||
| (** Returns the last element of the given list. *) | ||
| let rec last cl = | ||
| match cl with | ||
| | Singleton(e) | ||
| | Snoc(_, e) -> e | ||
| | Cons(e, l) when is_empty l -> e | ||
| | Cons(e, l) -> last l | ||
| | Append(_, l2) when not(is_empty l2) -> last l2 | ||
| | Append(l1, _) -> last l1 | ||
| | Wrapped(hd::[]) -> hd | ||
| | Wrapped(hd::rest) -> last (Wrapped(rest)) | ||
| | Wrapped([]) | ||
| | Empty -> raise (Failure "last") | ||
| let rec mapped_t_of_list : 'a 'b. ('a -> 'b) -> 'a list -> 'b t = fun f lst -> | ||
| match lst with | ||
| | [] -> Empty | ||
| | [x] -> Singleton(f x) | ||
| | hd::tl -> Cons(f hd, mapped_t_of_list f tl) | ||
| let t_of_list : 'a. 'a list -> 'a t = fun lst -> Wrapped lst | ||
| (** The empty concatlist. *) | ||
| let empty : 'a. 'a t = Empty | ||
| (** Constructs a one-item concatlist. *) | ||
| let singleton : 'a. 'a -> 'a t = fun x -> Singleton(x) | ||
| (** Appends the two given concatlists. *) | ||
| let append : 'a. 'a t -> 'a t -> 'a t = fun a b -> Append(a, b) | ||
| (** Adds the given item to the front of the given concatlist. *) | ||
| let cons : 'a. 'a -> 'a t -> 'a t = fun a b -> Cons(a, b) | ||
| (** Adds the given item to the end of the given concatlist. *) | ||
| let snoc : 'a. 'a t -> 'a -> 'a t = fun a b -> Snoc(a, b) | ||
| (** Wraps the given list into a concatlist (a synonym for [t_of_list])*) | ||
| let wrapped : 'a. 'a list -> 'a t = t_of_list | ||
| let (@) = append | ||
| let (@+) l1 l2 = Append(l1, t_of_list l2) | ||
| let (+@) = (@+) | ||
| let flatten : 'a. 'a t list -> 'a t = fun concatlists -> List.fold_right (@) concatlists Empty | ||
| @@ -0,0 +1,76 @@ | ||
| (** Catenable lists. Adapted from Pyret. *) | ||
| type 'a t [@@deriving sexp] | ||
| (** Flattens the given concatlist into a list. *) | ||
| val list_of_t : 'a t -> 'a list | ||
| (** Maps the given function over the given concatlist, | ||
| collecting the result as a list. *) | ||
| val mapped_list_of_t : ('a -> 'b) -> 'a t -> 'b list | ||
| (** Like [mapped_list_of_t], but guarantees that the function will | ||
| be called with the items in order. *) | ||
| val left_mapped_list_of_t : ('a -> 'b) -> 'a t -> 'b list | ||
| (** Like [List.map], but over concatlists. *) | ||
| val map : ('a -> 'b) -> 'a t -> 'b t | ||
| (** Like [List.iter], but over concatlists. *) | ||
| val iter : ('a -> unit) -> 'a t -> unit | ||
| (** Like [List.fold_left], but over concatlists. *) | ||
| val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b | ||
| (** Like [List.fold_right], but over concatlists. *) | ||
| val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b | ||
| (** Returns the number of elements in the given concatlist *) | ||
| val length : 'a t -> int | ||
| (** Returns true if the given concatlist contains no elements. *) | ||
| val is_empty : 'a t -> bool | ||
| (** Reverses the given concatlist. *) | ||
| val rev : 'a t -> 'a t | ||
| (** Returns the first element of the given concatlist. If the list has | ||
| no elements, [Failure "hd"] is raised. *) | ||
| val hd : 'a t -> 'a | ||
| (** Returns all but the first element of the given concatlist. If the list has no tail, | ||
| [Failure "tl"] is raised. *) | ||
| val tl : 'a t -> 'a t | ||
| (** Returns the last element of the given concatlist. If the list has no tail, | ||
| [Failure "last"] is raised. *) | ||
| val last : 'a t -> 'a | ||
| (** Maps the given function over all items in the given list and | ||
| collects the result in a concatlist. *) | ||
| val mapped_t_of_list : ('a -> 'b) -> 'a list -> 'b t | ||
| (** Wraps the given list as a concatlist. *) | ||
| val t_of_list : 'a list -> 'a t | ||
| (** Flattens the given list of concatlists into a single concatlist. *) | ||
| val flatten : 'a t list -> 'a t | ||
| (** The empty concatlist. *) | ||
| val empty : 'a t | ||
| (** Constructs a one-item concatlist. *) | ||
| val singleton : 'a -> 'a t | ||
| (** Appends the two given concatlists. *) | ||
| val append : 'a t -> 'a t -> 'a t | ||
| (** Adds the given item to the front of the given concatlist. *) | ||
| val cons : 'a -> 'a t -> 'a t | ||
| (** Adds the given item to the end of the given concatlist. *) | ||
| val snoc : 'a t -> 'a -> 'a t | ||
| (** Wraps the given list into a concatlist (a synonym for [t_of_list])*) | ||
| val wrapped : 'a list -> 'a t | ||
| (** Infix operator for [append] *) | ||
| val (@) : 'a t -> 'a t -> 'a t | ||
| (** Like [@], but wraps the right-hand side *) | ||
| val (@+) : 'a t -> 'a list -> 'a t | ||
| (** Alias for [@+] (for left-associativity) *) | ||
| val (+@) : 'a t -> 'a list -> 'a t | ||
| @@ -0,0 +1,25 @@ | ||
| open Grain_typed | ||
| open Grain_utils | ||
| open Compmod | ||
| let emit_module {asm; signature} outfile = | ||
| Files.ensure_parent_directory_exists outfile; | ||
| if !Config.debug then begin | ||
| let asm_string = Wasm.Sexpr.to_string 80 (Wasm.Arrange.module_ asm) in | ||
| let sig_string = Sexplib.Sexp.to_string_hum (Cmi_format.sexp_of_cmi_infos signature) in | ||
| let wast_file = outfile ^ ".wast" in | ||
| let sig_file = outfile ^ ".modsig" in | ||
| let oc = open_out wast_file in | ||
| output_string oc asm_string; | ||
| close_out oc; | ||
| let oc = open_out sig_file in | ||
| output_string oc sig_string; | ||
| close_out oc | ||
| end; | ||
| let encoded = Wasm.Encode.encode asm in | ||
| let oc = open_out_bin outfile in | ||
| output_string oc encoded; | ||
| Cmi_format.output_cmi outfile oc signature; | ||
| close_out oc | ||
| @@ -0,0 +1,9 @@ | ||
| (jbuild_version 1) | ||
| (library | ||
| ((name grain_codegen) | ||
| (public_name grain_codegen) | ||
| (synopsis "Grain compiler code generation") | ||
| (libraries (wasm stdint grain_parsing grain_typed grain_middle_end grain_utils ppx_deriving ppx_sexp_conv sexplib)) | ||
| (preprocess (pps (ppx_sexp_conv ppx_deriving))))) | ||
| @@ -0,0 +1,171 @@ | ||
| (** Low-level IR, suitable for direct translation into WASM *) | ||
| open Sexplib.Conv | ||
| open Grain_parsing | ||
| open Grain_typed | ||
| open Value_tags | ||
| open Runtime_errors | ||
| (* OCaml floats are 64-bit | ||
| (see section 2.3: https://github.com/janestreet/janestreet.github.com/blob/009358427533b46ba2c66200779ea05a73ef0783/ocaml-perf-notes.md)*) | ||
| type float32 = float | ||
| type float64 = float | ||
| type tag_type = Value_tags.tag_type | ||
| type heap_tag_type = Value_tags.heap_tag_type | ||
| type grain_error = Runtime_errors.grain_error | ||
| let prim1_of_sexp, sexp_of_prim1 = Parsetree.prim1_of_sexp, Parsetree.sexp_of_prim1 | ||
| let prim2_of_sexp, sexp_of_prim2 = Parsetree.prim2_of_sexp, Parsetree.sexp_of_prim2 | ||
| type prim1 = Parsetree.prim1 = | ||
| | Add1 | ||
| | Sub1 | ||
| | Not | ||
| | IsNum | ||
| | IsBool | ||
| | IsTuple | ||
| type prim2 = Parsetree.prim2 = | ||
| | Plus | ||
| | Minus | ||
| | Times | ||
| | Less | ||
| | Greater | ||
| | LessEq | ||
| | GreaterEq | ||
| | Eq | ||
| | And | ||
| | Or | ||
| (* Types within the WASM output *) | ||
| type asmtype = | ||
| | I32Type | ||
| | I64Type | ||
| | F32Type | ||
| | F64Type | ||
| [@@deriving sexp] | ||
| type constant = | ||
| | MConstI32 of int32 | ||
| | MConstI64 of int64 | ||
| | MConstF32 of float | ||
| | MConstF64 of float | ||
| | MConstLiteral of constant (* Special case for things which should not be encoded *) | ||
| [@@deriving sexp] | ||
| type binding = | ||
| | MArgBind of int32 | ||
| | MLocalBind of int32 | ||
| | MGlobalBind of int32 | ||
| | MClosureBind of int32 | ||
| | MSwapBind of int32 (* Used like a register would be *) | ||
| | MImport of int32 (* Index into list of imports *) | ||
| [@@deriving sexp] | ||
| type immediate = | ||
| | MImmConst of constant | ||
| | MImmBinding of binding | ||
| [@@deriving sexp] | ||
| type closure_data = { | ||
| func_idx: int32; | ||
| arity: int32; | ||
| variables: immediate list; | ||
| } [@@deriving sexp] | ||
| type allocation_type = | ||
| | MClosure of closure_data | ||
| | MTuple of immediate list | ||
| | MString of string | ||
| [@@deriving sexp] | ||
| type tag_op = | ||
| | MCheckTag | ||
| | MAssertTag | ||
| | MAddTag | ||
| | MRemoveTag | ||
| [@@deriving sexp] | ||
| type arity_operand = | ||
| | MLambdaArity | ||
| | MTupleArity | ||
| [@@deriving sexp] | ||
| type arity_op = | ||
| | MGetArity | ||
| | MAssertArity of int32 | ||
| [@@deriving sexp] | ||
| type tuple_op = | ||
| | MTupleGet of int32 | ||
| | MTupleSet of int32 * immediate | ||
| [@@deriving sexp] | ||
| type instr = | ||
| | MImmediate of immediate | ||
| | MCallKnown of int32 * immediate list (* Optimized path for statically-known function names *) | ||
| | MCallIndirect of immediate * immediate list | ||
| | MError of grain_error * immediate list | ||
| | MAllocate of allocation_type | ||
| | MTagOp of tag_op * tag_type * immediate | ||
| | MArityOp of arity_operand * arity_op * immediate | ||
| | MIf of immediate * block * block | ||
| | MSwitch of immediate * (int32 * block) list * block (* value, branches, default *) | ||
| | MPrim1 of prim1 * immediate | ||
| | MPrim2 of prim2 * immediate * immediate | ||
| | MTupleOp of tuple_op * immediate | ||
| | MStore of (binding * instr) list (* Items in the same list have their backpatching delayed until the end of that list *) | ||
| [@@deriving sexp] | ||
| and block = instr list [@@deriving sexp] | ||
| type import_type = | ||
| | MFuncImport of asmtype list * asmtype list | ||
| | MGlobalImport of asmtype | ||
| [@@deriving sexp] | ||
| type import_kind = | ||
| | MImportWasm | ||
| | MImportGrain | ||
| [@@deriving sexp] | ||
| type import_setup = | ||
| | MCallGetter | ||
| | MWrap of int32 | ||
| | MSetupNone | ||
| [@@deriving sexp] | ||
| type import = { | ||
| mimp_mod: Ident.t; | ||
| mimp_name: Ident.t; | ||
| mimp_type: import_type; | ||
| mimp_kind: import_kind; | ||
| mimp_setup: import_setup; | ||
| } [@@deriving sexp] | ||
| type export = { | ||
| ex_name: Ident.t; | ||
| ex_global_index: int32; | ||
| ex_getter_index: int32; | ||
| } [@@deriving sexp] | ||
| type mash_function = { | ||
| index: int32; | ||
| arity: int32; (* TODO: Proper typing of arguments *) | ||
| body: block; | ||
| stack_size: int; | ||
| } [@@deriving sexp] | ||
| type mash_program = { | ||
| functions: mash_function list; | ||
| imports: import list; | ||
| exports: export list; | ||
| main_body: block; | ||
| main_body_stack_size: int; | ||
| num_globals: int; | ||
| signature: Cmi_format.cmi_infos; | ||
| } [@@deriving sexp] | ||
| let const_true = MConstLiteral (MConstI32 (Int32.of_int 0xFFFFFFFF)) | ||
| let const_false = MConstLiteral (MConstI32 (Int32.of_int 0x7FFFFFFF)) |
| @@ -0,0 +1,353 @@ | ||
| open Grain_parsing | ||
| open Grain_typed | ||
| open Grain_middle_end | ||
| open Asttypes | ||
| open Anftree | ||
| open Mashtree | ||
| module StrMap = BatMap.String | ||
| type compilation_env = { | ||
| ce_binds: Mashtree.binding Ident.tbl; | ||
| (* Useful due to us needing a second pass over exports (for mutual recursion) *) | ||
| ce_exported_globals: int32 Ident.tbl; | ||
| ce_stack_idx: int; | ||
| ce_arity: int; | ||
| } | ||
| let initial_compilation_env = { | ||
| ce_binds = Ident.empty; | ||
| ce_exported_globals = Ident.empty; | ||
| ce_stack_idx = 0; | ||
| ce_arity = 0; | ||
| } | ||
| type worklist_elt_body = | ||
| | Anf of anf_expression | ||
| | Precompiled of block | ||
| type worklist_elt = { | ||
| body : worklist_elt_body; | ||
| env : compilation_env; | ||
| arity : int; | ||
| idx : int; (* Lambda-lifted index *) | ||
| stack_size : int; | ||
| } | ||
| let compilation_worklist = ref (BatDeque.empty : worklist_elt BatDeque.t) | ||
| (** Lambda-lifting index (function index) *) | ||
| let lift_index = ref 0 | ||
| let reset_lift() = | ||
| lift_index := 0 | ||
| let next_lift() = | ||
| let ret = !lift_index in | ||
| lift_index := ret + 1; | ||
| ret | ||
| (** Global index (index of global variables) *) | ||
| let global_table = ref (Ident.empty : (int32 * int32) Ident.tbl) | ||
| let global_index = ref 0 | ||
| let global_exports() = | ||
| let tbl = !global_table in | ||
| Ident.fold_all (fun ex_name (ex_global_index, ex_getter_index) acc -> {ex_name; ex_global_index; ex_getter_index}::acc) tbl [] | ||
| let reset_global() = | ||
| global_table := Ident.empty; | ||
| global_index := 0 | ||
| let next_global id = | ||
| (* RIP Hygiene (this behavior works as expected until we have more metaprogramming constructs) *) | ||
| match Ident.find_name_opt (Ident.name id) (!global_table) with | ||
| | Some(_, (ret, ret_get)) -> Int32.to_int ret, Int32.to_int ret_get | ||
| | None -> | ||
| begin | ||
| let ret = !global_index in | ||
| let ret_get = next_lift() in | ||
| global_table := Ident.add id ((Int32.of_int ret), (Int32.of_int ret_get)) !global_table; | ||
| global_index := ret + 1; | ||
| (ret, ret_get) | ||
| end | ||
| let find_id id env = Ident.find_same id env.ce_binds | ||
| let find_global id env = Ident.find_same id env.ce_exported_globals | ||
| let worklist_reset () = compilation_worklist := BatDeque.empty | ||
| let worklist_enqueue elt = compilation_worklist := BatDeque.snoc !compilation_worklist elt | ||
| let worklist_empty () = BatDeque.is_empty !compilation_worklist | ||
| let worklist_pop () = | ||
| match BatDeque.front !compilation_worklist with | ||
| | None -> raise Not_found | ||
| | Some(hd, tl) -> | ||
| compilation_worklist := tl; | ||
| hd | ||
| let compile_const (c : Asttypes.constant) = | ||
| match c with | ||
| | Const_int i -> MConstI32 (Int32.of_int i) | ||
| | Const_string _ -> failwith "NYI: compile_const string" | ||
| | Const_float f_str -> failwith "NYI: compile_const float" | ||
| | Const_int32 i32 -> MConstI32 i32 | ||
| | Const_int64 i64 -> MConstI64 i64 | ||
| | Const_bool b when b = true -> const_true | ||
| | Const_bool _ -> const_false | ||
| let compile_imm env (i : imm_expression) = | ||
| match i.imm_desc with | ||
| | ImmConst c -> MImmConst(compile_const c) | ||
| | ImmId id -> MImmBinding(find_id id env) | ||
| let compile_lambda env args body : Mashtree.closure_data = | ||
| let used_var_set = Anf_utils.anf_free_vars body in | ||
| let free_var_set = Ident.Set.diff used_var_set @@ Ident.Set.of_list args in | ||
| let free_vars = Ident.Set.elements free_var_set in | ||
| (* Bind all non-arguments in the function body to | ||
| their respective closure slots *) | ||
| let free_binds = BatList.fold_lefti (fun acc closure_idx var -> | ||
| Ident.add var (MClosureBind(Int32.of_int closure_idx)) acc) | ||
| Ident.empty free_vars in | ||
| let closure_arg = Ident.create "$self" in | ||
| let new_args = closure_arg::args in | ||
| let arg_binds = BatList.fold_lefti (fun acc arg_idx arg -> | ||
| Ident.add arg (MArgBind(Int32.of_int arg_idx)) acc) | ||
| free_binds new_args in | ||
| let idx = next_lift() in | ||
| let arity = List.length new_args in | ||
| let stack_size = Anf_utils.anf_count_vars body in | ||
| let lam_env = { | ||
| env with | ||
| ce_binds=arg_binds; | ||
| ce_stack_idx=0; | ||
| ce_arity=arity; | ||
| } in | ||
| let worklist_item = { | ||
| body=Anf body; | ||
| env=lam_env; | ||
| idx; | ||
| arity; | ||
| stack_size; | ||
| } in | ||
| worklist_enqueue worklist_item; | ||
| { | ||
| func_idx=(Int32.of_int idx); | ||
| arity=(Int32.of_int arity); | ||
| (* These variables should be in scope when the lambda is constructed. *) | ||
| variables=(List.map (fun id -> MImmBinding(find_id id env)) free_vars); | ||
| } | ||
| let compile_wrapper env real_idx arity : Mashtree.closure_data = | ||
| let body = [ | ||
| MCallKnown(Int32.of_int real_idx, BatList.init arity (fun i -> MImmBinding(MArgBind(Int32.of_int (i + 1))))); | ||
| ] in | ||
| let idx = next_lift() in | ||
| let lam_env = { | ||
| env with | ||
| ce_binds=Ident.empty; | ||
| ce_stack_idx=0; | ||
| ce_arity=arity + 1; | ||
| } in | ||
| let worklist_item = { | ||
| body=Precompiled body; | ||
| env=lam_env; | ||
| idx; | ||
| arity=arity + 1; | ||
| stack_size=0; | ||
| } in | ||
| worklist_enqueue worklist_item; | ||
| { | ||
| func_idx=(Int32.of_int idx); | ||
| arity=(Int32.of_int (arity + 1)); | ||
| variables=[]; | ||
| } | ||
| let next_global id = | ||
| let ret, idx = next_global id in | ||
| if ret <> ((!global_index) - 1) then | ||
| ret | ||
| else begin | ||
| let body = [ | ||
| MImmediate(MImmBinding(MGlobalBind (Int32.of_int ret))); | ||
| ] in | ||
| let worklist_item = { | ||
| body=Precompiled body; | ||
| env=initial_compilation_env; | ||
| idx; | ||
| arity=0; (* <- this function cannot be called by the user, so no self argument is needed. *) | ||
| stack_size=0; | ||
| } in | ||
| worklist_enqueue worklist_item; | ||
| ret | ||
| end | ||
| let rec compile_comp env c = | ||
| match c.comp_desc with | ||
| | CSwitch(arg, branches) -> | ||
| let compiled_arg = compile_imm env arg in | ||
| MSwitch(compiled_arg, | ||
| List.map (fun (lbl, body) -> | ||
| (Int32.of_int lbl, compile_anf_expr env body)) branches, | ||
| [MError(Runtime_errors.SwitchError, [compiled_arg])]) | ||
| | CIf(cond, thn, els) -> | ||
| MIf(compile_imm env cond, compile_anf_expr env thn, compile_anf_expr env els) | ||
| | CPrim1(p1, arg) -> | ||
| MPrim1(p1, compile_imm env arg) | ||
| | CPrim2(p2, arg1, arg2) -> | ||
| MPrim2(p2, compile_imm env arg1, compile_imm env arg2) | ||
| | CTuple(args) -> | ||
| MAllocate(MTuple (List.map (compile_imm env) args)) | ||
| | CString(s) -> | ||
| MAllocate(MString s) | ||
| | CGetTupleItem(idx, tup) -> | ||
| MTupleOp(MTupleGet(idx), compile_imm env tup) | ||
| | CSetTupleItem(idx, tup, value) -> | ||
| MTupleOp(MTupleSet(idx, compile_imm env value), compile_imm env tup) | ||
| | CLambda(args, body) -> | ||
| MAllocate(MClosure(compile_lambda env args body)) | ||
| | CApp(f, args) -> | ||
| (* TODO: Utilize MCallKnown *) | ||
| MCallIndirect(compile_imm env f, List.map (compile_imm env) args) | ||
| | CAppBuiltin(modname, name, args) -> | ||
| let builtin_idx = Int32.zero in | ||
| MCallKnown(builtin_idx, List.map (compile_imm env) args) | ||
| | CImmExpr(i) -> MImmediate(compile_imm env i) | ||
| and compile_anf_expr env a = | ||
| match a.anf_desc with | ||
| | AESeq(hd, tl) -> (compile_comp env hd)::(compile_anf_expr env tl) | ||
| | AELet(global, recflag, binds, body) -> | ||
| let get_loc idx (id, _) = | ||
| match global with | ||
| | Global -> MGlobalBind(Int32.of_int (next_global id)) | ||
| | Nonglobal -> MLocalBind(Int32.of_int (env.ce_stack_idx + idx)) in | ||
| let locations = List.mapi get_loc binds in | ||
| let new_env = BatList.fold_left2 (fun acc new_loc (id, _) -> | ||
| {acc with ce_binds=Ident.add id new_loc acc.ce_binds; ce_stack_idx=acc.ce_stack_idx + 1}) | ||
| env locations binds in | ||
| begin match recflag with | ||
| | Nonrecursive -> | ||
| BatList.fold_right2 (fun loc (_, rhs) acc -> | ||
| (MStore [loc, (compile_comp env rhs)]) :: acc) | ||
| locations binds (compile_anf_expr new_env body) | ||
| | Recursive -> | ||
| let binds = BatList.fold_left2 (fun acc loc (_, rhs) -> | ||
| (loc, (compile_comp new_env rhs)) :: acc) | ||
| [] locations binds in | ||
| MStore(List.rev binds) :: (compile_anf_expr new_env body) | ||
| end | ||
| | AEComp(c) -> [compile_comp env c] | ||
| let compile_worklist_elt ({body; env} : worklist_elt) = | ||
| match body with | ||
| | Anf body -> | ||
| compile_anf_expr env body | ||
| | Precompiled block -> block | ||
| let fold_left_pop f base = | ||
| let rec help acc = | ||
| if worklist_empty() then | ||
| acc | ||
| else | ||
| help (f acc (worklist_pop())) in | ||
| help base | ||
| let compile_remaining_worklist () = | ||
| let compile_one funcs ((({idx=index; arity; stack_size}) as cur) : worklist_elt) = | ||
| let body = compile_worklist_elt cur in | ||
| let func = { | ||
| index=Int32.of_int index; | ||
| arity=Int32.of_int arity; | ||
| body; | ||
| stack_size; | ||
| } in | ||
| func::funcs in | ||
| List.rev (fold_left_pop compile_one []) | ||
| let lift_imports env imports = | ||
| let process_shape = function | ||
| | GlobalShape -> MGlobalImport I32Type | ||
| | FunctionShape(inputs, outputs) -> | ||
| MFuncImport | ||
| ((BatList.init inputs (fun _ -> I32Type)), | ||
| (BatList.init outputs (fun _ -> I32Type))) | ||
| in | ||
| let import_idx = ref 0 in | ||
| let process_import (imports, setups, env) {imp_use_id; imp_desc; imp_shape} = | ||
| let glob = next_global imp_use_id in | ||
| let import_idx = begin | ||
| let i = !import_idx in | ||
| import_idx := i + 1; | ||
| i | ||
| end in | ||
| match imp_desc with | ||
| | GrainValue(mod_, name) -> | ||
| ({ | ||
| mimp_mod = Ident.create mod_; | ||
| mimp_name = Ident.create name; | ||
| mimp_type = MGlobalImport I32Type (*process_shape imp_shape*); | ||
| mimp_kind = MImportGrain; | ||
| mimp_setup = MCallGetter; | ||
| }::imports), | ||
| ([ | ||
| MStore([(MGlobalBind (Int32.of_int glob)), | ||
| MCallKnown((Int32.of_int import_idx), [])]); | ||
| ]::setups), | ||
| ({env with ce_binds=Ident.add imp_use_id (MGlobalBind(Int32.of_int glob)) env.ce_binds}) | ||
| | WasmFunction(mod_, name) -> | ||
| ({ | ||
| mimp_mod = Ident.create mod_; | ||
| mimp_name = Ident.create name; | ||
| mimp_type = process_shape imp_shape; | ||
| mimp_kind = MImportWasm; | ||
| mimp_setup = MWrap(Int32.zero); | ||
| }::imports), | ||
| (begin | ||
| match imp_shape with | ||
| | GlobalShape -> [] | ||
| | FunctionShape(inputs, outputs) -> | ||
| if outputs > 1 then | ||
| failwith "NYI: Multi-result wrapper" | ||
| else | ||
| [MStore([MGlobalBind(Int32.of_int glob), | ||
| MAllocate(MClosure (compile_wrapper env import_idx inputs))])] | ||
| end::setups), | ||
| ({env with ce_binds=Ident.add imp_use_id (MGlobalBind(Int32.of_int glob)) env.ce_binds}) | ||
| | JSFunction _ -> failwith "NYI: lift_imports JSFunction" | ||
| in | ||
| let imports, setups, env = List.fold_left process_import ([], [], env) imports in | ||
| let imports = List.rev imports in | ||
| let setups = List.flatten (List.rev setups) in | ||
| imports, setups, env | ||
| let transl_anf_program (anf_prog : Anftree.anf_program) : Mashtree.mash_program = | ||
| reset_lift(); | ||
| reset_global(); | ||
| worklist_reset(); | ||
| let imports, setups, env = lift_imports initial_compilation_env anf_prog.imports in | ||
| let main_body_stack_size = Anf_utils.anf_count_vars anf_prog.body in | ||
| let main_body = setups @ (compile_anf_expr env anf_prog.body) in | ||
| let exports = global_exports() in | ||
| let functions = compile_remaining_worklist() in | ||
| { | ||
| functions; | ||
| imports; | ||
| exports; | ||
| main_body; | ||
| main_body_stack_size; | ||
| num_globals=(!global_index); | ||
| signature=anf_prog.signature; | ||
| } | ||
| @@ -0,0 +1,3 @@ | ||
| open Grain_middle_end | ||
| val transl_anf_program : Anftree.anf_program -> Mashtree.mash_program |
| @@ -1,6 +0,0 @@ | ||
| let grain_root = ref @@ Sys.getenv_opt "GRAIN_ROOT" | ||
| let get_grain_root() = !grain_root | ||
| let set_grain_root root = grain_root := Some(root) |
| @@ -1,8 +0,0 @@ | ||
| (** Global configuration settings for Grain compiler runtime. *) | ||
| (** Gets the Grain root, if set. Default is GRAIN_ROOT environment variable (if set). | ||
| Can be configured by set_grain_root. *) | ||
| val get_grain_root : unit -> string option | ||
| (** Sets the Grain root. *) | ||
| val set_grain_root : string -> unit |
| @@ -1,193 +0,0 @@ | ||
| open Types | ||
| type tag = int | ||
| let tag (p : 'a program) : tag program = | ||
| let next = ref 0 in | ||
| let tag () = | ||
| next := !next + 1; | ||
| !next in | ||
| let rec helpE (e : 'a expr) : tag expr = | ||
| match e with | ||
| | EId(x, _) -> EId(x, tag()) | ||
| | ENumber(n, _) -> ENumber(n, tag()) | ||
| | EBool(b, _) -> EBool(b, tag()) | ||
| | EInclude(lib, body, _) -> EInclude(lib, helpE body, tag()) | ||
| | EEllipsis(_) -> EEllipsis(tag()) | ||
| | EPrim1(op, e, _) -> | ||
| let prim_tag = tag() in | ||
| EPrim1(op, helpE e, prim_tag) | ||
| | EPrim2(op, e1, e2, _) -> | ||
| let prim_tag = tag() in | ||
| EPrim2(op, helpE e1, helpE e2, prim_tag) | ||
| | ESeq(stmts, _) -> | ||
| let seq_tag = tag() in | ||
| ESeq(List.map helpE stmts, seq_tag) | ||
| | ELet(binds, body, _) -> | ||
| let let_tag = tag() in | ||
| ELet(List.map (fun (x, topt, b, _) -> let t = tag() in (x, topt, helpE b, t)) binds, helpE body, let_tag) | ||
| | ELetRec(binds, body, _) -> | ||
| let let_tag = tag() in | ||
| ELetRec(List.map (fun (x, topt, b, _) -> let t = tag() in (x, topt, helpE b, t)) binds, helpE body, let_tag) | ||
| | EIf(cond, thn, els, _) -> | ||
| let if_tag = tag() in | ||
| EIf(helpE cond, helpE thn, helpE els, if_tag) | ||
| | ETuple(vals, _) -> | ||
| let tuple_tag = tag() in | ||
| ETuple(List.map helpE vals, tuple_tag) | ||
| | EString(s, _) -> | ||
| let string_tag = tag() in | ||
| EString(s, string_tag) | ||
| | EGetItem(tup, idx, _) -> | ||
| let get_tag = tag() in | ||
| EGetItem(helpE tup, helpE idx, get_tag) | ||
| | ESetItem(tup, idx, rhs, _) -> | ||
| let get_tag = tag() in | ||
| ESetItem(helpE tup, helpE idx, helpE rhs, get_tag) | ||
| | EGetItemExact(tup, idx, _) -> | ||
| let get_tag = tag() in | ||
| EGetItemExact(helpE tup, idx, get_tag) | ||
| | ESetItemExact(tup, idx, rhs, _) -> | ||
| let get_tag = tag() in | ||
| ESetItemExact(helpE tup, idx, helpE rhs, get_tag) | ||
| | EApp(func, args, _) -> | ||
| let app_tag = tag() in | ||
| EApp(helpE func, List.map helpE args, app_tag) | ||
| | ELambda(args, body, _) -> | ||
| let lam_tag = tag() in | ||
| ELambda(List.map (fun (a, _) -> (a, tag())) args, helpE body, lam_tag) | ||
| and helpP p = helpE p | ||
| in helpP p | ||
| let rec untag : 'a. 'a program -> unit program = fun p -> | ||
| let rec helpE e = | ||
| match e with | ||
| | EId(x, _) -> EId(x, ()) | ||
| | ENumber(n, _) -> ENumber(n, ()) | ||
| | EBool(b, _) -> EBool(b, ()) | ||
| | EInclude(lib, body, _) -> EInclude(lib, helpE body, ()) | ||
| | EEllipsis(_) -> EEllipsis(()) | ||
| | EPrim1(op, e, _) -> | ||
| EPrim1(op, helpE e, ()) | ||
| | EPrim2(op, e1, e2, _) -> | ||
| EPrim2(op, helpE e1, helpE e2, ()) | ||
| | ESeq(stmts, _) -> | ||
| ESeq(List.map helpE stmts, ()) | ||
| | ELet(binds, body, _) -> | ||
| ELet(List.map(fun (x, topt, b, _) -> (x, topt, helpE b, ())) binds, helpE body, ()) | ||
| | ELetRec(binds, body, _) -> | ||
| ELetRec(List.map(fun (x, topt, b, _) -> (x, topt, helpE b, ())) binds, helpE body, ()) | ||
| | EIf(cond, thn, els, _) -> | ||
| EIf(helpE cond, helpE thn, helpE els, ()) | ||
| | ETuple(vals, _) -> | ||
| ETuple(List.map helpE vals, ()) | ||
| | EString(s, _) -> | ||
| EString(s, ()) | ||
| | EGetItem(tup, idx, _) -> | ||
| EGetItem(helpE tup, helpE idx, ()) | ||
| | ESetItem(tup, idx, rhs, _) -> | ||
| ESetItem(helpE tup, helpE idx, helpE rhs, ()) | ||
| | EGetItemExact(tup, idx, _) -> | ||
| EGetItemExact(helpE tup, idx, ()) | ||
| | ESetItemExact(tup, idx, rhs, _) -> | ||
| ESetItemExact(helpE tup, idx, helpE rhs, ()) | ||
| | EApp(name, args, _) -> | ||
| EApp(helpE name, List.map helpE args, ()) | ||
| | ELambda(args, body, _) -> | ||
| ELambda(List.map (fun (x, _) -> (x, ())) args, helpE body, ()) | ||
| and helpP p = helpE p | ||
| in helpP p | ||
| let atag (p : 'a aprogram) : tag aprogram = | ||
| let next = ref 0 in | ||
| let tag () = | ||
| next := !next + 1; | ||
| !next in | ||
| let rec helpA (e : 'a aexpr) : tag aexpr = | ||
| match e with | ||
| | ASeq(fst, snd, _) -> | ||
| let seq_tag = tag() in | ||
| ASeq(helpC fst, helpA snd, seq_tag) | ||
| | ALet(x, c, b, _) -> | ||
| let let_tag = tag() in | ||
| ALet(x, helpC c, helpA b, let_tag) | ||
| | ALetRec(xcs, b, _) -> | ||
| let let_tag = tag() in | ||
| ALetRec(List.map (fun (x, c) -> (x, helpC c)) xcs, helpA b, let_tag) | ||
| | ACExpr c -> ACExpr (helpC c) | ||
| and helpC (c : 'a cexpr) : tag cexpr = | ||
| match c with | ||
| | CPrim1(op, e, _) -> | ||
| let prim_tag = tag() in | ||
| CPrim1(op, helpI e, prim_tag) | ||
| | CPrim2(op, e1, e2, _) -> | ||
| let prim_tag = tag() in | ||
| CPrim2(op, helpI e1, helpI e2, prim_tag) | ||
| | CIf(cond, thn, els, _) -> | ||
| let if_tag = tag() in | ||
| CIf(helpI cond, helpA thn, helpA els, if_tag) | ||
| | CTuple(vals, _) -> | ||
| let tuple_tag = tag() in | ||
| CTuple(List.map helpI vals, tuple_tag) | ||
| | CString(s, _) -> | ||
| let string_tag = tag() in | ||
| CString(s, string_tag) | ||
| | CGetItem(tup, idx, _) -> | ||
| let get_tag = tag() in | ||
| CGetItem(helpI tup, helpI idx, get_tag) | ||
| | CSetItem(tup, idx, rhs, _) -> | ||
| let get_tag = tag() in | ||
| CSetItem(helpI tup, helpI idx, helpI rhs, get_tag) | ||
| | CApp(name, args, _) -> | ||
| let app_tag = tag() in | ||
| CApp(helpI name, List.map helpI args, app_tag) | ||
| | CLambda(args, body, _) -> | ||
| let lam_tag = tag() in | ||
| CLambda(args, helpA body, lam_tag) | ||
| | CImmExpr i -> CImmExpr (helpI i) | ||
| and helpI (i : 'a immexpr) : tag immexpr = | ||
| match i with | ||
| | ImmId(x, _) -> ImmId(x, tag()) | ||
| | ImmNum(n, _) -> ImmNum(n, tag()) | ||
| | ImmBool(b, _) -> ImmBool(b, tag()) | ||
| and helpP p = helpA p | ||
| in helpP p | ||
| let auntag (p : 'a aprogram) : unit aprogram = | ||
| let rec helpA (e : 'a aexpr) : unit aexpr = | ||
| match e with | ||
| | ASeq(fst, snd, _) -> | ||
| ASeq(helpC fst, helpA snd, ()) | ||
| | ALet(x, c, b, _) -> | ||
| ALet(x, helpC c, helpA b, ()) | ||
| | ALetRec(xcs, b, _) -> | ||
| ALetRec(List.map (fun (x, c) -> (x, helpC c)) xcs, helpA b, ()) | ||
| | ACExpr c -> ACExpr (helpC c) | ||
| and helpC (c : 'a cexpr) : unit cexpr = | ||
| match c with | ||
| | CPrim1(op, e, _) -> | ||
| CPrim1(op, helpI e, ()) | ||
| | CPrim2(op, e1, e2, _) -> | ||
| CPrim2(op, helpI e1, helpI e2, ()) | ||
| | CIf(cond, thn, els, _) -> | ||
| CIf(helpI cond, helpA thn, helpA els, ()) | ||
| | CTuple(vals, _) -> | ||
| CTuple(List.map helpI vals, ()) | ||
| | CString(s, _) -> | ||
| CString(s, ()) | ||
| | CGetItem(tup, idx, _) -> | ||
| CGetItem(helpI tup, helpI idx, ()) | ||
| | CSetItem(tup, idx, rhs, _) -> | ||
| CSetItem(helpI tup, helpI idx, helpI rhs, ()) | ||
| | CApp(name, args, _) -> | ||
| CApp(helpI name, List.map helpI args, ()) | ||
| | CLambda(args, body, _) -> | ||
| CLambda(args, helpA body, ()) | ||
| | CImmExpr i -> CImmExpr (helpI i) | ||
| and helpI (i : 'a immexpr) : unit immexpr = | ||
| match i with | ||
| | ImmId(x, _) -> ImmId(x, ()) | ||
| | ImmNum(n, _) -> ImmNum(n, ()) | ||
| | ImmBool(b, _) -> ImmBool(b, ()) | ||
| and helpP p = helpA p | ||
| in helpP p |
| @@ -1,10 +0,0 @@ | ||
| open Types | ||
| type tag = int | ||
| val tag : 'a program -> tag program | ||
| val untag : 'a program -> unit program | ||
| val atag : 'a aprogram -> tag aprogram | ||
| val auntag : 'a aprogram -> unit aprogram |
| @@ -1,33 +1,64 @@ | ||
| # Standard library for list functionality | ||
| let rec link = (lambda first, rest: (first, rest)), | ||
| length = (lambda l: if l == false: 0 else: 1 + length(l[1])), | ||
| sum = (lambda l: if l == false: 0 else: l[0] + sum(l[1])), | ||
| reverse = (lambda l: | ||
| let rec help = (lambda _l, acc: | ||
| if _l == false: | ||
| acc | ||
| else: | ||
| help(_l[1], link(_l[0], acc))) in | ||
| help(l, false)), | ||
| append = (lambda l1, l2: | ||
| if l1 == false: l2 | ||
| else: link(l1[0], append(l1[1], l2))), | ||
| contains = (lambda x, l: | ||
| if l == false: false | ||
| else: | ||
| if equal(x, l[0]): | ||
| true | ||
| else: | ||
| contains(x, l[1])), | ||
| fold_left = (lambda f, b, l: | ||
| if l == false: b | ||
| else: | ||
| fold_left(f, f(b, l[0]), l[1])), | ||
| fold_right = (lambda f, b, l: | ||
| if l == false: b | ||
| else: | ||
| f(l[0], fold_right(f, b, l[1]))), | ||
| map = (lambda f, l: | ||
| fold_right((lambda hd, tl: link(f(hd), tl)), false, l)) in | ||
| ... | ||
| data List<a> = | ||
| | Empty | ||
| | Cons(a, List<a>); | ||
| let rec length = (lst) => { | ||
| match (lst) { | ||
| | Empty => 0 | ||
| | Cons(hd, tl) => 1 + length(tl) | ||
| } | ||
| }; | ||
| let rec sum = (lst) => { | ||
| match (lst) { | ||
| | Empty => 0 | ||
| | Cons(hd, tl) => hd + sum(tl) | ||
| } | ||
| }; | ||
| let reverse = (lst) => { | ||
| let rec help = (l, acc) => { | ||
| match (l) { | ||
| | Empty => acc | ||
| | Cons(hd, tl) => help(tl, Cons(hd, acc)) | ||
| } | ||
| }; | ||
| help(lst, Empty) | ||
| }; | ||
| let rec append = (l1, l2) => { | ||
| match (l1) { | ||
| | Empty => l2 | ||
| | Cons(hd, tl) => Cons(hd, append(l1, l2)) | ||
| } | ||
| }; | ||
| let rec contains = (e, l) => { | ||
| match (l) { | ||
| | Empty => false | ||
| | Cons(hd, tl) => (hd == e) or contains(e, tl) | ||
| } | ||
| }; | ||
| let rec fold_left = (f, b, l) => { | ||
| match (l) { | ||
| | Empty => b | ||
| | Cons(hd, tl) => fold_left(f, f(b, hd), tl) | ||
| } | ||
| }; | ||
| let rec fold_right = (f, b, l) => { | ||
| match (l) { | ||
| | Empty => b | ||
| | Cons(hd, tl) => f(hd, fold_right(f, b, tl)) | ||
| } | ||
| }; | ||
| let rec map = (f, l) => { | ||
| match (l) { | ||
| | Empty => Empty | ||
| | Cons(hd, tl) => Cons(f(hd), map(f, tl)) | ||
| } | ||
| }; |
| @@ -0,0 +1,14 @@ | ||
| # Prints the given value to the console. | ||
| foreign wasm grainBuiltins print : a -> a; | ||
| # Checks the given items for structural equality. | ||
| foreign wasm grainBuiltins equal : (a, a) -> Bool; | ||
| # Converts the given value to a string | ||
| foreign wasm grainBuiltins toString : a -> String; | ||
| # TODO: These should be in a separate WASM module | ||
| foreign wasm grainBuiltins stringAppend : (String, String) -> String; | ||
| foreign wasm grainBuiltins stringSlice : (String, Number, Number) -> String; |
| @@ -1,22 +0,0 @@ | ||
| Anf | ||
| Ast_utils | ||
| Codegen | ||
| Expr | ||
| Compile | ||
| Errors | ||
| Lexer | ||
| Parser | ||
| Types | ||
| Intermediate | ||
| Ir_anf | ||
| Optimize | ||
| Pretty | ||
| Resolve_scope | ||
| Runner | ||
| Simple_expr | ||
| Grain_stdlib | ||
| Type_check | ||
| Utils | ||
| Value_tags | ||
| Wasm_runner | ||
| Well_formedness |
| @@ -1,112 +1,56 @@ | ||
| open Lexing | ||
| open Printf | ||
| open Types | ||
| type grain_library = sourcespan program -> sourcespan program | ||
| let parse name lexbuf = | ||
| let open Lexing in | ||
| let string_of_position p = | ||
| sprintf "%s:line %d, col %d" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) in | ||
| try | ||
| lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = name }; | ||
| Parser.program Lexer.token lexbuf | ||
| with | ||
| | Failure x when String.equal x "lexing: empty token" -> | ||
| failwith (sprintf "lexical error at %s" | ||
| (string_of_position lexbuf.lex_curr_p)) | ||
| | Parsing.Parse_error -> | ||
| begin | ||
| let curr = lexbuf.Lexing.lex_curr_p in | ||
| let line = curr.Lexing.pos_lnum in | ||
| let cnum = curr.Lexing.pos_cnum - curr.Lexing.pos_bol in | ||
| let tok = Lexing.lexeme lexbuf in | ||
| failwith (sprintf "Parse error at line %d, col %d: token %s" | ||
| line cnum tok) | ||
| end | ||
| (** Converts an library AST's ellipsis into a 'hole' to be filled | ||
| by the returned function. The idea is that a loaded program | ||
| can be applied to the returned function to wrap it with the | ||
| given standard library *) | ||
| let convert_to_continuation ast : grain_library = | ||
| let rec help ast k = | ||
| match ast with | ||
| | ELet(binds, body, a) -> | ||
| help body (fun b -> k @@ ELet(binds, b, a)) | ||
| | ELetRec(binds, body, a) -> | ||
| help body (fun b -> k @@ ELetRec(binds, b, a)) | ||
| | EEllipsis(_) -> k | ||
| | _ -> failwith "Invalid library AST passed well-formedness" in | ||
| help ast (fun x -> x) | ||
| let load_library initial_env library = | ||
| let filename = library in | ||
| let inchan = open_in filename in | ||
| let lexbuf = Lexing.from_channel inchan in | ||
| let lib = parse filename lexbuf in | ||
| let errors = Well_formedness.well_formed lib true initial_env in | ||
| match errors with | ||
| | [] -> Right(convert_to_continuation lib) | ||
| | _ -> Left(errors) | ||
| let compose f g x = f (g x) | ||
| (** Lifts the given list of loaded libraries into a single either result *) | ||
| let lift_loaded_libraries (libs : (exn list, grain_library) either list) : (exn list, grain_library) either = | ||
| List.fold_left (fun acc cur -> | ||
| match cur with | ||
| | Right(cont) -> | ||
| (match acc with | ||
| | Right(rest_cont) -> Right(compose cont rest_cont) | ||
| | Left(_) -> acc) | ||
| | Left(errs) -> | ||
| (match acc with | ||
| | Right(_) -> cur | ||
| | Left(rest_errs) -> Left(errs @ rest_errs))) (Right(fun x -> x)) libs | ||
| (** Returns the path to the given library within the given list | ||
| of include directories, if it exists. *) | ||
| let library_path (include_dirs : string list) (lib : string) = | ||
| let lib_path dir = | ||
| let open BatPathGen.OfString in | ||
| let open Infix in | ||
| to_string @@ (of_string dir) /: (lib ^ ".grlib") in | ||
| List.map lib_path include_dirs | ||
| |> List.find_opt Sys.file_exists | ||
| let rec extract_includes (include_dirs : string list) (prog : sourcespan program) = | ||
| match prog with | ||
| | EInclude(lib, body, loc) -> | ||
| let rest = extract_includes include_dirs body in | ||
| let lib_file = library_path include_dirs lib in | ||
| begin | ||
| match (rest, lib_file) with | ||
| | Left(errs), None -> Left((IncludeNotFound(lib, loc))::errs) | ||
| | Left(_), _ -> rest | ||
| | Right(_), None -> Left([IncludeNotFound(lib, loc)]) | ||
| | Right((libs, body)), Some(lib_path) -> Right((lib_path::libs), body) | ||
| end | ||
| | _ -> Right([], prog) | ||
| open Grain_parsing | ||
| (*type grain_library = sourcespan program -> sourcespan program*) | ||
| let stdlib_directory() : string option = | ||
| let open BatPathGen.OfString in | ||
| let open Infix in | ||
| Config.get_grain_root() | ||
| !Grain_utils.Config.grain_root | ||
| |> Option.map (fun root -> | ||
| to_string @@ (of_string root) /: "lib" /: "grain" /: "stdlib") | ||
| let include_dirs() = | ||
| (Option.map_default (fun x -> [x]) [] (stdlib_directory())) @ !Grain_utils.Config.include_dirs | ||
| let load_libraries (initial_env : sourcespan envt) (include_dirs : string list) (prog : sourcespan program) = | ||
| let extracted = extract_includes include_dirs prog in | ||
| match extracted with | ||
| | Left(errs) -> Left(errs) | ||
| | Right((libs, body)) -> | ||
| let loaded = List.map (load_library initial_env) libs | ||
| |> lift_loaded_libraries in | ||
| match loaded with | ||
| | Left(errs) -> Left(errs) | ||
| | Right(add_lib) -> Right(add_lib body) | ||
| let locate_module (lib : string) = | ||
| let lib_path dir = | ||
| let open BatPathGen.OfString in | ||
| let open Infix in | ||
| to_string @@ (of_string dir) /: (lib ^ ".grlib") in | ||
| List.map lib_path (include_dirs()) | ||
| |> List.find_opt Sys.file_exists | ||
| let load_module import : Parsetree.parsed_program = | ||
| let open Parsetree in | ||
| let open Identifier in | ||
| let id = match import.ptop_desc with | ||
| | PTopImport({pimp_mod}) -> pimp_mod | ||
| | _ -> failwith "Impossible" in | ||
| let name = match id with | ||
| | {txt=IdentName n} -> n | ||
| | _ -> failwith "Bad module name" in | ||
| match locate_module name with | ||
| (* Close enough *) | ||
| | None -> raise (Grain_typed.Typemod.Error(Location.dummy_loc, Grain_typed.Env.empty, Grain_typed.Typemod.Interface_not_compiled(name))) | ||
| | Some(file) -> | ||
| let inchan = open_in file in | ||
| let lexbuf = Lexing.from_channel inchan in | ||
| let loaded = Driver.parse ~name:name lexbuf in | ||
| (* Not going to bother with a worklist since we're getting rid of this soon anyhow *) | ||
| if List.exists (function | {Parsetree.ptop_desc=Parsetree.PTopImport _} -> true | _ -> false) (loaded.statements) then | ||
| eprintf "WARNING: Library '%s' appears to import another library. This is currently unsupported!\n" name; | ||
| if loaded.body.Parsetree.pexp_desc <> Parsetree.PExpNull then | ||
| eprintf "WARNING: Library '%s' appears to have a non-empty body. This is currently unsupported!\n" name; | ||
| loaded | ||
| let load_libraries (prog : Parsetree.parsed_program) = | ||
| (* TODO: Ditch this altogether and use the facilities in 'typed' for separate compilation *) | ||
| (* Currently hacked together. *) | ||
| let open Parsetree in | ||
| let imports, others = List.partition (function | {ptop_desc=PTopImport _} -> true | _ -> false) prog.statements in | ||
| let loaded = List.map load_module imports in | ||
| let new_stmts = List.fold_left (fun acc cur -> cur.statements @ acc) others loaded in | ||
| {prog with statements=new_stmts} |
| @@ -1,130 +0,0 @@ | ||
| open Compile | ||
| open Runner | ||
| open Printf | ||
| open Lexing | ||
| open Types | ||
| open Filename | ||
| open Cmdliner | ||
| let language_name = "Grain" | ||
| (** `remove_extension` new enough that we should just use this *) | ||
| let safe_remove_extension name = | ||
| try | ||
| Filename.chop_extension name | ||
| with | ||
| | Invalid_argument _ -> name | ||
| let default_output_filename name = safe_remove_extension name ^ ".wasm" | ||
| let default_assembly_filename name = safe_remove_extension name ^ ".wast" | ||
| let compile_file debug cdebug unsound_opts name outfile no_stdlib extra_includes = | ||
| let input_file = open_in name in | ||
| let runnable = true in | ||
| let opts = {Compile.default_compile_options with | ||
| sound_optimizations=(not unsound_opts); | ||
| optimizations_enabled=(not debug); | ||
| verbose=cdebug; | ||
| use_stdlib=(not no_stdlib); | ||
| include_dirs=extra_includes | ||
| } in | ||
| let output = if runnable then | ||
| compile_file_to_binary name opts debug input_file (Option.default (default_output_filename name) outfile) | ||
| else | ||
| match outfile with | ||
| | Some(out) -> | ||
| compile_file_to_assembly name opts input_file out | ||
| | None -> | ||
| match compile_file_to_string name opts input_file with | ||
| | Left errs -> | ||
| Left(ExtString.String.join "\n" (print_errors errs)) | ||
| | Right program -> (printf "%s\n" program; Right(program)) in | ||
| match output with | ||
| | Left (err) -> | ||
| `Error (false, err) | ||
| | Right prog -> `Ok () | ||
| ;; | ||
| (** Converter which checks that the given output filename is valid *) | ||
| let output_file_conv = | ||
| let parse s = | ||
| let s_dir = dirname s in | ||
| match Sys.file_exists s_dir with | ||
| | true -> if Sys.is_directory s_dir then `Ok s else `Error (sprintf "`%s' is not a directory" s_dir) | ||
| | false -> `Error (sprintf "no `%s' directory" s_dir) in | ||
| parse, Format.pp_print_string | ||
| let runnable = | ||
| let doc = "Emit runnable program (deprecated)" in | ||
| Arg.(value & flag & info ["r"; "runnable"] ~doc) | ||
| let debug = | ||
| let doc = "Compile with debug information" in | ||
| Arg.(value & flag & info ["g"] ~doc) | ||
| ;; | ||
| let compiler_debug = | ||
| let doc = "Print internal debug messages" in | ||
| Arg.(value & flag & info ["cdebug"] ~doc) | ||
| ;; | ||
| let unsound_opts = | ||
| let doc = "Compile with optimizations which may remove errors" in | ||
| Arg.(value & flag & info ["Ounsound"; "big-kid"] ~doc) | ||
| ;; | ||
| let no_stdlib = | ||
| let doc = sprintf "Disable the %s standard library." language_name in | ||
| Arg.(value & flag & info ["no-stdlib"] ~doc) | ||
| ;; | ||
| let input_filename = | ||
| let doc = sprintf "%s source file to compile" language_name in | ||
| let docv = "FILE" in | ||
| Arg.(required & pos ~rev:true 0 (some non_dir_file) None & info [] ~docv ~doc) | ||
| ;; | ||
| let output_filename = | ||
| let doc = sprintf "Output filename" in | ||
| let docv = "FILE" in | ||
| Arg.(value & opt (some output_file_conv) None & info ["o"] ~docv ~doc) | ||
| ;; | ||
| let extra_includes = | ||
| let doc = "Extra library include directories" in | ||
| let docv = "DIR" in | ||
| Arg.(value & opt (list dir) [] & info ["I"] ~docv ~doc) | ||
| ;; | ||
| let help_flag = | ||
| let doc = "Show this help message" in | ||
| Arg.(value & flag & info ["h"] ~doc) | ||
| let help_cmd = | ||
| Term.(ret (const (fun _ -> `Help (`Pager, None)) $ help_flag)), | ||
| Term.info "help" | ||
| let cmd = | ||
| let doc = sprintf "Compile %s programs" language_name in | ||
| Term.(ret (const compile_file $ debug $ compiler_debug $ unsound_opts $ input_filename $ output_filename $ no_stdlib $ extra_includes)), | ||
| Term.info (Sys.argv.(0)) ~version:"1.0.0" ~doc | ||
| let () = | ||
| let open BatPathGen.OfString in | ||
| match Config.get_grain_root() with | ||
| (* Prefer environment variable over inferred path *) | ||
| | Some(_) -> () | ||
| | None -> | ||
| begin | ||
| let grainc_dir = parent @@ of_string Sys.argv.(0) in | ||
| let as_abs = | ||
| if is_absolute grainc_dir then | ||
| grainc_dir | ||
| else | ||
| normalize @@ concat (of_string @@ Unix.getcwd()) grainc_dir in | ||
| Config.set_grain_root @@ to_string @@ parent as_abs | ||
| end; | ||
| match Term.eval cmd with | ||
| | `Error _ -> exit 1 | ||
| | _ -> exit 0 |
| @@ -1,48 +0,0 @@ | ||
| open Value_tags | ||
| (* NOTE: Currently unused *) | ||
| (* Based loosely on Tiger book's IR *) | ||
| type ir_binop = | ||
| | PLUS | ||
| | MINUS | ||
| | MUL | ||
| | DIV | ||
| | AND | ||
| | OR | ||
| type ir_label = string | ||
| type ir_relop = | ||
| | EQ | ||
| | NE | ||
| | LT | ||
| | GT | ||
| | LE | ||
| | GE | ||
| type 'a ir_imm = | ||
| | IConst of int * 'a | ||
| | IName of string * 'a | ||
| | ITemp of string * 'a | ||
| | ILabelImm of string * 'a | ||
| and 'a ir_arg = | ||
| | IImm of 'a ir_imm * 'a | ||
| | IBinop of ir_binop * 'a ir_arg * 'a ir_arg * 'a | ||
| | IMem of 'a ir_imm * int * 'a (* loc, offset in words *) | ||
| | ICall of 'a ir_arg * 'a ir_arg list * 'a | ||
| | IArgSeq of 'a ir_stmt * 'a ir_arg * 'a | ||
| | IAlloc of int * 'a | ||
| | ITagCheck of 'a ir_arg * 'a | ||
| | ITag of 'a ir_arg * tag_type * 'a | ||
| | IUntag of 'a ir_arg * tag_type * 'a | ||
| and 'a ir_stmt = | ||
| | IMove of 'a ir_arg * 'a ir_arg * 'a | ||
| | IExp of 'a ir_arg * 'a | ||
| | IJump of 'a ir_arg * ir_label list * 'a | ||
| | ICJump of ir_relop * 'a ir_arg * 'a ir_arg * ir_label * ir_label * 'a | ||
| | IStmtSeq of 'a ir_stmt * 'a ir_stmt * 'a | ||
| | ILabel of ir_label * 'a | ||
| | ITagAssert of 'a ir_arg * 'a | ||
| @@ -1,47 +0,0 @@ | ||
| open Graph | ||
| open Types | ||
| open Anf | ||
| open Intermediate | ||
| module CFGNode = struct | ||
| type t = unit ir_stmt list | ||
| let compare = compare | ||
| let hash = Hashtbl.hash | ||
| let equal = (=) | ||
| let default = [] | ||
| end | ||
| module CFG = Imperative.Digraph.Abstract(CFGNode) | ||
| open CFG | ||
| type ir_frame = { | ||
| base_pointer : unit ir_imm | ||
| } | ||
| type ir_env = { | ||
| stack_index : int; | ||
| bindings: (string * unit ir_arg) list; | ||
| frame: ir_frame; | ||
| } | ||
| let rec add_aexpr_to_cfg graph aexpr env = | ||
| match aexpr with | ||
| | ALet(name, expr, body, _) -> | ||
| let (expr_start, expr_end) = add_cexpr_to_cfg graph expr env in | ||
| let new_env = { | ||
| env with | ||
| bindings = (name, IMem(env.frame.base_pointer, env.stack_index, ()))::env.bindings; | ||
| stack_index = env.stack_index + 1 | ||
| } in | ||
| (expr_start, V.create []) | ||
| | _ -> (V.create [], V.create []) | ||
| and add_cexpr_to_cfg graph cexpr env = | ||
| match cexpr with | ||
| | CIf(_, _, _, _) -> (V.create [], V.create []) | ||
| | _ -> (V.create [], V.create []) | ||
| and add_immexpr_to_cfg graph immexpr env : CFG.vertex * CFG.vertex = | ||
| match immexpr with | ||
| | ImmNum(_, _) -> (V.create [], V.create []) | ||
| | _ -> (V.create [], V.create []) |
| @@ -1,20 +1,14 @@ | ||
| (jbuild_version 1) | ||
| (ocamllex (lexer)) | ||
| (ocamlyacc (parser)) | ||
| (library | ||
| ((name grain) | ||
| (public_name grain) | ||
| (libraries (oUnit extlib batteries cmdliner ocamlgraph wasm stdint)))) | ||
| (executable | ||
| ((name grainc) | ||
| (public_name grainc) | ||
| (package grain) | ||
| (libraries (grain)))) | ||
| ;; Note: 'dyp' is provided by the 'dypgen' OPAM package | ||
| (libraries (oUnit extlib batteries cmdliner ocamlgraph wasm stdint grain_parsing grain_utils grain_typed grain_middle_end grain_codegen ppx_deriving ppx_sexp_conv sexplib)) | ||
| (preprocess (pps (ppx_sexp_conv ppx_deriving))))) | ||
| (install | ||
| ((section lib) | ||
| (files ((grain-stdlib/lists.grlib as stdlib/lists.grlib))) | ||
| (files ((grain-stdlib/lists.grlib as stdlib/lists.grlib) | ||
| (grain-stdlib/pervasives.grlib as stdlib/pervasives.grlib))) | ||
| (package grain))) |