From 9a374eb4d60a489df981de8e9e68ddf100e597bf Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Thu, 24 Oct 1996 16:14:57 +0000 Subject: Portage 680x0. git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@1093 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- asmcomp/arch_m68k.ml | 108 ++++++++ asmcomp/emit_m68k.mlp | 723 ++++++++++++++++++++++++++++++++++++++++++++++++++ asmcomp/proc_m68k.ml | 353 ++++++++++++++++++++++++ asmrun/m68k.S | 259 ++++++++++++++++++ asmrun/stack.h | 5 + byterun/interp.c | 5 + configure | 2 + 7 files changed, 1455 insertions(+) create mode 100644 asmcomp/arch_m68k.ml create mode 100644 asmcomp/emit_m68k.mlp create mode 100644 asmcomp/proc_m68k.ml create mode 100644 asmrun/m68k.S diff --git a/asmcomp/arch_m68k.ml b/asmcomp/arch_m68k.ml new file mode 100644 index 0000000000..3eff0a6e31 --- /dev/null +++ b/asmcomp/arch_m68k.ml @@ -0,0 +1,108 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Specific operations for the Motorola 68020 processor *) + +type addressing_mode = + Ibased of string * int (* symbol + displ *) + | Iindexed of int (* reg + displ *) + | Iindexed2 of int (* reg + reg + displ *) + | Iscaled of int * int (* reg * scale + displ *) + | Iindexed2scaled of int * int (* reg + reg * scale + displ *) + +type specific_operation = + Ilea of addressing_mode (* Lea gives scaled adds *) + | Istore_int of int * addressing_mode (* Store an integer constant *) + | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Ipush (* Push regs on stack *) + | Ipush_int of int (* Push an integer constant *) + | Ipush_symbol of string (* Push a symbol *) + | Ipush_load of addressing_mode (* Load a scalar and push *) + | Ipush_load_float of addressing_mode (* Load a float and push *) + +(* Sizes, endianness *) + +let big_endian = true + +let size_addr = 4 +let size_int = 4 +let size_float = 8 + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + Ibased(s, n) -> Ibased(s, n + delta) + | Iindexed n -> Iindexed(n + delta) + | Iindexed2 n -> Iindexed2(n + delta) + | Iscaled(scale, n) -> Iscaled(scale, n + delta) + | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) + +let num_args_addressing = function + Ibased(s, n) -> 0 + | Iindexed n -> 1 + | Iindexed2 n -> 2 + | Iscaled(scale, n) -> 1 + | Iindexed2scaled(scale, n) -> 2 + +(* Printing operations and addressing modes *) + +open Format + +let print_addressing printreg addr arg = + match addr with + Ibased(s, 0) -> + print_string "\""; print_string s; print_string "\"" + | Ibased(s, n) -> + print_string "\""; print_string s; print_string "\" + "; print_int n + | Iindexed n -> + printreg arg.(0); + if n <> 0 then begin print_string " + "; print_int n end + | Iindexed2 n -> + printreg arg.(0); print_string " + "; printreg arg.(1); + if n <> 0 then begin print_string " + "; print_int n end + | Iscaled(scale, n) -> + printreg arg.(0); print_string " * "; print_int scale; + if n <> 0 then begin print_string " + "; print_int n end + | Iindexed2scaled(scale, n) -> + printreg arg.(0); print_string " + "; printreg arg.(1); + print_string " * "; print_int scale; + if n <> 0 then begin print_string " + "; print_int n end + +let print_specific_operation printreg op arg = + match op with + Ilea addr -> print_addressing printreg addr arg + | Istore_int(n, addr) -> + print_string "["; print_addressing printreg addr arg; + print_string "] := "; print_int n + | Istore_symbol(lbl, addr) -> + print_string "["; print_addressing printreg addr arg; + print_string "] := \""; print_string lbl; print_string "\"" + | Ipush -> + print_string "push "; + for i = 0 to Array.length arg - 1 do + if i > 0 then print_string ", "; + printreg arg.(i) + done + | Ipush_int n -> + print_string "push "; print_int n + | Ipush_symbol s -> + print_string "push \""; print_string s; print_string "\"" + | Ipush_load addr -> + print_string "push ["; print_addressing printreg addr arg; + print_string "]" + | Ipush_load_float addr -> + print_string "pushfloat ["; print_addressing printreg addr arg; + print_string "]" diff --git a/asmcomp/emit_m68k.mlp b/asmcomp/emit_m68k.mlp new file mode 100644 index 0000000000..71ec17dc2a --- /dev/null +++ b/asmcomp/emit_m68k.mlp @@ -0,0 +1,723 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Emission of Motorola 68020 assembly code (MIT syntax) *) + +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +let stack_offset = ref 0 + +(* Layout of the stack frame *) + +let frame_size () = (* includes return address *) + !stack_offset + + 4 * (num_stack_slots.(0) + num_stack_slots.(1)) + + 8 * num_stack_slots.(2) + + 4 (* return address *) + +let slot_offset loc cl = + match loc with + Incoming n -> frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + n * 4 + else if cl = 1 + then !stack_offset + num_stack_slots.(0) * 4 + n * 4 + else !stack_offset + + (num_stack_slots.(0) + num_stack_slots.(1)) * 4 + n * 8 + | Outgoing n -> n + +(* Output a symbol *) + +let emit_symbol s = + emit_char '_'; Emitaux.emit_symbol '$' s + +(* Output a label *) + +let emit_label lbl = + emit_char 'L'; emit_int lbl + +(* Output an align directive *) + +let emit_align n = + ` .align {emit_int n}\n` + +(* Output a pseudo-register *) + +let emit_reg = function + { loc = Reg r } -> + emit_string (register_name r) + | { loc = Stack s } as r -> + let ofs = slot_offset s (register_class r) in + if ofs = 0 + then `a7@` + else `a7@({emit_int ofs})` + | { loc = Unknown } -> + fatal_error "Emit_m68k.emit_reg" + +(* Check if the given register is an address register *) + +let is_address_reg = function { loc = Reg _; typ = Addr } -> true | _ -> false + +(* Check if the given register overlaps (same location) with the given + array of registers *) + +let register_overlap reg arr = + try + for i = 0 to Array.length arr - 1 do + if reg.loc = arr.(i).loc then raise Exit + done; + false + with Exit -> + true + +(* Output a suffix for a floating-point instruction -- either .x if + the argument is a register or .d if it's in memory. *) + +let emit_float_size r = + match r.loc with + Reg _ -> `x` + | _ -> `d` + +let emit_float_size2 r1 r2 = + match (r1.loc, r2.loc) with + (Reg _, Reg _) -> `x` + | _ -> `d` + +(* Output an addressing mode *) + +let emit_displacement d = + if d <> 0 then `{emit_int d}, ` + +let emit_addressing addr r n = + match addr with + Ibased(s, d) -> + `{emit_symbol s}`; + if d <> 0 then ` + {emit_int d}` + | Iindexed d -> + `{emit_reg r.(n)}@`; + if d <> 0 then `({emit_int d})` + | Iindexed2 d -> + `{emit_reg r.(n)}@({emit_int d}, {emit_reg r.(n+1)}:l)` + | Iscaled(scale, d) -> + `@({emit_int d}, {emit_reg r.(n)}:l:{emit_int scale})` + | Iindexed2scaled(scale, d) -> + `{emit_reg r.(n)}@({emit_int d}, {emit_reg r.(n+1)}:l:{emit_int scale})` + +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list } (* Offsets/regs of live addresses *) + +let frame_descriptors = ref([] : frame_descr list) + +let record_frame_label live = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset } :: !frame_descriptors; + lbl + +let record_frame live = + let lbl = record_frame_label live in `{emit_label lbl}:\n` + +let emit_frame fd = + ` .long {emit_label fd.fd_lbl}\n`; + ` .word {emit_int fd.fd_frame_size}\n`; + ` .word {emit_int (List.length fd.fd_live_offset)}\n`; + List.iter + (fun n -> + ` .word {emit_int n}\n`) + fd.fd_live_offset; + emit_align 4 + +(* Names for instructions *) + +let instr_for_intop = function + Iadd -> "addl" + | Isub -> "subl" + | Imul -> "mulsl" + | Idiv -> "divsl" + | Iand -> "andl" + | Ior -> "orl" + | Ixor -> "eorl" + | Ilsl -> "lsll" + | Ilsr -> "lsrl" + | Iasr -> "asrl" + | _ -> fatal_error "Emit_m68k: instr_for_intop" + +let instr_for_floatop = function + Inegf -> "fneg" + | Iabsf -> "fabs" + | Iaddf -> "fadd" + | Isubf -> "fsub" + | Imulf -> "fmul" + | Idivf -> "fdiv" + | _ -> fatal_error "Emit_m68k: instr_for_floatop" + +let name_for_cond_branch = function + Isigned Ceq -> "eq" | Isigned Cne -> "ne" + | Isigned Cle -> "le" | Isigned Cgt -> "gt" + | Isigned Clt -> "lt" | Isigned Cge -> "ge" + | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" + | Iunsigned Cle -> "ls" | Iunsigned Cgt -> "hi" + | Iunsigned Clt -> "cs" | Iunsigned Cge -> "cc" + +let name_for_float_cond_branch cond neg = + match cond with + Ceq -> if neg then "ne" else "eq" + | Cne -> if neg then "eq" else "ne" + | Cle -> if neg then "ugt" else "ole" + | Cgt -> if neg then "ule" else "ogt" + | Clt -> if neg then "uge" else "olt" + | Cge -> if neg then "ult" else "oge" + +(* Emit an immediate move in the given data register *) + +let emit_move_immediate n dreg = + if n >= -128 && n < 128 + then ` moveq #{emit_int n}, {emit_string dreg}\n` + else ` movel #{emit_int n}, {emit_string dreg}\n` + +(* Offset the stack by the given amount of bytes *) + +let output_stack_offset n = + if n > 0 && n <= 8 then + ` subql #{emit_int(n)}, a7\n` + else if n < 0 && n >= -8 then + ` addql #{emit_int(-n)}, a7\n` + else + ` addw #{emit_int(-n)}, a7\n` + +(* Deallocate the stack frame before a return or tail call *) + +let output_epilogue () = + let n = frame_size() - 4 in + if n > 0 then output_stack_offset (-n) + +(* Record the state of the condition codes *) + +type condition_code = CCundefined | CCreflect of Reg.t + +let cc_state = ref CCundefined + +let undef_cc () = + cc_state := CCundefined + +let set_cc reg = + cc_state := CCreflect reg + +let output_test reg = + match !cc_state with + CCreflect r when r.loc = reg.loc -> () + | _ -> + ` tstl {emit_reg reg}\n`; + cc_state := CCreflect reg + +(* Output the assembly code for an instruction *) + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Label of trap for out-of-range accesses *) +let range_check_trap = ref 0 + +let emit_instr i = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + match (src, dst) with + ({typ = Float; loc = Stack ss}, {loc = Stack sd}) -> + let os = slot_offset ss 2 in + let od = slot_offset sd 2 in + ` movel ({emit_int os}, a7), ({emit_int od}, a7)\n`; + ` movel ({emit_int (os+4)}, a7), ({emit_int (od+4)}, a7)\n`; + undef_cc() + | ({typ = Float}, _) -> + ` fmove{emit_float_size2 src dst} {emit_reg src}, {emit_reg dst}\n` + | (_, _) -> + ` movel {emit_reg src}, {emit_reg dst}\n`; + set_cc dst + end + | Lop(Iconst_int n) -> + begin match i.res.(0) with + {typ = Addr; loc = Reg _} -> + if n >= -32768 && n < 32768 then + ` movew #{emit_int n}, {emit_reg i.res.(0)}\n` + else + ` movel #{emit_int n}, {emit_reg i.res.(0)}\n` + | _ when n = 0 -> + ` clrl {emit_reg i.res.(0)}\n`; + set_cc i.res.(0) + | {typ = Int; loc = Reg _} when n >= -128 && n < 128 -> + ` moveq #{emit_int n}, {emit_reg i.res.(0)}\n`; + set_cc i.res.(0) + | _ -> + ` movel #{emit_int n}, {emit_reg i.res.(0)}\n`; + set_cc i.res.(0) + end + | Lop(Iconst_float s) -> + let f = float_of_string s in + if f = 0.0 then + ` fmovecr #0x0F, {emit_reg i.res.(0)}\n` + else if f = 1.0 then + ` fmovecr #0x32, {emit_reg i.res.(0)}\n` + else + ` fmoved #0r{emit_string s}, {emit_reg i.res.(0)}\n` + | Lop(Iconst_symbol s) -> + ` lea {emit_symbol s}, {emit_reg i.res.(0)}\n` + | Lop(Icall_ind) -> + ` jbsr {emit_reg i.arg.(0)}@\n`; + record_frame i.live; + undef_cc() + | Lop(Icall_imm s) -> + ` jbsr {emit_symbol s}\n`; + record_frame i.live; + undef_cc() + | Lop(Itailcall_ind) -> + output_epilogue(); + ` jmp {emit_reg i.arg.(0)}@\n`; + undef_cc() + | Lop(Itailcall_imm s) -> + if s = !function_name then + ` bra {emit_label !tailrec_entry_point}\n` + else begin + output_epilogue(); + ` jmp {emit_symbol s}\n` + end; + undef_cc() + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + ` lea {emit_symbol s}, a0\n`; + ` jbsr {emit_symbol "caml_c_call"}\n`; + record_frame i.live + end else begin + ` jbsr {emit_symbol s}\n` + end; + if Array.length i.res > 0 && i.res.(0).typ = Float then begin + ` movel d1, a7@-\n`; + ` movel d0, a7@-\n`; + ` fmoved a7@+, {emit_reg i.res.(0)}\n` + end; + undef_cc() + | Lop(Istackoffset n) -> + output_stack_offset n; + stack_offset := !stack_offset + n; + undef_cc() + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match dest.typ with + Int | Addr -> + begin match chunk with + Word -> + ` movel {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Byte_unsigned when not (register_overlap dest i.arg) -> + ` clrl {emit_reg dest}\n`; + ` moveb {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Byte_unsigned -> + ` moveb {emit_addressing addr i.arg 0}, {emit_reg dest}\n`; + ` andl #0xFF, {emit_reg dest}\n` + | Byte_signed -> + ` moveb {emit_addressing addr i.arg 0}, {emit_reg dest}\n`; + ` extbl {emit_reg dest}\n` + | Sixteen_unsigned when not (register_overlap dest i.arg) -> + ` clrl {emit_reg dest}\n`; + ` movew {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + | Sixteen_unsigned -> + ` movew {emit_addressing addr i.arg 0}, {emit_reg dest}\n`; + ` andl #0xFFFF, {emit_reg dest}\n` + | Sixteen_signed -> + ` movew {emit_addressing addr i.arg 0}, {emit_reg dest}\n`; + ` extl {emit_reg dest}\n` + end; + set_cc dest + | Float -> + ` fmoved {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + end + | Lop(Istore(chunk, addr)) -> + let src = i.arg.(0) in + let instr = + match src.typ with + Int -> + begin match chunk with + Word -> "movel" + | Byte_unsigned | Byte_signed -> "moveb" + | Sixteen_unsigned | Sixteen_signed -> "movew" + end + | Addr -> "movel" + | Float -> "fmoved" in + ` {emit_string instr} {emit_reg src}, {emit_addressing addr i.arg 1}\n`; + undef_cc() + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_frame = record_frame_label i.live in + ` subl #{emit_int n}, d6\n`; + ` cmpl {emit_symbol "young_limit"}, d6\n`; + ` bcc {emit_label lbl_frame}\n`; + emit_move_immediate n "d5"; + ` jbsr {emit_symbol "caml_call_gc"}\n`; + `{emit_label lbl_frame}: movel d6, {emit_reg i.res.(0)}\n`; + ` addql #4, {emit_reg i.res.(0)}\n` + end else begin + begin match n with + 8 -> ` jbsr {emit_symbol "caml_alloc1"}\n` + | 12 -> ` jbsr {emit_symbol "caml_alloc2"}\n` + | 16 -> ` jbsr {emit_symbol "caml_alloc3"}\n` + | _ -> emit_move_immediate n "d5"; + ` jbsr {emit_symbol "caml_alloc"}\n` + end; + `{record_frame i.live} movel d6, {emit_reg i.res.(0)}\n`; + ` addql #4, {emit_reg i.res.(0)}\n` + end; + undef_cc() + | Lop(Iintop(Icomp cmp)) -> + ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` s{emit_string b} {emit_reg i.res.(0)}\n`; + ` negb {emit_reg i.res.(0)}\n`; + ` extbl {emit_reg i.res.(0)}\n`; + set_cc i.res.(0) + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmpl #{emit_int n}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` s{emit_string b} {emit_reg i.res.(0)}\n`; + ` negb {emit_reg i.res.(0)}\n`; + ` extbl {emit_reg i.res.(0)}\n`; + set_cc i.res.(0) + | Lop(Iintop Icheckbound) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + ` bls {emit_label !range_check_trap}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + if !range_check_trap = 0 then range_check_trap := new_label(); + ` cmpl #{emit_int n}, {emit_reg i.arg.(0)}\n`; + ` bls {emit_label !range_check_trap}\n` + | Lop(Iintop_imm(Iadd, n)) -> + let dest = i.res.(0) in + begin match dest with + {loc = Reg _} when n > 0 && n <= 8 -> + ` addql #{emit_int n}, {emit_reg dest}\n`; + set_cc i.res.(0) + | {loc = Reg _} when n < 0 && n >= -8 -> + ` subql #{emit_int(-n)}, {emit_reg dest}\n`; + set_cc i.res.(0) + | _ -> + ` addl #{emit_int n}, {emit_reg dest}\n`; + set_cc i.res.(0) + end + | Lop(Iintop_imm(Isub, n)) -> + let dest = i.res.(0) in + begin match dest with + {loc = Reg _} when n > 0 && n <= 8 -> + ` subql #{emit_int n}, {emit_reg dest}\n`; + set_cc i.res.(0) + | {loc = Reg _} when n < 0 && n >= -8 -> + ` addql #{emit_int(-n)}, {emit_reg dest}\n`; + set_cc i.res.(0) + | _ -> + ` subl #{emit_int n}, {emit_reg dest}\n`; + set_cc i.res.(0) + end + | Lop(Iintop_imm(Idiv, n)) when n = 1 lsl (Misc.log2 n) -> + let l = Misc.log2 n in + let lbl = new_label() in + output_test i.arg.(0); + ` bge {emit_label lbl}\n`; + ` addl #{emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; + `{emit_label lbl}:`; + if l <= 8 then + ` asrl #{emit_int l}, {emit_reg i.arg.(0)}\n` + else begin + ` moveq #{emit_int l}, d5\n`; + ` asrl d0, {emit_reg i.arg.(0)}\n` + end; + set_cc i.res.(0) + | Lop(Iintop Imod) -> + ` movel {emit_reg i.arg.(0)}, d5\n`; + ` divsll {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}:d5\n`; + undef_cc() + | Lop(Iintop_imm(Imod, n)) when n = 1 lsl (Misc.log2 n) -> + let l = Misc.log2 n in + let lbl = new_label() in + ` movel {emit_reg i.arg.(0)}, d5\n`; + ` bge {emit_label lbl}\n`; + ` addl #{emit_int(n-1)}, d5\n`; + `{emit_label lbl}: andl #{emit_int(-n)}, d5\n`; + ` subl d5, {emit_reg i.arg.(0)}\n`; + set_cc i.res.(0) + | Lop(Iintop_imm(Imod, n)) -> + ` movel {emit_reg i.arg.(0)}, d5\n`; + ` divsll #{emit_int n}, {emit_reg i.res.(0)}:d5\n`; + undef_cc() + | Lop(Iintop op) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`; + set_cc i.res.(0) + | Lop(Iintop_imm(op, n)) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} #{emit_int n}, {emit_reg i.res.(0)}\n`; + set_cc i.res.(0) + | Lop(Inegf | Iabsf as floatop) -> + ` {emit_string(instr_for_floatop floatop)}{emit_float_size i.arg.(0)} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) -> + ` {emit_string(instr_for_floatop floatop)}{emit_float_size i.arg.(1)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Ifloatofint) -> + ` fmovel {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` + | Lop(Iintoffloat) -> + ` fintrz{emit_float_size i.arg.(0)} {emit_reg i.arg.(0)}, fp0\n`; + ` fmovel fp0, {emit_reg i.res.(0)}\n`; + undef_cc() + | Lop(Ispecific(Ilea addr)) -> + ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` + | Lop(Ispecific(Istore_int(n, addr))) -> + if n = 0 then + ` clrl {emit_addressing addr i.arg 0}\n` + else + ` movel #{emit_int n}, {emit_addressing addr i.arg 0}\n`; + undef_cc() + | Lop(Ispecific(Istore_symbol(s, addr))) -> + ` movel #{emit_symbol s}, {emit_addressing addr i.arg 0}\n`; + undef_cc() + | Lop(Ispecific(Ipush)) -> + (* Push arguments in reverse order *) + for n = Array.length i.arg - 1 downto 0 do + let r = i.arg.(n) in + match r with + {loc = Reg _; typ = Float} -> + ` fmoved {emit_reg r}, a7@-\n`; + stack_offset := !stack_offset + 8 + | {loc = Stack sl; typ = Float} -> + let ofs = slot_offset sl 2 in + ` movel ({emit_int(ofs + 4)}, a7), a7@-\n`; + ` movel ({emit_int(ofs + 4)}, a7), a7@-\n`; + stack_offset := !stack_offset + 8 + | _ -> + ` movel {emit_reg r}, a7@-\n`; + stack_offset := !stack_offset + 4 + done; + undef_cc() + | Lop(Ispecific(Ipush_int n)) -> + ` movel #{emit_int n}, a7@-\n`; + stack_offset := !stack_offset + 4; + undef_cc() + | Lop(Ispecific(Ipush_symbol s)) -> + ` pea {emit_symbol s}\n`; + stack_offset := !stack_offset + 4; + undef_cc() + | Lop(Ispecific(Ipush_load addr)) -> + ` movel {emit_addressing addr i.arg 0}, a7@-\n`; + stack_offset := !stack_offset + 4; + undef_cc() + | Lop(Ispecific(Ipush_load_float addr)) -> + ` movel {emit_addressing (offset_addressing addr 4) i.arg 0}, a7@-\n`; + ` movel {emit_addressing addr i.arg 0}, a7@-\n`; + stack_offset := !stack_offset + 8; + undef_cc() + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue(); + ` rts\n`; + undef_cc() + | Llabel lbl -> + `{emit_label lbl}:\n`; + undef_cc() + | Lbranch lbl -> + ` bra {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + output_test i.arg.(0); + ` bne {emit_label lbl}\n` + | Ifalsetest -> + output_test i.arg.(0); + ` beq {emit_label lbl}\n` + | Iinttest cmp -> + ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` b{emit_string b} {emit_label lbl}\n` + | Iinttest_imm(cmp, 0) -> + output_test i.arg.(0); + let b = name_for_cond_branch cmp in + ` b{emit_string b} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + ` cmpl #{emit_int n}, {emit_reg i.arg.(0)}\n`; + let b = name_for_cond_branch cmp in + ` b{emit_string b} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + ` fcmp{emit_float_size2 i.arg.(0) i.arg.(1)} {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; + let b = name_for_float_cond_branch cmp neg in + ` fb{emit_string b} {emit_label lbl}\n` + | Ioddtest -> + begin match i.arg.(0) with + {typ = Addr; loc = Reg _} as arg -> + ` movel {emit_reg arg}, d5\n`; + ` btst #0, d5\n` + | arg -> + ` btst #0, {emit_reg arg}\n` + end; + ` bne {emit_label lbl}\n` + | Ieventest -> + begin match i.arg.(0) with + {typ = Addr; loc = Reg _} as arg -> + ` movel {emit_reg arg}, d5\n`; + ` btst #0, d5\n` + | arg -> + ` btst #0, {emit_reg arg}\n` + end; + ` beq {emit_label lbl}\n` + end; + undef_cc() + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmpl #1, {emit_reg i.arg.(0)}\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` blt {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` beq {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` bgt {emit_label lbl}\n` + end; + undef_cc() + | Lswitch jumptbl -> + let lbl_load = new_label() in + let lbl_table = new_label() in + `{emit_label lbl_load}: movew pc@({emit_label lbl_table}-{emit_label lbl_load}-2:b, {emit_reg i.arg.(0)}:l:2), d0\n`; + ` jmp pc@(2, d0:w)\n`; + `{emit_label lbl_table}:`; + for i = 0 to Array.length jumptbl - 1 do + ` .word {emit_label jumptbl.(i)} - {emit_label lbl_table}\n` + done; + undef_cc() + | Lsetuptrap lbl -> + ` bsr {emit_label lbl}\n` + | Lpushtrap -> + ` movel d7, a7@-\n`; + ` movel a7, d7\n`; + stack_offset := !stack_offset + 8; + undef_cc() + | Lpoptrap -> + ` movel a7@+, d7\n`; + ` addql #4, a7\n`; + stack_offset := !stack_offset - 8; + undef_cc() + | Lraise -> + ` movel d7, a7\n`; + ` movel a7@+, d7\n`; + ` rts\n` + +let rec emit_all i = + match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + stack_offset := 0; + range_check_trap := 0; + undef_cc(); + ` .text\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; + let n = frame_size() - 4 in + if n > 0 then output_stack_offset n; + `{emit_label !tailrec_entry_point}:\n`; + emit_all fundecl.fun_body; + if !range_check_trap > 0 then + `{emit_label !range_check_trap}: jbsr {emit_symbol "array_bound_error"}\n` + +(* Emission of data *) + +let emit_item = function + Cdefine_symbol s -> + ` .globl {emit_symbol s}\n`; + `{emit_symbol s}:\n` + | Cdefine_label lbl -> + `{emit_label (10000 + lbl)}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .word {emit_int n}\n` + | Cint n -> + ` .long {emit_int n}\n` + | Cintlit n -> + ` .long {emit_string n}\n` + | Cfloat f -> + ` .double 0r{emit_string f}\n` + | Csymbol_address s -> + ` .long {emit_symbol s}\n` + | Clabel_address lbl -> + ` .long {emit_label (10000 + lbl)}\n` + | Cstring s -> + emit_string_directive " .ascii " s + | Cskip n -> + if n > 0 then ` .skip {emit_int n}\n` + | Calign n -> + emit_align n + +let data l = + ` .data\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + let lbl_begin = Compilenv.current_unit_name() ^ "_begin" in + ` .data\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n` + +let end_assembly() = + ` .data\n`; + let lbl_end = Compilenv.current_unit_name() ^ "_end" in + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + let lbl = Compilenv.current_unit_name() ^ "_frametable" in + ` .globl {emit_symbol lbl}\n`; + `{emit_symbol lbl}:\n`; + ` .long {emit_int (List.length !frame_descriptors)}\n`; + List.iter emit_frame !frame_descriptors; + frame_descriptors := [] diff --git a/asmcomp/proc_m68k.ml b/asmcomp/proc_m68k.ml new file mode 100644 index 0000000000..3a2261ec6b --- /dev/null +++ b/asmcomp/proc_m68k.ml @@ -0,0 +1,353 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Description of the Motorola 68020 processor *) + +open Misc +open Arch +open Format +open Cmm +open Reg +open Mach + +(* Registers available for register allocation *) + +(* Register map: + A0 - A6 0-6 address registers (A2-A6 callee-save) + A7 stack pointer + D0 - D4 7-11 data registers (D2 - D7 callee-save) + D5 temporary + D6 allocation pointer + D7 trap pointer + FP0 - FP7 12-19 floating-point registers (FP2 - FP7 callee-save) +*) + +let register_names = + [| "a0"; "a1"; "a2"; "a3"; "a4"; "a5"; "a6"; + "d0"; "d1"; "d2"; "d3"; "d4"; + "fp0"; "fp1"; "fp2"; "fp3"; "fp4"; "fp5"; "fp6"; "fp7" |] + +let num_register_classes = 3 + +let register_class r = + match r.typ with + Addr -> 0 + | Int -> 1 + | Float -> 2 + +let num_available_registers = [| 7; 5; 8 |] + +let first_available_register = [| 0; 7; 12 |] + +let register_name r = register_names.(r) + +(* There is no scheduling, so just pack registers. *) + +let rotate_registers = false + +(* Representation of hard registers by pseudo-registers *) + +let all_phys_regs = + let v = Array.create 20 Reg.dummy in + for i = 0 to 6 do v.(i) <- Reg.at_location Addr (Reg i) done; + for i = 7 to 11 do v.(i) <- Reg.at_location Int (Reg i) done; + for i = 12 to 19 do v.(i) <- Reg.at_location Float (Reg i) done; + v + +let phys_reg n = all_phys_regs.(n) + +let stack_slot slot ty = Reg.at_location ty (Stack slot) + +let reg_A0 = phys_reg 0 +let reg_FP0 = phys_reg 12 + +(* Exceptions raised to signal cases not handled here *) + +exception Use_default + +(* Instruction selection *) + +(* Auxiliary for recognizing addressing modes *) + +type addressing_expr = + Asymbol of string + | Alinear of expression + | Aadd of expression * expression + | Ascale of expression * int + | Ascaledadd of expression * expression * int + +let rec select_addr exp = + match exp with + Cconst_symbol s -> + (Asymbol s, 0) + | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop((Csubi | Csuba), [arg; Cconst_int m]) -> + let (a, n) = select_addr arg in (a, n - m) + | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) -> + begin match select_addr arg with + (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift) + | _ -> (Alinear exp, 0) + end + | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) -> + begin match select_addr arg with + (Alinear e, n) -> (Ascale(e, mult), n * mult) + | _ -> (Alinear exp, 0) + end + | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) -> + begin match select_addr arg with + (Alinear e, n) -> (Ascale(e, mult), n * mult) + | _ -> (Alinear exp, 0) + end + | Cop((Caddi | Cadda), [arg1; arg2]) -> + begin match (select_addr arg1, select_addr arg2) with + ((Alinear e1, n1), (Alinear e2, n2)) -> + (Aadd(e1, e2), n1 + n2) + | ((Alinear e1, n1), (Ascale(e2, scale), n2)) -> + (Ascaledadd(e1, e2, scale), n1 + n2) + | ((Ascale(e1, scale), n1), (Alinear e2, n2)) -> + (Ascaledadd(e2, e1, scale), n1 + n2) + | (_, (Ascale(e2, scale), n2)) -> + (Ascaledadd(arg1, e2, scale), n2) + | ((Ascale(e1, scale), n1), _) -> + (Ascaledadd(arg2, e1, scale), n1) + | _ -> + (Aadd(arg1, arg2), 0) + end + | arg -> + (Alinear arg, 0) + +let select_addressing exp = + match select_addr exp with + (Asymbol s, d) -> + (Ibased(s, d), Ctuple []) + | (Alinear e, d) -> + (Iindexed d, e) + | (Aadd(e1, e2), d) -> + (Iindexed2 d, Ctuple[e1; e2]) + | (Ascale(e, scale), d) -> + (Iscaled(scale, d), e) + | (Ascaledadd(e1, e2, scale), d) -> + (Iindexed2scaled(scale, d), Ctuple[e1; e2]) + +(* Selection of immediate shifts *) + +let select_shift op args = + match args with + [arg1; Cconst_int n] when n >= 1 && n <= 8 -> (Iintop_imm(op, n), [arg1]) + | _ -> (Iintop op, args) + +(* Main instruction selection functions *) + +let select_oper op args = + match op with + (* Recognize the LEA instruction *) + Cadda | Csuba -> + begin match select_addressing (Cop(op, args)) with + (Iindexed d, _) -> raise Use_default + | (addr, arg) -> (Ispecific(Ilea addr), [arg]) + end + (* Recognize immediate shifts only if 1 <= count <= 8 *) + | Clsl -> select_shift Ilsl args + | Clsr -> select_shift Ilsr args + | Casr -> select_shift Iasr args + (* Recognize store instructions *) + | Cstore -> + begin match args with + [loc; Cconst_int n] -> + let (addr, arg) = select_addressing loc in + (Ispecific(Istore_int(n, addr)), [arg]) + | [loc; Cconst_pointer n] -> + let (addr, arg) = select_addressing loc in + (Ispecific(Istore_int(n, addr)), [arg]) + | [loc; Cconst_symbol s] -> + let (addr, arg) = select_addressing loc in + (Ispecific(Istore_symbol(s, addr)), [arg]) + | _ -> + raise Use_default + end + | _ -> raise Use_default + +let select_store addr exp = + match exp with + Cconst_int n -> (Ispecific(Istore_int(n, addr)), Ctuple []) + | Cconst_pointer n -> (Ispecific(Istore_int(n, addr)), Ctuple []) + | Cconst_symbol s -> (Ispecific(Istore_symbol(s, addr)), Ctuple []) + | _ -> raise Use_default + +let select_push exp = + match exp with + Cconst_int n -> (Ispecific(Ipush_int n), Ctuple []) + | Cconst_pointer n -> (Ispecific(Ipush_int n), Ctuple []) + | Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple []) + | Cop(Cload ty, [loc]) when ty = typ_float -> + let (addr, arg) = select_addressing loc in + (Ispecific(Ipush_load_float addr), arg) + | Cop(Cload ty, [loc]) when ty = typ_addr or ty = typ_int -> + let (addr, arg) = select_addressing loc in + (Ispecific(Ipush_load addr), arg) + | _ -> (Ispecific(Ipush), exp) + +let pseudoregs_for_operation op arg res = + match op with + (* Two-address binary operations *) + Iintop(Iadd | Isub | Imul | Idiv | Imod | Ilsl | Ilsr | Iasr) | + Iaddf | Isubf | Imulf | Idivf -> + ([|res.(0); arg.(1)|], res, false) + (* Two-address binary operations, forcing the second argument to be + in a data register *) + | Iintop(Iand | Ior | Ixor) -> + let newarg1 = Reg.create Int in + ([|res.(0); newarg1|], res, false) + (* Two-address unary operations *) + | Iintop_imm((Iadd | Isub | Imul | Idiv | Imod | Iand | Ior | Ixor | + Ilsl | Ilsr | Iasr), _) -> + (res, res, false) + (* Other instructions are regular *) + | _ -> raise Use_default + +let is_immediate (n: int) = true + +let word_addressed = false + +(* Calling conventions *) + +let calling_conventions first_addr last_addr first_float last_float + make_stack arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let addr = ref first_addr in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + (Addr | Int) as ty -> + if !addr <= last_addr then begin + loc.(i) <- phys_reg !addr; + incr addr + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_addr + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, !ofs) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 0 5 12 18 outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 0 5 12 18 incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 5 12 18 not_supported res in loc +let extcall_use_push = true +let loc_external_arguments arg = + fatal_error "Proc.loc_external_arguments" +let loc_external_results res = + let (loc, ofs) = calling_conventions 7 7 12 12 not_supported res in loc + +let loc_exn_bucket = reg_A0 + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = + Array.of_list(List.map phys_reg [0; 1; 7; 8; 12; 13]) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | Iop(Iintoffloat) -> [| reg_FP0 |] + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure op = 5 + +let max_register_pressure = function + Iextcall(_, _) -> [| 5; 3; 6 |] + | Iintoffloat -> [| 7; 5; 7 |] + | _ -> num_available_registers + +(* Reloading of instruction arguments, storing of instruction results. *) + +let stackp r = + match r.loc with + Stack _ -> true + | _ -> false + +let reload_test makereg round tst arg = + match tst with + Iinttest _ | Ifloattest _ -> + (* The second argument can be on stack *) + [| makereg arg.(0); arg.(1) |] + | _ -> + (* The argument can be on stack *) + arg + +let reload_operation makereg round op arg res = + match op with + Imove | Ireload | Ispill | + Iintop_imm((Iadd | Isub | Iand | Ior | Ixor | + Icomp _ | Ilsl | Ilsr | Iasr), _) | + Ifloatofint | Iintoffloat | Ispecific(Ipush) -> + (* The argument(s) can be either in register or on stack *) + (arg, res) + | Iintop(Iadd | Isub | Iand | Ior | Ixor | Icomp _) -> + (* One of the two arguments can reside in the stack *) + if stackp arg.(0) && stackp arg.(1) + then ([|arg.(0); makereg arg.(1)|], res) + else (arg, res) + | Iintop(Ilsl | Ilsr | Iasr) -> + (* The first argument and result can reside in the stack *) + ([|arg.(0); makereg arg.(1)|], res) + | Iintop(Imul | Idiv | Imod) | Iaddf | Isubf | Imulf | Idivf -> + (* The second argument can reside in the stack *) + let r = makereg arg.(0) in ([|r; arg.(1)|], [|r|]) + | _ -> (* Other operations: all args and results in registers *) + raise Use_default + +(* Scheduling is turned off. *) + +let need_scheduling = false + +let oper_latency _ = 0 + +(* Layout of the stack frame *) + +let num_stack_slots = [| 0; 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Sys.command ("as -o " ^ outfile ^ " " ^ infile) + +(* Calling the archiver *) + +let create_archive archive file_list = + Misc.remove_file archive; + Sys.command ("ar rc " ^ archive ^ " " ^ String.concat " " file_list ^ + " && ranlib " ^ archive) diff --git a/asmrun/m68k.S b/asmrun/m68k.S new file mode 100644 index 0000000000..100f249732 --- /dev/null +++ b/asmrun/m68k.S @@ -0,0 +1,259 @@ +|*********************************************************************** +|* * +|* Objective Caml * +|* * +|* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +|* * +|* Copyright 1996 Institut National de Recherche en Informatique et * +|* Automatique. Distributed only by permission. * +|* * +|*********************************************************************** + +| $Id$ + +| Asm part of the runtime system, Motorola 68k processor + + .comm _young_limit, 4 + .comm _young_ptr, 4 + .comm _gc_entry_regs, 48 + .comm _caml_bottom_of_stack, 4 + .comm _caml_top_of_stack, 4 + .comm _caml_last_return_address, 4 + .comm _caml_exception_pointer, 4 + .comm _caml_requested_size, 4 + +| Allocation + + .text + .globl _caml_call_gc + .globl _caml_alloc1 + .globl _caml_alloc2 + .globl _caml_alloc3 + .globl _caml_alloc + +_caml_call_gc: + | Save desired size + movel d5, _caml_requested_size + | Record lowest stack address and return address + movel a7@, _caml_last_return_address + movel a7, d5 + addql #4, d5 + movel d5, _caml_bottom_of_stack + | Record current allocation pointer (for debugging) + movel d6, _young_ptr + | Save all regs used by the code generator + movel a0, _gc_entry_regs + movel a1, _gc_entry_regs + 4 + movel a2, _gc_entry_regs + 8 + movel a3, _gc_entry_regs + 12 + movel a4, _gc_entry_regs + 16 + movel a5, _gc_entry_regs + 20 + movel a6, _gc_entry_regs + 24 + movel d0, _gc_entry_regs + 28 + movel d1, _gc_entry_regs + 32 + movel d2, _gc_entry_regs + 36 + movel d3, _gc_entry_regs + 40 + movel d4, _gc_entry_regs + 44 + fmovem fp0-fp7, a7@- + | Call the garbage collector + jbsr _garbage_collection + | Restore all regs used by the code generator + fmovem a7@+, fp0-fp7 + movel _gc_entry_regs, a0 + movel _gc_entry_regs + 4, a1 + movel _gc_entry_regs + 8, a2 + movel _gc_entry_regs + 12, a3 + movel _gc_entry_regs + 16, a4 + movel _gc_entry_regs + 20, a5 + movel _gc_entry_regs + 24, a6 + movel _gc_entry_regs + 28, d0 + movel _gc_entry_regs + 32, d1 + movel _gc_entry_regs + 36, d2 + movel _gc_entry_regs + 40, d3 + movel _gc_entry_regs + 44, d4 + | Reload allocation pointer and allocate block + movel _young_ptr, d6 + subl _caml_requested_size, d6 + | Return to caller + rts + +_caml_alloc1: + subql #8, d6 + cmpl _young_limit, d6 + bcs L100 + rts +L100: moveq #8, d5 + bra _caml_call_gc + +_caml_alloc2: + subl #12, d6 + cmpl _young_limit, d6 + bcs L101 + rts +L101: moveq #12, d5 + bra _caml_call_gc + +_caml_alloc3: + subl #16, d6 + cmpl _young_limit, d6 + bcs L102 + rts +L102: moveq #16, d5 + bra _caml_call_gc + +_caml_alloc: + subl d5, d6 + cmpl _young_limit, d6 + bcs _caml_call_gc + rts + +| Call a C function from Caml + + .globl _caml_c_call + +_caml_c_call: + | Record lowest stack address and return address + movel a7@+, _caml_last_return_address + movel a7, _caml_bottom_of_stack + | Save allocation pointer and exception pointer + movel d6, _young_ptr + movel d7, _caml_exception_pointer + | Call the function (address in a0) + jbsr a0@ + | Reload allocation pointer + movel _young_ptr, d6 + | Return to caller + movel _caml_last_return_address, a1 + jmp a1@ + +| Start the Caml program + + .globl _caml_start_program + +_caml_start_program: + | Save callee-save registers + moveml a2-a6/d2-d7, a7@- + fmovem fp2-fp7, a7@- + | Build an exception handler + pea L103 + pea 0 + movel a7, d7 + | Record highest stack address + movel a7, _caml_top_of_stack + | Load allocation pointer + movel _young_ptr, d6 + | Go for it + jbsr _caml_program + | Pop handler + addql #8, a7 + | Zero return code + clrl d0 + bra L104 +L103: + | Return exception bucket + movel a0, d0 +L104: + | Restore registers and return + fmovem a7@+, fp2-fp7 + moveml a7@+, a2-a6/d2-d7 + rts + +| Raise an exception from C + + .globl _raise_caml_exception +_raise_caml_exception: + movel a7@(4), a0 | exception bucket + movel _young_ptr, d6 + movel _caml_exception_pointer, a7 + movel a7@+, d7 + rts + +| Callback from C to Caml + + .globl _callback +_callback: + link a6, #0 + | Save callee-save registers + moveml a2-a6/d2-d7, a7@- + fmovem fp2-fp7, a7@- + | Initial loading of arguments + movel a6@(8), a1 | closure + movel a6@(12), a0 | argument + movel a1@(0), a5 | code pointer +L106: + | Build a callback link + movel _caml_last_return_address, a7@- + movel _caml_bottom_of_stack, a7@- + | Build an exception handler + pea L108 + movel _caml_exception_pointer, a7@- + movel a7, d7 + | Load allocation pointer + movel _young_ptr, d6 + | Call the Caml code + jbsr a5@ +L107: + | Move result where C code expects it + movel a0, d0 + | Save allocation pointer + movel d6, _young_ptr + | Pop the exception handler + movel a7@+, _caml_exception_pointer + addql #4, a7 + | Pop the callback link, restoring the global variables + | used by caml_c_call + movel a7@+, _caml_bottom_of_stack + movel a7@+, _caml_last_return_address + | Restore callee-save registers and return + fmovem a7@+, fp2-fp7 + moveml a7@+, a2-a6/d2-d7 + unlk a6 + rts +L108: + | Exception handler + | Save allocation pointer and exception pointer + movel d6, _young_ptr + movel d7, _caml_exception_pointer + | Pop the callback link, restoring the global variables + | used by caml_c_call + movel a7@+, _caml_bottom_of_stack + movel a7@+, _caml_last_return_address + | Re-raise the exception through mlraise, + | so that local C roots are cleaned up correctly. + movel a0, a7@- | exn bucket is the argument + jbsr _mlraise | never returns + + .globl _callback2 +_callback2: + link a6, #0 + | Save callee-save registers + moveml a2-a6/d2-d7, a7@- + fmovem fp2-fp7, a7@- + | Initial loading of arguments + movel a6@(8), a2 | closure + movel a6@(12), a0 | first argument + movel a6@(16), a1 | second argument + lea _caml_apply2, a5 | code pointer + bra L106 + + .globl _callback3 +_callback3: + link a6, #0 + | Save callee-save registers + moveml a2-a6/d2-d7, a7@- + fmovem fp2-fp7, a7@- + | Initial loading of arguments + movel a6@(8), a3 | closure + movel a6@(12), a0 | first argument + movel a6@(16), a1 | second argument + movel a6@(20), a2 | third argument + lea _caml_apply3, a5 | code pointer + bra L106 + + .data + .globl _system_frametable +_system_frametable: + .long 1 | one descriptor + .long L107 | return address into callback + .word -1 | negative frame size => use callback link + .word 0 | no roots here diff --git a/asmrun/stack.h b/asmrun/stack.h index 406ecfa654..233cb41b2a 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -59,5 +59,10 @@ #define Callback_link(sp) ((struct callback_link *)(sp + Trap_frame_size)) #endif +#ifdef TARGET_m68k +#define Saved_return_address(sp) *((long *)(sp - 4)) +#define Callback_link(sp) ((struct callback_link *)(sp + 8)) +#endif + #endif /* _stack_ */ diff --git a/byterun/interp.c b/byterun/interp.c index 0b60954bd4..e493c8a331 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -99,6 +99,11 @@ int callback_depth = 0; #define SP_REG asm("%r17") #define ACCU_REG asm("%r16") #endif +#ifdef __mc68000__ +#define PC_REG asm("a5") +#define SP_REG asm("a4") +#define ACCU_REG asm("d7") +#endif #endif /* The interpreter itself */ diff --git a/configure b/configure index 4a9f3e309d..30f42509ec 100755 --- a/configure +++ b/configure @@ -195,6 +195,7 @@ case "$host" in rs6000-*-aix*) arch=power; model=rs6000; system=aix;; powerpc-*-aix*) arch=power; model=ppc; system=aix;; powerpc-*-linux*) arch=power; model=ppc; system=elf;; + m68k-*-sunos*) arch=m68k; system=sunos;; esac case "$arch" in @@ -501,6 +502,7 @@ case "$host" in sparc-*-sunos*) bignum_arch=supersparc;; sparc-*-solaris*) bignum_arch=supersparc-solaris;; sparc-*-*bsd*) bignum_arch=sparc;; + m68k-*-sunos*) bignum_arch=68K;; *) bignum_arch=C esac -- cgit v1.2.1