diff options
Diffstat (limited to 'testsuite/tests/asmgen')
33 files changed, 2602 insertions, 0 deletions
diff --git a/testsuite/tests/asmgen/Makefile b/testsuite/tests/asmgen/Makefile new file mode 100644 index 0000000000..f6d0c238ff --- /dev/null +++ b/testsuite/tests/asmgen/Makefile @@ -0,0 +1,122 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Clerc, SED, INRIA Rocquencourt * +#* * +#* Copyright 2010 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +BASEDIR=../.. + +include $(BASEDIR)/../config/Makefile + +INCLUDES=\ + -I $(OTOPDIR)/parsing \ + -I $(OTOPDIR)/utils \ + -I $(OTOPDIR)/typing \ + -I $(OTOPDIR)/middle_end \ + -I $(OTOPDIR)/bytecomp \ + -I $(OTOPDIR)/asmcomp + +OTHEROBJS=\ + $(OTOPDIR)/compilerlibs/ocamlcommon.cma \ + $(OTOPDIR)/compilerlibs/ocamloptcomp.cma + +OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo + +ADD_COMPFLAGS=$(INCLUDES) -w -40 -g + +default: + @if $(BYTECODE_ONLY) || $(SKIP) ; then $(MAKE) skips ; else \ + $(MAKE) all; \ + fi + +all: + @$(MAKE) arch codegen + @$(MAKE) tests + +main.cmo: parsecmm.cmo + +codegen: parsecmm.ml lexcmm.ml $(OBJS:.cmo=.cmi) $(OBJS) main.cmo + @$(OCAMLC) $(LINKFLAGS) -o codegen $(OTHEROBJS) $(OBJS) main.cmo + +parsecmm.mli parsecmm.ml: parsecmm.mly + @$(OCAMLYACC) -q parsecmm.mly + +lexcmm.ml: lexcmm.mll + @$(OCAMLLEX) -q lexcmm.mll + +CASES=fib tak quicksort quicksort2 soli \ + arith checkbound tagged-fib tagged-integr tagged-quicksort tagged-tak \ + catch-try catch-rec even-odd even-odd-spill pgcd +ARGS_fib=-DINT_INT -DFUN=fib main.c +ARGS_tak=-DUNIT_INT -DFUN=takmain main.c +ARGS_quicksort=-DSORT -DFUN=quicksort main.c +ARGS_quicksort2=-DSORT -DFUN=quicksort main.c +ARGS_soli=-DUNIT_INT -DFUN=solitaire main.c +ARGS_integr=-DINT_FLOAT -DFUN=test main.c +ARGS_arith=mainarith.c +ARGS_checkbound=-DCHECKBOUND main.c +ARGS_tagged-fib=-DINT_INT -DFUN=fib main.c +ARGS_tagged-integr=-DINT_FLOAT -DFUN=test main.c +ARGS_tagged-quicksort=-DSORT -DFUN=quicksort main.c +ARGS_tagged-tak=-DUNIT_INT -DFUN=takmain main.c +ARGS_catch-try=-DINT_INT -DFUN=catch_exit main.c +ARGS_catch-rec=-DINT_INT -DFUN=catch_fact main.c +ARGS_even-odd=-DINT_INT -DFUN=is_even main.c +ARGS_even-odd-spill=-DINT_INT -DFUN=is_even main.c +ARGS_pgcd=-DINT_INT -DFUN=pgcd_30030 main.c + +skips: + @for c in $(CASES); do \ + echo " ... testing '$$c': => skipped"; \ + done + +one: + @$(call CCOMP,$(NAME).out $(ARGS_$(NAME)) $(NAME).$(O) $(ARCH).$(O)) \ + && echo " => passed" || echo " => failed" + +clean: defaultclean + @rm -f ./codegen *.out *.out.manifest *.$(O) *.exe + @rm -f parsecmm.ml parsecmm.mli lexcmm.ml + @rm -f $(CASES:=.s) + +include $(BASEDIR)/makefiles/Makefile.common + +ifeq "$(CCOMPTYPE)-$(ARCH)" "msvc-amd64" +# these tests are not ported to MSVC64 yet +SKIP=true +else +SKIP=false +endif + +ifeq "$(WITH_SPACETIME)" "true" +# These tests have not been ported for Spacetime +SKIP=true +endif + +ifeq ($(CCOMPTYPE),msvc) +CCOMP=set -o pipefail ; $(CC) $(CFLAGS) /Fe$(1) | tail -n +2 +else +CCOMP=$(CC) $(CFLAGS) -o $(1) +endif +tests: $(CASES:=.$(O)) + @for c in $(CASES); do \ + printf " ... testing '$$c':"; \ + $(MAKE) one NAME=$$c; \ + done + +promote: + +arch: $(ARCH).$(O) + +i386.obj: i386nt.asm + @set -o pipefail ; \ + $(ASM) $@ $^ | tail -n +2 diff --git a/testsuite/tests/asmgen/amd64.S b/testsuite/tests/asmgen/amd64.S new file mode 100644 index 0000000000..fb87307df0 --- /dev/null +++ b/testsuite/tests/asmgen/amd64.S @@ -0,0 +1,83 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifdef SYS_macosx +#define ALIGN 4 +#else +#define ALIGN 16 +#endif + +#ifdef SYS_macosx +#define CALL_GEN_CODE _call_gen_code +#define CAML_C_CALL _caml_c_call +#define CAML_NEGF_MASK _caml_negf_mask +#define CAML_ABSF_MASK _caml_absf_mask +#else +#define CALL_GEN_CODE call_gen_code +#define CAML_C_CALL caml_c_call +#define CAML_NEGF_MASK caml_negf_mask +#define CAML_ABSF_MASK caml_absf_mask +#endif + + .globl CALL_GEN_CODE + .align ALIGN +CALL_GEN_CODE: + pushq %rbx + pushq %rbp + pushq %r12 + pushq %r13 + pushq %r14 + pushq %r15 + movq %rdi, %r10 + movq %rsi, %rax + movq %rdx, %rbx + movq %rcx, %rdi + movq %r8, %rsi + call *%r10 + popq %r15 + popq %r14 + popq %r13 + popq %r12 + popq %rbp + popq %rbx + ret + + .globl CAML_C_CALL + .align ALIGN +CAML_C_CALL: + jmp *%rax + +#ifdef SYS_macosx + .literal16 +#elif defined(SYS_mingw64) || defined(SYS_cygwin) + .section .rodata.cst8 +#else + .section .rodata.cst8,"aM",@progbits,8 +#endif + .globl CAML_NEGF_MASK + .align ALIGN +CAML_NEGF_MASK: + .quad 0x8000000000000000, 0 + .globl CAML_ABSF_MASK + .align ALIGN +CAML_ABSF_MASK: + .quad 0x7FFFFFFFFFFFFFFF, 0 + + .comm young_limit, 8 + +#if defined(SYS_linux) + /* Mark stack as non-executable */ + .section .note.GNU-stack,"",%progbits +#endif diff --git a/testsuite/tests/asmgen/arith.cmm b/testsuite/tests/asmgen/arith.cmm new file mode 100644 index 0000000000..09156568a9 --- /dev/null +++ b/testsuite/tests/asmgen/arith.cmm @@ -0,0 +1,221 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Regression test for arithmetic instructions *) + +(function "testarith" () + (let r "R" + (let d "D" + (let x (load int "X") + (let y (load int "Y") + (let f (load float "F") + (let g (load float "G") + (addraset r 0 0) + (addraset r 1 1) + (addraset r 2 -1) + (addraset r 3 256) + (addraset r 4 65536) + (addraset r 5 16777216) + (addraset r 6 -256) + (addraset r 7 -65536) + (addraset r 8 -16777216) + + (addraset r 9 (+ x y)) + (addraset r 10 (+ x 1)) + (addraset r 11 (+ x -1)) + + (addraset r 12 (+a "R" 8)) + (addraset r 13 (+a "R" y)) + + (addraset r 14 (- x y)) + (addraset r 15 (- x 1)) + (addraset r 16 (- x -1)) + + (addraset r 17 (- "R" 8)) + (addraset r 18 (- "R" y)) + + (addraset r 19 ( * x 2)) + (addraset r 20 ( * 2 x)) + (addraset r 21 ( * x 16)) + (addraset r 22 ( * 16 x)) + (addraset r 23 ( * x 12345)) + (addraset r 24 ( * 12345 x)) + (addraset r 25 ( * x y)) + + (addraset r 26 (/ x 2)) + (addraset r 27 (/ x 16)) + (addraset r 28 (/ x 7)) + (addraset r 29 (if (!= y 0) (/ x y) 0)) + + (addraset r 30 (mod x 2)) + (addraset r 31 (mod x 16)) + (addraset r 32 (if (!= y 0) (mod x y) 0)) + + (addraset r 33 (and x y)) + (addraset r 34 (and x 3)) + (addraset r 35 (and 3 x)) + + (addraset r 36 (or x y)) + (addraset r 37 (or x 3)) + (addraset r 38 (or 3 x)) + + (addraset r 39 (xor x y)) + (addraset r 40 (xor x 3)) + (addraset r 41 (xor 3 x)) + + (addraset r 42 (<< x y)) + (addraset r 43 (<< x 1)) + (addraset r 44 (<< x 8)) + + (addraset r 45 (>>u x y)) + (addraset r 46 (>>u x 1)) + (addraset r 47 (>>u x 8)) + + (addraset r 48 (>>s x y)) + (addraset r 49 (>>s x 1)) + (addraset r 50 (>>s x 8)) + + (addraset r 51 (== x y)) + (addraset r 52 (!= x y)) + (addraset r 53 (< x y)) + (addraset r 54 (> x y)) + (addraset r 55 (<= x y)) + (addraset r 56 (>= x y)) + (addraset r 57 (== x 1)) + (addraset r 58 (!= x 1)) + (addraset r 59 (< x 1)) + (addraset r 60 (> x 1)) + (addraset r 61 (<= x 1)) + (addraset r 62 (>= x 1)) + + (addraset r 63 (==a x y)) + (addraset r 64 (!=a x y)) + (addraset r 65 (<a x y)) + (addraset r 66 (>a x y)) + (addraset r 67 (<=a x y)) + (addraset r 68 (>=a x y)) + (addraset r 69 (==a x 1)) + (addraset r 70 (!=a x 1)) + (addraset r 71 (<a x 1)) + (addraset r 72 (>a x 1)) + (addraset r 73 (<=a x 1)) + (addraset r 74 (>=a x 1)) + + (addraset r 75 (+ x (<< y 1))) + (addraset r 76 (+ x (<< y 2))) + (addraset r 77 (+ x (<< y 3))) + (addraset r 78 (- x (<< y 1))) + (addraset r 79 (- x (<< y 2))) + (addraset r 80 (- x (<< y 3))) + + (floataset d 0 0.0) + (floataset d 1 1.0) + (floataset d 2 -1.0) + (floataset d 3 (+f f g)) + (floataset d 4 (-f f g)) + (floataset d 5 ( *f f g)) + (floataset d 6 (/f f g)) + + (floataset d 7 (+f f (+f g 1.0))) + (floataset d 8 (-f f (+f g 1.0))) + (floataset d 9 ( *f f (+f g 1.0))) + (floataset d 10 (/f f (+f g 1.0))) + + (floataset d 11 (+f (+f f 1.0) g)) + (floataset d 12 (-f (+f f 1.0) g)) + (floataset d 13 ( *f (+f f 1.0) g)) + (floataset d 14 (/f (+f f 1.0) g)) + + (floataset d 15 (+f (+f f 1.0) (+f g 1.0))) + (floataset d 16 (-f (+f f 1.0) (+f g 1.0))) + (floataset d 17 ( *f (+f f 1.0) (+f g 1.0))) + (floataset d 18 (/f (+f f 1.0) (+f g 1.0))) + + (addraset r 81 (==f f g)) + (addraset r 82 (!=f f g)) + (addraset r 83 (<f f g)) + (addraset r 84 (>f f g)) + (addraset r 85 (<=f f g)) + (addraset r 86 (>=f f g)) + + (floataset d 19 (floatofint x)) + (addraset r 87 (intoffloat f)) + + (if (and (>= x 0) (< x y)) + (seq (checkbound y x) (addraset r 88 1)) + (addraset r 88 0)) + + (if (< 0 y) + (seq (checkbound y 0) (addraset r 89 1)) + (addraset r 89 0)) + + (if (< 5 y) + (seq (checkbound y 5) (addraset r 90 1)) + (addraset r 90 0)) + + (addraset r 91 (let res 1 (if (==f f g) [] (assign res 0)) res)) + (addraset r 92 (let res 1 (if (!=f f g) [] (assign res 0)) res)) + (addraset r 93 (let res 1 (if (<f f g) [] (assign res 0)) res)) + (addraset r 94 (let res 1 (if (>f f g) [] (assign res 0)) res)) + (addraset r 95 (let res 1 (if (<=f f g) [] (assign res 0)) res)) + (addraset r 96 (let res 1 (if (>=f f g) [] (assign res 0)) res)) + + (addraset r 97 (==f (+f f 1.0) (+f g 1.0))) + (addraset r 98 (!=f (+f f 1.0) (+f g 1.0))) + (addraset r 99 (<f (+f f 1.0) (+f g 1.0))) + (addraset r 100 (>f (+f f 1.0) (+f g 1.0))) + (addraset r 101 (<=f (+f f 1.0) (+f g 1.0))) + (addraset r 102 (>=f (+f f 1.0) (+f g 1.0))) + + (addraset r 103 (==f f (+f g 1.0))) + (addraset r 104 (!=f f (+f g 1.0))) + (addraset r 105 (<f f (+f g 1.0))) + (addraset r 106 (>f f (+f g 1.0))) + (addraset r 107 (<=f f (+f g 1.0))) + (addraset r 108 (>=f f (+f g 1.0))) + + (addraset r 109 (==f (+f f 1.0) g)) + (addraset r 110 (!=f (+f f 1.0) g)) + (addraset r 111 (<f (+f f 1.0) g)) + (addraset r 112 (>f (+f f 1.0) g)) + (addraset r 113 (<=f (+f f 1.0) g)) + (addraset r 114 (>=f (+f f 1.0) g)) + + (floataset d 20 (+f (floatofint x) 1.0)) + (addraset r 115 (intoffloat (+f f 1.0))) + + (floataset d 21 (+f f (load float "G"))) + (floataset d 22 (+f (load float "G") f)) + (floataset d 23 (-f f (load float "G"))) + (floataset d 24 (-f (load float "G") f)) + (floataset d 25 ( *f f (load float "G"))) + (floataset d 26 ( *f (load float "G") f)) + (floataset d 27 (/f f (load float "G"))) + (floataset d 28 (/f (load float "G") f)) + + (floataset d 29 (+f ( *f f 2.0) (load float "G"))) + (floataset d 30 (+f (load float "G") ( *f f 2.0))) + (floataset d 31 (-f ( *f f 2.0) (load float "G"))) + (floataset d 32 (-f (load float "G") ( *f f 2.0))) + (floataset d 33 ( *f ( +f f 2.0) (load float "G"))) + (floataset d 34 ( *f (load float "G") ( +f f 2.0))) + (floataset d 35 (/f ( *f f 2.0) (load float "G"))) + (floataset d 36 (/f (load float "G") ( *f f 2.0))) + + (floataset d 37 (-f f)) + (floataset d 38 (absf f)) + + (addraset r 116 (mulh x y)) +))))))) diff --git a/testsuite/tests/asmgen/arm.S b/testsuite/tests/asmgen/arm.S new file mode 100644 index 0000000000..da6d9ee74f --- /dev/null +++ b/testsuite/tests/asmgen/arm.S @@ -0,0 +1,42 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1998 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + + .text + + .global call_gen_code + .type call_gen_code, %function + .align 0 +call_gen_code: + mov ip, sp + stmfd sp!, {r4, r5, r6, r7, r8, r9, fp, ip, lr, pc} + sub fp, ip, #4 + @ r0 is function to call + @ r1, r2, r3 are arguments 1, 2, 3 + mov r4, r0 + mov r0, r1 + mov r1, r2 + mov r2, r3 + blx r4 + ldmea fp, {r4, r5, r6, r7, r8, r9, fp, sp, pc} + + .global caml_c_call + .type caml_c_call, %function + .align 0 +caml_c_call: + @ function to call is in r10 + bx r10 + +/* Mark stack as non-executable */ + .section .note.GNU-stack,"",%progbits diff --git a/testsuite/tests/asmgen/arm64.S b/testsuite/tests/asmgen/arm64.S new file mode 100644 index 0000000000..4b803d20b1 --- /dev/null +++ b/testsuite/tests/asmgen/arm64.S @@ -0,0 +1,58 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2013 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + + .globl call_gen_code + .align 2 +call_gen_code: + /* Set up stack frame and save callee-save registers */ + stp x29, x30, [sp, -160]! + add x29, sp, #0 + stp x19, x20, [sp, 16] + stp x21, x22, [sp, 32] + stp x23, x24, [sp, 48] + stp x25, x26, [sp, 64] + stp x27, x28, [sp, 80] + stp d8, d9, [sp, 96] + stp d10, d11, [sp, 112] + stp d12, d13, [sp, 128] + stp d14, d15, [sp, 144] + /* Shuffle arguments */ + mov x8, x0 + mov x0, x1 + mov x1, x2 + mov x2, x3 + mov x3, x4 + /* Call generated asm */ + blr x8 + /* Reload callee-save registers and return address */ + ldp x19, x20, [sp, 16] + ldp x21, x22, [sp, 32] + ldp x23, x24, [sp, 48] + ldp x25, x26, [sp, 64] + ldp x27, x28, [sp, 80] + ldp d8, d9, [sp, 96] + ldp d10, d11, [sp, 112] + ldp d12, d13, [sp, 128] + ldp d14, d15, [sp, 144] + ldp x29, x30, [sp], 160 + ret + + .globl caml_c_call + .align 2 +caml_c_call: + br x15 + +/* Mark stack as non-executable */ + .section .note.GNU-stack,"",%progbits diff --git a/testsuite/tests/asmgen/catch-rec.cmm b/testsuite/tests/asmgen/catch-rec.cmm new file mode 100644 index 0000000000..69208f5f4a --- /dev/null +++ b/testsuite/tests/asmgen/catch-rec.cmm @@ -0,0 +1,5 @@ +(function "catch_fact" (b:int) + (catch (exit fact b 1) + with (fact c acc) + (if (== c 0) acc + (exit fact (- c 1) ( * c acc))))) diff --git a/testsuite/tests/asmgen/catch-try.cmm b/testsuite/tests/asmgen/catch-try.cmm new file mode 100644 index 0000000000..bbbdc387b1 --- /dev/null +++ b/testsuite/tests/asmgen/catch-try.cmm @@ -0,0 +1,7 @@ + +(function "catch_exit" (b:int) + (+ 33 + (catch + (try (exit lbl 12) + with var 456) + with (lbl x) (+ x 789)))) diff --git a/testsuite/tests/asmgen/checkbound.cmm b/testsuite/tests/asmgen/checkbound.cmm new file mode 100644 index 0000000000..35206f25bb --- /dev/null +++ b/testsuite/tests/asmgen/checkbound.cmm @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(function "checkbound2" (x: int y: int) + (checkbound x y)) + +(function "checkbound1" (x: int) + (checkbound x 2)) diff --git a/testsuite/tests/asmgen/even-odd-spill.cmm b/testsuite/tests/asmgen/even-odd-spill.cmm new file mode 100644 index 0000000000..0c5f05589c --- /dev/null +++ b/testsuite/tests/asmgen/even-odd-spill.cmm @@ -0,0 +1,19 @@ +("format_odd": string "odd %d\n\000") +("format_even": string "even %d\n\000") + +(function "force_spill" (a:int) 0) + +(function "is_even" (b:int) + (catch (exit even b) + with (odd v) + (if (== v 0) 0 + (seq + (extcall "printf_int" "format_odd" v unit) + (let v2 (- v 1) + (app "force_spill" 0 int) + (exit even v2)))) + and (even v) + (if (== v 0) 1 + (seq + (extcall "printf_int" "format_even" v unit) + (exit odd (- v 1)))))) diff --git a/testsuite/tests/asmgen/even-odd.cmm b/testsuite/tests/asmgen/even-odd.cmm new file mode 100644 index 0000000000..db79f1cab8 --- /dev/null +++ b/testsuite/tests/asmgen/even-odd.cmm @@ -0,0 +1,8 @@ +(function "is_even" (b:int) + (catch (exit even b) + with (odd v) + (if (== v 0) 0 + (exit even (- v 1))) + and (even v) + (if (== v 0) 1 + (exit odd (- v 1)))))
\ No newline at end of file diff --git a/testsuite/tests/asmgen/fib.cmm b/testsuite/tests/asmgen/fib.cmm new file mode 100644 index 0000000000..49de4ba12e --- /dev/null +++ b/testsuite/tests/asmgen/fib.cmm @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(function "fib" (n: int) + (if (< n 2) + 1 + (+ (app "fib" (- n 1) int) + (app "fib" (- n 2) int)))) diff --git a/testsuite/tests/asmgen/i386.S b/testsuite/tests/asmgen/i386.S new file mode 100644 index 0000000000..26dc83fcac --- /dev/null +++ b/testsuite/tests/asmgen/i386.S @@ -0,0 +1,59 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Linux with ELF binaries does not prefix identifiers with _. + Linux with a.out binaries, FreeBSD, and NextStep do. */ + +#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \ + || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu) +#define G(x) x +#define FUNCTION_ALIGN 16 +#else +#define G(x) _##x +#define FUNCTION_ALIGN 4 +#endif + + .globl G(call_gen_code) + .align FUNCTION_ALIGN +G(call_gen_code): + pushl %ebp + movl %esp,%ebp + pushl %ebx + pushl %esi + pushl %edi + movl 12(%ebp),%eax + movl 16(%ebp),%ebx + movl 20(%ebp),%ecx + movl 24(%ebp),%edx + call *8(%ebp) + popl %edi + popl %esi + popl %ebx + popl %ebp + ret + + .globl G(caml_c_call) + .align FUNCTION_ALIGN +G(caml_c_call): + jmp *%eax + + .comm G(caml_exception_pointer), 4 + .comm G(young_ptr), 4 + .comm G(young_start), 4 + +#if defined(SYS_linux_elf) + /* Mark stack as non-executable */ + .section .note.GNU-stack,"",%progbits +#endif diff --git a/testsuite/tests/asmgen/i386nt.asm b/testsuite/tests/asmgen/i386nt.asm new file mode 100644 index 0000000000..618d41c949 --- /dev/null +++ b/testsuite/tests/asmgen/i386nt.asm @@ -0,0 +1,65 @@ +;*********************************************************************; +; ; +; OCaml ; +; ; +; Xavier Leroy, projet Cristal, INRIA Rocquencourt ; +; ; +; Copyright 1996 Institut National de Recherche en Informatique et ; +; en Automatique. All rights reserved. This file is distributed ; +; under the terms of the Q Public License version 1.0. ; +; ; +;*********************************************************************; + + .386 + .MODEL FLAT + + .CODE + PUBLIC _call_gen_code + ALIGN 4 +_call_gen_code: + push ebp + mov ebp, esp + push ebx + push esi + push edi + mov eax, [ebp+12] + mov ebx, [ebp+16] + mov ecx, [ebp+20] + mov edx, [ebp+24] + call DWORD PTR [ebp+8] + pop edi + pop esi + pop ebx + pop ebp + ret + + PUBLIC _caml_c_call + ALIGN 4 +_caml_c_call: + ffree st(0) + ffree st(1) + ffree st(2) + ffree st(3) + jmp eax + + PUBLIC _caml_call_gc + PUBLIC _caml_alloc + PUBLIC _caml_alloc1 + PUBLIC _caml_alloc2 + PUBLIC _caml_alloc3 +_caml_call_gc: +_caml_alloc: +_caml_alloc1: +_caml_alloc2: +_caml_alloc3: + int 3 + + .DATA + PUBLIC _caml_exception_pointer +_caml_exception_pointer dword 0 + PUBLIC _young_ptr +_young_ptr dword 0 + PUBLIC _young_limit +_young_limit dword 0 + + END diff --git a/testsuite/tests/asmgen/integr.cmm b/testsuite/tests/asmgen/integr.cmm new file mode 100644 index 0000000000..c82d60b247 --- /dev/null +++ b/testsuite/tests/asmgen/integr.cmm @@ -0,0 +1,31 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(function "square" (x: float) + ( *f x x)) + +(function "integr" (f: addr low: float high: float n: int) + (let (h (/f (-f high low) (floatofint n)) + x low + s 0.0 + i n) + (while (> i 0) + (assign s (+f s (app f x float))) + (assign x (+f x h)) + (assign i (- i 1))) + ( *f s h))) + +(function "test" (n: int) + (app "integr" "square" 0.0 1.0 n float)) diff --git a/testsuite/tests/asmgen/lexcmm.mli b/testsuite/tests/asmgen/lexcmm.mli new file mode 100644 index 0000000000..f9fe6afadf --- /dev/null +++ b/testsuite/tests/asmgen/lexcmm.mli @@ -0,0 +1,10 @@ +val token: Lexing.lexbuf -> Parsecmm.token + +type error = + Illegal_character + | Unterminated_comment + | Unterminated_string + +exception Error of error + +val report_error: Lexing.lexbuf -> error -> unit diff --git a/testsuite/tests/asmgen/lexcmm.mll b/testsuite/tests/asmgen/lexcmm.mll new file mode 100644 index 0000000000..a946f6aa62 --- /dev/null +++ b/testsuite/tests/asmgen/lexcmm.mll @@ -0,0 +1,241 @@ +{ +open Parsecmm + +type error = + Illegal_character + | Unterminated_comment + | Unterminated_string + +exception Error of error + +(* For nested comments *) + +let comment_depth = ref 0 + +(* The table of keywords *) + +let keyword_table = + Misc.create_hashtable 149 [ + "absf", ABSF; + "addr", ADDR; + "align", ALIGN; + "alloc", ALLOC; + "and", AND; + "app", APPLY; + "assign", ASSIGN; + "byte", BYTE; + "case", CASE; + "catch", CATCH; + "checkbound", CHECKBOUND; + "data", DATA; + "exit", EXIT; + "extcall", EXTCALL; + "float", FLOAT; + "float32", FLOAT32; + "float64", FLOAT64; + "floatofint", FLOATOFINT; + "function", FUNCTION; + "global", GLOBAL; + "half", HALF; + "if", IF; + "int", INT; + "int32", INT32; + "intoffloat", INTOFFLOAT; + "string", KSTRING; + "let", LET; + "load", LOAD; + "mod", MODI; + "mulh", MULH; + "or", OR; + "proj", PROJ; + "raise_withtrace", RAISE Cmm.Raise_withtrace; + "raise_notrace", RAISE Cmm.Raise_notrace; + "seq", SEQ; + "signed", SIGNED; + "skip", SKIP; + "store", STORE; + "switch", SWITCH; + "try", TRY; + "unit", UNIT; + "unsigned", UNSIGNED; + "val", VAL; + "while", WHILE; + "with", WITH; + "xor", XOR; + "addraref", ADDRAREF; + "intaref", INTAREF; + "floataref", FLOATAREF; + "addraset", ADDRASET; + "intaset", INTASET; + "floataset", FLOATASET +] + +(* To buffer string literals *) + +let initial_string_buffer = Bytes.create 256 +let string_buff = ref initial_string_buffer +let string_index = ref 0 + +let reset_string_buffer () = + string_buff := initial_string_buffer; + string_index := 0 + +let store_string_char c = + if !string_index >= Bytes.length (!string_buff) then begin + let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in + Bytes.blit (!string_buff) 0 new_buff 0 (Bytes.length (!string_buff)); + string_buff := new_buff + end; + Bytes.unsafe_set (!string_buff) (!string_index) c; + incr string_index + +let get_stored_string () = + let s = Bytes.sub_string (!string_buff) 0 (!string_index) in + string_buff := initial_string_buffer; + s + +(* To translate escape sequences *) + +let char_for_backslash = function + 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + +let char_for_decimal_code lexbuf i = + Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48)) + +(* Error report *) + +let report_error lexbuf msg = + prerr_string "Lexical error around character "; + prerr_int (Lexing.lexeme_start lexbuf); + match msg with + Illegal_character -> + prerr_string ": illegal character" + | Unterminated_comment -> + prerr_string ": unterminated comment" + | Unterminated_string -> + prerr_string ": unterminated string" + +} + +let newline = ('\013'* '\010') + +rule token = parse + newline + { Lexing.new_line lexbuf; token lexbuf } + | [' ' '\009' '\012'] + + { token lexbuf } + | "+a" { ADDA } + | "+v" { ADDV } + | "+f" { ADDF } + | "+" { ADDI } + | ">>s" { ASR } + | ":" { COLON } + | "/f" { DIVF } + | "/" { DIVI } + | eof { EOF } + | "==a" { EQA } + | "==f" { EQF } + | "==" { EQI } + | ">=a" { GEA } + | ">=f" { GEF } + | ">=" { GEI } + | ">a" { GTA } + | ">f" { GTF } + | ">" { GTI } + | "[" { LBRACKET } + | "<=a" { LEA } + | "<=f" { LEF } + | "<=" { LEI } + | "(" { LPAREN } + | "<<" { LSL } + | ">>u" { LSR } + | "<a" { LTA } + | "<f" { LTF } + | "<" { LTI } + | "*f" { MULF } + | "*" { STAR } + | "!=a" { NEA } + | "!=f" { NEF } + | "!=" { NEI } + | "]" { RBRACKET } + | ")" { RPAREN } + | "-f" { SUBF } + | "-" { SUBI } + | '-'? (['0'-'9']+ | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+ + | "0o" ['0'-'7']+ | "0b" ['0'-'1']+) + { INTCONST(int_of_string(Lexing.lexeme lexbuf)) } + | '-'? ['0'-'9']+ 'a' + { let s = Lexing.lexeme lexbuf in + POINTER(int_of_string(String.sub s 0 (String.length s - 1))) } + | '-'? ['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)? + { FLOATCONST(Lexing.lexeme lexbuf) } + | ['A'-'Z' 'a'-'z' '\223'-'\246' '\248'-'\255' ] + (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' + '\'' '0'-'9' ]) * '/'? (['0'-'9'] *) + { let s = Lexing.lexeme lexbuf in + try + Hashtbl.find keyword_table s + with Not_found -> + IDENT s } + | "\"" + { reset_string_buffer(); + string lexbuf; + STRING (get_stored_string()) } + | "(*" + { comment_depth := 1; + comment lexbuf; + token lexbuf } + | '{' ['A' - 'Z' 'a'-'z' '/' ',' '.' '-' '_' ' ''0'-'9']+ + ':' [ '0'-'9' ]+ ',' ['0'-'9' ]+ '-' ['0'-'9' ]+ '}' + { + let loc_s = Lexing.lexeme lexbuf in + let pos_fname, pos_lnum, start, end_ = + Scanf.sscanf loc_s "{%s@:%i,%i-%i}" (fun file line start end_ -> + (file, line, start, end_)) + in + let loc_start = + Lexing.{ pos_fname; pos_lnum; pos_bol = 0; pos_cnum = start } + in + let loc_end = + Lexing.{ pos_fname; pos_lnum; pos_bol = 0; pos_cnum = end_ } + in + let location = Location.{ loc_start; loc_end; loc_ghost = false } in + LOCATION location } + | _ { raise(Error(Illegal_character)) } + +and comment = parse + "(*" + { comment_depth := succ !comment_depth; comment lexbuf } + | "*)" + { comment_depth := pred !comment_depth; + if !comment_depth > 0 then comment lexbuf } + | eof + { raise (Error(Unterminated_comment)) } + | newline + { Lexing.new_line lexbuf; comment lexbuf } + | _ + { comment lexbuf } + +and string = parse + '"' + { () } + | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] + + { string lexbuf } + | '\\' ['\\' '"' 'n' 't' 'b' 'r'] + { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); + string lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { store_string_char(char_for_decimal_code lexbuf 1); + string lexbuf } + | eof + { raise (Error(Unterminated_string)) } + | _ + { store_string_char(Lexing.lexeme_char lexbuf 0); + string lexbuf } + diff --git a/testsuite/tests/asmgen/main.c b/testsuite/tests/asmgen/main.c new file mode 100644 index 0000000000..5f305731f0 --- /dev/null +++ b/testsuite/tests/asmgen/main.c @@ -0,0 +1,125 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#include <stddef.h> +#include <stdio.h> +#include <stdlib.h> +#include <time.h> + +void caml_ml_array_bound_error(void) +{ + fprintf(stderr, "Fatal error: out-of-bound access in array or string\n"); + exit(2); +} + +void print_string(char * s) +{ + fputs(s, stdout); +} + +void printf_int(char * fmt, int arg) +{ + printf(fmt, arg); +} + +#ifdef SORT + +int cmpint(const void * i, const void * j) +{ + long vi = *((long *) i); + long vj = *((long *) j); + if (vi == vj) return 0; + if (vi < vj) return -1; + return 1; +} + +#endif + +int main(int argc, char **argv) +{ +#ifdef UNIT_INT + { extern long FUN(void); + extern long call_gen_code(long (*)(void)); + printf("%ld\n", call_gen_code(FUN)); + } +#else + if (argc < 2) { + fprintf(stderr, "Usage: %s [int arg]\n", argv[0]); + exit(2); + } +#ifdef INT_INT + { extern long FUN(long); + extern long call_gen_code(long (*)(long), long); + printf("%ld\n", call_gen_code(FUN, atoi(argv[1]))); + } +#endif +#ifdef INT_FLOAT + { extern double FUN(long); + extern double call_gen_code(double (*)(long), long); + printf("%f\n", call_gen_code(FUN, atoi(argv[1]))); + } +#endif +#ifdef SORT + { extern void FUN(long, long, long *); + extern void call_gen_code(void (*)(long, long, long *), long, long, long *); + long n; + long * a, * b; + long i; + + srand(argc >= 3 ? atoi(argv[2]) : time((time_t *) 0)); + n = atoi(argv[1]); + a = (long *) malloc(n * sizeof(long)); + for (i = 0 ; i < n; i++) a[i] = rand() & 0xFFF; +#ifdef DEBUG + for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n"); +#endif + b = (long *) malloc(n * sizeof(long)); + for (i = 0; i < n; i++) b[i] = a[i]; + call_gen_code(FUN, 0, n-1, a); +#ifdef DEBUG + for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n"); +#endif + qsort(b, n, sizeof(long), cmpint); + for (i = 0; i < n; i++) { + if (a[i] != b[i]) { printf("Bug!\n"); return 2; } + } + printf("OK\n"); + } +#endif +#endif +#ifdef CHECKBOUND + { extern void checkbound1(long), checkbound2(long, long); + extern void call_gen_code(void *, ...); + long x, y; + x = atoi(argv[1]); + if (argc >= 3) { + y = atoi(argv[2]); + if ((unsigned long) x < (unsigned long) y) + printf("Should not trap\n"); + else + printf("Should trap\n"); + call_gen_code(checkbound2, y, x); + } else { + if (2 < (unsigned long) x) + printf("Should not trap\n"); + else + printf("Should trap\n"); + call_gen_code(checkbound1, x); + } + printf("OK\n"); + } +#endif + return 0; +} diff --git a/testsuite/tests/asmgen/main.ml b/testsuite/tests/asmgen/main.ml new file mode 100644 index 0000000000..6970f99a93 --- /dev/null +++ b/testsuite/tests/asmgen/main.ml @@ -0,0 +1,66 @@ +open Clflags +let write_asm_file = ref false + +let compile_file filename = + if !write_asm_file then begin + let out_name = Filename.chop_extension filename ^ ".s" in + Emitaux.output_channel := open_out out_name + end; (* otherwise, stdout *) + Compilenv.reset "test"; + Emit.begin_assembly(); + let ic = open_in filename in + let lb = Lexing.from_channel ic in + lb.Lexing.lex_curr_p <- { lb.Lexing.lex_curr_p with pos_fname = filename }; + try + while true do + Asmgen.compile_phrase Format.std_formatter + (Parsecmm.phrase Lexcmm.token lb) + done + with + End_of_file -> + close_in ic; Emit.end_assembly(); + if !write_asm_file then close_out !Emitaux.output_channel + | Lexcmm.Error msg -> + close_in ic; Lexcmm.report_error lb msg + | Parsing.Parse_error -> + close_in ic; + let start_p = Lexing.lexeme_start_p lb in + let end_p = Lexing.lexeme_end_p lb in + Printf.eprintf "File \"%s\", line %i, characters %i-%i:\n\ + Syntax error.\n%!" + filename + start_p.Lexing.pos_lnum + (start_p.Lexing.pos_cnum - start_p.Lexing.pos_bol) + (end_p.Lexing.pos_cnum - start_p.Lexing.pos_bol) + | Parsecmmaux.Error msg -> + close_in ic; Parsecmmaux.report_error msg + | x -> + close_in ic; raise x + +let usage = "Usage: codegen <options> <files>\noptions are:" + +let main() = + Arg.parse [ + "-S", Arg.Set write_asm_file, + " Output file to filename.s (default is stdout)"; + "-g", Arg.Set Clflags.debug, ""; + "-dcmm", Arg.Set dump_cmm, ""; + "-dcse", Arg.Set dump_cse, ""; + "-dsel", Arg.Set dump_selection, ""; + "-dlive", Arg.Unit(fun () -> dump_live := true; + Printmach.print_live := true), ""; + "-dspill", Arg.Set dump_spill, ""; + "-dsplit", Arg.Set dump_split, ""; + "-dinterf", Arg.Set dump_interf, ""; + "-dprefer", Arg.Set dump_prefer, ""; + "-dalloc", Arg.Set dump_regalloc, ""; + "-dreload", Arg.Set dump_reload, ""; + "-dscheduling", Arg.Set dump_scheduling, ""; + "-dlinear", Arg.Set dump_linear, ""; + "-dtimings", Arg.Unit (fun () -> profile_columns := [ `Time ]), ""; + ] compile_file usage + +let () = + main (); + Profile.print Format.std_formatter !Clflags.profile_columns; + exit 0 diff --git a/testsuite/tests/asmgen/mainarith.c b/testsuite/tests/asmgen/mainarith.c new file mode 100644 index 0000000000..de876bfead --- /dev/null +++ b/testsuite/tests/asmgen/mainarith.c @@ -0,0 +1,343 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#include <stdio.h> +#include <math.h> +#include <time.h> +#include <stdlib.h> +#include <string.h> + +#include "../../../byterun/caml/config.h" +#define FMT ARCH_INTNAT_PRINTF_FORMAT + +void caml_ml_array_bound_error(void) +{ + fprintf(stderr, "Fatal error: out-of-bound access in array or string\n"); + exit(2); +} + +intnat R[200]; +double D[40]; +intnat X, Y; +double F, G; + +#define INTTEST(arg,res) \ + { intnat result = (res); \ + if (arg != result) \ + printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: " \ + "result %"FMT"d, expected %"FMT"d\n", \ + #arg, #res, X, Y, arg, result); \ + } +#define INTFLOATTEST(arg,res) \ + { intnat result = (res); \ + if (arg != result) \ + printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\ + "result %"FMT"d, expected %"FMT"d\n", \ + #arg, #res, F, G, arg, result); \ + } +#define FLOATTEST(arg,res) \ + { double result = (res); \ + if (arg < result || arg > result) \ + printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\ + "result %.15g, expected %.15g\n", \ + #arg, #res, F, G, arg, result); \ + } +#define FLOATINTTEST(arg,res) \ + { double result = (res); \ + if (arg < result || arg > result) \ + printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: "\ + "result %.15g, expected %.15g\n", \ + #arg, #res, X, Y, arg, result); \ + } + +extern void call_gen_code(void (*)(void)); +extern void testarith(void); +static intnat mulhs(intnat x, intnat y); + +void do_test(void) +{ + call_gen_code(testarith); + + INTTEST(R[0], 0); + INTTEST(R[1], 1); + INTTEST(R[2], -1); + INTTEST(R[3], 256); + INTTEST(R[4], 65536); + INTTEST(R[5], 16777216); + INTTEST(R[6], -256); + INTTEST(R[7], -65536); + INTTEST(R[8], -16777216); + + INTTEST(R[9], (X + Y)); + INTTEST(R[10], (X + 1)); + INTTEST(R[11], (X + -1)); + + INTTEST(R[12], ((intnat) ((char *)R + 8))); + INTTEST(R[13], ((intnat) ((char *)R + Y))); + + INTTEST(R[14], (X - Y)); + INTTEST(R[15], (X - 1)); + INTTEST(R[16], (X - -1)); + + INTTEST(R[17], ((intnat) ((uintnat)R - 8))); + INTTEST(R[18], ((intnat) ((char *)R - Y))); + + INTTEST(R[19], (X * 2)); + INTTEST(R[20], (2 * X)); + INTTEST(R[21], (X * 16)); + INTTEST(R[22], (16 * X)); + INTTEST(R[23], (X * 12345)); + INTTEST(R[24], (12345 * X)); + INTTEST(R[25], (X * Y)); + + INTTEST(R[26], (X / 2)); + INTTEST(R[27], (X / 16)); + INTTEST(R[28], (X / 7)); + INTTEST(R[29], (Y != 0 ? X / Y : 0)); + + INTTEST(R[30], (X % 2)); + INTTEST(R[31], (X % 16)); + INTTEST(R[32], (Y != 0 ? X % Y : 0)); + + INTTEST(R[33], (X & Y)); + INTTEST(R[34], (X & 3)); + INTTEST(R[35], (3 & X)); + + INTTEST(R[36], (X | Y)); + INTTEST(R[37], (X | 3)); + INTTEST(R[38], (3 | X)); + + INTTEST(R[39], (X ^ Y)); + INTTEST(R[40], (X ^ 3)); + INTTEST(R[41], (3 ^ X)); + + INTTEST(R[42], (X << Y)); + INTTEST(R[43], (X << 1)); + INTTEST(R[44], (X << 8)); + + INTTEST(R[45], ((uintnat) X >> Y)); + INTTEST(R[46], ((uintnat) X >> 1)); + INTTEST(R[47], ((uintnat) X >> 8)); + + INTTEST(R[48], (X >> Y)); + INTTEST(R[49], (X >> 1)); + INTTEST(R[50], (X >> 8)); + + INTTEST(R[51], (X == Y)); + INTTEST(R[52], (X != Y)); + INTTEST(R[53], (X < Y)); + INTTEST(R[54], (X > Y)); + INTTEST(R[55], (X <= Y)); + INTTEST(R[56], (X >= Y)); + INTTEST(R[57], (X == 1)); + INTTEST(R[58], (X != 1)); + INTTEST(R[59], (X < 1)); + INTTEST(R[60], (X > 1)); + INTTEST(R[61], (X <= 1)); + INTTEST(R[62], (X >= 1)); + + INTTEST(R[63], ((char *)X == (char *)Y)); + INTTEST(R[64], ((char *)X != (char *)Y)); + INTTEST(R[65], ((char *)X < (char *)Y)); + INTTEST(R[66], ((char *)X > (char *)Y)); + INTTEST(R[67], ((char *)X <= (char *)Y)); + INTTEST(R[68], ((char *)X >= (char *)Y)); + INTTEST(R[69], ((char *)X == (char *)1)); + INTTEST(R[70], ((char *)X != (char *)1)); + INTTEST(R[71], ((char *)X < (char *)1)); + INTTEST(R[72], ((char *)X > (char *)1)); + INTTEST(R[73], ((char *)X <= (char *)1)); + INTTEST(R[74], ((char *)X >= (char *)1)); + + INTTEST(R[75], (X + (Y << 1))); + INTTEST(R[76], (X + (Y << 2))); + INTTEST(R[77], (X + (Y << 3))); + INTTEST(R[78], (X - (Y << 1))); + INTTEST(R[79], (X - (Y << 2))); + INTTEST(R[80], (X - (Y << 3))); + + FLOATTEST(D[0], 0.0); + FLOATTEST(D[1], 1.0); + FLOATTEST(D[2], -1.0); + FLOATTEST(D[3], (F + G)); + FLOATTEST(D[4], (F - G)); + FLOATTEST(D[5], (F * G)); + FLOATTEST(D[6], F / G); + + FLOATTEST(D[7], (F + (G + 1.0))); + FLOATTEST(D[8], (F - (G + 1.0))); + FLOATTEST(D[9], (F * (G + 1.0))); + FLOATTEST(D[10], F / (G + 1.0)); + + FLOATTEST(D[11], ((F + 1.0) + G)); + FLOATTEST(D[12], ((F + 1.0) - G)); + FLOATTEST(D[13], ((F + 1.0) * G)); + FLOATTEST(D[14], (F + 1.0) / G); + + FLOATTEST(D[15], ((F + 1.0) + (G + 1.0))); + FLOATTEST(D[16], ((F + 1.0) - (G + 1.0))); + FLOATTEST(D[17], ((F + 1.0) * (G + 1.0))); + FLOATTEST(D[18], (F + 1.0) / (G + 1.0)); + + INTFLOATTEST(R[81], (F == G)); + INTFLOATTEST(R[82], (F != G)); + INTFLOATTEST(R[83], (F < G)); + INTFLOATTEST(R[84], (F > G)); + INTFLOATTEST(R[85], (F <= G)); + INTFLOATTEST(R[86], (F >= G)); + + FLOATINTTEST(D[19], (double) X); + INTFLOATTEST(R[87], (intnat) F); + + INTTEST(R[88], (X >= 0) && (X < Y)); + INTTEST(R[89], (0 < Y)); + INTTEST(R[90], (5 < Y)); + + INTFLOATTEST(R[91], (F == G)); + INTFLOATTEST(R[92], (F != G)); + INTFLOATTEST(R[93], (F < G)); + INTFLOATTEST(R[94], (F > G)); + INTFLOATTEST(R[95], (F <= G)); + INTFLOATTEST(R[96], (F >= G)); + + INTFLOATTEST(R[97], (F + 1.0 == G + 1.0)); + INTFLOATTEST(R[98], (F + 1.0 != G + 1.0)); + INTFLOATTEST(R[99], (F + 1.0 < G + 1.0)); + INTFLOATTEST(R[100], (F + 1.0 > G + 1.0)); + INTFLOATTEST(R[101], (F + 1.0 <= G + 1.0)); + INTFLOATTEST(R[102], (F + 1.0 >= G + 1.0)); + + INTFLOATTEST(R[103], (F == G + 1.0)); + INTFLOATTEST(R[104], (F != G + 1.0)); + INTFLOATTEST(R[105], (F < G + 1.0)); + INTFLOATTEST(R[106], (F > G + 1.0)); + INTFLOATTEST(R[107], (F <= G + 1.0)); + INTFLOATTEST(R[108], (F >= G + 1.0)); + + INTFLOATTEST(R[109], (F + 1.0 == G)); + INTFLOATTEST(R[110], (F + 1.0 != G)); + INTFLOATTEST(R[111], (F + 1.0 < G)); + INTFLOATTEST(R[112], (F + 1.0 > G)); + INTFLOATTEST(R[113], (F + 1.0 <= G)); + INTFLOATTEST(R[114], (F + 1.0 >= G)); + + FLOATINTTEST(D[20], ((double) X) + 1.0); + INTFLOATTEST(R[115], (intnat)(F + 1.0)); + + FLOATTEST(D[21], F + G); + FLOATTEST(D[22], G + F); + FLOATTEST(D[23], F - G); + FLOATTEST(D[24], G - F); + FLOATTEST(D[25], F * G); + FLOATTEST(D[26], G * F); + FLOATTEST(D[27], F / G); + FLOATTEST(D[28], G / F); + + FLOATTEST(D[29], (F * 2.0) + G); + FLOATTEST(D[30], G + (F * 2.0)); + FLOATTEST(D[31], (F * 2.0) - G); + FLOATTEST(D[32], G - (F * 2.0)); + FLOATTEST(D[33], (F + 2.0) * G); + FLOATTEST(D[34], G * (F + 2.0)); + FLOATTEST(D[35], (F * 2.0) / G); + FLOATTEST(D[36], G / (F * 2.0)); + + FLOATTEST(D[37], - F); + FLOATTEST(D[38], fabs(F)); + + INTTEST(R[116], mulhs(X, Y)); +} + +/* Multiply-high signed. Hacker's Delight section 8.2 */ + +#define HALFSIZE (4 * sizeof(intnat)) +#define HALFMASK (((intnat)1 << HALFSIZE) - 1) + +static intnat mulhs(intnat u, intnat v) +{ + uintnat u0, v0, w0; + intnat u1, v1, w1, w2, t; + u0 = u & HALFMASK; u1 = u >> HALFSIZE; + v0 = v & HALFMASK; v1 = v >> HALFSIZE; + w0 = u0*v0; + t = u1*v0 + (w0 >> HALFSIZE); + w1 = t & HALFMASK; + w2 = t >> HALFSIZE; + w1 = u0*v1 + w1; + return u1*v1 + w2 + (w1 >> HALFSIZE); +} + +/* A simple linear congruential PRNG */ + +#ifdef ARCH_SIXTYFOUR +#define RAND_A 6364136223846793005ULL +#define RAND_C 1442695040888963407ULL +#else +#define RAND_A 214013U +#define RAND_C 2531011U +#endif + +static intnat rnd(void) +{ + static uintnat seed = 0; + seed = seed * RAND_A + RAND_C; + return (intnat) seed; +} + +/* Test harness */ + +#define NUM_RANDOM_ITERATIONS 1000000 + +int main(int argc, char **argv) +{ + int i; + double weird[4]; + + if (argc >= 5) { + X = atoi(argv[1]); + Y = atoi(argv[2]); + sscanf(argv[3], "%lf", &F); + sscanf(argv[4], "%lf", &G); + do_test(); + return 0; + } + printf("Testing -2...2\n"); + for(Y = -2; Y <= 2; Y++) { + for (X = -2; X <= 2; X++) { + F = X; G = Y; do_test(); + } + } + if (!(argc >= 2 && strcmp(argv[1], "noinf"))) { + printf("Testing special FP values\n"); + weird[0] = 0.0; + weird[1] = 1.0 / weird[0]; /* +infty */ + weird[2] = -1.0 / weird[0]; /* -infty */ + weird[3] = 0.0 / weird[0]; /* NaN */ + for (X = 0; X < 4; X++) { + for (Y = 0; Y < 4; Y++) { + F = weird[X]; G = weird[Y]; do_test(); + } + } + } + printf("Testing %d random values\n", NUM_RANDOM_ITERATIONS); + for (i = 0; i < NUM_RANDOM_ITERATIONS; i++) { + X = rnd(); + Y = rnd(); + F = X / 1e3; + G = Y / 1e3; + do_test(); + } + return 0; +} diff --git a/testsuite/tests/asmgen/parsecmm.mly b/testsuite/tests/asmgen/parsecmm.mly new file mode 100644 index 0000000000..52a6dfad1d --- /dev/null +++ b/testsuite/tests/asmgen/parsecmm.mly @@ -0,0 +1,359 @@ +/* A simple parser for C-- */ + +%{ +open Cmm +open Parsecmmaux + +let rec make_letdef def body = + match def with + [] -> body + | (id, def) :: rem -> + unbind_ident id; + Clet(id, def, make_letdef rem body) + +let make_switch n selector caselist = + let index = Array.make n 0 in + let casev = Array.of_list caselist in + let actv = Array.make (Array.length casev) (Cexit(0,[])) in + for i = 0 to Array.length casev - 1 do + let (posl, e) = casev.(i) in + List.iter (fun pos -> index.(pos) <- i) posl; + actv.(i) <- e + done; + Cswitch(selector, index, actv, Debuginfo.none) + +let access_array base numelt size = + match numelt with + Cconst_int 0 -> base + | Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)], Debuginfo.none) + | _ -> Cop(Cadda, [base; + Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)], + Debuginfo.none)], + Debuginfo.none) + +%} + +%token ABSF +%token ADDA +%token ADDF +%token ADDI +%token ADDV +%token ADDR +%token ALIGN +%token ALLOC +%token AND +%token APPLY +%token ASR +%token ASSIGN +%token BYTE +%token CASE +%token CATCH +%token CHECKBOUND +%token COLON +%token DATA +%token DIVF +%token DIVI +%token EOF +%token EQA +%token EQF +%token EQI +%token EXIT +%token EXTCALL +%token FLOAT +%token FLOAT32 +%token FLOAT64 +%token <string> FLOATCONST +%token FLOATOFINT +%token FUNCTION +%token GEA +%token GEF +%token GEI +%token GLOBAL +%token GTA +%token GTF +%token GTI +%token HALF +%token <string> IDENT +%token IF +%token INT +%token INT32 +%token <int> INTCONST +%token INTOFFLOAT +%token KSTRING +%token LBRACKET +%token LEA +%token LEF +%token LEI +%token LET +%token LOAD +%token <Location.t> LOCATION +%token LPAREN +%token LSL +%token LSR +%token LTA +%token LTF +%token LTI +%token MODI +%token MULF +%token MULH +%token MULI +%token NEA +%token NEF +%token NEI +%token OR +%token <int> POINTER +%token PROJ +%token <Cmm.raise_kind> RAISE +%token RBRACKET +%token RPAREN +%token SEQ +%token SIGNED +%token SKIP +%token STAR +%token STORE +%token <string> STRING +%token SUBF +%token SUBI +%token SWITCH +%token TRY +%token UNIT +%token UNSIGNED +%token VAL +%token WHILE +%token WITH +%token XOR +%token ADDRAREF +%token INTAREF +%token FLOATAREF +%token ADDRASET +%token INTASET +%token FLOATASET + +%start phrase +%type <Cmm.phrase> phrase + +%% + +phrase: + fundecl { Cfunction $1 } + | datadecl { Cdata $1 } + | EOF { raise End_of_file } +; +fundecl: + LPAREN FUNCTION fun_name LPAREN params RPAREN sequence RPAREN + { List.iter (fun (id, ty) -> unbind_ident id) $5; + {fun_name = $3; fun_args = $5; fun_body = $7; fun_fast = true; + fun_dbg = debuginfo ()} } +; +fun_name: + STRING { $1 } + | IDENT { $1 } +params: + oneparam params { $1 :: $2 } + | /**/ { [] } +; +oneparam: + IDENT COLON machtype { (bind_ident $1, $3) } +; +machtype: + UNIT { [||] } + | componentlist { Array.of_list(List.rev $1) } +; +component: + VAL { Val } + | ADDR { Addr } + | INT { Int } + | FLOAT { Float } +; +componentlist: + component { [$1] } + | componentlist STAR component { $3 :: $1 } +; +expr: + INTCONST { Cconst_int $1 } + | FLOATCONST { Cconst_float (float_of_string $1) } + | STRING { Cconst_symbol $1 } + | POINTER { Cconst_pointer $1 } + | IDENT { Cvar(find_ident $1) } + | LBRACKET RBRACKET { Ctuple [] } + | LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 } + | LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_ident $3, $4) } + | LPAREN APPLY location expr exprlist machtype RPAREN + { Cop(Capply $6, $4 :: List.rev $5, debuginfo ?loc:$3 ()) } + | LPAREN EXTCALL STRING exprlist machtype RPAREN + {Cop(Cextcall($3, $5, false, None), List.rev $4, debuginfo ())} + | LPAREN ALLOC exprlist RPAREN { Cop(Calloc, List.rev $3, debuginfo ()) } + | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3], debuginfo ()) } + | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4], debuginfo ()) } + | LPAREN unaryop expr RPAREN { Cop($2, [$3], debuginfo ()) } + | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4], debuginfo ()) } + | LPAREN SEQ sequence RPAREN { $3 } + | LPAREN IF expr expr expr RPAREN { Cifthenelse($3, $4, $5) } + | LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 } + | LPAREN WHILE expr sequence RPAREN + { let body = + match $3 with + Cconst_int x when x <> 0 -> $4 + | _ -> Cifthenelse($3, $4, (Cexit(0,[]))) in + Ccatch(Recursive, [0, [], Cloop body], Ctuple []) } + | LPAREN EXIT IDENT exprlist RPAREN + { Cexit(find_label $3, List.rev $4) } + | LPAREN CATCH sequence WITH catch_handlers RPAREN + { let handlers = $5 in + List.iter (fun (_, l, _) -> List.iter unbind_ident l) handlers; + Ccatch(Recursive, handlers, $3) } + | EXIT { Cexit(0,[]) } + | LPAREN TRY sequence WITH bind_ident sequence RPAREN + { unbind_ident $5; Ctrywith($3, $5, $6) } + | LPAREN VAL expr expr RPAREN + { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr], + debuginfo ()) } + | LPAREN ADDRAREF expr expr RPAREN + { Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr], + Debuginfo.none) } + | LPAREN INTAREF expr expr RPAREN + { Cop(Cload (Word_int, Mutable), [access_array $3 $4 Arch.size_int], + Debuginfo.none) } + | LPAREN FLOATAREF expr expr RPAREN + { Cop(Cload (Double_u, Mutable), [access_array $3 $4 Arch.size_float], + Debuginfo.none) } + | LPAREN ADDRASET expr expr expr RPAREN + { Cop(Cstore (Word_val, Assignment), + [access_array $3 $4 Arch.size_addr; $5], Debuginfo.none) } + | LPAREN INTASET expr expr expr RPAREN + { Cop(Cstore (Word_int, Assignment), + [access_array $3 $4 Arch.size_int; $5], Debuginfo.none) } + | LPAREN FLOATASET expr expr expr RPAREN + { Cop(Cstore (Double_u, Assignment), + [access_array $3 $4 Arch.size_float; $5], Debuginfo.none) } +; +exprlist: + exprlist expr { $2 :: $1 } + | /**/ { [] } +; +letdef: + oneletdef { [$1] } + | LPAREN letdefmult RPAREN { $2 } +; +letdefmult: + /**/ { [] } + | oneletdef letdefmult { $1 :: $2 } +; +oneletdef: + IDENT expr { (bind_ident $1, $2) } +; +chunk: + UNSIGNED BYTE { Byte_unsigned } + | SIGNED BYTE { Byte_signed } + | UNSIGNED HALF { Sixteen_unsigned } + | SIGNED HALF { Sixteen_signed } + | UNSIGNED INT32 { Thirtytwo_unsigned } + | SIGNED INT32 { Thirtytwo_signed } + | INT { Word_int } + | ADDR { Word_val } + | FLOAT32 { Single } + | FLOAT64 { Double } + | FLOAT { Double_u } + | VAL { Word_val } +; +unaryop: + LOAD chunk { Cload ($2, Mutable) } + | FLOATOFINT { Cfloatofint } + | INTOFFLOAT { Cintoffloat } + | RAISE { Craise $1 } + | ABSF { Cabsf } +; +binaryop: + STORE chunk { Cstore ($2, Assignment) } + | ADDI { Caddi } + | SUBI { Csubi } + | STAR { Cmuli } + | DIVI { Cdivi } + | MODI { Cmodi } + | AND { Cand } + | OR { Cor } + | XOR { Cxor } + | LSL { Clsl } + | LSR { Clsr } + | ASR { Casr } + | EQI { Ccmpi Ceq } + | NEI { Ccmpi Cne } + | LTI { Ccmpi Clt } + | LEI { Ccmpi Cle } + | GTI { Ccmpi Cgt } + | GEI { Ccmpi Cge } + | ADDA { Cadda } + | ADDV { Caddv } + | EQA { Ccmpa Ceq } + | NEA { Ccmpa Cne } + | LTA { Ccmpa Clt } + | LEA { Ccmpa Cle } + | GTA { Ccmpa Cgt } + | GEA { Ccmpa Cge } + | ADDF { Caddf } + | MULF { Cmulf } + | DIVF { Cdivf } + | EQF { Ccmpf Ceq } + | NEF { Ccmpf Cne } + | LTF { Ccmpf Clt } + | LEF { Ccmpf Cle } + | GTF { Ccmpf Cgt } + | GEF { Ccmpf Cge } + | CHECKBOUND { Ccheckbound } + | MULH { Cmulhi } +; +sequence: + expr sequence { Csequence($1, $2) } + | expr { $1 } +; +caselist: + onecase sequence caselist { ($1, $2) :: $3 } + | /**/ { [] } +; +onecase: + CASE INTCONST COLON onecase { $2 :: $4 } + | CASE INTCONST COLON { [$2] } +; +bind_ident: + IDENT { bind_ident $1 } +; +datadecl: + LPAREN datalist RPAREN { List.rev $2 } + | LPAREN DATA datalist RPAREN { List.rev $3 } +; +datalist: + datalist dataitem { $2 :: $1 } + | /**/ { [] } +; +dataitem: + STRING COLON { Cdefine_symbol $1 } + | BYTE INTCONST { Cint8 $2 } + | HALF INTCONST { Cint16 $2 } + | INT INTCONST { Cint(Nativeint.of_int $2) } + | FLOAT FLOATCONST { Cdouble (float_of_string $2) } + | ADDR STRING { Csymbol_address $2 } + | VAL STRING { Csymbol_address $2 } + | KSTRING STRING { Cstring $2 } + | SKIP INTCONST { Cskip $2 } + | ALIGN INTCONST { Calign $2 } + | GLOBAL STRING { Cglobal_symbol $2 } +; +catch_handlers: + | catch_handler + { [$1] } + | catch_handler AND catch_handlers + { $1 :: $3 } + +catch_handler: + | sequence + { 0, [], $1 } + | LPAREN IDENT bind_identlist RPAREN sequence + { find_label $2, $3, $5 } + +bind_identlist: + /**/ { [] } + | bind_ident bind_identlist { $1 :: $2 } + +location: + /**/ { None } + | LOCATION { Some $1 } diff --git a/testsuite/tests/asmgen/parsecmmaux.ml b/testsuite/tests/asmgen/parsecmmaux.ml new file mode 100644 index 0000000000..db55527354 --- /dev/null +++ b/testsuite/tests/asmgen/parsecmmaux.ml @@ -0,0 +1,43 @@ +(* Auxiliary functions for parsing *) + +type error = + Unbound of string + +exception Error of error + +let tbl_ident = (Hashtbl.create 57 : (string, Ident.t) Hashtbl.t) +let tbl_label = (Hashtbl.create 57 : (string, int) Hashtbl.t) + +let ident_name s = + match String.index s '/' with + | exception Not_found -> s + | n -> String.sub s 0 n + +let bind_ident s = + let id = Ident.create (ident_name s) in + Hashtbl.add tbl_ident s id; + id + +let find_ident s = + try + Hashtbl.find tbl_ident s + with Not_found -> + raise(Error(Unbound s)) + +let unbind_ident id = + Hashtbl.remove tbl_ident (Ident.name id) + +let find_label s = + try + Hashtbl.find tbl_label s + with Not_found -> + let lbl = Lambda.next_raise_count () in + Hashtbl.add tbl_label s lbl; + lbl + +let report_error = function + Unbound s -> + prerr_string "Unbound identifier "; prerr_string s; prerr_endline "." + +let debuginfo ?(loc=Location.symbol_rloc ()) () = + Debuginfo.(from_location loc) diff --git a/testsuite/tests/asmgen/parsecmmaux.mli b/testsuite/tests/asmgen/parsecmmaux.mli new file mode 100644 index 0000000000..f5478579ee --- /dev/null +++ b/testsuite/tests/asmgen/parsecmmaux.mli @@ -0,0 +1,16 @@ +(* Auxiliary functions for parsing *) + +val bind_ident: string -> Ident.t +val find_ident: string -> Ident.t +val unbind_ident: Ident.t -> unit + +val find_label: string -> int + +val debuginfo: ?loc:Location.t -> unit -> Debuginfo.t + +type error = + Unbound of string + +exception Error of error + +val report_error: error -> unit diff --git a/testsuite/tests/asmgen/pgcd.cmm b/testsuite/tests/asmgen/pgcd.cmm new file mode 100644 index 0000000000..e75a149ac0 --- /dev/null +++ b/testsuite/tests/asmgen/pgcd.cmm @@ -0,0 +1,9 @@ +(function "pgcd_30030" (a:int) + (catch (exit pgcd a 30030) + with (pgcd n m) + (if (> n m) + (exit pgcd m n) + (if (== n 0) + m + (let (r (mod m n)) + (exit pgcd r n))))))
\ No newline at end of file diff --git a/testsuite/tests/asmgen/power.S b/testsuite/tests/asmgen/power.S new file mode 100644 index 0000000000..71c692f97b --- /dev/null +++ b/testsuite/tests/asmgen/power.S @@ -0,0 +1,200 @@ +/*********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the Q Public License version 1.0. */ +/* */ +/*********************************************************************/ + +#if defined(MODEL_ppc64) || defined(MODEL_ppc64le) +#define EITHER(a,b) b +#else +#define EITHER(a,b) a +#endif + +#define WORD EITHER(4,8) +#define lg EITHER(lwz,ld) +#define lgu EITHER(lwzu,ldu) +#define stg EITHER(stw,std) +#define stgu EITHER(stwu,stdu) + +#if defined(MODEL_ppc) +#define RESERVED_STACK 16 +#define LR_SAVE_AREA 4 +#endif +#if defined(MODEL_ppc64) +#define RESERVED_STACK 48 +#define LR_SAVE_AREA 16 +#endif +#if defined(MODEL_ppc64le) +#define RESERVED_STACK 32 +#define LR_SAVE_AREA 16 +#endif + +/* Function definitions */ + +#if defined(MODEL_ppc) +#define FUNCTION(name) \ + .section ".text"; \ + .globl name; \ + .type name, @function; \ + .align 2; \ + name: +#endif + +#if defined(MODEL_ppc64) +#define FUNCTION(name) \ + .section ".opd","aw"; \ + .align 3; \ + .globl name; \ + .type name, @function; \ + name: .quad .L.name,.TOC.@tocbase; \ + .text; \ + .align 2; \ + .L.name: +#endif + +#if defined(MODEL_ppc64le) +#define FUNCTION(name) \ + .section ".text"; \ + .globl name; \ + .type name, @function; \ + .align 2; \ + name: ; \ + 0: addis 2, 12, (.TOC. - 0b)@ha; \ + addi 2, 2, (.TOC. - 0b)@l; \ + .localentry name, . - 0b +#endif + +FUNCTION(call_gen_code) + /* Allocate and link stack frame */ + stgu 1, -(WORD*18 + 8*18 + RESERVED_STACK)(1) + /* 18 saved GPRs, 18 saved FPRs */ + /* Save return address */ + mflr 0 + stg 0, (WORD*18 + 8*18 + RESERVED_STACK + LR_SAVE_AREA)(1) + /* Save all callee-save registers, starting at RESERVED_STACK */ + addi 11, 1, RESERVED_STACK - WORD + stgu 14, WORD(11) + stgu 15, WORD(11) + stgu 16, WORD(11) + stgu 17, WORD(11) + stgu 18, WORD(11) + stgu 19, WORD(11) + stgu 20, WORD(11) + stgu 21, WORD(11) + stgu 22, WORD(11) + stgu 23, WORD(11) + stgu 24, WORD(11) + stgu 25, WORD(11) + stgu 26, WORD(11) + stgu 27, WORD(11) + stgu 28, WORD(11) + stgu 29, WORD(11) + stgu 30, WORD(11) + stgu 31, WORD(11) + stfdu 14, 8(11) + stfdu 15, 8(11) + stfdu 16, 8(11) + stfdu 17, 8(11) + stfdu 18, 8(11) + stfdu 19, 8(11) + stfdu 20, 8(11) + stfdu 21, 8(11) + stfdu 22, 8(11) + stfdu 23, 8(11) + stfdu 24, 8(11) + stfdu 25, 8(11) + stfdu 26, 8(11) + stfdu 27, 8(11) + stfdu 28, 8(11) + stfdu 29, 8(11) + stfdu 30, 8(11) + stfdu 31, 8(11) + /* Get function pointer in CTR */ +#if defined(MODEL_ppc) + mtctr 3 +#elif defined(MODEL_ppc64) + ld 0, 0(3) + mtctr 0 + ld 2, 8(3) +#elif defined(MODEL_ppc64le) + mtctr 3 + mr 12, 3 +#else +#error "wrong MODEL" +#endif + /* Shuffle arguments */ + mr 3, 4 + mr 4, 5 + mr 5, 6 + mr 6, 7 + /* Call the function */ + bctrl + /* Restore callee-save registers */ + addi 11, 1, RESERVED_STACK - WORD + lgu 14, WORD(11) + lgu 15, WORD(11) + lgu 16, WORD(11) + lgu 17, WORD(11) + lgu 18, WORD(11) + lgu 19, WORD(11) + lgu 20, WORD(11) + lgu 21, WORD(11) + lgu 22, WORD(11) + lgu 23, WORD(11) + lgu 24, WORD(11) + lgu 25, WORD(11) + lgu 26, WORD(11) + lgu 27, WORD(11) + lgu 28, WORD(11) + lgu 29, WORD(11) + lgu 30, WORD(11) + lgu 31, WORD(11) + lfdu 14, 8(11) + lfdu 15, 8(11) + lfdu 16, 8(11) + lfdu 17, 8(11) + lfdu 18, 8(11) + lfdu 19, 8(11) + lfdu 20, 8(11) + lfdu 21, 8(11) + lfdu 22, 8(11) + lfdu 23, 8(11) + lfdu 24, 8(11) + lfdu 25, 8(11) + lfdu 26, 8(11) + lfdu 27, 8(11) + lfdu 28, 8(11) + lfdu 29, 8(11) + lfdu 30, 8(11) + lfdu 31, 8(11) + /* Reload return address */ + lg 0, (WORD*18 + 8*18 + RESERVED_STACK + LR_SAVE_AREA)(1) + mtlr 0 + /* Return */ + addi 1, 1, (WORD*18 + 8*18 + RESERVED_STACK) + blr + +FUNCTION(caml_c_call) + /* Jump to C function (address in r28) */ +#if defined(MODEL_ppc) + mtctr 28 +#elif defined(MODEL_ppc64) + ld 0, 0(28) + mtctr 0 + ld 2, 8(28) +#elif defined(MODEL_ppc64le) + mtctr 28 + mr 12, 28 +#else +#error "wrong MODEL" +#endif + bctr + +/* Mark stack as non-executable */ + .section .note.GNU-stack,"",%progbits diff --git a/testsuite/tests/asmgen/quicksort.cmm b/testsuite/tests/asmgen/quicksort.cmm new file mode 100644 index 0000000000..b08594154b --- /dev/null +++ b/testsuite/tests/asmgen/quicksort.cmm @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(function "quicksort" (lo: int hi: int a: val) + (if (< lo hi) + (let (i lo + j hi + pivot (addraref a hi)) + (while (< i j) + (catch + (while 1 + (if (>= i hi) exit []) + (if (> (addraref a i) pivot) exit []) + (assign i (+ i 1))) + with []) + (catch + (while 1 + (if (<= j lo) exit []) + (if (< (addraref a j) pivot) exit []) + (assign j (- j 1))) + with []) + (if (< i j) + (let temp (addraref a i) + (addraset a i (addraref a j)) + (addraset a j temp)) + [])) + (let temp (addraref a i) + (addraset a i (addraref a hi)) + (addraset a hi temp)) + (app "quicksort" lo (- i 1) a unit) + (app "quicksort" (+ i 1) hi a unit)) + [])) diff --git a/testsuite/tests/asmgen/quicksort2.cmm b/testsuite/tests/asmgen/quicksort2.cmm new file mode 100644 index 0000000000..96c1fc12e7 --- /dev/null +++ b/testsuite/tests/asmgen/quicksort2.cmm @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(function "cmp" (i: int j: int) + (- i j)) + +(function "quick" (lo: int hi: int a: val cmp: val) + (if (< lo hi) + (let (i lo + j hi + pivot (intaref a hi)) + (while (< i j) + (catch + (while 1 + (if (>= i hi) exit []) + (if (> (app cmp (intaref a i) pivot int) 0) exit []) + (assign i (+ i 1))) + with []) + (catch + (while 1 + (if (<= j lo) exit []) + (if (< (app cmp (intaref a j) pivot int) 0) exit []) + (assign j (- j 1))) + with []) + (if (< i j) + (let temp (intaref a i) + (intaset a i (intaref a j)) + (intaset a j temp)) + [])) + (let temp (intaref a i) + (intaset a i (intaref a hi)) + (intaset a hi temp)) + (app "quick" lo (- i 1) a cmp unit) + (app "quick" (+ i 1) hi a cmp unit)) + [])) + +(function "quicksort" (lo: int hi: int a: val) + (app "quick" lo hi a "cmp" unit)) diff --git a/testsuite/tests/asmgen/s390x.S b/testsuite/tests/asmgen/s390x.S new file mode 100644 index 0000000000..99eeca2704 --- /dev/null +++ b/testsuite/tests/asmgen/s390x.S @@ -0,0 +1,67 @@ +#define ALIGN 8 + +#define CALL_GEN_CODE call_gen_code +#define CAML_C_CALL caml_c_call +#define CAML_NEGF_MASK caml_negf_mask +#define CAML_ABSF_MASK caml_absf_mask + + .section ".text" + + .globl CALL_GEN_CODE + .type CALL_GEN_CODE, @function + .align ALIGN +CALL_GEN_CODE: + /* Stack space */ + lay %r15, -144(%r15) + /* Save registers */ + stmg %r6,%r14, 0(%r15) + std %f8, 72(%r15) + std %f9, 80(%r15) + std %f10, 88(%r15) + std %f11, 96(%r15) + std %f12, 104(%r15) + std %f13, 112(%r15) + std %f14, 120(%r15) + std %f15, 128(%r15) + /* Shuffle args */ + lgr %r1, %r2 + lgr %r2, %r3 + lgr %r3, %r4 + lgr %r4, %r5 + /* Function call */ + basr %r14, %r1 + /* Restore registers */ + lmg %r6,%r14, 0(%r15) + ld %f8, 72(%r15) + ld %f9, 80(%r15) + ld %f10, 88(%r15) + ld %f11, 96(%r15) + ld %f12, 104(%r15) + ld %f13, 112(%r15) + ld %f14, 120(%r15) + ld %f15, 128(%r15) + /* Return */ + lay %r15, 144(%r15) + br %r14 + + .globl CAML_C_CALL + .type CAML_C_CALL, @function + .align ALIGN +CAML_C_CALL: + br %r7 + + .section ".rodata" + + .global CAML_NEGF_MASK + .align ALIGN +CAML_NEGF_MASK: + .quad 0x8000000000000000, 0 + .global CAML_ABSF_MASK + .align ALIGN +CAML_ABSF_MASK: + .quad 0x7FFFFFFFFFFFFFFF, 0 + + .comm young_limit, 8 + +/* Mark stack as non-executable */ + .section .note.GNU-stack,"",%progbits diff --git a/testsuite/tests/asmgen/soli.cmm b/testsuite/tests/asmgen/soli.cmm new file mode 100644 index 0000000000..c8ffc5d684 --- /dev/null +++ b/testsuite/tests/asmgen/soli.cmm @@ -0,0 +1,110 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +("d1": int 0 int 1 + "d2": int 1 int 0 + "d3": int 0 int -1 + "d4": int -1 int 0 + "dir": val "d1" val "d2" val "d3" val "d4") + +("counter": int 0) + +(* Out = 0 Empty = 1 Peg = 2 *) + +("line0": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 + "line1": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0 + "line2": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0 + "line3": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0 + "line4": int 0 int 2 int 2 int 2 int 1 int 2 int 2 int 2 int 0 + "line5": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0 + "line6": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0 + "line7": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0 + "line8": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 + "board": val "line0" val "line1" val "line2" val "line3" + val "line4" val "line5" val "line6" val "line7" val "line8") + +("format": string "%d\n\000") + +(function "solve" (m: int) + (store int "counter" (+ (load int "counter") 1)) + (if (== m 31) + (== (intaref (addraref "board" 4) 4) 2) + (try + (if (== (mod (load int "counter") 500) 0) + (extcall "printf_int" "format" (load int "counter") unit) + []) + (let i 1 + (while (<= i 7) + (let j 1 + (while (<= j 7) + (if (== (intaref (addraref "board" i) j) 2) + (seq + (let k 0 + (while (<= k 3) + (let (d1 (intaref (addraref "dir" k) 0) + d2 (intaref (addraref "dir" k) 1) + i1 (+ i d1) + i2 (+ i1 d1) + j1 (+ j d2) + j2 (+ j1 d2)) + (if (== (intaref (addraref "board" i1) j1) 2) + (if (== (intaref (addraref "board" i2) j2) 1) + (seq + (intaset (addraref "board" i) j 1) + (intaset (addraref "board" i1) j1 1) + (intaset (addraref "board" i2) j2 2) + (if (app "solve" (+ m 1) int) + (raise_notrace 0a) + []) + (intaset (addraref "board" i) j 2) + (intaset (addraref "board" i1) j1 2) + (intaset (addraref "board" i2) j2 1)) + []) + [])) + (assign k (+ k 1))))) + []) + (assign j (+ j 1)))) + (assign i (+ i 1)))) + 0 + with bucket + 1))) + +("format_out": string ".\000") +("format_empty": string " \000") +("format_peg": string "$\000") +("format_newline": string "\n\000") + +(function "print_board" () + (let i 0 + (while (< i 9) + (let j 0 + (while (< j 9) + (switch 3 (intaref (addraref "board" i) j) + case 0: + (extcall "print_string" "format_out" unit) + case 1: + (extcall "print_string" "format_empty" unit) + case 2: + (extcall "print_string" "format_peg" unit)) + (assign j (+ j 1)))) + (extcall "print_string" "format_newline" unit) + (assign i (+ i 1))))) + +(function "solitaire" () + (seq + (if (app "solve" 0 int) + (app "print_board" [] unit) + []) + 0)) diff --git a/testsuite/tests/asmgen/tagged-fib.cmm b/testsuite/tests/asmgen/tagged-fib.cmm new file mode 100644 index 0000000000..d83afaa487 --- /dev/null +++ b/testsuite/tests/asmgen/tagged-fib.cmm @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(function "fib" (n: int) + (if (< n 5) + 3 + (- (+ (app "fib" (- n 2) int) (app "fib" (- n 4) int)) 1))) diff --git a/testsuite/tests/asmgen/tagged-integr.cmm b/testsuite/tests/asmgen/tagged-integr.cmm new file mode 100644 index 0000000000..b89bd50863 --- /dev/null +++ b/testsuite/tests/asmgen/tagged-integr.cmm @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +("res_square": skip 8) +("h": skip 8) +("x": skip 8) +("s": skip 8) +("res_integr": skip 8) + +(function "square" (x: val) + (let r "res_square" + (store float r ( *f (load float x) (load float x))) + r)) + +(function "integr" (f: val low: val high: val n: int) + (let (h "h" x "x" s "s" i n) + (store float h (/f (-f (load float high) (load float low)) (floatofint n))) + (store float x (load float low)) + (store float s 0.0) + (while (> i 0) + (store float s (+f (load float s) (load float (app f x val)))) + (store float x (+f (load float x) (load float h))) + (assign i (- i 1))) + (store float "res_integr" ( *f (load float s) (load float h))) + "res_integr")) + +("low": skip 8) +("hi": skip 8) + +(function "test" (n: int) + (store float "low" 0.0) + (store float "hi" 1.0) + (load float (app "integr" "square" "low" "hi" n val))) diff --git a/testsuite/tests/asmgen/tagged-quicksort.cmm b/testsuite/tests/asmgen/tagged-quicksort.cmm new file mode 100644 index 0000000000..59293aa2ed --- /dev/null +++ b/testsuite/tests/asmgen/tagged-quicksort.cmm @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(function "quick" (lo: int hi: int a: val) + (if (< lo hi) + (let (i lo + j hi + pivot (addraref a (>>s hi 1))) + (while (< i j) + (catch + (while 1 + (if (>= i hi) exit []) + (if (> (addraref a (>>s i 1)) pivot) exit []) + (assign i (+ i 2))) + with []) + (catch + (while 1 + (if (<= j lo) exit []) + (if (< (addraref a (>>s j 1)) pivot) exit []) + (assign j (- j 2))) + with []) + (if (< i j) + (let temp (addraref a (>>s i 1)) + (addraset a (>>s i 1) (addraref a (>>s j 1))) + (addraset a (>>s j 1) temp)) + [])) + (let temp (addraref a (>>s i 1)) + (addraset a (>>s i 1) (addraref a (>>s hi 1))) + (addraset a (>>s hi 1) temp)) + (app "quick" lo (- i 2) a unit) + (app "quick" (+ i 2) hi a unit)) + [])) + +(function "quicksort" (lo: int hi: int a: val) + (app "quick" (+ (<< lo 1) 1) (+ (<< hi 1) 1) a unit)) diff --git a/testsuite/tests/asmgen/tagged-tak.cmm b/testsuite/tests/asmgen/tagged-tak.cmm new file mode 100644 index 0000000000..30c98a00bf --- /dev/null +++ b/testsuite/tests/asmgen/tagged-tak.cmm @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(function "tak" (x:int y:int z:int) + (if (> x y) + (app "tak" (app "tak" (- x 2) y z int) + (app "tak" (- y 2) z x int) + (app "tak" (- z 2) x y int) int) + z)) + +(function "takmain" (dummy: int) + (app "tak" 37 25 13 int)) diff --git a/testsuite/tests/asmgen/tak.cmm b/testsuite/tests/asmgen/tak.cmm new file mode 100644 index 0000000000..2750fff334 --- /dev/null +++ b/testsuite/tests/asmgen/tak.cmm @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(function "tak" (x:int y:int z:int) + (if (> x y) + (app "tak" (app "tak" (- x 1) y z int) + (app "tak" (- y 1) z x int) + (app "tak" (- z 1) x y int) int) + z)) + +(function "takmain" (dummy: int) + (app "tak" 18 12 6 int)) |