From 092d5f2f33ff4ae10d4ad88653205b7fa3190d89 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Fri, 30 Aug 2024 00:35:31 +0300 Subject: [PATCH] WIP on more dune Signed-off-by: Kakadu --- dune-project | 7 +++ runtime/dune | 7 +++ runtime32/Makefile | 7 ++- runtime32/dune | 7 +++ src/Driver.ml | 5 ++- src/Options.ml | 5 +++ src/X86_32.ml | 103 +++++++++++++++++++++++---------------------- src/X86_64.ml | 7 +-- stdlib/Makefile | 20 +++++---- stdlib/amd64/dune | 15 +++++++ stdlib/x32/dune | 38 +++++++++++++++++ tutorial/dune | 19 +++++++++ 12 files changed, 174 insertions(+), 66 deletions(-) create mode 100644 runtime/dune create mode 100644 runtime32/dune create mode 100644 stdlib/amd64/dune create mode 100644 stdlib/x32/dune create mode 100644 tutorial/dune diff --git a/dune-project b/dune-project index 31718a853..c45c2d060 100644 --- a/dune-project +++ b/dune-project @@ -1,3 +1,10 @@ (lang dune 3.3) (cram enable) + +(generate_opam_files true) + +(package + (name Lama) + (synopsis "TODO") + (depends posix-uname)) diff --git a/runtime/dune b/runtime/dune new file mode 100644 index 000000000..181031f59 --- /dev/null +++ b/runtime/dune @@ -0,0 +1,7 @@ +(rule + (target runtime.a) + (mode + (promote (until-clean))) + (deps Makefile gc.c gc.h runtime_common.h runtime.c runtime.h printf.S) + (action + (run make))) diff --git a/runtime32/Makefile b/runtime32/Makefile index a82daa3f0..68c5ea8cf 100644 --- a/runtime32/Makefile +++ b/runtime32/Makefile @@ -1,6 +1,9 @@ +RUNTIME=runtime32.a -all: gc_runtime.o runtime.o - ar rc runtime.a gc_runtime.o runtime.o +.DEFAULT := $(RUNTIME) + +$(RUNTIME): gc_runtime.o runtime.o + ar rc $@ gc_runtime.o runtime.o gc_runtime.o: gc_runtime.s $(CC) -g -fstack-protector-all -m32 -c gc_runtime.s diff --git a/runtime32/dune b/runtime32/dune new file mode 100644 index 000000000..27a6cb55c --- /dev/null +++ b/runtime32/dune @@ -0,0 +1,7 @@ +(rule + (target runtime32.a) + (mode + (promote (until-clean))) + (deps Makefile gc_runtime.s runtime.c runtime.h) + (action + (run make))) diff --git a/src/Driver.ml b/src/Driver.ml index 581a76383..c50471552 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -12,7 +12,10 @@ let[@ocaml.warning "-32"] main = cmd#dump_AST (snd prog); cmd#dump_source (snd prog); match cmd#get_mode with - | `Default | `Compile -> ignore @@ X86_64.build cmd prog + | `Default | `Compile -> ( + match cmd#march with + | `X86_32 -> ignore @@ X86_32.build cmd prog + | `AMD64 -> ignore @@ X86_64.build cmd prog) | `BC -> SM.ByteCode.compile cmd (SM.compile cmd prog) | _ -> let rec read acc = diff --git a/src/Options.ml b/src/Options.ml index f56dded90..297149d0a 100644 --- a/src/Options.ml +++ b/src/Options.ml @@ -43,6 +43,7 @@ class options args = val i = ref 1 val infile = ref (None : string option) val outfile = ref (None : string option) + val march = ref `AMD64 val runtime_path = runtime_path_ val paths = ref [ runtime_path_ ] val mode = ref (`Default : [ `Default | `Eval | `SM | `Compile | `BC ]) @@ -79,6 +80,8 @@ class options args = raise (Commandline_error "Path expected after '-I' specifier") | Some path -> self#add_include_path path) + | "-march=amd64" -> march := `AMD64 + | "-march=x86" -> march := `X86_32 | "-s" -> self#set_mode `SM | "-b" -> self#set_mode `BC | "-i" -> self#set_mode `Eval @@ -139,6 +142,8 @@ class options args = Some args.(j)) else None + method march : [ `AMD64 | `X86_32 ] = !march + method get_debug = "" method get_mode = !mode method get_output_option = diff --git a/src/X86_32.ml b/src/X86_32.ml index cf1ea17a8..10f778dde 100644 --- a/src/X86_32.ml +++ b/src/X86_32.ml @@ -1,7 +1,7 @@ open GT open Language open SM - + (* X86 codegeneration interface *) (* The registers: *) @@ -66,11 +66,11 @@ let stack_offset i = if i >= 0 then (i+1) * word_size else 8 + (-i-1) * word_size - + let show instr = let rec opnd = function | R i -> regs.(i) - | C -> "4(%ebp)" + | C -> "4(%ebp)" | S i -> if i >= 0 then Printf.sprintf "-%d(%%ebp)" (stack_offset i) else Printf.sprintf "%d(%%ebp)" (stack_offset i) @@ -134,12 +134,12 @@ let compile cmd env imports code = | ">" -> "g" | _ -> failwith "unknown operator" in - let box n = (n lsl 1) lor 1 in + let box n = (n lsl 1) lor 1 in let rec compile' env scode = let on_stack = function S _ -> true | _ -> false in let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)] in let callc env n tail = - let tail = tail && env#nargs = n in + let tail = tail && env#nargs = n in if tail then ( let rec push_args env acc = function @@ -178,13 +178,13 @@ let compile cmd env imports code = then [Mov (closure, edx); Mov (edx, eax); CallI eax] else [Mov (closure, edx); CallI closure] in - env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) + env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) in let y, env = env#allocate in env, code @ [Mov (eax, y)] ) in let call env f n tail = - let tail = tail && env#nargs = n && f.[0] <> '.' in + let tail = tail && env#nargs = n && f.[0] <> '.' in let f = match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f in @@ -204,7 +204,7 @@ let compile cmd env imports code = else ( let pushr, popr = List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n) - in + in let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in let env, code = let rec push_args env acc = function @@ -220,7 +220,7 @@ let compile cmd env imports code = | "Bsta" -> pushs | _ -> List.rev pushs in - env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) + env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) in let y, env = env#allocate in env, code @ [Mov (eax, y)] ) @@ -242,26 +242,26 @@ let compile cmd env imports code = | PUBLIC name -> env#register_public name, [] | EXTERN name -> env#register_extern name, [] | IMPORT name -> env, [] - + | CLOSURE (name, closure) -> let pushr, popr = List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0) in - let closure_len = List.length closure in + let closure_len = List.length closure in let push_closure = List.map (fun d -> Push (env#loc d)) @@ List.rev closure in - let s, env = env#allocate in + let s, env = env#allocate in (env, pushr @ push_closure @ [Push (M ("$" ^ name)); Push (L (box closure_len)); Call "Bclosure"; - Binop ("+", L (word_size * (closure_len + 2)), esp); + Binop ("+", L (word_size * (closure_len + 2)), esp); Mov (eax, s)] @ List.rev popr @ env#reload_closure) - + | CONST n -> let s, env' = env#allocate in (env', [Mov (L (box n), s)]) @@ -276,7 +276,7 @@ let compile cmd env imports code = let s, env' = (env #variable x)#allocate in let s', env''= env'#allocate in env'', - [Lea (env'#loc x, eax); Mov (eax, s); Mov (eax, s')] + [Lea (env'#loc x, eax); Mov (eax, s); Mov (eax, s')] | LD x -> let s, env' = (env#variable x)#allocate in @@ -395,8 +395,8 @@ let compile cmd env imports code = then [Mov (x, eax); Binop (op, eax, y); Or1 y] else [Binop (op, x, y); Or1 y] ) - - | LABEL s + + | LABEL s | FLABEL s | SLABEL s -> env, [Label s] @@ -406,7 +406,7 @@ let compile cmd env imports code = let x, env = env#pop in env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)] - | BEGIN (f, nargs, nlocals, closure, args, scopes) -> + | BEGIN (f, nargs, nlocals, closure, args, scopes) -> let rec stabs_scope scope = let names = List.map @@ -419,7 +419,7 @@ let compile cmd env imports code = (if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 192,0,0,%s-%s" scope.blab f)]) @ (List.flatten @@ List.map stabs_scope scope.subs) @ (if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 224,0,0,%s-%s" scope.elab f)]) - in + in let name = if f.[0] = 'L' then String.sub f 1 (String.length f - 1) else f in @@ -429,10 +429,10 @@ let compile cmd env imports code = env, [Meta (Printf.sprintf "\t.type %s, @function" name)] @ (if f = "main" then [] - else + else [Meta (Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" name f)] @ (List.mapi (fun i a -> Meta (Printf.sprintf "\t.stabs \"%s:p1\",160,0,0,%d" a ((i*4) + 8))) args) @ - (List.flatten @@ List.map stabs_scope scopes) + (List.flatten @@ List.map stabs_scope scopes) ) @ [Meta "\t.cfi_startproc"] @ @@ -447,7 +447,7 @@ let compile cmd env imports code = Mov (L 1, M "_init"); ] else [] - ) @ + ) @ [Push ebp; Meta ("\t.cfi_def_cfa_offset\t" ^ if has_closure then "12" else "8"); Meta ("\t.cfi_offset 5, -" ^ if has_closure then "12" else "8"); @@ -466,7 +466,7 @@ let compile cmd env imports code = (if f = cmd#topname then List.map (fun i -> Call ("init" ^ i)) (List.filter (fun i -> i <> "Std") imports) else [] - ) + ) | END -> let x, env = env#pop in @@ -494,11 +494,11 @@ let compile cmd env imports code = env, [Mov (x, eax); Jmp env#epilogue] | ELEM -> call env ".elem" 2 false - + | CALL (f, n, tail) -> call env f n tail - + | CALLC (n, tail) -> callc env n tail - + | SEXP (t, n) -> let s, env = env#allocate in let env, code = call env ".sexp" (n+1) false in @@ -530,7 +530,7 @@ let compile cmd env imports code = | PATT StrCmp -> call env ".string_patt" 2 false | PATT patt -> - call env + call env (match patt with | Boxed -> ".boxed_patt" | UnBoxed -> ".unboxed_patt" @@ -541,12 +541,12 @@ let compile cmd env imports code = ) 1 false | LINE (line) -> env#gen_line line - - | FAIL ((line, col), value) -> + + | FAIL ((line, col), value) -> let v, env = if value then env#peek, env else env#pop in let s, env = env#string cmd#get_infile in env, [Push (L (box col)); Push (L (box line)); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop ("+", L (4 * word_size), esp)] - + | i -> invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i)) in @@ -554,7 +554,7 @@ let compile cmd env imports code = env'', [Meta (Printf.sprintf "# %s / %s" (GT.show(SM.insn) instr) stack)] @ code' @ code'' in compile' env code - + (* A set of strings *) module S = Set.Make (String) @@ -572,7 +572,7 @@ class env prg = val stringm = M.empty (* a string map *) val scount = 0 (* string count *) val stack_slots = 0 (* maximal number of stack positions *) - + val static_size = 0 (* static data size *) val stack = [] (* symbolic stack *) val nargs = 0 (* number of function arguments *) @@ -586,16 +586,16 @@ class env prg = val externs = S.empty val nlabels = 0 val first_line = true - + method publics = S.elements publics - + method register_public name = {< publics = S.add name publics >} method register_extern name = {< externs = S.add name externs >} - + method max_locals_size = max_locals_size - + method has_closure = has_closure - + method save_closure = if has_closure then [Push edx] else [] @@ -604,9 +604,9 @@ class env prg = method reload_closure = if has_closure then [Mov (C (*S 0*), edx)] else [] - + method fname = fname - + method leave = if stack_slots > max_locals_size then {< max_locals_size = stack_slots >} @@ -660,7 +660,7 @@ class env prg = | Value.Local i -> S i | Value.Arg i -> S (- (i + if has_closure then 2 else 1)) | Value.Access i -> I (word_size * (i+1), edx) - + (* allocates a fresh position on a symbolic stack *) method allocate = let x, n = @@ -732,7 +732,7 @@ class env prg = (* gets number of arguments in the current function *) method nargs = nargs - + (* gets all global variables *) method globals = S.elements (S.diff globals externs) @@ -741,9 +741,9 @@ class env prg = (* gets a number of stack positions allocated *) method allocated = stack_slots - + method allocated_size = Printf.sprintf "LS%s_SIZE" fname - + (* enters a function *) method enter f nargs nlocals has_closure = {< nargs = nargs; static_size = nlocals; stack_slots = nlocals; stack = []; fname = f; has_closure = has_closure; first_line = true >} @@ -753,7 +753,7 @@ class env prg = (* returns a name for local size meta-symbol *) method lsize = Printf.sprintf "L%s_SIZE" fname - + (* returns a list of live registers *) method live_registers depth = let rec inner d acc = function @@ -771,9 +771,9 @@ class env prg = then [Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab); Label lab] else - (if first_line then [Meta (Printf.sprintf "\t.stabn 68,0,%d,0" line)] else []) @ + (if first_line then [Meta (Printf.sprintf "\t.stabn 68,0,%d,0" line)] else []) @ [Meta (Printf.sprintf "\t.stabn 68,0,%d,%s-%s" line lab fname); Label lab] - + end (* Generates an assembler text for a program: first compiles the program into @@ -804,7 +804,7 @@ let genasm cmd prog = Meta (Printf.sprintf "\t.stabs \"%s\",100,0,0,.Ltext" cmd#get_absolute_infile)] @ globals @ data @ - [Meta "\t.text"; Label ".Ltext"; Meta "\t.stabs \"data:t1=r1;0;4294967295;\",128,0,0,0"] @ + [Meta "\t.text"; Label ".Ltext"; Meta "\t.stabs \"data:t1=r1;0;4294967295;\",128,0,0,0"] @ code); Buffer.contents asm @@ -812,18 +812,18 @@ let get_std_path () = match Sys.getenv_opt "LAMA" with | Some s -> s | None -> Stdpath.path - + (* Builds a program: generates the assembler file and compiles it with the gcc toolchain *) let build cmd prog = let find_objects imports paths = let module S = Set.Make (String) in let rec iterate acc s = function | [] -> acc - | import::imports -> + | import::imports -> if S.mem import s then iterate acc s imports else - let path, intfs = Interface.find import paths in + let path, intfs = Interface.find import paths in iterate ((Filename.concat path (import ^ ".o")) :: acc) (S.add import s) @@ -841,7 +841,8 @@ let build cmd prog = let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in let buf = Buffer.create 255 in List.iter (fun o -> Buffer.add_string buf o; Buffer.add_string buf " ") objs; - let gcc_cmdline = Printf.sprintf "gcc %s -m32 %s %s.s %s %s/runtime.a" cmd#get_debug cmd#get_output_option cmd#basename (Buffer.contents buf) inc in + let gcc_cmdline = Printf.sprintf "gcc %s -m32 %s %s.s %s %s/runtime32.a" cmd#get_debug cmd#get_output_option cmd#basename (Buffer.contents buf) inc in + Printf.printf " > %s\n%!" gcc_cmdline; Sys.command gcc_cmdline | `Compile -> Sys.command (Printf.sprintf "gcc %s -m32 -c %s.s" cmd#get_debug cmd#basename) diff --git a/src/X86_64.ml b/src/X86_64.ml index 33a7dfb1a..93b12e037 100644 --- a/src/X86_64.ml +++ b/src/X86_64.ml @@ -1482,9 +1482,10 @@ let build cmd prog = Buffer.add_string buf " ") objs; let gcc_cmdline = - Printf.sprintf "%s %s %s %s %s %s.s %s %s/runtime.a" compiler - compiler_flags linker_flags debug_flags cmd#get_output_option - cmd#basename (Buffer.contents buf) cmd#get_runtime_path + Printf.sprintf "%s %s %s %s %s %s.s %s %s/%s.a" compiler compiler_flags + linker_flags debug_flags cmd#get_output_option cmd#basename + (Buffer.contents buf) cmd#get_runtime_path + (match cmd#march with `X86_32 -> "runtime32" | `AMD64 -> "runtime") in Sys.command gcc_cmdline | `Compile -> diff --git a/stdlib/Makefile b/stdlib/Makefile index 47bd5568a..10feda1a6 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -1,10 +1,12 @@ -SHELL := /bin/bash +.PHONY: all +SHELL := /bin/bash FILES=$(wildcard *.lama) ALL=$(sort $(FILES:.lama=.o)) -LAMAC=../src/lamac +LAMAC ?= ../src/lamac +BDIR ?= . -all: $(ALL) +all: $(addprefix $(BDIR)/,$(ALL)) Fun.o: Ref.o @@ -12,18 +14,18 @@ Data.o: Ref.o Collection.o Collection.o: List.o Ref.o -Array.o: List.o +$(BDIR)/Array.o: $(BDIR)/List.o Ostap.o: List.o Collection.o Ref.o Fun.o Matcher.o -Buffer.o: List.o +$(BDIR)/Buffer.o: $(BDIR)/List.o -STM.o: List.o Fun.o +$(BDIR)/STM.o: $(BDIR)/List.o $(BDIR)/Fun.o -%.o: %.lama - LAMA=../runtime $(LAMAC) -g -I . -c $< +$(BDIR)/%.o: %.lama + LAMA=../runtime $(LAMAC) -g -I . -c $< -o $@ clean: - rm -Rf *.s *.o *.i *~ + $(RM) -r *.s *.o *.i *~ pushd regression && make clean && popd diff --git a/stdlib/amd64/dune b/stdlib/amd64/dune new file mode 100644 index 000000000..a0464fb76 --- /dev/null +++ b/stdlib/amd64/dune @@ -0,0 +1,15 @@ +(rule + (deps ../List.lama ../Makefile ../../runtime/Std.i) + (targets List.i List.o) + (action + (progn + (setenv + BDIR + "amd64" + (setenv + LAMA + "../runtime" + (setenv + LAMAC + "../src/Driver.exe -I ../runtime" + (run make -C .. all))))))) diff --git a/stdlib/x32/dune b/stdlib/x32/dune new file mode 100644 index 000000000..33cbf3209 --- /dev/null +++ b/stdlib/x32/dune @@ -0,0 +1,38 @@ +(rule + (targets List.o List.i) + (deps + (:lama ../List.lama) + %{project_root}/runtime32/runtime32.a + %{project_root}/runtime32/Std.i) + (action + (setenv + LAMA + "../../runtime32" + (run + %{project_root}/src/Driver.exe + -march=x86 + -I + %{project_root}/runtime32 + -c + %{lama})))) + +(rule + (targets Array.o Array.i) + (deps + (:lama ../Array.lama) + %{project_root}/runtime32/Std.i + List.i + List.o) + (action + (setenv + LAMA + "../../runtime32" + (run + %{project_root}/src/Driver.exe + -march=x86 + -I + . + -I + %{project_root}/runtime32 + -c + %{lama})))) diff --git a/tutorial/dune b/tutorial/dune new file mode 100644 index 000000000..1f6e131c7 --- /dev/null +++ b/tutorial/dune @@ -0,0 +1,19 @@ +(rule + (targets Hello.exe) + (deps Hello.lama) + (mode + (promote (until-clean))) + (action + (setenv + LAMA + "../runtime32" + (run + %{project_root}/src/Driver.exe + %{deps} + -march=x86 + -I + ../stdlib/x32 + -I + ../runtime32 + -o + %{targets}))))