Made compiler working on Linux too

This commit is contained in:
Roman Venediktov 2024-07-01 11:37:41 +02:00
parent 468caac0f2
commit 85b838ea2b
10 changed files with 188 additions and 128 deletions

View file

@ -17,6 +17,7 @@ depends: [
"camlp5" { >= "8.00.05" } "camlp5" { >= "8.00.05" }
"ostap" { >= "0.5"} "ostap" { >= "0.5"}
"GT" { >= "0.5.1" } "GT" { >= "0.5.1" }
"posix-uname" { = "2.0.2" }
] ]
build: [ build: [

View file

@ -3,6 +3,13 @@ TESTS=$(sort $(filter-out test111, $(basename $(wildcard test*.lama))))
LAMAC=../src/lamac LAMAC=../src/lamac
UNAME_S := $(shell uname -s)
ifeq ($(UNAME_S),Linux)
else ifeq ($(UNAME_S),Darwin)
ARCH = arch -x86_64
endif
.PHONY: check $(TESTS) .PHONY: check $(TESTS)
@ -12,11 +19,11 @@ $(TESTS): %: %.lama
@echo "regression/$@" @echo "regression/$@"
# @cat $@.input | LAMA=../runtime $(LAMAC) -i $< > $@.log && diff $@.log orig/$@.log # @cat $@.input | LAMA=../runtime $(LAMAC) -i $< > $@.log && diff $@.log orig/$@.log
# @cat $@.input | LAMA=../runtime $(LAMAC) -ds -s $< > $@.log && diff $@.log orig/$@.log # @cat $@.input | LAMA=../runtime $(LAMAC) -ds -s $< > $@.log && diff $@.log orig/$@.log
@LAMA=../runtime $(LAMAC) $< && cat $@.input | arch -x86_64 ./$@ > $@.log && diff $@.log orig/$@.log @LAMA=../runtime $(LAMAC) $< && cat $@.input | $(ARCH) ./$@ > $@.log && diff $@.log orig/$@.log
ctest111: ctest111:
@echo "regression/test111" @echo "regression/test111"
@LAMA=../runtime $(LAMAC) test111.lama && cat test111.input | arch -x86_64 ./test111 > test111.log && diff test111.log orig/test111.log @LAMA=../runtime $(LAMAC) test111.lama && cat test111.input | $(ARCH) ./test111 > test111.log && diff test111.log orig/test111.log
clean: clean:
$(RM) test*.log *.s *.sm *~ $(TESTS) *.i $(DEBUG_FILES) test111 $(RM) test*.log *.s *.sm *~ $(TESTS) *.i $(DEBUG_FILES) test111

View file

@ -51,8 +51,8 @@ runtime.o: runtime.c runtime.h
runtime64.o: runtime.c runtime.h runtime64.o: runtime.c runtime.h
$(CC) $(PROD_FLAGS) -c runtime.c -o runtime64.o $(CC) $(PROD_FLAGS) -c runtime.c -o runtime64.o
printf.o: printf.s printf.o: printf.S
$(CC) $(PROD_FLAGS) -c -g printf.s -o printf.o $(CC) $(PROD_FLAGS) -x assembler-with-cpp -c -g printf.S -o printf.o
clean: clean:
$(RM) *.a *.o *~ negative_scenarios/*.err $(RM) *.a *.o *~ negative_scenarios/*.err

View file

@ -26,9 +26,13 @@ static extra_roots_pool extra_roots;
size_t __gc_stack_top = 0, __gc_stack_bottom = 0; size_t __gc_stack_top = 0, __gc_stack_bottom = 0;
#ifdef LAMA_ENV #ifdef LAMA_ENV
#ifdef __linux__
extern const size_t __start_custom_data, __stop_custom_data;
#elif defined(__APPLE__)
extern const size_t __start_custom_data __asm("section$start$__DATA$custom_data"); extern const size_t __start_custom_data __asm("section$start$__DATA$custom_data");
extern const size_t __stop_custom_data __asm("section$end$__DATA$custom_data"); extern const size_t __stop_custom_data __asm("section$end$__DATA$custom_data");
#endif #endif
#endif
#ifdef DEBUG_VERSION #ifdef DEBUG_VERSION
memory_chunk heap; memory_chunk heap;

View file

@ -1,22 +1,27 @@
#ifdef __linux__
#define PREFIXED(name) name
#elif defined(__APPLE__)
#define PREFIXED(name) _##name
#endif
.data .data
.global _Lprintf .global PREFIXED(Lprintf)
.extern _Bprintf .extern PREFIXED(Bprintf)
.global _Lfprintf .global PREFIXED(Lfprintf)
.extern _Bfprintf .extern PREFIXED(Bfprintf)
.global _Lsprintf .global PREFIXED(Lsprintf)
.extern _Bsprintf .extern PREFIXED(Bsprintf)
.global _Lfailure .global PREFIXED(Lfailure)
.extern _failure .extern PREFIXED(failure)
.extern cnt_percentage_sign .extern cnt_percentage_sign
.text .text
_Lprintf: PREFIXED(Lprintf):
# save return address # save return address
popq %r14 popq %r14
@ -28,22 +33,22 @@ _Lprintf:
movq %rsp, %rax movq %rsp, %rax
# rdi --- format string # rdi --- format string
# r11 --- number of arguments except format string # r11 --- number of arguments except format string
_Lprintf_loop: PREFIXED(Lprintf_loop):
movq $0, %r12 movq $0, %r12
cmpq %r11, %r12 cmpq %r11, %r12
jz _Lprintf_continue jz PREFIXED(Lprintf_continue)
decq %r11 decq %r11
movq (%rax), %r10 movq (%rax), %r10
testq $1, %r10 testq $1, %r10
jz _Lprintf_loop_end jz PREFIXED(Lprintf_loop_end)
# unbox value # unbox value
sarq %r10 sarq %r10
movq %r10, (%rax) movq %r10, (%rax)
_Lprintf_loop_end: PREFIXED(Lprintf_loop_end):
addq $8, %rax addq $8, %rax
jmp _Lprintf_loop jmp PREFIXED(Lprintf_loop)
_Lprintf_continue: PREFIXED(Lprintf_continue):
popq %rsi popq %rsi
popq %rdx popq %rdx
popq %rcx popq %rcx
@ -51,9 +56,9 @@ _Lprintf_continue:
popq %r9 popq %r9
# restore return address # restore return address
pushq %r14 pushq %r14
jmp _Bprintf jmp PREFIXED(Bprintf)
_Lfprintf: PREFIXED(Lfprintf):
# save return address # save return address
popq %r14 popq %r14
@ -65,31 +70,31 @@ _Lfprintf:
# rdi --- FILE* # rdi --- FILE*
# rsi --- format string # rsi --- format string
# r11 --- number of arguments except format string # r11 --- number of arguments except format string
_Lfprintf_loop: PREFIXED(Lfprintf_loop):
movq $0, %r12 movq $0, %r12
cmpq %r11, %r12 cmpq %r11, %r12
jz _Lfprintf_continue jz PREFIXED(Lfprintf_continue)
decq %r11 decq %r11
movq (%rax), %r10 movq (%rax), %r10
testq $1, %r10 testq $1, %r10
jz _Lfprintf_loop_end jz PREFIXED(Lfprintf_loop_end)
# unbox value # unbox value
sarq %r10 sarq %r10
movq %r10, (%rax) movq %r10, (%rax)
_Lfprintf_loop_end: PREFIXED(Lfprintf_loop_end):
addq $8, %rax addq $8, %rax
jmp _Lfprintf_loop jmp PREFIXED(Lfprintf_loop)
_Lfprintf_continue: PREFIXED(Lfprintf_continue):
popq %rdx popq %rdx
popq %rcx popq %rcx
popq %r8 popq %r8
popq %r9 popq %r9
# restore return address # restore return address
pushq %r14 pushq %r14
jmp _Bfprintf jmp PREFIXED(Bfprintf)
_Lsprintf: PREFIXED(Lsprintf):
# save return address # save return address
popq %r14 popq %r14
@ -101,22 +106,22 @@ _Lsprintf:
movq %rsp, %rax movq %rsp, %rax
# rdi --- format string # rdi --- format string
# r11 --- number of arguments except format string # r11 --- number of arguments except format string
_Lsprintf_loop: PREFIXED(Lsprintf_loop):
movq $0, %r12 movq $0, %r12
cmpq %r11, %r12 cmpq %r11, %r12
jz _Lsprintf_continue jz PREFIXED(Lsprintf_continue)
decq %r11 decq %r11
movq (%rax), %r10 movq (%rax), %r10
testq $1, %r10 testq $1, %r10
jz _Lsprintf_loop_end jz PREFIXED(Lsprintf_loop_end)
# unbox value # unbox value
sarq %r10 sarq %r10
movq %r10, (%rax) movq %r10, (%rax)
_Lsprintf_loop_end: PREFIXED(Lsprintf_loop_end):
addq $8, %rax addq $8, %rax
jmp _Lsprintf_loop jmp PREFIXED(Lsprintf_loop)
_Lsprintf_continue: PREFIXED(Lsprintf_continue):
popq %rsi popq %rsi
popq %rdx popq %rdx
popq %rcx popq %rcx
@ -124,9 +129,9 @@ _Lsprintf_continue:
popq %r9 popq %r9
# restore return address # restore return address
pushq %r14 pushq %r14
jmp _Bsprintf jmp PREFIXED(Bsprintf)
_Lfailure: PREFIXED(Lfailure):
# save return address # save return address
popq %r14 popq %r14
@ -138,22 +143,22 @@ _Lfailure:
movq %rsp, %rax movq %rsp, %rax
# rdi --- format string # rdi --- format string
# r11 --- number of arguments except format string # r11 --- number of arguments except format string
_Lfailure_loop: PREFIXED(Lfailure_loop):
movq $0, %r12 movq $0, %r12
cmpq %r11, %r12 cmpq %r11, %r12
jz _Lfailure_continue jz PREFIXED(Lfailure_continue)
decq %r11 decq %r11
movq (%rax), %r10 movq (%rax), %r10
testq $1, %r10 testq $1, %r10
jz _Lfailure_loop_end jz PREFIXED(Lfailure_loop_end)
# unbox value # unbox value
sarq %r10 sarq %r10
movq %r10, (%rax) movq %r10, (%rax)
_Lfailure_loop_end: PREFIXED(Lfailure_loop_end):
addq $8, %rax addq $8, %rax
jmp _Lfailure_loop jmp PREFIXED(Lfailure_loop)
_Lfailure_continue: PREFIXED(Lfailure_continue):
popq %rsi popq %rsi
popq %rdx popq %rdx
popq %rcx popq %rcx
@ -161,4 +166,4 @@ _Lfailure_continue:
popq %r9 popq %r9
# restore return address # restore return address
pushq %r14 pushq %r14
jmp _failure jmp PREFIXED(failure)

View file

@ -143,7 +143,7 @@ class options args =
Filename.chop_suffix (Filename.basename self#get_infile) ".lama" Filename.chop_suffix (Filename.basename self#get_infile) ".lama"
method topname = method topname =
match !mode with `Compile -> "init" ^ self#basename | _ -> "_main" match !mode with `Compile -> "init" ^ self#basename | _ -> "main"
method dump_file ext contents = method dump_file ext contents =
let name = self#basename in let name = self#basename in

View file

@ -14,11 +14,13 @@ type scope = {
} }
[@@deriving gt ~options:{ show }] [@@deriving gt ~options:{ show }]
let normal_prefix = "_L" let normal_label = "L"
let builtin_prefix = "_B" let builtin_label = "B"
let label s = normal_prefix ^ s let global_label = "global_"
let builtin_label s = builtin_prefix ^ s let labeled s = normal_label ^ s
let scope_label i s = label s ^ "_" ^ string_of_int i let labeled_builtin s = builtin_label ^ s
let labeled_global s = global_label ^ s
let labeled_scoped i s = labeled s ^ "_" ^ string_of_int i
let show_scope = show scope let show_scope = show scope
(* The type for the stack machine instructions *) (* The type for the stack machine instructions *)
@ -270,13 +272,13 @@ module ByteCode = struct
add_fixup s; add_fixup s;
add_ints [ 0 ] add_ints [ 0 ]
(* 0x70 *) (* 0x70 *)
| CALL (f, _, _) when f = label "read" -> add_bytes [ (7 * 16) + 0 ] | CALL (f, _, _) when f = labeled "read" -> add_bytes [ (7 * 16) + 0 ]
(* 0x71 *) (* 0x71 *)
| CALL (f, _, _) when f = label "write" -> add_bytes [ (7 * 16) + 1 ] | CALL (f, _, _) when f = labeled "write" -> add_bytes [ (7 * 16) + 1 ]
(* 0x72 *) (* 0x72 *)
| CALL (f, _, _) when f = label "length" -> add_bytes [ (7 * 16) + 2 ] | CALL (f, _, _) when f = labeled "length" -> add_bytes [ (7 * 16) + 2 ]
(* 0x73 *) (* 0x73 *)
| CALL (f, _, _) when f = label "string" -> add_bytes [ (7 * 16) + 3 ] | CALL (f, _, _) when f = labeled "string" -> add_bytes [ (7 * 16) + 3 ]
(* 0x74 *) (* 0x74 *)
| CALL (".array", n, _) -> | CALL (".array", n, _) ->
add_bytes [ (7 * 16) + 4 ]; add_bytes [ (7 * 16) + 4 ];
@ -1016,7 +1018,7 @@ class env cmd imports =
{<funinfo = funinfo#register_closure f self#closure>} {<funinfo = funinfo#register_closure f self#closure>}
method current_function = method current_function =
match fundefs with Top _ -> "_main" | Item (fd, _, _) -> fd.name match fundefs with Top _ -> "main" | Item (fd, _, _) -> fd.name
method private import_imports = method private import_imports =
let paths = cmd#get_include_paths in let paths = cmd#get_include_paths in
@ -1037,10 +1039,10 @@ class env cmd imports =
method global_scope = scope_index = 0 method global_scope = scope_index = 0
method get_label = method get_label =
(label @@ string_of_int label_index, {<label_index = label_index + 1>}) (labeled @@ string_of_int label_index, {<label_index = label_index + 1>})
method get_end_label = method get_end_label =
let lab = label @@ string_of_int label_index in let lab = labeled @@ string_of_int label_index in
(lab, {<end_label = lab; label_index = label_index + 1>}) (lab, {<end_label = lab; label_index = label_index + 1>})
method end_label = end_label method end_label = end_label
@ -1048,7 +1050,10 @@ class env cmd imports =
method nlocals = scope.nlocals method nlocals = scope.nlocals
method get_decls = method get_decls =
let opt_label = function true -> label | _ -> fun x -> "_global_" ^ x in let opt_label = function
| true -> labeled
| _ -> labeled_global
in
List.flatten List.flatten
@@ List.map (function @@ List.map (function
| name, `Extern, f -> [ EXTERN (opt_label f name) ] | name, `Extern, f -> [ EXTERN (opt_label f name) ]
@ -1196,7 +1201,9 @@ class env cmd imports =
}>} }>}
method fun_internal_name (name : string) = method fun_internal_name (name : string) =
(match scope.st with State.G _ -> label | _ -> scope_label scope_index) (match scope.st with
| State.G _ -> labeled
| _ -> labeled_scoped scope_index)
name name
method add_fun_name (name : string) method add_fun_name (name : string)
@ -1651,7 +1658,7 @@ let compile cmd ((imports, _), p) =
LABEL topname; LABEL topname;
BEGIN BEGIN
( topname, ( topname,
(if topname = "_main" then 2 else 0), (if topname = "main" then 2 else 0),
env#nlocals, env#nlocals,
[], [],
[], [],

View file

@ -4,6 +4,18 @@ open SM
(* X86 codegeneration interface *) (* X86 codegeneration interface *)
type os_t = Linux | Darwin
let os =
let uname = Posix_uname.uname () in
match uname.sysname with
| "Darwin" -> Darwin
| "Linux" -> Linux
| _ -> failwith "Unsupported OS"
let prefix = match os with Linux -> "" | Darwin -> "_"
let prefixed name = prefix ^ name
module Register : sig module Register : sig
type t type t
@ -203,10 +215,10 @@ let show instr =
| S i -> | S i ->
if i >= 0 then Printf.sprintf "-%d(%%rbp)" (stack_offset i) if i >= 0 then Printf.sprintf "-%d(%%rbp)" (stack_offset i)
else Printf.sprintf "%d(%%rbp)" (stack_offset i) else Printf.sprintf "%d(%%rbp)" (stack_offset i)
| M (_, I, _, s) -> Printf.sprintf "%s(%%rip)" s | M (_, I, _, s) -> Printf.sprintf "%s(%%rip)" (prefixed s)
| M (F, E, _, s) -> Printf.sprintf "%s(%%rip)" s | M (F, E, _, s) -> Printf.sprintf "%s(%%rip)" (prefixed s)
| M (D, E, _, s) -> Printf.sprintf "%s@GOTPCREL(%%rip)" s | M (D, E, _, s) -> Printf.sprintf "%s@GOTPCREL(%%rip)" (prefixed s)
| C s -> Printf.sprintf "$%s" s | C s -> Printf.sprintf "$%s" (prefixed s)
| L i -> Printf.sprintf "$%d" i | L i -> Printf.sprintf "$%d" i
| I (0, x) -> Printf.sprintf "(%s)" (opnd x) | I (0, x) -> Printf.sprintf "(%s)" (opnd x)
| I (n, x) -> Printf.sprintf "%d(%s)" n (opnd x) | I (n, x) -> Printf.sprintf "%d(%s)" n (opnd x)
@ -237,12 +249,12 @@ let show instr =
| Push s -> Printf.sprintf "\tpushq\t%s" (opnd s) | Push s -> Printf.sprintf "\tpushq\t%s" (opnd s)
| Pop s -> Printf.sprintf "\tpopq\t%s" (opnd s) | Pop s -> Printf.sprintf "\tpopq\t%s" (opnd s)
| Ret -> "\tret" | Ret -> "\tret"
| Call p -> Printf.sprintf "\tcall\t%s" p | Call p -> Printf.sprintf "\tcall\t%s" (prefixed p)
| CallI o -> Printf.sprintf "\tcall\t*(%s)" (opnd o) | CallI o -> Printf.sprintf "\tcall\t*(%s)" (opnd o)
| Label l -> Printf.sprintf "%s:\n" l | Label l -> Printf.sprintf "%s:\n" (prefixed l)
| Jmp l -> Printf.sprintf "\tjmp\t%s" l | Jmp l -> Printf.sprintf "\tjmp\t%s" (prefixed l)
| JmpI o -> Printf.sprintf "\tjmp\t*(%s)" (opnd o) | JmpI o -> Printf.sprintf "\tjmp\t*(%s)" (opnd o)
| CJmp (s, l) -> Printf.sprintf "\tj%s\t%s" s l | CJmp (s, l) -> Printf.sprintf "\tj%s\t%s" s (prefixed l)
| Meta s -> Printf.sprintf "%s\n" s | Meta s -> Printf.sprintf "%s\n" s
| Dec s -> Printf.sprintf "\tdecq\t%s" (opnd s) | Dec s -> Printf.sprintf "\tdecq\t%s" (opnd s)
| Or1 s -> Printf.sprintf "\torq\t$0x0001,\t%s" (opnd s) | Or1 s -> Printf.sprintf "\torq\t$0x0001,\t%s" (opnd s)
@ -407,29 +419,29 @@ let compile_binop env op =
let safepoint_functions = let safepoint_functions =
[ [
label "s__Infix_58"; labeled "s__Infix_58";
label "substring"; labeled "substring";
label "clone"; labeled "clone";
builtin_label "string"; labeled_builtin "string";
label "stringcat"; labeled "stringcat";
label "string"; labeled "string";
builtin_label "closure"; labeled_builtin "closure";
builtin_label "array"; labeled_builtin "array";
builtin_label "sexp"; labeled_builtin "sexp";
label "i__Infix_4343" labeled "i__Infix_4343"
(* "makeArray"; not required as do not have ptr arguments *) (* "makeArray"; not required as do not have ptr arguments *)
(* "makeString"; not required as do not have ptr arguments *) (* "makeString"; not required as do not have ptr arguments *)
(* "getEnv", not required as do not have ptr arguments *) (* "getEnv", not required as do not have ptr arguments *)
(* "set_args", not required as do not have ptr arguments *); (* "set_args", not required as do not have ptr arguments *);
(* Lsprintf, or Bsprintf is an extra dirty hack that works? *) (* Lsprintf, or Bsprintf is an extra dirty hack that probably works *)
] ]
let vararg_functions = let vararg_functions =
[ [
(label "printf", 1); (labeled "printf", 1);
(label "fprintf", 2); (labeled "fprintf", 2);
(label "sprintf", 1); (labeled "sprintf", 1);
(label "failure", 1); (labeled "failure", 1);
] ]
let compile_call env ?fname nargs tail = let compile_call env ?fname nargs tail =
@ -437,7 +449,7 @@ let compile_call env ?fname nargs tail =
Option.map Option.map
(fun fname -> (fun fname ->
match fname.[0] with match fname.[0] with
| '.' -> builtin_label (String.sub fname 1 (String.length fname - 1)) | '.' -> labeled_builtin (String.sub fname 1 (String.length fname - 1))
| _ -> fname) | _ -> fname)
fname fname
in in
@ -557,9 +569,10 @@ let compile_call env ?fname nargs tail =
let setup_args_code = List.map (fun arg -> Push arg) @@ List.rev args in let setup_args_code = List.map (fun arg -> Push arg) @@ List.rev args in
let setup_args_code = setup_args_code @ [ Mov (rsp, rdi) ] in let setup_args_code = setup_args_code @ [ Mov (rsp, rdi) ] in
let setup_args_code = let setup_args_code =
if fname = builtin_label "closure" then if fname = labeled_builtin "closure" then
setup_args_code @ [ Mov (L (box (nargs - 1)), rsi) ] setup_args_code @ [ Mov (L (box (nargs - 1)), rsi) ]
else if fname = builtin_label "sexp" || fname = builtin_label "array" else if
fname = labeled_builtin "sexp" || fname = labeled_builtin "array"
then setup_args_code @ [ Mov (L (box nargs), rsi) ] then setup_args_code @ [ Mov (L (box nargs), rsi) ]
else setup_args_code else setup_args_code
in in
@ -715,18 +728,18 @@ let compile cmd env imports code =
[ Meta "\t.cfi_startproc" ] [ Meta "\t.cfi_startproc" ]
@ (if f = cmd#topname then @ (if f = cmd#topname then
[ [
Mov (M (D, I, V, "_init"), rax); Mov (M (D, I, V, "init"), rax);
Binop ("test", rax, rax); Binop ("test", rax, rax);
CJmp ("z", "_continue"); CJmp ("z", "continue");
Ret; Ret;
Label "_ERROR"; Label "_ERROR";
Call (label "binoperror"); Call (labeled "binoperror");
Ret; Ret;
Label "_ERROR2"; Label "_ERROR2";
Call (label "binoperror2"); Call (labeled "binoperror2");
Ret; Ret;
Label "_continue"; Label "continue";
Mov (L 1, M (D, I, V, "_init")); Mov (L 1, M (D, I, V, "init"));
] ]
else []) else [])
@ [ @ [
@ -747,21 +760,21 @@ let compile cmd env imports code =
Mov (r13, rsi); Mov (r13, rsi);
Mov (r14, rcx); Mov (r14, rcx);
] ]
@ (if f = "_main" then @ (if f = "main" then
[ [
(* Align stack as main function is the only function that could be called without alignment. TODO *) (* Align stack as main function is the only function that could be called without alignment. TODO *)
Mov (L 0xF, rax); Mov (L 0xF, rax);
Binop ("test", rsp, rax); Binop ("test", rsp, rax);
CJmp ("z", "_ALIGNED"); CJmp ("z", "ALIGNED");
Push filler; Push filler;
Label "_ALIGNED"; Label "ALIGNED";
(* Initialize gc and arguments *) (* Initialize gc and arguments *)
Push (R Registers.rdi); Push (R Registers.rdi);
Push (R Registers.rsi); Push (R Registers.rsi);
Call "___gc_init"; Call "__gc_init";
Pop (R Registers.rsi); Pop (R Registers.rsi);
Pop (R Registers.rdi); Pop (R Registers.rdi);
Call "_set_args"; Call "set_args";
] ]
else []) else [])
@ @
@ -782,7 +795,7 @@ let compile cmd env imports code =
Mov (rbp, rsp); Mov (rbp, rsp);
Pop rbp; Pop rbp;
] ]
@ (if name = "_main" then [ Binop ("^", rax, rax) ] else []) @ (if name = "main" then [ Binop ("^", rax, rax) ] else [])
@ [ @ [
Meta "\t.cfi_restore\t5"; Meta "\t.cfi_restore\t5";
Meta "\t.cfi_def_cfa\t4, 4"; Meta "\t.cfi_def_cfa\t4, 4";
@ -791,12 +804,13 @@ let compile cmd env imports code =
Meta Meta
(* Allocate space for the symbolic stack (* Allocate space for the symbolic stack
Add extra word if needed to preserve alignment *) Add extra word if needed to preserve alignment *)
(Printf.sprintf "\t.set\t%s,\t%d" env#lsize (Printf.sprintf "\t.set\t%s,\t%d" (prefixed env#lsize)
(if env#allocated mod 2 == 0 then (if env#allocated mod 2 == 0 then
env#allocated * word_size env#allocated * word_size
else (env#allocated + 1) * word_size)); else (env#allocated + 1) * word_size));
Meta Meta
(Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size (Printf.sprintf "\t.set\t%s,\t%d"
(prefixed env#allocated_size)
env#allocated); env#allocated);
] ) ] )
| RET -> | RET ->
@ -1092,7 +1106,7 @@ class env prg =
method loc x = method loc x =
match x with match x with
| Value.Global name -> | Value.Global name ->
let loc_name = "_global_" ^ name in let loc_name = labeled_global name in
let ext = if self#is_external name then E else I in let ext = if self#is_external name then E else I in
M (D, ext, V, loc_name) M (D, ext, V, loc_name)
| Value.Fun name -> | Value.Fun name ->
@ -1146,7 +1160,7 @@ class env prg =
(* registers a variable in the environment *) (* registers a variable in the environment *)
method variable x = method variable x =
match x with match x with
| Value.Global name -> {<globals = S.add ("_global_" ^ name) globals>} | Value.Global name -> {<globals = S.add (labeled_global name) globals>}
| _ -> self | _ -> self
(* registers a string constant *) (* registers a string constant *)
@ -1157,7 +1171,9 @@ class env prg =
let rec iterate i = let rec iterate i =
if i < n then ( if i < n then (
(match x.[i] with (match x.[i] with
| '"' -> (Buffer.add_char buf '\\'; Buffer.add_char buf '"') | '"' ->
Buffer.add_char buf '\\';
Buffer.add_char buf '"'
| c -> Buffer.add_char buf c); | c -> Buffer.add_char buf c);
iterate (i + 1)) iterate (i + 1))
in in
@ -1184,7 +1200,7 @@ class env prg =
(* gets a number of stack positions allocated *) (* gets a number of stack positions allocated *)
method allocated = stack_slots method allocated = stack_slots
method allocated_size = label (Printf.sprintf "S%s_SIZE" fname) method allocated_size = labeled (Printf.sprintf "S%s_SIZE" fname)
(* enters a function *) (* enters a function *)
method enter f nargs nlocals has_closure = method enter f nargs nlocals has_closure =
@ -1197,10 +1213,10 @@ class env prg =
; first_line = true>} ; first_line = true>}
(* returns a label for the epilogue *) (* returns a label for the epilogue *)
method epilogue = label (Printf.sprintf "%s_epilogue" fname) method epilogue = labeled (Printf.sprintf "%s_epilogue" fname)
(* returns a name for local size meta-symbol *) (* returns a name for local size meta-symbol *)
method lsize = label (Printf.sprintf "%s_SIZE" fname) method lsize = labeled (Printf.sprintf "%s_SIZE" fname)
(* returns a list of live registers *) (* returns a list of live registers *)
method live_registers = method live_registers =
@ -1213,8 +1229,11 @@ class env prg =
method gen_line = method gen_line =
let lab = Printf.sprintf ".L%d" nlabels in let lab = Printf.sprintf ".L%d" nlabels in
( {<nlabels = nlabels + 1; first_line = false>}, ( {<nlabels = nlabels + 1; first_line = false>},
if fname = "_main" then if fname = "main" then
[ (* Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab); *) Label lab ] [
(* Meta (Printf.sprintf "\t.stabn 68,0,%d,%s" line lab); *)
Label lab;
]
else else
(if first_line then (if first_line then
[ (* Meta (Printf.sprintf "\t.stabn 68,0,%d,0" line) *) ] [ (* Meta (Printf.sprintf "\t.stabn 68,0,%d,0" line) *) ]
@ -1232,17 +1251,25 @@ let genasm cmd prog =
let sm = SM.compile cmd prog in let sm = SM.compile cmd prog in
let env, code = compile cmd (new env sm) (fst (fst prog)) sm in let env, code = compile cmd (new env sm) (fst (fst prog)) sm in
let globals = let globals =
List.map (fun s -> Meta (Printf.sprintf "\t.globl\t%s" s)) env#publics List.map
(fun s -> Meta (Printf.sprintf "\t.globl\t%s" (prefixed s)))
env#publics
in in
let data = let data =
[ Meta "\t.data" ] [ Meta "\t.data" ]
@ List.map @ List.map
(fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) (fun (s, v) ->
Meta (Printf.sprintf "%s:\t.string\t\"%s\"" (prefixed v) s))
env#strings env#strings
@ [ @ [
Meta "_init:\t.quad 0"; Meta (prefixed "init" ^ ":\t.quad 0");
Meta "\t.section __DATA, custom_data, regular, no_dead_strip"; (match os with
Meta (Printf.sprintf "filler:\t.fill\t%d, 8, 1" env#max_locals_size); | Darwin ->
Meta "\t.section __DATA, custom_data, regular, no_dead_strip"
| Linux -> Meta "\t.section custom_data,\"aw\",@progbits");
Meta
(Printf.sprintf "%s:\t.fill\t%d, 8, 1" (prefixed "filler")
env#max_locals_size);
] ]
@ List.concat @ List.concat
@@ List.map @@ List.map
@ -1253,7 +1280,7 @@ let genasm cmd prog =
(String.sub s (String.length "global_") (String.sub s (String.length "global_")
(String.length s - String.length "global_")) (String.length s - String.length "global_"))
s); *) s); *)
Meta (Printf.sprintf "%s:\t.quad\t1" s); Meta (Printf.sprintf "%s:\t.quad\t1" (prefixed s));
]) ])
env#globals env#globals
in in
@ -1303,7 +1330,9 @@ let build cmd prog =
cmd#dump_file "i" (Interface.gen prog); cmd#dump_file "i" (Interface.gen prog);
let inc = get_std_path () in let inc = get_std_path () in
let compiler = "clang" in let compiler = "clang" in
let flags = "-arch x86_64" in let compiler_flags, linker_flags =
match os with Darwin -> ("-arch x86_64", "-ld_classic") | Linux -> ("", "")
in
match cmd#get_mode with match cmd#get_mode with
| `Default -> | `Default ->
let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in let objs = find_objects (fst @@ fst prog) cmd#get_include_paths in
@ -1314,13 +1343,13 @@ let build cmd prog =
Buffer.add_string buf " ") Buffer.add_string buf " ")
objs; objs;
let gcc_cmdline = let gcc_cmdline =
Printf.sprintf "%s -ld_classic %s %s %s %s.s %s %s/runtime.a" compiler flags Printf.sprintf "%s %s %s %s %s %s.s %s %s/runtime.a" compiler
cmd#get_debug cmd#get_output_option cmd#basename (Buffer.contents buf) compiler_flags linker_flags cmd#get_debug cmd#get_output_option
inc cmd#basename (Buffer.contents buf) inc
in in
Sys.command gcc_cmdline Sys.command gcc_cmdline
| `Compile -> | `Compile ->
Sys.command Sys.command
(Printf.sprintf "%s %s %s -c -g %s.s" compiler flags cmd#get_debug (Printf.sprintf "%s %s %s -c -g %s.s" compiler compiler_flags
cmd#basename) cmd#get_debug cmd#basename)
| _ -> invalid_arg "must not happen" | _ -> invalid_arg "must not happen"

View file

@ -46,7 +46,7 @@
(library (library
(name liba) (name liba)
(modules Language Pprinter stdpath version X86 SM) (modules Language Pprinter stdpath version X86 SM)
(libraries GT ostap) (libraries GT ostap posix-uname)
(flags (flags
(:standard (:standard
-rectypes -rectypes

View file

@ -2,13 +2,20 @@ TESTS=$(sort $(filter-out test02 test30, $(basename $(wildcard test*.lama))))
LAMAC=../../src/lamac LAMAC=../../src/lamac
UNAME_S := $(shell uname -s)
ifeq ($(UNAME_S),Linux)
else ifeq ($(UNAME_S),Darwin)
ARCH = arch -x86_64
endif
.PHONY: check $(TESTS) .PHONY: check $(TESTS)
check: $(TESTS) check: $(TESTS)
$(TESTS): %: %.lama $(TESTS): %: %.lama
@echo "stdlib/regression/$@" @echo "stdlib/regression/$@"
@LAMA=../../runtime $(LAMAC) -I .. -ds -dp $< && arch -X86_64 ./$@ > $@.log && diff $@.log orig/$@.log @LAMA=../../runtime $(LAMAC) -I .. -ds -dp $< && $(ARCH) ./$@ > $@.log && diff $@.log orig/$@.log
clean: clean:
$(RM) test*.log *.s *~ $(TESTS) *.i $(RM) test*.log *.s *~ $(TESTS) *.i