From 71f4339b60addfa55ce2de1ccceb40aabe63cc31 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Wed, 16 Aug 2017 14:31:25 +0100 Subject: riscv: fix warnings because of unneeded catch-all cases in types.hgen. --- risc-v/hgen/types.hgen | 2 -- 1 file changed, 2 deletions(-) diff --git a/risc-v/hgen/types.hgen b/risc-v/hgen/types.hgen index 87fc9b95..3c4ae55a 100644 --- a/risc-v/hgen/types.hgen +++ b/risc-v/hgen/types.hgen @@ -107,14 +107,12 @@ let pp_riscv_load_op (unsigned, width) = match (unsigned, width) with | (false, RISCVWORD) -> "lw" | (true, RISCVWORD) -> "lwu" | (_, RISCVDOUBLE) -> "ld" - | _ -> failwith "unexpected load op" let pp_riscv_store_op width = match width with | RISCVBYTE -> "sb" | RISCVHALF -> "sh" | RISCVWORD -> "sw" | RISCVDOUBLE -> "sd" -| _ -> failwith "unexpected store op" let pp_riscv_fence_option = function | 0b0011 -> "rw" -- cgit v1.2.3 From cc46b5a2366cd73d34117590448f6779fac4d312 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 17 Aug 2017 13:41:21 +0100 Subject: added RISC-V load-acquire --- etc/regfp.sail | 8 ++++- risc-v/hgen/ast.hgen | 2 +- risc-v/hgen/fold.hgen | 2 +- risc-v/hgen/herdtools_ast_to_shallow_ast.hgen | 5 +-- risc-v/hgen/lexer.hgen | 22 ++++++++----- risc-v/hgen/map.hgen | 2 +- risc-v/hgen/parser.hgen | 2 +- risc-v/hgen/pretty.hgen | 3 +- risc-v/hgen/sail_trans_out.hgen | 3 +- risc-v/hgen/shallow_ast_to_herdtools_ast.hgen | 3 +- risc-v/hgen/token_types.hgen | 2 +- risc-v/hgen/trans_sail.hgen | 3 +- risc-v/hgen/types.hgen | 7 +++-- risc-v/riscv.sail | 45 +++++++++++++++++---------- risc-v/riscv_extras.lem | 6 ++-- risc-v/riscv_extras_embed.lem | 13 +++++--- risc-v/riscv_extras_embed_sequential.lem | 14 ++++++--- risc-v/riscv_regfp.sail | 12 +++++-- src/lem_interp/sail_impl_base.lem | 2 ++ 19 files changed, 104 insertions(+), 52 deletions(-) diff --git a/etc/regfp.sail b/etc/regfp.sail index fb15310a..c98e3fa4 100644 --- a/etc/regfp.sail +++ b/etc/regfp.sail @@ -37,7 +37,10 @@ typedef read_kind = enumerate { Read_acquire; Read_exclusive; Read_exclusive_acquire; - Read_stream + Read_stream; + Read_RISCV_acquire; + Read_RISCV_reserved; + Read_RISCV_reserved_acquire; } typedef write_kind = enumerate { @@ -62,6 +65,9 @@ typedef barrier_kind = enumerate { Barrier_DSB_LD; Barrier_ISB; Barrier_MIPS_SYNC; + Barrier_RISCV_rw_rw; + Barrier_RISCV_r_rw; + Barrier_RISCV_rw_w; } typedef trans_kind = enumerate { diff --git a/risc-v/hgen/ast.hgen b/risc-v/hgen/ast.hgen index 8983b5ae..6e323e85 100644 --- a/risc-v/hgen/ast.hgen +++ b/risc-v/hgen/ast.hgen @@ -5,7 +5,7 @@ | `RISCVIType of bit12 * reg * reg * riscvIop | `RISCVShiftIop of bit6 * reg * reg * riscvSop | `RISCVRType of reg * reg * reg * riscvRop -| `RISCVLoad of bit12 * reg * reg * bool * wordWidth +| `RISCVLoad of bit12 * reg * reg * bool * wordWidth * bool | `RISCVStore of bit12 * reg * reg * wordWidth | `RISCVADDIW of bit12 * reg * reg | `RISCVSHIFTW of bit5 * reg * reg * riscvSop diff --git a/risc-v/hgen/fold.hgen b/risc-v/hgen/fold.hgen index 03318805..be91659b 100644 --- a/risc-v/hgen/fold.hgen +++ b/risc-v/hgen/fold.hgen @@ -6,7 +6,7 @@ | `RISCVIType (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVShiftIop (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVRType (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) -| `RISCVLoad (_, r0, r1, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVLoad (_, r0, r1, _, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVStore (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVADDIW (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVSHIFTW (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) diff --git a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen index 50026612..0e8bfdc2 100644 --- a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen +++ b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen @@ -30,12 +30,13 @@ translate_reg "rs1" rs1, translate_reg "rd" rd, translate_rop op) -| `RISCVLoad(imm, rs, rd, unsigned, width) -> LOAD( +| `RISCVLoad(imm, rs, rd, unsigned, width, aq) -> LOAD( translate_imm12 "imm" imm, translate_reg "rs" rs, translate_reg "rd" rd, translate_bool "unsigned" unsigned, - translate_wordWidth width) + translate_wordWidth width, + translate_bool "aq" aq) | `RISCVStore(imm, rs, rd, width) -> STORE ( translate_imm12 "imm" imm, translate_reg "rs" rs, diff --git a/risc-v/hgen/lexer.hgen b/risc-v/hgen/lexer.hgen index 5f2c8326..c4408139 100644 --- a/risc-v/hgen/lexer.hgen +++ b/risc-v/hgen/lexer.hgen @@ -33,13 +33,21 @@ "or", RTYPE{op=RISCVOR}; "and", RTYPE{op=RISCVAND}; -"lb", LOAD{unsigned=false; width=RISCVBYTE}; -"lbu", LOAD{unsigned=true; width=RISCVBYTE}; -"lh", LOAD{unsigned=false; width=RISCVHALF}; -"lhu", LOAD{unsigned=true; width=RISCVHALF}; -"lw", LOAD{unsigned=false; width=RISCVWORD}; -"lwu", LOAD{unsigned=true; width=RISCVWORD}; -"ld", LOAD{unsigned=false; width=RISCVDOUBLE}; +"lb", LOAD{unsigned=false; width=RISCVBYTE; aq=false}; +"lbu", LOAD{unsigned=true; width=RISCVBYTE; aq=false}; +"lh", LOAD{unsigned=false; width=RISCVHALF; aq=false}; +"lhu", LOAD{unsigned=true; width=RISCVHALF; aq=false}; +"lw", LOAD{unsigned=false; width=RISCVWORD; aq=false}; +"lwu", LOAD{unsigned=true; width=RISCVWORD; aq=false}; +"ld", LOAD{unsigned=false; width=RISCVDOUBLE; aq=false}; + +"lb.aq", LOAD{unsigned=false; width=RISCVBYTE; aq=true}; +"lbu.aq", LOAD{unsigned=true; width=RISCVBYTE; aq=true}; +"lh.aq", LOAD{unsigned=false; width=RISCVHALF; aq=true}; +"lhu.aq", LOAD{unsigned=true; width=RISCVHALF; aq=true}; +"lw.aq", LOAD{unsigned=false; width=RISCVWORD; aq=true}; +"lwu.aq", LOAD{unsigned=true; width=RISCVWORD; aq=true}; +"ld.aq", LOAD{unsigned=false; width=RISCVDOUBLE; aq=true}; "sb", STORE{width=RISCVBYTE}; "sh", STORE{width=RISCVHALF}; diff --git a/risc-v/hgen/map.hgen b/risc-v/hgen/map.hgen index ff14c428..1deacc06 100644 --- a/risc-v/hgen/map.hgen +++ b/risc-v/hgen/map.hgen @@ -5,7 +5,7 @@ | `RISCVIType (x, r0, r1, y) -> `RISCVIType (x, map_reg r0, map_reg r1, y) | `RISCVShiftIop (x, r0, r1, y) -> `RISCVShiftIop (x, map_reg r0, map_reg r1, y) | `RISCVRType (r0, r1, r2, y) -> `RISCVRType (r0, map_reg r1, map_reg r2, y) -| `RISCVLoad (x, r0, r1, y, z) -> `RISCVLoad (x, map_reg r0, map_reg r1, y, z) +| `RISCVLoad (x, r0, r1, y, z, a) -> `RISCVLoad (x, map_reg r0, map_reg r1, y, z, a) | `RISCVStore (x, r0, r1, y) -> `RISCVStore (x, map_reg r0, map_reg r1, y) | `RISCVADDIW (x, r0, r1) -> `RISCVADDIW (x, map_reg r0, map_reg r1) | `RISCVSHIFTW (x, r0, r1, y) -> `RISCVSHIFTW (x, map_reg r0, map_reg r1, y) diff --git a/risc-v/hgen/parser.hgen b/risc-v/hgen/parser.hgen index 37fd8d8d..10257ecd 100644 --- a/risc-v/hgen/parser.hgen +++ b/risc-v/hgen/parser.hgen @@ -13,7 +13,7 @@ | RTYPE reg COMMA reg COMMA reg { `RISCVRType ($6, $4, $2, $1.op) } | LOAD reg COMMA NUM LPAR reg RPAR - { `RISCVLoad($4, $6, $2, $1.unsigned, $1.width) } + { `RISCVLoad($4, $6, $2, $1.unsigned, $1.width, $1.aq) } | STORE reg COMMA NUM LPAR reg RPAR { `RISCVStore($4, $2, $6, $1.width) } | ADDIW reg COMMA reg COMMA NUM diff --git a/risc-v/hgen/pretty.hgen b/risc-v/hgen/pretty.hgen index 1da3ef11..6c4f3e53 100644 --- a/risc-v/hgen/pretty.hgen +++ b/risc-v/hgen/pretty.hgen @@ -7,7 +7,8 @@ | `RISCVIType(imm, rs2, rs1, op) -> sprintf "%s %s, %s, %d" (pp_riscv_iop op) (pp_reg rs1) (pp_reg rs2) imm | `RISCVShiftIop(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm | `RISCVRType (rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_rop op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) -| `RISCVLoad(imm, rs, rd, unsigned, width) -> sprintf "%s %s, %d(%s)" (pp_riscv_load_op (unsigned, width)) (pp_reg rd) imm (pp_reg rs) +| `RISCVLoad(imm, rs, rd, unsigned, width, aq) + -> sprintf "%s %s, %d(%s)" (pp_riscv_load_op (unsigned, width, aq)) (pp_reg rd) imm (pp_reg rs) | `RISCVStore(imm, rs2, rs1, width) -> sprintf "%s %s, %d(%s)" (pp_riscv_store_op width) (pp_reg rs2) imm (pp_reg rs1) | `RISCVADDIW(imm, rs, rd) -> sprintf "addiw %s, %s, %d" (pp_reg rd) (pp_reg rs) imm | `RISCVSHIFTW(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm diff --git a/risc-v/hgen/sail_trans_out.hgen b/risc-v/hgen/sail_trans_out.hgen index dca5bea1..2a161bda 100644 --- a/risc-v/hgen/sail_trans_out.hgen +++ b/risc-v/hgen/sail_trans_out.hgen @@ -6,7 +6,8 @@ | ("ITYPE", [imm; rs1; rd; op]) -> `RISCVIType(translate_out_simm12 imm, translate_out_ireg rs1, translate_out_ireg rd, translate_out_iop op) | ("SHIFTIOP", [imm; rs; rd; op]) -> `RISCVShiftIop(translate_out_imm6 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | ("RTYPE", [rs2; rs1; rd; op]) -> `RISCVRType (translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_rop op) -| ("LOAD", [imm; rs; rd; unsigned; width]) -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width) +| ("LOAD", [imm; rs; rd; unsigned; width; aq]) + -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq) | ("STORE", [imm; rs; rd; width]) -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width) | ("ADDIW", [imm; rs; rd]) -> `RISCVADDIW(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) | ("SHIFTW", [imm; rs; rd; op]) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) diff --git a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen index 6158ebd7..c24ecd8f 100644 --- a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen +++ b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen @@ -6,7 +6,8 @@ | ITYPE( imm, rs1, rd, op) -> `RISCVIType(translate_out_simm12 imm, translate_out_ireg rs1, translate_out_ireg rd, translate_out_iop op) | SHIFTIOP( imm, rs, rd, op) -> `RISCVShiftIop(translate_out_imm6 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | RTYPE( rs2, rs1, rd, op) -> `RISCVRType (translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_rop op) -| LOAD( imm, rs, rd, unsigned, width) -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width) +| LOAD( imm, rs, rd, unsigned, width, aq) + -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq) | STORE( imm, rs, rd, width) -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width) | ADDIW( imm, rs, rd) -> `RISCVADDIW(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) | SHIFTW( imm, rs, rd, op) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) diff --git a/risc-v/hgen/token_types.hgen b/risc-v/hgen/token_types.hgen index 2980b985..ca19c6eb 100644 --- a/risc-v/hgen/token_types.hgen +++ b/risc-v/hgen/token_types.hgen @@ -5,7 +5,7 @@ type token_BType = {op : riscvBop } type token_IType = {op : riscvIop } type token_ShiftIop = {op : riscvSop } type token_RTYPE = {op : riscvRop } -type token_Load = {unsigned: bool; width : wordWidth } +type token_Load = {unsigned: bool; width : wordWidth; aq: bool } type token_Store = {width : wordWidth } type token_ADDIW = unit type token_SHIFTW = {op : riscvSop } diff --git a/risc-v/hgen/trans_sail.hgen b/risc-v/hgen/trans_sail.hgen index df22d9dc..7fdfd516 100644 --- a/risc-v/hgen/trans_sail.hgen +++ b/risc-v/hgen/trans_sail.hgen @@ -58,7 +58,7 @@ translate_rop "op" op; ], []) -| `RISCVLoad(imm, rs, rd, unsigned, width) -> +| `RISCVLoad(imm, rs, rd, unsigned, width, aq) -> ("LOAD", [ translate_imm12 "imm" imm; @@ -66,6 +66,7 @@ translate_reg "rd" rd; translate_bool "unsigned" unsigned; translate_width "width" width; + translate_bool "aq" aq; ], []) | `RISCVStore(imm, rs2, rs1, width) -> diff --git a/risc-v/hgen/types.hgen b/risc-v/hgen/types.hgen index 87fc9b95..bb6d164c 100644 --- a/risc-v/hgen/types.hgen +++ b/risc-v/hgen/types.hgen @@ -99,7 +99,8 @@ type wordWidth = | RISCVWORD | RISCVDOUBLE -let pp_riscv_load_op (unsigned, width) = match (unsigned, width) with +let pp_riscv_load_op (unsigned, width, aq) = + begin match (unsigned, width) with | (false, RISCVBYTE) -> "lb" | (true, RISCVBYTE) -> "lbu" | (false, RISCVHALF) -> "lh" @@ -107,7 +108,9 @@ let pp_riscv_load_op (unsigned, width) = match (unsigned, width) with | (false, RISCVWORD) -> "lw" | (true, RISCVWORD) -> "lwu" | (_, RISCVDOUBLE) -> "ld" - | _ -> failwith "unexpected load op" + | _ -> failwith "unexpected load op" + end + ^ (if aq then ".aq" else "") let pp_riscv_store_op width = match width with | RISCVBYTE -> "sb" diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index 4a80adb0..c9ba5256 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -58,6 +58,17 @@ function forall 'a. 'a effect { escape } not_implemented((string) message) = } val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_acquire +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved_acquire +function forall Nat 'n. (bit[8 * 'n]) effect { rmem } mem_read( (bit[64]) addr, ([|'n|]) width, (bool) aq, (bool) res) = + switch (aq, res) { + case (false, false) -> MEMr(addr, width) + case (true, false) -> MEMr_acquire(addr, width) + case (false, true) -> MEMr_reserved(addr, width) + case (true, true) -> MEMr_reserved_acquire(addr, width) + } + val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval val extern unit -> unit effect { barr } MEM_fence_rw_rw @@ -202,29 +213,29 @@ function clause execute (RTYPE(rs2, rs1, rd, op)) = } in wGPR(rd, result) -union ast member ((bit[12]), regno, regno, bool, word_width) LOAD -function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, BYTE)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b001 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, HALF)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b010 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, WORD)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b011 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, DOUBLE)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b100 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, BYTE)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b101 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, HALF)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b110 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, WORD)) -function clause execute(LOAD(imm, rs1, rd, unsigned, width)) = +union ast member ((bit[12]), regno, regno, bool, word_width, bool) LOAD +function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, BYTE, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b001 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, HALF, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b010 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, WORD, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b011 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, DOUBLE, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b100 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, BYTE, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b101 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, HALF, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b110 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, WORD, false)) +function clause execute(LOAD(imm, rs1, rd, unsigned, width, aq)) = let (bit[64]) addr = rGPR(rs1) + EXTS(imm) in let (bit[64]) result = if unsigned then switch (width) { - case BYTE -> EXTZ(MEMr(addr, 1)) - case HALF -> EXTZ(MEMr(addr, 2)) - case WORD -> EXTZ(MEMr(addr, 4)) - case DOUBLE -> MEMr(addr, 8) + case BYTE -> EXTZ(mem_read(addr, 1, aq, false)) + case HALF -> EXTZ(mem_read(addr, 2, aq, false)) + case WORD -> EXTZ(mem_read(addr, 4, aq, false)) + case DOUBLE -> mem_read(addr, 8, aq, false) } else switch (width) { - case BYTE -> EXTS(MEMr(addr, 1)) - case HALF -> EXTS(MEMr(addr, 2)) - case WORD -> EXTS(MEMr(addr, 4)) - case DOUBLE -> MEMr(addr, 8) + case BYTE -> EXTS(mem_read(addr, 1, aq, false)) + case HALF -> EXTS(mem_read(addr, 2, aq, false)) + case WORD -> EXTS(mem_read(addr, 4, aq, false)) + case DOUBLE -> mem_read(addr, 8, aq, false) } in wGPR(rd, result) diff --git a/risc-v/riscv_extras.lem b/risc-v/riscv_extras.lem index aa5d8fb8..80f8bcc9 100644 --- a/risc-v/riscv_extras.lem +++ b/risc-v/riscv_extras.lem @@ -32,8 +32,10 @@ let memory_parameter_transformer_option_address _mode v = let read_memory_functions : memory_reads = - [ ("MEMr", (MR Read_plain memory_parameter_transformer)); - ("MEMr_reserve", (MR Read_reserve memory_parameter_transformer)); + [ ("MEMr", (MR Read_plain memory_parameter_transformer)); + ("MEMr_acquire", (MR Read_RISCV_acquire memory_parameter_transformer)); + ("MEMr_reserved", (MR Read_RISCV_reserved memory_parameter_transformer)); + ("MEMr_reserved_acquire", (MR Read_RISCV_reserved_acquire memory_parameter_transformer)); ] let memory_writes : memory_writes = diff --git a/risc-v/riscv_extras_embed.lem b/risc-v/riscv_extras_embed.lem index 1146d1cd..440ad378 100644 --- a/risc-v/riscv_extras_embed.lem +++ b/risc-v/riscv_extras_embed.lem @@ -4,11 +4,16 @@ open import Sail_impl_base open import Sail_values open import Prompt -val MEMr : (vector bitU * integer) -> M (vector bitU) -val MEMr_reserve : (vector bitU * integer) -> M (vector bitU) +val MEMr : (vector bitU * integer) -> M (vector bitU) +val MEMr_acquire : (vector bitU * integer) -> M (vector bitU) +val MEMr_reserved : (vector bitU * integer) -> M (vector bitU) +val MEMr_reserved_acquire : (vector bitU * integer) -> M (vector bitU) + +let MEMr (addr,size) = read_mem false Read_plain addr size +let MEMr_acquire (addr,size) = read_mem false Read_RISCV_acquire addr size +let MEMr_reserved (addr,size) = read_mem false Read_RISCV_reserved addr size +let MEMr_reserved_acquire (addr,size) = read_mem false Read_RISCV_reserved_acquire addr size -let MEMr (addr,size) = read_mem false Read_plain addr size -let MEMr_reserve (addr,size) = read_mem false Read_reserve addr size val MEMea : (vector bitU * integer) -> M unit val MEMea_conditional : (vector bitU * integer) -> M unit diff --git a/risc-v/riscv_extras_embed_sequential.lem b/risc-v/riscv_extras_embed_sequential.lem index f6709ff7..518a5a15 100644 --- a/risc-v/riscv_extras_embed_sequential.lem +++ b/risc-v/riscv_extras_embed_sequential.lem @@ -4,11 +4,15 @@ open import Sail_impl_base open import Sail_values open import State -val MEMr : (vector bitU * integer) -> M (vector bitU) -val MEMr_reserve : (vector bitU * integer) -> M (vector bitU) - -let MEMr (addr,size) = read_mem false Read_plain addr size -let MEMr_reserve (addr,size) = read_mem false Read_reserve addr size +val MEMr : (vector bitU * integer) -> M (vector bitU) +val MEMr_acquire : (vector bitU * integer) -> M (vector bitU) +val MEMr_reserved : (vector bitU * integer) -> M (vector bitU) +val MEMr_reserved_acquire : (vector bitU * integer) -> M (vector bitU) + +let MEMr (addr,size) = read_mem false Read_plain addr size +let MEMr_acquire (addr,size) = read_mem false Read_RISCV_acquire addr size +let MEMr_reserved (addr,size) = read_mem false Read_RISCV_reserved addr size +let MEMr_reserved_acquire (addr,size) = read_mem false Read_RISCV_reserved_acquire addr size val MEMea : (vector bitU * integer) -> M unit val MEMea_conditional : (vector bitU * integer) -> M unit diff --git a/risc-v/riscv_regfp.sail b/risc-v/riscv_regfp.sail index 0c7a67d8..fe0efa43 100644 --- a/risc-v/riscv_regfp.sail +++ b/risc-v/riscv_regfp.sail @@ -51,11 +51,11 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; } - case (LOAD ( imm, rs, rd, unsign, width)) -> { (* XXX "unsigned" causes name conflict in lem shallow embedding... *) + case (LOAD ( imm, rs, rd, unsign, width, aq)) -> { (* XXX "unsigned" causes name conflict in lem shallow embedding... *) if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; aR := iR; - ik := IK_mem_read (Read_plain); + ik := if aq then IK_mem_read (Read_RISCV_acquire) else IK_mem_read (Read_plain); } case (STORE( imm, rs2, rs1, width)) -> { if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; @@ -77,7 +77,13 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; } case (FENCE(pred, succ)) -> { - ik := IK_barrier (Barrier_MIPS_SYNC); + ik := + switch(pred, succ) { + case (0b0011, 0b0011) -> IK_barrier (Barrier_RISCV_rw_rw) + case (0b0010, 0b0011) -> IK_barrier (Barrier_RISCV_r_rw) + case (0b0011, 0b0001) -> IK_barrier (Barrier_RISCV_rw_w) + case _ -> exit "unsupported fence" + }; } }; (iR,oR,aR,Nias,Dia,ik) diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index cda6702c..1642bc81 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -426,6 +426,8 @@ type read_kind = | Read_reserve (* AArch64 reads *) | Read_acquire | Read_exclusive | Read_exclusive_acquire | Read_stream + (* RISC-V reads *) + | Read_RISCV_acquire | Read_RISCV_reserved | Read_RISCV_reserved_acquire instance (Show read_kind) let show = function -- cgit v1.2.3 From 9a26a0440f4d3c63ea19976c44cd39edb8149b2a Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Sat, 19 Aug 2017 10:34:04 +0100 Subject: RISC-V store-release --- etc/regfp.sail | 3 ++ risc-v/hgen/ast.hgen | 2 +- risc-v/hgen/fold.hgen | 2 +- risc-v/hgen/herdtools_ast_to_shallow_ast.hgen | 5 ++- risc-v/hgen/lexer.hgen | 13 ++++-- risc-v/hgen/map.hgen | 2 +- risc-v/hgen/parser.hgen | 2 +- risc-v/hgen/pretty.hgen | 3 +- risc-v/hgen/sail_trans_out.hgen | 3 +- risc-v/hgen/shallow_ast_to_herdtools_ast.hgen | 3 +- risc-v/hgen/token_types.hgen | 2 +- risc-v/hgen/trans_sail.hgen | 3 +- risc-v/hgen/types.hgen | 13 +++--- risc-v/riscv.sail | 58 ++++++++++++++++++++------- risc-v/riscv_extras.lem | 22 +++++++--- risc-v/riscv_extras_embed.lem | 31 ++++++++------ risc-v/riscv_extras_embed_sequential.lem | 31 ++++++++------ risc-v/riscv_regfp.sail | 4 +- src/lem_interp/sail_impl_base.lem | 11 +++++ 19 files changed, 147 insertions(+), 66 deletions(-) diff --git a/etc/regfp.sail b/etc/regfp.sail index c98e3fa4..71f53547 100644 --- a/etc/regfp.sail +++ b/etc/regfp.sail @@ -50,6 +50,9 @@ typedef write_kind = enumerate { Write_release; Write_exclusive; Write_exclusive_release; + Write_RISCV_release; + Write_RISCV_conditional; + Write_RISCV_conditional_release; } typedef barrier_kind = enumerate { diff --git a/risc-v/hgen/ast.hgen b/risc-v/hgen/ast.hgen index 6e323e85..d5e4b45b 100644 --- a/risc-v/hgen/ast.hgen +++ b/risc-v/hgen/ast.hgen @@ -6,7 +6,7 @@ | `RISCVShiftIop of bit6 * reg * reg * riscvSop | `RISCVRType of reg * reg * reg * riscvRop | `RISCVLoad of bit12 * reg * reg * bool * wordWidth * bool -| `RISCVStore of bit12 * reg * reg * wordWidth +| `RISCVStore of bit12 * reg * reg * wordWidth * bool | `RISCVADDIW of bit12 * reg * reg | `RISCVSHIFTW of bit5 * reg * reg * riscvSop | `RISCVRTYPEW of reg * reg * reg * riscvRopw diff --git a/risc-v/hgen/fold.hgen b/risc-v/hgen/fold.hgen index be91659b..376ab19f 100644 --- a/risc-v/hgen/fold.hgen +++ b/risc-v/hgen/fold.hgen @@ -7,7 +7,7 @@ | `RISCVShiftIop (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVRType (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) | `RISCVLoad (_, r0, r1, _, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVStore (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVStore (_, r0, r1, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVADDIW (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVSHIFTW (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVRTYPEW (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) diff --git a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen index 0e8bfdc2..d756d3d0 100644 --- a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen +++ b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen @@ -37,11 +37,12 @@ translate_bool "unsigned" unsigned, translate_wordWidth width, translate_bool "aq" aq) -| `RISCVStore(imm, rs, rd, width) -> STORE ( +| `RISCVStore(imm, rs, rd, width, rl) -> STORE ( translate_imm12 "imm" imm, translate_reg "rs" rs, translate_reg "rd" rd, - translate_wordWidth width) + translate_wordWidth width, + translate_bool "rl" rl) | `RISCVADDIW(imm, rs, rd) -> ADDIW( translate_imm12 "imm" imm, translate_reg "rs" rs, diff --git a/risc-v/hgen/lexer.hgen b/risc-v/hgen/lexer.hgen index c4408139..40481f75 100644 --- a/risc-v/hgen/lexer.hgen +++ b/risc-v/hgen/lexer.hgen @@ -49,10 +49,15 @@ "lwu.aq", LOAD{unsigned=true; width=RISCVWORD; aq=true}; "ld.aq", LOAD{unsigned=false; width=RISCVDOUBLE; aq=true}; -"sb", STORE{width=RISCVBYTE}; -"sh", STORE{width=RISCVHALF}; -"sw", STORE{width=RISCVWORD}; -"sd", STORE{width=RISCVDOUBLE}; +"sb", STORE{width=RISCVBYTE; rl=false}; +"sh", STORE{width=RISCVHALF; rl=false}; +"sw", STORE{width=RISCVWORD; rl=false}; +"sd", STORE{width=RISCVDOUBLE; rl=false}; + +"sb.rl", STORE{width=RISCVBYTE; rl=true}; +"sh.rl", STORE{width=RISCVHALF; rl=true}; +"sw.rl", STORE{width=RISCVWORD; rl=true}; +"sd.rl", STORE{width=RISCVDOUBLE; rl=true}; "addiw", ADDIW (); diff --git a/risc-v/hgen/map.hgen b/risc-v/hgen/map.hgen index 1deacc06..edd376b4 100644 --- a/risc-v/hgen/map.hgen +++ b/risc-v/hgen/map.hgen @@ -6,7 +6,7 @@ | `RISCVShiftIop (x, r0, r1, y) -> `RISCVShiftIop (x, map_reg r0, map_reg r1, y) | `RISCVRType (r0, r1, r2, y) -> `RISCVRType (r0, map_reg r1, map_reg r2, y) | `RISCVLoad (x, r0, r1, y, z, a) -> `RISCVLoad (x, map_reg r0, map_reg r1, y, z, a) -| `RISCVStore (x, r0, r1, y) -> `RISCVStore (x, map_reg r0, map_reg r1, y) +| `RISCVStore (x, r0, r1, y, z) -> `RISCVStore (x, map_reg r0, map_reg r1, y, z) | `RISCVADDIW (x, r0, r1) -> `RISCVADDIW (x, map_reg r0, map_reg r1) | `RISCVSHIFTW (x, r0, r1, y) -> `RISCVSHIFTW (x, map_reg r0, map_reg r1, y) | `RISCVRTYPEW (r0, r1, r2, x) -> `RISCVRTYPEW (r0, map_reg r1, map_reg r2, x) diff --git a/risc-v/hgen/parser.hgen b/risc-v/hgen/parser.hgen index 10257ecd..cb31f5a9 100644 --- a/risc-v/hgen/parser.hgen +++ b/risc-v/hgen/parser.hgen @@ -15,7 +15,7 @@ | LOAD reg COMMA NUM LPAR reg RPAR { `RISCVLoad($4, $6, $2, $1.unsigned, $1.width, $1.aq) } | STORE reg COMMA NUM LPAR reg RPAR - { `RISCVStore($4, $2, $6, $1.width) } + { `RISCVStore($4, $2, $6, $1.width, $1.rl) } | ADDIW reg COMMA reg COMMA NUM { `RISCVADDIW ($6, $4, $2) } | SHIFTW reg COMMA reg COMMA NUM diff --git a/risc-v/hgen/pretty.hgen b/risc-v/hgen/pretty.hgen index 6c4f3e53..cce77641 100644 --- a/risc-v/hgen/pretty.hgen +++ b/risc-v/hgen/pretty.hgen @@ -9,7 +9,8 @@ | `RISCVRType (rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_rop op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) | `RISCVLoad(imm, rs, rd, unsigned, width, aq) -> sprintf "%s %s, %d(%s)" (pp_riscv_load_op (unsigned, width, aq)) (pp_reg rd) imm (pp_reg rs) -| `RISCVStore(imm, rs2, rs1, width) -> sprintf "%s %s, %d(%s)" (pp_riscv_store_op width) (pp_reg rs2) imm (pp_reg rs1) +| `RISCVStore(imm, rs2, rs1, width, rl) + -> sprintf "%s %s, %d(%s)" (pp_riscv_store_op (width, rl)) (pp_reg rs2) imm (pp_reg rs1) | `RISCVADDIW(imm, rs, rd) -> sprintf "addiw %s, %s, %d" (pp_reg rd) (pp_reg rs) imm | `RISCVSHIFTW(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm | `RISCVRTYPEW(rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_ropw op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) diff --git a/risc-v/hgen/sail_trans_out.hgen b/risc-v/hgen/sail_trans_out.hgen index 2a161bda..45445a25 100644 --- a/risc-v/hgen/sail_trans_out.hgen +++ b/risc-v/hgen/sail_trans_out.hgen @@ -8,7 +8,8 @@ | ("RTYPE", [rs2; rs1; rd; op]) -> `RISCVRType (translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_rop op) | ("LOAD", [imm; rs; rd; unsigned; width; aq]) -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq) -| ("STORE", [imm; rs; rd; width]) -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width) +| ("STORE", [imm; rs; rd; width; rl]) + -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width, translate_out_bool rl) | ("ADDIW", [imm; rs; rd]) -> `RISCVADDIW(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) | ("SHIFTW", [imm; rs; rd; op]) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | ("RTYPEW", [rs2; rs1; rd; op]) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) diff --git a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen index c24ecd8f..abfc0412 100644 --- a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen +++ b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen @@ -8,7 +8,8 @@ | RTYPE( rs2, rs1, rd, op) -> `RISCVRType (translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_rop op) | LOAD( imm, rs, rd, unsigned, width, aq) -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq) -| STORE( imm, rs, rd, width) -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width) +| STORE( imm, rs, rd, width, rl) + -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width, translate_out_bool rl) | ADDIW( imm, rs, rd) -> `RISCVADDIW(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) | SHIFTW( imm, rs, rd, op) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | RTYPEW( rs2, rs1, rd, op) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) diff --git a/risc-v/hgen/token_types.hgen b/risc-v/hgen/token_types.hgen index ca19c6eb..03dde52b 100644 --- a/risc-v/hgen/token_types.hgen +++ b/risc-v/hgen/token_types.hgen @@ -6,7 +6,7 @@ type token_IType = {op : riscvIop } type token_ShiftIop = {op : riscvSop } type token_RTYPE = {op : riscvRop } type token_Load = {unsigned: bool; width : wordWidth; aq: bool } -type token_Store = {width : wordWidth } +type token_Store = {width : wordWidth; rl: bool } type token_ADDIW = unit type token_SHIFTW = {op : riscvSop } type token_RTYPEW = {op : riscvRopw } diff --git a/risc-v/hgen/trans_sail.hgen b/risc-v/hgen/trans_sail.hgen index 7fdfd516..9fb3b546 100644 --- a/risc-v/hgen/trans_sail.hgen +++ b/risc-v/hgen/trans_sail.hgen @@ -69,13 +69,14 @@ translate_bool "aq" aq; ], []) -| `RISCVStore(imm, rs2, rs1, width) -> +| `RISCVStore(imm, rs2, rs1, width, rl) -> ("STORE", [ translate_imm12 "imm" imm; translate_reg "rs2" rs2; translate_reg "rs1" rs1; translate_width "width" width; + translate_bool "rl" rl; ], []) | `RISCVADDIW(imm, rs, rd) -> diff --git a/risc-v/hgen/types.hgen b/risc-v/hgen/types.hgen index 11d0921e..180e0b37 100644 --- a/risc-v/hgen/types.hgen +++ b/risc-v/hgen/types.hgen @@ -111,11 +111,14 @@ let pp_riscv_load_op (unsigned, width, aq) = end ^ (if aq then ".aq" else "") -let pp_riscv_store_op width = match width with -| RISCVBYTE -> "sb" -| RISCVHALF -> "sh" -| RISCVWORD -> "sw" -| RISCVDOUBLE -> "sd" +let pp_riscv_store_op (width, rl) = + begin match width with + | RISCVBYTE -> "sb" + | RISCVHALF -> "sh" + | RISCVWORD -> "sw" + | RISCVDOUBLE -> "sd" + end + ^ (if rl then ".rl" else "") let pp_riscv_fence_option = function | 0b0011 -> "rw" diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index c9ba5256..3b42b94c 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -70,7 +70,37 @@ function forall Nat 'n. (bit[8 * 'n]) effect { rmem } mem_read( (bit[64]) addr, } val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_release +function forall Nat 'n. unit effect { eamem } mem_write_ea( (bit[64]) addr , ([|'n|]) width, (bool) rl) = + switch rl { + case false -> MEMea(addr, width) + case true -> MEMea_release(addr, width) + } + val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_release +function forall Nat 'n. unit effect { wmv } mem_write_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) rl) = + switch rl { + case false -> MEMval(addr, width, value) + case true -> MEMval_release(addr, width, value) + } + +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_release +function forall Nat 'n. unit effect { eamem } mem_write_conditional_ea( (bit[64]) addr , ([|'n|]) width, (bool) rl) = + switch rl { + case false -> MEMea_conditional(addr, width) + case true -> MEMea_conditional_release(addr, width) + } + +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> bool effect { wmv } MEMval_conditional +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> bool effect { wmv } MEMval_conditional_release +function forall Nat 'n. bool effect { wmv } mem_write_conditional_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) rl) = + switch rl { + case false -> MEMval_conditional(addr, width, value) + case true -> MEMval_conditional_release(addr, width, value) + } + val extern unit -> unit effect { barr } MEM_fence_rw_rw val extern unit -> unit effect { barr } MEM_fence_r_rw val extern unit -> unit effect { barr } MEM_fence_rw_w @@ -239,25 +269,25 @@ function clause execute(LOAD(imm, rs1, rd, unsigned, width, aq)) = } in wGPR(rd, result) -union ast member ((bit[12]), regno, regno, word_width) STORE -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b000 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, BYTE)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b001 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, HALF)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b010 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, WORD)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b011 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, DOUBLE)) -function clause execute (STORE(imm, rs2, rs1, width)) = +union ast member ((bit[12]), regno, regno, word_width, bool) STORE +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b000 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, BYTE, false)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b001 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, HALF, false)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b010 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, WORD, false)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b011 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, DOUBLE, false)) +function clause execute (STORE(imm, rs2, rs1, width, rl)) = let (bit[64]) addr = rGPR(rs1) + EXTS(imm) in { switch (width) { - case BYTE -> MEMea(addr, 1) - case HALF -> MEMea(addr, 2) - case WORD -> MEMea(addr, 4) - case DOUBLE -> MEMea(addr, 8) + case BYTE -> mem_write_ea(addr, 1, rl) + case HALF -> mem_write_ea(addr, 2, rl) + case WORD -> mem_write_ea(addr, 4, rl) + case DOUBLE -> mem_write_ea(addr, 8, rl) }; let rs2_val = rGPR(rs2) in switch (width) { - case BYTE -> MEMval(addr, 1, rs2_val[7..0]) - case HALF -> MEMval(addr, 2, rs2_val[15..0]) - case WORD -> MEMval(addr, 4, rs2_val[31..0]) - case DOUBLE -> MEMval(addr, 8, rs2_val) + case BYTE -> mem_write_value(addr, 1, rs2_val[7..0], rl) + case HALF -> mem_write_value(addr, 2, rs2_val[15..0], rl) + case WORD -> mem_write_value(addr, 4, rs2_val[31..0], rl) + case DOUBLE -> mem_write_value(addr, 8, rs2_val, rl) } } diff --git a/risc-v/riscv_extras.lem b/risc-v/riscv_extras.lem index 80f8bcc9..3803839d 100644 --- a/risc-v/riscv_extras.lem +++ b/risc-v/riscv_extras.lem @@ -42,15 +42,25 @@ let memory_writes : memory_writes = [] let memory_eas : memory_write_eas = - [ ("MEMea", (MEA Write_plain memory_parameter_transformer)); - ("MEMea_conditional", (MEA Write_conditional memory_parameter_transformer)); + [ ("MEMea", (MEA Write_plain memory_parameter_transformer)); + ("MEMea_release", (MEA Write_RISCV_release memory_parameter_transformer)); + ("MEMea_conditional", (MEA Write_RISCV_conditional memory_parameter_transformer)); + ("MEMea_conditional_release", (MEA Write_RISCV_conditional_release memory_parameter_transformer)); ] let memory_vals : memory_write_vals = - [ ("MEMval", (MV memory_parameter_transformer_option_address Nothing)); - ("MEMval_conditional", (MV memory_parameter_transformer_option_address - (Just - (fun (IState interp context) b -> + [ ("MEMval", (MV memory_parameter_transformer_option_address Nothing)); + ("MEMval_release", (MV memory_parameter_transformer_option_address Nothing)); + ("MEMval_conditional", + (MV memory_parameter_transformer_option_address + (Just + (fun (IState interp context) b -> + let bit = Interp_ast.V_lit (L_aux (if b then L_one else L_zero) Interp_ast.Unknown) in + (IState (Interp.add_answer_to_stack interp bit) context))))); + ("MEMval_conditional_release", + (MV memory_parameter_transformer_option_address + (Just + (fun (IState interp context) b -> let bit = Interp_ast.V_lit (L_aux (if b then L_one else L_zero) Interp_ast.Unknown) in (IState (Interp.add_answer_to_stack interp bit) context))))); ] diff --git a/risc-v/riscv_extras_embed.lem b/risc-v/riscv_extras_embed.lem index 440ad378..35d217ff 100644 --- a/risc-v/riscv_extras_embed.lem +++ b/risc-v/riscv_extras_embed.lem @@ -14,18 +14,25 @@ let MEMr_acquire (addr,size) = read_mem false Read_RISCV_acquire addr s let MEMr_reserved (addr,size) = read_mem false Read_RISCV_reserved addr size let MEMr_reserved_acquire (addr,size) = read_mem false Read_RISCV_reserved_acquire addr size - -val MEMea : (vector bitU * integer) -> M unit -val MEMea_conditional : (vector bitU * integer) -> M unit - -let MEMea (addr,size) = write_mem_ea Write_plain addr size -let MEMea_conditional (addr,size) = write_mem_ea Write_conditional addr size - -val MEMval : (vector bitU * integer * vector bitU) -> M unit -val MEMval_conditional : (vector bitU * integer * vector bitU) -> M bitU - -let MEMval (_,_,v) = write_mem_val v >>= fun _ -> return () -let MEMval_conditional (_,_,v) = write_mem_val v >>= fun b -> return (if b then B1 else B0) +val MEMea : (vector bitU * integer) -> M unit +val MEMea_release : (vector bitU * integer) -> M unit +val MEMea_conditional : (vector bitU * integer) -> M unit +val MEMea_conditional_release : (vector bitU * integer) -> M unit + +let MEMea (addr,size) = write_mem_ea Write_plain addr size +let MEMea_release (addr,size) = write_mem_ea Write_RISCV_release addr size +let MEMea_conditional (addr,size) = write_mem_ea Write_RISCV_conditional addr size +let MEMea_conditional_release (addr,size) = write_mem_ea Write_RISCV_conditional_release addr size + +val MEMval : (vector bitU * integer * vector bitU) -> M unit +val MEMval_release : (vector bitU * integer * vector bitU) -> M unit +val MEMval_conditional : (vector bitU * integer * vector bitU) -> M bitU +val MEMval_conditional_release : (vector bitU * integer * vector bitU) -> M bitU + +let MEMval (_,_,v) = write_mem_val v >>= fun _ -> return () +let MEMval_release (_,_,v) = write_mem_val v >>= fun _ -> return () +let MEMval_conditional (_,_,v) = write_mem_val v >>= fun b -> return (if b then B1 else B0) +let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun b -> return (if b then B1 else B0) val MEM_fence_rw_rw : unit -> M unit val MEM_fence_r_rw : unit -> M unit diff --git a/risc-v/riscv_extras_embed_sequential.lem b/risc-v/riscv_extras_embed_sequential.lem index 518a5a15..93b5dfec 100644 --- a/risc-v/riscv_extras_embed_sequential.lem +++ b/risc-v/riscv_extras_embed_sequential.lem @@ -14,18 +14,25 @@ let MEMr_acquire (addr,size) = read_mem false Read_RISCV_acquire addr s let MEMr_reserved (addr,size) = read_mem false Read_RISCV_reserved addr size let MEMr_reserved_acquire (addr,size) = read_mem false Read_RISCV_reserved_acquire addr size -val MEMea : (vector bitU * integer) -> M unit -val MEMea_conditional : (vector bitU * integer) -> M unit - -let MEMea (addr,size) = write_mem_ea Write_plain addr size -let MEMea_conditional (addr,size) = write_mem_ea Write_conditional addr size - - -val MEMval : (vector bitU * integer * vector bitU) -> M unit -val MEMval_conditional : (vector bitU * integer * vector bitU) -> M bitU - -let MEMval (_,_,v) = write_mem_val v >>= fun _ -> return () -let MEMval_conditional (_,_,v) = write_mem_val v >>= fun b -> return (if b then B1 else B0) +val MEMea : (vector bitU * integer) -> M unit +val MEMea_release : (vector bitU * integer) -> M unit +val MEMea_conditional : (vector bitU * integer) -> M unit +val MEMea_conditional_release : (vector bitU * integer) -> M unit + +let MEMea (addr,size) = write_mem_ea Write_plain addr size +let MEMea_release (addr,size) = write_mem_ea Write_RISCV_release addr size +let MEMea_conditional (addr,size) = write_mem_ea Write_RISCV_conditional addr size +let MEMea_conditional_release (addr,size) = write_mem_ea Write_RISCV_conditional_release addr size + +val MEMval : (vector bitU * integer * vector bitU) -> M unit +val MEMval_release : (vector bitU * integer * vector bitU) -> M unit +val MEMval_conditional : (vector bitU * integer * vector bitU) -> M bitU +val MEMval_conditional_release : (vector bitU * integer * vector bitU) -> M bitU + +let MEMval (_,_,v) = write_mem_val v >>= fun _ -> return () +let MEMval_release (_,_,v) = write_mem_val v >>= fun _ -> return () +let MEMval_conditional (_,_,v) = write_mem_val v >>= fun b -> return (if b then B1 else B0) +let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun b -> return (if b then B1 else B0) val MEM_fence_rw_rw : unit -> M unit val MEM_fence_r_rw : unit -> M unit diff --git a/risc-v/riscv_regfp.sail b/risc-v/riscv_regfp.sail index fe0efa43..2c94012e 100644 --- a/risc-v/riscv_regfp.sail +++ b/risc-v/riscv_regfp.sail @@ -57,11 +57,11 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( aR := iR; ik := if aq then IK_mem_read (Read_RISCV_acquire) else IK_mem_read (Read_plain); } - case (STORE( imm, rs2, rs1, width)) -> { + case (STORE( imm, rs2, rs1, width, rl)) -> { if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; if (rs1 == 0) then () else aR := RFull(GPRstr[rs1]) :: aR; - ik := IK_mem_write (Write_plain); + ik := if rl then IK_mem_write (Write_RISCV_release) else IK_mem_write (Write_plain); } case (ADDIW ( imm, rs, rd)) -> { if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 1642bc81..caec3838 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -437,6 +437,9 @@ instance (Show read_kind) | Read_exclusive -> "Read_exclusive" | Read_exclusive_acquire -> "Read_exclusive_acquire" | Read_stream -> "Read_stream" + | Read_RISCV_acquire -> "Read_RISCV_acquire" + | Read_RISCV_reserved -> "Read_RISCV_reserved" + | Read_RISCV_reserved_acquire -> "Read_RISCV_reserved_acquire" end end @@ -447,6 +450,8 @@ type write_kind = | Write_conditional (* AArch64 writes *) | Write_release | Write_exclusive | Write_exclusive_release + (* RISC-V *) + | Write_RISCV_release | Write_RISCV_conditional | Write_RISCV_conditional_release instance (Show write_kind) let show = function @@ -455,6 +460,9 @@ instance (Show write_kind) | Write_release -> "Write_release" | Write_exclusive -> "Write_exclusive" | Write_exclusive_release -> "Write_exclusive_release" + | Write_RISCV_release -> "Write_RISCV_release" + | Write_RISCV_conditional -> "Write_RISCV_conditional" + | Write_RISCV_conditional_release -> "Write_RISCV_conditional_release" end end @@ -488,6 +496,9 @@ instance (Show barrier_kind) | Barrier_ISB -> "Barrier_ISB" | Barrier_TM_COMMIT -> "Barrier_TM_COMMIT" | Barrier_MIPS_SYNC -> "Barrier_MIPS_SYNC" + | Barrier_RISCV_rw_rw -> "Barrier_RISCV_rw_rw" + | Barrier_RISCV_r_rw -> "Barrier_RISCV_r_rw" + | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" end end -- cgit v1.2.3 From 56b661f4d0d4ef4aa5107f73efbee7d7e8df8fea Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Mon, 21 Aug 2017 14:44:12 +0100 Subject: RISC-V load-reserved and store-conditional --- risc-v/hgen/ast.hgen | 2 ++ risc-v/hgen/fold.hgen | 2 ++ risc-v/hgen/herdtools_ast_to_shallow_ast.hgen | 17 +++++++++++-- risc-v/hgen/lexer.hgen | 10 ++++++++ risc-v/hgen/map.hgen | 2 ++ risc-v/hgen/parser.hgen | 4 +++ risc-v/hgen/pretty.hgen | 15 ++++++++++++ risc-v/hgen/sail_trans_out.hgen | 4 +++ risc-v/hgen/shallow_ast_to_herdtools_ast.hgen | 4 +++ risc-v/hgen/token_types.hgen | 2 ++ risc-v/hgen/tokens.hgen | 2 ++ risc-v/hgen/trans_sail.hgen | 21 ++++++++++++++++ risc-v/hgen/types.hgen | 20 +++++++++++++++ risc-v/riscv.sail | 35 +++++++++++++++++++++++++++ risc-v/riscv_regfp.sail | 22 ++++++++++++++++- 15 files changed, 159 insertions(+), 3 deletions(-) diff --git a/risc-v/hgen/ast.hgen b/risc-v/hgen/ast.hgen index d5e4b45b..a0a59e4a 100644 --- a/risc-v/hgen/ast.hgen +++ b/risc-v/hgen/ast.hgen @@ -11,3 +11,5 @@ | `RISCVSHIFTW of bit5 * reg * reg * riscvSop | `RISCVRTYPEW of reg * reg * reg * riscvRopw | `RISCVFENCE of bit4 * bit4 +| `RISCVLoadRes of bool * bool * reg * wordWidth * reg +| `RISCVStoreCon of bool * bool * reg * reg * wordWidth * reg diff --git a/risc-v/hgen/fold.hgen b/risc-v/hgen/fold.hgen index 376ab19f..4cbaf779 100644 --- a/risc-v/hgen/fold.hgen +++ b/risc-v/hgen/fold.hgen @@ -11,3 +11,5 @@ | `RISCVADDIW (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVSHIFTW (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) | `RISCVRTYPEW (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) +| `RISCVLoadRes (_, _, rs1, _, rd) -> fold_reg rs1 (fold_reg rd (y_reg, y_sreg)) +| `RISCVStoreCon (_, _, rs2, rs1, _, rd) -> fold_reg rs2 (fold_reg rs1 (fold_reg rd (y_reg, y_sreg))) diff --git a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen index d756d3d0..ffea1575 100644 --- a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen +++ b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen @@ -58,5 +58,18 @@ translate_reg "rd" rd, translate_ropw op) | `RISCVFENCE(pred, succ) -> FENCE( - translate_imm4 "pred" pred, - translate_imm4 "succ" succ) + translate_imm4 "pred" pred, + translate_imm4 "succ" succ) +| `RISCVLoadRes(aq, rl, rs1, width, rd) -> LOADRES( + translate_bool "aq" aq, + translate_bool "rl" rl, + translate_reg "rs1" rs1, + translate_wordWidth width, + translate_reg "rd" rd) +| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> STORECON( + translate_bool "aq" aq, + translate_bool "rl" rl, + translate_reg "rs2" rs2, + translate_reg "rs1" rs1, + translate_wordWidth width, + translate_reg "rd" rd) diff --git a/risc-v/hgen/lexer.hgen b/risc-v/hgen/lexer.hgen index 40481f75..abc0ff82 100644 --- a/risc-v/hgen/lexer.hgen +++ b/risc-v/hgen/lexer.hgen @@ -75,3 +75,13 @@ "r", FENCEOPTION Fence_R; "w", FENCEOPTION Fence_W; "rw", FENCEOPTION Fence_RW; + +"lr.w", LOADRES {width=RISCVWORD; aq=false; rl=false}; +"lr.w.aq", LOADRES {width=RISCVWORD; aq=true; rl=false}; +"lr.d", LOADRES {width=RISCVDOUBLE; aq=false; rl=false}; +"lr.d.aq", LOADRES {width=RISCVDOUBLE; aq=true; rl=false}; + +"sc.w", STORECON {width=RISCVWORD; aq=false; rl=false}; +"sc.w.rl", STORECON {width=RISCVWORD; aq=false; rl=true}; +"sc.d", STORECON {width=RISCVDOUBLE; aq=false; rl=false}; +"sc.d.rl", STORECON {width=RISCVDOUBLE; aq=false; rl=true}; diff --git a/risc-v/hgen/map.hgen b/risc-v/hgen/map.hgen index edd376b4..639a68bd 100644 --- a/risc-v/hgen/map.hgen +++ b/risc-v/hgen/map.hgen @@ -10,3 +10,5 @@ | `RISCVADDIW (x, r0, r1) -> `RISCVADDIW (x, map_reg r0, map_reg r1) | `RISCVSHIFTW (x, r0, r1, y) -> `RISCVSHIFTW (x, map_reg r0, map_reg r1, y) | `RISCVRTYPEW (r0, r1, r2, x) -> `RISCVRTYPEW (r0, map_reg r1, map_reg r2, x) +| `RISCVLoadRes (aq, rl, rs1, w, rd) -> `RISCVLoadRes (aq, rl, map_reg rs1, w, map_reg rd) +| `RISCVStoreCon (aq, rl, rs2, rs1, w, rd) -> `RISCVStoreCon (aq, rl, map_reg rs2, map_reg rs1, w, map_reg rd) diff --git a/risc-v/hgen/parser.hgen b/risc-v/hgen/parser.hgen index cb31f5a9..d077c2df 100644 --- a/risc-v/hgen/parser.hgen +++ b/risc-v/hgen/parser.hgen @@ -34,3 +34,7 @@ | (Fence_W, Fence_R) -> failwith "'fence w,r' is not supported" | (Fence_W, Fence_W) -> failwith "'fence w,w' is not supported" } +| LOADRES reg COMMA LPAR reg RPAR + { `RISCVLoadRes($1.aq, $1.rl, $5, $1.width, $2) } +| STORECON reg COMMA reg COMMA LPAR reg RPAR + { `RISCVStoreCon($1.aq, $1.rl, $4, $7, $1.width, $2) } diff --git a/risc-v/hgen/pretty.hgen b/risc-v/hgen/pretty.hgen index cce77641..b4516b16 100644 --- a/risc-v/hgen/pretty.hgen +++ b/risc-v/hgen/pretty.hgen @@ -15,3 +15,18 @@ | `RISCVSHIFTW(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm | `RISCVRTYPEW(rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_ropw op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) | `RISCVFENCE(pred, succ) -> sprintf "fence %s, %s" (pp_riscv_fence_option pred) (pp_riscv_fence_option succ) +| `RISCVLoadRes(aq, rl, rs1, width, rd) + -> + assert (rl = false); + sprintf "%s %s, (%s)" + (pp_riscv_load_reserved_op (aq, rl, width)) + (pp_reg rd) + (pp_reg rs1) +| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) + -> + assert (aq = false); + sprintf "%s %s, %s, (%s)" + (pp_riscv_store_conditional_op (aq, rl, width)) + (pp_reg rd) + (pp_reg rs2) + (pp_reg rs1) diff --git a/risc-v/hgen/sail_trans_out.hgen b/risc-v/hgen/sail_trans_out.hgen index 45445a25..f216180a 100644 --- a/risc-v/hgen/sail_trans_out.hgen +++ b/risc-v/hgen/sail_trans_out.hgen @@ -14,3 +14,7 @@ | ("SHIFTW", [imm; rs; rd; op]) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | ("RTYPEW", [rs2; rs1; rd; op]) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) | ("FENCE", [pred; succ]) -> `RISCVFENCE(translate_out_imm4 pred, translate_out_imm4 succ) +| ("LOADRES", [aq; rl; rs1; width; rd]) + -> `RISCVLoadRes(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) +| ("STORECON", [aq; rl; rs2; rs1; width; rd]) + -> `RISCVStoreCon(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) diff --git a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen index abfc0412..01d8dded 100644 --- a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen +++ b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen @@ -14,3 +14,7 @@ | SHIFTW( imm, rs, rd, op) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | RTYPEW( rs2, rs1, rd, op) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) | FENCE( pred, succ) -> `RISCVFENCE(translate_out_imm4 pred, translate_out_imm4 succ) +| LOADRES( aq, rl, rs1, width, rd) + -> `RISCVLoadRes(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) +| STORECON( aq, rl, rs2, rs1, width, rd) + -> `RISCVStoreCon(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) diff --git a/risc-v/hgen/token_types.hgen b/risc-v/hgen/token_types.hgen index 03dde52b..c0ef8445 100644 --- a/risc-v/hgen/token_types.hgen +++ b/risc-v/hgen/token_types.hgen @@ -11,5 +11,7 @@ type token_ADDIW = unit type token_SHIFTW = {op : riscvSop } type token_RTYPEW = {op : riscvRopw } type token_FENCE = unit +type token_LoadRes = {width : wordWidth; aq: bool; rl: bool } +type token_StoreCon = {width : wordWidth; aq: bool; rl: bool } type token_FENCEOPTION = Fence_R | Fence_W | Fence_RW diff --git a/risc-v/hgen/tokens.hgen b/risc-v/hgen/tokens.hgen index f952cf77..1276fd68 100644 --- a/risc-v/hgen/tokens.hgen +++ b/risc-v/hgen/tokens.hgen @@ -12,3 +12,5 @@ %token RTYPEW %token FENCE %token FENCEOPTION +%token LOADRES +%token STORECON diff --git a/risc-v/hgen/trans_sail.hgen b/risc-v/hgen/trans_sail.hgen index 9fb3b546..4d568fe8 100644 --- a/risc-v/hgen/trans_sail.hgen +++ b/risc-v/hgen/trans_sail.hgen @@ -112,3 +112,24 @@ translate_imm4 "succ" succ; ], []) +| `RISCVLoadRes(aq, rl, rs1, width, rd) -> + ("LOADRES", + [ + translate_bool "aq" aq; + translate_bool "rl" rl; + translate_reg "rs1" rs1; + translate_width "width" width; + translate_reg "rd" rd; + ], + []) +| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> + ("STORECON", + [ + translate_bool "aq" aq; + translate_bool "rl" rl; + translate_reg "rs2" rs2; + translate_reg "rs1" rs1; + translate_width "width" width; + translate_reg "rd" rd; + ], + []) diff --git a/risc-v/hgen/types.hgen b/risc-v/hgen/types.hgen index 180e0b37..1471812c 100644 --- a/risc-v/hgen/types.hgen +++ b/risc-v/hgen/types.hgen @@ -120,6 +120,26 @@ let pp_riscv_store_op (width, rl) = end ^ (if rl then ".rl" else "") +let pp_riscv_load_reserved_op (aq, rl, width) = + "lr" ^ + begin match width with + | RISCVWORD -> ".w" + | RISCVDOUBLE -> ".d" + | _ -> assert false + end ^ + (if aq then ".aq" else "") ^ + (if rl then ".rl" else "") + +let pp_riscv_store_conditional_op (aq, rl, width) = + "sc" ^ + begin match width with + | RISCVWORD -> ".w" + | RISCVDOUBLE -> ".d" + | _ -> assert false + end ^ + (if aq then ".aq" else "") ^ + (if rl then ".rl" else "") + let pp_riscv_fence_option = function | 0b0011 -> "rw" | 0b0010 -> "r" diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index 3b42b94c..b5a25578 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -353,6 +353,41 @@ union ast member unit EBREAK function clause decode (0b000000000001 : 0b00000 : 0b000 : 0b00000 : 0b1110011) = Some(EBREAK ()) function clause execute EBREAK = { exit () } +union ast member (bool, bool, regno, word_width, regno) LOADRES +function clause decode (0b00010 : [aq] : [rl] : 0b00000 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(LOADRES(aq, rl, rs1, WORD, rd)) +function clause decode (0b00010 : [aq] : [rl] : 0b00000 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(LOADRES(aq, rl, rs1, DOUBLE, rd)) +function clause execute(LOADRES(aq, rl, rs1, width, rd)) = + if rl then not_implemented("load-reserved-release is not implemented") + else { + let (bit[64]) addr = rGPR(rs1) in + let (bit[64]) result = + switch width { + case WORD -> EXTS(mem_read(addr, 4, aq, true)) + case DOUBLE -> mem_read(addr, 8, aq, true) + } in + wGPR(rd, result) + } + +union ast member (bool, bool, regno, regno, word_width, regno) STORECON +function clause decode (0b00011 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(STORECON(aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b00011 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(STORECON(aq, rl, rs2, rs1, DOUBLE, rd)) +function clause execute (STORECON(aq, rl, rs2, rs1, width, rd)) = { + if aq then not_implemented("store-conditional-acquire is not implemented"); + (bit[64]) addr := rGPR(rs1); + switch width { + case WORD -> mem_write_conditional_ea(addr, 4, rl) + case DOUBLE -> mem_write_conditional_ea(addr, 8, rl) + }; + rs2_val := rGPR(rs2); + (bool) success := + switch width { + case WORD -> mem_write_conditional_value(addr, 4, rs2_val[31..0], rl) + case DOUBLE -> mem_write_conditional_value(addr, 8, rs2_val, rl) + }; + if success then wGPR(rd, 0) + else wGPR(rd, 1); +} + function clause decode _ = None diff --git a/risc-v/riscv_regfp.sail b/risc-v/riscv_regfp.sail index 2c94012e..1cfc68d7 100644 --- a/risc-v/riscv_regfp.sail +++ b/risc-v/riscv_regfp.sail @@ -82,7 +82,27 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( case (0b0011, 0b0011) -> IK_barrier (Barrier_RISCV_rw_rw) case (0b0010, 0b0011) -> IK_barrier (Barrier_RISCV_r_rw) case (0b0011, 0b0001) -> IK_barrier (Barrier_RISCV_rw_w) - case _ -> exit "unsupported fence" + case _ -> exit "not implemented" + }; + } + case (LOADRES ( aq, rl, rs1, width, rd)) -> { + if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + aR := iR; + ik := switch (aq, rl) { + case (false, false) -> IK_mem_read (Read_RISCV_reserved) + case (true, false) -> IK_mem_read (Read_RISCV_reserved_acquire) + case (_, true) -> exit "not implemented" + }; + } + case (STORECON( aq, rl, rs2, rs1, width, rd)) -> { + if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; + if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; + if (rs1 == 0) then () else aR := RFull(GPRstr[rs1]) :: aR; + ik := switch (aq, rl) { + case (false, false) -> IK_mem_write (Write_RISCV_conditional) + case (false, true) -> IK_mem_write (Write_RISCV_conditional_release) + case (true, _) -> exit "not implemented" }; } }; -- cgit v1.2.3 From faf546790ae218522dc0a465059ee4abee3e4135 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 21 Aug 2017 17:40:57 +0100 Subject: port x86 model to old type checker. --- x86/Makefile | 3 + x86/x64.sail | 1333 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 1336 insertions(+) create mode 100644 x86/Makefile create mode 100644 x86/x64.sail diff --git a/x86/Makefile b/x86/Makefile new file mode 100644 index 00000000..2bc4c1a4 --- /dev/null +++ b/x86/Makefile @@ -0,0 +1,3 @@ +all: + ../src/sail.native -o x86 -lem -lem_lib X86_extras_embed ../etc/regfp.sail x64.sail + ../src/sail.native -o x86 -lem_ast ../etc/regfp.sail x64.sail diff --git a/x86/x64.sail b/x86/x64.sail new file mode 100644 index 00000000..16c71d12 --- /dev/null +++ b/x86/x64.sail @@ -0,0 +1,1333 @@ +(*========================================================================*) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(*========================================================================*) + +default Order dec + +val extern forall Type 'a. ('a, list<'a>) -> bool effect pure ismember +val extern forall Type 'a. list<'a> -> nat effect pure listlength + +function (bit[8 ]) ASR8 ((bit[8 ]) v, ([|8 |]) shift) = let v2 = ((bit[16 ]) (EXTS(v))) in (bit[8 ]) (mask(v2 >> shift)) +function (bit[16]) ASR16 ((bit[16]) v, ([|16|]) shift) = let v2 = ((bit[32 ]) (EXTS(v))) in (bit[16]) (mask(v2 >> shift)) +function (bit[32]) ASR32 ((bit[32]) v, ([|32|]) shift) = let v2 = ((bit[64 ]) (EXTS(v))) in (bit[32]) (mask(v2 >> shift)) +function (bit[64]) ASR64 ((bit[64]) v, ([|64|]) shift) = let v2 = ((bit[128]) (EXTS(v))) in (bit[64]) (mask(v2 >> shift)) + +function (bit[8 ]) ROR8 ((bit[8 ]) v, ([|8 |]) shift) = let v2 = ((bit[16 ]) (v:v)) in (bit[8 ]) (mask(v2 >> shift)) +function (bit[16]) ROR16 ((bit[16]) v, ([|16|]) shift) = let v2 = ((bit[32 ]) (v:v)) in (bit[16]) (mask(v2 >> shift)) +function (bit[32]) ROR32 ((bit[32]) v, ([|32|]) shift) = let v2 = ((bit[64 ]) (v:v)) in (bit[32]) (mask(v2 >> shift)) +function (bit[64]) ROR64 ((bit[64]) v, ([|64|]) shift) = let v2 = ((bit[128]) (v:v)) in (bit[64]) (mask(v2 >> shift)) + +function (bit[8 ]) ROL8 ((bit[8 ]) v, ([|8 |]) shift) = let v2 = ((bit[16 ]) (v:v)) in (bit[8 ]) (mask(v2 << shift)) +function (bit[16]) ROL16 ((bit[16]) v, ([|16|]) shift) = let v2 = ((bit[32 ]) (v:v)) in (bit[16]) (mask(v2 << shift)) +function (bit[32]) ROL32 ((bit[32]) v, ([|32|]) shift) = let v2 = ((bit[64 ]) (v:v)) in (bit[32]) (mask(v2 << shift)) +function (bit[64]) ROL64 ((bit[64]) v, ([|64|]) shift) = let v2 = ((bit[128]) (v:v)) in (bit[64]) (mask(v2 << shift)) + +(*val cast bool -> bit effect pure cast_bool_bit +val cast bit -> int effect pure cast_bit_int *) +function forall Nat 'n, Nat 'm, Nat 'o, 'n <= 0, 'm <= 'o. ([|0:'o|]) negative_to_zero (([|'n:'m|]) x) = + if x < 0 then 0 else x + +typedef byte = bit[8] +typedef qword = bit[64] +typedef regn = [|15|] +typedef byte_stream = list +typedef ostream = option + +(* -------------------------------------------------------------------------- + Registers + -------------------------------------------------------------------------- *) + +(* Program Counter *) + +register qword RIP + +(* General purpose registers *) + +register qword RAX (* 0 *) +register qword RCX (* 1 *) +register qword RDX (* 2 *) +register qword RBX (* 3 *) +register qword RSP (* 4 *) +register qword RBP (* 5 *) +register qword RSI (* 6 *) +register qword RDI (* 7 *) +register qword R8 +register qword R9 +register qword R10 +register qword R11 +register qword R12 +register qword R13 +register qword R14 +register qword R15 + +let (vector<0,16,inc,(register)>) REG = + [RAX,RCX,RDX,RBX,RSP,RBP,RSI,RDI,R8,R9,R10,R11,R12,R13,R14,R15] + +(* Flags *) + +register bit[1] CF +register bit[1] PF +register bit[1] AF +register bit[1] ZF +register bit[1] SF +register bit[1] OF + +(* -------------------------------------------------------------------------- + Memory + -------------------------------------------------------------------------- *) + +val extern forall Nat 'n. (qword, [|'n|]) -> (bit[8 * 'n]) effect { rmem } rMEM + + + +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval + +function forall Nat 'n. unit effect {eamem, wmv} wMEM ((qword) addr, ([|'n|]) len, (bit[8 * 'n]) data) = { + MEMea(addr, len); + MEMval(addr, len, data); +} + +(* -------------------------------------------------------------------------- + Helper functions + -------------------------------------------------------------------------- *) + +(* Instruction addressing modes *) + +typedef size = const union { + bool Sz8; + unit Sz16; + unit Sz32; + unit Sz64; +} + +typedef base = const union { + unit NoBase; + unit RipBase; + regn RegBase; +} + +typedef scale_index = (bit[2],regn) + +typedef rm = const union { + regn Reg; + (option,base,qword) Mem; +} + +typedef dest_src = const union { + (rm,qword) Rm_i; + (rm,regn) Rm_r; + (regn,rm) R_rm; +} + +typedef imm_rm = const union { + rm Rm; + qword Imm; +} + +typedef monop_name = enumerate { Dec; Inc; Not; Neg } + +typedef binop_name = enumerate { + Add; Or; Adc; Sbb; And; Sub; Xor; Cmp; Rol; Ror; Rcl; Rcr; Shl; Shr; Test; Sar +} + +function binop_name opc_to_binop_name ((bit[4]) opc) = + switch opc + { + case 0x0 -> Add + case 0x1 -> Or + case 0x2 -> Adc + case 0x3 -> Sbb + case 0x4 -> And + case 0x5 -> Sub + case 0x6 -> Xor + case 0x7 -> Cmp + case 0x8 -> Rol + case 0x9 -> Ror + case 0xa -> Rcl + case 0xb -> Rcr + case 0xc -> Shl + case 0xd -> Shr + case 0xe -> Test + case 0xf -> Sar + } + +typedef cond = enumerate { + O; NO; B; NB; E; NE; NA; A; S; NS; P; NP; L; NL; NG; G; ALWAYS +} + +function cond bv_to_cond ((bit[4]) v) = + switch v + { + case 0x0 -> O + case 0x1 -> NO + case 0x2 -> B + case 0x3 -> NB + case 0x4 -> E + case 0x5 -> NE + case 0x6 -> NA + case 0x7 -> A + case 0x8 -> S + case 0x9 -> NS + case 0xa -> P + case 0xb -> NP + case 0xc -> L + case 0xd -> NL + case 0xe -> NG + case 0xf -> G + } + +(* Effective addresses *) + +typedef ea = const union { + (size,qword) Ea_i; + (size,regn) Ea_r; + (size,qword) Ea_m; +} + +function qword ea_index ((option) index) = + switch (index) { + case None -> 0x0000000000000000 + case (Some(scale, idx)) -> + let x = (qword) (0x0000000000000001 << scale) in + let y = (qword) (REG[idx]) in + let z = (bit[128]) (x * y) in + z[63 .. 0] + } + +function qword ea_base ((base) b) = + switch b { + case NoBase -> 0x0000000000000000 + case RipBase -> RIP + case (RegBase(b)) -> REG[b] + } + +function ea ea_rm ((size) sz, (rm) r) = + switch r { + case (Reg(n)) -> Ea_r (sz, n) + case (Mem(idx, b, d)) -> Ea_m (sz, ea_index(idx) + (qword) (ea_base(b) + d)) + } + +function ea ea_dest ((size) sz, (dest_src) ds) = + switch ds { + case (Rm_i (v, _)) -> ea_rm (sz, v) + case (Rm_r (v, _)) -> ea_rm (sz, v) + case (R_rm (v, _)) -> Ea_r (sz, v) + } + +function ea ea_src ((size) sz, (dest_src) ds) = + switch ds { + case (Rm_i (_, v)) -> Ea_i (sz, v) + case (Rm_r (_, v)) -> Ea_r (sz, v) + case (R_rm (_, v)) -> ea_rm (sz, v) + } + +function ea ea_imm_rm ((imm_rm) i_rm) = + switch i_rm { + case (Rm (v)) -> ea_rm (Sz64, v) + case (Imm (v)) -> Ea_i (Sz64, v) + } + +function qword restrict_size ((size) sz, (qword) imm) = + switch sz { + case (Sz8(_)) -> imm & 0x00000000000000FF + case Sz16 -> imm & 0x000000000000FFFF + case Sz32 -> imm & 0x00000000FFFFFFFF + case Sz64 -> imm + } + +function regn sub4 ((regn) r) = negative_to_zero (r - 4) + +function qword effect { rreg, rmem } EA ((ea) e) = + switch e { + case (Ea_i(sz,i)) -> restrict_size(sz,i) + case (Ea_r((Sz8(have_rex)),r)) -> + if have_rex | r < 4 (* RSP *) | r > 7 (* RDI *) then + REG[r] + else + (REG[sub4 (r)] >> 8) & 0x00000000000000FF + case (Ea_r(sz,r)) -> restrict_size(sz, REG[r]) + case (Ea_m((Sz8(_)),a)) -> EXTZ (rMEM(a, 1)) + case (Ea_m(Sz16,a)) -> EXTZ (rMEM(a, 2)) + case (Ea_m(Sz32,a)) -> EXTZ (rMEM(a, 4)) + case (Ea_m(Sz64,a)) -> rMEM(a, 8) + } + +function unit effect { wmem, wreg, escape } wEA ((ea) e, (qword) w) = + switch e { + case (Ea_i(_,_)) -> exit () + case (Ea_r((Sz8(have_rex)),r)) -> + if have_rex | r < 4 (* RSP *) | r > 7 (* RDI *) then + { + (qword) regr := REG[r]; + regr[7 .. 0] := w[7 .. 0]; + REG[r] := regr + } + else + { + (qword) regr := REG[sub4(r)]; + regr[15 .. 8] := (vector<15,8,dec,bit>) (w[7 .. 0]); + REG[sub4(r)] := regr + } + case (Ea_r(Sz16,r)) -> + { + (qword) regr := REG[r]; + regr[15 .. 8] := w[15 .. 8]; + REG[r] := regr + } + case (Ea_r(Sz32,r)) -> REG[r] := (qword) (EXTZ (w[31 .. 0])) + case (Ea_r(Sz64,r)) -> REG[r] := w + case (Ea_m((Sz8(_)),a)) -> wMEM(a, 1, w[7 .. 0]) + case (Ea_m(Sz16,a)) -> wMEM(a, 2, w[15 .. 0]) + case (Ea_m(Sz32,a)) -> wMEM(a, 4, w[31 .. 0]) + case (Ea_m(Sz64,a)) -> wMEM(a, 8, w) + } + +function (ea, qword, qword) read_dest_src_ea ((size) sz, (dest_src) ds) = + let e = ea_dest (sz, ds) in + (e, EA(e), EA(ea_src(sz, ds))) + +function qword call_dest_from_ea ((ea) e) = + switch e { + case (Ea_i(_, i)) -> RIP + i + case (Ea_r(_, r)) -> REG[r] + case (Ea_m(_, a)) -> rMEM(a, 8) + } + +function qword get_ea_address ((ea) e) = + switch e { + case (Ea_i(_, i)) -> 0x0000000000000000 + case (Ea_r(_, r)) -> 0x0000000000000000 + case (Ea_m(_, a)) -> 0x0000000000000000 + } + +function unit jump_to_ea ((ea) e) = RIP := call_dest_from_ea(e) + +(* EFLAG updates *) + +function bit byte_parity ((byte) b) = +{ + (int) acc := 0; + foreach (i from 0 to 7) acc := acc + (int) (b[i]); + (bit) (acc mod 2 == 0) +} + +function [|64|] size_width ((size) sz) = + switch sz { + case (Sz8(_)) -> 8 + case Sz16 -> 16 + case Sz32 -> 32 + case Sz64 -> 64 + } + +function [|63|] size_width_sub1 ((size) sz) = + switch sz { + case (Sz8(_)) -> 7 + case Sz16 -> 15 + case Sz32 -> 31 + case Sz64 -> 63 + } + +(* XXXXX +function bit word_size_msb ((size) sz, (qword) w) = w[size_width(sz) - 1] +*) + +function bit word_size_msb ((size) sz, (qword) w) = w[size_width_sub1(sz)] + +function unit write_PF ((qword) w) = PF := byte_parity (w[7 .. 0]) + +function unit write_SF ((size) sz, (qword) w) = SF := word_size_msb (sz, w) + +function unit write_ZF ((size) sz, (qword) w) = + ZF := (bit) + (switch sz { + case (Sz8(_)) -> w[7 .. 0] == 0x00 + case Sz16 -> w[15 .. 0] == 0x0000 + case Sz32 -> w[31 .. 0] == 0x00000000 + case Sz64 -> w == 0x0000000000000000 + }) + +function unit write_arith_eflags_except_CF_OF ((size) sz, (qword) w) = +{ + AF := undefined; + write_PF(w); + write_SF(sz, w); + write_ZF(sz, w); +} + +function unit write_arith_eflags ((size) sz, (qword) w, (bit) c, (bit) x) = +{ + CF := c; + OF := x; + write_arith_eflags_except_CF_OF (sz, w) +} + +function unit write_logical_eflags ((size) sz, (qword) w) = + write_arith_eflags (sz, w, bitzero, bitzero) + +function unit erase_eflags () = +{ + AF := undefined; + CF := undefined; + OF := undefined; + PF := undefined; + SF := undefined; + ZF := undefined; +} + +(* XXXXX *) +function nat power ((nat) x, ([|64|]) y) = undefined + +function nat value_width ((size) sz) = power (2, size_width(sz)) + +function bit word_signed_overflow_add ((size) sz, (qword) a, (qword) b) = + (bit) (word_size_msb (sz, a) == word_size_msb (sz, b) & + word_size_msb (sz, a + b) != word_size_msb (sz, a)) + +function bit word_signed_overflow_sub ((size) sz, (qword) a, (qword) b) = + (bit) (word_size_msb (sz, a) != word_size_msb (sz, b) & + word_size_msb (sz, a - b) != word_size_msb (sz, a)) + +function (qword, bit, bit) add_with_carry_out ((size) sz, (qword) a, (qword) b) = + (a + b, (bit) ((int) (value_width (sz)) <= unsigned(a) + unsigned(b)), + word_signed_overflow_add (sz, a, b)) + +function (qword, bit, bit) sub_with_borrow ((size) sz, (qword) a, (qword) b) = + (a - b, (bit) (a < b), word_signed_overflow_sub (sz, a, b)) + +function unit write_arith_result ((size) sz, (qword) w, (bit) c, (bit) x, (ea) e) = +{ + write_arith_eflags (sz, w, c, x); + wEA (e) := w; +} + +function unit write_arith_result_no_CF_OF ((size) sz, (qword) w, (ea) e) = +{ + write_arith_eflags_except_CF_OF (sz, w); + wEA (e) := w; +} + +function unit write_logical_result ((size) sz, (qword) w, (ea) e) = +{ + write_arith_eflags_except_CF_OF (sz, w); + wEA (e) := w; +} + +function unit write_result_erase_eflags ((qword) w, (ea) e) = +{ + erase_eflags (); + wEA (e) := w; +} + +function qword effect { escape } sign_extension ((qword) w, (size) size1, (size) size2) = +{ + (qword) x := w; + switch (size1, size2) { + case ((Sz8(_)), Sz16) -> x[15 .. 0] := (bit[16]) (EXTS (w[7 .. 0])) + case ((Sz8(_)), Sz32) -> x[31 .. 0] := (bit[32]) (EXTS (w[7 .. 0])) + case ((Sz8(_)), Sz64) -> x := (qword) (EXTS (w[7 .. 0])) + case (Sz16, Sz32) -> x[31 .. 0] := (bit[32]) (EXTS (w[15 .. 0])) + case (Sz16, Sz64) -> x := (qword) (EXTS (w[15 .. 0])) + case (Sz32, Sz64) -> x := (qword) (EXTS (w[31 .. 0])) + case _ -> undefined + }; + x; +} + +function [|64|] mask_shift ((size) sz, (qword) w) = + if sz == Sz64 then w[5 .. 0] else w[4 .. 0] + +function qword rol ((size) sz, (qword) a, (qword) b) = + switch sz { + case (Sz8(_)) -> EXTZ (ROL8 (a[7 .. 0], b[2 .. 0])) + case Sz16 -> EXTZ (ROL16 (a[15 .. 0], b[3 .. 0])) + case Sz32 -> EXTZ (ROL32 (a[31 .. 0], b[4 .. 0])) + case Sz64 -> ROL64 (a, b[5 .. 0]) + } + +function qword ror ((size) sz, (qword) a, (qword) b) = + switch sz { + case (Sz8(_)) -> EXTZ (ROR8 (a[7 .. 0], b[2 .. 0])) + case Sz16 -> EXTZ (ROR16 (a[15 .. 0], b[3 .. 0])) + case Sz32 -> EXTZ (ROR32 (a[31 .. 0], b[4 .. 0])) + case Sz64 -> ROR64 (a, b[5 .. 0]) + } + +function qword sar ((size) sz, (qword) a, (qword) b) = + switch sz { + case (Sz8(_)) -> EXTZ (ASR8 (a[7 .. 0], b[2 .. 0])) + case Sz16 -> EXTZ (ASR16 (a[15 .. 0], b[3 .. 0])) + case Sz32 -> EXTZ (ASR32 (a[31 .. 0], b[4 .. 0])) + case Sz64 -> ASR64 (a, b[5 .. 0]) + } + +function unit write_binop ((size) sz, (binop_name) bop, (qword) a, (qword) b, (ea) e) = + switch bop { + case Add -> let (w,c,x) = add_with_carry_out (sz, a, b) in + write_arith_result (sz, w, c, x, e) + case Sub -> let (w,c,x) = sub_with_borrow (sz, a, b) in + write_arith_result (sz, w, c, x, e) + case Cmp -> let (w,c,x) = sub_with_borrow (sz, a, b) in + write_arith_eflags (sz, w, c, x) + case Test -> write_logical_eflags (sz, a & b) + case And -> write_logical_result (sz, a & b, e) + case Xor -> write_logical_result (sz, a ^ b, e) + case Or -> write_logical_result (sz, a | b, e) + case Rol -> write_result_erase_eflags (rol (sz, a, b), e) + case Ror -> write_result_erase_eflags (ror (sz, a, b), e) + case Sar -> write_result_erase_eflags (sar (sz, a, b), e) + case Shl -> write_result_erase_eflags (a << mask_shift (sz, b), e) + case Shr -> write_result_erase_eflags (a >> mask_shift (sz, b), e) + case Adc -> + { + let carry = (bit) CF in + let (qword) result = a + (qword) (b + carry) in + { + CF := (bit) ((int) (value_width (sz)) <= unsigned(a) + unsigned(b)); + OF := undefined; + write_arith_result_no_CF_OF (sz, result, e); + } + } + case Sbb -> + { + let carry = (bit) CF in + let (qword) result = a - (qword) (b + carry) in + { + CF := (bit) (unsigned(a) < unsigned(b) + (int) carry); + OF := undefined; + write_arith_result_no_CF_OF (sz, result, e); + } + } + case _ -> exit () + } + +function unit write_monop ((size) sz, (monop_name) mop, (qword) a, (ea) e) = + switch mop { + case Not -> wEA(e) := ~(a) + case Dec -> write_arith_result_no_CF_OF (sz, a - 1, e) + case Inc -> write_arith_result_no_CF_OF (sz, a + 1, e) + case Neg -> { write_arith_result_no_CF_OF (sz, 0 - a, e); + CF := undefined; + } + } + +function bool read_cond ((cond) c) = + switch c { + case A -> ~(CF) & ~(ZF) + case NB -> ~(CF) + case B -> CF + case NA -> CF | (bit) ZF + case E -> ZF + case G -> ~(ZF) & (SF == OF) + case NL -> SF == OF + case L -> SF != OF + case NG -> ZF | SF != OF + case NE -> ~(ZF) + case NO -> ~(OF) + case NP -> ~(PF) + case NS -> ~(SF) + case O -> OF + case P -> PF + case S -> SF + case ALWAYS -> true + } + +function qword pop_aux () = + let top = rMEM(RSP, 8) in + { + RSP := RSP + 8; + top; + } + +function unit push_aux ((qword) w) = +{ + RSP := RSP - 8; + wMEM(RSP, 8) := w; +} + +function unit pop ((rm) r) = wEA (ea_rm (Sz64,r)) := pop_aux() +function unit pop_rip () = RIP := pop_aux() +function unit push ((imm_rm) i) = push_aux (EA (ea_imm_rm (i))) +function unit push_rip () = push_aux (RIP) + +function unit drop ((qword) i) = if i[7 ..0] != 0 then () else RSP := RSP + i + +(* -------------------------------------------------------------------------- + Instructions + -------------------------------------------------------------------------- *) + +scattered function unit execute +scattered typedef ast = const union + +val ast -> unit effect {escape, rmem, rreg, undef, eamem, wmv, wreg} execute + +(* ========================================================================== + Binop + ========================================================================== *) + +union ast member (binop_name,size,dest_src) Binop + +function clause execute (Binop (bop,sz,ds)) = + let (e, val_dst, val_src) = read_dest_src_ea (sz, ds) in + write_binop (sz, bop, val_dst, val_src, e) + +(* ========================================================================== + CALL + ========================================================================== *) + +union ast member imm_rm CALL + +function clause execute (CALL (i)) = +{ + push_rip(); + jump_to_ea (ea_imm_rm (i)) +} + +(* ========================================================================== + CLC + ========================================================================== *) + +union ast member unit CLC + +function clause execute CLC = CF := false + +(* ========================================================================== + CMC + ========================================================================== *) + +union ast member unit CMC + +function clause execute CMC = CF := ~(CF) + +(* ========================================================================== + CMPXCHG + ========================================================================== *) + +union ast member (size,rm,regn) CMPXCHG + +function clause execute (CMPXCHG (sz,r,n)) = + let src = Ea_r(sz, n) in + let acc = Ea_r(sz, 0) in (* RAX *) + let dst = ea_rm(sz, r) in + let val_dst = EA(dst) in + let val_acc = EA(src) in + { + write_binop (sz, Cmp, val_acc, val_dst, src); + if val_acc == val_dst then + wEA(dst) := EA (src) + else + wEA(acc) := val_dst; + } + +(* ========================================================================== + DIV + ========================================================================== *) + +union ast member (size,rm) DIV + +function clause execute (DIV (sz,r)) = + let w = (int) (value_width(sz)) in + let eax = Ea_r(sz, 0) in (* RAX *) + let edx = Ea_r(sz, 2) in (* RDX *) + let n = unsigned(EA(edx)) * w + unsigned(EA(eax)) in + let d = unsigned(EA(ea_rm(sz, r))) in + let q = n quot d in + let m = n mod d in + if d == 0 | w < q then exit () + else + { + wEA(eax) := (qword) q; + wEA(edx) := (qword) m; + erase_eflags(); + } + +(* ========================================================================== + Jcc + ========================================================================== *) + +union ast member (cond,qword) Jcc + +function clause execute (Jcc (c,i)) = + if read_cond (c) then RIP := RIP + i else () + +(* ========================================================================== + JMP + ========================================================================== *) + +union ast member rm JMP + +function clause execute (JMP (r)) = RIP := EA (ea_rm (Sz64, r)) + +(* ========================================================================== + LEA + ========================================================================== *) + +union ast member (size,dest_src) LEA + +function clause execute (LEA (sz,ds)) = + let src = ea_src (sz, ds) in + let dst = ea_dest (sz, ds) in + wEA(dst) := get_ea_address (src) + +(* ========================================================================== + LEAVE + ========================================================================== *) + +union ast member unit LEAVE + +function clause execute LEAVE = +{ + RSP := RBP; + pop (Reg (5)); (* RBP *) +} + +(* ========================================================================== + LOOP + ========================================================================== *) + +union ast member (cond,qword) LOOP + +function clause execute (LOOP (c,i)) = +{ + RCX := RCX - 1; + if RCX != 0 & read_cond (c) then RIP := RIP + i else (); +} + +(* ========================================================================== + Monop + ========================================================================== *) + +union ast member (monop_name,size,rm) Monop + +function clause execute (Monop (mop,sz,r)) = + let e = ea_rm (sz, r) in write_monop (sz, mop, EA(e), e) + +(* ========================================================================== + MOV + ========================================================================== *) + +union ast member (cond,size,dest_src) MOV + +function clause execute (MOV (c,sz,ds)) = + if read_cond (c) then + let src = ea_src (sz, ds) in + let dst = ea_dest (sz, ds) in + wEA(dst) := EA(src) + else () + +(* ========================================================================== + MOVSX + ========================================================================== *) + +union ast member (size,dest_src,size) MOVSX + +function clause execute (MOVSX (sz1,ds,sz2)) = + let src = ea_src (sz1, ds) in + let dst = ea_dest (sz2, ds) in + wEA(dst) := sign_extension (EA(src), sz1, sz2) + +(* ========================================================================== + MOVZX + ========================================================================== *) + +union ast member (size,dest_src,size) MOVZX + +function clause execute (MOVZX (sz1,ds,sz2)) = + let src = ea_src (sz1, ds) in + let dst = ea_dest (sz2, ds) in + wEA(dst) := EA(src) + +(* ========================================================================== + MUL + ========================================================================== *) + +union ast member (size,rm) MUL + +function clause execute (MUL (sz,r)) = + let eax = Ea_r (sz, 0) in (* RAX *) + let val_eax = EA(eax) in + let val_src = EA(ea_rm (sz, r)) in + switch sz { + case (Sz8(_)) -> wEA(Ea_r(Sz16,0)) := (val_eax * val_src)[63 .. 0] + case _ -> + let m = val_eax * val_src in + let edx = Ea_r (sz, 2) in (* RDX *) + { + wEA(eax) := m[63 .. 0]; + wEA(edx) := (m >> size_width(sz))[63 .. 0] + } + } + +(* ========================================================================== + NOP + ========================================================================== *) + +union ast member nat NOP + +function clause execute (NOP (_)) = () + +(* ========================================================================== + POP + ========================================================================== *) + +union ast member rm POP + +function clause execute (POP (r)) = pop(r) + +(* ========================================================================== + PUSH + ========================================================================== *) + +union ast member imm_rm PUSH + +function clause execute (PUSH (i)) = push(i) + +(* ========================================================================== + RET + ========================================================================== *) + +union ast member qword RET + +function clause execute (RET (i)) = +{ + pop_rip(); + drop(i); +} + +(* ========================================================================== + SET + ========================================================================== *) + +union ast member (cond,bool,rm) SET + +function clause execute (SET (c,b,r)) = + wEA(ea_rm(Sz8(b),r)) := if read_cond (c) then 1 else 0 + +(* ========================================================================== + STC + ========================================================================== *) + +union ast member unit STC + +function clause execute STC = CF := true + +(* ========================================================================== + XADD + ========================================================================== *) + +union ast member (size,rm,regn) XADD + +function clause execute (XADD (sz,r,n)) = + let src = Ea_r (sz, n) in + let dst = ea_rm (sz, r) in + let val_src = EA(src) in + let val_dst = EA(dst) in + { + wEA(src) := val_dst; + write_binop (sz, Add, val_src, val_dst, dst); + } + +(* ========================================================================== + XCHG + ========================================================================== *) + +union ast member (size,rm,regn) XCHG + +function clause execute (XCHG (sz,r,n)) = + let src = Ea_r (sz, n) in + let dst = ea_rm (sz, r) in + let val_src = EA(src) in + let val_dst = EA(dst) in + { + wEA(src) := val_dst; + wEA(dst) := val_src; + } + +end ast +end execute + +(* -------------------------------------------------------------------------- + Decoding + -------------------------------------------------------------------------- *) +(* +function (qword,ostream) oimmediate8 ((ostream) strm) = + switch strm { + case (Some (b :: t)) -> ((qword) (EXTS(b)), Some (t)) + case _ -> ((qword) undefined, (ostream) None) + } + +function (qword,ostream) immediate8 ((byte_stream) strm) = + oimmediate8 (Some (strm)) + +function (qword,ostream) immediate16 ((byte_stream) strm) = + switch strm { + case b1 :: b2 :: t -> ((qword) (EXTS(b2 : b1)), Some (t)) + case _ -> ((qword) undefined, (ostream) None) + } + +function (qword,ostream) immediate32 ((byte_stream) strm) = + switch strm { + case b1 :: b2 :: b3 :: b4 :: t -> + ((qword) (EXTS(b4 : b3 : b2 : b1)), Some (t)) + case _ -> ((qword) undefined, (ostream) None) + } + +function (qword,ostream) immediate64 ((byte_stream) strm) = + switch strm { + case b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: b8 :: t -> + ((qword) (EXTS(b8 : b7 : b6 : b5 : b4 : b3 : b2 : b1)), Some (t)) + case _ -> ((qword) undefined, (ostream) None) + } + +function (qword, ostream) immediate ((size) sz, (byte_stream) strm) = + switch sz { + case (Sz8 (_)) -> immediate8 (strm) + case Sz16 -> immediate16 (strm) + case _ -> immediate32 (strm) + } + +function (qword, ostream) oimmediate ((size) sz, (ostream) strm) = + switch strm { + case (Some (s)) -> immediate (sz, s) + case None -> ((qword) undefined, (ostream) None) + } + +function (qword, ostream) full_immediate ((size) sz, (byte_stream) strm) = + if sz == Sz64 then immediate64 (strm) else immediate (sz, strm) + +(* - Parse ModR/M and SIB bytes --------------------------------------------- *) + +typedef REX = register bits [3 : 0] { + 3 : W; + 2 : R; + 1 : X; + 0 : B +} + +function regn rex_reg ((bit[1]) b, (bit[3]) r) = unsigned(b : r) + +function (qword, ostream) read_displacement ((bit[2]) Mod, (byte_stream) strm) = + if Mod == 0b01 + then immediate8 (strm) + else if Mod == 0b10 + then immediate32 (strm) + else (0x0000000000000000, (Some (strm))) + +function (qword, ostream) + read_sib_displacement ((bit[2]) Mod, (byte_stream) strm) = + if Mod == 0b01 then immediate8 (strm) else immediate32 (strm) + +function (rm, ostream) + read_SIB ((REX) rex, (bit[2]) Mod, (byte_stream) strm) = + switch strm { + case ((bit[2]) SS : (bit[3]) Index : (bit[3]) Base) :: strm1 -> + (let bbase = rex_reg (rex.B, Base) in + let index = rex_reg (rex.X, Index) in + let scaled_index = if index == 4 (* RSP *) then + (option) None + else let x = (scale_index) (SS, index) in + Some (x) in + (if bbase == 5 (* RBP *) + then let (displacement, strm2) = + read_sib_displacement (Mod, strm1) in + let bbase = if Mod == 0b00 then NoBase else RegBase (bbase) + in + (Mem (scaled_index, bbase, displacement), strm2) + else let (displacement, strm2) = read_displacement (Mod, strm1) in + (Mem (scaled_index, RegBase (bbase), displacement), strm2))) + case _ -> ((rm) undefined, (ostream) None) + } + +function (regn, rm, ostream) read_ModRM ((REX) rex, (byte_stream) strm) = + switch strm { + case (0b00 : (bit[3]) RegOpc : 0b101) :: strm1 -> + let (displacement, strm2) = immediate32 (strm1) in + (rex_reg (rex.R, RegOpc), Mem (None, RipBase, displacement), strm2) + case (0b11 : (bit[3]) REG : (bit[3]) RM) :: strm1 -> + (rex_reg (rex.R, REG), Reg (rex_reg (rex.B, RM)), Some (strm1)) + case ((bit[2]) Mod : (bit[3]) RegOpc : 0b100) :: strm1 -> + let (sib, strm2) = read_SIB (rex, Mod, strm1) in + (rex_reg (rex.R, RegOpc), sib, strm2) + case ((bit[2]) Mod : (bit[3]) RegOpc : (bit[3]) RM) :: strm1 -> + let (displacement, strm2) = read_displacement (Mod, strm1) in + (rex_reg (rex.R, RegOpc), + Mem (None, RegBase (rex_reg (rex.B, RM)), displacement), + strm2) + case _ -> ((regn) undefined, (rm) undefined, (ostream) None) + } + +function (bit[3], rm, ostream) + read_opcode_ModRM ((REX) rex, (byte_stream) strm) = + let (opcode, r, strm1) = read_ModRM (rex, strm) in + ((bit[3]) (cast_int_vec((int) opcode mod 8)), r, strm1) + +(* - Prefixes --------------------------------------------------------------- *) + +typedef prefix = [|5|] + +function prefix prefix_group ((byte) b) = + switch b { + case 0xf0 -> 1 + case 0xf2 -> 1 + case 0xf3 -> 1 + case 0x26 -> 2 + case 0x2e -> 2 + case 0x36 -> 2 + case 0x3e -> 2 + case 0x64 -> 2 + case 0x65 -> 2 + case 0x66 -> 3 + case 0x67 -> 4 + case _ -> if b[7 .. 4] == 0b0100 then 5 else 0 + } + +typedef atuple = (byte_stream, bool, REX, byte_stream) + +val (list, byte_stream, byte_stream) -> option effect {undef} read_prefix + +function rec option read_prefix + ((list) s, (byte_stream) p, (byte_stream) strm) = + switch strm { + case h :: strm1 -> + let group = prefix_group (h) in + if group == 0 then + let x = (p, false, (REX) 0b0000, strm) in Some (x) + else if group == 5 then + let x = (p, true, (REX) (h[3 .. 0]), strm1) in Some (x) + else if ismember (group, s) then + None + else + read_prefix (group :: s, h :: p, strm1) + case _ -> let x = (p, false, (REX) undefined, strm) in Some (x) + } + +function option read_prefixes ((byte_stream) strm) = + read_prefix ([||||], [||||], strm) + +function size op_size ((bool) have_rex, (bit[1]) w, (bit[1]) v, (bool) override) = + if v == 1 then + Sz8 (have_rex) + else if w == 1 then + Sz64 + else if override then + Sz16 + else + Sz32 + +function bool is_mem ((rm) r) = + switch r {case (Mem (_, _, _)) -> true case _ -> false} + +(* - Decoder ---------------------------------------------------------------- *) + +function (ast, ostream) decode_aux + ((byte_stream) strm, (bool) have_rex, (REX) rex, (bool) op_size_override) = + switch strm + { + case (0b00 : (bit[3]) opc : 0b0 : (bit[1]) x : (bit[1]) v) :: strm2 -> + let (reg, r, strm3) = read_ModRM (rex, strm2) in + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let binop = opc_to_binop_name (EXTZ (opc)) in + let src_dst = if x == 0 then Rm_r (r, reg) else R_rm (reg, r) in + (Binop (binop, sz, src_dst), strm3) + case (0b00 : (bit[3]) opc : 0b10 : (bit[1]) v) :: strm2 -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let binop = opc_to_binop_name (EXTZ (opc)) in + let (imm, strm3) = immediate (sz, strm2) in + (Binop (binop, sz, Rm_i (Reg (0), imm)), strm3) + case (0x5 : (bit[1]) b : (bit[3]) r) :: strm2 -> + let reg = Reg (([|15|]) (rex.B : r)) in + (if b == 0b0 then PUSH (Rm (reg)) else POP (reg), Some (strm2)) + case 0x63 :: strm2 -> + let (reg, r, strm3) = read_ModRM (rex, strm2) in + (MOVSX (Sz32, R_rm (reg, r), Sz64), strm3) + case (0x6 : 0b10 : (bit[1]) b : 0b0) :: strm2 -> + let (imm, strm3) = if b == 1 then immediate8 (strm2) + else immediate32 (strm2) in + (PUSH (Imm (imm)), strm3) + case (0x7 : (bit[4]) c) :: strm2 -> + let (imm, strm3) = immediate8 (strm2) in + (Jcc (bv_to_cond (c), imm), strm3) + case (0x8 : 0b000 : (bit[1]) v) :: strm2 -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let (opc, r, strm3) = read_opcode_ModRM (rex, strm2) in + let (imm, strm4) = oimmediate (sz, strm3) in + let binop = opc_to_binop_name (EXTZ (opc)) in + (Binop (binop, sz, Rm_i (r, imm)), strm4) + case 0x83 :: strm2 -> + let sz = op_size (have_rex, rex.W, 1, op_size_override) in + let (opc, r, strm3) = read_opcode_ModRM (rex, strm2) in + let (imm, strm4) = oimmediate (sz, strm3) in + let binop = opc_to_binop_name (EXTZ (opc)) in + (Binop (binop, sz, Rm_i (r, imm)), strm4) + case (0x8 : 0b010 : (bit[1]) v) :: strm2 -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let (reg, r, strm3) = read_ModRM (rex, strm2) in + (Binop (Test, sz, Rm_r (r, reg)), strm3) + case (0x8 : 0b011 : (bit[1]) v) :: strm2 -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let (reg, r, strm3) = read_ModRM (rex, strm2) in + (XCHG (sz, r, reg), strm3) + case (0x8 : 0b10 : (bit[1]) x : (bit[1]) v) :: strm2 -> + let (reg, r, strm3) = read_ModRM (rex, strm2) in + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let src_dst = if x == 0 then Rm_r (r, reg) else R_rm (reg, r) in + (MOV (ALWAYS, sz, src_dst), strm3) + case 0x8d :: strm2 -> + let sz = op_size (true, rex.W, 1, op_size_override) in + let (reg, r, strm3) = read_ModRM (rex, strm2) in + if is_mem (r) then (LEA (sz, R_rm (reg, r)), strm3) else exit () + case 0x8f :: strm2 -> + let (opc, r, strm3) = read_opcode_ModRM (rex, strm2) in + if opc == 0 then (POP (r), strm3) else exit () + case (0x9 : 0b0 : (bit[3]) r) :: strm2 -> + let sz = op_size (true, rex.W, 1, op_size_override) in + let reg = rex_reg (rex.B, r) in + if reg == 0 then + (NOP (listlength (strm)), Some (strm2)) + else + (XCHG (sz, Reg (0), reg), Some (strm2)) + case (0xa : 0b100 : (bit[1]) v) :: strm2 -> + let sz = op_size (true, rex.W, v, op_size_override) in + let (imm, strm3) = immediate (sz, strm2) in + (Binop (Test, sz, Rm_i (Reg (0), imm)), strm3) + case (0xb : (bit[1]) v : (bit[3]) r) :: strm2 -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let (imm, strm3) = full_immediate (sz, strm2) in + let reg = rex_reg (rex.B, r) in + (MOV (ALWAYS, sz, Rm_i (Reg (reg), imm)), strm3) + case (0xc : 0b000 : (bit[1]) v) :: strm2 -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let (opc, r, strm3) = read_opcode_ModRM (rex, strm2) in + let (imm, strm4) = oimmediate8 (strm3) in + let binop = opc_to_binop_name (0b1 : opc) in + if opc == 0b110 then exit () + else (Binop (binop, sz, Rm_i (r, imm)), strm4) + case (0xc : 0b001 : (bit[1]) v) :: strm2 -> + if v == 0 then + let (imm, strm3) = immediate16 (strm2) in (RET (imm), strm3) + else + (RET (0), Some (strm2)) + case (0xc : 0b011 : (bit[1]) v) :: strm2 -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let (opc, r, strm3) = read_opcode_ModRM (rex, strm2) in + let (imm, strm4) = oimmediate (sz, strm3) in + if opc == 0 then (MOV (ALWAYS, sz, Rm_i (r, imm)), strm4) + else exit () + case 0xc9 :: strm2 -> + (LEAVE, Some (strm2)) + case (0xd : 0b00 : (bit[1]) b : (bit[1]) v) :: strm2 -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let (opc, r, strm3) = read_opcode_ModRM (rex, strm2) in + let shift = if b == 0 then Rm_i (r, 1) else Rm_r (r, 1) in + let binop = opc_to_binop_name (0b1 : opc) in + if opc == 0b110 then exit () + else (Binop (binop, sz, shift), strm3) + case (0xe : 0b000 : (bit[1]) b) :: strm2 -> + let (imm, strm3) = immediate8 (strm2) in + let cnd = if b == 0 then NE else E in + (LOOP (cnd, imm), strm3) + case 0xe2 :: strm2 -> + let (imm, strm3) = immediate8 (strm2) in + (LOOP (ALWAYS, imm), strm3) + case 0xe8 :: strm2 -> + let (imm, strm3) = immediate32 (strm2) in + (CALL (Imm (imm)), strm3) + case (0xe : 0b10 : (bit[1]) b : 0b1) :: strm2 -> + let (imm, strm3) = if b == 0 then immediate32 (strm2) + else immediate8 (strm2) in + (Jcc (ALWAYS, imm), strm3) + case 0xf5 :: strm2 -> (CMC, Some (strm2)) + case 0xf8 :: strm2 -> (CLC, Some (strm2)) + case 0xf9 :: strm2 -> (STC, Some (strm2)) + case (0xf : 0b011 : (bit[1]) v) :: strm2 -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let (opc, r, strm3) = read_opcode_ModRM (rex, strm2) in + switch opc { + case 0b000 -> let (imm, strm4) = oimmediate (sz, strm3) in + (Binop (Test, sz, Rm_i (r, imm)), strm4) + case 0b010 -> (Monop (Not, sz, r), strm3) + case 0b011 -> (Monop (Neg, sz, r), strm3) + case 0b100 -> (MUL (sz, r), strm3) + case 0b110 -> (DIV (sz, r), strm3) + case _ -> exit () + } + case 0xfe :: strm2 -> + let (opc, r, strm3) = read_opcode_ModRM (rex, strm2) in + switch opc { + case 0b000 -> (Monop (Inc, Sz8 (have_rex), r), strm3) + case 0b001 -> (Monop (Dec, Sz8 (have_rex), r), strm3) + case _ -> exit () + } + case 0xff :: strm2 -> + let sz = op_size (have_rex, rex.W, 1, op_size_override) in + let (opc, r, strm3) = read_opcode_ModRM (rex, strm2) in + switch opc { + case 0b000 -> (Monop (Inc, sz, r), strm3) + case 0b001 -> (Monop (Dec, sz, r), strm3) + case 0b010 -> (CALL (Rm (r)), strm3) + case 0b100 -> (JMP (r), strm3) + case 0b110 -> (PUSH (Rm (r)), strm3) + case _ -> exit () + } + case 0x0f :: opc :: strm2 -> + switch opc { + case 0x1f -> + let (opc, r, strm3) = read_opcode_ModRM (rex, strm2) in + (NOP (listlength (strm)), strm3) + case (0x4 : (bit[4]) c) -> + let sz = op_size (true, rex.W, 1, op_size_override) in + let (reg, r, strm3) = read_ModRM (rex, strm2) in + (MOV (bv_to_cond (c), sz, R_rm (reg, r)), strm3) + case (0x8 : (bit[4]) c) -> + let (imm, strm3) = immediate32 (strm2) in + (Jcc (bv_to_cond (c), imm), strm3) + case (0x9 : (bit[4]) c) -> + let (reg, r, strm3) = read_ModRM (rex, strm2) in + (SET (bv_to_cond (c), have_rex, r), strm3) + case (0xb : 0b000 : (bit[1]) v) -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let (reg, r, strm3) = read_ModRM (rex, strm2) in + (CMPXCHG (sz, r, reg), strm3) + case (0xc : 0b000 : (bit[1]) v) -> + let sz = op_size (have_rex, rex.W, v, op_size_override) in + let (reg, r, strm3) = read_ModRM (rex, strm2) in + (XADD (sz, r, reg), strm3) + case (0xb : (bit[1]) s : 0b11 : (bit[1]) v) -> + let sz2 = op_size (have_rex, rex.W, 1, op_size_override) in + let sz = if v == 1 then Sz16 else Sz8 (have_rex) in + let (reg, r, strm3) = read_ModRM (rex, strm2) in + if s == 1 then + (MOVSX (sz, R_rm (reg, r), sz2), strm3) + else + (MOVZX (sz, R_rm (reg, r), sz2), strm3) + case _ -> exit () + } + case _ -> exit () + } + +function (byte_stream, ast, nat) decode ((byte_stream) strm) = + switch read_prefixes (strm) + { + case None -> exit () + case (Some (prefixes, have_rex, rex, strm1)) -> + let op_size_override = ismember (0x66, prefixes) in + if rex.W == 1 & op_size_override | ismember (0x67, prefixes) then + exit () + else + switch decode_aux (strm1, have_rex, rex, op_size_override) { + case (instr, (Some (strm2))) -> (prefixes, instr, listlength (strm2)) + case _ -> exit () + } + } + *) + +let (vector <0, 16, inc, string >) GPRstr = + ["RAX","RCX","RDX","RBX","RSP","RBP","RSI","RDI","R8","R9","R10","R11","R12","R13","R14","R15"] + +function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis (instr) = { + iR := [|| ||]; + oR := [|| ||]; + aR := [|| ||]; + ik := IK_simple; + Nias := [|| NIAFP_successor ||]; + Dia := DIAFP_none; + x := (qword) RIP; + (*switch instr { + case (EBREAK) -> () + case (UTYPE ( imm, rd, op)) -> { + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + } + case (JAL ( imm, rd)) -> { + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + let (bit[64]) offset = EXTS(imm) in + Nias := [|| NIAFP_concrete_address (PC + offset) ||] + } + case (JALR ( imm, rs, rd)) -> { + if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + let (bit[64]) offset = EXTS(imm) in + Nias := [|| NIAFP_register (RFull(GPRstr[rs])) ||]; (* XXX this should br rs + offset... *) + } + case (BTYPE ( imm, rs2, rs1, op)) -> { + if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; + if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; + ik := IK_cond_branch; + let (bit[64]) offset = EXTS(imm) in + Nias := NIAFP_concrete_address(PC + offset) :: Nias; + } + case (ITYPE ( imm, rs, rd, op)) -> { + if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + } + case (SHIFTIOP ( imm, rs, rd, op)) -> { + if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + } + case (RTYPE ( rs2, rs1, rd, op)) -> { + if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; + if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + } + case (LOAD ( imm, rs, rd, unsign, width, aq)) -> { (* XXX "unsigned" causes name conflict in lem shallow embedding... *) + if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + aR := iR; + ik := if aq then IK_mem_read (Read_RISCV_acquire) else IK_mem_read (Read_plain); + } + case (STORE( imm, rs2, rs1, width)) -> { + if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; + if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; + if (rs1 == 0) then () else aR := RFull(GPRstr[rs1]) :: aR; + ik := IK_mem_write (Write_plain); + } + case (ADDIW ( imm, rs, rd)) -> { + if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + } + case (SHIFTW ( imm, rs, rd, op)) -> { + if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + } + case (RTYPEW ( rs2, rs1, rd, op))-> { + if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; + if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + } + case (FENCE(pred, succ)) -> { + ik := + switch(pred, succ) { + case (0b0011, 0b0011) -> IK_barrier (Barrier_RISCV_rw_rw) + case (0b0010, 0b0011) -> IK_barrier (Barrier_RISCV_r_rw) + case (0b0011, 0b0001) -> IK_barrier (Barrier_RISCV_rw_w) + case _ -> exit "unsupported fence" + }; + } + };*) + (iR,oR,aR,Nias,Dia,ik) +} -- cgit v1.2.3 From 78a35c575021679b5e512539598d47603a6822f0 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Tue, 22 Aug 2017 11:09:47 +0100 Subject: adapt state.lem to RISCV additions --- src/gen_lib/state.lem | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/gen_lib/state.lem b/src/gen_lib/state.lem index 430ee562..2e29d19a 100644 --- a/src/gen_lib/state.lem +++ b/src/gen_lib/state.lem @@ -60,6 +60,9 @@ let read_mem dir read_kind addr sz state = | Sail_impl_base.Read_exclusive -> true | Sail_impl_base.Read_exclusive_acquire -> true | Sail_impl_base.Read_stream -> false + | Sail_impl_base.Read_RISCV_acquire -> false + | Sail_impl_base.Read_RISCV_reserved -> true + | Sail_impl_base.Read_RISCV_reserved_acquire -> true end in if is_exclusive -- cgit v1.2.3 From 6cc248cc27d9133e23da1454f115176f0799a572 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Tue, 22 Aug 2017 14:16:01 +0100 Subject: added RISC-V "fence w,w" and "fence.i"; fixed the interpreter nias analysis; --- etc/regfp.sail | 2 ++ risc-v/hgen/ast.hgen | 1 + risc-v/hgen/herdtools_ast_to_shallow_ast.hgen | 1 + risc-v/hgen/lexer.hgen | 1 + risc-v/hgen/parser.hgen | 4 ++- risc-v/hgen/pretty.hgen | 1 + risc-v/hgen/sail_trans_out.hgen | 1 + risc-v/hgen/shallow_ast_to_herdtools_ast.hgen | 1 + risc-v/hgen/token_types.hgen | 1 + risc-v/hgen/tokens.hgen | 1 + risc-v/hgen/trans_sail.hgen | 4 +++ risc-v/riscv.sail | 9 +++-- risc-v/riscv_extras.lem | 2 ++ risc-v/riscv_extras_embed.lem | 4 +++ risc-v/riscv_extras_embed_sequential.lem | 4 +++ risc-v/riscv_regfp.sail | 20 ++++++----- src/lem_interp/interp_inter_imp.lem | 49 ++++++++++++++++++++++++--- src/lem_interp/sail_impl_base.lem | 4 +++ 18 files changed, 94 insertions(+), 16 deletions(-) diff --git a/etc/regfp.sail b/etc/regfp.sail index 71f53547..776e22af 100644 --- a/etc/regfp.sail +++ b/etc/regfp.sail @@ -71,6 +71,8 @@ typedef barrier_kind = enumerate { Barrier_RISCV_rw_rw; Barrier_RISCV_r_rw; Barrier_RISCV_rw_w; + Barrier_RISCV_w_w; + Barrier_RISCV_i; } typedef trans_kind = enumerate { diff --git a/risc-v/hgen/ast.hgen b/risc-v/hgen/ast.hgen index a0a59e4a..6fd52b03 100644 --- a/risc-v/hgen/ast.hgen +++ b/risc-v/hgen/ast.hgen @@ -11,5 +11,6 @@ | `RISCVSHIFTW of bit5 * reg * reg * riscvSop | `RISCVRTYPEW of reg * reg * reg * riscvRopw | `RISCVFENCE of bit4 * bit4 +| `RISCVFENCEI | `RISCVLoadRes of bool * bool * reg * wordWidth * reg | `RISCVStoreCon of bool * bool * reg * reg * wordWidth * reg diff --git a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen index ffea1575..770f9263 100644 --- a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen +++ b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen @@ -60,6 +60,7 @@ | `RISCVFENCE(pred, succ) -> FENCE( translate_imm4 "pred" pred, translate_imm4 "succ" succ) +| `RISCVFENCEI -> FENCEI | `RISCVLoadRes(aq, rl, rs1, width, rd) -> LOADRES( translate_bool "aq" aq, translate_bool "rl" rl, diff --git a/risc-v/hgen/lexer.hgen b/risc-v/hgen/lexer.hgen index abc0ff82..d422e82f 100644 --- a/risc-v/hgen/lexer.hgen +++ b/risc-v/hgen/lexer.hgen @@ -75,6 +75,7 @@ "r", FENCEOPTION Fence_R; "w", FENCEOPTION Fence_W; "rw", FENCEOPTION Fence_RW; +"fence.i", FENCEI (); "lr.w", LOADRES {width=RISCVWORD; aq=false; rl=false}; "lr.w.aq", LOADRES {width=RISCVWORD; aq=true; rl=false}; diff --git a/risc-v/hgen/parser.hgen b/risc-v/hgen/parser.hgen index d077c2df..5b000725 100644 --- a/risc-v/hgen/parser.hgen +++ b/risc-v/hgen/parser.hgen @@ -27,13 +27,15 @@ | (Fence_RW, Fence_RW) -> `RISCVFENCE (0b0011, 0b0011) | (Fence_R, Fence_RW) -> `RISCVFENCE (0b0010, 0b0011) | (Fence_RW, Fence_W) -> `RISCVFENCE (0b0011, 0b0001) + | (Fence_W, Fence_W) -> `RISCVFENCE (0b0001, 0b0001) | (Fence_RW, Fence_R) -> failwith "'fence rw,r' is not supported" | (Fence_R, Fence_R) -> failwith "'fence r,r' is not supported" | (Fence_R, Fence_W) -> failwith "'fence r,w' is not supported" | (Fence_W, Fence_RW) -> failwith "'fence w,rw' is not supported" | (Fence_W, Fence_R) -> failwith "'fence w,r' is not supported" - | (Fence_W, Fence_W) -> failwith "'fence w,w' is not supported" } +| FENCEI + { `RISCVFENCEI } | LOADRES reg COMMA LPAR reg RPAR { `RISCVLoadRes($1.aq, $1.rl, $5, $1.width, $2) } | STORECON reg COMMA reg COMMA LPAR reg RPAR diff --git a/risc-v/hgen/pretty.hgen b/risc-v/hgen/pretty.hgen index b4516b16..0b6548ea 100644 --- a/risc-v/hgen/pretty.hgen +++ b/risc-v/hgen/pretty.hgen @@ -15,6 +15,7 @@ | `RISCVSHIFTW(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm | `RISCVRTYPEW(rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_ropw op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) | `RISCVFENCE(pred, succ) -> sprintf "fence %s, %s" (pp_riscv_fence_option pred) (pp_riscv_fence_option succ) +| `RISCVFENCEI -> sprintf "fence.i" | `RISCVLoadRes(aq, rl, rs1, width, rd) -> assert (rl = false); diff --git a/risc-v/hgen/sail_trans_out.hgen b/risc-v/hgen/sail_trans_out.hgen index f216180a..61477f43 100644 --- a/risc-v/hgen/sail_trans_out.hgen +++ b/risc-v/hgen/sail_trans_out.hgen @@ -14,6 +14,7 @@ | ("SHIFTW", [imm; rs; rd; op]) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | ("RTYPEW", [rs2; rs1; rd; op]) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) | ("FENCE", [pred; succ]) -> `RISCVFENCE(translate_out_imm4 pred, translate_out_imm4 succ) +| ("FENCEI", []) -> `RISCVFENCEI | ("LOADRES", [aq; rl; rs1; width; rd]) -> `RISCVLoadRes(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) | ("STORECON", [aq; rl; rs2; rs1; width; rd]) diff --git a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen index 01d8dded..f84ed1fa 100644 --- a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen +++ b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen @@ -14,6 +14,7 @@ | SHIFTW( imm, rs, rd, op) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | RTYPEW( rs2, rs1, rd, op) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) | FENCE( pred, succ) -> `RISCVFENCE(translate_out_imm4 pred, translate_out_imm4 succ) +| FENCEI -> `RISCVFENCEI | LOADRES( aq, rl, rs1, width, rd) -> `RISCVLoadRes(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) | STORECON( aq, rl, rs2, rs1, width, rd) diff --git a/risc-v/hgen/token_types.hgen b/risc-v/hgen/token_types.hgen index c0ef8445..242a7173 100644 --- a/risc-v/hgen/token_types.hgen +++ b/risc-v/hgen/token_types.hgen @@ -11,6 +11,7 @@ type token_ADDIW = unit type token_SHIFTW = {op : riscvSop } type token_RTYPEW = {op : riscvRopw } type token_FENCE = unit +type token_FENCEI = unit type token_LoadRes = {width : wordWidth; aq: bool; rl: bool } type token_StoreCon = {width : wordWidth; aq: bool; rl: bool } diff --git a/risc-v/hgen/tokens.hgen b/risc-v/hgen/tokens.hgen index 1276fd68..449be0f0 100644 --- a/risc-v/hgen/tokens.hgen +++ b/risc-v/hgen/tokens.hgen @@ -12,5 +12,6 @@ %token RTYPEW %token FENCE %token FENCEOPTION +%token FENCEI %token LOADRES %token STORECON diff --git a/risc-v/hgen/trans_sail.hgen b/risc-v/hgen/trans_sail.hgen index 4d568fe8..6d10471c 100644 --- a/risc-v/hgen/trans_sail.hgen +++ b/risc-v/hgen/trans_sail.hgen @@ -112,6 +112,10 @@ translate_imm4 "succ" succ; ], []) +| `RISCVFENCEI -> + ("FENCEI", + [], + []) | `RISCVLoadRes(aq, rl, rs1, width, rd) -> ("LOADRES", [ diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index b5a25578..1d1867c4 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -104,6 +104,8 @@ function forall Nat 'n. bool effect { wmv } mem_write_conditional_value( (bit[64 val extern unit -> unit effect { barr } MEM_fence_rw_rw val extern unit -> unit effect { barr } MEM_fence_r_rw val extern unit -> unit effect { barr } MEM_fence_rw_w +val extern unit -> unit effect { barr } MEM_fence_w_w +val extern unit -> unit effect { barr } MEM_fence_i (* Ideally these would be sail builtin *) function (bit[64]) shift_right_arith64 ((bit[64]) v, (bit[6]) shift) = @@ -337,17 +339,18 @@ function clause execute (FENCE(pred, succ)) = { case (0b0011, 0b0011) -> MEM_fence_rw_rw() case (0b0010, 0b0011) -> MEM_fence_r_rw() case (0b0011, 0b0001) -> MEM_fence_rw_w() + case (0b0001, 0b0001) -> MEM_fence_w_w() case _ -> not_implemented("unsupported fence") } } union ast member unit FENCEI -function clause decode (0b0000 : 0b0000 : 0b0000 : 0b00000 : 0b001 : 0b00000 : 0b0001111) = Some(FENCEI) -function clause execute FENCEI = () (* XXX TODO *) +function clause decode (0b000000000000 : 0b00000 : 0b001 : 0b00000 : 0b0001111) = Some(FENCEI) +function clause execute FENCEI = MEM_fence_i() union ast member unit ECALL function clause decode (0b000000000000 : 0b00000 : 0b000 : 0b00000 : 0b1110011) = Some(ECALL ()) -function clause execute ECALL = () +function clause execute ECALL = not_implemented("ECALL is not implemented") union ast member unit EBREAK function clause decode (0b000000000001 : 0b00000 : 0b000 : 0b00000 : 0b1110011) = Some(EBREAK ()) diff --git a/risc-v/riscv_extras.lem b/risc-v/riscv_extras.lem index 3803839d..59e3cd4a 100644 --- a/risc-v/riscv_extras.lem +++ b/risc-v/riscv_extras.lem @@ -69,4 +69,6 @@ let barrier_functions = [ ("MEM_fence_rw_rw", Barrier_RISCV_rw_rw); ("MEM_fence_r_rw", Barrier_RISCV_r_rw); ("MEM_fence_rw_w", Barrier_RISCV_rw_w); + ("MEM_fence_w_w", Barrier_RISCV_w_w); + ("MEM_fence_i", Barrier_RISCV_i); ] diff --git a/risc-v/riscv_extras_embed.lem b/risc-v/riscv_extras_embed.lem index 35d217ff..6bfc2490 100644 --- a/risc-v/riscv_extras_embed.lem +++ b/risc-v/riscv_extras_embed.lem @@ -37,10 +37,14 @@ let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun b -> return (if val MEM_fence_rw_rw : unit -> M unit val MEM_fence_r_rw : unit -> M unit val MEM_fence_rw_w : unit -> M unit +val MEM_fence_w_w : unit -> M unit +val MEM_fence_i : unit -> M unit let MEM_fence_rw_rw () = barrier Barrier_RISCV_rw_rw let MEM_fence_r_rw () = barrier Barrier_RISCV_r_rw let MEM_fence_rw_w () = barrier Barrier_RISCV_rw_w +let MEM_fence_w_w () = barrier Barrier_RISCV_w_w +let MEM_fence_i () = barrier Barrier_RISCV_i let duplicate (bit,len) = let bits = repeat [bit] len in diff --git a/risc-v/riscv_extras_embed_sequential.lem b/risc-v/riscv_extras_embed_sequential.lem index 93b5dfec..0fca7709 100644 --- a/risc-v/riscv_extras_embed_sequential.lem +++ b/risc-v/riscv_extras_embed_sequential.lem @@ -37,10 +37,14 @@ let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun b -> return (if val MEM_fence_rw_rw : unit -> M unit val MEM_fence_r_rw : unit -> M unit val MEM_fence_rw_w : unit -> M unit +val MEM_fence_w_w : unit -> M unit +val MEM_fence_i : unit -> M unit let MEM_fence_rw_rw () = barrier Barrier_RISCV_rw_rw let MEM_fence_r_rw () = barrier Barrier_RISCV_r_rw let MEM_fence_rw_w () = barrier Barrier_RISCV_rw_w +let MEM_fence_w_w () = barrier Barrier_RISCV_w_w +let MEM_fence_i () = barrier Barrier_RISCV_i let duplicate (bit,len) = let bits = repeat [bit] len in diff --git a/risc-v/riscv_regfp.sail b/risc-v/riscv_regfp.sail index 1cfc68d7..20da3da3 100644 --- a/risc-v/riscv_regfp.sail +++ b/risc-v/riscv_regfp.sail @@ -29,7 +29,7 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; let (bit[64]) offset = EXTS(imm) in - Nias := [|| NIAFP_register (RFull(GPRstr[rs])) ||]; (* XXX this should br rs + offset... *) + Nias := [|| NIAFP_register (RFull(GPRstr[rs])) ||]; } case (BTYPE ( imm, rs2, rs1, op)) -> { if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; @@ -77,13 +77,17 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; } case (FENCE(pred, succ)) -> { - ik := - switch(pred, succ) { - case (0b0011, 0b0011) -> IK_barrier (Barrier_RISCV_rw_rw) - case (0b0010, 0b0011) -> IK_barrier (Barrier_RISCV_r_rw) - case (0b0011, 0b0001) -> IK_barrier (Barrier_RISCV_rw_w) - case _ -> exit "not implemented" - }; + ik := + switch(pred, succ) { + case (0b0011, 0b0011) -> IK_barrier (Barrier_RISCV_rw_rw) + case (0b0010, 0b0011) -> IK_barrier (Barrier_RISCV_r_rw) + case (0b0011, 0b0001) -> IK_barrier (Barrier_RISCV_rw_w) + case (0b0001, 0b0001) -> IK_barrier (Barrier_RISCV_w_w) + case _ -> exit "not implemented" + }; + } + case (FENCEI) -> { + ik := IK_barrier (Barrier_RISCV_i); } case (LOADRES ( aq, rl, rs1, width, rd)) -> { if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index fda9d5dd..6a9a77a1 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -1267,6 +1267,10 @@ let nias_of_instruction else [NIA_successor] | _ -> [ NIA_successor ] end + | ("PPCGEN_ism", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"PPCGEN_ism\", \"" ^ s ^ "\")") in + [ NIA_successor ] (* AARch64 label branch (i.e. address must be known) although these instructions take the address as an offset from PC, in here @@ -1301,7 +1305,10 @@ let nias_of_instruction | (Reg name _ _ _) -> name = n_reg | _ -> false end] - + | ("AArch64HandSail", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"AArch64HandSail\", \"" ^ s ^ "\")") in + [ NIA_successor ] (** hacky cut-and-paste for AArch64Gen, duplicating code just to see if this suffices *) @@ -1334,18 +1341,52 @@ let nias_of_instruction | (Reg name _ _ _) -> name = n_reg | _ -> false end] + | ("AArch64GenSail", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"AArch64GenSail\", \"" ^ s ^ "\")") in + [ NIA_successor ] (** end of hacky *) | ("AArch64LitmusSail", "CtrlDep") -> NIA_successor :: nias + | ("AArch64LitmusSail", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"AArch64LitmusSail\", \"" ^ s ^ "\")") in + [ NIA_successor ] | ("MIPS_ism", "B") -> fail + | ("MIPS_ism", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"MIPS_ism\", \"" ^ s ^ "\")") in + [ NIA_successor ] - | (s1,s2) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\""^s1^"\", \""^s2^"\")") in + | ("RISCV_ism", "JAL") -> nias + | ("RISCV_ism", "JALR") -> + let rs1_integer = + match instruction_fields with + | [_; (_, _, rs1); _] -> integer_of_bit_list rs1 + | _ -> fail + end + in + let () = ensure (0 <= rs1_integer && rs1_integer <= 31) + "expected register number from 0 to 31" + in + if rs1_integer = 0 then nias + else + let rs1_reg = "x" ^ (String_extra.stringFromInteger rs1_integer) in + [NIA_register r | forall (r MEM regs_in) + | match r with + | (Reg name _ _ _) -> name = rs1_reg + | _ -> false + end] + | ("RISCV_ism", "BTYPE") -> NIA_successor :: nias + | ("RISCV_ism", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"RISCV_ism\", \"" ^ s ^ "\")") in [ NIA_successor ] + + | (s1, s2) -> failwith ("unexpected (thread_ism, instruction_name): (" ^ s1 ^ ", " ^ s2 ^ ")") end let interp_instruction_analysis diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index caec3838..ebf0db4a 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -479,6 +479,8 @@ type barrier_kind = | Barrier_RISCV_rw_rw | Barrier_RISCV_r_rw | Barrier_RISCV_rw_w + | Barrier_RISCV_w_w + | Barrier_RISCV_i instance (Show barrier_kind) @@ -499,6 +501,8 @@ instance (Show barrier_kind) | Barrier_RISCV_rw_rw -> "Barrier_RISCV_rw_rw" | Barrier_RISCV_r_rw -> "Barrier_RISCV_r_rw" | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" + | Barrier_RISCV_w_w -> "Barrier_RISCV_w_w" + | Barrier_RISCV_I -> "Barrier_RISCV_i" end end -- cgit v1.2.3 From d8c238ddac07ed8bf828596ff68198d0c63758f5 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Tue, 22 Aug 2017 14:39:20 +0100 Subject: and fix that other places --- src/gen_lib/state.lem | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/src/gen_lib/state.lem b/src/gen_lib/state.lem index 2e29d19a..2ea1247e 100644 --- a/src/gen_lib/state.lem +++ b/src/gen_lib/state.lem @@ -47,25 +47,27 @@ let set_reg state reg bitv = <| state with regstate = Map.insert reg bitv state.regstate |> +let is_exclusive = function + | Sail_impl_base.Read_plain -> false + | Sail_impl_base.Read_reserve -> true + | Sail_impl_base.Read_acquire -> false + | Sail_impl_base.Read_exclusive -> true + | Sail_impl_base.Read_exclusive_acquire -> true + | Sail_impl_base.Read_stream -> false + | Sail_impl_base.Read_RISCV_acquire -> false + | Sail_impl_base.Read_RISCV_reserved -> true + | Sail_impl_base.Read_RISCV_reserved_acquire -> true +end + + val read_mem : bool -> read_kind -> vector bitU -> integer -> M (vector bitU) let read_mem dir read_kind addr sz state = let addr = integer_of_address (address_of_bitv addr) in let addrs = range addr (addr+sz-1) in let memory_value = List.map (fun addr -> Map_extra.find addr state.memstate) addrs in let value = Sail_values.internal_mem_value dir memory_value in - let is_exclusive = match read_kind with - | Sail_impl_base.Read_plain -> false - | Sail_impl_base.Read_reserve -> true - | Sail_impl_base.Read_acquire -> false - | Sail_impl_base.Read_exclusive -> true - | Sail_impl_base.Read_exclusive_acquire -> true - | Sail_impl_base.Read_stream -> false - | Sail_impl_base.Read_RISCV_acquire -> false - | Sail_impl_base.Read_RISCV_reserved -> true - | Sail_impl_base.Read_RISCV_reserved_acquire -> true - end in - if is_exclusive + if is_exclusive read_kind then [(Left value, <| state with last_exclusive_operation_was_load = true |>)] else [(Left value, state)] @@ -79,17 +81,8 @@ let read_tag dir read_kind addr state = | Just t -> t | Nothing -> B0 end in - let is_exclusive = match read_kind with - | Sail_impl_base.Read_plain -> false - | Sail_impl_base.Read_reserve -> true - | Sail_impl_base.Read_acquire -> false - | Sail_impl_base.Read_exclusive -> true - | Sail_impl_base.Read_exclusive_acquire -> true - | Sail_impl_base.Read_stream -> false - end in - (* TODO Should reading a tag set the exclusive flag? *) - if is_exclusive + if is_exclusive read_kind then [(Left tag, <| state with last_exclusive_operation_was_load = true |>)] else [(Left tag, state)] -- cgit v1.2.3 From 7f534961bd02a86779160a0ee656aba3b7eb5dd9 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Tue, 22 Aug 2017 15:10:27 +0100 Subject: x86: rename size type to avoid name clash in RMEM. --- x86/x64.sail | 96 ++++++++++++++++++++++++++++++------------------------------ 1 file changed, 48 insertions(+), 48 deletions(-) diff --git a/x86/x64.sail b/x86/x64.sail index 16c71d12..902a861e 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -120,7 +120,7 @@ function forall Nat 'n. unit effect {eamem, wmv} wMEM ((qword) addr, ([|'n|]) le (* Instruction addressing modes *) -typedef size = const union { +typedef wsize = const union { bool Sz8; unit Sz16; unit Sz32; @@ -206,9 +206,9 @@ function cond bv_to_cond ((bit[4]) v) = (* Effective addresses *) typedef ea = const union { - (size,qword) Ea_i; - (size,regn) Ea_r; - (size,qword) Ea_m; + (wsize,qword) Ea_i; + (wsize,regn) Ea_r; + (wsize,qword) Ea_m; } function qword ea_index ((option) index) = @@ -228,20 +228,20 @@ function qword ea_base ((base) b) = case (RegBase(b)) -> REG[b] } -function ea ea_rm ((size) sz, (rm) r) = +function ea ea_rm ((wsize) sz, (rm) r) = switch r { case (Reg(n)) -> Ea_r (sz, n) case (Mem(idx, b, d)) -> Ea_m (sz, ea_index(idx) + (qword) (ea_base(b) + d)) } -function ea ea_dest ((size) sz, (dest_src) ds) = +function ea ea_dest ((wsize) sz, (dest_src) ds) = switch ds { case (Rm_i (v, _)) -> ea_rm (sz, v) case (Rm_r (v, _)) -> ea_rm (sz, v) case (R_rm (v, _)) -> Ea_r (sz, v) } -function ea ea_src ((size) sz, (dest_src) ds) = +function ea ea_src ((wsize) sz, (dest_src) ds) = switch ds { case (Rm_i (_, v)) -> Ea_i (sz, v) case (Rm_r (_, v)) -> Ea_r (sz, v) @@ -254,7 +254,7 @@ function ea ea_imm_rm ((imm_rm) i_rm) = case (Imm (v)) -> Ea_i (Sz64, v) } -function qword restrict_size ((size) sz, (qword) imm) = +function qword restrict_size ((wsize) sz, (qword) imm) = switch sz { case (Sz8(_)) -> imm & 0x00000000000000FF case Sz16 -> imm & 0x000000000000FFFF @@ -309,7 +309,7 @@ function unit effect { wmem, wreg, escape } wEA ((ea) e, (qword) w) = case (Ea_m(Sz64,a)) -> wMEM(a, 8, w) } -function (ea, qword, qword) read_dest_src_ea ((size) sz, (dest_src) ds) = +function (ea, qword, qword) read_dest_src_ea ((wsize) sz, (dest_src) ds) = let e = ea_dest (sz, ds) in (e, EA(e), EA(ea_src(sz, ds))) @@ -338,7 +338,7 @@ function bit byte_parity ((byte) b) = (bit) (acc mod 2 == 0) } -function [|64|] size_width ((size) sz) = +function [|64|] size_width ((wsize) sz) = switch sz { case (Sz8(_)) -> 8 case Sz16 -> 16 @@ -346,7 +346,7 @@ function [|64|] size_width ((size) sz) = case Sz64 -> 64 } -function [|63|] size_width_sub1 ((size) sz) = +function [|63|] size_width_sub1 ((wsize) sz) = switch sz { case (Sz8(_)) -> 7 case Sz16 -> 15 @@ -355,16 +355,16 @@ function [|63|] size_width_sub1 ((size) sz) = } (* XXXXX -function bit word_size_msb ((size) sz, (qword) w) = w[size_width(sz) - 1] +function bit word_size_msb ((wsize) sz, (qword) w) = w[size_width(sz) - 1] *) -function bit word_size_msb ((size) sz, (qword) w) = w[size_width_sub1(sz)] +function bit word_size_msb ((wsize) sz, (qword) w) = w[size_width_sub1(sz)] function unit write_PF ((qword) w) = PF := byte_parity (w[7 .. 0]) -function unit write_SF ((size) sz, (qword) w) = SF := word_size_msb (sz, w) +function unit write_SF ((wsize) sz, (qword) w) = SF := word_size_msb (sz, w) -function unit write_ZF ((size) sz, (qword) w) = +function unit write_ZF ((wsize) sz, (qword) w) = ZF := (bit) (switch sz { case (Sz8(_)) -> w[7 .. 0] == 0x00 @@ -373,7 +373,7 @@ function unit write_ZF ((size) sz, (qword) w) = case Sz64 -> w == 0x0000000000000000 }) -function unit write_arith_eflags_except_CF_OF ((size) sz, (qword) w) = +function unit write_arith_eflags_except_CF_OF ((wsize) sz, (qword) w) = { AF := undefined; write_PF(w); @@ -381,14 +381,14 @@ function unit write_arith_eflags_except_CF_OF ((size) sz, (qword) w) = write_ZF(sz, w); } -function unit write_arith_eflags ((size) sz, (qword) w, (bit) c, (bit) x) = +function unit write_arith_eflags ((wsize) sz, (qword) w, (bit) c, (bit) x) = { CF := c; OF := x; write_arith_eflags_except_CF_OF (sz, w) } -function unit write_logical_eflags ((size) sz, (qword) w) = +function unit write_logical_eflags ((wsize) sz, (qword) w) = write_arith_eflags (sz, w, bitzero, bitzero) function unit erase_eflags () = @@ -404,36 +404,36 @@ function unit erase_eflags () = (* XXXXX *) function nat power ((nat) x, ([|64|]) y) = undefined -function nat value_width ((size) sz) = power (2, size_width(sz)) +function nat value_width ((wsize) sz) = power (2, size_width(sz)) -function bit word_signed_overflow_add ((size) sz, (qword) a, (qword) b) = +function bit word_signed_overflow_add ((wsize) sz, (qword) a, (qword) b) = (bit) (word_size_msb (sz, a) == word_size_msb (sz, b) & word_size_msb (sz, a + b) != word_size_msb (sz, a)) -function bit word_signed_overflow_sub ((size) sz, (qword) a, (qword) b) = +function bit word_signed_overflow_sub ((wsize) sz, (qword) a, (qword) b) = (bit) (word_size_msb (sz, a) != word_size_msb (sz, b) & word_size_msb (sz, a - b) != word_size_msb (sz, a)) -function (qword, bit, bit) add_with_carry_out ((size) sz, (qword) a, (qword) b) = +function (qword, bit, bit) add_with_carry_out ((wsize) sz, (qword) a, (qword) b) = (a + b, (bit) ((int) (value_width (sz)) <= unsigned(a) + unsigned(b)), word_signed_overflow_add (sz, a, b)) -function (qword, bit, bit) sub_with_borrow ((size) sz, (qword) a, (qword) b) = +function (qword, bit, bit) sub_with_borrow ((wsize) sz, (qword) a, (qword) b) = (a - b, (bit) (a < b), word_signed_overflow_sub (sz, a, b)) -function unit write_arith_result ((size) sz, (qword) w, (bit) c, (bit) x, (ea) e) = +function unit write_arith_result ((wsize) sz, (qword) w, (bit) c, (bit) x, (ea) e) = { write_arith_eflags (sz, w, c, x); wEA (e) := w; } -function unit write_arith_result_no_CF_OF ((size) sz, (qword) w, (ea) e) = +function unit write_arith_result_no_CF_OF ((wsize) sz, (qword) w, (ea) e) = { write_arith_eflags_except_CF_OF (sz, w); wEA (e) := w; } -function unit write_logical_result ((size) sz, (qword) w, (ea) e) = +function unit write_logical_result ((wsize) sz, (qword) w, (ea) e) = { write_arith_eflags_except_CF_OF (sz, w); wEA (e) := w; @@ -445,7 +445,7 @@ function unit write_result_erase_eflags ((qword) w, (ea) e) = wEA (e) := w; } -function qword effect { escape } sign_extension ((qword) w, (size) size1, (size) size2) = +function qword effect { escape } sign_extension ((qword) w, (wsize) size1, (wsize) size2) = { (qword) x := w; switch (size1, size2) { @@ -460,10 +460,10 @@ function qword effect { escape } sign_extension ((qword) w, (size) size1, (size) x; } -function [|64|] mask_shift ((size) sz, (qword) w) = +function [|64|] mask_shift ((wsize) sz, (qword) w) = if sz == Sz64 then w[5 .. 0] else w[4 .. 0] -function qword rol ((size) sz, (qword) a, (qword) b) = +function qword rol ((wsize) sz, (qword) a, (qword) b) = switch sz { case (Sz8(_)) -> EXTZ (ROL8 (a[7 .. 0], b[2 .. 0])) case Sz16 -> EXTZ (ROL16 (a[15 .. 0], b[3 .. 0])) @@ -471,7 +471,7 @@ function qword rol ((size) sz, (qword) a, (qword) b) = case Sz64 -> ROL64 (a, b[5 .. 0]) } -function qword ror ((size) sz, (qword) a, (qword) b) = +function qword ror ((wsize) sz, (qword) a, (qword) b) = switch sz { case (Sz8(_)) -> EXTZ (ROR8 (a[7 .. 0], b[2 .. 0])) case Sz16 -> EXTZ (ROR16 (a[15 .. 0], b[3 .. 0])) @@ -479,7 +479,7 @@ function qword ror ((size) sz, (qword) a, (qword) b) = case Sz64 -> ROR64 (a, b[5 .. 0]) } -function qword sar ((size) sz, (qword) a, (qword) b) = +function qword sar ((wsize) sz, (qword) a, (qword) b) = switch sz { case (Sz8(_)) -> EXTZ (ASR8 (a[7 .. 0], b[2 .. 0])) case Sz16 -> EXTZ (ASR16 (a[15 .. 0], b[3 .. 0])) @@ -487,7 +487,7 @@ function qword sar ((size) sz, (qword) a, (qword) b) = case Sz64 -> ASR64 (a, b[5 .. 0]) } -function unit write_binop ((size) sz, (binop_name) bop, (qword) a, (qword) b, (ea) e) = +function unit write_binop ((wsize) sz, (binop_name) bop, (qword) a, (qword) b, (ea) e) = switch bop { case Add -> let (w,c,x) = add_with_carry_out (sz, a, b) in write_arith_result (sz, w, c, x, e) @@ -527,7 +527,7 @@ function unit write_binop ((size) sz, (binop_name) bop, (qword) a, (qword) b, (e case _ -> exit () } -function unit write_monop ((size) sz, (monop_name) mop, (qword) a, (ea) e) = +function unit write_monop ((wsize) sz, (monop_name) mop, (qword) a, (ea) e) = switch mop { case Not -> wEA(e) := ~(a) case Dec -> write_arith_result_no_CF_OF (sz, a - 1, e) @@ -591,7 +591,7 @@ val ast -> unit effect {escape, rmem, rreg, undef, eamem, wmv, wreg} execute Binop ========================================================================== *) -union ast member (binop_name,size,dest_src) Binop +union ast member (binop_name,wsize,dest_src) Binop function clause execute (Binop (bop,sz,ds)) = let (e, val_dst, val_src) = read_dest_src_ea (sz, ds) in @@ -629,7 +629,7 @@ function clause execute CMC = CF := ~(CF) CMPXCHG ========================================================================== *) -union ast member (size,rm,regn) CMPXCHG +union ast member (wsize,rm,regn) CMPXCHG function clause execute (CMPXCHG (sz,r,n)) = let src = Ea_r(sz, n) in @@ -649,7 +649,7 @@ function clause execute (CMPXCHG (sz,r,n)) = DIV ========================================================================== *) -union ast member (size,rm) DIV +union ast member (wsize,rm) DIV function clause execute (DIV (sz,r)) = let w = (int) (value_width(sz)) in @@ -688,7 +688,7 @@ function clause execute (JMP (r)) = RIP := EA (ea_rm (Sz64, r)) LEA ========================================================================== *) -union ast member (size,dest_src) LEA +union ast member (wsize,dest_src) LEA function clause execute (LEA (sz,ds)) = let src = ea_src (sz, ds) in @@ -723,7 +723,7 @@ function clause execute (LOOP (c,i)) = Monop ========================================================================== *) -union ast member (monop_name,size,rm) Monop +union ast member (monop_name,wsize,rm) Monop function clause execute (Monop (mop,sz,r)) = let e = ea_rm (sz, r) in write_monop (sz, mop, EA(e), e) @@ -732,7 +732,7 @@ function clause execute (Monop (mop,sz,r)) = MOV ========================================================================== *) -union ast member (cond,size,dest_src) MOV +union ast member (cond,wsize,dest_src) MOV function clause execute (MOV (c,sz,ds)) = if read_cond (c) then @@ -745,7 +745,7 @@ function clause execute (MOV (c,sz,ds)) = MOVSX ========================================================================== *) -union ast member (size,dest_src,size) MOVSX +union ast member (wsize,dest_src,wsize) MOVSX function clause execute (MOVSX (sz1,ds,sz2)) = let src = ea_src (sz1, ds) in @@ -756,7 +756,7 @@ function clause execute (MOVSX (sz1,ds,sz2)) = MOVZX ========================================================================== *) -union ast member (size,dest_src,size) MOVZX +union ast member (wsize,dest_src,wsize) MOVZX function clause execute (MOVZX (sz1,ds,sz2)) = let src = ea_src (sz1, ds) in @@ -767,7 +767,7 @@ function clause execute (MOVZX (sz1,ds,sz2)) = MUL ========================================================================== *) -union ast member (size,rm) MUL +union ast member (wsize,rm) MUL function clause execute (MUL (sz,r)) = let eax = Ea_r (sz, 0) in (* RAX *) @@ -841,7 +841,7 @@ function clause execute STC = CF := true XADD ========================================================================== *) -union ast member (size,rm,regn) XADD +union ast member (wsize,rm,regn) XADD function clause execute (XADD (sz,r,n)) = let src = Ea_r (sz, n) in @@ -857,7 +857,7 @@ function clause execute (XADD (sz,r,n)) = XCHG ========================================================================== *) -union ast member (size,rm,regn) XCHG +union ast member (wsize,rm,regn) XCHG function clause execute (XCHG (sz,r,n)) = let src = Ea_r (sz, n) in @@ -905,20 +905,20 @@ function (qword,ostream) immediate64 ((byte_stream) strm) = case _ -> ((qword) undefined, (ostream) None) } -function (qword, ostream) immediate ((size) sz, (byte_stream) strm) = +function (qword, ostream) immediate ((wsize) sz, (byte_stream) strm) = switch sz { case (Sz8 (_)) -> immediate8 (strm) case Sz16 -> immediate16 (strm) case _ -> immediate32 (strm) } -function (qword, ostream) oimmediate ((size) sz, (ostream) strm) = +function (qword, ostream) oimmediate ((wsize) sz, (ostream) strm) = switch strm { case (Some (s)) -> immediate (sz, s) case None -> ((qword) undefined, (ostream) None) } -function (qword, ostream) full_immediate ((size) sz, (byte_stream) strm) = +function (qword, ostream) full_immediate ((wsize) sz, (byte_stream) strm) = if sz == Sz64 then immediate64 (strm) else immediate (sz, strm) (* - Parse ModR/M and SIB bytes --------------------------------------------- *) @@ -1030,7 +1030,7 @@ function rec option read_prefix function option read_prefixes ((byte_stream) strm) = read_prefix ([||||], [||||], strm) -function size op_size ((bool) have_rex, (bit[1]) w, (bit[1]) v, (bool) override) = +function wsize op_size ((bool) have_rex, (bit[1]) w, (bit[1]) v, (bool) override) = if v == 1 then Sz8 (have_rex) else if w == 1 then -- cgit v1.2.3 From 888b0f2bd01b8a2e026d6a081e85ffe2df3ed16c Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 24 Aug 2017 10:06:34 +0100 Subject: added barrier-kind for x86 MFENCE; fixed some compare functions; --- src/lem_interp/sail_impl_base.lem | 168 ++++++++++++++++++++++---------------- 1 file changed, 96 insertions(+), 72 deletions(-) diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index ebf0db4a..b52eb58f 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -481,6 +481,8 @@ type barrier_kind = | Barrier_RISCV_rw_w | Barrier_RISCV_w_w | Barrier_RISCV_i + (* X86 *) + | Barrier_X86_MFENCE instance (Show barrier_kind) @@ -503,6 +505,7 @@ instance (Show barrier_kind) | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" | Barrier_RISCV_w_w -> "Barrier_RISCV_w_w" | Barrier_RISCV_I -> "Barrier_RISCV_i" + | Barrier_X86_MFENCE -> "Barrier_X86_MFENCE" end end @@ -546,48 +549,42 @@ end let ~{ocaml} read_kindCompare rk1 rk2 = match (rk1, rk2) with - | (Read_plain, Read_plain) -> EQ - | (Read_plain, Read_reserve) -> LT - | (Read_plain, Read_acquire) -> LT - | (Read_plain, Read_exclusive) -> LT - | (Read_plain, Read_exclusive_acquire) -> LT - | (Read_plain, Read_stream) -> LT - - | (Read_reserve, Read_plain) -> GT - | (Read_reserve, Read_reserve) -> EQ - | (Read_reserve, Read_acquire) -> LT - | (Read_reserve, Read_exclusive) -> LT - | (Read_reserve, Read_exclusive_acquire) -> LT - | (Read_reserve, Read_stream) -> LT - - | (Read_acquire, Read_plain) -> GT - | (Read_acquire, Read_reserve) -> GT - | (Read_acquire, Read_acquire) -> EQ - | (Read_acquire, Read_exclusive) -> LT - | (Read_acquire, Read_exclusive_acquire) -> LT - | (Read_acquire, Read_stream) -> LT - - | (Read_exclusive, Read_plain) -> GT - | (Read_exclusive, Read_reserve) -> GT - | (Read_exclusive, Read_acquire) -> GT - | (Read_exclusive, Read_exclusive) -> EQ - | (Read_exclusive, Read_exclusive_acquire) -> LT - | (Read_exclusive, Read_stream) -> LT - - | (Read_exclusive_acquire, Read_plain) -> GT - | (Read_exclusive_acquire, Read_reserve) -> GT - | (Read_exclusive_acquire, Read_acquire) -> GT - | (Read_exclusive_acquire, Read_exclusive) -> GT + | (Read_plain, Read_plain) -> EQ + | (Read_plain, _) -> LT + | (_, Read_plain) -> GT + + | (Read_reserve, Read_reserve) -> EQ + | (Read_reserve, _) -> LT + | (_, Read_reserve) -> GT + + | (Read_acquire, Read_acquire) -> EQ + | (Read_acquire, _) -> LT + | (_, Read_acquire) -> GT + + | (Read_exclusive, Read_exclusive) -> EQ + | (Read_exclusive, _) -> LT + | (_, Read_exclusive) -> GT + | (Read_exclusive_acquire, Read_exclusive_acquire) -> EQ - | (Read_exclusive_acquire, Read_stream) -> GT - - | (Read_stream, Read_plain) -> GT - | (Read_stream, Read_reserve) -> GT - | (Read_stream, Read_acquire) -> GT - | (Read_stream, Read_exclusive) -> GT - | (Read_stream, Read_exclusive_acquire) -> GT - | (Read_stream, Read_stream) -> EQ -end + | (Read_exclusive_acquire, _) -> LT + | (_, Read_exclusive_acquire) -> GT + + | (Read_stream, Read_stream) -> EQ + | (Read_stream, _) -> LT + | (_, Read_stream) -> GT + + | (Read_RISCV_acquire, Read_RISCV_acquire) -> EQ + | (Read_RISCV_acquire, _) -> LT + | (_, Read_RISCV_acquire) -> GT + + | (Read_RISCV_reserved, Read_RISCV_reserved) -> EQ + | (Read_RISCV_reserved, _) -> LT + | (_, Read_RISCV_reserved) -> GT + + | (Read_RISCV_reserved_acquire, Read_RISCV_reserved_acquire) -> EQ + (*| (Read_RISCV_reserved_acquire, _) -> LT + | (_, Read_RISCV_reserved_acquire) -> GT*) + end let inline {ocaml} read_kindCompare = defaultCompare let ~{ocaml} read_kindLess b1 b2 = read_kindCompare b1 b2 = LT @@ -610,36 +607,39 @@ end let ~{ocaml} write_kindCompare wk1 wk2 = match (wk1, wk2) with - | (Write_plain, Write_plain) -> EQ - | (Write_plain, Write_conditional) -> LT - | (Write_plain, Write_release) -> LT - | (Write_plain, Write_exclusive) -> LT - | (Write_plain, Write_exclusive_release) -> LT - - | (Write_conditional, Write_plain) -> GT - | (Write_conditional, Write_conditional) -> EQ - | (Write_conditional, Write_release) -> LT - | (Write_conditional, Write_exclusive) -> LT - | (Write_conditional, Write_exclusive_release) -> LT - - | (Write_release, Write_plain) -> GT - | (Write_release, Write_conditional) -> GT - | (Write_release, Write_release) -> EQ - | (Write_release, Write_exclusive) -> LT - | (Write_release, Write_exclusive_release) -> LT - - | (Write_exclusive, Write_plain) -> GT - | (Write_exclusive, Write_conditional) -> GT - | (Write_exclusive, Write_release) -> GT - | (Write_exclusive, Write_exclusive) -> EQ - | (Write_exclusive, Write_exclusive_release) -> LT - - | (Write_exclusive_release, Write_plain) -> GT - | (Write_exclusive_release, Write_conditional) -> GT - | (Write_exclusive_release, Write_release) -> GT - | (Write_exclusive_release, Write_exclusive) -> GT + | (Write_plain, Write_plain) -> EQ + | (Write_plain, _) -> LT + | (_, Write_plain) -> GT + + | (Write_conditional, Write_conditional) -> EQ + | (Write_conditional, _) -> LT + | (_, Write_conditional) -> GT + + + | (Write_release, Write_release) -> EQ + | (Write_release, _) -> LT + | (_, Write_release) -> GT + + | (Write_exclusive, Write_exclusive) -> EQ + | (Write_exclusive, _) -> LT + | (_, Write_exclusive) -> GT + | (Write_exclusive_release, Write_exclusive_release) -> EQ -end + | (Write_exclusive_release, _) -> LT + | (_, Write_exclusive_release) -> GT + + | (Write_RISCV_release, Write_RISCV_release) -> EQ + | (Write_RISCV_release, _) -> LT + | (_, Write_RISCV_release) -> GT + + | (Write_RISCV_conditional, Write_RISCV_conditional) -> EQ + | (Write_RISCV_conditional, _) -> LT + | (_, Write_RISCV_conditional) -> GT + + | (Write_RISCV_conditional_release, Write_RISCV_conditional_release) -> EQ + (*| (Write_RISCV_conditional_release, _) -> LT + | (_, Write_RISCV_conditional_release) -> GT*) + end let inline {ocaml} write_kindCompare = defaultCompare let ~{ocaml} write_kindLess b1 b2 = write_kindCompare b1 b2 = LT @@ -660,6 +660,7 @@ instance (Ord write_kind) let (>=) = write_kindGreaterEq end + let ~{ocaml} barrier_kindCompare bk1 bk2 = match (bk1, bk2) with | (Barrier_Sync, Barrier_Sync) -> EQ @@ -711,9 +712,32 @@ let ~{ocaml} barrier_kindCompare bk1 bk2 = | (_, Barrier_TM_COMMIT) -> GT | (Barrier_MIPS_SYNC, Barrier_MIPS_SYNC) -> EQ - (* | (Barrier_MIPS_SYNC, _) -> LT - | (_, Barrier_MIPS_SYNC) -> GT *) + | (Barrier_MIPS_SYNC, _) -> LT + | (_, Barrier_MIPS_SYNC) -> GT + + | (Barrier_RISCV_rw_rw, Barrier_RISCV_rw_rw) -> EQ + | (Barrier_RISCV_rw_rw, _) -> LT + | (_, Barrier_RISCV_rw_rw) -> GT + + | (Barrier_RISCV_r_rw, Barrier_RISCV_r_rw) -> EQ + | (Barrier_RISCV_r_rw, _) -> LT + | (_, Barrier_RISCV_r_rw) -> GT + + | (Barrier_RISCV_rw_w, Barrier_RISCV_rw_w) -> EQ + | (Barrier_RISCV_rw_w, _) -> LT + | (_, Barrier_RISCV_rw_w) -> GT + + | (Barrier_RISCV_w_w, Barrier_RISCV_w_w) -> EQ + | (Barrier_RISCV_w_w, _) -> LT + | (_, Barrier_RISCV_w_w) -> GT + + | (Barrier_RISCV_i, Barrier_RISCV_i) -> EQ + | (Barrier_RISCV_i, _) -> LT + | (_, Barrier_RISCV_i) -> GT + | (Barrier_X86_MFENCE, Barrier_X86_MFENCE) -> EQ + (*| (Barrier_X86_MFENCE, _) -> LT + | (_, Barrier_X86_MFENCE) -> GT*) end let inline {ocaml} barrier_kindCompare = defaultCompare -- cgit v1.2.3 From 3721093caa882173526ab7ba03ccaa3226e2a94f Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 24 Aug 2017 10:09:00 +0100 Subject: typo --- src/lem_interp/sail_impl_base.lem | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index b52eb58f..60beffb4 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -504,7 +504,7 @@ instance (Show barrier_kind) | Barrier_RISCV_r_rw -> "Barrier_RISCV_r_rw" | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" | Barrier_RISCV_w_w -> "Barrier_RISCV_w_w" - | Barrier_RISCV_I -> "Barrier_RISCV_i" + | Barrier_RISCV_i -> "Barrier_RISCV_i" | Barrier_X86_MFENCE -> "Barrier_X86_MFENCE" end end -- cgit v1.2.3 From 1dd42197633a1b608303187fac8cc7f5b30ec22e Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 24 Aug 2017 10:11:22 +0100 Subject: typo --- src/lem_interp/sail_impl_base.lem | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 60beffb4..65ae87c2 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -482,7 +482,7 @@ type barrier_kind = | Barrier_RISCV_w_w | Barrier_RISCV_i (* X86 *) - | Barrier_X86_MFENCE + | Barrier_x86_MFENCE instance (Show barrier_kind) @@ -505,7 +505,7 @@ instance (Show barrier_kind) | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" | Barrier_RISCV_w_w -> "Barrier_RISCV_w_w" | Barrier_RISCV_i -> "Barrier_RISCV_i" - | Barrier_X86_MFENCE -> "Barrier_X86_MFENCE" + | Barrier_x86_MFENCE -> "Barrier_x86_MFENCE" end end @@ -735,9 +735,9 @@ let ~{ocaml} barrier_kindCompare bk1 bk2 = | (Barrier_RISCV_i, _) -> LT | (_, Barrier_RISCV_i) -> GT - | (Barrier_X86_MFENCE, Barrier_X86_MFENCE) -> EQ - (*| (Barrier_X86_MFENCE, _) -> LT - | (_, Barrier_X86_MFENCE) -> GT*) + | (Barrier_x86_MFENCE, Barrier_x86_MFENCE) -> EQ + (*| (Barrier_x86_MFENCE, _) -> LT + | (_, Barrier_x86_MFENCE) -> GT*) end let inline {ocaml} barrier_kindCompare = defaultCompare -- cgit v1.2.3 From d9e3c14533806986f7c6ce843148cf1973f9711b Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Wed, 30 Aug 2017 14:44:28 +0100 Subject: typeclass instance Ord(opcode) --- src/lem_interp/sail_impl_base.lem | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 65ae87c2..3886f919 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -110,7 +110,7 @@ type address = Address of list byte (* of length 8 *) * integer type opcode = Opcode of list byte (* of length 4 *) (** typeclass instantiations *) - + let ~{ocaml} bitCompare (b1:bit) (b2:bit) = match (b1,b2) with | (Bitc_zero, Bitc_zero) -> EQ @@ -214,6 +214,36 @@ instance (Ord byte) let (>=) = byteGreaterEq end + + + + +let ~{ocaml} opcodeCompare (Opcode o1) (Opcode o2) = + compare o1 o2 +let {ocaml} opcodeCompare = defaultCompare + +let ~{ocaml} opcodeLess b1 b2 = opcodeCompare b1 b2 = LT +let ~{ocaml} opcodeLessEq b1 b2 = opcodeCompare b1 b2 <> GT +let ~{ocaml} opcodeGreater b1 b2 = opcodeCompare b1 b2 = GT +let ~{ocaml} opcodeGreaterEq b1 b2 = opcodeCompare b1 b2 <> LT + +let inline {ocaml} opcodeLess = defaultLess +let inline {ocaml} opcodeLessEq = defaultLessEq +let inline {ocaml} opcodeGreater = defaultGreater +let inline {ocaml} opcodeGreaterEq = defaultGreaterEq + +instance (Ord opcode) + let compare = opcodeCompare + let (<) = opcodeLess + let (<=) = opcodeLessEq + let (>) = opcodeGreater + let (>=) = opcodeGreaterEq +end + + + + + let addressCompare (Address b1 i1) (Address b2 i2) = compare i1 i2 (* this cannot be defaultCompare for OCaml because addresses contain big ints *) -- cgit v1.2.3 From 07fad742df72ff6e7bfb948c1c353a2cf12f5e28 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 31 Aug 2017 15:08:10 +0100 Subject: added RISC-V AMOs --- etc/regfp.sail | 1 + risc-v/hgen/ast.hgen | 1 + risc-v/hgen/fold.hgen | 1 + risc-v/hgen/herdtools_ast_to_shallow_ast.hgen | 8 ++ risc-v/hgen/herdtools_types_to_shallow_types.hgen | 11 ++ risc-v/hgen/lexer.hgen | 80 +++++++++++++ risc-v/hgen/map.hgen | 1 + risc-v/hgen/parser.hgen | 2 + risc-v/hgen/pretty.hgen | 7 ++ risc-v/hgen/sail_trans_out.hgen | 2 + risc-v/hgen/shallow_ast_to_herdtools_ast.hgen | 2 + risc-v/hgen/shallow_types_to_herdtools_types.hgen | 11 ++ risc-v/hgen/token_types.hgen | 1 + risc-v/hgen/tokens.hgen | 1 + risc-v/hgen/trans_sail.hgen | 12 ++ risc-v/hgen/types.hgen | 32 +++++ risc-v/hgen/types_sail_trans_out.hgen | 12 ++ risc-v/hgen/types_trans_sail.hgen | 1 + risc-v/riscv.sail | 138 +++++++++++++++------- risc-v/riscv_extras.lem | 19 ++- risc-v/riscv_extras_embed.lem | 10 +- risc-v/riscv_extras_embed_sequential.lem | 10 +- risc-v/riscv_regfp.sail | 15 +++ src/lem_interp/interp_inter_imp.lem | 39 +++++- src/lem_interp/sail_impl_base.lem | 25 ++-- 25 files changed, 374 insertions(+), 68 deletions(-) diff --git a/etc/regfp.sail b/etc/regfp.sail index 776e22af..761737db 100644 --- a/etc/regfp.sail +++ b/etc/regfp.sail @@ -83,6 +83,7 @@ typedef instruction_kind = const union { (barrier_kind) IK_barrier; (read_kind) IK_mem_read; (write_kind) IK_mem_write; + (read_kind, write_kind) IK_mem_rmw; IK_cond_branch; (trans_kind) IK_trans; IK_simple diff --git a/risc-v/hgen/ast.hgen b/risc-v/hgen/ast.hgen index 6fd52b03..1839557f 100644 --- a/risc-v/hgen/ast.hgen +++ b/risc-v/hgen/ast.hgen @@ -14,3 +14,4 @@ | `RISCVFENCEI | `RISCVLoadRes of bool * bool * reg * wordWidth * reg | `RISCVStoreCon of bool * bool * reg * reg * wordWidth * reg +| `RISCVAMO of riscvAmoop * bool * bool * reg * reg * wordWidth * reg diff --git a/risc-v/hgen/fold.hgen b/risc-v/hgen/fold.hgen index 4cbaf779..d8806a37 100644 --- a/risc-v/hgen/fold.hgen +++ b/risc-v/hgen/fold.hgen @@ -13,3 +13,4 @@ | `RISCVRTYPEW (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) | `RISCVLoadRes (_, _, rs1, _, rd) -> fold_reg rs1 (fold_reg rd (y_reg, y_sreg)) | `RISCVStoreCon (_, _, rs2, rs1, _, rd) -> fold_reg rs2 (fold_reg rs1 (fold_reg rd (y_reg, y_sreg))) +| `RISCVAMO (_, _, _, rs2, rs1, _, rd) -> fold_reg rs2 (fold_reg rs1 (fold_reg rd (y_reg, y_sreg))) diff --git a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen index 770f9263..2e508678 100644 --- a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen +++ b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen @@ -74,3 +74,11 @@ translate_reg "rs1" rs1, translate_wordWidth width, translate_reg "rd" rd) +| `RISCVAMO (op, aq, rl, rs2, rs1, width, rd) -> AMO( + translate_amoop op, + translate_bool "aq" aq, + translate_bool "rl" rl, + translate_reg "rs2" rs2, + translate_reg "rs1" rs1, + translate_wordWidth width, + translate_reg "rd" rd) diff --git a/risc-v/hgen/herdtools_types_to_shallow_types.hgen b/risc-v/hgen/herdtools_types_to_shallow_types.hgen index 4d8bd87a..a63f9aed 100644 --- a/risc-v/hgen/herdtools_types_to_shallow_types.hgen +++ b/risc-v/hgen/herdtools_types_to_shallow_types.hgen @@ -47,6 +47,17 @@ let translate_ropw op = match op with | RISCVSRLW -> SRLW | RISCVSRAW -> SRAW +let translate_amoop op = match op with + | RISCVAMOSWAP -> AMOSWAP + | RISCVAMOADD -> AMOADD + | RISCVAMOXOR -> AMOXOR + | RISCVAMOAND -> AMOAND + | RISCVAMOOR -> AMOOR + | RISCVAMOMIN -> AMOMIN + | RISCVAMOMAX -> AMOMAX + | RISCVAMOMINU -> AMOMINU + | RISCVAMOMAXU -> AMOMAXU + let translate_wordWidth op = match op with | RISCVBYTE -> BYTE | RISCVHALF -> HALF diff --git a/risc-v/hgen/lexer.hgen b/risc-v/hgen/lexer.hgen index d422e82f..9d5df538 100644 --- a/risc-v/hgen/lexer.hgen +++ b/risc-v/hgen/lexer.hgen @@ -86,3 +86,83 @@ "sc.w.rl", STORECON {width=RISCVWORD; aq=false; rl=true}; "sc.d", STORECON {width=RISCVDOUBLE; aq=false; rl=false}; "sc.d.rl", STORECON {width=RISCVDOUBLE; aq=false; rl=true}; + +"amoswap.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOSWAP}; +"amoadd.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOADD}; +"amoand.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOAND}; +"amoor.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOOR}; +"amoxor.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOXOR}; +"amomax.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMAX}; +"amomin.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMIN}; +"amomaxu.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMAXU}; +"amominu.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMINU}; + +"amoswap.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOSWAP}; +"amoadd.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOADD}; +"amoand.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOAND}; +"amoor.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOOR}; +"amoxor.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOXOR}; +"amomax.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMAX}; +"amomin.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMIN}; +"amomaxu.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMAXU}; +"amominu.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMINU}; + +"amoswap.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOSWAP}; +"amoadd.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOADD}; +"amoand.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOAND}; +"amoor.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOOR}; +"amoxor.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOXOR}; +"amomax.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMAX}; +"amomin.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMIN}; +"amomaxu.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMAXU}; +"amominu.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMINU}; + +"amoswap.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOSWAP}; +"amoadd.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOADD}; +"amoand.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOAND}; +"amoor.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOOR}; +"amoxor.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOXOR}; +"amomax.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMAX}; +"amomin.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMIN}; +"amomaxu.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMAXU}; +"amominu.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMINU}; + +"amoswap.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOSWAP}; +"amoadd.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOADD}; +"amoand.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOAND}; +"amoor.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOOR}; +"amoxor.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOXOR}; +"amomax.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMAX}; +"amomin.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMIN}; +"amomaxu.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMAXU}; +"amominu.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMINU}; + +"amoswap.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOSWAP}; +"amoadd.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOADD}; +"amoand.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOAND}; +"amoor.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOOR}; +"amoxor.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOXOR}; +"amomax.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMAX}; +"amomin.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMIN}; +"amomaxu.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMAXU}; +"amominu.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMINU}; + +"amoswap.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOSWAP}; +"amoadd.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOADD}; +"amoand.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOAND}; +"amoor.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOOR}; +"amoxor.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOXOR}; +"amomax.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMAX}; +"amomin.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMIN}; +"amomaxu.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMAXU}; +"amominu.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMINU}; + +"amoswap.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOSWAP}; +"amoadd.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOADD}; +"amoand.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOAND}; +"amoor.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOOR}; +"amoxor.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOXOR}; +"amomax.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMAX}; +"amomin.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMIN}; +"amomaxu.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMAXU}; +"amominu.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMINU}; diff --git a/risc-v/hgen/map.hgen b/risc-v/hgen/map.hgen index 639a68bd..91eecc56 100644 --- a/risc-v/hgen/map.hgen +++ b/risc-v/hgen/map.hgen @@ -12,3 +12,4 @@ | `RISCVRTYPEW (r0, r1, r2, x) -> `RISCVRTYPEW (r0, map_reg r1, map_reg r2, x) | `RISCVLoadRes (aq, rl, rs1, w, rd) -> `RISCVLoadRes (aq, rl, map_reg rs1, w, map_reg rd) | `RISCVStoreCon (aq, rl, rs2, rs1, w, rd) -> `RISCVStoreCon (aq, rl, map_reg rs2, map_reg rs1, w, map_reg rd) +| `RISCVAMO (op, aq, rl, rs2, rs1, w, rd) -> `RISCVAMO (op, aq, rl, map_reg rs2, map_reg rs1, w, map_reg rd) diff --git a/risc-v/hgen/parser.hgen b/risc-v/hgen/parser.hgen index 5b000725..4440ffda 100644 --- a/risc-v/hgen/parser.hgen +++ b/risc-v/hgen/parser.hgen @@ -40,3 +40,5 @@ { `RISCVLoadRes($1.aq, $1.rl, $5, $1.width, $2) } | STORECON reg COMMA reg COMMA LPAR reg RPAR { `RISCVStoreCon($1.aq, $1.rl, $4, $7, $1.width, $2) } +| AMO reg COMMA reg COMMA LPAR reg RPAR + { `RISCVAMO($1.op, $1.aq, $1.rl, $4, $7, $1.width, $2) } diff --git a/risc-v/hgen/pretty.hgen b/risc-v/hgen/pretty.hgen index 0b6548ea..b5068c71 100644 --- a/risc-v/hgen/pretty.hgen +++ b/risc-v/hgen/pretty.hgen @@ -31,3 +31,10 @@ (pp_reg rd) (pp_reg rs2) (pp_reg rs1) +| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) + -> + sprintf "%s %s, %s, (%s)" + (pp_riscv_amo_op (op, aq, rl, width)) + (pp_reg rd) + (pp_reg rs2) + (pp_reg rs1) diff --git a/risc-v/hgen/sail_trans_out.hgen b/risc-v/hgen/sail_trans_out.hgen index 61477f43..bec35203 100644 --- a/risc-v/hgen/sail_trans_out.hgen +++ b/risc-v/hgen/sail_trans_out.hgen @@ -19,3 +19,5 @@ -> `RISCVLoadRes(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) | ("STORECON", [aq; rl; rs2; rs1; width; rd]) -> `RISCVStoreCon(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) +| ("AMO", [op; aq; rl; rs2; rs1; width; rd]) + -> `RISCVAMO(translate_out_amoop op, translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) diff --git a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen index f84ed1fa..662b1044 100644 --- a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen +++ b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen @@ -19,3 +19,5 @@ -> `RISCVLoadRes(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) | STORECON( aq, rl, rs2, rs1, width, rd) -> `RISCVStoreCon(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) +| AMO( op, aq, rl, rs2, rs1, width, rd) + -> `RISCVAMO(translate_out_amoop op, translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) diff --git a/risc-v/hgen/shallow_types_to_herdtools_types.hgen b/risc-v/hgen/shallow_types_to_herdtools_types.hgen index a891d7d0..03b8820c 100644 --- a/risc-v/hgen/shallow_types_to_herdtools_types.hgen +++ b/risc-v/hgen/shallow_types_to_herdtools_types.hgen @@ -53,6 +53,17 @@ let translate_out_ropw op = match op with | SRLW -> RISCVSRLW | SRAW -> RISCVSRAW +let translate_out_amoop op = match op with + | AMOSWAP -> RISCVAMOSWAP + | AMOADD -> RISCVAMOADD + | AMOXOR -> RISCVAMOXOR + | AMOAND -> RISCVAMOAND + | AMOOR -> RISCVAMOOR + | AMOMIN -> RISCVAMOMIN + | AMOMAX -> RISCVAMOMAX + | AMOMINU -> RISCVAMOMINU + | AMOMAXU -> RISCVAMOMAXU + let translate_out_wordWidth op = match op with | BYTE -> RISCVBYTE | HALF -> RISCVHALF diff --git a/risc-v/hgen/token_types.hgen b/risc-v/hgen/token_types.hgen index 242a7173..9b469a27 100644 --- a/risc-v/hgen/token_types.hgen +++ b/risc-v/hgen/token_types.hgen @@ -14,5 +14,6 @@ type token_FENCE = unit type token_FENCEI = unit type token_LoadRes = {width : wordWidth; aq: bool; rl: bool } type token_StoreCon = {width : wordWidth; aq: bool; rl: bool } +type token_AMO = {width : wordWidth; aq: bool; rl: bool; op: riscvAmoop } type token_FENCEOPTION = Fence_R | Fence_W | Fence_RW diff --git a/risc-v/hgen/tokens.hgen b/risc-v/hgen/tokens.hgen index 449be0f0..b0cf1d88 100644 --- a/risc-v/hgen/tokens.hgen +++ b/risc-v/hgen/tokens.hgen @@ -15,3 +15,4 @@ %token FENCEI %token LOADRES %token STORECON +%token AMO diff --git a/risc-v/hgen/trans_sail.hgen b/risc-v/hgen/trans_sail.hgen index 6d10471c..12da62d8 100644 --- a/risc-v/hgen/trans_sail.hgen +++ b/risc-v/hgen/trans_sail.hgen @@ -137,3 +137,15 @@ translate_reg "rd" rd; ], []) +| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) -> + ("AMO", + [ + translate_amoop "op" op; + translate_bool "aq" aq; + translate_bool "rl" rl; + translate_reg "rs2" rs2; + translate_reg "rs1" rs1; + translate_width "width" width; + translate_reg "rd" rd; + ], + []) diff --git a/risc-v/hgen/types.hgen b/risc-v/hgen/types.hgen index 1471812c..83deb4a2 100644 --- a/risc-v/hgen/types.hgen +++ b/risc-v/hgen/types.hgen @@ -140,6 +140,38 @@ let pp_riscv_store_conditional_op (aq, rl, width) = (if aq then ".aq" else "") ^ (if rl then ".rl" else "") +type riscvAmoop = + | RISCVAMOSWAP + | RISCVAMOADD + | RISCVAMOXOR + | RISCVAMOAND + | RISCVAMOOR + | RISCVAMOMIN + | RISCVAMOMAX + | RISCVAMOMINU + | RISCVAMOMAXU + +let pp_riscv_amo_op (op, aq, rl, width) = + "amo" ^ + begin match op with + | RISCVAMOSWAP -> "swap" + | RISCVAMOADD -> "add" + | RISCVAMOXOR -> "xor" + | RISCVAMOAND -> "and" + | RISCVAMOOR -> "or" + | RISCVAMOMIN -> "min" + | RISCVAMOMAX -> "max" + | RISCVAMOMINU -> "minu" + | RISCVAMOMAXU -> "maxu" + end ^ + begin match width with + | RISCVWORD -> ".w" + | RISCVDOUBLE -> ".d" + | _ -> assert false + end ^ + (if aq then ".aq" else "") ^ + (if rl then ".rl" else "") + let pp_riscv_fence_option = function | 0b0011 -> "rw" | 0b0010 -> "r" diff --git a/risc-v/hgen/types_sail_trans_out.hgen b/risc-v/hgen/types_sail_trans_out.hgen index e22110d0..66a2020c 100644 --- a/risc-v/hgen/types_sail_trans_out.hgen +++ b/risc-v/hgen/types_sail_trans_out.hgen @@ -84,3 +84,15 @@ let translate_out_ropw op = match translate_out_enum op with | 3 -> RISCVSRLW | 4 -> RISCVSRAW | _ -> failwith "Unknown ropw in sail translate out" + +let translate_out_amoop op = match translate_out_enum op with +| 0 -> RISCVAMOSWAP +| 1 -> RISCVAMOADD +| 2 -> RISCVAMOXOR +| 3 -> RISCVAMOAND +| 4 -> RISCVAMOOR +| 5 -> RISCVAMOMIN +| 6 -> RISCVAMOMAX +| 7 -> RISCVAMOMINU +| 8 -> RISCVAMOMAXU +| _ -> failwith "Unknown amoop in sail translate out" diff --git a/risc-v/hgen/types_trans_sail.hgen b/risc-v/hgen/types_trans_sail.hgen index 1bf174fa..7528a522 100644 --- a/risc-v/hgen/types_trans_sail.hgen +++ b/risc-v/hgen/types_trans_sail.hgen @@ -16,6 +16,7 @@ let translate_iop = translate_enum [RISCVADDI; RISCVSLTI; RISCVSLTIU; RISCVXORI; let translate_sop = translate_enum [RISCVSLLI; RISCVSRLI; RISCVSRAI] (* shift ops *) let translate_rop = translate_enum [RISCVADD; RISCVSUB; RISCVSLL; RISCVSLT; RISCVSLTU; RISCVXOR; RISCVSRL; RISCVSRA; RISCVOR; RISCVAND] (* reg-reg ops *) let translate_ropw = translate_enum [RISCVADDW; RISCVSUBW; RISCVSLLW; RISCVSRLW; RISCVSRAW] (* reg-reg 32-bit ops *) +let translate_amoop = translate_enum [RISCVAMOSWAP; RISCVAMOADD; RISCVAMOXOR; RISCVAMOAND; RISCVAMOOR; RISCVAMOMIN; RISCVAMOMAX; RISCVAMOMINU; RISCVAMOMAXU] let translate_width = translate_enum [RISCVBYTE; RISCVHALF; RISCVWORD; RISCVDOUBLE] let translate_reg name value = (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int (reg_to_int value))) diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index 1d1867c4..5b749656 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -40,7 +40,10 @@ register (bit[64]) PC register (bit[64]) nextPC let (vector <0, 32, inc, (register<(regval)>)>) GPRs = - [x0, x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30,x31] + [ x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, + x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, + x28, x29, x30, x31 + ] function (regval) rGPR ((regno) r) = if (r == 0) then @@ -71,35 +74,29 @@ function forall Nat 'n. (bit[8 * 'n]) effect { rmem } mem_read( (bit[64]) addr, val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_release -function forall Nat 'n. unit effect { eamem } mem_write_ea( (bit[64]) addr , ([|'n|]) width, (bool) rl) = - switch rl { - case false -> MEMea(addr, width) - case true -> MEMea_release(addr, width) +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_release +function forall Nat 'n. unit effect { eamem } mem_write_ea( (bit[64]) addr , ([|'n|]) width, (bool) rl, (bool) con) = + switch (rl, con) { + case (false, false) -> MEMea(addr, width) + case (true, false) -> MEMea_release(addr, width) + case (false, true) -> MEMea_conditional(addr, width) + case (true , true) -> MEMea_conditional_release(addr, width) } val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_release -function forall Nat 'n. unit effect { wmv } mem_write_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) rl) = - switch rl { - case false -> MEMval(addr, width, value) - case true -> MEMval_release(addr, width, value) +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional_release +function forall Nat 'n. unit effect { wmv } mem_write_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) rl, (bool) con) = + switch (rl, con) { + case (false, false) -> MEMval(addr, width, value) + case (true, false) -> MEMval_release(addr, width, value) + case (false, true) -> MEMval_conditional(addr, width, value) + case (true, true) -> MEMval_conditional_release(addr, width, value) } -val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional -val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_release -function forall Nat 'n. unit effect { eamem } mem_write_conditional_ea( (bit[64]) addr , ([|'n|]) width, (bool) rl) = - switch rl { - case false -> MEMea_conditional(addr, width) - case true -> MEMea_conditional_release(addr, width) - } - -val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> bool effect { wmv } MEMval_conditional -val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> bool effect { wmv } MEMval_conditional_release -function forall Nat 'n. bool effect { wmv } mem_write_conditional_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) rl) = - switch rl { - case false -> MEMval_conditional(addr, width, value) - case true -> MEMval_conditional_release(addr, width, value) - } +val extern unit -> bool effect {exmem} speculate_conditional_success val extern unit -> unit effect { barr } MEM_fence_rw_rw val extern unit -> unit effect { barr } MEM_fence_r_rw @@ -122,6 +119,9 @@ typedef iop = enumerate {ADDI; SLTI; SLTIU; XORI; ORI; ANDI} (* immediate ops *) typedef sop = enumerate {SLLI; SRLI; SRAI} (* shift ops *) typedef rop = enumerate {ADD; SUB; SLL; SLT; SLTU; XOR; SRL; SRA; OR; AND} (* reg-reg ops *) typedef ropw = enumerate {ADDW; SUBW; SLLW; SRLW; SRAW} (* reg-reg 32-bit ops *) +typedef amoop = enumerate {AMOSWAP; AMOADD; AMOXOR; AMOAND; AMOOR; + AMOMIN; AMOMAX; AMOMINU; AMOMAXU} (* AMO ops *) + typedef word_width = enumerate {BYTE; HALF; WORD; DOUBLE} @@ -279,17 +279,17 @@ function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b011 : (bit function clause execute (STORE(imm, rs2, rs1, width, rl)) = let (bit[64]) addr = rGPR(rs1) + EXTS(imm) in { switch (width) { - case BYTE -> mem_write_ea(addr, 1, rl) - case HALF -> mem_write_ea(addr, 2, rl) - case WORD -> mem_write_ea(addr, 4, rl) - case DOUBLE -> mem_write_ea(addr, 8, rl) + case BYTE -> mem_write_ea(addr, 1, rl, false) + case HALF -> mem_write_ea(addr, 2, rl, false) + case WORD -> mem_write_ea(addr, 4, rl, false) + case DOUBLE -> mem_write_ea(addr, 8, rl, false) }; let rs2_val = rGPR(rs2) in switch (width) { - case BYTE -> mem_write_value(addr, 1, rs2_val[7..0], rl) - case HALF -> mem_write_value(addr, 2, rs2_val[15..0], rl) - case WORD -> mem_write_value(addr, 4, rs2_val[31..0], rl) - case DOUBLE -> mem_write_value(addr, 8, rs2_val, rl) + case BYTE -> mem_write_value(addr, 1, rs2_val[7..0], rl, false) + case HALF -> mem_write_value(addr, 2, rs2_val[15..0], rl, false) + case WORD -> mem_write_value(addr, 4, rs2_val[31..0], rl, false) + case DOUBLE -> mem_write_value(addr, 8, rs2_val, rl, false) } } @@ -376,21 +376,77 @@ function clause decode (0b00011 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b01 function clause decode (0b00011 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(STORECON(aq, rl, rs2, rs1, DOUBLE, rd)) function clause execute (STORECON(aq, rl, rs2, rs1, width, rd)) = { if aq then not_implemented("store-conditional-acquire is not implemented"); + + (*(bit)*) status := if speculate_conditional_success() then 0 else 1; + wGPR(rd) := (bit[64]) (EXTZ([status])); + (bit[64]) addr := rGPR(rs1); switch width { - case WORD -> mem_write_conditional_ea(addr, 4, rl) - case DOUBLE -> mem_write_conditional_ea(addr, 8, rl) + case WORD -> mem_write_ea(addr, 4, rl, true) + case DOUBLE -> mem_write_ea(addr, 8, rl, true) }; rs2_val := rGPR(rs2); - (bool) success := - switch width { - case WORD -> mem_write_conditional_value(addr, 4, rs2_val[31..0], rl) - case DOUBLE -> mem_write_conditional_value(addr, 8, rs2_val, rl) - }; - if success then wGPR(rd, 0) - else wGPR(rd, 1); + switch width { + case WORD -> mem_write_value(addr, 4, rs2_val[31..0], rl, true) + case DOUBLE -> mem_write_value(addr, 8, rs2_val, rl, true) + }; } +union ast member (amoop, bool, bool, regno, regno, word_width, regno) AMO + +function clause decode (0b00001 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOSWAP, aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b00001 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOSWAP, aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b00000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOADD , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b00000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOADD , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b00100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOXOR , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b00100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOXOR , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b01100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOAND , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b01100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOAND , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b01000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOOR , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b01000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOOR , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b10000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOMIN , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b10000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOMIN , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b10100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOMAX , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b10100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOMAX , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b11000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOMINU, aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b11000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOMINU, aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b11100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOMAXU, aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b11100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOMAXU, aq, rl, rs2, rs1, DOUBLE, rd)) +function clause execute (AMO(op, aq, rl, rs2, rs1, width, rd)) = { + (bit[64]) addr := rGPR(rs1); + + switch (width) { + case WORD -> mem_write_ea(addr, 4, rl, true) + case DOUBLE -> mem_write_ea(addr, 8, rl, true) + }; + + (bit[64]) loaded := + switch (width) { + case WORD -> EXTS(mem_read(addr, 4, aq, true)) + case DOUBLE -> mem_read(addr, 8, aq, true) + }; + wGPR(rd, loaded); + + (bit[64]) rs2_val := rGPR(rs2); + (bit[64]) result := + switch(op) { + case AMOSWAP -> rs2_val + case AMOADD -> rs2_val + loaded + case AMOXOR -> rs2_val ^ loaded + case AMOAND -> rs2_val & loaded + case AMOOR -> rs2_val | loaded + + case AMOMIN -> (bit[64]) (min(signed(rs2_val), signed(loaded))) + case AMOMAX -> (bit[64]) (max(signed(rs2_val), signed(loaded))) + case AMOMINU -> (bit[64]) (min(unsigned(rs2_val), unsigned(loaded))) + case AMOMAXU -> (bit[64]) (max(unsigned(rs2_val), unsigned(loaded))) + }; + + switch (width) { + case WORD -> mem_write_value(addr, 4, result[31..0], rl, true) + case DOUBLE -> mem_write_value(addr, 8, result, rl, true) + }; +} function clause decode _ = None diff --git a/risc-v/riscv_extras.lem b/risc-v/riscv_extras.lem index 59e3cd4a..62a7bb91 100644 --- a/risc-v/riscv_extras.lem +++ b/risc-v/riscv_extras.lem @@ -51,20 +51,27 @@ let memory_eas : memory_write_eas = let memory_vals : memory_write_vals = [ ("MEMval", (MV memory_parameter_transformer_option_address Nothing)); ("MEMval_release", (MV memory_parameter_transformer_option_address Nothing)); - ("MEMval_conditional", - (MV memory_parameter_transformer_option_address + ("MEMval_conditional", (MV memory_parameter_transformer_option_address Nothing)); + (* (MV memory_parameter_transformer_option_address (Just (fun (IState interp context) b -> let bit = Interp_ast.V_lit (L_aux (if b then L_one else L_zero) Interp_ast.Unknown) in - (IState (Interp.add_answer_to_stack interp bit) context))))); - ("MEMval_conditional_release", - (MV memory_parameter_transformer_option_address + (IState (Interp.add_answer_to_stack interp bit) context))))); *) + ("MEMval_conditional_release", (MV memory_parameter_transformer_option_address Nothing)); + (* (MV memory_parameter_transformer_option_address (Just (fun (IState interp context) b -> let bit = Interp_ast.V_lit (L_aux (if b then L_one else L_zero) Interp_ast.Unknown) in - (IState (Interp.add_answer_to_stack interp bit) context))))); + (IState (Interp.add_answer_to_stack interp bit) context))))); *) ] +let speculate_conditional_success : excl_res = + let f = fun (IState interp context) b -> + let bool_res = Interp_ast.V_lit (L_aux (if b then L_one else L_zero) Interp_ast.Unknown) in + IState (Interp.add_answer_to_stack interp bool_res) context + in + Just ("speculate_conditional_success", (ER (Just f))) + let barrier_functions = [ ("MEM_fence_rw_rw", Barrier_RISCV_rw_rw); ("MEM_fence_r_rw", Barrier_RISCV_r_rw); diff --git a/risc-v/riscv_extras_embed.lem b/risc-v/riscv_extras_embed.lem index 6bfc2490..3f04f9a2 100644 --- a/risc-v/riscv_extras_embed.lem +++ b/risc-v/riscv_extras_embed.lem @@ -26,13 +26,15 @@ let MEMea_conditional_release (addr,size) = write_mem_ea Write_RISCV_conditional val MEMval : (vector bitU * integer * vector bitU) -> M unit val MEMval_release : (vector bitU * integer * vector bitU) -> M unit -val MEMval_conditional : (vector bitU * integer * vector bitU) -> M bitU -val MEMval_conditional_release : (vector bitU * integer * vector bitU) -> M bitU +val MEMval_conditional : (vector bitU * integer * vector bitU) -> M unit +val MEMval_conditional_release : (vector bitU * integer * vector bitU) -> M unit let MEMval (_,_,v) = write_mem_val v >>= fun _ -> return () let MEMval_release (_,_,v) = write_mem_val v >>= fun _ -> return () -let MEMval_conditional (_,_,v) = write_mem_val v >>= fun b -> return (if b then B1 else B0) -let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun b -> return (if b then B1 else B0) +let MEMval_conditional (_,_,v) = write_mem_val v >>= fun _ -> return () (* (if b then B1 else B0) *) +let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun _ -> return () (* (if b then B1 else B0) *) + +let speculate_conditional_success () = excl_result () >>= fun b -> return (if b then B1 else B0) val MEM_fence_rw_rw : unit -> M unit val MEM_fence_r_rw : unit -> M unit diff --git a/risc-v/riscv_extras_embed_sequential.lem b/risc-v/riscv_extras_embed_sequential.lem index 0fca7709..dabd4d12 100644 --- a/risc-v/riscv_extras_embed_sequential.lem +++ b/risc-v/riscv_extras_embed_sequential.lem @@ -26,13 +26,15 @@ let MEMea_conditional_release (addr,size) = write_mem_ea Write_RISCV_conditional val MEMval : (vector bitU * integer * vector bitU) -> M unit val MEMval_release : (vector bitU * integer * vector bitU) -> M unit -val MEMval_conditional : (vector bitU * integer * vector bitU) -> M bitU -val MEMval_conditional_release : (vector bitU * integer * vector bitU) -> M bitU +val MEMval_conditional : (vector bitU * integer * vector bitU) -> M unit +val MEMval_conditional_release : (vector bitU * integer * vector bitU) -> M unit let MEMval (_,_,v) = write_mem_val v >>= fun _ -> return () let MEMval_release (_,_,v) = write_mem_val v >>= fun _ -> return () -let MEMval_conditional (_,_,v) = write_mem_val v >>= fun b -> return (if b then B1 else B0) -let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun b -> return (if b then B1 else B0) +let MEMval_conditional (_,_,v) = write_mem_val v >>= fun _ -> return () (* (if b then B1 else B0) *) +let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun _ -> return () (* (if b then B1 else B0) *) + +let speculate_conditional_success () = excl_result () >>= fun b -> return (if b then B1 else B0) val MEM_fence_rw_rw : unit -> M unit val MEM_fence_r_rw : unit -> M unit diff --git a/risc-v/riscv_regfp.sail b/risc-v/riscv_regfp.sail index 20da3da3..e6813c37 100644 --- a/risc-v/riscv_regfp.sail +++ b/risc-v/riscv_regfp.sail @@ -103,12 +103,27 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; if (rs1 == 0) then () else aR := RFull(GPRstr[rs1]) :: aR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + ik := switch (aq, rl) { case (false, false) -> IK_mem_write (Write_RISCV_conditional) case (false, true) -> IK_mem_write (Write_RISCV_conditional_release) case (true, _) -> exit "not implemented" }; } + case (AMO( op, aq, rl, rs2, rs1, width, rd)) -> { + if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; + if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; + if (rs1 == 0) then () else aR := RFull(GPRstr[rs1]) :: aR; + if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; + + ik := switch (aq, rl) { + case (false, false) -> IK_mem_rmw (Read_RISCV_reserved, Write_RISCV_conditional) + case (false, true) -> IK_mem_rmw (Read_RISCV_reserved, Write_RISCV_conditional_release) + case (true, false) -> IK_mem_rmw (Read_RISCV_reserved_acquire, Write_RISCV_conditional) + case (true, true) -> IK_mem_rmw (Read_RISCV_reserved_acquire, Write_RISCV_conditional_release) + }; + } }; (iR,oR,aR,Nias,Dia,ik) } diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 6a9a77a1..411ad3fc 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -1416,6 +1416,41 @@ let interp_instruction_analysis if forall (inst_kind' MEM inst_kinds). inst_kind' = inst_kind then inst_kind + + else if + (forall (inst_kind' MEM (inst_kind :: inst_kinds)). + match inst_kind' with + | IK_mem_read _ -> true + | IK_mem_write _ -> true + | IK_mem_rmw _ -> false + | IK_barrier _ -> false + | IK_cond_branch -> false + | IK_trans _ -> false + | IK_simple -> false + end) && + (exists (inst_kind' MEM (inst_kind :: inst_kinds)). + match inst_kind' with + | IK_mem_read _ -> true + | _ -> false + end) && + (exists (inst_kind' MEM (inst_kind :: inst_kinds)). + match inst_kind' with + | IK_mem_write _ -> true + | _ -> false + end) + then + match + List.partition + (function IK_mem_read _ -> true | _ -> false end) + (inst_kind :: inst_kinds) + with + | ((IK_mem_read r) :: rs, (IK_mem_write w) :: ws) -> + let () = ensure (forall (r' MEM rs). r' = IK_mem_read r) "more than one kind of read" in + let () = ensure (forall (w' MEM ws). w' = IK_mem_write w) "more than one kind of write" in + IK_mem_rmw (r, w) + | _ -> fail + end + (* the TSTART instruction can also be aborted so it will have two kinds of events *) else if (exists (inst_kind' MEM (inst_kind :: inst_kinds)). inst_kind' = IK_trans Transaction_start) && @@ -1424,7 +1459,9 @@ let interp_instruction_analysis || inst_kind' = IK_trans Transaction_abort) then IK_trans Transaction_start - else failwith "multiple instruction kinds" + + else + failwith "multiple instruction kinds" end in (regs_in, regs_out, regs_feeding_address, nias, dia, inst_kind) diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 3886f919..721c0226 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -552,26 +552,27 @@ instance (Show trans_kind) end type instruction_kind = - | IK_barrier of barrier_kind - | IK_mem_read of read_kind + | IK_barrier of barrier_kind + | IK_mem_read of read_kind | IK_mem_write of write_kind -(* SS reinstating cond_branches -at present branches are not distinguished in the instruction_kind; -they just have particular nias (and will be IK_simple *) - | IK_cond_branch -(* | IK_uncond_branch *) - | IK_trans of trans_kind + | IK_mem_rmw of (read_kind * write_kind) + | IK_cond_branch + (* unconditional branches are not distinguished in the instruction_kind; + they just have particular nias (and will be IK_simple *) + (* | IK_uncond_branch *) + | IK_trans of trans_kind | IK_simple instance (Show instruction_kind) let show = function | IK_barrier barrier_kind -> "IK_barrier " ^ (show barrier_kind) - | IK_mem_read read_kind -> "IK_mem_read " ^ (show read_kind) + | IK_mem_read read_kind -> "IK_mem_read " ^ (show read_kind) | IK_mem_write write_kind -> "IK_mem_write " ^ (show write_kind) - | IK_cond_branch -> "IK_cond_branch" - | IK_trans trans_kind -> "IK_trans " ^ (show trans_kind) - | IK_simple -> "IK_simple" + | IK_mem_rmw (r, w) -> "IK_mem_rmw " ^ (show r) ^ " " ^ (show w) + | IK_cond_branch -> "IK_cond_branch" + | IK_trans trans_kind -> "IK_trans " ^ (show trans_kind) + | IK_simple -> "IK_simple" end end -- cgit v1.2.3 From f83c3d00f60a2507dfa5c3f31de6ddfc08eee610 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Thu, 31 Aug 2017 17:25:30 +0100 Subject: add EnumerationType type class: if a type is a member you get Ord membership and Set membership for free --- src/lem_interp/sail_impl_base.lem | 361 ++++++++++---------------------------- 1 file changed, 89 insertions(+), 272 deletions(-) diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 721c0226..c577c44b 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -42,6 +42,29 @@ open import Pervasives_extra + + +class ( EnumerationType 'a ) + val toNat : 'a -> nat +end + + +val enumeration_typeCompare : forall 'a. EnumerationType 'a => 'a -> 'a -> ordering +let ~{ocaml} enumeration_typeCompare e1 e2 = + compare (toNat e1) (toNat e2) +let inline {ocaml} enumeration_typeCompare = defaultCompare + + +default_instance forall 'a. EnumerationType 'a => (Ord 'a) + let compare = enumeration_typeCompare + let (<) r1 r2 = (enumeration_typeCompare r1 r2) = LT + let (<=) r1 r2 = (enumeration_typeCompare r1 r2) <> GT + let (>) r1 r2 = (enumeration_typeCompare r1 r2) = GT + let (>=) r1 r2 = (enumeration_typeCompare r1 r2) <> LT +end + + + (* maybe isn't a member of type Ord - this should be in the Lem standard library*) instance forall 'a. Ord 'a => (Ord (maybe 'a)) let compare = maybeCompare compare @@ -111,65 +134,21 @@ type opcode = Opcode of list byte (* of length 4 *) (** typeclass instantiations *) -let ~{ocaml} bitCompare (b1:bit) (b2:bit) = - match (b1,b2) with - | (Bitc_zero, Bitc_zero) -> EQ - | (Bitc_one, Bitc_one) -> EQ - | (Bitc_zero, _) -> LT - | (_,_) -> GT + +instance (EnumerationType bit) + let toNat = function + | Bitc_zero -> 0 + | Bitc_one -> 1 end -let inline {ocaml} bitCompare = defaultCompare - -let ~{ocaml} bitLess b1 b2 = bitCompare b1 b2 = LT -let ~{ocaml} bitLessEq b1 b2 = bitCompare b1 b2 <> GT -let ~{ocaml} bitGreater b1 b2 = bitCompare b1 b2 = GT -let ~{ocaml} bitGreaterEq b1 b2 = bitCompare b1 b2 <> LT - -let inline {ocaml} bitLess = defaultLess -let inline {ocaml} bitLessEq = defaultLessEq -let inline {ocaml} bitGreater = defaultGreater -let inline {ocaml} bitGreaterEq = defaultGreaterEq - -instance (Ord bit) - let compare = bitCompare - let (<) = bitLess - let (<=) = bitLessEq - let (>) = bitGreater - let (>=) = bitGreaterEq end -let ~{ocaml} bit_liftedCompare (bl1:bit_lifted) (bl2:bit_lifted) = - match (bl1,bl2) with - | (Bitl_zero, Bitl_zero) -> EQ - | (Bitl_zero,_) -> LT - | (Bitl_one, Bitl_zero) -> GT - | (Bitl_one, Bitl_one) -> EQ - | (Bitl_one, _) -> LT - | (Bitl_undef,Bitl_zero) -> GT - | (Bitl_undef,Bitl_one) -> GT - | (Bitl_undef,Bitl_undef) -> EQ - | (Bitl_undef,_) -> LT - | (Bitl_unknown,Bitl_unknown) -> EQ - | (Bitl_unknown,_) -> GT +instance (EnumerationType bit_lifted) + let toNat = function + | Bitl_zero -> 0 + | Bitl_one -> 1 + | Bitl_undef -> 2 + | Bitl_unknown -> 3 end -let inline {ocaml} bit_liftedCompare = defaultCompare - -let ~{ocaml} bit_liftedLess b1 b2 = bit_liftedCompare b1 b2 = LT -let ~{ocaml} bit_liftedLessEq b1 b2 = bit_liftedCompare b1 b2 <> GT -let ~{ocaml} bit_liftedGreater b1 b2 = bit_liftedCompare b1 b2 = GT -let ~{ocaml} bit_liftedGreaterEq b1 b2 = bit_liftedCompare b1 b2 <> LT - -let inline {ocaml} bit_liftedLess = defaultLess -let inline {ocaml} bit_liftedLessEq = defaultLessEq -let inline {ocaml} bit_liftedGreater = defaultGreater -let inline {ocaml} bit_liftedGreaterEq = defaultGreaterEq - -instance (Ord bit_lifted) - let compare = bit_liftedCompare - let (<) = bit_liftedLess - let (<=) = bit_liftedLessEq - let (>) = bit_liftedGreater - let (>=) = bit_liftedGreaterEq end let ~{ocaml} byte_liftedCompare (Byte_lifted b1) (Byte_lifted b2) = compare b1 b2 @@ -578,233 +557,71 @@ end -let ~{ocaml} read_kindCompare rk1 rk2 = - match (rk1, rk2) with - | (Read_plain, Read_plain) -> EQ - | (Read_plain, _) -> LT - | (_, Read_plain) -> GT - - | (Read_reserve, Read_reserve) -> EQ - | (Read_reserve, _) -> LT - | (_, Read_reserve) -> GT - - | (Read_acquire, Read_acquire) -> EQ - | (Read_acquire, _) -> LT - | (_, Read_acquire) -> GT - - | (Read_exclusive, Read_exclusive) -> EQ - | (Read_exclusive, _) -> LT - | (_, Read_exclusive) -> GT - - | (Read_exclusive_acquire, Read_exclusive_acquire) -> EQ - | (Read_exclusive_acquire, _) -> LT - | (_, Read_exclusive_acquire) -> GT - - | (Read_stream, Read_stream) -> EQ - | (Read_stream, _) -> LT - | (_, Read_stream) -> GT - - | (Read_RISCV_acquire, Read_RISCV_acquire) -> EQ - | (Read_RISCV_acquire, _) -> LT - | (_, Read_RISCV_acquire) -> GT - - | (Read_RISCV_reserved, Read_RISCV_reserved) -> EQ - | (Read_RISCV_reserved, _) -> LT - | (_, Read_RISCV_reserved) -> GT - - | (Read_RISCV_reserved_acquire, Read_RISCV_reserved_acquire) -> EQ - (*| (Read_RISCV_reserved_acquire, _) -> LT - | (_, Read_RISCV_reserved_acquire) -> GT*) +instance (EnumerationType read_kind) + let toNat = function + | Read_plain -> 0 + | Read_reserve -> 1 + | Read_acquire -> 2 + | Read_exclusive -> 3 + | Read_exclusive_acquire -> 4 + | Read_stream -> 5 + | Read_RISCV_acquire -> 6 + | Read_RISCV_reserved -> 7 + | Read_RISCV_reserved_acquire -> 8 end -let inline {ocaml} read_kindCompare = defaultCompare - -let ~{ocaml} read_kindLess b1 b2 = read_kindCompare b1 b2 = LT -let ~{ocaml} read_kindLessEq b1 b2 = read_kindCompare b1 b2 <> GT -let ~{ocaml} read_kindGreater b1 b2 = read_kindCompare b1 b2 = GT -let ~{ocaml} read_kindGreaterEq b1 b2 = read_kindCompare b1 b2 <> LT - -let inline {ocaml} read_kindLess = defaultLess -let inline {ocaml} read_kindLessEq = defaultLessEq -let inline {ocaml} read_kindGreater = defaultGreater -let inline {ocaml} read_kindGreaterEq = defaultGreaterEq - -instance (Ord read_kind) - let compare = read_kindCompare - let (<) = read_kindLess - let (<=) = read_kindLessEq - let (>) = read_kindGreater - let (>=) = read_kindGreaterEq end -let ~{ocaml} write_kindCompare wk1 wk2 = - match (wk1, wk2) with - | (Write_plain, Write_plain) -> EQ - | (Write_plain, _) -> LT - | (_, Write_plain) -> GT - - | (Write_conditional, Write_conditional) -> EQ - | (Write_conditional, _) -> LT - | (_, Write_conditional) -> GT - - - | (Write_release, Write_release) -> EQ - | (Write_release, _) -> LT - | (_, Write_release) -> GT - - | (Write_exclusive, Write_exclusive) -> EQ - | (Write_exclusive, _) -> LT - | (_, Write_exclusive) -> GT - - | (Write_exclusive_release, Write_exclusive_release) -> EQ - | (Write_exclusive_release, _) -> LT - | (_, Write_exclusive_release) -> GT - - | (Write_RISCV_release, Write_RISCV_release) -> EQ - | (Write_RISCV_release, _) -> LT - | (_, Write_RISCV_release) -> GT - - | (Write_RISCV_conditional, Write_RISCV_conditional) -> EQ - | (Write_RISCV_conditional, _) -> LT - | (_, Write_RISCV_conditional) -> GT - - | (Write_RISCV_conditional_release, Write_RISCV_conditional_release) -> EQ - (*| (Write_RISCV_conditional_release, _) -> LT - | (_, Write_RISCV_conditional_release) -> GT*) +instance (EnumerationType write_kind) + let toNat = function + | Write_plain -> 0 + | Write_conditional -> 1 + | Write_release -> 2 + | Write_exclusive -> 3 + | Write_exclusive_release -> 4 + | Write_RISCV_release -> 5 + | Write_RISCV_conditional -> 6 + | Write_RISCV_conditional_release -> 7 end -let inline {ocaml} write_kindCompare = defaultCompare - -let ~{ocaml} write_kindLess b1 b2 = write_kindCompare b1 b2 = LT -let ~{ocaml} write_kindLessEq b1 b2 = write_kindCompare b1 b2 <> GT -let ~{ocaml} write_kindGreater b1 b2 = write_kindCompare b1 b2 = GT -let ~{ocaml} write_kindGreaterEq b1 b2 = write_kindCompare b1 b2 <> LT - -let inline {ocaml} write_kindLess = defaultLess -let inline {ocaml} write_kindLessEq = defaultLessEq -let inline {ocaml} write_kindGreater = defaultGreater -let inline {ocaml} write_kindGreaterEq = defaultGreaterEq - -instance (Ord write_kind) - let compare = write_kindCompare - let (<) = write_kindLess - let (<=) = write_kindLessEq - let (>) = write_kindGreater - let (>=) = write_kindGreaterEq end - -let ~{ocaml} barrier_kindCompare bk1 bk2 = - match (bk1, bk2) with - | (Barrier_Sync, Barrier_Sync) -> EQ - | (Barrier_Sync, _) -> LT - | (_, Barrier_Sync) -> GT - - | (Barrier_LwSync, Barrier_LwSync) -> EQ - | (Barrier_LwSync, _) -> LT - | (_, Barrier_LwSync) -> GT - - | (Barrier_Eieio, Barrier_Eieio) -> EQ - | (Barrier_Eieio, _) -> LT - | (_, Barrier_Eieio) -> GT - - | (Barrier_Isync, Barrier_Isync) -> EQ - | (Barrier_Isync, _) -> LT - | (_, Barrier_Isync) -> GT - - | (Barrier_DMB, Barrier_DMB) -> EQ - | (Barrier_DMB, _) -> LT - | (_, Barrier_DMB) -> GT - - | (Barrier_DMB_ST, Barrier_DMB_ST) -> EQ - | (Barrier_DMB_ST, _) -> LT - | (_, Barrier_DMB_ST) -> GT - - | (Barrier_DMB_LD, Barrier_DMB_LD) -> EQ - | (Barrier_DMB_LD, _) -> LT - | (_, Barrier_DMB_LD) -> GT - - | (Barrier_DSB, Barrier_DSB) -> EQ - | (Barrier_DSB, _) -> LT - | (_, Barrier_DSB) -> GT - - | (Barrier_DSB_ST, Barrier_DSB_ST) -> EQ - | (Barrier_DSB_ST, _) -> LT - | (_, Barrier_DSB_ST) -> GT - - | (Barrier_DSB_LD, Barrier_DSB_LD) -> EQ - | (Barrier_DSB_LD, _) -> LT - | (_, Barrier_DSB_LD) -> GT - - | (Barrier_ISB, Barrier_ISB) -> EQ - | (Barrier_ISB, _) -> LT - | (_, Barrier_ISB) -> GT - - | (Barrier_TM_COMMIT, Barrier_TM_COMMIT) -> EQ - | (Barrier_TM_COMMIT, _) -> LT - | (_, Barrier_TM_COMMIT) -> GT - - | (Barrier_MIPS_SYNC, Barrier_MIPS_SYNC) -> EQ - | (Barrier_MIPS_SYNC, _) -> LT - | (_, Barrier_MIPS_SYNC) -> GT - - | (Barrier_RISCV_rw_rw, Barrier_RISCV_rw_rw) -> EQ - | (Barrier_RISCV_rw_rw, _) -> LT - | (_, Barrier_RISCV_rw_rw) -> GT - - | (Barrier_RISCV_r_rw, Barrier_RISCV_r_rw) -> EQ - | (Barrier_RISCV_r_rw, _) -> LT - | (_, Barrier_RISCV_r_rw) -> GT - - | (Barrier_RISCV_rw_w, Barrier_RISCV_rw_w) -> EQ - | (Barrier_RISCV_rw_w, _) -> LT - | (_, Barrier_RISCV_rw_w) -> GT - - | (Barrier_RISCV_w_w, Barrier_RISCV_w_w) -> EQ - | (Barrier_RISCV_w_w, _) -> LT - | (_, Barrier_RISCV_w_w) -> GT - - | (Barrier_RISCV_i, Barrier_RISCV_i) -> EQ - | (Barrier_RISCV_i, _) -> LT - | (_, Barrier_RISCV_i) -> GT - - | (Barrier_x86_MFENCE, Barrier_x86_MFENCE) -> EQ - (*| (Barrier_x86_MFENCE, _) -> LT - | (_, Barrier_x86_MFENCE) -> GT*) +instance (EnumerationType barrier_kind) + let toNat = function + | Barrier_Sync -> 0 + | Barrier_LwSync -> 1 + | Barrier_Eieio ->2 + | Barrier_Isync -> 3 + | Barrier_DMB -> 4 + | Barrier_DMB_ST -> 5 + | Barrier_DMB_LD -> 6 + | Barrier_DSB -> 7 + | Barrier_DSB_ST -> 8 + | Barrier_DSB_LD -> 9 + | Barrier_ISB -> 10 + | Barrier_TM_COMMIT -> 11 + | Barrier_MIPS_SYNC -> 12 + | Barrier_RISCV_rw_rw -> 13 + | Barrier_RISCV_r_rw -> 14 + | Barrier_RISCV_rw_w -> 15 + | Barrier_RISCV_w_w -> 16 + | Barrier_RISCV_i -> 17 + | Barrier_x86_MFENCE -> 18 end -let inline {ocaml} barrier_kindCompare = defaultCompare - -let ~{ocaml} barrier_kindLess b1 b2 = barrier_kindCompare b1 b2 = LT -let ~{ocaml} barrier_kindLessEq b1 b2 = barrier_kindCompare b1 b2 <> GT -let ~{ocaml} barrier_kindGreater b1 b2 = barrier_kindCompare b1 b2 = GT -let ~{ocaml} barrier_kindGreaterEq b1 b2 = barrier_kindCompare b1 b2 <> LT - -let inline {ocaml} barrier_kindLess = defaultLess -let inline {ocaml} barrier_kindLessEq = defaultLessEq -let inline {ocaml} barrier_kindGreater = defaultGreater -let inline {ocaml} barrier_kindGreaterEq = defaultGreaterEq - -instance (Ord barrier_kind) - let compare = barrier_kindCompare - let (<) = barrier_kindLess - let (<=) = barrier_kindLessEq - let (>) = barrier_kindGreater - let (>=) = barrier_kindGreaterEq end - type event = -| E_read_mem of read_kind * address_lifted * nat * maybe (list reg_name) -| E_read_memt of read_kind * address_lifted * nat * maybe (list reg_name) -| E_write_mem of write_kind * address_lifted * nat * maybe (list reg_name) * memory_value * maybe (list reg_name) -| E_write_ea of write_kind * address_lifted * nat * maybe (list reg_name) -| E_excl_res -| E_write_memv of maybe address_lifted * memory_value * maybe (list reg_name) -| E_write_memvt of maybe address_lifted * (bit_lifted * memory_value) * maybe (list reg_name) -| E_barrier of barrier_kind -| E_footprint -| E_read_reg of reg_name -| E_write_reg of reg_name * register_value -| E_escape -| E_error of string + | E_read_mem of read_kind * address_lifted * nat * maybe (list reg_name) + | E_read_memt of read_kind * address_lifted * nat * maybe (list reg_name) + | E_write_mem of write_kind * address_lifted * nat * maybe (list reg_name) * memory_value * maybe (list reg_name) + | E_write_ea of write_kind * address_lifted * nat * maybe (list reg_name) + | E_excl_res + | E_write_memv of maybe address_lifted * memory_value * maybe (list reg_name) + | E_write_memvt of maybe address_lifted * (bit_lifted * memory_value) * maybe (list reg_name) + | E_barrier of barrier_kind + | E_footprint + | E_read_reg of reg_name + | E_write_reg of reg_name * register_value + | E_escape + | E_error of string let eventCompare e1 e2 = -- cgit v1.2.3 From 016cb11c78f84d02b40988958098b464dffc0f26 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Sat, 2 Sep 2017 08:09:44 +0100 Subject: check the status of SC before doing the memory write --- risc-v/riscv.sail | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index 5b749656..cd0e5bf9 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -380,15 +380,17 @@ function clause execute (STORECON(aq, rl, rs2, rs1, width, rd)) = { (*(bit)*) status := if speculate_conditional_success() then 0 else 1; wGPR(rd) := (bit[64]) (EXTZ([status])); - (bit[64]) addr := rGPR(rs1); - switch width { - case WORD -> mem_write_ea(addr, 4, rl, true) - case DOUBLE -> mem_write_ea(addr, 8, rl, true) - }; - rs2_val := rGPR(rs2); - switch width { - case WORD -> mem_write_value(addr, 4, rs2_val[31..0], rl, true) - case DOUBLE -> mem_write_value(addr, 8, rs2_val, rl, true) + if status == 1 then () else { + (bit[64]) addr := rGPR(rs1); + switch width { + case WORD -> mem_write_ea(addr, 4, rl, true) + case DOUBLE -> mem_write_ea(addr, 8, rl, true) + }; + rs2_val := rGPR(rs2); + switch width { + case WORD -> mem_write_value(addr, 4, rs2_val[31..0], rl, true) + case DOUBLE -> mem_write_value(addr, 8, rs2_val, rl, true) + }; }; } -- cgit v1.2.3 From 69dbe323ef6a8195465e2662fd447e1853e40866 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Sat, 2 Sep 2017 10:23:33 +0100 Subject: fix for parsing diy generated tests --- risc-v/hgen/parser.hgen | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/risc-v/hgen/parser.hgen b/risc-v/hgen/parser.hgen index 4440ffda..dc61e566 100644 --- a/risc-v/hgen/parser.hgen +++ b/risc-v/hgen/parser.hgen @@ -38,7 +38,13 @@ { `RISCVFENCEI } | LOADRES reg COMMA LPAR reg RPAR { `RISCVLoadRes($1.aq, $1.rl, $5, $1.width, $2) } +| LOADRES reg COMMA NUM LPAR reg RPAR + { if $4 <> 0 then failwith "'lr' offset must be 0" else + `RISCVLoadRes($1.aq, $1.rl, $6, $1.width, $2) } | STORECON reg COMMA reg COMMA LPAR reg RPAR { `RISCVStoreCon($1.aq, $1.rl, $4, $7, $1.width, $2) } +| STORECON reg COMMA reg COMMA NUM LPAR reg RPAR + { if $6 <> 0 then failwith "'sc' offset must be 0" else + `RISCVStoreCon($1.aq, $1.rl, $4, $8, $1.width, $2) } | AMO reg COMMA reg COMMA LPAR reg RPAR { `RISCVAMO($1.op, $1.aq, $1.rl, $4, $7, $1.width, $2) } -- cgit v1.2.3 From 75022d46352525305b4c06b4988bf2df15f9f29e Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Sun, 3 Sep 2017 15:05:23 +0100 Subject: added RISC-V strong-acquire/release --- etc/regfp.sail | 4 + risc-v/hgen/ast.hgen | 4 +- risc-v/hgen/fold.hgen | 26 ++--- risc-v/hgen/herdtools_ast_to_shallow_ast.hgen | 8 +- risc-v/hgen/lexer.hgen | 86 ++++++++------ risc-v/hgen/map.hgen | 24 ++-- risc-v/hgen/parser.hgen | 7 +- risc-v/hgen/pretty.hgen | 42 +++---- risc-v/hgen/sail_trans_out.hgen | 8 +- risc-v/hgen/shallow_ast_to_herdtools_ast.hgen | 8 +- risc-v/hgen/token_types.hgen | 4 +- risc-v/hgen/trans_sail.hgen | 6 +- risc-v/hgen/types.hgen | 14 ++- risc-v/hgen/types_trans_sail.hgen | 17 +++ risc-v/riscv.sail | 155 ++++++++++++++------------ risc-v/riscv_extras.lem | 29 ++--- risc-v/riscv_extras_embed.lem | 19 +++- risc-v/riscv_extras_embed_sequential.lem | 19 +++- risc-v/riscv_regfp.sail | 33 ++++-- src/gen_lib/sail_values.lem | 3 + src/gen_lib/state.lem | 2 + src/lem_interp/sail_impl_base.lem | 24 +++- 22 files changed, 328 insertions(+), 214 deletions(-) diff --git a/etc/regfp.sail b/etc/regfp.sail index 761737db..f7744e8c 100644 --- a/etc/regfp.sail +++ b/etc/regfp.sail @@ -39,8 +39,10 @@ typedef read_kind = enumerate { Read_exclusive_acquire; Read_stream; Read_RISCV_acquire; + Read_RISCV_strong_acquire; Read_RISCV_reserved; Read_RISCV_reserved_acquire; + Read_RISCV_reserved_strong_acquire; } typedef write_kind = enumerate { @@ -51,8 +53,10 @@ typedef write_kind = enumerate { Write_exclusive; Write_exclusive_release; Write_RISCV_release; + Write_RISCV_strong_release; Write_RISCV_conditional; Write_RISCV_conditional_release; + Write_RISCV_conditional_strong_release; } typedef barrier_kind = enumerate { diff --git a/risc-v/hgen/ast.hgen b/risc-v/hgen/ast.hgen index 1839557f..b1968173 100644 --- a/risc-v/hgen/ast.hgen +++ b/risc-v/hgen/ast.hgen @@ -5,8 +5,8 @@ | `RISCVIType of bit12 * reg * reg * riscvIop | `RISCVShiftIop of bit6 * reg * reg * riscvSop | `RISCVRType of reg * reg * reg * riscvRop -| `RISCVLoad of bit12 * reg * reg * bool * wordWidth * bool -| `RISCVStore of bit12 * reg * reg * wordWidth * bool +| `RISCVLoad of bit12 * reg * reg * bool * wordWidth * bool * bool +| `RISCVStore of bit12 * reg * reg * wordWidth * bool * bool | `RISCVADDIW of bit12 * reg * reg | `RISCVSHIFTW of bit5 * reg * reg * riscvSop | `RISCVRTYPEW of reg * reg * reg * riscvRopw diff --git a/risc-v/hgen/fold.hgen b/risc-v/hgen/fold.hgen index d8806a37..4c51e114 100644 --- a/risc-v/hgen/fold.hgen +++ b/risc-v/hgen/fold.hgen @@ -1,16 +1,16 @@ -| `RISCVThreadStart -> (y_reg, y_sreg) -| `RISCVUTYPE (_, r0, _) -> fold_reg r0 (y_reg, y_sreg) -| `RISCVJAL (_, r0) -> fold_reg r0 (y_reg, y_sreg) -| `RISCVJALR (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVBType (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVIType (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVShiftIop (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVRType (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) -| `RISCVLoad (_, r0, r1, _, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVStore (_, r0, r1, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVADDIW (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVSHIFTW (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVRTYPEW (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) +| `RISCVThreadStart -> (y_reg, y_sreg) +| `RISCVUTYPE (_, r0, _) -> fold_reg r0 (y_reg, y_sreg) +| `RISCVJAL (_, r0) -> fold_reg r0 (y_reg, y_sreg) +| `RISCVJALR (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVBType (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVIType (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVShiftIop (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVRType (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) +| `RISCVLoad (_, r0, r1, _, _, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVStore (_, r0, r1, _, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVADDIW (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVSHIFTW (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVRTYPEW (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) | `RISCVLoadRes (_, _, rs1, _, rd) -> fold_reg rs1 (fold_reg rd (y_reg, y_sreg)) | `RISCVStoreCon (_, _, rs2, rs1, _, rd) -> fold_reg rs2 (fold_reg rs1 (fold_reg rd (y_reg, y_sreg))) | `RISCVAMO (_, _, _, rs2, rs1, _, rd) -> fold_reg rs2 (fold_reg rs1 (fold_reg rd (y_reg, y_sreg))) diff --git a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen index 2e508678..e66608e6 100644 --- a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen +++ b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen @@ -30,18 +30,20 @@ translate_reg "rs1" rs1, translate_reg "rd" rd, translate_rop op) -| `RISCVLoad(imm, rs, rd, unsigned, width, aq) -> LOAD( +| `RISCVLoad(imm, rs, rd, unsigned, width, aq, rl) -> LOAD( translate_imm12 "imm" imm, translate_reg "rs" rs, translate_reg "rd" rd, translate_bool "unsigned" unsigned, translate_wordWidth width, - translate_bool "aq" aq) -| `RISCVStore(imm, rs, rd, width, rl) -> STORE ( + translate_bool "aq" aq, + translate_bool "rl" rl) +| `RISCVStore(imm, rs, rd, width, aq, rl) -> STORE ( translate_imm12 "imm" imm, translate_reg "rs" rs, translate_reg "rd" rd, translate_wordWidth width, + translate_bool "aq" aq, translate_bool "rl" rl) | `RISCVADDIW(imm, rs, rd) -> ADDIW( translate_imm12 "imm" imm, diff --git a/risc-v/hgen/lexer.hgen b/risc-v/hgen/lexer.hgen index 9d5df538..27df99f4 100644 --- a/risc-v/hgen/lexer.hgen +++ b/risc-v/hgen/lexer.hgen @@ -33,31 +33,44 @@ "or", RTYPE{op=RISCVOR}; "and", RTYPE{op=RISCVAND}; -"lb", LOAD{unsigned=false; width=RISCVBYTE; aq=false}; -"lbu", LOAD{unsigned=true; width=RISCVBYTE; aq=false}; -"lh", LOAD{unsigned=false; width=RISCVHALF; aq=false}; -"lhu", LOAD{unsigned=true; width=RISCVHALF; aq=false}; -"lw", LOAD{unsigned=false; width=RISCVWORD; aq=false}; -"lwu", LOAD{unsigned=true; width=RISCVWORD; aq=false}; -"ld", LOAD{unsigned=false; width=RISCVDOUBLE; aq=false}; - -"lb.aq", LOAD{unsigned=false; width=RISCVBYTE; aq=true}; -"lbu.aq", LOAD{unsigned=true; width=RISCVBYTE; aq=true}; -"lh.aq", LOAD{unsigned=false; width=RISCVHALF; aq=true}; -"lhu.aq", LOAD{unsigned=true; width=RISCVHALF; aq=true}; -"lw.aq", LOAD{unsigned=false; width=RISCVWORD; aq=true}; -"lwu.aq", LOAD{unsigned=true; width=RISCVWORD; aq=true}; -"ld.aq", LOAD{unsigned=false; width=RISCVDOUBLE; aq=true}; - -"sb", STORE{width=RISCVBYTE; rl=false}; -"sh", STORE{width=RISCVHALF; rl=false}; -"sw", STORE{width=RISCVWORD; rl=false}; -"sd", STORE{width=RISCVDOUBLE; rl=false}; - -"sb.rl", STORE{width=RISCVBYTE; rl=true}; -"sh.rl", STORE{width=RISCVHALF; rl=true}; -"sw.rl", STORE{width=RISCVWORD; rl=true}; -"sd.rl", STORE{width=RISCVDOUBLE; rl=true}; +"lb", LOAD{unsigned=false; width=RISCVBYTE; aq=false; rl=false}; +"lbu", LOAD{unsigned=true; width=RISCVBYTE; aq=false; rl=false}; +"lh", LOAD{unsigned=false; width=RISCVHALF; aq=false; rl=false}; +"lhu", LOAD{unsigned=true; width=RISCVHALF; aq=false; rl=false}; +"lw", LOAD{unsigned=false; width=RISCVWORD; aq=false; rl=false}; +"lwu", LOAD{unsigned=true; width=RISCVWORD; aq=false; rl=false}; +"ld", LOAD{unsigned=false; width=RISCVDOUBLE; aq=false; rl=false}; + +"lb.aq", LOAD{unsigned=false; width=RISCVBYTE; aq=true; rl=false}; +"lbu.aq", LOAD{unsigned=true; width=RISCVBYTE; aq=true; rl=false}; +"lh.aq", LOAD{unsigned=false; width=RISCVHALF; aq=true; rl=false}; +"lhu.aq", LOAD{unsigned=true; width=RISCVHALF; aq=true; rl=false}; +"lw.aq", LOAD{unsigned=false; width=RISCVWORD; aq=true; rl=false}; +"lwu.aq", LOAD{unsigned=true; width=RISCVWORD; aq=true; rl=false}; +"ld.aq", LOAD{unsigned=false; width=RISCVDOUBLE; aq=true; rl=false}; + +"lb.aq.rl", LOAD{unsigned=false; width=RISCVBYTE; aq=true; rl=true}; +"lbu.aq.rl", LOAD{unsigned=true; width=RISCVBYTE; aq=true; rl=true}; +"lh.aq.rl", LOAD{unsigned=false; width=RISCVHALF; aq=true; rl=true}; +"lhu.aq.rl", LOAD{unsigned=true; width=RISCVHALF; aq=true; rl=true}; +"lw.aq.rl", LOAD{unsigned=false; width=RISCVWORD; aq=true; rl=true}; +"lwu.aq.rl", LOAD{unsigned=true; width=RISCVWORD; aq=true; rl=true}; +"ld.aq.rl", LOAD{unsigned=false; width=RISCVDOUBLE; aq=true; rl=true}; + +"sb", STORE{width=RISCVBYTE; aq=false; rl=false}; +"sh", STORE{width=RISCVHALF; aq=false; rl=false}; +"sw", STORE{width=RISCVWORD; aq=false; rl=false}; +"sd", STORE{width=RISCVDOUBLE; aq=false; rl=false}; + +"sb.rl", STORE{width=RISCVBYTE; aq=false; rl=true}; +"sh.rl", STORE{width=RISCVHALF; aq=false; rl=true}; +"sw.rl", STORE{width=RISCVWORD; aq=false; rl=true}; +"sd.rl", STORE{width=RISCVDOUBLE; aq=false; rl=true}; + +"sb.aq.rl", STORE{width=RISCVBYTE; aq=true; rl=true}; +"sh.aq.rl", STORE{width=RISCVHALF; aq=true; rl=true}; +"sw.aq.rl", STORE{width=RISCVWORD; aq=true; rl=true}; +"sd.aq.rl", STORE{width=RISCVDOUBLE; aq=true; rl=true}; "addiw", ADDIW (); @@ -75,17 +88,22 @@ "r", FENCEOPTION Fence_R; "w", FENCEOPTION Fence_W; "rw", FENCEOPTION Fence_RW; -"fence.i", FENCEI (); -"lr.w", LOADRES {width=RISCVWORD; aq=false; rl=false}; -"lr.w.aq", LOADRES {width=RISCVWORD; aq=true; rl=false}; -"lr.d", LOADRES {width=RISCVDOUBLE; aq=false; rl=false}; -"lr.d.aq", LOADRES {width=RISCVDOUBLE; aq=true; rl=false}; +"fence.i", FENCEI (); -"sc.w", STORECON {width=RISCVWORD; aq=false; rl=false}; -"sc.w.rl", STORECON {width=RISCVWORD; aq=false; rl=true}; -"sc.d", STORECON {width=RISCVDOUBLE; aq=false; rl=false}; -"sc.d.rl", STORECON {width=RISCVDOUBLE; aq=false; rl=true}; +"lr.w", LOADRES {width=RISCVWORD; aq=false; rl=false}; +"lr.w.aq", LOADRES {width=RISCVWORD; aq=true; rl=false}; +"lr.w.aq.rl", LOADRES {width=RISCVWORD; aq=true; rl=true}; +"lr.d", LOADRES {width=RISCVDOUBLE; aq=false; rl=false}; +"lr.d.aq", LOADRES {width=RISCVDOUBLE; aq=true; rl=false}; +"lr.d.aq.rl", LOADRES {width=RISCVDOUBLE; aq=true; rl=true}; + +"sc.w", STORECON {width=RISCVWORD; aq=false; rl=false}; +"sc.w.rl", STORECON {width=RISCVWORD; aq=false; rl=true}; +"sc.w.aq.rl", STORECON {width=RISCVWORD; aq=true; rl=true}; +"sc.d", STORECON {width=RISCVDOUBLE; aq=false; rl=false}; +"sc.d.rl", STORECON {width=RISCVDOUBLE; aq=false; rl=true}; +"sc.d.aq.rl", STORECON {width=RISCVDOUBLE; aq=true; rl=true}; "amoswap.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOSWAP}; "amoadd.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOADD}; diff --git a/risc-v/hgen/map.hgen b/risc-v/hgen/map.hgen index 91eecc56..bab5ced8 100644 --- a/risc-v/hgen/map.hgen +++ b/risc-v/hgen/map.hgen @@ -1,15 +1,15 @@ -| `RISCVUTYPE (x, r0, y) -> `RISCVUTYPE (x, map_reg r0, y) -| `RISCVJAL (x, r0) -> `RISCVJAL (x, map_reg r0) -| `RISCVJALR (x, r0, r1) -> `RISCVJALR (x, map_reg r0, map_reg r1) -| `RISCVBType (x, r0, r1, y) -> `RISCVBType (x, map_reg r0, map_reg r1, y) -| `RISCVIType (x, r0, r1, y) -> `RISCVIType (x, map_reg r0, map_reg r1, y) -| `RISCVShiftIop (x, r0, r1, y) -> `RISCVShiftIop (x, map_reg r0, map_reg r1, y) -| `RISCVRType (r0, r1, r2, y) -> `RISCVRType (r0, map_reg r1, map_reg r2, y) -| `RISCVLoad (x, r0, r1, y, z, a) -> `RISCVLoad (x, map_reg r0, map_reg r1, y, z, a) -| `RISCVStore (x, r0, r1, y, z) -> `RISCVStore (x, map_reg r0, map_reg r1, y, z) -| `RISCVADDIW (x, r0, r1) -> `RISCVADDIW (x, map_reg r0, map_reg r1) -| `RISCVSHIFTW (x, r0, r1, y) -> `RISCVSHIFTW (x, map_reg r0, map_reg r1, y) -| `RISCVRTYPEW (r0, r1, r2, x) -> `RISCVRTYPEW (r0, map_reg r1, map_reg r2, x) +| `RISCVUTYPE (x, r0, y) -> `RISCVUTYPE (x, map_reg r0, y) +| `RISCVJAL (x, r0) -> `RISCVJAL (x, map_reg r0) +| `RISCVJALR (x, r0, r1) -> `RISCVJALR (x, map_reg r0, map_reg r1) +| `RISCVBType (x, r0, r1, y) -> `RISCVBType (x, map_reg r0, map_reg r1, y) +| `RISCVIType (x, r0, r1, y) -> `RISCVIType (x, map_reg r0, map_reg r1, y) +| `RISCVShiftIop (x, r0, r1, y) -> `RISCVShiftIop (x, map_reg r0, map_reg r1, y) +| `RISCVRType (r0, r1, r2, y) -> `RISCVRType (r0, map_reg r1, map_reg r2, y) +| `RISCVLoad (x, r0, r1, y, z, a, b) -> `RISCVLoad (x, map_reg r0, map_reg r1, y, z, a, b) +| `RISCVStore (x, r0, r1, y, z, a) -> `RISCVStore (x, map_reg r0, map_reg r1, y, z, a) +| `RISCVADDIW (x, r0, r1) -> `RISCVADDIW (x, map_reg r0, map_reg r1) +| `RISCVSHIFTW (x, r0, r1, y) -> `RISCVSHIFTW (x, map_reg r0, map_reg r1, y) +| `RISCVRTYPEW (r0, r1, r2, x) -> `RISCVRTYPEW (r0, map_reg r1, map_reg r2, x) | `RISCVLoadRes (aq, rl, rs1, w, rd) -> `RISCVLoadRes (aq, rl, map_reg rs1, w, map_reg rd) | `RISCVStoreCon (aq, rl, rs2, rs1, w, rd) -> `RISCVStoreCon (aq, rl, map_reg rs2, map_reg rs1, w, map_reg rd) | `RISCVAMO (op, aq, rl, rs2, rs1, w, rd) -> `RISCVAMO (op, aq, rl, map_reg rs2, map_reg rs1, w, map_reg rd) diff --git a/risc-v/hgen/parser.hgen b/risc-v/hgen/parser.hgen index dc61e566..82bb1d5b 100644 --- a/risc-v/hgen/parser.hgen +++ b/risc-v/hgen/parser.hgen @@ -13,9 +13,9 @@ | RTYPE reg COMMA reg COMMA reg { `RISCVRType ($6, $4, $2, $1.op) } | LOAD reg COMMA NUM LPAR reg RPAR - { `RISCVLoad($4, $6, $2, $1.unsigned, $1.width, $1.aq) } + { `RISCVLoad($4, $6, $2, $1.unsigned, $1.width, $1.aq, $1.rl) } | STORE reg COMMA NUM LPAR reg RPAR - { `RISCVStore($4, $2, $6, $1.width, $1.rl) } + { `RISCVStore($4, $2, $6, $1.width, $1.aq, $1.rl) } | ADDIW reg COMMA reg COMMA NUM { `RISCVADDIW ($6, $4, $2) } | SHIFTW reg COMMA reg COMMA NUM @@ -48,3 +48,6 @@ `RISCVStoreCon($1.aq, $1.rl, $4, $8, $1.width, $2) } | AMO reg COMMA reg COMMA LPAR reg RPAR { `RISCVAMO($1.op, $1.aq, $1.rl, $4, $7, $1.width, $2) } +| AMO reg COMMA reg COMMA NUM LPAR reg RPAR + { if $6 <> 0 then failwith "'amo' offset must be 0" else + `RISCVAMO($1.op, $1.aq, $1.rl, $4, $8, $1.width, $2) } diff --git a/risc-v/hgen/pretty.hgen b/risc-v/hgen/pretty.hgen index b5068c71..fc1c0000 100644 --- a/risc-v/hgen/pretty.hgen +++ b/risc-v/hgen/pretty.hgen @@ -7,34 +7,24 @@ | `RISCVIType(imm, rs2, rs1, op) -> sprintf "%s %s, %s, %d" (pp_riscv_iop op) (pp_reg rs1) (pp_reg rs2) imm | `RISCVShiftIop(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm | `RISCVRType (rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_rop op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) -| `RISCVLoad(imm, rs, rd, unsigned, width, aq) - -> sprintf "%s %s, %d(%s)" (pp_riscv_load_op (unsigned, width, aq)) (pp_reg rd) imm (pp_reg rs) -| `RISCVStore(imm, rs2, rs1, width, rl) - -> sprintf "%s %s, %d(%s)" (pp_riscv_store_op (width, rl)) (pp_reg rs2) imm (pp_reg rs1) + +| `RISCVLoad(imm, rs, rd, unsigned, width, aq, rl) -> + sprintf "%s %s, %d(%s)" (pp_riscv_load_op (unsigned, width, aq, rl)) (pp_reg rd) imm (pp_reg rs) + +| `RISCVStore(imm, rs2, rs1, width, aq, rl) -> + sprintf "%s %s, %d(%s)" (pp_riscv_store_op (width, aq, rl)) (pp_reg rs2) imm (pp_reg rs1) + | `RISCVADDIW(imm, rs, rd) -> sprintf "addiw %s, %s, %d" (pp_reg rd) (pp_reg rs) imm | `RISCVSHIFTW(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm | `RISCVRTYPEW(rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_ropw op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) | `RISCVFENCE(pred, succ) -> sprintf "fence %s, %s" (pp_riscv_fence_option pred) (pp_riscv_fence_option succ) | `RISCVFENCEI -> sprintf "fence.i" -| `RISCVLoadRes(aq, rl, rs1, width, rd) - -> - assert (rl = false); - sprintf "%s %s, (%s)" - (pp_riscv_load_reserved_op (aq, rl, width)) - (pp_reg rd) - (pp_reg rs1) -| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) - -> - assert (aq = false); - sprintf "%s %s, %s, (%s)" - (pp_riscv_store_conditional_op (aq, rl, width)) - (pp_reg rd) - (pp_reg rs2) - (pp_reg rs1) -| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) - -> - sprintf "%s %s, %s, (%s)" - (pp_riscv_amo_op (op, aq, rl, width)) - (pp_reg rd) - (pp_reg rs2) - (pp_reg rs1) + +| `RISCVLoadRes(aq, rl, rs1, width, rd) -> + sprintf "%s %s, (%s)" (pp_riscv_load_reserved_op (aq, rl, width)) (pp_reg rd) (pp_reg rs1) + +| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> + sprintf "%s %s, %s, (%s)" (pp_riscv_store_conditional_op (aq, rl, width)) (pp_reg rd) (pp_reg rs2) (pp_reg rs1) + +| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) -> + sprintf "%s %s, %s, (%s)" (pp_riscv_amo_op (op, aq, rl, width)) (pp_reg rd) (pp_reg rs2) (pp_reg rs1) diff --git a/risc-v/hgen/sail_trans_out.hgen b/risc-v/hgen/sail_trans_out.hgen index bec35203..2f9a80f1 100644 --- a/risc-v/hgen/sail_trans_out.hgen +++ b/risc-v/hgen/sail_trans_out.hgen @@ -6,10 +6,10 @@ | ("ITYPE", [imm; rs1; rd; op]) -> `RISCVIType(translate_out_simm12 imm, translate_out_ireg rs1, translate_out_ireg rd, translate_out_iop op) | ("SHIFTIOP", [imm; rs; rd; op]) -> `RISCVShiftIop(translate_out_imm6 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | ("RTYPE", [rs2; rs1; rd; op]) -> `RISCVRType (translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_rop op) -| ("LOAD", [imm; rs; rd; unsigned; width; aq]) - -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq) -| ("STORE", [imm; rs; rd; width; rl]) - -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width, translate_out_bool rl) +| ("LOAD", [imm; rs; rd; unsigned; width; aq; rl]) + -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) +| ("STORE", [imm; rs; rd; width; aq; rl]) + -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) | ("ADDIW", [imm; rs; rd]) -> `RISCVADDIW(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) | ("SHIFTW", [imm; rs; rd; op]) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | ("RTYPEW", [rs2; rs1; rd; op]) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) diff --git a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen index 662b1044..23bcc4cb 100644 --- a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen +++ b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen @@ -6,10 +6,10 @@ | ITYPE( imm, rs1, rd, op) -> `RISCVIType(translate_out_simm12 imm, translate_out_ireg rs1, translate_out_ireg rd, translate_out_iop op) | SHIFTIOP( imm, rs, rd, op) -> `RISCVShiftIop(translate_out_imm6 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | RTYPE( rs2, rs1, rd, op) -> `RISCVRType (translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_rop op) -| LOAD( imm, rs, rd, unsigned, width, aq) - -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq) -| STORE( imm, rs, rd, width, rl) - -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width, translate_out_bool rl) +| LOAD( imm, rs, rd, unsigned, width, aq, rl) + -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) +| STORE( imm, rs, rd, width, aq, rl) + -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) | ADDIW( imm, rs, rd) -> `RISCVADDIW(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) | SHIFTW( imm, rs, rd, op) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) | RTYPEW( rs2, rs1, rd, op) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) diff --git a/risc-v/hgen/token_types.hgen b/risc-v/hgen/token_types.hgen index 9b469a27..d338d865 100644 --- a/risc-v/hgen/token_types.hgen +++ b/risc-v/hgen/token_types.hgen @@ -5,8 +5,8 @@ type token_BType = {op : riscvBop } type token_IType = {op : riscvIop } type token_ShiftIop = {op : riscvSop } type token_RTYPE = {op : riscvRop } -type token_Load = {unsigned: bool; width : wordWidth; aq: bool } -type token_Store = {width : wordWidth; rl: bool } +type token_Load = {unsigned: bool; width : wordWidth; aq: bool; rl: bool } +type token_Store = {width : wordWidth; aq: bool; rl: bool } type token_ADDIW = unit type token_SHIFTW = {op : riscvSop } type token_RTYPEW = {op : riscvRopw } diff --git a/risc-v/hgen/trans_sail.hgen b/risc-v/hgen/trans_sail.hgen index 12da62d8..8b7cbe11 100644 --- a/risc-v/hgen/trans_sail.hgen +++ b/risc-v/hgen/trans_sail.hgen @@ -58,7 +58,7 @@ translate_rop "op" op; ], []) -| `RISCVLoad(imm, rs, rd, unsigned, width, aq) -> +| `RISCVLoad(imm, rs, rd, unsigned, width, aq, rl) -> ("LOAD", [ translate_imm12 "imm" imm; @@ -67,15 +67,17 @@ translate_bool "unsigned" unsigned; translate_width "width" width; translate_bool "aq" aq; + translate_bool "rl" rl; ], []) -| `RISCVStore(imm, rs2, rs1, width, rl) -> +| `RISCVStore(imm, rs2, rs1, width, aq, rl) -> ("STORE", [ translate_imm12 "imm" imm; translate_reg "rs2" rs2; translate_reg "rs1" rs1; translate_width "width" width; + translate_bool "aq" aq; translate_bool "rl" rl; ], []) diff --git a/risc-v/hgen/types.hgen b/risc-v/hgen/types.hgen index 83deb4a2..e0caed2d 100644 --- a/risc-v/hgen/types.hgen +++ b/risc-v/hgen/types.hgen @@ -99,7 +99,7 @@ type wordWidth = | RISCVWORD | RISCVDOUBLE -let pp_riscv_load_op (unsigned, width, aq) = +let pp_riscv_load_op (unsigned, width, aq, rl) = begin match (unsigned, width) with | (false, RISCVBYTE) -> "lb" | (true, RISCVBYTE) -> "lbu" @@ -108,17 +108,19 @@ let pp_riscv_load_op (unsigned, width, aq) = | (false, RISCVWORD) -> "lw" | (true, RISCVWORD) -> "lwu" | (_, RISCVDOUBLE) -> "ld" - end - ^ (if aq then ".aq" else "") + end ^ + (if aq then ".aq" else "") ^ + (if rl then ".rl" else "") -let pp_riscv_store_op (width, rl) = +let pp_riscv_store_op (width, aq, rl) = begin match width with | RISCVBYTE -> "sb" | RISCVHALF -> "sh" | RISCVWORD -> "sw" | RISCVDOUBLE -> "sd" - end - ^ (if rl then ".rl" else "") + end ^ + (if aq then ".aq" else "") ^ + (if rl then ".rl" else "") let pp_riscv_load_reserved_op (aq, rl, width) = "lr" ^ diff --git a/risc-v/hgen/types_trans_sail.hgen b/risc-v/hgen/types_trans_sail.hgen index 7528a522..238c7e5b 100644 --- a/risc-v/hgen/types_trans_sail.hgen +++ b/risc-v/hgen/types_trans_sail.hgen @@ -11,30 +11,47 @@ let translate_enum enum_values name value = (name, Range0 (Some size), IInt.bit_list_of_integer size (Nat_big_num.of_int index)) let translate_uop = translate_enum [RISCVLUI; RISCVAUIPC] + let translate_bop = translate_enum [RISCVBEQ; RISCVBNE; RISCVBLT; RISCVBGE; RISCVBLTU; RISCVBGEU] (* branch ops *) + let translate_iop = translate_enum [RISCVADDI; RISCVSLTI; RISCVSLTIU; RISCVXORI; RISCVORI; RISCVANDI] (* immediate ops *) + let translate_sop = translate_enum [RISCVSLLI; RISCVSRLI; RISCVSRAI] (* shift ops *) + let translate_rop = translate_enum [RISCVADD; RISCVSUB; RISCVSLL; RISCVSLT; RISCVSLTU; RISCVXOR; RISCVSRL; RISCVSRA; RISCVOR; RISCVAND] (* reg-reg ops *) + let translate_ropw = translate_enum [RISCVADDW; RISCVSUBW; RISCVSLLW; RISCVSRLW; RISCVSRAW] (* reg-reg 32-bit ops *) + let translate_amoop = translate_enum [RISCVAMOSWAP; RISCVAMOADD; RISCVAMOXOR; RISCVAMOAND; RISCVAMOOR; RISCVAMOMIN; RISCVAMOMAX; RISCVAMOMINU; RISCVAMOMAXU] + let translate_width = translate_enum [RISCVBYTE; RISCVHALF; RISCVWORD; RISCVDOUBLE] + let translate_reg name value = (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int (reg_to_int value))) + let translate_imm21 name value = (name, Bvector (Some 21), bit_list_of_integer 21 (Nat_big_num.of_int value)) + let translate_imm20 name value = (name, Bvector (Some 20), bit_list_of_integer 20 (Nat_big_num.of_int value)) + let translate_imm16 name value = (name, Bvector (Some 16), bit_list_of_integer 16 (Nat_big_num.of_int value)) + let translate_imm13 name value = (name, Bvector (Some 13), bit_list_of_integer 13 (Nat_big_num.of_int value)) + let translate_imm12 name value = (name, Bvector (Some 12), bit_list_of_integer 12 (Nat_big_num.of_int value)) + let translate_imm6 name value = (name, Bvector (Some 6), bit_list_of_integer 6 (Nat_big_num.of_int value)) + let translate_imm5 name value = (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int value)) + let translate_imm4 name value = (name, Bvector (Some 4), bit_list_of_integer 4 (Nat_big_num.of_int value)) + let translate_bool name value = (name, Bit, [if value then Bitc_one else Bitc_zero]) diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index cd0e5bf9..c5b19d26 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -62,38 +62,56 @@ function forall 'a. 'a effect { escape } not_implemented((string) message) = val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_acquire +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_strong_acquire val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved_acquire -function forall Nat 'n. (bit[8 * 'n]) effect { rmem } mem_read( (bit[64]) addr, ([|'n|]) width, (bool) aq, (bool) res) = - switch (aq, res) { - case (false, false) -> MEMr(addr, width) - case (true, false) -> MEMr_acquire(addr, width) - case (false, true) -> MEMr_reserved(addr, width) - case (true, true) -> MEMr_reserved_acquire(addr, width) +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved_strong_acquire +function forall Nat 'n. (bit[8 * 'n]) effect { rmem } mem_read( (bit[64]) addr, ([|'n|]) width, (bool) aq, (bool) rl, (bool) res) = + switch (aq, rl, res) { + case (false, false, false) -> MEMr(addr, width) + case (true, false, false) -> MEMr_acquire(addr, width) + case (false, false, true) -> MEMr_reserved(addr, width) + case (true, false, true) -> MEMr_reserved_acquire(addr, width) + case (false, true, false) -> not_implemented("load.rl is not implemented") + case (true, true, false) -> MEMr_strong_acquire(addr, width) + case (false, true, true) -> not_implemented("lr.rl is not implemented") + case (true, true, true) -> MEMr_reserved_strong_acquire(addr, width) } val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_release +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_strong_release val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_release -function forall Nat 'n. unit effect { eamem } mem_write_ea( (bit[64]) addr , ([|'n|]) width, (bool) rl, (bool) con) = - switch (rl, con) { - case (false, false) -> MEMea(addr, width) - case (true, false) -> MEMea_release(addr, width) - case (false, true) -> MEMea_conditional(addr, width) - case (true , true) -> MEMea_conditional_release(addr, width) +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_strong_release +function forall Nat 'n. unit effect { eamem } mem_write_ea( (bit[64]) addr , ([|'n|]) width, (bool) aq, (bool) rl, (bool) con) = + switch (aq, rl, con) { + case (false, false, false) -> MEMea(addr, width) + case (false, true, false) -> MEMea_release(addr, width) + case (false, false, true) -> MEMea_conditional(addr, width) + case (false, true , true) -> MEMea_conditional_release(addr, width) + case (true, false, false) -> not_implemented("store.aq is not implemented") + case (true, true, false) -> MEMea_strong_release(addr, width) + case (true, false, true) -> not_implemented("sc.aq is not implemented") + case (true, true , true) -> MEMea_conditional_strong_release(addr, width) } val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_release +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_strong_release val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional_release -function forall Nat 'n. unit effect { wmv } mem_write_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) rl, (bool) con) = - switch (rl, con) { - case (false, false) -> MEMval(addr, width, value) - case (true, false) -> MEMval_release(addr, width, value) - case (false, true) -> MEMval_conditional(addr, width, value) - case (true, true) -> MEMval_conditional_release(addr, width, value) +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional_strong_release +function forall Nat 'n. unit effect { wmv } mem_write_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) aq, (bool) rl, (bool) con) = + switch (aq, rl, con) { + case (false, false, false) -> MEMval(addr, width, value) + case (false, true, false) -> MEMval_release(addr, width, value) + case (false, false, true) -> MEMval_conditional(addr, width, value) + case (false, true, true) -> MEMval_conditional_release(addr, width, value) + case (true, false, false) -> not_implemented("store.aq is not implemented") + case (true, true, false) -> MEMval_strong_release(addr, width, value) + case (true, false, true) -> not_implemented("sc.aq is not implemented") + case (true, true, true) -> MEMval_conditional_strong_release(addr, width, value) } val extern unit -> bool effect {exmem} speculate_conditional_success @@ -245,51 +263,51 @@ function clause execute (RTYPE(rs2, rs1, rd, op)) = } in wGPR(rd, result) -union ast member ((bit[12]), regno, regno, bool, word_width, bool) LOAD -function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, BYTE, false)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b001 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, HALF, false)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b010 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, WORD, false)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b011 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, DOUBLE, false)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b100 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, BYTE, false)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b101 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, HALF, false)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b110 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, WORD, false)) -function clause execute(LOAD(imm, rs1, rd, unsigned, width, aq)) = +union ast member ((bit[12]), regno, regno, bool, word_width, bool, bool) LOAD +function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, BYTE, false, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b001 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, HALF, false, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b010 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, WORD, false, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b011 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, DOUBLE, false, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b100 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, BYTE, false, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b101 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, HALF, false, false)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b110 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, WORD, false, false)) +function clause execute(LOAD(imm, rs1, rd, unsigned, width, aq, rl)) = let (bit[64]) addr = rGPR(rs1) + EXTS(imm) in let (bit[64]) result = if unsigned then switch (width) { - case BYTE -> EXTZ(mem_read(addr, 1, aq, false)) - case HALF -> EXTZ(mem_read(addr, 2, aq, false)) - case WORD -> EXTZ(mem_read(addr, 4, aq, false)) - case DOUBLE -> mem_read(addr, 8, aq, false) + case BYTE -> EXTZ(mem_read(addr, 1, aq, rl, false)) + case HALF -> EXTZ(mem_read(addr, 2, aq, rl, false)) + case WORD -> EXTZ(mem_read(addr, 4, aq, rl, false)) + case DOUBLE -> mem_read(addr, 8, aq, rl, false) } else switch (width) { - case BYTE -> EXTS(mem_read(addr, 1, aq, false)) - case HALF -> EXTS(mem_read(addr, 2, aq, false)) - case WORD -> EXTS(mem_read(addr, 4, aq, false)) - case DOUBLE -> mem_read(addr, 8, aq, false) + case BYTE -> EXTS(mem_read(addr, 1, aq, rl, false)) + case HALF -> EXTS(mem_read(addr, 2, aq, rl, false)) + case WORD -> EXTS(mem_read(addr, 4, aq, rl, false)) + case DOUBLE -> mem_read(addr, 8, aq, rl, false) } in wGPR(rd, result) -union ast member ((bit[12]), regno, regno, word_width, bool) STORE -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b000 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, BYTE, false)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b001 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, HALF, false)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b010 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, WORD, false)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b011 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, DOUBLE, false)) -function clause execute (STORE(imm, rs2, rs1, width, rl)) = +union ast member ((bit[12]), regno, regno, word_width, bool, bool) STORE +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b000 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, BYTE, false, false)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b001 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, HALF, false, false)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b010 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, WORD, false, false)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b011 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, DOUBLE, false, false)) +function clause execute (STORE(imm, rs2, rs1, width, aq, rl)) = let (bit[64]) addr = rGPR(rs1) + EXTS(imm) in { switch (width) { - case BYTE -> mem_write_ea(addr, 1, rl, false) - case HALF -> mem_write_ea(addr, 2, rl, false) - case WORD -> mem_write_ea(addr, 4, rl, false) - case DOUBLE -> mem_write_ea(addr, 8, rl, false) + case BYTE -> mem_write_ea(addr, 1, aq, rl, false) + case HALF -> mem_write_ea(addr, 2, aq, rl, false) + case WORD -> mem_write_ea(addr, 4, aq, rl, false) + case DOUBLE -> mem_write_ea(addr, 8, aq, rl, false) }; let rs2_val = rGPR(rs2) in switch (width) { - case BYTE -> mem_write_value(addr, 1, rs2_val[7..0], rl, false) - case HALF -> mem_write_value(addr, 2, rs2_val[15..0], rl, false) - case WORD -> mem_write_value(addr, 4, rs2_val[31..0], rl, false) - case DOUBLE -> mem_write_value(addr, 8, rs2_val, rl, false) + case BYTE -> mem_write_value(addr, 1, rs2_val[7..0], aq, rl, false) + case HALF -> mem_write_value(addr, 2, rs2_val[15..0], aq, rl, false) + case WORD -> mem_write_value(addr, 4, rs2_val[31..0], aq, rl, false) + case DOUBLE -> mem_write_value(addr, 8, rs2_val, aq, rl, false) } } @@ -360,36 +378,31 @@ union ast member (bool, bool, regno, word_width, regno) LOADRES function clause decode (0b00010 : [aq] : [rl] : 0b00000 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(LOADRES(aq, rl, rs1, WORD, rd)) function clause decode (0b00010 : [aq] : [rl] : 0b00000 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(LOADRES(aq, rl, rs1, DOUBLE, rd)) function clause execute(LOADRES(aq, rl, rs1, width, rd)) = - if rl then not_implemented("load-reserved-release is not implemented") - else { - let (bit[64]) addr = rGPR(rs1) in - let (bit[64]) result = - switch width { - case WORD -> EXTS(mem_read(addr, 4, aq, true)) - case DOUBLE -> mem_read(addr, 8, aq, true) - } in - wGPR(rd, result) - } + let (bit[64]) addr = rGPR(rs1) in + let (bit[64]) result = + switch width { + case WORD -> EXTS(mem_read(addr, 4, aq, rl, true)) + case DOUBLE -> mem_read(addr, 8, aq, rl, true) + } in + wGPR(rd, result) union ast member (bool, bool, regno, regno, word_width, regno) STORECON function clause decode (0b00011 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(STORECON(aq, rl, rs2, rs1, WORD, rd)) function clause decode (0b00011 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(STORECON(aq, rl, rs2, rs1, DOUBLE, rd)) function clause execute (STORECON(aq, rl, rs2, rs1, width, rd)) = { - if aq then not_implemented("store-conditional-acquire is not implemented"); - (*(bit)*) status := if speculate_conditional_success() then 0 else 1; wGPR(rd) := (bit[64]) (EXTZ([status])); if status == 1 then () else { (bit[64]) addr := rGPR(rs1); switch width { - case WORD -> mem_write_ea(addr, 4, rl, true) - case DOUBLE -> mem_write_ea(addr, 8, rl, true) + case WORD -> mem_write_ea(addr, 4, aq, rl, true) + case DOUBLE -> mem_write_ea(addr, 8, aq, rl, true) }; rs2_val := rGPR(rs2); switch width { - case WORD -> mem_write_value(addr, 4, rs2_val[31..0], rl, true) - case DOUBLE -> mem_write_value(addr, 8, rs2_val, rl, true) + case WORD -> mem_write_value(addr, 4, rs2_val[31..0], aq, rl, true) + case DOUBLE -> mem_write_value(addr, 8, rs2_val, aq, rl, true) }; }; } @@ -418,14 +431,14 @@ function clause execute (AMO(op, aq, rl, rs2, rs1, width, rd)) = { (bit[64]) addr := rGPR(rs1); switch (width) { - case WORD -> mem_write_ea(addr, 4, rl, true) - case DOUBLE -> mem_write_ea(addr, 8, rl, true) + case WORD -> mem_write_ea(addr, 4, aq, rl, true) + case DOUBLE -> mem_write_ea(addr, 8, aq, rl, true) }; (bit[64]) loaded := switch (width) { - case WORD -> EXTS(mem_read(addr, 4, aq, true)) - case DOUBLE -> mem_read(addr, 8, aq, true) + case WORD -> EXTS(mem_read(addr, 4, aq, rl, true)) + case DOUBLE -> mem_read(addr, 8, aq, rl, true) }; wGPR(rd, loaded); @@ -445,8 +458,8 @@ function clause execute (AMO(op, aq, rl, rs2, rs1, width, rd)) = { }; switch (width) { - case WORD -> mem_write_value(addr, 4, result[31..0], rl, true) - case DOUBLE -> mem_write_value(addr, 8, result, rl, true) + case WORD -> mem_write_value(addr, 4, result[31..0], aq, rl, true) + case DOUBLE -> mem_write_value(addr, 8, result, aq, rl, true) }; } diff --git a/risc-v/riscv_extras.lem b/risc-v/riscv_extras.lem index 62a7bb91..280095e5 100644 --- a/risc-v/riscv_extras.lem +++ b/risc-v/riscv_extras.lem @@ -34,8 +34,11 @@ let memory_parameter_transformer_option_address _mode v = let read_memory_functions : memory_reads = [ ("MEMr", (MR Read_plain memory_parameter_transformer)); ("MEMr_acquire", (MR Read_RISCV_acquire memory_parameter_transformer)); + ("MEMr_strong_acquire", (MR Read_RISCV_strong_acquire memory_parameter_transformer)); ("MEMr_reserved", (MR Read_RISCV_reserved memory_parameter_transformer)); ("MEMr_reserved_acquire", (MR Read_RISCV_reserved_acquire memory_parameter_transformer)); + ("MEMr_reserved_strong_acquire", + (MR Read_RISCV_reserved_acquire memory_parameter_transformer)); ] let memory_writes : memory_writes = @@ -44,25 +47,23 @@ let memory_writes : memory_writes = let memory_eas : memory_write_eas = [ ("MEMea", (MEA Write_plain memory_parameter_transformer)); ("MEMea_release", (MEA Write_RISCV_release memory_parameter_transformer)); + ("MEMea_strong_release", (MEA Write_RISCV_strong_release memory_parameter_transformer)); ("MEMea_conditional", (MEA Write_RISCV_conditional memory_parameter_transformer)); ("MEMea_conditional_release", (MEA Write_RISCV_conditional_release memory_parameter_transformer)); + ("MEMea_conditional_strong_release", + (MEA Write_RISCV_conditional_strong_release + memory_parameter_transformer)); ] let memory_vals : memory_write_vals = - [ ("MEMval", (MV memory_parameter_transformer_option_address Nothing)); - ("MEMval_release", (MV memory_parameter_transformer_option_address Nothing)); - ("MEMval_conditional", (MV memory_parameter_transformer_option_address Nothing)); - (* (MV memory_parameter_transformer_option_address - (Just - (fun (IState interp context) b -> - let bit = Interp_ast.V_lit (L_aux (if b then L_one else L_zero) Interp_ast.Unknown) in - (IState (Interp.add_answer_to_stack interp bit) context))))); *) - ("MEMval_conditional_release", (MV memory_parameter_transformer_option_address Nothing)); - (* (MV memory_parameter_transformer_option_address - (Just - (fun (IState interp context) b -> - let bit = Interp_ast.V_lit (L_aux (if b then L_one else L_zero) Interp_ast.Unknown) in - (IState (Interp.add_answer_to_stack interp bit) context))))); *) + [ ("MEMval", (MV memory_parameter_transformer_option_address Nothing)); + ("MEMval_release", (MV memory_parameter_transformer_option_address Nothing)); + ("MEMval_strong_release", (MV memory_parameter_transformer_option_address Nothing)); + ("MEMval_conditional", (MV memory_parameter_transformer_option_address Nothing)); + ("MEMval_conditional_release",(MV memory_parameter_transformer_option_address Nothing)); + ("MEMval_conditional_strong_release", + (MV memory_parameter_transformer_option_address Nothing)); + ] let speculate_conditional_success : excl_res = diff --git a/risc-v/riscv_extras_embed.lem b/risc-v/riscv_extras_embed.lem index 3f04f9a2..d89dc44c 100644 --- a/risc-v/riscv_extras_embed.lem +++ b/risc-v/riscv_extras_embed.lem @@ -6,33 +6,48 @@ open import Prompt val MEMr : (vector bitU * integer) -> M (vector bitU) val MEMr_acquire : (vector bitU * integer) -> M (vector bitU) +val MEMr_strong_acquire : (vector bitU * integer) -> M (vector bitU) val MEMr_reserved : (vector bitU * integer) -> M (vector bitU) val MEMr_reserved_acquire : (vector bitU * integer) -> M (vector bitU) +val MEMr_reserved_strong_acquire : (vector bitU * integer) -> M (vector bitU) let MEMr (addr,size) = read_mem false Read_plain addr size let MEMr_acquire (addr,size) = read_mem false Read_RISCV_acquire addr size +let MEMr_strong_acquire (addr,size) = read_mem false Read_RISCV_strong_acquire addr size let MEMr_reserved (addr,size) = read_mem false Read_RISCV_reserved addr size let MEMr_reserved_acquire (addr,size) = read_mem false Read_RISCV_reserved_acquire addr size +let MEMr_reserved_strong_acquire (addr,size) + = read_mem false Read_RISCV_reserved_strong_acquire addr size val MEMea : (vector bitU * integer) -> M unit val MEMea_release : (vector bitU * integer) -> M unit +val MEMea_strong_release : (vector bitU * integer) -> M unit val MEMea_conditional : (vector bitU * integer) -> M unit val MEMea_conditional_release : (vector bitU * integer) -> M unit +val MEMea_conditional_strong_release : (vector bitU * integer) -> M unit let MEMea (addr,size) = write_mem_ea Write_plain addr size let MEMea_release (addr,size) = write_mem_ea Write_RISCV_release addr size +let MEMea_strong_release (addr,size) = write_mem_ea Write_RISCV_strong_release addr size let MEMea_conditional (addr,size) = write_mem_ea Write_RISCV_conditional addr size let MEMea_conditional_release (addr,size) = write_mem_ea Write_RISCV_conditional_release addr size +let MEMea_conditional_strong_release (addr,size) + = write_mem_ea Write_RISCV_conditional_strong_release addr size val MEMval : (vector bitU * integer * vector bitU) -> M unit val MEMval_release : (vector bitU * integer * vector bitU) -> M unit +val MEMval_strong_release : (vector bitU * integer * vector bitU) -> M unit val MEMval_conditional : (vector bitU * integer * vector bitU) -> M unit val MEMval_conditional_release : (vector bitU * integer * vector bitU) -> M unit +val MEMval_conditional_strong_release : (vector bitU * integer * vector bitU) -> M unit let MEMval (_,_,v) = write_mem_val v >>= fun _ -> return () let MEMval_release (_,_,v) = write_mem_val v >>= fun _ -> return () -let MEMval_conditional (_,_,v) = write_mem_val v >>= fun _ -> return () (* (if b then B1 else B0) *) -let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun _ -> return () (* (if b then B1 else B0) *) +let MEMval_strong_release (_,_,v) = write_mem_val v >>= fun _ -> return () +let MEMval_conditional (_,_,v) = write_mem_val v >>= fun _ -> return () +let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun _ -> return () +let MEMval_conditional_strong_release (_,_,v) + = write_mem_val v >>= fun _ -> return () let speculate_conditional_success () = excl_result () >>= fun b -> return (if b then B1 else B0) diff --git a/risc-v/riscv_extras_embed_sequential.lem b/risc-v/riscv_extras_embed_sequential.lem index dabd4d12..1f2a0e47 100644 --- a/risc-v/riscv_extras_embed_sequential.lem +++ b/risc-v/riscv_extras_embed_sequential.lem @@ -6,33 +6,48 @@ open import State val MEMr : (vector bitU * integer) -> M (vector bitU) val MEMr_acquire : (vector bitU * integer) -> M (vector bitU) +val MEMr_strong_acquire : (vector bitU * integer) -> M (vector bitU) val MEMr_reserved : (vector bitU * integer) -> M (vector bitU) val MEMr_reserved_acquire : (vector bitU * integer) -> M (vector bitU) +val MEMr_reserved_strong_acquire : (vector bitU * integer) -> M (vector bitU) let MEMr (addr,size) = read_mem false Read_plain addr size let MEMr_acquire (addr,size) = read_mem false Read_RISCV_acquire addr size +let MEMr_strong_acquire (addr,size) = read_mem false Read_RISCV_strong_acquire addr size let MEMr_reserved (addr,size) = read_mem false Read_RISCV_reserved addr size let MEMr_reserved_acquire (addr,size) = read_mem false Read_RISCV_reserved_acquire addr size +let MEMr_reserved_strong_acquire (addr,size) + = read_mem false Read_RISCV_reserved_strong_acquire addr size val MEMea : (vector bitU * integer) -> M unit val MEMea_release : (vector bitU * integer) -> M unit +val MEMea_strong_release : (vector bitU * integer) -> M unit val MEMea_conditional : (vector bitU * integer) -> M unit val MEMea_conditional_release : (vector bitU * integer) -> M unit +val MEMea_conditional_strong_release : (vector bitU * integer) -> M unit let MEMea (addr,size) = write_mem_ea Write_plain addr size let MEMea_release (addr,size) = write_mem_ea Write_RISCV_release addr size +let MEMea_strong_release (addr,size) = write_mem_ea Write_RISCV_strong_release addr size let MEMea_conditional (addr,size) = write_mem_ea Write_RISCV_conditional addr size let MEMea_conditional_release (addr,size) = write_mem_ea Write_RISCV_conditional_release addr size +let MEMea_conditional_strong_release (addr,size) + = write_mem_ea Write_RISCV_conditional_strong_release addr size val MEMval : (vector bitU * integer * vector bitU) -> M unit val MEMval_release : (vector bitU * integer * vector bitU) -> M unit +val MEMval_strong_release : (vector bitU * integer * vector bitU) -> M unit val MEMval_conditional : (vector bitU * integer * vector bitU) -> M unit val MEMval_conditional_release : (vector bitU * integer * vector bitU) -> M unit +val MEMval_conditional_strong_release : (vector bitU * integer * vector bitU) -> M unit let MEMval (_,_,v) = write_mem_val v >>= fun _ -> return () let MEMval_release (_,_,v) = write_mem_val v >>= fun _ -> return () -let MEMval_conditional (_,_,v) = write_mem_val v >>= fun _ -> return () (* (if b then B1 else B0) *) -let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun _ -> return () (* (if b then B1 else B0) *) +let MEMval_strong_release (_,_,v) = write_mem_val v >>= fun _ -> return () +let MEMval_conditional (_,_,v) = write_mem_val v >>= fun _ -> return () +let MEMval_conditional_release (_,_,v) = write_mem_val v >>= fun _ -> return () +let MEMval_conditional_strong_release (_,_,v) + = write_mem_val v >>= fun _ -> return () let speculate_conditional_success () = excl_result () >>= fun b -> return (if b then B1 else B0) diff --git a/risc-v/riscv_regfp.sail b/risc-v/riscv_regfp.sail index e6813c37..602f0bec 100644 --- a/risc-v/riscv_regfp.sail +++ b/risc-v/riscv_regfp.sail @@ -51,17 +51,29 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; } - case (LOAD ( imm, rs, rd, unsign, width, aq)) -> { (* XXX "unsigned" causes name conflict in lem shallow embedding... *) + case (LOAD ( imm, rs, rd, unsign, width, aq, rl)) -> { (* XXX "unsigned" causes name conflict in lem shallow embedding... *) if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; aR := iR; - ik := if aq then IK_mem_read (Read_RISCV_acquire) else IK_mem_read (Read_plain); + ik := + switch (aq, rl) { + case (false, false) -> IK_mem_read (Read_plain) + case (true, false) -> IK_mem_read (Read_RISCV_acquire) + case (false, true) -> exit "not implemented" + case (true, true) -> IK_mem_read (Read_RISCV_strong_acquire) + }; } - case (STORE( imm, rs2, rs1, width, rl)) -> { + case (STORE( imm, rs2, rs1, width, aq, rl)) -> { if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; if (rs1 == 0) then () else aR := RFull(GPRstr[rs1]) :: aR; - ik := if rl then IK_mem_write (Write_RISCV_release) else IK_mem_write (Write_plain); + ik := + switch (aq, rl) { + case (false, false) -> IK_mem_write (Write_plain) + case (true, false) -> exit "not implemented" + case (false, true) -> IK_mem_write (Write_RISCV_release) + case (true, true) -> IK_mem_write (Write_RISCV_strong_release) + }; } case (ADDIW ( imm, rs, rd)) -> { if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; @@ -96,7 +108,8 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( ik := switch (aq, rl) { case (false, false) -> IK_mem_read (Read_RISCV_reserved) case (true, false) -> IK_mem_read (Read_RISCV_reserved_acquire) - case (_, true) -> exit "not implemented" + case (false, true) -> exit "not implemented" + case (true, true) -> IK_mem_read (Read_RISCV_reserved_strong_acquire) }; } case (STORECON( aq, rl, rs2, rs1, width, rd)) -> { @@ -118,10 +131,12 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; ik := switch (aq, rl) { - case (false, false) -> IK_mem_rmw (Read_RISCV_reserved, Write_RISCV_conditional) - case (false, true) -> IK_mem_rmw (Read_RISCV_reserved, Write_RISCV_conditional_release) - case (true, false) -> IK_mem_rmw (Read_RISCV_reserved_acquire, Write_RISCV_conditional) - case (true, true) -> IK_mem_rmw (Read_RISCV_reserved_acquire, Write_RISCV_conditional_release) + case (false, false) -> IK_mem_rmw (Read_RISCV_reserved, Write_RISCV_conditional) + case (false, true) -> IK_mem_rmw (Read_RISCV_reserved, Write_RISCV_conditional_release) + case (true, false) -> IK_mem_rmw (Read_RISCV_reserved_acquire, + Write_RISCV_conditional) + case (true, true) -> IK_mem_rmw (Read_RISCV_reserved_strong_acquire, + Write_RISCV_conditional_strong_release) }; } }; diff --git a/src/gen_lib/sail_values.lem b/src/gen_lib/sail_values.lem index 49f37381..121f6cc8 100644 --- a/src/gen_lib/sail_values.lem +++ b/src/gen_lib/sail_values.lem @@ -956,3 +956,6 @@ let diafp_to_dia reginfo = function | DIAFP_concrete v -> DIA_concrete_address (address_of_bitv v) | DIAFP_reg r -> DIA_register (regfp_to_reg reginfo r) end + +let max = uncurry max +let min = uncurry min diff --git a/src/gen_lib/state.lem b/src/gen_lib/state.lem index 2ea1247e..ac5cb869 100644 --- a/src/gen_lib/state.lem +++ b/src/gen_lib/state.lem @@ -55,8 +55,10 @@ let is_exclusive = function | Sail_impl_base.Read_exclusive_acquire -> true | Sail_impl_base.Read_stream -> false | Sail_impl_base.Read_RISCV_acquire -> false + | Sail_impl_base.Read_RISCV_strong_acquire -> false | Sail_impl_base.Read_RISCV_reserved -> true | Sail_impl_base.Read_RISCV_reserved_acquire -> true + | Sail_impl_base.Read_RISCV_reserved_strong_acquire -> true end diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index c577c44b..48ddd10e 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -436,7 +436,9 @@ type read_kind = (* AArch64 reads *) | Read_acquire | Read_exclusive | Read_exclusive_acquire | Read_stream (* RISC-V reads *) - | Read_RISCV_acquire | Read_RISCV_reserved | Read_RISCV_reserved_acquire + | Read_RISCV_acquire | Read_RISCV_strong_acquire + | Read_RISCV_reserved | Read_RISCV_reserved_acquire + | Read_RISCV_reserved_strong_acquire instance (Show read_kind) let show = function @@ -447,8 +449,10 @@ instance (Show read_kind) | Read_exclusive_acquire -> "Read_exclusive_acquire" | Read_stream -> "Read_stream" | Read_RISCV_acquire -> "Read_RISCV_acquire" + | Read_RISCV_strong_acquire -> "Read_RISCV_strong_acquire" | Read_RISCV_reserved -> "Read_RISCV_reserved" | Read_RISCV_reserved_acquire -> "Read_RISCV_reserved_acquire" + | Read_RISCV_reserved_strong_acquire -> "Read_RISCV_reserved_strong_acquire" end end @@ -460,7 +464,9 @@ type write_kind = (* AArch64 writes *) | Write_release | Write_exclusive | Write_exclusive_release (* RISC-V *) - | Write_RISCV_release | Write_RISCV_conditional | Write_RISCV_conditional_release + | Write_RISCV_release | Write_RISCV_strong_release + | Write_RISCV_conditional | Write_RISCV_conditional_release + | Write_RISCV_conditional_strong_release instance (Show write_kind) let show = function @@ -470,8 +476,10 @@ instance (Show write_kind) | Write_exclusive -> "Write_exclusive" | Write_exclusive_release -> "Write_exclusive_release" | Write_RISCV_release -> "Write_RISCV_release" + | Write_RISCV_strong_release -> "Write_RISCV_strong_release" | Write_RISCV_conditional -> "Write_RISCV_conditional" | Write_RISCV_conditional_release -> "Write_RISCV_conditional_release" + | Write_RISCV_conditional_strong_release -> "Write_RISCV_conditional_strong_release" end end @@ -566,8 +574,10 @@ instance (EnumerationType read_kind) | Read_exclusive_acquire -> 4 | Read_stream -> 5 | Read_RISCV_acquire -> 6 - | Read_RISCV_reserved -> 7 - | Read_RISCV_reserved_acquire -> 8 + | Read_RISCV_strong_acquire -> 7 + | Read_RISCV_reserved -> 8 + | Read_RISCV_reserved_acquire -> 9 + | Read_RISCV_reserved_strong_acquire -> 10 end end @@ -579,8 +589,10 @@ instance (EnumerationType write_kind) | Write_exclusive -> 3 | Write_exclusive_release -> 4 | Write_RISCV_release -> 5 - | Write_RISCV_conditional -> 6 - | Write_RISCV_conditional_release -> 7 + | Write_RISCV_strong_release -> 6 + | Write_RISCV_conditional -> 7 + | Write_RISCV_conditional_release -> 8 + | Write_RISCV_conditional_strong_release -> 9 end end -- cgit v1.2.3 From 5207f6f2c53c9661bb4087a65f46fe6c5a74a776 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Wed, 6 Sep 2017 16:46:14 +0100 Subject: power is builtin in old tc so use it. --- x86/x64.sail | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/x86/x64.sail b/x86/x64.sail index 902a861e..2d17cf86 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -401,10 +401,7 @@ function unit erase_eflags () = ZF := undefined; } -(* XXXXX *) -function nat power ((nat) x, ([|64|]) y) = undefined - -function nat value_width ((wsize) sz) = power (2, size_width(sz)) +function nat value_width ((wsize) sz) = 2 ** size_width(sz) function bit word_signed_overflow_add ((wsize) sz, (qword) a, (qword) b) = (bit) (word_size_msb (sz, a) == word_size_msb (sz, b) & -- cgit v1.2.3 From c5b352f9fb87c1d42d93df4cb39cce7a0f8e0ff0 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Thu, 7 Sep 2017 11:59:27 +0100 Subject: add MFENCE --- x86/x64.sail | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/x86/x64.sail b/x86/x64.sail index 2d17cf86..2f75f540 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -108,6 +108,7 @@ val extern forall Nat 'n. (qword, [|'n|]) -> (bit[8 * 'n]) effect { rmem } rMEM val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval +val extern unit -> unit effect { barr } X86_MFENCE function forall Nat 'n. unit effect {eamem, wmv} wMEM ((qword) addr, ([|'n|]) len, (bit[8 * 'n]) data) = { MEMea(addr, len); @@ -582,7 +583,7 @@ function unit drop ((qword) i) = if i[7 ..0] != 0 then () else RSP := RSP + i scattered function unit execute scattered typedef ast = const union -val ast -> unit effect {escape, rmem, rreg, undef, eamem, wmv, wreg} execute +val ast -> unit effect {escape, rmem, rreg, undef, eamem, wmv, wreg, barr} execute (* ========================================================================== Binop @@ -716,6 +717,15 @@ function clause execute (LOOP (c,i)) = if RCX != 0 & read_cond (c) then RIP := RIP + i else (); } +(* ========================================================================== + MFENCE + ========================================================================== *) + +union ast member unit MFENCE + +function clause execute (MFENCE) = + X86_MFENCE () + (* ========================================================================== Monop ========================================================================== *) -- cgit v1.2.3 From 53f13aeb3ff1289d92211aec6181cf178df82993 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Mon, 11 Sep 2017 10:36:55 +0100 Subject: added xml pp --- risc-v/hgen/pretty_xml.hgen | 137 ++++++++++++++++++++++++++++++++++++++++++++ risc-v/hgen/types.hgen | 53 +++++++---------- 2 files changed, 159 insertions(+), 31 deletions(-) create mode 100644 risc-v/hgen/pretty_xml.hgen diff --git a/risc-v/hgen/pretty_xml.hgen b/risc-v/hgen/pretty_xml.hgen new file mode 100644 index 00000000..b0306161 --- /dev/null +++ b/risc-v/hgen/pretty_xml.hgen @@ -0,0 +1,137 @@ +| `RISCVThreadStart -> ("op_thread_start", []) + +| `RISCVStopFetching -> ("op_stop_fetching", []) + +| `RISCVUTYPE(imm, rd, op) -> + ("op_U_type", + [ ("op", pp_riscv_uop op); + ("uimm", sprintf "%d" imm); + ("dest", pp_reg rd); + ]) + +| `RISCVJAL(imm, rd) -> + ("op_jal", + [ ("offset", sprintf "%d" imm); + ("dest", pp_reg rd); + ]) + +| `RISCVJALR(imm, rs1, rd) -> + ("op_jalr", + [ ("offset", sprintf "%d" imm); + ("base", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVBType(imm, rs2, rs1, op) -> + ("op_branch", + [ ("op", pp_riscv_bop op); + ("offset", sprintf "%d" imm); + ("src2", pp_reg rs2); + ("src1", pp_reg rs1); + ]) + +| `RISCVIType(imm, rs1, rd, op) -> + ("op_I_type", + [ ("op", pp_riscv_iop op); + ("iimm", sprintf "%d" imm); + ("src", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVShiftIop(imm, rs1, rd, op) -> + ("op_IS_type", + [ ("op", pp_riscv_sop op); + ("shamt", sprintf "%d" imm); + ("src", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVSHIFTW(imm, rs1, rd, op) -> + ("op_ISW_type", + [ ("op", pp_riscv_sop op); + ("shamt", sprintf "%d" imm); + ("src", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVRType (rs2, rs1, rd, op) -> + ("op_R_type", + [ ("op", pp_riscv_rop op); + ("src2", pp_reg rs2); + ("src1", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVLoad(imm, rs1, rd, unsigned, width, aq, rl) -> + ("op_load", + [ ("aq", if aq then "true" else "false"); + ("rl", if rl then "true" else "false"); + ("width", pp_word_width width); + ("unsigned", if unsigned then "true" else "false"); + ("base", pp_reg rs1); + ("offset", sprintf "%d" imm); + ("dest", pp_reg rd); + ]) + +| `RISCVStore(imm, rs2, rs1, width, aq, rl) -> + ("op_store", + [ ("aq", if aq then "true" else "false"); + ("rl", if rl then "true" else "false"); + ("width", pp_word_width width); + ("src", pp_reg rs2); + ("base", pp_reg rs1); + ("offset", sprintf "%d" imm); + ]) + +| `RISCVADDIW(imm, rs1, rd) -> + ("op_addiw", + [ ("iimm", sprintf "%d" imm); + ("src", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVRTYPEW(rs2, rs1, rd, op) -> + ("op_RW_type", + [ ("op", pp_riscv_ropw op); + ("src2", pp_reg rs2); + ("src1", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVFENCE(pred, succ) -> + ("op_fence", + [ ("pred", pp_riscv_fence_option pred); + ("succ", pp_riscv_fence_option succ); + ]) + +| `RISCVFENCEI -> ("op_fence_i", []) + +| `RISCVLoadRes(aq, rl, rs1, width, rd) -> + ("op_lr", + [ ("aq", if aq then "true" else "false"); + ("rl", if rl then "true" else "false"); + ("width", pp_word_width width); + ("addr", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> + ("op_sc", + [ ("aq", if aq then "true" else "false"); + ("rl", if rl then "true" else "false"); + ("width", pp_word_width width); + ("addr", pp_reg rs1); + ("src", pp_reg rs2); + ("dest", pp_reg rd); + ]) + +| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) -> + ("op_amo", + [ ("op", pp_riscv_amo_op_part op); + ("aq", if aq then "true" else "false"); + ("rl", if rl then "true" else "false"); + ("width", pp_word_width width); + ("src", pp_reg rs2); + ("addr", pp_reg rs1); + ("dest", pp_reg rd); + ]) diff --git a/risc-v/hgen/types.hgen b/risc-v/hgen/types.hgen index e0caed2d..a0b75606 100644 --- a/risc-v/hgen/types.hgen +++ b/risc-v/hgen/types.hgen @@ -99,46 +99,36 @@ type wordWidth = | RISCVWORD | RISCVDOUBLE +let pp_word_width width : string = + begin match width with + | RISCVBYTE -> "b" + | RISCVHALF -> "h" + | RISCVWORD -> "w" + | RISCVDOUBLE -> "d" + end + let pp_riscv_load_op (unsigned, width, aq, rl) = - begin match (unsigned, width) with - | (false, RISCVBYTE) -> "lb" - | (true, RISCVBYTE) -> "lbu" - | (false, RISCVHALF) -> "lh" - | (true, RISCVHALF) -> "lhu" - | (false, RISCVWORD) -> "lw" - | (true, RISCVWORD) -> "lwu" - | (_, RISCVDOUBLE) -> "ld" - end ^ + "l" ^ + (pp_word_width width) ^ + (if unsigned then "u" else "") ^ (if aq then ".aq" else "") ^ (if rl then ".rl" else "") let pp_riscv_store_op (width, aq, rl) = - begin match width with - | RISCVBYTE -> "sb" - | RISCVHALF -> "sh" - | RISCVWORD -> "sw" - | RISCVDOUBLE -> "sd" - end ^ + "s" ^ + (pp_word_width width) ^ (if aq then ".aq" else "") ^ (if rl then ".rl" else "") let pp_riscv_load_reserved_op (aq, rl, width) = - "lr" ^ - begin match width with - | RISCVWORD -> ".w" - | RISCVDOUBLE -> ".d" - | _ -> assert false - end ^ + "lr." ^ + (pp_word_width width) ^ (if aq then ".aq" else "") ^ (if rl then ".rl" else "") let pp_riscv_store_conditional_op (aq, rl, width) = - "sc" ^ - begin match width with - | RISCVWORD -> ".w" - | RISCVDOUBLE -> ".d" - | _ -> assert false - end ^ + "sc." ^ + (pp_word_width width) ^ (if aq then ".aq" else "") ^ (if rl then ".rl" else "") @@ -153,9 +143,7 @@ type riscvAmoop = | RISCVAMOMINU | RISCVAMOMAXU -let pp_riscv_amo_op (op, aq, rl, width) = - "amo" ^ - begin match op with +let pp_riscv_amo_op_part = function | RISCVAMOSWAP -> "swap" | RISCVAMOADD -> "add" | RISCVAMOXOR -> "xor" @@ -165,7 +153,10 @@ let pp_riscv_amo_op (op, aq, rl, width) = | RISCVAMOMAX -> "max" | RISCVAMOMINU -> "minu" | RISCVAMOMAXU -> "maxu" - end ^ + +let pp_riscv_amo_op (op, aq, rl, width) = + "amo" ^ + pp_riscv_amo_op_part op ^ begin match width with | RISCVWORD -> ".w" | RISCVDOUBLE -> ".d" -- cgit v1.2.3 From 8c143d2aaebaa210e4d4778a0bcfd5326908bdf8 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Wed, 13 Sep 2017 15:33:47 +0100 Subject: add HLT instruction for RMEM integration. --- x86/x64.sail | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/x86/x64.sail b/x86/x64.sail index 2f75f540..9630a873 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -665,6 +665,15 @@ function clause execute (DIV (sz,r)) = erase_eflags(); } +(* ========================================================================== + HLT -- halt instruction used to end test in RMEM + ========================================================================== *) + +union ast member unit HLT + +function clause execute (HLT) = () + + (* ========================================================================== Jcc ========================================================================== *) -- cgit v1.2.3 From a97cd6081df6a76c9daa34c773d82f21f5d014c8 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 15 Sep 2017 11:50:54 +0100 Subject: reinstate deep/shallow conversion --- src/gen_lib/deep_shallow_convert.lem | 116 ++++++++++++--------- src/lem_interp/sail_impl_base.lem | 2 + src/pretty_print.mli | 2 +- src/pretty_print_lem.ml | 191 +++++++++++++++++------------------ src/process_file.ml | 13 ++- 5 files changed, 176 insertions(+), 148 deletions(-) diff --git a/src/gen_lib/deep_shallow_convert.lem b/src/gen_lib/deep_shallow_convert.lem index 23c34222..4af6eb2f 100644 --- a/src/gen_lib/deep_shallow_convert.lem +++ b/src/gen_lib/deep_shallow_convert.lem @@ -6,20 +6,20 @@ open import Sail_values class (ToFromInterpValue 'a) - val toInterpValue : 'a -> Interp.value - val fromInterpValue : Interp.value -> 'a + val toInterpValue : 'a -> Interp_ast.value + val fromInterpValue : Interp_ast.value -> 'a end let toInterValueBool = function - | true -> Interp.V_lit (L_aux (L_one) Unknown) - | false -> Interp.V_lit (L_aux (L_zero) Unknown) + | true -> Interp_ast.V_lit (L_aux (L_one) Unknown) + | false -> Interp_ast.V_lit (L_aux (L_zero) Unknown) end let rec fromInterpValueBool v = match v with - | Interp.V_lit (L_aux (L_true) _) -> true - | Interp.V_lit (L_aux (L_false) _) -> false - | Interp.V_lit (L_aux (L_one) _) -> true - | Interp.V_lit (L_aux (L_zero) _) -> false - | Interp.V_tuple [v] -> fromInterpValueBool v + | Interp_ast.V_lit (L_aux (L_true) _) -> true + | Interp_ast.V_lit (L_aux (L_false) _) -> false + | Interp_ast.V_lit (L_aux (L_one) _) -> true + | Interp_ast.V_lit (L_aux (L_zero) _) -> false + | Interp_ast.V_tuple [v] -> fromInterpValueBool v | v -> failwith ("fromInterpValue bool: unexpected value. " ^ Interp.debug_print_value v) end @@ -29,10 +29,10 @@ instance (ToFromInterpValue bool) end -let toInterpValueUnit () = Interp.V_lit (L_aux (L_unit) Unknown) +let toInterpValueUnit () = Interp_ast.V_lit (L_aux (L_unit) Unknown) let rec fromInterpValueUnit v = match v with - | Interp.V_lit (L_aux (L_unit) _) -> () - | Interp.V_tuple [v] -> fromInterpValueUnit v + | Interp_ast.V_lit (L_aux (L_unit) _) -> () + | Interp_ast.V_tuple [v] -> fromInterpValueUnit v | v -> failwith ("fromInterpValue unit: unexpected value. " ^ Interp.debug_print_value v) end @@ -44,8 +44,8 @@ end let toInterpValueInteger i = V_lit (L_aux (L_num i) Unknown) let rec fromInterpValueInteger v = match v with - | Interp.V_lit (L_aux (L_num i) _) -> i - | Interp.V_tuple [v] -> fromInterpValueInteger v + | Interp_ast.V_lit (L_aux (L_num i) _) -> i + | Interp_ast.V_tuple [v] -> fromInterpValueInteger v | v -> failwith ("fromInterpValue integer: unexpected value. " ^ Interp.debug_print_value v) end @@ -57,8 +57,8 @@ end let toInterpValueString s = V_lit (L_aux (L_string s) Unknown) let rec fromInterpValueString v = match v with - | Interp.V_lit (L_aux (L_string s) _) -> s - | Interp.V_tuple [v] -> fromInterpValueString v + | Interp_ast.V_lit (L_aux (L_string s) _) -> s + | Interp_ast.V_tuple [v] -> fromInterpValueString v | v -> failwith ("fromInterpValue integer: unexpected value. " ^ Interp.debug_print_value v) end @@ -69,17 +69,17 @@ end let toInterpValueBitU = function - | I -> Interp.V_lit (L_aux (L_one) Unknown) - | O -> Interp.V_lit (L_aux (L_zero) Unknown) - | Undef -> Interp.V_lit (L_aux (L_undef) Unknown) + | I -> Interp_ast.V_lit (L_aux (L_one) Unknown) + | O -> Interp_ast.V_lit (L_aux (L_zero) Unknown) + | Undef -> Interp_ast.V_lit (L_aux (L_undef) Unknown) end let rec fromInterpValueBitU v = match v with - | Interp.V_lit (L_aux (L_one) _) -> I - | Interp.V_lit (L_aux (L_zero) _) -> O - | Interp.V_lit (L_aux (L_undef) _) -> Undef - | Interp.V_lit (L_aux (L_true) _) -> I - | Interp.V_lit (L_aux (L_false) _) -> O - | Interp.V_tuple [v] -> fromInterpValueBitU v + | Interp_ast.V_lit (L_aux (L_one) _) -> B1 + | Interp_ast.V_lit (L_aux (L_zero) _) -> B0 + | Interp_ast.V_lit (L_aux (L_undef) _) -> BU + | Interp_ast.V_lit (L_aux (L_true) _) -> B1 + | Interp_ast.V_lit (L_aux (L_false) _) -> B0 + | Interp_ast.V_tuple [v] -> fromInterpValueBitU v | v -> failwith ("fromInterpValue bitU: unexpected value. " ^ Interp.debug_print_value v) end @@ -383,29 +383,31 @@ instance forall 'a. ToFromInterpValue 'a => (ToFromInterpValue (maybe 'a)) end -module SI = Interp -module SIA = Interp_ast - - let read_kindToInterpValue = function | Read_plain -> V_ctor (Id_aux (Id "Read_plain") Unknown) (T_id "read_kind") (C_Enum 0) (toInterpValue ()) - | Read_tag -> V_ctor (Id_aux (Id "Read_tag") Unknown) (T_id "read_kind") (C_Enum 1) (toInterpValue ()) - | Read_tag_reserve -> V_ctor (Id_aux (Id "Read_tag_reserve") Unknown) (T_id "read_kind") (C_Enum 1) (toInterpValue ()) | Read_reserve -> V_ctor (Id_aux (Id "Read_reserve") Unknown) (T_id "read_kind") (C_Enum 2) (toInterpValue ()) | Read_acquire -> V_ctor (Id_aux (Id "Read_acquire") Unknown) (T_id "read_kind") (C_Enum 3) (toInterpValue ()) | Read_exclusive -> V_ctor (Id_aux (Id "Read_exclusive") Unknown) (T_id "read_kind") (C_Enum 4) (toInterpValue ()) | Read_exclusive_acquire -> V_ctor (Id_aux (Id "Read_exclusive_acquire") Unknown) (T_id "read_kind") (C_Enum 5) (toInterpValue ()) | Read_stream -> V_ctor (Id_aux (Id "Read_stream") Unknown) (T_id "read_kind") (C_Enum 6) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_acquire") Unknown) (T_id "read_kind") (C_Enum 7) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 8) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved") Unknown) (T_id "read_kind") (C_Enum 9) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) end let rec read_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Read_plain") _) _ _ v -> Read_plain - | V_ctor (Id_aux (Id "Read_tag") _) _ _ v -> Read_tag - | V_ctor (Id_aux (Id "Read_tag_reserve") _) _ _ v -> Read_tag_reserve | V_ctor (Id_aux (Id "Read_reserve") _) _ _ v -> Read_reserve | V_ctor (Id_aux (Id "Read_acquire") _) _ _ v -> Read_acquire | V_ctor (Id_aux (Id "Read_exclusive") _) _ _ v -> Read_exclusive | V_ctor (Id_aux (Id "Read_exclusive_acquire") _) _ _ v -> Read_exclusive_acquire | V_ctor (Id_aux (Id "Read_stream") _) _ _ v -> Read_stream + | V_ctor (Id_aux (Id "Read_RISCV_acquire") _) _ _ v -> Read_RISCV_acquire + | V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") _) _ _ v -> Read_RISCV_strong_acquire + | V_ctor (Id_aux (Id "Read_RISCV_reserved") _) _ _ v -> Read_RISCV_reserved + | V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") _) _ _ v -> Read_RISCV_reserved_acquire + | V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") _) _ _ v -> Read_RISCV_reserved_strong_acquire | V_tuple [v] -> read_kindFromInterpValue v | v -> failwith ("fromInterpValue read_kind: unexpected value. " ^ Interp.debug_print_value v) @@ -418,21 +420,27 @@ end let write_kindToInterpValue = function | Write_plain -> V_ctor (Id_aux (Id "Write_plain") Unknown) (T_id "write_kind") (C_Enum 0) (toInterpValue ()) - | Write_tag -> V_ctor (Id_aux (Id "Write_tag") Unknown) (T_id "write_kind") (C_Enum 1) (toInterpValue ()) - | Write_tag_conditional -> V_ctor (Id_aux (Id "Write_tag_conditional") Unknown) (T_id "write_kind") (C_Enum 1) (toInterpValue ()) | Write_conditional -> V_ctor (Id_aux (Id "Write_conditional") Unknown) (T_id "write_kind") (C_Enum 2) (toInterpValue ()) | Write_release -> V_ctor (Id_aux (Id "Write_release") Unknown) (T_id "write_kind") (C_Enum 3) (toInterpValue ()) | Write_exclusive -> V_ctor (Id_aux (Id "Write_exclusive") Unknown) (T_id "write_kind") (C_Enum 4) (toInterpValue ()) | Write_exclusive_release -> V_ctor (Id_aux (Id "Write_exclusive_release") Unknown) (T_id "write_kind") (C_Enum 5) (toInterpValue ()) + | Write_RISCV_release -> V_ctor (Id_aux (Id "Write_RISCV_release") Unknown) (T_id "write_kind") (C_Enum 6) (toInterpValue ()) + | Write_RISCV_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_strong_release") Unknown) (T_id "write_kind") (C_Enum 7) (toInterpValue ()) + | Write_RISCV_conditional -> V_ctor (Id_aux (Id "Write_RISCV_conditional") Unknown) (T_id "write_kind") (C_Enum 8) (toInterpValue ()) + | Write_RISCV_conditional_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_release") Unknown) (T_id "write_kind") (C_Enum 9) (toInterpValue ()) + | Write_RISCV_conditional_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_strong_release") Unknown) (T_id "write_kind") (C_Enum 10) (toInterpValue ()) end let rec write_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Write_plain") _) _ _ v -> Write_plain - | V_ctor (Id_aux (Id "Write_tag") _) _ _ v -> Write_tag - | V_ctor (Id_aux (Id "Write_tag_conditional") _) _ _ v -> Write_tag_conditional | V_ctor (Id_aux (Id "Write_conditional") _) _ _ v -> Write_conditional | V_ctor (Id_aux (Id "Write_release") _) _ _ v -> Write_release | V_ctor (Id_aux (Id "Write_exclusive") _) _ _ v -> Write_exclusive | V_ctor (Id_aux (Id "Write_exclusive_release") _) _ _ v -> Write_exclusive_release + | V_ctor (Id_aux (Id "Write_RISCV_release") _) _ _ v -> Write_RISCV_release + | V_ctor (Id_aux (Id "Write_RISCV_strong_release") _) _ _ v -> Write_RISCV_strong_release + | V_ctor (Id_aux (Id "Write_RISCV_conditional") _) _ _ v -> Write_RISCV_conditional + | V_ctor (Id_aux (Id "Write_RISCV_conditional_release") _) _ _ v -> Write_RISCV_conditional_release + | V_ctor (Id_aux (Id "Write_RISCV_conditional_strong_release") _) _ _ v -> Write_RISCV_conditional_strong_release | V_tuple [v] -> write_kindFromInterpValue v | v -> failwith ("fromInterpValue write_kind: unexpected value " ^ Interp.debug_print_value v) @@ -455,7 +463,14 @@ let barrier_kindToInterpValue = function | Barrier_DSB_ST -> V_ctor (Id_aux (Id "Barrier_DSB_ST") Unknown) (T_id "barrier_kind") (C_Enum 8) (toInterpValue ()) | Barrier_DSB_LD -> V_ctor (Id_aux (Id "Barrier_DSB_LD") Unknown) (T_id "barrier_kind") (C_Enum 9) (toInterpValue ()) | Barrier_ISB -> V_ctor (Id_aux (Id "Barrier_ISB") Unknown) (T_id "barrier_kind") (C_Enum 10) (toInterpValue ()) - | Barrier_MIPS_SYNC -> V_ctor (Id_aux (Id "Barrier_MIPS_SYNC") Unknown) (T_id "barrier_kind") (C_Enum 11) (toInterpValue ()) + | Barrier_TM_COMMIT -> V_ctor (Id_aux (Id "Barrier_TM_COMMIT") Unknown) (T_id "barrier_kind") (C_Enum 11) (toInterpValue ()) + | Barrier_MIPS_SYNC -> V_ctor (Id_aux (Id "Barrier_MIPS_SYNC") Unknown) (T_id "barrier_kind") (C_Enum 12) (toInterpValue ()) + | Barrier_RISCV_rw_rw -> V_ctor (Id_aux (Id "Barrier_RISCV_rw_rw") Unknown) (T_id "barrier_kind") (C_Enum 13) (toInterpValue ()) + | Barrier_RISCV_r_rw -> V_ctor (Id_aux (Id "Barrier_RISCV_r_rw") Unknown) (T_id "barrier_kind") (C_Enum 14) (toInterpValue ()) + | Barrier_RISCV_rw_w -> V_ctor (Id_aux (Id "Barrier_RISCV_rw_w") Unknown) (T_id "barrier_kind") (C_Enum 15) (toInterpValue ()) + | Barrier_RISCV_w_w -> V_ctor (Id_aux (Id "Barrier_RISCV_w_w") Unknown) (T_id "barrier_kind") (C_Enum 16) (toInterpValue ()) + | Barrier_RISCV_i -> V_ctor (Id_aux (Id "Barrier_RISCV_i") Unknown) (T_id "barrier_kind") (C_Enum 17) (toInterpValue ()) + | Barrier_x86_MFENCE -> V_ctor (Id_aux (Id "Barrier_x86_MFENCE") Unknown) (T_id "barrier_kind") (C_Enum 18) (toInterpValue ()) end let rec barrier_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Barrier_Sync") _) _ _ v -> Barrier_Sync @@ -469,7 +484,14 @@ let rec barrier_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Barrier_DSB_ST") _) _ _ v -> Barrier_DSB_ST | V_ctor (Id_aux (Id "Barrier_DSB_LD") _) _ _ v -> Barrier_DSB_LD | V_ctor (Id_aux (Id "Barrier_ISB") _) _ _ v -> Barrier_ISB + | V_ctor (Id_aux (Id "Barrier_TM_COMMIT") _) _ _ v -> Barrier_TM_COMMIT | V_ctor (Id_aux (Id "Barrier_MIPS_SYNC") _) _ _ v -> Barrier_MIPS_SYNC + | V_ctor (Id_aux (Id "Barrier_RISCV_rw_rw") _) _ _ v -> Barrier_RISCV_rw_rw + | V_ctor (Id_aux (Id "Barrier_RISCV_r_rw") _) _ _ v -> Barrier_RISCV_r_rw + | V_ctor (Id_aux (Id "Barrier_RISCV_rw_w") _) _ _ v -> Barrier_RISCV_rw_w + | V_ctor (Id_aux (Id "Barrier_RISCV_w_w") _) _ _ v -> Barrier_RISCV_w_w + | V_ctor (Id_aux (Id "Barrier_RISCV_i") _) _ _ v -> Barrier_RISCV_i + | V_ctor (Id_aux (Id "Barrier_x86_MFENCE") _) _ _ v -> Barrier_x86_MFENCE | V_tuple [v] -> barrier_kindFromInterpValue v | v -> failwith ("fromInterpValue barrier_kind: unexpected value. " ^ Interp.debug_print_value v) @@ -503,18 +525,18 @@ instance (ToFromInterpValue instruction_kind) end let regfpToInterpValue = function - | RFull v -> SI.V_ctor (SIA.Id_aux (SIA.Id "RFull") SIA.Unknown) (SIA.T_id "regfp") SI.C_Union (toInterpValue v) - | RSlice v -> SI.V_ctor (SIA.Id_aux (SIA.Id "RSlice") SIA.Unknown) (SIA.T_id "regfp") SI.C_Union (toInterpValue v) - | RSliceBit v -> SI.V_ctor (SIA.Id_aux (SIA.Id "RSliceBit") SIA.Unknown) (SIA.T_id "regfp") SI.C_Union (toInterpValue v) - | RField v -> SI.V_ctor (SIA.Id_aux (SIA.Id "RField") SIA.Unknown) (SIA.T_id "regfp") SI.C_Union (toInterpValue v) + | RFull v -> Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RFull") Interp_ast.Unknown) (Interp_ast.T_id "regfp") Interp_ast.C_Union (toInterpValue v) + | RSlice v -> Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RSlice") Interp_ast.Unknown) (Interp_ast.T_id "regfp") Interp_ast.C_Union (toInterpValue v) + | RSliceBit v -> Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RSliceBit") Interp_ast.Unknown) (Interp_ast.T_id "regfp") Interp_ast.C_Union (toInterpValue v) + | RField v -> Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RField") Interp_ast.Unknown) (Interp_ast.T_id "regfp") Interp_ast.C_Union (toInterpValue v) end let rec regfpFromInterpValue v = match v with - | SI.V_ctor (SIA.Id_aux (SIA.Id "RFull") _) _ _ v -> RFull (fromInterpValue v) - | SI.V_ctor (SIA.Id_aux (SIA.Id "RSlice") _) _ _ v -> RSlice (fromInterpValue v) - | SI.V_ctor (SIA.Id_aux (SIA.Id "RSliceBit") _) _ _ v -> RSliceBit (fromInterpValue v) - | SI.V_ctor (SIA.Id_aux (SIA.Id "RField") _) _ _ v -> RField (fromInterpValue v) - | SI.V_tuple [v] -> regfpFromInterpValue v + | Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RFull") _) _ _ v -> RFull (fromInterpValue v) + | Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RSlice") _) _ _ v -> RSlice (fromInterpValue v) + | Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RSliceBit") _) _ _ v -> RSliceBit (fromInterpValue v) + | Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RField") _) _ _ v -> RField (fromInterpValue v) + | Interp_ast.V_tuple [v] -> regfpFromInterpValue v | v -> failwith ("fromInterpValue regfp: unexpected value. " ^ Interp.debug_print_value v) end diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 48ddd10e..e6169762 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -428,6 +428,8 @@ end (* Data structures for building up instructions *) +(* careful: changes in the read/write/barrier kinds have to be + reflected in deep_shallow_convert *) type read_kind = (* common reads *) | Read_plain diff --git a/src/pretty_print.mli b/src/pretty_print.mli index 9a002454..034db664 100644 --- a/src/pretty_print.mli +++ b/src/pretty_print.mli @@ -52,7 +52,7 @@ val pat_to_string : tannot pat -> string val pp_lem_defs : Format.formatter -> tannot defs -> unit val pp_defs_ocaml : out_channel -> tannot defs -> string -> string list -> unit -val pp_defs_lem : (out_channel * string list) -> (out_channel * string list) -> (out_channel * string list) -> tannot defs -> string -> unit +val pp_defs_lem : (out_channel * string list) -> (out_channel * string list) -> (out_channel * string list) -> (out_channel * string list) -> tannot defs -> string -> unit val pp_format_annot_ascii : tannot -> string diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 9758b2de..cf8fda59 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -50,7 +50,7 @@ open Pretty_print_common * PPrint-based sail-to-lem pprinter ****************************************************************************) -let print_to_from_interp_value = ref false +let print_to_from_interp_value = ref true let langlebar = string "<|" let ranglebar = string "|>" let anglebars = enclose langlebar ranglebar @@ -805,8 +805,8 @@ let rec doc_range_lem (BF_aux(r,_)) = match r with let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with | TD_abbrev(id,nm,typschm) -> - doc_op equals (concat [string "type"; space; doc_id_lem_type id]) - (doc_typschm_lem regtypes typschm) + (doc_op equals (concat [string "type"; space; doc_id_lem_type id]) + (doc_typschm_lem regtypes typschm),empty) | TD_record(id,nm,typq,fs,_) -> let f_pp (typ,fid) = let fname = if prefix_recordtype @@ -814,19 +814,19 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with else doc_id_lem_type fid in concat [fname;space;colon;space;doc_typ_lem regtypes typ; semi] in let fs_doc = group (separate_map (break 1) f_pp fs) in - doc_op equals + (doc_op equals (concat [string "type"; space; doc_id_lem_type id;]) - (doc_typquant_lem typq (anglebars (space ^^ align fs_doc ^^ space))) + (doc_typquant_lem typq (anglebars (space ^^ align fs_doc ^^ space))),empty) | TD_variant(id,nm,typq,ar,_) -> (match id with - | Id_aux ((Id "read_kind"),_) -> empty - | Id_aux ((Id "write_kind"),_) -> empty - | Id_aux ((Id "barrier_kind"),_) -> empty - | Id_aux ((Id "trans_kind"),_) -> empty - | Id_aux ((Id "instruction_kind"),_) -> empty - | Id_aux ((Id "regfp"),_) -> empty - | Id_aux ((Id "niafp"),_) -> empty - | Id_aux ((Id "diafp"),_) -> empty + | Id_aux ((Id "read_kind"),_) -> (empty,empty) + | Id_aux ((Id "write_kind"),_) -> (empty,empty) + | Id_aux ((Id "barrier_kind"),_) -> (empty,empty) + | Id_aux ((Id "trans_kind"),_) -> (empty,empty) + | Id_aux ((Id "instruction_kind"),_) -> (empty,empty) + | Id_aux ((Id "regfp"),_) -> (empty,empty) + | Id_aux ((Id "niafp"),_) -> (empty,empty) + | Id_aux ((Id "diafp"),_) -> (empty,empty) | _ -> let ar_doc = group (separate_map (break 1) (doc_type_union_lem regtypes) ar) in let typ_pp = @@ -835,9 +835,9 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with (concat [string "type"; space; doc_id_lem_type id;]) (doc_typquant_lem typq ar_doc) in let make_id pat id = - separate space [string "SIA.Id_aux"; - parens (string "SIA.Id " ^^ string_lit (doc_id id)); - if pat then underscore else string "SIA.Unknown"] in + separate space [string "Interp_ast.Id_aux"; + parens (string "Interp_ast.Id " ^^ string_lit (doc_id id)); + if pat then underscore else string "Interp_ast.Unknown"] in let fromInterpValueF = concat [doc_id_lem_type id;string "FromInterpValue"] in let toInterpValueF = concat [doc_id_lem_type id;string "ToInterpValue"] in let fromInterpValuePP = @@ -849,18 +849,18 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with match tu with | Tu_ty_id (ty,cid) -> (separate space) - [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow; doc_id_lem_ctor cid; parens (string "fromInterpValue v")] | Tu_id cid -> (separate space) - [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow; doc_id_lem_ctor cid]) ar) ^/^ - ((separate space) [pipe;string "SI.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ + ((separate space) [pipe;string "Interp_ast.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ let failmessage = (string_lit @@ -879,43 +879,40 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with | Tu_ty_id (ty,cid) -> (separate space) [pipe;doc_id_lem_ctor cid;string "v";arrow; - string "SI.V_ctor"; + string "Interp_ast.V_ctor"; parens (make_id false cid); - parens (string "SIA.T_id " ^^ string_lit (doc_id id)); - string "SI.C_Union"; + parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); + string "Interp_ast.C_Union"; parens (string "toInterpValue v")] | Tu_id cid -> (separate space) [pipe;doc_id_lem_ctor cid;arrow; - string "SI.V_ctor"; + string "Interp_ast.V_ctor"; parens (make_id false cid); - parens (string "SIA.T_id " ^^ string_lit (doc_id id)); - string "SI.C_Union"; + parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); + string "Interp_ast.C_Union"; parens (string "toInterpValue ()")]) ar) ^/^ string "end") in let fromToInterpValuePP = + toInterpValuePP ^^ hardline ^^ hardline ^^ + fromInterpValuePP ^^ hardline ^^ hardline ^^ ((prefix 2 1) (concat [string "instance ";parens (string "ToFromInterpValue " ^^ doc_id_lem_type id)]) (concat [string "let toInterpValue = ";toInterpValueF;hardline; string "let fromInterpValue = ";fromInterpValueF])) ^/^ string "end" in - typ_pp ^^ hardline ^^ hardline ^^ - if !print_to_from_interp_value then - toInterpValuePP ^^ hardline ^^ hardline ^^ - fromInterpValuePP ^^ hardline ^^ hardline ^^ - fromToInterpValuePP ^^ hardline - else empty) + (typ_pp ^^ hardline,fromToInterpValuePP ^^ hardline)) | TD_enum(id,nm,enums,_) -> (match id with - | Id_aux ((Id "read_kind"),_) -> empty - | Id_aux ((Id "write_kind"),_) -> empty - | Id_aux ((Id "barrier_kind"),_) -> empty - | Id_aux ((Id "trans_kind"),_) -> empty - | Id_aux ((Id "instruction_kind"),_) -> empty - | Id_aux ((Id "regfp"),_) -> empty - | Id_aux ((Id "niafp"),_) -> empty - | Id_aux ((Id "diafp"),_) -> empty + | Id_aux ((Id "read_kind"),_) -> (empty,empty) + | Id_aux ((Id "write_kind"),_) -> (empty,empty) + | Id_aux ((Id "barrier_kind"),_) -> (empty,empty) + | Id_aux ((Id "trans_kind"),_) -> (empty,empty) + | Id_aux ((Id "instruction_kind"),_) -> (empty,empty) + | Id_aux ((Id "regfp"),_) -> (empty,empty) + | Id_aux ((Id "niafp"),_) -> (empty,empty) + | Id_aux ((Id "diafp"),_) -> (empty,empty) | _ -> let rec range i j = if i > j then [] else i :: (range (i+1) j) in let nats = range 0 in @@ -926,9 +923,9 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with let fromInterpValueF = concat [doc_id_lem_type id;string "FromInterpValue"] in let toInterpValueF = concat [doc_id_lem_type id;string "ToInterpValue"] in let make_id pat id = - separate space [string "SIA.Id_aux"; - parens (string "SIA.Id " ^^ string_lit (doc_id id)); - if pat then underscore else string "SIA.Unknown"] in + separate space [string "Interp_ast.Id_aux"; + parens (string "Interp_ast.Id " ^^ string_lit (doc_id id)); + if pat then underscore else string "Interp_ast.Unknown"] in let fromInterpValuePP = (prefix 2 1) (separate space [string "let rec";fromInterpValueF;string "v";equals;string "match v with"]) @@ -936,7 +933,7 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with ((separate_map (break 1)) (fun (cid) -> (separate space) - [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow;doc_id_lem_ctor cid] ) enums @@ -944,7 +941,7 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with ( (align ((prefix 3 1) - (separate space [pipe;string ("SI.V_lit (SIA.L_aux (SIA.L_num n) _)");arrow]) + (separate space [pipe;string ("Interp_ast.V_lit (Interp_ast.L_aux (Interp_ast.L_num n) _)");arrow]) (separate space [string "match";parens(string "natFromInteger n");string "with"] ^/^ ( ((separate_map (break 1)) @@ -960,7 +957,7 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with ) ) ^/^ - ((separate space) [pipe;string "SI.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ + ((separate space) [pipe;string "Interp_ast.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ let failmessage = (string_lit @@ -978,25 +975,23 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with (fun (cid,number) -> (separate space) [pipe;doc_id_lem_ctor cid;arrow; - string "SI.V_ctor"; + string "Interp_ast.V_ctor"; parens (make_id false cid); - parens (string "SIA.T_id " ^^ string_lit (doc_id id)); - parens (string ("SI.C_Enum " ^ string_of_int number)); + parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); + parens (string ("Interp_ast.C_Enum " ^ string_of_int number)); parens (string "toInterpValue ()")]) (List.combine enums (nats ((List.length enums) - 1)))) ^/^ string "end") in let fromToInterpValuePP = + toInterpValuePP ^^ hardline ^^ hardline ^^ + fromInterpValuePP ^^ hardline ^^ hardline ^^ ((prefix 2 1) (concat [string "instance ";parens (string "ToFromInterpValue " ^^ doc_id_lem_type id)]) (concat [string "let toInterpValue = ";toInterpValueF;hardline; string "let fromInterpValue = ";fromInterpValueF])) ^/^ string "end" in - typ_pp ^^ hardline ^^ hardline ^^ - if !print_to_from_interp_value - then toInterpValuePP ^^ hardline ^^ hardline ^^ - fromInterpValuePP ^^ hardline ^^ hardline ^^ - fromToInterpValuePP ^^ hardline - else empty) + (typ_pp ^^ hardline, + fromToInterpValuePP ^^ hardline)) | TD_register(id,n1,n2,rs) -> match n1,n2 with | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> @@ -1010,11 +1005,11 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with let dir_b = i1 < i2 in let dir = string (if dir_b then "true" else "false") in let size = if dir_b then i2-i1 +1 else i1-i2 + 1 in - (doc_op equals) + ((doc_op equals) (concat [string "let";space;string "build_";doc_id_lem id;space;string "regname"]) (string "Register" ^^ space ^^ align (separate space [string "regname"; doc_int size; doc_int i1; dir; - break 0 ^^ brackets (align doc_rids)])) + break 0 ^^ brackets (align doc_rids)])),empty) (*^^ hardline ^^ separate_map hardline doc_rfield rs *) @@ -1147,26 +1142,29 @@ let doc_spec_lem regtypes (VS_aux (valspec,annot)) = let rec doc_def_lem regtypes def = match def with - | DEF_spec v_spec -> (doc_spec_lem regtypes v_spec,empty) - | DEF_type t_def -> (group (doc_typdef_lem regtypes t_def) ^/^ hardline,empty) - | DEF_reg_dec dec -> (group (doc_dec_lem dec),empty) + | DEF_spec v_spec -> ((doc_spec_lem regtypes v_spec,empty),empty) + | DEF_type t_def -> + let (typdefs,fromtodefs) = doc_typdef_lem regtypes t_def in + ((group typdefs ^/^ hardline,fromtodefs),empty) + | DEF_reg_dec dec -> ((group (doc_dec_lem dec),empty),empty) - | DEF_default df -> (empty,empty) - | DEF_fundef f_def -> (empty,group (doc_fundef_lem regtypes f_def) ^/^ hardline) - | DEF_val lbind -> (empty,group (doc_let_lem regtypes lbind) ^/^ hardline) + | DEF_default df -> ((empty,empty),empty) + | DEF_fundef f_def -> ((empty,empty),group (doc_fundef_lem regtypes f_def) ^/^ hardline) + | DEF_val lbind -> ((empty,empty),group (doc_let_lem regtypes lbind) ^/^ hardline) | DEF_scattered sdef -> failwith "doc_def_lem: shoulnd't have DEF_scattered at this point" - | DEF_kind _ -> (empty,empty) + | DEF_kind _ -> ((empty,empty),empty) - | DEF_comm (DC_comm s) -> (empty,comment (string s)) + | DEF_comm (DC_comm s) -> ((empty,empty),comment (string s)) | DEF_comm (DC_comm_struct d) -> - let (typdefs,vdefs) = doc_def_lem regtypes d in - (empty,comment (typdefs ^^ hardline ^^ vdefs)) + let ((typdefs,tofromdefs),vdefs) = doc_def_lem regtypes d in + ((empty,empty),comment (typdefs ^^ hardline ^^ tofromdefs ^^ hardline ^^ vdefs)) let doc_defs_lem regtypes (Defs defs) = let (typdefs,valdefs) = List.split (List.map (doc_def_lem regtypes) defs) in - (separate empty typdefs,separate empty valdefs) + let (typdefs,tofromdefs) = List.split typdefs in + (separate empty typdefs,separate empty tofromdefs, separate empty valdefs) let find_regtypes (Defs defs) = List.fold_left @@ -1180,38 +1178,33 @@ let find_regtypes (Defs defs) = let typ_to_t env = Type_check.typ_to_t env false false -let pp_defs_lem (types_file,types_modules) (prompt_file,prompt_modules) (state_file,state_modules) d top_line = +let pp_defs_lem + (types_file,types_modules) + (prompt_file,prompt_modules) + (state_file,state_modules) + (tofrom_file,tofrom_modules) + d top_line = + let pp_aux file modules defs = + (print file) + (concat + [string "(*" ^^ (string top_line) ^^ string "*)";hardline; + (separate_map hardline) + (fun lib -> separate space [string "open import";string lib]) modules;hardline; + defs]); + in + + let regtypes = find_regtypes d in - let (typdefs,valdefs) = doc_defs_lem regtypes d in - (print types_file) - (concat - [string "(*" ^^ (string top_line) ^^ string "*)";hardline; - (separate_map hardline) - (fun lib -> separate space [string "open import";string lib]) types_modules;hardline; - if !print_to_from_interp_value - then - concat - [(separate_map hardline) - (fun lib -> separate space [string " import";string lib]) ["Interp";"Interp_ast"]; - string "open import Deep_shallow_convert"; - hardline; - hardline; - string "module SI = Interp"; hardline; - string "module SIA = Interp_ast"; hardline; - hardline] - else empty; - typdefs]); - (print prompt_file) - (concat - [string "(*" ^^ (string top_line) ^^ string "*)";hardline; - (separate_map hardline) - (fun lib -> separate space [string "open import";string lib]) prompt_modules;hardline; - hardline; - valdefs]); - (print state_file) + let (typdefs,tofromdefs,valdefs) = doc_defs_lem regtypes d in + + pp_aux types_file types_modules typdefs; + pp_aux prompt_file prompt_modules valdefs; + pp_aux state_file state_modules valdefs; + + (print tofrom_file) (concat [string "(*" ^^ (string top_line) ^^ string "*)";hardline; - (separate_map hardline) - (fun lib -> separate space [string "open import";string lib]) state_modules;hardline; - hardline; - valdefs]); + (separate_map hardline) (fun lib -> separate space [string "open import";string lib]) tofrom_modules;hardline; + (separate_map hardline) (fun lib -> separate space [string " import";string lib]) ["Interp";"Interp_ast"];hardline; + string "open import Deep_shallow_convert"; + hardline;tofromdefs]) diff --git a/src/process_file.ml b/src/process_file.ml index 273979cf..39a8bf58 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -172,18 +172,23 @@ let output1 libpath out_arg filename defs = | Lem_out None -> let generated_line = generated_line filename in let types_module = (f' ^ "_embed_types") in + let tofrom_module = (f' ^ "_toFromInterp") in let ((o,_, _) as ext_o) = open_output_with_check_unformatted (f' ^ "_embed_types.lem") in let ((o',_, _) as ext_o') = open_output_with_check_unformatted (f' ^ "_embed.lem") in let ((o'',_, _) as ext_o'') = open_output_with_check_unformatted (f' ^ "_embed_sequential.lem") in + let ((o''',_, _) as ext_o''') = + open_output_with_check_unformatted (f' ^ "_toFromInterp.lem") in (Pretty_print.pp_defs_lem (o,["Pervasives_extra";"Sail_impl_base";"Sail_values"]) (o',["Pervasives_extra";"Sail_impl_base";"Prompt";"Sail_values"; String.capitalize types_module]) (o'',["Pervasives_extra";"Sail_impl_base";"State";"Sail_values"; String.capitalize types_module]) + (o''',["Pervasives_extra";"Sail_impl_base";"Sail_values"; + String.capitalize types_module]) defs generated_line); close_output_with_check ext_o; close_output_with_check ext_o'; @@ -191,22 +196,28 @@ let output1 libpath out_arg filename defs = | Lem_out (Some lib) -> let generated_line = generated_line filename in let types_module = (f' ^ "_embed_types") in + let tofrom_module = (f' ^ "_toFromInterp") in let ((o,_, _) as ext_o) = open_output_with_check_unformatted (f' ^ "_embed_types.lem") in let ((o',_, _) as ext_o') = open_output_with_check_unformatted (f' ^ "_embed.lem") in let ((o'',_, _) as ext_o'') = open_output_with_check_unformatted (f' ^ "_embed_sequential.lem") in + let ((o''',_, _) as ext_o''') = + open_output_with_check_unformatted (f' ^ "_toFromInterp.lem") in (Pretty_print.pp_defs_lem (o,["Pervasives_extra";"Sail_impl_base";"Sail_values"]) (o',["Pervasives_extra";"Sail_impl_base";"Prompt"; "Sail_values";String.capitalize types_module;lib]) (o'',["Pervasives_extra";"Sail_impl_base";"State"; "Sail_values";String.capitalize types_module;lib ^ "_sequential"]) + (o''',["Pervasives_extra";"Sail_impl_base"; + "Sail_values";String.capitalize types_module;lib]) defs generated_line); close_output_with_check ext_o; close_output_with_check ext_o'; - close_output_with_check ext_o'' + close_output_with_check ext_o''; + close_output_with_check ext_o''' | Ocaml_out None -> let ((o,temp_file_name, _) as ext_o) = open_output_with_check_unformatted (f' ^ ".ml") in begin Pretty_print.pp_defs_ocaml o defs (generated_line filename) ["Big_int_Z";"Sail_values"]; -- cgit v1.2.3 From 3a4358d34cca39d61da4a21953be2a55f0a0a89e Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Fri, 15 Sep 2017 18:26:16 +0100 Subject: x86: implement regfp analysis function (no control flow yet) --- etc/regfp.sail | 1 + src/lem_interp/interp_inter_imp.lem | 3 +- x86/x64.sail | 301 +++++++++++++++++++++++++++--------- 3 files changed, 227 insertions(+), 78 deletions(-) diff --git a/etc/regfp.sail b/etc/regfp.sail index f7744e8c..c0792df0 100644 --- a/etc/regfp.sail +++ b/etc/regfp.sail @@ -77,6 +77,7 @@ typedef barrier_kind = enumerate { Barrier_RISCV_rw_w; Barrier_RISCV_w_w; Barrier_RISCV_i; + Barrier_x86_MFENCE; } typedef trans_kind = enumerate { diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 411ad3fc..6ee13d60 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -587,7 +587,8 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis | "Barrier_DSB_ST" -> Barrier_DSB_ST | "Barrier_DSB_LD" -> Barrier_DSB_LD | "Barrier_ISB" -> Barrier_ISB - | "Barrier_MIPS_SYNC" -> Barrier_MIPS_SYNC + | "Barrier_MIPS_SYNC" -> Barrier_MIPS_SYNC + | "Barrier_x86_MFENCE" -> Barrier_x86_MFENCE end) | Interp_ast.V_ctor (Id_aux (Id "IK_mem_read") _) _ _ (Interp_ast.V_ctor (Id_aux (Id r) _) _ _ _) -> diff --git a/x86/x64.sail b/x86/x64.sail index 9630a873..deee01ad 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -321,7 +321,7 @@ function qword call_dest_from_ea ((ea) e) = case (Ea_m(_, a)) -> rMEM(a, 8) } -function qword get_ea_address ((ea) e) = +function qword get_ea_address ((ea) e) = (* XXX rmn30 looks broken *) switch e { case (Ea_i(_, i)) -> 0x0000000000000000 case (Ea_r(_, r)) -> 0x0000000000000000 @@ -494,9 +494,9 @@ function unit write_binop ((wsize) sz, (binop_name) bop, (qword) a, (qword) b, ( case Cmp -> let (w,c,x) = sub_with_borrow (sz, a, b) in write_arith_eflags (sz, w, c, x) case Test -> write_logical_eflags (sz, a & b) - case And -> write_logical_result (sz, a & b, e) + case And -> write_logical_result (sz, a & b, e) (* XXX rmn30 wrong flags? *) case Xor -> write_logical_result (sz, a ^ b, e) - case Or -> write_logical_result (sz, a | b, e) + case Or -> write_logical_result (sz, a | b, e) case Rol -> write_result_erase_eflags (rol (sz, a, b), e) case Ror -> write_result_erase_eflags (ror (sz, a, b), e) case Sar -> write_result_erase_eflags (sar (sz, a, b), e) @@ -528,8 +528,8 @@ function unit write_binop ((wsize) sz, (binop_name) bop, (qword) a, (qword) b, ( function unit write_monop ((wsize) sz, (monop_name) mop, (qword) a, (ea) e) = switch mop { case Not -> wEA(e) := ~(a) - case Dec -> write_arith_result_no_CF_OF (sz, a - 1, e) - case Inc -> write_arith_result_no_CF_OF (sz, a + 1, e) + case Dec -> write_arith_result_no_CF_OF (sz, a - 1, e) + case Inc -> write_arith_result_no_CF_OF (sz, a + 1, e)(* XXX rmn30 should set OF *) case Neg -> { write_arith_result_no_CF_OF (sz, 0 - a, e); CF := undefined; } @@ -636,7 +636,7 @@ function clause execute (CMPXCHG (sz,r,n)) = let val_dst = EA(dst) in let val_acc = EA(src) in { - write_binop (sz, Cmp, val_acc, val_dst, src); + write_binop (sz, Cmp, val_acc, val_dst, src); if val_acc == val_dst then wEA(dst) := EA (src) else @@ -1266,6 +1266,103 @@ function (byte_stream, ast, nat) decode ((byte_stream) strm) = let (vector <0, 16, inc, string >) GPRstr = ["RAX","RCX","RDX","RBX","RSP","RBP","RSI","RDI","R8","R9","R10","R11","R12","R13","R14","R15"] +function (regfps) regfp_base ((base) b) = + switch b { + case NoBase -> [|| ||] + case RipBase -> [|| RFull("RIP") ||] + case (RegBase(b)) -> [|| RFull(GPRstr[b]) ||] + } + +function (regfps) regfp_idx ((option) idx) = + switch idx { + case (None) -> [|| ||] + case (Some(scale, idx)) -> [|| RFull(GPRstr[idx]) ||] + } + +function (bool, regfps, regfps) regfp_rm ((rm) r) = + switch r { + case (Reg(n)) -> + (false, [|| RFull(GPRstr[n]) ||], [|| ||]) + case (Mem(idx, b, d)) -> { + (true, [|| ||], append(regfp_idx(idx), regfp_base(b))) + } + } + +function (instruction_kind, regfps, regfps, regfps) regfp_dest_src ((dest_src) ds) = + switch ds { + case (Rm_i (r_m, i)) -> + let (m,rd,ars) = regfp_rm(r_m) in + (if m then IK_mem_write(Write_plain) else IK_simple, ars, rd, ars) + case (Rm_r (r_m, r)) -> + let (m,rd,ars) = regfp_rm(r_m) in + (if m then IK_mem_write(Write_plain) else IK_simple, RFull(GPRstr[r]) :: ars, rd, ars) + case (R_rm (r, r_m)) -> + let (m,rs,ars) = regfp_rm(r_m) in + (if m then IK_mem_read(Read_plain) else IK_simple, append(rs, ars), [|| RFull(GPRstr[r]) ||], ars) + } + +(* as above but where destination is also a source operand *) +function (instruction_kind, regfps, regfps, regfps) regfp_dest_src_rmw ((dest_src) ds) = + switch ds { + case (Rm_i (r_m, i)) -> + let (m,rds, ars) = regfp_rm(r_m) in + (if m then IK_mem_rmw(Read_plain, Write_plain) else IK_simple, append(rds, ars), rds, ars) + case (Rm_r (r_m, r)) -> + let (m,rds, ars) = regfp_rm(r_m) in + (if m then IK_mem_rmw(Read_plain, Write_plain) else IK_simple, RFull(GPRstr[r]) :: append(rds, ars), rds, ars) + case (R_rm (r, r_m)) -> + let rds = [|| RFull(GPRstr[r]) ||] in + let (m,rs,ars) = regfp_rm(r_m) in + (if m then IK_mem_read(Read_plain) else IK_simple, append(rds, ars), rds, ars) + } + +function (bool, regfps, regfps) regfp_imm_rm ((imm_rm) i_rm) = + switch i_rm { + case (Rm (v)) -> regfp_rm (v) + case (Imm (v)) -> (false, [|| ||], [|| ||]) + } + +let all_flags_but_cf_of = [|| RFull("AF"), RFull("PF"), RFull("SF"), RFull("ZF") ||] +let all_flags = append([|| RFull("CF"), RFull("OF") ||], all_flags_but_cf_of) + +function (regfps) regfp_binop_flags ((binop_name) op) = + switch (op) { + case Add -> all_flags + case Sub -> all_flags + case Cmp -> all_flags + case Test -> all_flags_but_cf_of + case And -> all_flags_but_cf_of + case Xor -> all_flags_but_cf_of + case Or -> all_flags_but_cf_of + case Rol -> all_flags + case Ror -> all_flags + case Sar -> all_flags + case Shl -> all_flags + case Shr -> all_flags + case Adc -> all_flags + case Sbb -> all_flags + } +function (regfps) regfp_cond ((cond) c) = + switch c { + case A -> [|| RFull("CF"), RFull("ZF") ||] + case NB -> [|| RFull("CF") ||] + case B -> [|| RFull("CF") ||] + case NA -> [|| RFull("CF"), RFull("ZF") ||] + case E -> [|| RFull("ZF") ||] + case G -> [|| RFull("ZF"), RFull("SF"), RFull("OF") ||] + case NL -> [|| RFull("SF"), RFull("OF") ||] + case L -> [|| RFull("SF"), RFull("OF") ||] + case NG -> [|| RFull("ZF"), RFull("SF"), RFull("OF") ||] + case NE -> [|| RFull("ZF") ||] + case NO -> [|| RFull("OF") ||] + case NP -> [|| RFull("PF") ||] + case NS -> [|| RFull("SF") ||] + case O -> [|| RFull("OF") ||] + case P -> [|| RFull("PF") ||] + case S -> [|| RFull("SF") ||] + case ALWAYS -> [|| ||] + } + function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis (instr) = { iR := [|| ||]; oR := [|| ||]; @@ -1274,76 +1371,126 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( Nias := [|| NIAFP_successor ||]; Dia := DIAFP_none; x := (qword) RIP; - (*switch instr { - case (EBREAK) -> () - case (UTYPE ( imm, rd, op)) -> { - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - } - case (JAL ( imm, rd)) -> { - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - let (bit[64]) offset = EXTS(imm) in - Nias := [|| NIAFP_concrete_address (PC + offset) ||] - } - case (JALR ( imm, rs, rd)) -> { - if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - let (bit[64]) offset = EXTS(imm) in - Nias := [|| NIAFP_register (RFull(GPRstr[rs])) ||]; (* XXX this should br rs + offset... *) - } - case (BTYPE ( imm, rs2, rs1, op)) -> { - if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; - if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; - ik := IK_cond_branch; - let (bit[64]) offset = EXTS(imm) in - Nias := NIAFP_concrete_address(PC + offset) :: Nias; - } - case (ITYPE ( imm, rs, rd, op)) -> { - if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - } - case (SHIFTIOP ( imm, rs, rd, op)) -> { - if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - } - case (RTYPE ( rs2, rs1, rd, op)) -> { - if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; - if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - } - case (LOAD ( imm, rs, rd, unsign, width, aq)) -> { (* XXX "unsigned" causes name conflict in lem shallow embedding... *) - if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - aR := iR; - ik := if aq then IK_mem_read (Read_RISCV_acquire) else IK_mem_read (Read_plain); - } - case (STORE( imm, rs2, rs1, width)) -> { - if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; - if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; - if (rs1 == 0) then () else aR := RFull(GPRstr[rs1]) :: aR; - ik := IK_mem_write (Write_plain); - } - case (ADDIW ( imm, rs, rd)) -> { - if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - } - case (SHIFTW ( imm, rs, rd, op)) -> { - if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - } - case (RTYPEW ( rs2, rs1, rd, op))-> { - if (rs2 == 0) then () else iR := RFull(GPRstr[rs2]) :: iR; - if (rs1 == 0) then () else iR := RFull(GPRstr[rs1]) :: iR; - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - } - case (FENCE(pred, succ)) -> { - ik := - switch(pred, succ) { - case (0b0011, 0b0011) -> IK_barrier (Barrier_RISCV_rw_rw) - case (0b0010, 0b0011) -> IK_barrier (Barrier_RISCV_r_rw) - case (0b0011, 0b0001) -> IK_barrier (Barrier_RISCV_rw_w) - case _ -> exit "unsupported fence" - }; - } - };*) + switch instr { + case(Binop (binop, sz, ds)) -> { + let flags = regfp_binop_flags (binop) in + let (ik', iRs, oRs, aRs) = regfp_dest_src_rmw(ds) in { + ik := ik'; + iR := append(iRs, iR); + oR := append(flags, append(oRs, oR)); + aR := append(aRs, aR); + } + } + (*case(CALL (imm_rm) ) -> { + + }*) + case(CLC ) -> oR := RFull("CF") :: oR + case(CMC ) -> { + iR := RFull("CF") :: iR; + oR := RFull("CF") :: oR; + } + case(CMPXCHG (sz, r_m, reg) ) -> + let (m, rs, aRs) = regfp_rm (r_m) in { + iK := if m then IK_mem_rmw (Read_plain, Write_plain) else IK_simple; + iR := RFull("RAX") :: RFull(GPRstr[reg]) :: append(rs, aRs); + oR := RFull("RAX") :: append(regfp_binop_flags(Cmp), rs); + aR := aRs; + } + case(DIV (sz, r_m) ) -> + let (m, rs, ars) = regfp_rm (r_m) in { + iK := if m then IK_mem_read (Read_plain) else IK_simple; + iR := RFull("RAX") :: RFull("RDX") :: append(rs, ars); + oR := RFull("RAX") :: RFull("RDX") :: append(oR, all_flags); + aR := ars; + } + case(HLT ) -> () + (*case(Jcc (cond, imm64) ) -> `X86JCC (translate_out_cond cond, translate_out_imm64 imm64) + case(JMP (rm) ) -> `X86JMP (translate_out_rm rm)*) + case(LEA (sz, ds) ) -> + let (_, irs, ors, ars) = regfp_dest_src (ds) in { + iR := irs; + oR := ors; + aR := ars; + } + (*case(LEAVE ) -> `X86LEAVE*) + (*case(LOOP (cond, imm64) ) -> `X86LOOP (translate_out_cond cond, translate_out_imm64 imm64)*) + case(MFENCE ) -> iK := IK_barrier (Barrier_x86_MFENCE) + case(Monop (monop, sz, r_m) ) -> + let (m, rds, ars) = regfp_rm(r_m) in { + iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_simple; + iR := append(rds, ars); + oR := append(all_flags_but_cf_of, rds); (* XXX fix flags *) + aR := ars; + } + case(MOV (c, sz, ds) ) -> + let (ik, irs, ors, ars) = regfp_dest_src (ds) in + let flags = regfp_cond(c) in + { + iK := ik; + iR := append(irs, flags); + oR := ors; + aR := ars; + } + case(MOVSX (sz1, ds, sz2) ) -> + let (ik, irs, ors, ars) = regfp_dest_src (ds) in { + iK := ik; + iR := irs; + oR := ors; + aR := ars; + } + case(MOVZX (sz1, ds, sz2) ) -> + let (ik, irs, ors, ars) = regfp_dest_src (ds) in { + iK := ik; + iR := irs; + oR := ors; + aR := ars; + } + case(MUL (sz, r_m) ) -> + let (m, rs, ars) = regfp_rm (r_m) in { + iK := if m then IK_mem_read (Read_plain) else IK_simple; + iR := RFull("RAX") :: append(rs, ars); + oR := RFull("RAX") :: RFull("RDX") :: append(oR, all_flags); + aR := ars; + } + case(NOP (_) ) -> () + case(POP (r_m) ) -> + let (m, rd, ars) = regfp_rm (r_m) in { + iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); + iR := RFull("RSP") :: ars; + oR := RFull("RSP") :: rd; + aR := RFull("RSP") :: ars; + } + case(PUSH (irm) ) -> + let (m, rs, ars) = regfp_imm_rm (irm) in { + iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); + iR := RFull("RSP") :: append(rs, ars); + oR := RFull("RSP") :: oR; + aR := RFull("RSP") :: ars; + } + (*case(RET (imm64) ) -> `X86RET (translate_out_imm64 imm64)*) + case(SET (c, b, r_m) ) -> + let flags = regfp_cond(c) in + let (m, rs, ars) = regfp_rm(r_m) in { + iK := if m then IK_mem_write(Write_plain) else IK_simple; + iR := append(flags, ars); + oR := rs; + aR := ars; + } + case(STC ) -> oR := [|| RFull("CF") ||] + case(XADD (sz, r_m, reg) ) -> + let (m, rs, ars) = regfp_rm(r_m) in { + iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_simple; + iR := RFull(GPRstr[reg]) :: append(rs, ars); + oR := RFull(GPRstr[reg]) :: append(rs, all_flags); + aR := ars; + } + case(XCHG (sz, r_m, reg) ) -> + let (m, rs, ars) = regfp_rm(r_m) in { + iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_simple; + iR := RFull(GPRstr[reg]) :: append(rs, ars); + oR := RFull(GPRstr[reg]) :: rs; + aR := ars; + } + }; (iR,oR,aR,Nias,Dia,ik) } -- cgit v1.2.3 From 1722a7eeedb68d65c732cc1e5808d9434340fd11 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 18 Sep 2017 15:35:04 +0100 Subject: add regfp for x86 control flow instrucitons. Need more support for memory indirect jumps. --- x86/x64.sail | 48 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 40 insertions(+), 8 deletions(-) diff --git a/x86/x64.sail b/x86/x64.sail index deee01ad..ba9f26a7 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -1381,9 +1381,13 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( aR := append(aRs, aR); } } - (*case(CALL (imm_rm) ) -> { - - }*) + case(CALL (irm) ) -> + let (m, rs, ars) = regfp_imm_rm (irm) in { + iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); + iR := RFull("RIP") :: RFull("RSP") :: rs; + oR := RFull("RSP") :: oR; + (* nias := XXX rmn30 help *) + } case(CLC ) -> oR := RFull("CF") :: oR case(CMC ) -> { iR := RFull("CF") :: iR; @@ -1404,16 +1408,38 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( aR := ars; } case(HLT ) -> () - (*case(Jcc (cond, imm64) ) -> `X86JCC (translate_out_cond cond, translate_out_imm64 imm64) - case(JMP (rm) ) -> `X86JMP (translate_out_rm rm)*) + case(Jcc (c, imm64) ) -> + let flags = regfp_cond(c) in { + iK := IK_cond_branch; + iR := RFull("RIP") :: flags; + Nias := NIAFP_concrete_address(RIP + imm64) :: Nias; + } + case(JMP (r_m) ) -> + let (m, rs, ars) = regfp_rm (r_m) in { + iK := if m then IK_mem_read(Read_plain) else IK_simple; + iR := RFull("RIP")::append(rs, ars); + aR := ars; + (* XXX rmn30 help Nias := *) + } case(LEA (sz, ds) ) -> let (_, irs, ors, ars) = regfp_dest_src (ds) in { iR := irs; oR := ors; aR := ars; } - (*case(LEAVE ) -> `X86LEAVE*) - (*case(LOOP (cond, imm64) ) -> `X86LOOP (translate_out_cond cond, translate_out_imm64 imm64)*) + case(LEAVE ) -> { + iK := IK_mem_read(Read_plain); + iR := RFull("RBP") :: iR; + oR := RFull("RBP") :: RFull("RSP") :: oR; + aR := RFull("RBP") :: aR; + } + case(LOOP (c, imm64) ) -> + let flags = regfp_cond(c) in { + iK := IK_cond_branch; + iR := RFull("RCX") :: flags; + oR := RFull("RCX") :: oR; + Nias := NIAFP_concrete_address(RIP + imm64) :: Nias; + } case(MFENCE ) -> iK := IK_barrier (Barrier_x86_MFENCE) case(Monop (monop, sz, r_m) ) -> let (m, rds, ars) = regfp_rm(r_m) in { @@ -1467,7 +1493,13 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( oR := RFull("RSP") :: oR; aR := RFull("RSP") :: ars; } - (*case(RET (imm64) ) -> `X86RET (translate_out_imm64 imm64)*) + case(RET (imm64) ) -> { + iK := IK_mem_read(Read_plain); + iR := RFull("RSP") :: iR; + oR := RFull("RSP") :: oR; + aR := RFull("RSP") :: aR; + (* Nias := XXX rmn30 help *) + } case(SET (c, b, r_m) ) -> let flags = regfp_cond(c) in let (m, rs, ars) = regfp_rm(r_m) in { -- cgit v1.2.3 From 0ad438b129de243fd573bbf2472858bf853d44c2 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Tue, 19 Sep 2017 15:15:48 +0100 Subject: According to Shaked NIAFP_register can be used to indicate that we don't know the possible destination of an instruction for memory indirect jumps (the register name is not used). --- x86/x64.sail | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/x86/x64.sail b/x86/x64.sail index ba9f26a7..7cce4262 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -1386,7 +1386,12 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); iR := RFull("RIP") :: RFull("RSP") :: rs; oR := RFull("RSP") :: oR; - (* nias := XXX rmn30 help *) + aR := ars; + Nias := switch irm { + (* XXX register name is not important here -- just indicates we don't know the destination yet. *) + case (Rm (v)) -> NIAFP_register(RFull("RAX")) + case (Imm (v)) -> NIAFP_concrete_address(RIP + v) + } :: Nias; } case(CLC ) -> oR := RFull("CF") :: oR case(CMC ) -> { @@ -1419,7 +1424,8 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( iK := if m then IK_mem_read(Read_plain) else IK_simple; iR := RFull("RIP")::append(rs, ars); aR := ars; - (* XXX rmn30 help Nias := *) + (* XXX register name is not important here -- just indicates we don't know the destination yet. *) + Nias := NIAFP_register(RFull("RAX")) :: Nias; } case(LEA (sz, ds) ) -> let (_, irs, ors, ars) = regfp_dest_src (ds) in { @@ -1498,7 +1504,8 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( iR := RFull("RSP") :: iR; oR := RFull("RSP") :: oR; aR := RFull("RSP") :: aR; - (* Nias := XXX rmn30 help *) + (* XXX register name is not important here -- just indicates we don't know the destination yet. *) + Nias := NIAFP_register(RFull("RAX")) :: Nias; } case(SET (c, b, r_m) ) -> let flags = regfp_cond(c) in -- cgit v1.2.3 From c3b5af179dde8d0b2c272eb851ebdb59764468d0 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Tue, 19 Sep 2017 19:45:36 +0300 Subject: fix --- src/gen_lib/deep_shallow_convert.lem | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/gen_lib/deep_shallow_convert.lem b/src/gen_lib/deep_shallow_convert.lem index 4af6eb2f..42a65c49 100644 --- a/src/gen_lib/deep_shallow_convert.lem +++ b/src/gen_lib/deep_shallow_convert.lem @@ -69,9 +69,9 @@ end let toInterpValueBitU = function - | I -> Interp_ast.V_lit (L_aux (L_one) Unknown) - | O -> Interp_ast.V_lit (L_aux (L_zero) Unknown) - | Undef -> Interp_ast.V_lit (L_aux (L_undef) Unknown) + | B1 -> Interp_ast.V_lit (L_aux (L_one) Unknown) + | B0 -> Interp_ast.V_lit (L_aux (L_zero) Unknown) + | BU -> Interp_ast.V_lit (L_aux (L_undef) Unknown) end let rec fromInterpValueBitU v = match v with | Interp_ast.V_lit (L_aux (L_one) _) -> B1 @@ -391,10 +391,10 @@ let read_kindToInterpValue = function | Read_exclusive_acquire -> V_ctor (Id_aux (Id "Read_exclusive_acquire") Unknown) (T_id "read_kind") (C_Enum 5) (toInterpValue ()) | Read_stream -> V_ctor (Id_aux (Id "Read_stream") Unknown) (T_id "read_kind") (C_Enum 6) (toInterpValue ()) | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_acquire") Unknown) (T_id "read_kind") (C_Enum 7) (toInterpValue ()) - | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 8) (toInterpValue ()) - | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved") Unknown) (T_id "read_kind") (C_Enum 9) (toInterpValue ()) - | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) - | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) + | Read_RISCV_strong_acquire -> V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 8) (toInterpValue ()) + | Read_RISCV_reserved -> V_ctor (Id_aux (Id "Read_RISCV_reserved") Unknown) (T_id "read_kind") (C_Enum 9) (toInterpValue ()) + | Read_RISCV_reserved_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) + | Read_RISCV_reserved_strong_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) end let rec read_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Read_plain") _) _ _ v -> Read_plain -- cgit v1.2.3 From a02e52919de565fc3fba82723b48200fbf034ff9 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Wed, 20 Sep 2017 15:38:14 +0100 Subject: add support for x86 lock prefix (also remove unused Read/Write_tag kind in etc/regfp.sail. --- etc/regfp.sail | 4 +- src/lem_interp/sail_impl_base.lem | 6 ++ x86/x64.sail | 210 ++++++++++++++++++++------------------ 3 files changed, 119 insertions(+), 101 deletions(-) diff --git a/etc/regfp.sail b/etc/regfp.sail index c0792df0..15d1a489 100644 --- a/etc/regfp.sail +++ b/etc/regfp.sail @@ -32,7 +32,6 @@ typedef diafp = const union { typedef read_kind = enumerate { Read_plain; - Read_tag; Read_reserve; Read_acquire; Read_exclusive; @@ -43,11 +42,11 @@ typedef read_kind = enumerate { Read_RISCV_reserved; Read_RISCV_reserved_acquire; Read_RISCV_reserved_strong_acquire; + Read_X86_locked; } typedef write_kind = enumerate { Write_plain; - Write_tag; Write_conditional; Write_release; Write_exclusive; @@ -57,6 +56,7 @@ typedef write_kind = enumerate { Write_RISCV_conditional; Write_RISCV_conditional_release; Write_RISCV_conditional_strong_release; + Write_X86_locked; } typedef barrier_kind = enumerate { diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index e6169762..e39c4421 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -441,6 +441,7 @@ type read_kind = | Read_RISCV_acquire | Read_RISCV_strong_acquire | Read_RISCV_reserved | Read_RISCV_reserved_acquire | Read_RISCV_reserved_strong_acquire + | Read_X86_locked instance (Show read_kind) let show = function @@ -455,6 +456,7 @@ instance (Show read_kind) | Read_RISCV_reserved -> "Read_RISCV_reserved" | Read_RISCV_reserved_acquire -> "Read_RISCV_reserved_acquire" | Read_RISCV_reserved_strong_acquire -> "Read_RISCV_reserved_strong_acquire" + | Read_X86_locked -> "Read_X86_locked" end end @@ -469,6 +471,7 @@ type write_kind = | Write_RISCV_release | Write_RISCV_strong_release | Write_RISCV_conditional | Write_RISCV_conditional_release | Write_RISCV_conditional_strong_release + | Write_X86_locked instance (Show write_kind) let show = function @@ -482,6 +485,7 @@ instance (Show write_kind) | Write_RISCV_conditional -> "Write_RISCV_conditional" | Write_RISCV_conditional_release -> "Write_RISCV_conditional_release" | Write_RISCV_conditional_strong_release -> "Write_RISCV_conditional_strong_release" + | Write_X86_locked -> "Write_X86_locked" end end @@ -580,6 +584,7 @@ instance (EnumerationType read_kind) | Read_RISCV_reserved -> 8 | Read_RISCV_reserved_acquire -> 9 | Read_RISCV_reserved_strong_acquire -> 10 + | Read_X86_locked -> 11 end end @@ -595,6 +600,7 @@ instance (EnumerationType write_kind) | Write_RISCV_conditional -> 7 | Write_RISCV_conditional_release -> 8 | Write_RISCV_conditional_strong_release -> 9 + | Write_X86_locked -> 10 end end diff --git a/x86/x64.sail b/x86/x64.sail index 7cce4262..0b0d2230 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -103,15 +103,17 @@ register bit[1] OF -------------------------------------------------------------------------- *) val extern forall Nat 'n. (qword, [|'n|]) -> (bit[8 * 'n]) effect { rmem } rMEM - - +val extern forall Nat 'n. (qword, [|'n|]) -> (bit[8 * 'n]) effect { rmem } rMEM_locked +function forall Nat 'n. (bit[8 * 'n]) effect { rmem } rMEMl ((bool) locked, (qword) addr, ([|'n|]) size) = + if locked then rMEM_locked(addr, size) else rMEM(addr, size) val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_locked val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval val extern unit -> unit effect { barr } X86_MFENCE -function forall Nat 'n. unit effect {eamem, wmv} wMEM ((qword) addr, ([|'n|]) len, (bit[8 * 'n]) data) = { - MEMea(addr, len); +function forall Nat 'n. unit effect {eamem, wmv} wMEM ((bool) locked, (qword) addr, ([|'n|]) len, (bit[8 * 'n]) data) = { + if locked then MEMea_locked(addr, len) else MEMea(addr, len); MEMval(addr, len, data); } @@ -265,7 +267,7 @@ function qword restrict_size ((wsize) sz, (qword) imm) = function regn sub4 ((regn) r) = negative_to_zero (r - 4) -function qword effect { rreg, rmem } EA ((ea) e) = +function qword effect { rreg, rmem } EA ((bool) locked, (ea) e) = switch e { case (Ea_i(sz,i)) -> restrict_size(sz,i) case (Ea_r((Sz8(have_rex)),r)) -> @@ -274,13 +276,13 @@ function qword effect { rreg, rmem } EA ((ea) e) = else (REG[sub4 (r)] >> 8) & 0x00000000000000FF case (Ea_r(sz,r)) -> restrict_size(sz, REG[r]) - case (Ea_m((Sz8(_)),a)) -> EXTZ (rMEM(a, 1)) - case (Ea_m(Sz16,a)) -> EXTZ (rMEM(a, 2)) - case (Ea_m(Sz32,a)) -> EXTZ (rMEM(a, 4)) - case (Ea_m(Sz64,a)) -> rMEM(a, 8) + case (Ea_m((Sz8(_)),a)) -> EXTZ (rMEMl(locked, a, 1)) + case (Ea_m(Sz16,a)) -> EXTZ (rMEMl(locked, a, 2)) + case (Ea_m(Sz32,a)) -> EXTZ (rMEMl(locked, a, 4)) + case (Ea_m(Sz64,a)) -> rMEMl(locked, a, 8) } -function unit effect { wmem, wreg, escape } wEA ((ea) e, (qword) w) = +function unit effect { wmem, wreg, escape } wEA ((bool) locked, (ea) e, (qword) w) = switch e { case (Ea_i(_,_)) -> exit () case (Ea_r((Sz8(have_rex)),r)) -> @@ -304,15 +306,15 @@ function unit effect { wmem, wreg, escape } wEA ((ea) e, (qword) w) = } case (Ea_r(Sz32,r)) -> REG[r] := (qword) (EXTZ (w[31 .. 0])) case (Ea_r(Sz64,r)) -> REG[r] := w - case (Ea_m((Sz8(_)),a)) -> wMEM(a, 1, w[7 .. 0]) - case (Ea_m(Sz16,a)) -> wMEM(a, 2, w[15 .. 0]) - case (Ea_m(Sz32,a)) -> wMEM(a, 4, w[31 .. 0]) - case (Ea_m(Sz64,a)) -> wMEM(a, 8, w) + case (Ea_m((Sz8(_)),a)) -> wMEM(locked, a, 1, w[7 .. 0]) + case (Ea_m(Sz16,a)) -> wMEM(locked, a, 2, w[15 .. 0]) + case (Ea_m(Sz32,a)) -> wMEM(locked, a, 4, w[31 .. 0]) + case (Ea_m(Sz64,a)) -> wMEM(locked, a, 8, w) } -function (ea, qword, qword) read_dest_src_ea ((wsize) sz, (dest_src) ds) = +function (ea, qword, qword) read_dest_src_ea ((bool) locked, (wsize) sz, (dest_src) ds) = let e = ea_dest (sz, ds) in - (e, EA(e), EA(ea_src(sz, ds))) + (e, EA(locked, e), EA(locked, ea_src(sz, ds))) function qword call_dest_from_ea ((ea) e) = switch e { @@ -419,28 +421,28 @@ function (qword, bit, bit) add_with_carry_out ((wsize) sz, (qword) a, (qword) b) function (qword, bit, bit) sub_with_borrow ((wsize) sz, (qword) a, (qword) b) = (a - b, (bit) (a < b), word_signed_overflow_sub (sz, a, b)) -function unit write_arith_result ((wsize) sz, (qword) w, (bit) c, (bit) x, (ea) e) = +function unit write_arith_result ((bool) locked, (wsize) sz, (qword) w, (bit) c, (bit) x, (ea) e) = { write_arith_eflags (sz, w, c, x); - wEA (e) := w; + wEA (locked, e) := w; } -function unit write_arith_result_no_CF_OF ((wsize) sz, (qword) w, (ea) e) = +function unit write_arith_result_no_CF_OF ((bool) locked, (wsize) sz, (qword) w, (ea) e) = { write_arith_eflags_except_CF_OF (sz, w); - wEA (e) := w; + wEA (locked, e) := w; } -function unit write_logical_result ((wsize) sz, (qword) w, (ea) e) = +function unit write_logical_result ((bool) locked, (wsize) sz, (qword) w, (ea) e) = { write_arith_eflags_except_CF_OF (sz, w); - wEA (e) := w; + wEA (locked, e) := w; } -function unit write_result_erase_eflags ((qword) w, (ea) e) = +function unit write_result_erase_eflags ((bool) locked, (qword) w, (ea) e) = { erase_eflags (); - wEA (e) := w; + wEA (locked, e) := w; } function qword effect { escape } sign_extension ((qword) w, (wsize) size1, (wsize) size2) = @@ -485,23 +487,23 @@ function qword sar ((wsize) sz, (qword) a, (qword) b) = case Sz64 -> ASR64 (a, b[5 .. 0]) } -function unit write_binop ((wsize) sz, (binop_name) bop, (qword) a, (qword) b, (ea) e) = +function unit write_binop ((bool) locked, (wsize) sz, (binop_name) bop, (qword) a, (qword) b, (ea) e) = switch bop { case Add -> let (w,c,x) = add_with_carry_out (sz, a, b) in - write_arith_result (sz, w, c, x, e) + write_arith_result (locked, sz, w, c, x, e) case Sub -> let (w,c,x) = sub_with_borrow (sz, a, b) in - write_arith_result (sz, w, c, x, e) + write_arith_result (locked, sz, w, c, x, e) case Cmp -> let (w,c,x) = sub_with_borrow (sz, a, b) in write_arith_eflags (sz, w, c, x) case Test -> write_logical_eflags (sz, a & b) - case And -> write_logical_result (sz, a & b, e) (* XXX rmn30 wrong flags? *) - case Xor -> write_logical_result (sz, a ^ b, e) - case Or -> write_logical_result (sz, a | b, e) - case Rol -> write_result_erase_eflags (rol (sz, a, b), e) - case Ror -> write_result_erase_eflags (ror (sz, a, b), e) - case Sar -> write_result_erase_eflags (sar (sz, a, b), e) - case Shl -> write_result_erase_eflags (a << mask_shift (sz, b), e) - case Shr -> write_result_erase_eflags (a >> mask_shift (sz, b), e) + case And -> write_logical_result (locked, sz, a & b, e) (* XXX rmn30 wrong flags? *) + case Xor -> write_logical_result (locked, sz, a ^ b, e) + case Or -> write_logical_result (locked, sz, a | b, e) + case Rol -> write_result_erase_eflags (locked, rol (sz, a, b), e) + case Ror -> write_result_erase_eflags (locked, ror (sz, a, b), e) + case Sar -> write_result_erase_eflags (locked, sar (sz, a, b), e) + case Shl -> write_result_erase_eflags (locked, a << mask_shift (sz, b), e) + case Shr -> write_result_erase_eflags (locked, a >> mask_shift (sz, b), e) case Adc -> { let carry = (bit) CF in @@ -509,7 +511,7 @@ function unit write_binop ((wsize) sz, (binop_name) bop, (qword) a, (qword) b, ( { CF := (bit) ((int) (value_width (sz)) <= unsigned(a) + unsigned(b)); OF := undefined; - write_arith_result_no_CF_OF (sz, result, e); + write_arith_result_no_CF_OF (locked, sz, result, e); } } case Sbb -> @@ -519,18 +521,18 @@ function unit write_binop ((wsize) sz, (binop_name) bop, (qword) a, (qword) b, ( { CF := (bit) (unsigned(a) < unsigned(b) + (int) carry); OF := undefined; - write_arith_result_no_CF_OF (sz, result, e); + write_arith_result_no_CF_OF (locked, sz, result, e); } } case _ -> exit () } -function unit write_monop ((wsize) sz, (monop_name) mop, (qword) a, (ea) e) = +function unit write_monop ((bool) locked, (wsize) sz, (monop_name) mop, (qword) a, (ea) e) = switch mop { - case Not -> wEA(e) := ~(a) - case Dec -> write_arith_result_no_CF_OF (sz, a - 1, e) - case Inc -> write_arith_result_no_CF_OF (sz, a + 1, e)(* XXX rmn30 should set OF *) - case Neg -> { write_arith_result_no_CF_OF (sz, 0 - a, e); + case Not -> wEA(locked, e) := ~(a) + case Dec -> write_arith_result_no_CF_OF (locked, sz, a - 1, e) + case Inc -> write_arith_result_no_CF_OF (locked, sz, a + 1, e)(* XXX rmn30 should set OF *) + case Neg -> { write_arith_result_no_CF_OF (locked, sz, 0 - a, e); CF := undefined; } } @@ -566,12 +568,12 @@ function qword pop_aux () = function unit push_aux ((qword) w) = { RSP := RSP - 8; - wMEM(RSP, 8) := w; + wMEM(false, RSP, 8) := w; } -function unit pop ((rm) r) = wEA (ea_rm (Sz64,r)) := pop_aux() +function unit pop ((rm) r) = wEA (false, ea_rm (Sz64,r)) := pop_aux() function unit pop_rip () = RIP := pop_aux() -function unit push ((imm_rm) i) = push_aux (EA (ea_imm_rm (i))) +function unit push ((imm_rm) i) = push_aux (EA (false, ea_imm_rm (i))) function unit push_rip () = push_aux (RIP) function unit drop ((qword) i) = if i[7 ..0] != 0 then () else RSP := RSP + i @@ -589,11 +591,11 @@ val ast -> unit effect {escape, rmem, rreg, undef, eamem, wmv, wreg, barr} execu Binop ========================================================================== *) -union ast member (binop_name,wsize,dest_src) Binop +union ast member (bool,binop_name,wsize,dest_src) Binop -function clause execute (Binop (bop,sz,ds)) = - let (e, val_dst, val_src) = read_dest_src_ea (sz, ds) in - write_binop (sz, bop, val_dst, val_src, e) +function clause execute (Binop (locked,bop,sz,ds)) = + let (e, val_dst, val_src) = read_dest_src_ea (locked, sz, ds) in + write_binop (locked, sz, bop, val_dst, val_src, e) (* ========================================================================== CALL @@ -627,20 +629,20 @@ function clause execute CMC = CF := ~(CF) CMPXCHG ========================================================================== *) -union ast member (wsize,rm,regn) CMPXCHG +union ast member (bool, wsize,rm,regn) CMPXCHG -function clause execute (CMPXCHG (sz,r,n)) = +function clause execute (CMPXCHG (locked, sz,r,n)) = let src = Ea_r(sz, n) in let acc = Ea_r(sz, 0) in (* RAX *) let dst = ea_rm(sz, r) in - let val_dst = EA(dst) in - let val_acc = EA(src) in + let val_dst = EA(locked, dst) in + let val_acc = EA(false, acc) in { - write_binop (sz, Cmp, val_acc, val_dst, src); + write_binop (locked, sz, Cmp, val_acc, val_dst, src); if val_acc == val_dst then - wEA(dst) := EA (src) + wEA(locked, dst) := EA (false, src) else - wEA(acc) := val_dst; + wEA(false, acc) := val_dst; } (* ========================================================================== @@ -653,15 +655,15 @@ function clause execute (DIV (sz,r)) = let w = (int) (value_width(sz)) in let eax = Ea_r(sz, 0) in (* RAX *) let edx = Ea_r(sz, 2) in (* RDX *) - let n = unsigned(EA(edx)) * w + unsigned(EA(eax)) in - let d = unsigned(EA(ea_rm(sz, r))) in + let n = unsigned(EA(false, edx)) * w + unsigned(EA(false, eax)) in + let d = unsigned(EA(false, ea_rm(sz, r))) in let q = n quot d in let m = n mod d in if d == 0 | w < q then exit () else { - wEA(eax) := (qword) q; - wEA(edx) := (qword) m; + wEA(false, eax) := (qword) q; + wEA(false, edx) := (qword) m; erase_eflags(); } @@ -689,7 +691,7 @@ function clause execute (Jcc (c,i)) = union ast member rm JMP -function clause execute (JMP (r)) = RIP := EA (ea_rm (Sz64, r)) +function clause execute (JMP (r)) = RIP := EA (false, ea_rm (Sz64, r)) (* ========================================================================== LEA @@ -700,7 +702,7 @@ union ast member (wsize,dest_src) LEA function clause execute (LEA (sz,ds)) = let src = ea_src (sz, ds) in let dst = ea_dest (sz, ds) in - wEA(dst) := get_ea_address (src) + wEA(false, dst) := get_ea_address (src) (* ========================================================================== LEAVE @@ -739,10 +741,10 @@ function clause execute (MFENCE) = Monop ========================================================================== *) -union ast member (monop_name,wsize,rm) Monop +union ast member (bool,monop_name,wsize,rm) Monop -function clause execute (Monop (mop,sz,r)) = - let e = ea_rm (sz, r) in write_monop (sz, mop, EA(e), e) +function clause execute (Monop (locked,mop,sz,r)) = + let e = ea_rm (sz, r) in write_monop (locked, sz, mop, EA(locked, e), e) (* ========================================================================== MOV @@ -754,7 +756,7 @@ function clause execute (MOV (c,sz,ds)) = if read_cond (c) then let src = ea_src (sz, ds) in let dst = ea_dest (sz, ds) in - wEA(dst) := EA(src) + wEA(false, dst) := EA(false, src) else () (* ========================================================================== @@ -766,7 +768,7 @@ union ast member (wsize,dest_src,wsize) MOVSX function clause execute (MOVSX (sz1,ds,sz2)) = let src = ea_src (sz1, ds) in let dst = ea_dest (sz2, ds) in - wEA(dst) := sign_extension (EA(src), sz1, sz2) + wEA(false, dst) := sign_extension (EA(false, src), sz1, sz2) (* ========================================================================== MOVZX @@ -777,7 +779,7 @@ union ast member (wsize,dest_src,wsize) MOVZX function clause execute (MOVZX (sz1,ds,sz2)) = let src = ea_src (sz1, ds) in let dst = ea_dest (sz2, ds) in - wEA(dst) := EA(src) + wEA(false, dst) := EA(false, src) (* ========================================================================== MUL @@ -787,16 +789,16 @@ union ast member (wsize,rm) MUL function clause execute (MUL (sz,r)) = let eax = Ea_r (sz, 0) in (* RAX *) - let val_eax = EA(eax) in - let val_src = EA(ea_rm (sz, r)) in + let val_eax = EA(false, eax) in + let val_src = EA(false, ea_rm (sz, r)) in switch sz { - case (Sz8(_)) -> wEA(Ea_r(Sz16,0)) := (val_eax * val_src)[63 .. 0] + case (Sz8(_)) -> wEA(false, Ea_r(Sz16,0)) := (val_eax * val_src)[63 .. 0] case _ -> let m = val_eax * val_src in let edx = Ea_r (sz, 2) in (* RDX *) { - wEA(eax) := m[63 .. 0]; - wEA(edx) := (m >> size_width(sz))[63 .. 0] + wEA(false, eax) := m[63 .. 0]; + wEA(false, edx) := (m >> size_width(sz))[63 .. 0] } } @@ -843,7 +845,7 @@ function clause execute (RET (i)) = union ast member (cond,bool,rm) SET function clause execute (SET (c,b,r)) = - wEA(ea_rm(Sz8(b),r)) := if read_cond (c) then 1 else 0 + wEA(false, ea_rm(Sz8(b),r)) := if read_cond (c) then 1 else 0 (* ========================================================================== STC @@ -857,32 +859,32 @@ function clause execute STC = CF := true XADD ========================================================================== *) -union ast member (wsize,rm,regn) XADD +union ast member (bool, wsize,rm,regn) XADD -function clause execute (XADD (sz,r,n)) = +function clause execute (XADD (locked,sz,r,n)) = let src = Ea_r (sz, n) in let dst = ea_rm (sz, r) in - let val_src = EA(src) in - let val_dst = EA(dst) in + let val_src = EA(false, src) in + let val_dst = EA(locked, dst) in { - wEA(src) := val_dst; - write_binop (sz, Add, val_src, val_dst, dst); + wEA(false, src) := val_dst; + write_binop (locked, sz, Add, val_src, val_dst, dst); } (* ========================================================================== XCHG ========================================================================== *) -union ast member (wsize,rm,regn) XCHG +union ast member (bool,wsize,rm,regn) XCHG -function clause execute (XCHG (sz,r,n)) = +function clause execute (XCHG (locked,sz,r,n)) = let src = Ea_r (sz, n) in let dst = ea_rm (sz, r) in - let val_src = EA(src) in - let val_dst = EA(dst) in + let val_src = EA(false, src) in + let val_dst = EA(locked, dst) in { - wEA(src) := val_dst; - wEA(dst) := val_src; + wEA(false, src) := val_dst; + wEA(locked, dst) := val_src; } end ast @@ -1302,14 +1304,16 @@ function (instruction_kind, regfps, regfps, regfps) regfp_dest_src ((dest_src) d } (* as above but where destination is also a source operand *) -function (instruction_kind, regfps, regfps, regfps) regfp_dest_src_rmw ((dest_src) ds) = +function (instruction_kind, regfps, regfps, regfps) regfp_dest_src_rmw (locked, (dest_src) ds) = + let rk = if locked then Read_X86_locked else Read_plain in + let wk = if locked then Write_X86_locked else Write_plain in switch ds { case (Rm_i (r_m, i)) -> let (m,rds, ars) = regfp_rm(r_m) in - (if m then IK_mem_rmw(Read_plain, Write_plain) else IK_simple, append(rds, ars), rds, ars) + (if m then IK_mem_rmw(rk, wk) else IK_simple, append(rds, ars), rds, ars) case (Rm_r (r_m, r)) -> let (m,rds, ars) = regfp_rm(r_m) in - (if m then IK_mem_rmw(Read_plain, Write_plain) else IK_simple, RFull(GPRstr[r]) :: append(rds, ars), rds, ars) + (if m then IK_mem_rmw(rk, wk) else IK_simple, RFull(GPRstr[r]) :: append(rds, ars), rds, ars) case (R_rm (r, r_m)) -> let rds = [|| RFull(GPRstr[r]) ||] in let (m,rs,ars) = regfp_rm(r_m) in @@ -1372,9 +1376,9 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( Dia := DIAFP_none; x := (qword) RIP; switch instr { - case(Binop (binop, sz, ds)) -> { + case(Binop (locked, binop, sz, ds)) -> { let flags = regfp_binop_flags (binop) in - let (ik', iRs, oRs, aRs) = regfp_dest_src_rmw(ds) in { + let (ik', iRs, oRs, aRs) = regfp_dest_src_rmw(locked, ds) in { ik := ik'; iR := append(iRs, iR); oR := append(flags, append(oRs, oR)); @@ -1398,9 +1402,11 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( iR := RFull("CF") :: iR; oR := RFull("CF") :: oR; } - case(CMPXCHG (sz, r_m, reg) ) -> + case(CMPXCHG (locked, sz, r_m, reg) ) -> + let rk = if locked then Read_X86_locked else Read_plain in + let wk = if locked then Write_X86_locked else Write_plain in let (m, rs, aRs) = regfp_rm (r_m) in { - iK := if m then IK_mem_rmw (Read_plain, Write_plain) else IK_simple; + iK := if m then IK_mem_rmw (rk, wk) else IK_simple; iR := RFull("RAX") :: RFull(GPRstr[reg]) :: append(rs, aRs); oR := RFull("RAX") :: append(regfp_binop_flags(Cmp), rs); aR := aRs; @@ -1447,9 +1453,11 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( Nias := NIAFP_concrete_address(RIP + imm64) :: Nias; } case(MFENCE ) -> iK := IK_barrier (Barrier_x86_MFENCE) - case(Monop (monop, sz, r_m) ) -> + case(Monop (locked, monop, sz, r_m) ) -> + let rk = if locked then Read_X86_locked else Read_plain in + let wk = if locked then Write_X86_locked else Write_plain in let (m, rds, ars) = regfp_rm(r_m) in { - iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_simple; + iK := if m then IK_mem_rmw(rk, wk) else IK_simple; iR := append(rds, ars); oR := append(all_flags_but_cf_of, rds); (* XXX fix flags *) aR := ars; @@ -1516,16 +1524,20 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( aR := ars; } case(STC ) -> oR := [|| RFull("CF") ||] - case(XADD (sz, r_m, reg) ) -> + case(XADD (locked, sz, r_m, reg) ) -> + let rk = if locked then Read_X86_locked else Read_plain in + let wk = if locked then Write_X86_locked else Write_plain in let (m, rs, ars) = regfp_rm(r_m) in { - iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_simple; + iK := if m then IK_mem_rmw(rk, wk) else IK_simple; iR := RFull(GPRstr[reg]) :: append(rs, ars); oR := RFull(GPRstr[reg]) :: append(rs, all_flags); aR := ars; } - case(XCHG (sz, r_m, reg) ) -> + case(XCHG (locked, sz, r_m, reg) ) -> + let rk = if locked then Read_X86_locked else Read_plain in + let wk = if locked then Write_X86_locked else Write_plain in let (m, rs, ars) = regfp_rm(r_m) in { - iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_simple; + iK := if m then IK_mem_rmw(rk, wk) else IK_simple; iR := RFull(GPRstr[reg]) :: append(rs, ars); oR := RFull(GPRstr[reg]) :: rs; aR := ars; -- cgit v1.2.3 From 83adaea79d0ae53ff898985fdd359fbca7773de3 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 21 Sep 2017 09:51:41 +0100 Subject: added a comment to the x86 lock'd read and write --- src/lem_interp/sail_impl_base.lem | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index e39c4421..6957bb95 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -441,7 +441,8 @@ type read_kind = | Read_RISCV_acquire | Read_RISCV_strong_acquire | Read_RISCV_reserved | Read_RISCV_reserved_acquire | Read_RISCV_reserved_strong_acquire - | Read_X86_locked + (* x86 reads *) + | Read_X86_locked (* the read part of a lock'd instruction (rmw) *) instance (Show read_kind) let show = function @@ -471,7 +472,8 @@ type write_kind = | Write_RISCV_release | Write_RISCV_strong_release | Write_RISCV_conditional | Write_RISCV_conditional_release | Write_RISCV_conditional_strong_release - | Write_X86_locked + (* x86 writes *) + | Write_X86_locked (* the write part of a lock'd instruction (rmw) *) instance (Show write_kind) let show = function -- cgit v1.2.3 From 2148a88c9e9d16e07be1439ddc36ed69c31ee74c Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 21 Sep 2017 10:52:23 +0100 Subject: wib --- src/gen_lib/state.lem | 1 + 1 file changed, 1 insertion(+) diff --git a/src/gen_lib/state.lem b/src/gen_lib/state.lem index ac5cb869..88e29522 100644 --- a/src/gen_lib/state.lem +++ b/src/gen_lib/state.lem @@ -59,6 +59,7 @@ let is_exclusive = function | Sail_impl_base.Read_RISCV_reserved -> true | Sail_impl_base.Read_RISCV_reserved_acquire -> true | Sail_impl_base.Read_RISCV_reserved_strong_acquire -> true + | Sail_impl_base.Read_X86_locked -> true end -- cgit v1.2.3 From 44ade2212a4c7fe68d6c2c2bddc0f57a0d0ca5c7 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Fri, 22 Sep 2017 10:55:30 +0100 Subject: fix typo where Sz16 write to register was only writing 8 bits. --- x86/x64.sail | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/x86/x64.sail b/x86/x64.sail index 0b0d2230..a54b35a4 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -301,7 +301,7 @@ function unit effect { wmem, wreg, escape } wEA ((bool) locked, (ea) e, (qword) case (Ea_r(Sz16,r)) -> { (qword) regr := REG[r]; - regr[15 .. 8] := w[15 .. 8]; + regr[15 .. 0] := w[15 .. 0]; REG[r] := regr } case (Ea_r(Sz32,r)) -> REG[r] := (qword) (EXTZ (w[31 .. 0])) -- cgit v1.2.3 From 433063a6b229748599dde8f4374765c7d538fd22 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Fri, 22 Sep 2017 11:34:04 +0100 Subject: x86: remove unnecessary? read modify write of registers. --- x86/x64.sail | 19 +++---------------- 1 file changed, 3 insertions(+), 16 deletions(-) diff --git a/x86/x64.sail b/x86/x64.sail index a54b35a4..99da122f 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -287,23 +287,10 @@ function unit effect { wmem, wreg, escape } wEA ((bool) locked, (ea) e, (qword) case (Ea_i(_,_)) -> exit () case (Ea_r((Sz8(have_rex)),r)) -> if have_rex | r < 4 (* RSP *) | r > 7 (* RDI *) then - { - (qword) regr := REG[r]; - regr[7 .. 0] := w[7 .. 0]; - REG[r] := regr - } + (REG[r])[7 .. 0] := w[7 .. 0] else - { - (qword) regr := REG[sub4(r)]; - regr[15 .. 8] := (vector<15,8,dec,bit>) (w[7 .. 0]); - REG[sub4(r)] := regr - } - case (Ea_r(Sz16,r)) -> - { - (qword) regr := REG[r]; - regr[15 .. 0] := w[15 .. 0]; - REG[r] := regr - } + (REG[sub4(r)])[15 .. 8] := (vector<15,8,dec,bit>) (w[7 .. 0]) + case (Ea_r(Sz16,r)) ->(REG[r])[15 .. 0] := w[15 .. 0] case (Ea_r(Sz32,r)) -> REG[r] := (qword) (EXTZ (w[31 .. 0])) case (Ea_r(Sz64,r)) -> REG[r] := w case (Ea_m((Sz8(_)),a)) -> wMEM(locked, a, 1, w[7 .. 0]) -- cgit v1.2.3 From 963d4fef5b9c75939b744f1a2e09779859c7c643 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Fri, 22 Sep 2017 13:47:09 +0100 Subject: x86: implement get_ea_address function. --- x86/x64.sail | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/x86/x64.sail b/x86/x64.sail index 99da122f..2f6f07ed 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -310,11 +310,11 @@ function qword call_dest_from_ea ((ea) e) = case (Ea_m(_, a)) -> rMEM(a, 8) } -function qword get_ea_address ((ea) e) = (* XXX rmn30 looks broken *) +function qword get_ea_address ((ea) e) = switch e { case (Ea_i(_, i)) -> 0x0000000000000000 case (Ea_r(_, r)) -> 0x0000000000000000 - case (Ea_m(_, a)) -> 0x0000000000000000 + case (Ea_m(_, a)) -> a } function unit jump_to_ea ((ea) e) = RIP := call_dest_from_ea(e) -- cgit v1.2.3 From 8ca00a2729ed477183afeeb1ad20b5a0fc23dc82 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 25 Sep 2017 12:28:26 +0100 Subject: x86: always perform write for cmpxchg by writing back original value if comparison fails. This is specified in manual and also helps RMEM with locked writes. --- x86/x64.sail | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/x86/x64.sail b/x86/x64.sail index 2f6f07ed..dfa92fd3 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -628,8 +628,12 @@ function clause execute (CMPXCHG (locked, sz,r,n)) = write_binop (locked, sz, Cmp, val_acc, val_dst, src); if val_acc == val_dst then wEA(locked, dst) := EA (false, src) - else + else { wEA(false, acc) := val_dst; + (* write back the original value in dst so that we always + perform locked write after locked read *) + wEA(locked, dst) := val_dst; + } } (* ========================================================================== -- cgit v1.2.3 From 5cb198d1f9e944a9a7f7c4c01640ff8136b0e0ab Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Tue, 26 Sep 2017 09:12:37 +0100 Subject: RISC-V: check alignment of atomic memory accesses (and escape when misaligned) --- risc-v/riscv.sail | 29 ++++++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index c5b19d26..55a672ad 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -60,13 +60,24 @@ function forall 'a. 'a effect { escape } not_implemented((string) message) = exit message; } +function unit effect { escape } check_alignment( (bit[64]) addr, (nat) width) = +{ + if (unsigned(addr) quot width != 0) then + exit "misaligned memory access"; +} + + val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_acquire val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_strong_acquire val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved_acquire val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved_strong_acquire -function forall Nat 'n. (bit[8 * 'n]) effect { rmem } mem_read( (bit[64]) addr, ([|'n|]) width, (bool) aq, (bool) rl, (bool) res) = +function forall Nat 'n. (bit[8 * 'n]) effect { rmem, escape } mem_read( (bit[64]) addr, ([|'n|]) width, (bool) aq, (bool) rl, (bool) res) = +{ + if (aq | res) then + check_alignment(addr, width); + switch (aq, rl, res) { case (false, false, false) -> MEMr(addr, width) case (true, false, false) -> MEMr_acquire(addr, width) @@ -77,6 +88,7 @@ function forall Nat 'n. (bit[8 * 'n]) effect { rmem } mem_read( (bit[64]) addr, case (false, true, true) -> not_implemented("lr.rl is not implemented") case (true, true, true) -> MEMr_reserved_strong_acquire(addr, width) } +} val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_release @@ -84,7 +96,11 @@ val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_str val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_release val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_strong_release -function forall Nat 'n. unit effect { eamem } mem_write_ea( (bit[64]) addr , ([|'n|]) width, (bool) aq, (bool) rl, (bool) con) = +function forall Nat 'n. unit effect { eamem, escape } mem_write_ea( (bit[64]) addr , ([|'n|]) width, (bool) aq, (bool) rl, (bool) con) = +{ + if (rl | con) then + check_alignment(addr, width); + switch (aq, rl, con) { case (false, false, false) -> MEMea(addr, width) case (false, true, false) -> MEMea_release(addr, width) @@ -95,6 +111,7 @@ function forall Nat 'n. unit effect { eamem } mem_write_ea( (bit[64]) addr , ([| case (true, false, true) -> not_implemented("sc.aq is not implemented") case (true, true , true) -> MEMea_conditional_strong_release(addr, width) } +} val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_release @@ -102,7 +119,11 @@ val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional_release val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional_strong_release -function forall Nat 'n. unit effect { wmv } mem_write_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) aq, (bool) rl, (bool) con) = +function forall Nat 'n. unit effect { wmv, escape } mem_write_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) aq, (bool) rl, (bool) con) = +{ + if (rl | con) then + check_alignment(addr, width); + switch (aq, rl, con) { case (false, false, false) -> MEMval(addr, width, value) case (false, true, false) -> MEMval_release(addr, width, value) @@ -113,6 +134,7 @@ function forall Nat 'n. unit effect { wmv } mem_write_value( (bit[64]) addr , ([ case (true, false, true) -> not_implemented("sc.aq is not implemented") case (true, true, true) -> MEMval_conditional_strong_release(addr, width, value) } +} val extern unit -> bool effect {exmem} speculate_conditional_success @@ -427,6 +449,7 @@ function clause decode (0b11000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b01 function clause decode (0b11000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOMINU, aq, rl, rs2, rs1, DOUBLE, rd)) function clause decode (0b11100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOMAXU, aq, rl, rs2, rs1, WORD, rd)) function clause decode (0b11100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOMAXU, aq, rl, rs2, rs1, DOUBLE, rd)) + function clause execute (AMO(op, aq, rl, rs2, rs1, width, rd)) = { (bit[64]) addr := rGPR(rs1); -- cgit v1.2.3 From 72e597901e710f1549d387d9c1326b04be42e9d2 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Tue, 26 Sep 2017 12:23:46 +0100 Subject: fixes --- src/gen_lib/deep_shallow_convert.lem | 40 ++++++++++++++++++++---------------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/src/gen_lib/deep_shallow_convert.lem b/src/gen_lib/deep_shallow_convert.lem index 42a65c49..86365b78 100644 --- a/src/gen_lib/deep_shallow_convert.lem +++ b/src/gen_lib/deep_shallow_convert.lem @@ -385,16 +385,17 @@ end let read_kindToInterpValue = function | Read_plain -> V_ctor (Id_aux (Id "Read_plain") Unknown) (T_id "read_kind") (C_Enum 0) (toInterpValue ()) - | Read_reserve -> V_ctor (Id_aux (Id "Read_reserve") Unknown) (T_id "read_kind") (C_Enum 2) (toInterpValue ()) - | Read_acquire -> V_ctor (Id_aux (Id "Read_acquire") Unknown) (T_id "read_kind") (C_Enum 3) (toInterpValue ()) - | Read_exclusive -> V_ctor (Id_aux (Id "Read_exclusive") Unknown) (T_id "read_kind") (C_Enum 4) (toInterpValue ()) - | Read_exclusive_acquire -> V_ctor (Id_aux (Id "Read_exclusive_acquire") Unknown) (T_id "read_kind") (C_Enum 5) (toInterpValue ()) - | Read_stream -> V_ctor (Id_aux (Id "Read_stream") Unknown) (T_id "read_kind") (C_Enum 6) (toInterpValue ()) - | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_acquire") Unknown) (T_id "read_kind") (C_Enum 7) (toInterpValue ()) - | Read_RISCV_strong_acquire -> V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 8) (toInterpValue ()) - | Read_RISCV_reserved -> V_ctor (Id_aux (Id "Read_RISCV_reserved") Unknown) (T_id "read_kind") (C_Enum 9) (toInterpValue ()) - | Read_RISCV_reserved_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) + | Read_reserve -> V_ctor (Id_aux (Id "Read_reserve") Unknown) (T_id "read_kind") (C_Enum 1) (toInterpValue ()) + | Read_acquire -> V_ctor (Id_aux (Id "Read_acquire") Unknown) (T_id "read_kind") (C_Enum 2) (toInterpValue ()) + | Read_exclusive -> V_ctor (Id_aux (Id "Read_exclusive") Unknown) (T_id "read_kind") (C_Enum 3) (toInterpValue ()) + | Read_exclusive_acquire -> V_ctor (Id_aux (Id "Read_exclusive_acquire") Unknown) (T_id "read_kind") (C_Enum 4) (toInterpValue ()) + | Read_stream -> V_ctor (Id_aux (Id "Read_stream") Unknown) (T_id "read_kind") (C_Enum 5) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_acquire") Unknown) (T_id "read_kind") (C_Enum 6) (toInterpValue ()) + | Read_RISCV_strong_acquire -> V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 7) (toInterpValue ()) + | Read_RISCV_reserved -> V_ctor (Id_aux (Id "Read_RISCV_reserved") Unknown) (T_id "read_kind") (C_Enum 8) (toInterpValue ()) + | Read_RISCV_reserved_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") Unknown) (T_id "read_kind") (C_Enum 9) (toInterpValue ()) | Read_RISCV_reserved_strong_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) + | Read_X86_locked -> V_ctor (Id_aux (Id "Read_X86_locked") Unknown) (T_id "read_kind") (C_Enum 11) (toInterpValue ()) end let rec read_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Read_plain") _) _ _ v -> Read_plain @@ -408,6 +409,7 @@ let rec read_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Read_RISCV_reserved") _) _ _ v -> Read_RISCV_reserved | V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") _) _ _ v -> Read_RISCV_reserved_acquire | V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") _) _ _ v -> Read_RISCV_reserved_strong_acquire + | V_ctor (Id_aux (Id "Read_X86_locked") _) _ _ v -> Read_X86_locked | V_tuple [v] -> read_kindFromInterpValue v | v -> failwith ("fromInterpValue read_kind: unexpected value. " ^ Interp.debug_print_value v) @@ -420,15 +422,16 @@ end let write_kindToInterpValue = function | Write_plain -> V_ctor (Id_aux (Id "Write_plain") Unknown) (T_id "write_kind") (C_Enum 0) (toInterpValue ()) - | Write_conditional -> V_ctor (Id_aux (Id "Write_conditional") Unknown) (T_id "write_kind") (C_Enum 2) (toInterpValue ()) - | Write_release -> V_ctor (Id_aux (Id "Write_release") Unknown) (T_id "write_kind") (C_Enum 3) (toInterpValue ()) - | Write_exclusive -> V_ctor (Id_aux (Id "Write_exclusive") Unknown) (T_id "write_kind") (C_Enum 4) (toInterpValue ()) - | Write_exclusive_release -> V_ctor (Id_aux (Id "Write_exclusive_release") Unknown) (T_id "write_kind") (C_Enum 5) (toInterpValue ()) - | Write_RISCV_release -> V_ctor (Id_aux (Id "Write_RISCV_release") Unknown) (T_id "write_kind") (C_Enum 6) (toInterpValue ()) - | Write_RISCV_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_strong_release") Unknown) (T_id "write_kind") (C_Enum 7) (toInterpValue ()) - | Write_RISCV_conditional -> V_ctor (Id_aux (Id "Write_RISCV_conditional") Unknown) (T_id "write_kind") (C_Enum 8) (toInterpValue ()) - | Write_RISCV_conditional_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_release") Unknown) (T_id "write_kind") (C_Enum 9) (toInterpValue ()) - | Write_RISCV_conditional_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_strong_release") Unknown) (T_id "write_kind") (C_Enum 10) (toInterpValue ()) + | Write_conditional -> V_ctor (Id_aux (Id "Write_conditional") Unknown) (T_id "write_kind") (C_Enum 1) (toInterpValue ()) + | Write_release -> V_ctor (Id_aux (Id "Write_release") Unknown) (T_id "write_kind") (C_Enum 2) (toInterpValue ()) + | Write_exclusive -> V_ctor (Id_aux (Id "Write_exclusive") Unknown) (T_id "write_kind") (C_Enum 3) (toInterpValue ()) + | Write_exclusive_release -> V_ctor (Id_aux (Id "Write_exclusive_release") Unknown) (T_id "write_kind") (C_Enum 4) (toInterpValue ()) + | Write_RISCV_release -> V_ctor (Id_aux (Id "Write_RISCV_release") Unknown) (T_id "write_kind") (C_Enum 5) (toInterpValue ()) + | Write_RISCV_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_strong_release") Unknown) (T_id "write_kind") (C_Enum 6) (toInterpValue ()) + | Write_RISCV_conditional -> V_ctor (Id_aux (Id "Write_RISCV_conditional") Unknown) (T_id "write_kind") (C_Enum 7) (toInterpValue ()) + | Write_RISCV_conditional_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_release") Unknown) (T_id "write_kind") (C_Enum 8) (toInterpValue ()) + | Write_RISCV_conditional_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_strong_release") Unknown) (T_id "write_kind") (C_Enum 9) (toInterpValue ()) + | Write_X86_locked -> V_ctor (Id_aux (Id "Write_X86_locked") Unknown) (T_id "write_kind") (C_Enum 10) (toInterpValue ()) end let rec write_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Write_plain") _) _ _ v -> Write_plain @@ -441,6 +444,7 @@ let rec write_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Write_RISCV_conditional") _) _ _ v -> Write_RISCV_conditional | V_ctor (Id_aux (Id "Write_RISCV_conditional_release") _) _ _ v -> Write_RISCV_conditional_release | V_ctor (Id_aux (Id "Write_RISCV_conditional_strong_release") _) _ _ v -> Write_RISCV_conditional_strong_release + | V_ctor (Id_aux (Id "Write_X86_locked") _) _ _ v -> Write_X86_locked | V_tuple [v] -> write_kindFromInterpValue v | v -> failwith ("fromInterpValue write_kind: unexpected value " ^ Interp.debug_print_value v) -- cgit v1.2.3 From f5322fa262de3545d453891745e3c1cdaaceb5f5 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Wed, 27 Sep 2017 09:04:30 +0100 Subject: oops --- risc-v/riscv.sail | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index 55a672ad..ea885d90 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -62,7 +62,7 @@ function forall 'a. 'a effect { escape } not_implemented((string) message) = function unit effect { escape } check_alignment( (bit[64]) addr, (nat) width) = { - if (unsigned(addr) quot width != 0) then + if (unsigned(addr) mod width != 0) then exit "misaligned memory access"; } -- cgit v1.2.3 From a66b55639fddc862b7a3864afb0e3dc7b4ac0e34 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Wed, 27 Sep 2017 14:13:01 +0100 Subject: split RISC-V to two Sail files to make it more readable --- risc-v/Makefile | 2 +- risc-v/riscv.sail | 311 +++++++++++++++++------------------------------- risc-v/riscv_types.sail | 165 +++++++++++++++++++++++++ 3 files changed, 277 insertions(+), 201 deletions(-) create mode 100644 risc-v/riscv_types.sail diff --git a/risc-v/Makefile b/risc-v/Makefile index 856a48eb..d027556e 100644 --- a/risc-v/Makefile +++ b/risc-v/Makefile @@ -1,6 +1,6 @@ SAIL:=../src/sail.native -SOURCES:=riscv.sail ../etc/regfp.sail riscv_regfp.sail +SOURCES:=riscv_types.sail riscv.sail ../etc/regfp.sail riscv_regfp.sail all: lem_ast shallow lem_ast: $(SOURCES) $(SAIL) diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index ea885d90..8658ae96 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -1,177 +1,11 @@ -default Order dec - -typedef regval = bit[64] -typedef regno = bit[5] - -register (regval) x0 -register (regval) x1 -register (regval) x2 -register (regval) x3 -register (regval) x4 -register (regval) x5 -register (regval) x6 -register (regval) x7 -register (regval) x8 -register (regval) x9 -register (regval) x10 -register (regval) x11 -register (regval) x12 -register (regval) x13 -register (regval) x14 -register (regval) x15 -register (regval) x16 -register (regval) x17 -register (regval) x18 -register (regval) x19 -register (regval) x20 -register (regval) x21 -register (regval) x22 -register (regval) x23 -register (regval) x24 -register (regval) x25 -register (regval) x26 -register (regval) x27 -register (regval) x28 -register (regval) x29 -register (regval) x30 -register (regval) x31 - -register (bit[64]) PC -register (bit[64]) nextPC - -let (vector <0, 32, inc, (register<(regval)>)>) GPRs = - [ x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, - x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, - x28, x29, x30, x31 - ] - -function (regval) rGPR ((regno) r) = - if (r == 0) then - 0 - else - GPRs[r] - -function unit wGPR((regno) r, (regval) v) = - if (r != 0) then - GPRs[r] := v - -function forall 'a. 'a effect { escape } not_implemented((string) message) = -{ - exit message; -} - -function unit effect { escape } check_alignment( (bit[64]) addr, (nat) width) = -{ - if (unsigned(addr) mod width != 0) then - exit "misaligned memory access"; -} - - -val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr -val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_acquire -val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_strong_acquire -val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved -val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved_acquire -val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved_strong_acquire -function forall Nat 'n. (bit[8 * 'n]) effect { rmem, escape } mem_read( (bit[64]) addr, ([|'n|]) width, (bool) aq, (bool) rl, (bool) res) = -{ - if (aq | res) then - check_alignment(addr, width); - - switch (aq, rl, res) { - case (false, false, false) -> MEMr(addr, width) - case (true, false, false) -> MEMr_acquire(addr, width) - case (false, false, true) -> MEMr_reserved(addr, width) - case (true, false, true) -> MEMr_reserved_acquire(addr, width) - case (false, true, false) -> not_implemented("load.rl is not implemented") - case (true, true, false) -> MEMr_strong_acquire(addr, width) - case (false, true, true) -> not_implemented("lr.rl is not implemented") - case (true, true, true) -> MEMr_reserved_strong_acquire(addr, width) - } -} - -val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea -val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_release -val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_strong_release -val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional -val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_release -val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_strong_release -function forall Nat 'n. unit effect { eamem, escape } mem_write_ea( (bit[64]) addr , ([|'n|]) width, (bool) aq, (bool) rl, (bool) con) = -{ - if (rl | con) then - check_alignment(addr, width); - - switch (aq, rl, con) { - case (false, false, false) -> MEMea(addr, width) - case (false, true, false) -> MEMea_release(addr, width) - case (false, false, true) -> MEMea_conditional(addr, width) - case (false, true , true) -> MEMea_conditional_release(addr, width) - case (true, false, false) -> not_implemented("store.aq is not implemented") - case (true, true, false) -> MEMea_strong_release(addr, width) - case (true, false, true) -> not_implemented("sc.aq is not implemented") - case (true, true , true) -> MEMea_conditional_strong_release(addr, width) - } -} - -val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval -val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_release -val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_strong_release -val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional -val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional_release -val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional_strong_release -function forall Nat 'n. unit effect { wmv, escape } mem_write_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) aq, (bool) rl, (bool) con) = -{ - if (rl | con) then - check_alignment(addr, width); - - switch (aq, rl, con) { - case (false, false, false) -> MEMval(addr, width, value) - case (false, true, false) -> MEMval_release(addr, width, value) - case (false, false, true) -> MEMval_conditional(addr, width, value) - case (false, true, true) -> MEMval_conditional_release(addr, width, value) - case (true, false, false) -> not_implemented("store.aq is not implemented") - case (true, true, false) -> MEMval_strong_release(addr, width, value) - case (true, false, true) -> not_implemented("sc.aq is not implemented") - case (true, true, true) -> MEMval_conditional_strong_release(addr, width, value) - } -} - -val extern unit -> bool effect {exmem} speculate_conditional_success - -val extern unit -> unit effect { barr } MEM_fence_rw_rw -val extern unit -> unit effect { barr } MEM_fence_r_rw -val extern unit -> unit effect { barr } MEM_fence_rw_w -val extern unit -> unit effect { barr } MEM_fence_w_w -val extern unit -> unit effect { barr } MEM_fence_i - -(* Ideally these would be sail builtin *) -function (bit[64]) shift_right_arith64 ((bit[64]) v, (bit[6]) shift) = - let (bit[128]) v128 = EXTS(v) in - (v128 >> shift)[63..0] - -function (bit[32]) shift_right_arith32 ((bit[32]) v, (bit[5]) shift) = - let (bit[64]) v64 = EXTS(v) in - (v64 >> shift)[31..0] - -typedef uop = enumerate {LUI; AUIPC} (* upper immediate ops *) -typedef bop = enumerate {BEQ; BNE; BLT; BGE; BLTU; BGEU} (* branch ops *) -typedef iop = enumerate {ADDI; SLTI; SLTIU; XORI; ORI; ANDI} (* immediate ops *) -typedef sop = enumerate {SLLI; SRLI; SRAI} (* shift ops *) -typedef rop = enumerate {ADD; SUB; SLL; SLT; SLTU; XOR; SRL; SRA; OR; AND} (* reg-reg ops *) -typedef ropw = enumerate {ADDW; SUBW; SLLW; SRLW; SRAW} (* reg-reg 32-bit ops *) -typedef amoop = enumerate {AMOSWAP; AMOADD; AMOXOR; AMOAND; AMOOR; - AMOMIN; AMOMAX; AMOMINU; AMOMAXU} (* AMO ops *) - - -typedef word_width = enumerate {BYTE; HALF; WORD; DOUBLE} - -scattered function unit execute scattered typedef ast = const union val bit[32] -> option effect pure decode - scattered function option decode +scattered function unit execute + +(********************************************************************) union ast member ((bit[20]), regno, uop) UTYPE function clause decode ((bit[20]) imm : (regno) rd : 0b0110111) = Some(UTYPE(imm, rd, LUI)) @@ -185,30 +19,44 @@ function clause execute (UTYPE(imm, rd, op)) = } in wGPR(rd, ret) +(********************************************************************) union ast member ((bit[21]), regno) JAL + function clause decode ((bit[20]) imm : (regno) rd : 0b1101111) = Some (JAL(imm[19] : imm[7..0] : imm[8] : imm[18..13] : imm[12..9] : 0b0, rd)) + function clause execute (JAL(imm, rd)) = let (bit[64]) offset = EXTS(imm) in { nextPC := PC + offset; wGPR(rd, PC + 4); } +(********************************************************************) union ast member((bit[12]), regno, regno) JALR + function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b1100111) = Some(JALR(imm, rs1, rd)) + function clause execute (JALR(imm, rs1, rd)) = let (bit[64]) newPC = rGPR(rs1) + EXTS(imm) in { nextPC := newPC[63..1] : 0b0; wGPR(rd, PC + 4); } +(********************************************************************) union ast member ((bit[13]), regno, regno, bop) BTYPE -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b000 : (bit[5]) imm5 : 0b1100011) = Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BEQ)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b001 : (bit[5]) imm5 : 0b1100011) = Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BNE)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b100 : (bit[5]) imm5 : 0b1100011) = Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BLT)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b101 : (bit[5]) imm5 : 0b1100011) = Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BGE)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b110 : (bit[5]) imm5 : 0b1100011) = Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BLTU)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b111 : (bit[5]) imm5 : 0b1100011) = Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BGEU)) + +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b000 : (bit[5]) imm5 : 0b1100011) = + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BEQ)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b001 : (bit[5]) imm5 : 0b1100011) = + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BNE)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b100 : (bit[5]) imm5 : 0b1100011) = + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BLT)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b101 : (bit[5]) imm5 : 0b1100011) = + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BGE)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b110 : (bit[5]) imm5 : 0b1100011) = + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BLTU)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b111 : (bit[5]) imm5 : 0b1100011) = + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BGEU)) function clause execute (BTYPE(imm, rs2, rs1, op)) = let rs1_val = rGPR(rs1) in @@ -224,13 +72,16 @@ function clause execute (BTYPE(imm, rs2, rs1, op)) = if (taken) then nextPC := PC + EXTS(imm) +(********************************************************************) union ast member ((bit[12]), regno, regno, iop) ITYPE + function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, ADDI)) function clause decode ((bit[12]) imm : (regno) rs1 : 0b010 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, SLTI)) function clause decode ((bit[12]) imm : (regno) rs1 : 0b011 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, SLTIU)) function clause decode ((bit[12]) imm : (regno) rs1 : 0b100 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, XORI)) function clause decode ((bit[12]) imm : (regno) rs1 : 0b110 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, ORI)) function clause decode ((bit[12]) imm : (regno) rs1 : 0b111 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, ANDI)) + function clause execute (ITYPE (imm, rs1, rd, op)) = let rs1_val = rGPR(rs1) in let imm64 = (bit[64]) (EXTS(imm)) in @@ -244,10 +95,13 @@ function clause execute (ITYPE (imm, rs1, rd, op)) = } in wGPR(rd, result) +(********************************************************************) union ast member ((bit[6]), regno, regno, sop) SHIFTIOP + function clause decode (0b000000 : (bit[6]) shamt : (regno) rs1 : 0b001 : (regno) rd : 0b0010011) = Some(SHIFTIOP(shamt, rs1, rd, SLLI)) function clause decode (0b000000 : (bit[6]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0010011) = Some(SHIFTIOP(shamt, rs1, rd, SRLI)) function clause decode (0b010000 : (bit[6]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0010011) = Some(SHIFTIOP(shamt, rs1, rd, SRAI)) + function clause execute (SHIFTIOP(shamt, rs1, rd, op)) = let rs1_val = rGPR(rs1) in let result = switch(op) { @@ -257,7 +111,9 @@ function clause execute (SHIFTIOP(shamt, rs1, rd, op)) = } in wGPR(rd, result) +(********************************************************************) union ast member (regno, regno, regno, rop) RTYPE + function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, ADD)) function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, SUB)) function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b001 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, SLL)) @@ -268,6 +124,7 @@ function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, SRA)) function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b110 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, OR)) function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b111 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, AND)) + function clause execute (RTYPE(rs2, rs1, rd, op)) = let rs1_val = rGPR(rs1) in let rs2_val = rGPR(rs2) in @@ -285,7 +142,9 @@ function clause execute (RTYPE(rs2, rs1, rd, op)) = } in wGPR(rd, result) +(********************************************************************) union ast member ((bit[12]), regno, regno, bool, word_width, bool, bool) LOAD + function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, BYTE, false, false)) function clause decode ((bit[12]) imm : (regno) rs1 : 0b001 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, HALF, false, false)) function clause decode ((bit[12]) imm : (regno) rs1 : 0b010 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, false, WORD, false, false)) @@ -293,6 +152,7 @@ function clause decode ((bit[12]) imm : (regno) rs1 : 0b011 : (regno) rd : 0b000 function clause decode ((bit[12]) imm : (regno) rs1 : 0b100 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, BYTE, false, false)) function clause decode ((bit[12]) imm : (regno) rs1 : 0b101 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, HALF, false, false)) function clause decode ((bit[12]) imm : (regno) rs1 : 0b110 : (regno) rd : 0b0000011) = Some(LOAD(imm, rs1, rd, true, WORD, false, false)) + function clause execute(LOAD(imm, rs1, rd, unsigned, width, aq, rl)) = let (bit[64]) addr = rGPR(rs1) + EXTS(imm) in let (bit[64]) result = if unsigned then @@ -311,11 +171,18 @@ function clause execute(LOAD(imm, rs1, rd, unsigned, width, aq, rl)) = } in wGPR(rd, result) +(********************************************************************) union ast member ((bit[12]), regno, regno, word_width, bool, bool) STORE -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b000 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, BYTE, false, false)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b001 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, HALF, false, false)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b010 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, WORD, false, false)) -function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b011 : (bit[5]) imm5 : 0b0100011) = Some(STORE(imm7 : imm5, rs2, rs1, DOUBLE, false, false)) + +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b000 : (bit[5]) imm5 : 0b0100011) = + Some(STORE(imm7 : imm5, rs2, rs1, BYTE, false, false)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b001 : (bit[5]) imm5 : 0b0100011) = + Some(STORE(imm7 : imm5, rs2, rs1, HALF, false, false)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b010 : (bit[5]) imm5 : 0b0100011) = + Some(STORE(imm7 : imm5, rs2, rs1, WORD, false, false)) +function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b011 : (bit[5]) imm5 : 0b0100011) = + Some(STORE(imm7 : imm5, rs2, rs1, DOUBLE, false, false)) + function clause execute (STORE(imm, rs2, rs1, width, aq, rl)) = let (bit[64]) addr = rGPR(rs1) + EXTS(imm) in { switch (width) { @@ -333,18 +200,25 @@ function clause execute (STORE(imm, rs2, rs1, width, aq, rl)) = } } +(********************************************************************) union ast member ((bit[12]), regno, regno) ADDIW -function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b0011011) = Some(ADDIW(imm, rs1, rd)) + +function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b0011011) = + Some(ADDIW(imm, rs1, rd)) + function clause execute (ADDIW(imm, rs1, rd)) = let (bit[64]) imm64 = EXTS(imm) in let (bit[64]) result64 = imm64 + rGPR(rs1) in let (bit[64]) result32 = EXTS(result64[31..0]) in wGPR(rd, result32) +(********************************************************************) union ast member ((bit[5]), regno, regno, sop) SHIFTW + function clause decode (0b0000000 : (bit[5]) shamt : (regno) rs1 : 0b001 : (regno) rd : 0b0011011) = Some(SHIFTW(shamt, rs1, rd, SLLI)) function clause decode (0b0000000 : (bit[5]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0011011) = Some(SHIFTW(shamt, rs1, rd, SRLI)) function clause decode (0b0100000 : (bit[5]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0011011) = Some(SHIFTW(shamt, rs1, rd, SRAI)) + function clause execute (SHIFTW(shamt, rs1, rd, op)) = let rs1_val = (rGPR(rs1))[31..0] in let result = switch(op) { @@ -354,12 +228,15 @@ function clause execute (SHIFTW(shamt, rs1, rd, op)) = } in wGPR(rd, EXTS(result)) +(********************************************************************) union ast member (regno, regno, regno, ropw) RTYPEW + function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, ADDW)) function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, SUBW)) function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b001 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, SLLW)) function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, SRLW)) function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, SRAW)) + function clause execute (RTYPEW(rs2, rs1, rd, op)) = let rs1_val = (rGPR(rs1))[31..0] in let rs2_val = (rGPR(rs2))[31..0] in @@ -372,8 +249,11 @@ function clause execute (RTYPEW(rs2, rs1, rd, op)) = } in wGPR(rd, EXTS(result)) +(********************************************************************) union ast member (bit[4], bit[4]) FENCE + function clause decode (0b0000 : (bit[4]) pred : (bit[4]) succ : 0b00000 : 0b000 : 0b00000 : 0b0001111) = Some(FENCE (pred, succ)) + function clause execute (FENCE(pred, succ)) = { switch(pred, succ) { case (0b0011, 0b0011) -> MEM_fence_rw_rw() @@ -384,19 +264,24 @@ function clause execute (FENCE(pred, succ)) = { } } +(********************************************************************) union ast member unit FENCEI function clause decode (0b000000000000 : 0b00000 : 0b001 : 0b00000 : 0b0001111) = Some(FENCEI) function clause execute FENCEI = MEM_fence_i() +(********************************************************************) union ast member unit ECALL function clause decode (0b000000000000 : 0b00000 : 0b000 : 0b00000 : 0b1110011) = Some(ECALL ()) function clause execute ECALL = not_implemented("ECALL is not implemented") +(********************************************************************) union ast member unit EBREAK function clause decode (0b000000000001 : 0b00000 : 0b000 : 0b00000 : 0b1110011) = Some(EBREAK ()) function clause execute EBREAK = { exit () } +(********************************************************************) union ast member (bool, bool, regno, word_width, regno) LOADRES + function clause decode (0b00010 : [aq] : [rl] : 0b00000 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(LOADRES(aq, rl, rs1, WORD, rd)) function clause decode (0b00010 : [aq] : [rl] : 0b00000 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(LOADRES(aq, rl, rs1, DOUBLE, rd)) function clause execute(LOADRES(aq, rl, rs1, width, rd)) = @@ -408,9 +293,14 @@ function clause execute(LOADRES(aq, rl, rs1, width, rd)) = } in wGPR(rd, result) +(********************************************************************) union ast member (bool, bool, regno, regno, word_width, regno) STORECON -function clause decode (0b00011 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(STORECON(aq, rl, rs2, rs1, WORD, rd)) -function clause decode (0b00011 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(STORECON(aq, rl, rs2, rs1, DOUBLE, rd)) + +function clause decode (0b00011 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = + Some(STORECON(aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b00011 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = + Some(STORECON(aq, rl, rs2, rs1, DOUBLE, rd)) + function clause execute (STORECON(aq, rl, rs2, rs1, width, rd)) = { (*(bit)*) status := if speculate_conditional_success() then 0 else 1; wGPR(rd) := (bit[64]) (EXTZ([status])); @@ -429,26 +319,45 @@ function clause execute (STORECON(aq, rl, rs2, rs1, width, rd)) = { }; } +(********************************************************************) union ast member (amoop, bool, bool, regno, regno, word_width, regno) AMO -function clause decode (0b00001 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOSWAP, aq, rl, rs2, rs1, WORD, rd)) -function clause decode (0b00001 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOSWAP, aq, rl, rs2, rs1, DOUBLE, rd)) -function clause decode (0b00000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOADD , aq, rl, rs2, rs1, WORD, rd)) -function clause decode (0b00000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOADD , aq, rl, rs2, rs1, DOUBLE, rd)) -function clause decode (0b00100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOXOR , aq, rl, rs2, rs1, WORD, rd)) -function clause decode (0b00100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOXOR , aq, rl, rs2, rs1, DOUBLE, rd)) -function clause decode (0b01100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOAND , aq, rl, rs2, rs1, WORD, rd)) -function clause decode (0b01100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOAND , aq, rl, rs2, rs1, DOUBLE, rd)) -function clause decode (0b01000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOOR , aq, rl, rs2, rs1, WORD, rd)) -function clause decode (0b01000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOOR , aq, rl, rs2, rs1, DOUBLE, rd)) -function clause decode (0b10000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOMIN , aq, rl, rs2, rs1, WORD, rd)) -function clause decode (0b10000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOMIN , aq, rl, rs2, rs1, DOUBLE, rd)) -function clause decode (0b10100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOMAX , aq, rl, rs2, rs1, WORD, rd)) -function clause decode (0b10100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOMAX , aq, rl, rs2, rs1, DOUBLE, rd)) -function clause decode (0b11000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOMINU, aq, rl, rs2, rs1, WORD, rd)) -function clause decode (0b11000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOMINU, aq, rl, rs2, rs1, DOUBLE, rd)) -function clause decode (0b11100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = Some(AMO(AMOMAXU, aq, rl, rs2, rs1, WORD, rd)) -function clause decode (0b11100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = Some(AMO(AMOMAXU, aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b00001 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = + Some(AMO(AMOSWAP, aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b00001 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = + Some(AMO(AMOSWAP, aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b00000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = + Some(AMO(AMOADD , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b00000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = + Some(AMO(AMOADD , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b00100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = + Some(AMO(AMOXOR , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b00100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = + Some(AMO(AMOXOR , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b01100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = + Some(AMO(AMOAND , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b01100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = + Some(AMO(AMOAND , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b01000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = + Some(AMO(AMOOR , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b01000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = + Some(AMO(AMOOR , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b10000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = + Some(AMO(AMOMIN , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b10000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = + Some(AMO(AMOMIN , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b10100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = + Some(AMO(AMOMAX , aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b10100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = + Some(AMO(AMOMAX , aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b11000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = + Some(AMO(AMOMINU, aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b11000 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = + Some(AMO(AMOMINU, aq, rl, rs2, rs1, DOUBLE, rd)) +function clause decode (0b11100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0101111) = + Some(AMO(AMOMAXU, aq, rl, rs2, rs1, WORD, rd)) +function clause decode (0b11100 : [aq] : [rl] : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0101111) = + Some(AMO(AMOMAXU, aq, rl, rs2, rs1, DOUBLE, rd)) function clause execute (AMO(op, aq, rl, rs2, rs1, width, rd)) = { (bit[64]) addr := rGPR(rs1); @@ -486,6 +395,8 @@ function clause execute (AMO(op, aq, rl, rs2, rs1, width, rd)) = { }; } +(********************************************************************) + function clause decode _ = None end ast diff --git a/risc-v/riscv_types.sail b/risc-v/riscv_types.sail new file mode 100644 index 00000000..a11d5561 --- /dev/null +++ b/risc-v/riscv_types.sail @@ -0,0 +1,165 @@ +default Order dec + +function forall 'a. 'a effect { escape } not_implemented((string) message) = + exit message + +typedef regval = bit[64] +typedef regno = bit[5] + +(* register (regval) x0 is hard-wired zero *) +register (regval) x1 +register (regval) x2 +register (regval) x3 +register (regval) x4 +register (regval) x5 +register (regval) x6 +register (regval) x7 +register (regval) x8 +register (regval) x9 +register (regval) x10 +register (regval) x11 +register (regval) x12 +register (regval) x13 +register (regval) x14 +register (regval) x15 +register (regval) x16 +register (regval) x17 +register (regval) x18 +register (regval) x19 +register (regval) x20 +register (regval) x21 +register (regval) x22 +register (regval) x23 +register (regval) x24 +register (regval) x25 +register (regval) x26 +register (regval) x27 +register (regval) x28 +register (regval) x29 +register (regval) x30 +register (regval) x31 + +register (bit[64]) PC +register (bit[64]) nextPC + +let (vector <1, 31, inc, (register<(regval)>)>) GPRs = + [ (* x0, *) x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, + x15, x16, x17, x18, x19, x20, x21, x22, x23, x24, x25, x26, x27, + x28, x29, x30, x31 + ] + +function (regval) rGPR ((regno) r) = + if (r == 0) then + 0 + else + GPRs[r] + +function unit wGPR((regno) r, (regval) v) = + if (r != 0) then + GPRs[r] := v + +function unit effect { escape } check_alignment( (bit[64]) addr, (nat) width) = + if (unsigned(addr) mod width != 0) then + exit "misaligned memory access" + +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_acquire +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_strong_acquire +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved_acquire +val extern forall Nat 'n. ( bit[64] , [|'n|] ) -> (bit[8 * 'n]) effect { rmem } MEMr_reserved_strong_acquire + +function forall Nat 'n. (bit[8 * 'n]) effect { rmem, escape } mem_read( (bit[64]) addr, ([|'n|]) width, (bool) aq, (bool) rl, (bool) res) = +{ + if (aq | res) then + check_alignment(addr, width); + + switch (aq, rl, res) { + case (false, false, false) -> MEMr(addr, width) + case (true, false, false) -> MEMr_acquire(addr, width) + case (false, false, true) -> MEMr_reserved(addr, width) + case (true, false, true) -> MEMr_reserved_acquire(addr, width) + case (false, true, false) -> not_implemented("load.rl is not implemented") + case (true, true, false) -> MEMr_strong_acquire(addr, width) + case (false, true, true) -> not_implemented("lr.rl is not implemented") + case (true, true, true) -> MEMr_reserved_strong_acquire(addr, width) + } +} + +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_release +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_strong_release +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_release +val extern forall Nat 'n. ( bit[64] , [|'n|]) -> unit effect { eamem } MEMea_conditional_strong_release + +function forall Nat 'n. unit effect { eamem, escape } mem_write_ea( (bit[64]) addr , ([|'n|]) width, (bool) aq, (bool) rl, (bool) con) = +{ + if (rl | con) then + check_alignment(addr, width); + + switch (aq, rl, con) { + case (false, false, false) -> MEMea(addr, width) + case (false, true, false) -> MEMea_release(addr, width) + case (false, false, true) -> MEMea_conditional(addr, width) + case (false, true , true) -> MEMea_conditional_release(addr, width) + case (true, false, false) -> not_implemented("store.aq is not implemented") + case (true, true, false) -> MEMea_strong_release(addr, width) + case (true, false, true) -> not_implemented("sc.aq is not implemented") + case (true, true , true) -> MEMea_conditional_strong_release(addr, width) + } +} + +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_release +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_strong_release +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional_release +val extern forall Nat 'n. ( bit[64] , [|'n|] , bit[8*'n]) -> unit effect { wmv } MEMval_conditional_strong_release + +function forall Nat 'n. unit effect { wmv, escape } mem_write_value( (bit[64]) addr , ([|'n|]) width , (bit[8*'n]) value, (bool) aq, (bool) rl, (bool) con) = +{ + if (rl | con) then + check_alignment(addr, width); + + switch (aq, rl, con) { + case (false, false, false) -> MEMval(addr, width, value) + case (false, true, false) -> MEMval_release(addr, width, value) + case (false, false, true) -> MEMval_conditional(addr, width, value) + case (false, true, true) -> MEMval_conditional_release(addr, width, value) + case (true, false, false) -> not_implemented("store.aq is not implemented") + case (true, true, false) -> MEMval_strong_release(addr, width, value) + case (true, false, true) -> not_implemented("sc.aq is not implemented") + case (true, true, true) -> MEMval_conditional_strong_release(addr, width, value) + } +} + +val extern unit -> bool effect {exmem} speculate_conditional_success + +val extern unit -> unit effect { barr } MEM_fence_rw_rw +val extern unit -> unit effect { barr } MEM_fence_r_rw +val extern unit -> unit effect { barr } MEM_fence_rw_w +val extern unit -> unit effect { barr } MEM_fence_w_w +val extern unit -> unit effect { barr } MEM_fence_i + +typedef uop = enumerate {LUI; AUIPC} (* upper immediate ops *) +typedef bop = enumerate {BEQ; BNE; BLT; BGE; BLTU; BGEU} (* branch ops *) +typedef iop = enumerate {ADDI; SLTI; SLTIU; XORI; ORI; ANDI} (* immediate ops *) +typedef sop = enumerate {SLLI; SRLI; SRAI} (* shift ops *) +typedef rop = enumerate {ADD; SUB; SLL; SLT; SLTU; XOR; SRL; SRA; OR; AND} (* reg-reg ops *) +typedef ropw = enumerate {ADDW; SUBW; SLLW; SRLW; SRAW} (* reg-reg 32-bit ops *) +typedef amoop = enumerate {AMOSWAP; AMOADD; AMOXOR; AMOAND; AMOOR; + AMOMIN; AMOMAX; AMOMINU; AMOMAXU} (* AMO ops *) + +typedef word_width = enumerate {BYTE; HALF; WORD; DOUBLE} + +(********************************************************************) + +(* Ideally these would be sail builtin *) +function (bit[64]) shift_right_arith64 ((bit[64]) v, (bit[6]) shift) = + let (bit[128]) v128 = EXTS(v) in + (v128 >> shift)[63..0] + +function (bit[32]) shift_right_arith32 ((bit[32]) v, (bit[5]) shift) = + let (bit[64]) v64 = EXTS(v) in + (v64 >> shift)[31..0] -- cgit v1.2.3 From 4c0d3acebf8fd37b3ef1481ac282f5c47464310f Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Wed, 27 Sep 2017 14:34:18 +0100 Subject: fixed the RISC-V Makefile --- risc-v/Makefile | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/risc-v/Makefile b/risc-v/Makefile index d027556e..8449c7c4 100644 --- a/risc-v/Makefile +++ b/risc-v/Makefile @@ -4,10 +4,11 @@ SOURCES:=riscv_types.sail riscv.sail ../etc/regfp.sail riscv_regfp.sail all: lem_ast shallow lem_ast: $(SOURCES) $(SAIL) - $(SAIL) -lem_ast $(SOURCES) + $(SAIL) -lem_ast $(SOURCES) -o riscv shallow: $(SOURCES) $(SAIL) - $(SAIL) -lem_lib Riscv_extras_embed -lem $(SOURCES) + $(SAIL) -lem_lib Riscv_extras_embed -lem $(SOURCES) -o riscv clean: - rm -f riscv.lem riscv_embed*.lem + rm -f riscv.lem riscv_embed*.lem riscv_toFromInterp.lem + rm -f riscv_type*.lem -- cgit v1.2.3 From fd06b634ae814a28644eabe93880eb7f4967a9c0 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Fri, 29 Sep 2017 15:40:56 +0100 Subject: x86: add bit set, reset, complement operations. --- x86/x64.sail | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 73 insertions(+) diff --git a/x86/x64.sail b/x86/x64.sail index dfa92fd3..ae867747 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -130,6 +130,14 @@ typedef wsize = const union { unit Sz64; } +function ([|8:64|]) size_to_int((wsize) s) = + switch(s) { + case (Sz8(_)) -> 8 + case Sz16 -> 16 + case Sz32 -> 32 + case Sz64 -> 64 + } + typedef base = const union { unit NoBase; unit RipBase; @@ -154,12 +162,19 @@ typedef imm_rm = const union { qword Imm; } +typedef bit_offset = const union { + (rm, qword) Bit_rm_imm; + (rm, regn) Bit_rm_r; +} + typedef monop_name = enumerate { Dec; Inc; Not; Neg } typedef binop_name = enumerate { Add; Or; Adc; Sbb; And; Sub; Xor; Cmp; Rol; Ror; Rcl; Rcr; Shl; Shr; Test; Sar } +typedef bitop_name = enumerate { Bts; Btc; Btr } + function binop_name opc_to_binop_name ((bit[4]) opc) = switch opc { @@ -319,6 +334,24 @@ function qword get_ea_address ((ea) e) = function unit jump_to_ea ((ea) e) = RIP := call_dest_from_ea(e) +function (ea, nat) bit_offset_ea ((wsize) sz, (bit_offset) bo) = + let s = size_to_int (sz) in + switch bo { + case (Bit_rm_imm (r_m, imm)) -> + let base_ea = ea_rm (sz, r_m) in + switch (base_ea) { + case (Ea_r(_, r)) -> (Ea_r(sz, r), imm mod s) + case (Ea_m(_, a)) -> (Ea_m(sz, a), imm mod s) + } + case (Bit_rm_r (r_m, r)) -> + let base_ea = ea_rm (sz, r_m) in + let offset = REG[r] in + switch (base_ea) { + case (Ea_r(_, r)) -> (Ea_r(sz, r), offset mod s) + case (Ea_m(_, a)) -> (Ea_m(Sz64, a + (offset div 8)), offset mod 64) + } + } + (* EFLAG updates *) function bit byte_parity ((byte) b) = @@ -584,6 +617,25 @@ function clause execute (Binop (locked,bop,sz,ds)) = let (e, val_dst, val_src) = read_dest_src_ea (locked, sz, ds) in write_binop (locked, sz, bop, val_dst, val_src, e) +(* ========================================================================== + Bitop + ========================================================================== *) + +union ast member (bool,bitop_name,wsize,bit_offset) Bitop + +function clause execute (Bitop (locked,bop,sz,boffset)) = + let (base_ea, offset) = bit_offset_ea (sz, boffset) in { + word := EA(locked, base_ea); + bitval := word[offset]; + word[offset] := switch(bop) { + case Bts -> bitone + case Btc -> (~ (bitval)) + case Btr -> bitzero + }; + CF := bitval; + wEA(locked, base_ea) := word; + } + (* ========================================================================== CALL ========================================================================== *) @@ -1376,6 +1428,27 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( aR := append(aRs, aR); } } + case(Bitop (locked, bitop, sz, bitoff)) -> { + let rk = if locked then Read_X86_locked else Read_plain in + let wk = if locked then Write_X86_locked else Write_plain in + let (ik', iRs, oRs, aRs) = switch(bitoff) { + case (Bit_rm_imm (r_m, imm)) -> + let (m, rs, ars) = regfp_rm(r_m) in + (if m then IK_mem_rmw(rk, wk) else IK_simple, + append(rs, ars), rs, ars) + case (Bit_rm_r (r_m, r)) -> + let rfp = RFull(GPRstr[r]) in + let (m, rs, ars) = regfp_rm(r_m) in + (if m then IK_mem_rmw(rk, wk) else IK_simple, + rfp::append(rs, ars), rs, + if m then (rfp::ars) else ars) (* in memory case r is a third input to address! *) + } in { + ik := ik'; + iR := append(iRs, iR); + oR := RFull("CF")::append(oRs, oR); + aR := append(aRs, aR); + } + } case(CALL (irm) ) -> let (m, rs, ars) = regfp_imm_rm (irm) in { iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); -- cgit v1.2.3 From efa98fb796fdab5486193f792adf999826fde7b4 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 29 Sep 2017 17:02:38 +0100 Subject: fix deep_shallow_convert, stop using interp_interface.instruction for most things, SF and CP bugfixing --- src/gen_lib/deep_shallow_convert.lem | 29 ++++++++++++++++++-- src/lem_interp/interp.lem | 4 +-- src/lem_interp/interp_inter_imp.lem | 53 ++++++++++++++++++------------------ src/lem_interp/interp_interface.lem | 10 +++++-- src/lem_interp/sail_impl_base.lem | 2 -- 5 files changed, 62 insertions(+), 36 deletions(-) diff --git a/src/gen_lib/deep_shallow_convert.lem b/src/gen_lib/deep_shallow_convert.lem index 86365b78..5a0dd99e 100644 --- a/src/gen_lib/deep_shallow_convert.lem +++ b/src/gen_lib/deep_shallow_convert.lem @@ -15,10 +15,10 @@ let toInterValueBool = function | false -> Interp_ast.V_lit (L_aux (L_zero) Unknown) end let rec fromInterpValueBool v = match v with - | Interp_ast.V_lit (L_aux (L_true) _) -> true - | Interp_ast.V_lit (L_aux (L_false) _) -> false | Interp_ast.V_lit (L_aux (L_one) _) -> true + | Interp_ast.V_lit (L_aux (L_true) _) -> true | Interp_ast.V_lit (L_aux (L_zero) _) -> false + | Interp_ast.V_lit (L_aux (L_false) _) -> false | Interp_ast.V_tuple [v] -> fromInterpValueBool v | v -> failwith ("fromInterpValue bool: unexpected value. " ^ Interp.debug_print_value v) @@ -78,7 +78,7 @@ let rec fromInterpValueBitU v = match v with | Interp_ast.V_lit (L_aux (L_zero) _) -> B0 | Interp_ast.V_lit (L_aux (L_undef) _) -> BU | Interp_ast.V_lit (L_aux (L_true) _) -> B1 - | Interp_ast.V_lit (L_aux (L_false) _) -> B0 + | Interp_ast.V_lit (L_aux (L_false) _) -> B0 | Interp_ast.V_tuple [v] -> fromInterpValueBitU v | v -> failwith ("fromInterpValue bitU: unexpected value. " ^ Interp.debug_print_value v) @@ -506,18 +506,41 @@ instance (ToFromInterpValue barrier_kind) end +let trans_kindToInterpValue = function + | Transaction_start -> V_ctor (Id_aux (Id "Transaction_start") Unknown) (T_id "trans_kind") (C_Enum 0) (toInterpValue ()) + | Transaction_commit -> V_ctor (Id_aux (Id "Transaction_commit") Unknown) (T_id "trans_kind") (C_Enum 1) (toInterpValue ()) + | Transaction_abort -> V_ctor (Id_aux (Id "Transaction_abort") Unknown) (T_id "trans_kind") (C_Enum 2) (toInterpValue ()) + end +let rec trans_kindFromInterpValue v = match v with + | V_ctor (Id_aux (Id "Transaction_start") _) _ _ v -> Transaction_start + | V_ctor (Id_aux (Id "Transaction_commit") _) _ _ v -> Transaction_commit + | V_ctor (Id_aux (Id "Transaction_abort") _) _ _ v -> Transaction_abort + | V_tuple [v] -> trans_kindFromInterpValue v + | v -> failwith ("fromInterpValue trans_kind: unexpected value. " ^ + Interp.debug_print_value v) + end +instance (ToFromInterpValue trans_kind) + let toInterpValue = trans_kindToInterpValue + let fromInterpValue = trans_kindFromInterpValue +end + + let instruction_kindToInterpValue = function | IK_barrier v -> V_ctor (Id_aux (Id "IK_barrier") Unknown) (T_id "instruction_kind") C_Union (toInterpValue v) | IK_mem_read v -> V_ctor (Id_aux (Id "IK_mem_read") Unknown) (T_id "instruction_kind") C_Union (toInterpValue v) | IK_mem_write v -> V_ctor (Id_aux (Id "IK_mem_write") Unknown) (T_id "instruction_kind") C_Union (toInterpValue v) + | IK_mem_rmw v -> V_ctor (Id_aux (Id "IK_mem_rmw") Unknown) (T_id "instruction_kind") C_Union (toInterpValue v) | IK_cond_branch -> V_ctor (Id_aux (Id "IK_cond_branch") Unknown) (T_id "instruction_kind") C_Union (toInterpValue ()) + | IK_trans v -> V_ctor (Id_aux (Id "IK_trans") Unknown) (T_id "instruction_kind") C_Union (toInterpValue v) | IK_simple -> V_ctor (Id_aux (Id "IK_simple") Unknown) (T_id "instruction_kind") C_Union (toInterpValue ()) end let rec instruction_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "IK_barrier") _) _ _ v -> IK_barrier (fromInterpValue v) | V_ctor (Id_aux (Id "IK_mem_read") _) _ _ v -> IK_mem_read (fromInterpValue v) | V_ctor (Id_aux (Id "IK_mem_write") _) _ _ v -> IK_mem_write (fromInterpValue v) + | V_ctor (Id_aux (Id "IK_mem_rmw") _) _ _ v -> IK_mem_rmw (fromInterpValue v) | V_ctor (Id_aux (Id "IK_cond_branch") _) _ _ v -> IK_cond_branch + | V_ctor (Id_aux (Id "IK_trans") _) _ _ v -> IK_trans (fromInterpValue v) | V_ctor (Id_aux (Id "IK_simple") _) _ _ v -> IK_simple | V_tuple [v] -> instruction_kindFromInterpValue v | v -> failwith ("fromInterpValue instruction_kind: unexpected value. " ^ diff --git a/src/lem_interp/interp.lem b/src/lem_interp/interp.lem index 58874fa6..f00458b7 100644 --- a/src/lem_interp/interp.lem +++ b/src/lem_interp/interp.lem @@ -1424,8 +1424,8 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = | V_ctor (Id_aux cid _) t ckind v -> if id = cid then (match (pats,detaint v) with - | ([],(V_lit (L_aux L_unit _))) -> (true,true,eenv) - | ([P_aux (P_lit (L_aux L_unit _)) _],(V_lit (L_aux L_unit _))) -> (true,true,eenv) + | ([],(V_lit (L_aux L_unit _))) -> (true,false,eenv) + | ([P_aux (P_lit (L_aux L_unit _)) _],(V_lit (L_aux L_unit _))) -> (true,false,eenv) | ([p],_) -> match_pattern t_level p v | _ -> (false,false,eenv) end) else (false,false,eenv) diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 6ee13d60..52acae1e 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -469,7 +469,7 @@ let translate_address top_level end_flag thunk_name registers address = let (arg,_) = Interp.to_exp int_mode Interp.eenv intern_val in let internal_direction = if direction = D_increasing then Interp_ast.IInc else Interp_ast.IDec in let (address_error,events) = - interp_to_value_helper debug (Just (Opcode bytes)) Ivh_translate val_str ("",[]) internal_direction + interp_to_value_helper debug (Just (Opcode bytes)) Ivh_translate val_str (V_list []) internal_direction registers [] false (fun _ -> Interp.resume int_mode @@ -504,17 +504,16 @@ let intern_instruction direction (name,parms) = Interp_ast.V_ctor (Interp.id_of_string name) (T_id "ast") Interp_ast.C_Union (Interp_ast.V_tuple (List.map (value_of_instruction_param direction) parms)) -let instruction_analysis top_level end_flag thunk_name regn_to_reg_details registers instruction = +let instruction_analysis top_level end_flag thunk_name regn_to_reg_details registers (instruction : Interp_ast.value) = let (Context top_env direction _ _ _ _ _ _ _ _ _) = top_level in let (Interp.Env _ _ _ _ _ _ _ _ debug) = top_env in let mode = make_mode true false debug in let int_mode = mode.internal_mode in - let intern_val = intern_instruction direction instruction in - let val_str = Interp.string_of_value intern_val in - let (arg,_) = Interp.to_exp int_mode Interp.eenv intern_val in + let val_str = Interp.string_of_value instruction in + let (arg,_) = Interp.to_exp int_mode Interp.eenv instruction in let internal_direction = if direction = D_increasing then Interp_ast.IInc else Interp_ast.IDec in let (analysis_or_error,events) = - interp_to_value_helper debug Nothing Ivh_analysis val_str ("",[]) internal_direction + interp_to_value_helper debug Nothing Ivh_analysis val_str (V_list []) internal_direction registers [] false (fun _ -> Interp.resume int_mode @@ -680,7 +679,7 @@ let decode_to_instruction top_level registers value : instruction_or_decode_erro let (arg,_) = Interp.to_exp mode Interp.eenv intern_val in let internal_direction = if direction = D_increasing then Interp_ast.IInc else Interp_ast.IDec in let (instr_decoded_error,events) = - interp_to_value_helper debug (Just value) Ivh_decode val_str ("",[]) internal_direction registers [] false + interp_to_value_helper debug (Just value) Ivh_decode val_str (V_list []) internal_direction registers [] false (fun _ -> Interp.resume mode (Interp.Thunk_frame @@ -688,9 +687,9 @@ let decode_to_instruction top_level registers value : instruction_or_decode_erro top_env Interp.eenv (Interp.emem "decode top level") Interp.Top) Nothing) in match (instr_decoded_error) with | Ivh_value instr -> - let instr_external = interp_value_to_instr_external top_level instr in + (* let instr_external = interp_value_to_instr_external top_level instr in*) let (instr_decoded_error,events) = - interp_to_value_helper debug (Just value) Ivh_unsupported val_str instr_external internal_direction + interp_to_value_helper debug (Just value) Ivh_unsupported val_str instr (*instr_external*) internal_direction registers [] false (fun _ -> Interp.resume mode @@ -699,7 +698,7 @@ let decode_to_instruction top_level registers value : instruction_or_decode_erro (Interp_ast.Unknown, Nothing)) top_env Interp.eenv (Interp.emem "decode second top level") Interp.Top) Nothing) in match (instr_decoded_error) with - | Ivh_value _ -> IDE_instr instr_external instr + | Ivh_value _ -> IDE_instr instr (*instr_external*) | Ivh_value_after_exn v -> Assert_extra.failwith "supported_instructions called exit, so support will be needed for that now" | Ivh_error err -> IDE_decode_error err @@ -713,9 +712,9 @@ end let decode_to_istate (top_level:context) registers (value:opcode) : i_state_or_error = let (Context top_env _ _ _ _ _ _ _ _ _ _) = top_level in match decode_to_instruction top_level registers value with - | IDE_instr instr instrv -> + | IDE_instr instr -> let mode = make_interpreter_mode true false in - let (arg,_) = Interp.to_exp mode Interp.eenv instrv in + let (arg,_) = Interp.to_exp mode Interp.eenv instr in Instr instr (IState (Interp.Thunk_frame (E_aux (E_app (Id_aux (Id "execute") Interp_ast.Unknown) [arg]) (Interp_ast.Unknown,Nothing)) @@ -750,11 +749,11 @@ let instr_external_to_interp_value top_level instr = Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id name) Interp_ast.Unknown) (T_id "ast") Interp_ast.C_Union parmsV -val instruction_to_istate : context -> instruction -> instruction_state -let instruction_to_istate (top_level:context) (((name, parms) as instr):instruction) : instruction_state = +val instruction_to_istate : context -> Interp_ast.value -> instruction_state +let instruction_to_istate (top_level:context) (instr:Interp_ast.value) : instruction_state = let mode = make_interpreter_mode true false in let (Context top_env _ _ _ _ _ _ _ _ _ _) = top_level in - let ast_node = fst (Interp.to_exp mode Interp.eenv (instr_external_to_interp_value top_level instr)) in + let ast_node = fst (Interp.to_exp mode Interp.eenv instr) in (IState (Interp.Thunk_frame (E_aux (E_app (Id_aux (Id "execute") Interp_ast.Unknown) [ast_node]) @@ -1092,7 +1091,7 @@ and state_to_outcome_s pp_instruction_state mode state = (fun env -> interp_exhaustive mode.internal_mode.Interp.debug (Just env) state)) ) -val initial_outcome_s_of_instruction : (instruction_state -> unit -> (string * string)) -> context -> interp_mode -> instruction -> Sail_impl_base.outcome_s unit +val initial_outcome_s_of_instruction : (instruction_state -> unit -> (string * string)) -> context -> interp_mode -> Interp_ast.value -> Sail_impl_base.outcome_s unit let initial_outcome_s_of_instruction pp_instruction_state context mode instruction = let state = instruction_to_istate context instruction in state_to_outcome_s pp_instruction_state mode state @@ -1222,14 +1221,15 @@ let nia_address_of_event nia_reg (event: event) : maybe (maybe address) = | _ -> Nothing end -let nias_of_instruction +let nias_of_instruction + top_level thread_ism (nia_address: list (maybe address)) (* Nothing for unknown/undef*) (regs_in: list reg_name) - (instruction: instruction) + (instruction: Interp_ast.value) : list nia = - let (instruction_name, instruction_fields) = instruction in + let (instruction_name, instruction_fields) = interp_value_to_instr_external top_level instruction in let unknown_nia_address = List.elem Nothing nia_address in @@ -1390,7 +1390,9 @@ let nias_of_instruction | (s1, s2) -> failwith ("unexpected (thread_ism, instruction_name): (" ^ s1 ^ ", " ^ s2 ^ ")") end + let interp_instruction_analysis + top_level (interp_exhaustive : ((list (reg_name * register_value)) -> list event)) instruction nia_reg ism environment = @@ -1403,7 +1405,7 @@ let interp_instruction_analysis let nia_address = List.mapMaybe (nia_address_of_event nia_reg) es in - let nias = nias_of_instruction ism nia_address regs_in instruction in + let nias = nias_of_instruction top_level ism nia_address regs_in instruction in let dia = DIA_none in (* FIX THIS! *) @@ -1478,29 +1480,28 @@ val print_and_fail_of_inequal : forall 'a. Show 'a => (instruction -> string) -> (string * 'a) -> (string * 'a) -> unit let print_and_fail_if_inequal - (print_endline,pp_instruction,instruction) + (print_endline,instruction) (name1,xs1) (name2,xs2) = if xs1 = xs2 then () else let () = print_endline (name1^": "^show xs1) in let () = print_endline (name2^": "^show xs2) in - failwith (name1^" and "^ name2^" inequal for instruction " ^ pp_instruction instruction) + failwith (name1^" and "^ name2^" inequal for instruction: \n" ^ Interp.string_of_value instruction) let interp_compare_analyses print_endline - pp_instruction (non_pseudo_registers : set reg_name -> set reg_name) context endianness interp_exhaustive - instruction + (instruction : Interp_ast.value) nia_reg ism environment analysis_function reg_info = let (regs_in1,regs_out1,regs_feeding_address1,nias1,dia1,inst_kind1) = - interp_instruction_analysis interp_exhaustive instruction nia_reg ism + interp_instruction_analysis context interp_exhaustive instruction nia_reg ism environment in let (regs_in1S,regs_out1S,regs_feeding_address1S,nias1S) = (Set.fromList regs_in1, @@ -1525,7 +1526,7 @@ let interp_compare_analyses non_pseudo_registers regs_out2S, non_pseudo_registers regs_feeding_address2S) in - let aux = (print_endline,pp_instruction,instruction) in + let aux = (print_endline,instruction) in let () = (print_and_fail_if_inequal aux) ("regs_in exhaustive",regs_in1S) ("regs_in hand",regs_in2S) in diff --git a/src/lem_interp/interp_interface.lem b/src/lem_interp/interp_interface.lem index dcc9f537..07d9e2b3 100644 --- a/src/lem_interp/interp_interface.lem +++ b/src/lem_interp/interp_interface.lem @@ -104,6 +104,10 @@ end and the potential static effects from the funcl clause for this instruction Follows the form of the instruction in instruction_extractor, but populates the parameters with actual values *) + + +type instruction_field_value = list bit + type instruction = (string * list (string * instr_parm_typ * instruction_field_value)) let {coq} instructionEqual i1 i2 = match (i1,i2) with @@ -117,7 +121,7 @@ let inline ~{coq} instructionInequal = unsafe_structural_inequality type v_kind = Bitv | Bytev type decode_error = - | Unsupported_instruction_error of instruction + | Unsupported_instruction_error of Interp_ast.value | Not_an_instruction_error of opcode | Internal_error of string @@ -264,12 +268,12 @@ val initial_instruction_state : context -> string -> list register_value -> inst (* string is a function name, list of value are the parameters to that function *) type instruction_or_decode_error = - | IDE_instr of instruction * Interp_ast.value + | IDE_instr of Interp_ast.value | IDE_decode_error of decode_error (** propose to remove the following type and use the above instead *) type i_state_or_error = - | Instr of instruction * instruction_state + | Instr of Interp_ast.value * instruction_state | Decode_error of decode_error diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 6957bb95..4f07f574 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -106,8 +106,6 @@ type register_value = <| type byte_lifted = Byte_lifted of list bit_lifted (* of length 8 *) (*MSB first everywhere*) -type instruction_field_value = list bit - type byte = Byte of list bit (* of length 8 *) (*MSB first everywhere*) type address_lifted = Address_lifted of list byte_lifted (* of length 8 for 64bit machines*) * maybe integer -- cgit v1.2.3 From 9f58a1bbaadd0a679413a8cb424acfb6255f8eca Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 29 Sep 2017 17:55:48 +0100 Subject: fix those build errors --- src/lem_interp/run_with_elf.ml | 10 +++++++--- src/lem_interp/run_with_elf_cheri.ml | 6 ++++-- src/lem_interp/run_with_elf_cheri128.ml | 6 ++++-- 3 files changed, 15 insertions(+), 7 deletions(-) diff --git a/src/lem_interp/run_with_elf.ml b/src/lem_interp/run_with_elf.ml index 2a1783db..98b98a03 100644 --- a/src/lem_interp/run_with_elf.ml +++ b/src/lem_interp/run_with_elf.ml @@ -1198,12 +1198,16 @@ let rec fde_loop count context model mode track_dependencies addr_trans = let opcode = Opcode (get_opcode pc) in let (instruction,istate) = match Interp_inter_imp.decode_to_istate context None opcode with | Instr(instruction,istate) -> - interactf "\n**** Running: %s ****\n" (Printing_functions.instruction_to_string instruction); + let instruction = interp_value_to_instr_external context instruction in + interactf "\n**** Running: %s ****\n" + (Printing_functions.instruction_to_string instruction); (instruction,istate) | Decode_error d -> (match d with - | Interp_interface.Unsupported_instruction_error instr -> - errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instr) + | Interp_interface.Unsupported_instruction_error instruction -> + let instruction = interp_value_to_instr_external context instruction in + errorf "\n**** Encountered unsupported instruction %s ****\n" + (Printing_functions.instruction_to_string instruction) | Interp_interface.Not_an_instruction_error op -> (match op with | Opcode bytes -> diff --git a/src/lem_interp/run_with_elf_cheri.ml b/src/lem_interp/run_with_elf_cheri.ml index e773bf5b..b879f702 100644 --- a/src/lem_interp/run_with_elf_cheri.ml +++ b/src/lem_interp/run_with_elf_cheri.ml @@ -1290,12 +1290,14 @@ let rec fde_loop count context model mode track_dependencies addr_trans = let opcode = Opcode (get_opcode pc) in let (instruction,istate) = match Interp_inter_imp.decode_to_istate context None opcode with | Instr(instruction,istate) -> + let instruction = interp_value_to_instr_external context instruction in interactf "\n**** Running: %s ****\n" (Printing_functions.instruction_to_string instruction); (instruction,istate) | Decode_error d -> (match d with - | Interp_interface.Unsupported_instruction_error instr -> - errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instr) + | Interp_interface.Unsupported_instruction_error instruction -> + let instruction = interp_value_to_instr_external context instruction in + errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instruction) | Interp_interface.Not_an_instruction_error op -> (match op with | Opcode bytes -> diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index cd2e7312..3ad507bc 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -1290,12 +1290,14 @@ let rec fde_loop count context model mode track_dependencies addr_trans = let opcode = Opcode (get_opcode pc) in let (instruction,istate) = match Interp_inter_imp.decode_to_istate context None opcode with | Instr(instruction,istate) -> + let instruction = interp_value_to_instr_external context instruction in interactf "\n**** Running: %s ****\n" (Printing_functions.instruction_to_string instruction); (instruction,istate) | Decode_error d -> (match d with - | Interp_interface.Unsupported_instruction_error instr -> - errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instr) + | Interp_interface.Unsupported_instruction_error instruction -> + let instruction = interp_value_to_instr_external context instruction in + errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instruction) | Interp_interface.Not_an_instruction_error op -> (match op with | Opcode bytes -> -- cgit v1.2.3 From fcf8270b4f46b4cd92534807292694bfd6d14457 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Sun, 1 Oct 2017 12:02:07 +0100 Subject: fixed JALR: do the register write first to allow po-later reads --- risc-v/riscv.sail | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index 8658ae96..f36dba57 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -24,11 +24,12 @@ union ast member ((bit[21]), regno) JAL function clause decode ((bit[20]) imm : (regno) rd : 0b1101111) = Some (JAL(imm[19] : imm[7..0] : imm[8] : imm[18..13] : imm[12..9] : 0b0, rd)) -function clause execute (JAL(imm, rd)) = - let (bit[64]) offset = EXTS(imm) in { - nextPC := PC + offset; - wGPR(rd, PC + 4); - } +function clause execute (JAL(imm, rd)) = { + (bit[64]) pc := PC; + wGPR(rd, pc + 4); + (bit[64]) offset := EXTS(imm); + nextPC := pc + offset; +} (********************************************************************) union ast member((bit[12]), regno, regno) JALR @@ -36,11 +37,12 @@ union ast member((bit[12]), regno, regno) JALR function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b1100111) = Some(JALR(imm, rs1, rd)) -function clause execute (JALR(imm, rs1, rd)) = - let (bit[64]) newPC = rGPR(rs1) + EXTS(imm) in { - nextPC := newPC[63..1] : 0b0; - wGPR(rd, PC + 4); - } +function clause execute (JALR(imm, rs1, rd)) = { + (* write rd before anything else to prevent unintended strength *) + wGPR(rd, PC + 4); + (bit[64]) newPC := rGPR(rs1) + EXTS(imm); + nextPC := newPC[63..1] : 0b0; +} (********************************************************************) union ast member ((bit[13]), regno, regno, bop) BTYPE -- cgit v1.2.3 From 4d3e8058659d32e0b2668950fb1bb9d2a80cd7a1 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 2 Oct 2017 15:49:35 +0100 Subject: cheri: fix swapped cmovz and cmovn. --- cheri/cheri_insts.sail | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/cheri/cheri_insts.sail b/cheri/cheri_insts.sail index 8b5d9dd0..caa87e55 100644 --- a/cheri/cheri_insts.sail +++ b/cheri/cheri_insts.sail @@ -468,9 +468,9 @@ function clause execute (CClearTag(cd, cb)) = } union ast member (regno,regno,regno,bool) CMOVX -function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) rt : 0b011100) = Some(CMOVX(cd, cb, rt, false)) (* CMOVN *) -function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) rt : 0b011011) = Some(CMOVX(cd, cb, rt, true)) (* CMOVZ *) -function clause execute (CMOVX(cd, cb, rt, ismovz)) = +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) rt : 0b011100) = Some(CMOVX(cd, cb, rt, true)) (* CMOVN *) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) rt : 0b011011) = Some(CMOVX(cd, cb, rt, false)) (* CMOVZ *) +function clause execute (CMOVX(cd, cb, rt, ismovn)) = { (* START_CMOVX *) checkCP2usable(); @@ -478,7 +478,7 @@ function clause execute (CMOVX(cd, cb, rt, ismovz)) = raise_c2_exception(CapEx_AccessSystemRegsViolation, cd) else if (register_inaccessible(cb)) then raise_c2_exception(CapEx_AccessSystemRegsViolation, cb) - else if ((rGPR(rt) == 0) ^ ismovz) then + else if ((rGPR(rt) == 0) ^ ismovn) then writeCapReg(cd) := readCapReg(cb); (* END_CMOVX *) } -- cgit v1.2.3 From dd733219d795bd59516c54717e798ced9c378d33 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Fri, 6 Oct 2017 14:47:23 +0100 Subject: move nias_of_instruction into RMEM so that it can use shallow embedding ast and not obsolete interp_interface one. --- src/lem_interp/interp_inter_imp.lem | 180 ++---------------------------------- 1 file changed, 7 insertions(+), 173 deletions(-) diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 52acae1e..c0d2ea4a 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -1221,180 +1221,13 @@ let nia_address_of_event nia_reg (event: event) : maybe (maybe address) = | _ -> Nothing end -let nias_of_instruction - top_level - thread_ism - (nia_address: list (maybe address)) (* Nothing for unknown/undef*) - (regs_in: list reg_name) - (instruction: Interp_ast.value) - : list nia - = - let (instruction_name, instruction_fields) = interp_value_to_instr_external top_level instruction in - - let unknown_nia_address = List.elem Nothing nia_address in - - let nias = [NIA_concrete_address addr | forall (addr MEM (List.mapMaybe id nia_address)) | true] in - - (* it's a fact of the Power2.06B instruction pseudocode that in the B and Bc - cases there should be no Unknown values in nia_values, while in the Bclr - and Bcctr cases nia_values will just be Unknown and the semantics should - match the comments in the machineDefTypes definition of nia *) - (* All our other analysis is on the pseudocode directly, which is arguably - pleasingly robust. We could replace the nias pattern match on - instruction_name with something in that style if the exhaustive interpreter - announced register dependencies to register writes (easy) and if it could - check the form of the register writes to LR and CTR matches the - machineDefTypes nia definition *) - match (thread_ism, instruction_name) with - | ("PPCGEN_ism", "B") -> - let () = ensure (not unknown_nia_address) - "unexpected unknown/undefined address in nia_values 1" in - nias - | ("PPCGEN_ism", "Bc") -> - let () = ensure (not unknown_nia_address) - "unexpected unknown/undefined address in nia_values 2" in - NIA_successor :: nias - | ("PPCGEN_ism", "Bclr") -> [ NIA_successor; NIA_LR ] - | ("PPCGEN_ism", "Bcctr") -> [ NIA_successor; NIA_CTR ] - | ("PPCGEN_ism", "Sc") -> - let () = ensure (not unknown_nia_address) - "unexpected unknown/undefined address in nia_values 3" in - match instruction_fields with - | [(_, _, lev)] -> - (* LEV field is 7 bits long, pad it with false at beginning *) - if lev = [Bitc_zero;Bitc_one;Bitc_one;Bitc_one;Bitc_one;Bitc_one;Bitc_one] - (* (Interp_inter_imp.integer_of_byte_list (Interp_inter_imp.to_bytes (false :: bl))) = 63 *) - then [] - else [NIA_successor] - | _ -> [ NIA_successor ] - end - | ("PPCGEN_ism", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"PPCGEN_ism\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - (* AARch64 label branch (i.e. address must be known) although - these instructions take the address as an offset from PC, in here - we see the absolute address as it was extracted from the micro ops - just before write to PC *) - | ("AArch64HandSail", "BranchImmediate") -> nias - | ("AArch64HandSail", "BranchConditional") -> NIA_successor :: nias - | ("AArch64HandSail", "CompareAndBranch") -> NIA_successor :: nias - | ("AArch64HandSail", "TestBitAndBranch") -> NIA_successor :: nias - - (* AArch64 calculated address branch *) - | ("AArch64HandSail", "BranchRegister") -> - (* do some parsing of the ast fields to figure out which register holds - the branching address i.e. find n in "BR ". The ast constructor - from armV8.sail: (reg_index,BranchType) BranchRegister; *) - let n_integer = - match instruction_fields with - | [(_, _, n); _] -> integer_of_bit_list n - | _ -> fail - end - in - let () = ensure (0 <= n_integer && n_integer <= 31) - "expected register number from 0 to 31" - in - if n_integer = 31 then - nias (* BR XZR *) - else - (* look for Xn (which we actually call Rn) in regs_in *) - let n_reg = "R" ^ (String_extra.stringFromInteger n_integer) in - [NIA_register r | forall (r MEM regs_in) - | match r with - | (Reg name _ _ _) -> name = n_reg - | _ -> false - end] - | ("AArch64HandSail", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"AArch64HandSail\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - (** hacky cut-and-paste for AArch64Gen, duplicating code just to see if this suffices *) - - | ("AArch64GenSail", "BranchImmediate") -> nias - | ("AArch64GenSail", "BranchConditional") -> NIA_successor :: nias - | ("AArch64GenSail", "CompareAndBranch") -> NIA_successor :: nias - | ("AArch64GenSail", "TestBitAndBranch") -> NIA_successor :: nias - - (* AArch64 calculated address branch *) - | ("AArch64GenSail", "branch_unconditional_register") -> - (* do some parsing of the ast fields to figure out which register holds - the branching address i.e. find n in "BR ". The ast constructor - from armV8.sail: (reg_index,BranchType) BranchRegister; *) - let n_integer = - match instruction_fields with - | [(_, _, n); _] -> integer_of_bit_list n - | _ -> fail - end - in - let () = ensure (0 <= n_integer && n_integer <= 31) - "expected register number from 0 to 31" - in - if n_integer = 31 then - nias (* BR XZR *) - else - (* look for Xn (which we actually call Rn) in regs_in *) - let n_reg = "R" ^ (String_extra.stringFromInteger n_integer) in - [NIA_register r | forall (r MEM regs_in) - | match r with - | (Reg name _ _ _) -> name = n_reg - | _ -> false - end] - | ("AArch64GenSail", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"AArch64GenSail\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - (** end of hacky *) - - | ("AArch64LitmusSail", "CtrlDep") -> NIA_successor :: nias - | ("AArch64LitmusSail", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"AArch64LitmusSail\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - - | ("MIPS_ism", "B") -> fail - | ("MIPS_ism", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"MIPS_ism\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - | ("RISCV_ism", "JAL") -> nias - | ("RISCV_ism", "JALR") -> - let rs1_integer = - match instruction_fields with - | [_; (_, _, rs1); _] -> integer_of_bit_list rs1 - | _ -> fail - end - in - let () = ensure (0 <= rs1_integer && rs1_integer <= 31) - "expected register number from 0 to 31" - in - if rs1_integer = 0 then nias - else - let rs1_reg = "x" ^ (String_extra.stringFromInteger rs1_integer) in - [NIA_register r | forall (r MEM regs_in) - | match r with - | (Reg name _ _ _) -> name = rs1_reg - | _ -> false - end] - | ("RISCV_ism", "BTYPE") -> NIA_successor :: nias - | ("RISCV_ism", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"RISCV_ism\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - | (s1, s2) -> failwith ("unexpected (thread_ism, instruction_name): (" ^ s1 ^ ", " ^ s2 ^ ")") - end - - let interp_instruction_analysis top_level (interp_exhaustive : ((list (reg_name * register_value)) -> list event)) - instruction nia_reg ism environment = + instruction + nia_reg + (nias_function : (list (maybe address) -> list reg_name -> list nia)) + ism environment = let es = interp_exhaustive environment in @@ -1405,7 +1238,7 @@ let interp_instruction_analysis let nia_address = List.mapMaybe (nia_address_of_event nia_reg) es in - let nias = nias_of_instruction top_level ism nia_address regs_in instruction in + let nias = nias_function nia_address regs_in in let dia = DIA_none in (* FIX THIS! *) @@ -1496,12 +1329,13 @@ let interp_compare_analyses interp_exhaustive (instruction : Interp_ast.value) nia_reg + (nias_function : (list (maybe address) -> list reg_name -> list nia)) ism environment analysis_function reg_info = let (regs_in1,regs_out1,regs_feeding_address1,nias1,dia1,inst_kind1) = - interp_instruction_analysis context interp_exhaustive instruction nia_reg ism + interp_instruction_analysis context interp_exhaustive instruction nia_reg nias_function ism environment in let (regs_in1S,regs_out1S,regs_feeding_address1S,nias1S) = (Set.fromList regs_in1, -- cgit v1.2.3 From 100d8fd2fd591b2dcbf550e8d3b8cf476d17516f Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 9 Oct 2017 14:49:09 +0100 Subject: X86: Fix bug in register footprint caused by imperative variable update with wrong variable name (iK vs. ik). Spotted via compare_analyses. --- x86/x64.sail | 46 +++++++++++++++++++++++----------------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/x86/x64.sail b/x86/x64.sail index ae867747..16ba0f41 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -1417,7 +1417,6 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( ik := IK_simple; Nias := [|| NIAFP_successor ||]; Dia := DIAFP_none; - x := (qword) RIP; switch instr { case(Binop (locked, binop, sz, ds)) -> { let flags = regfp_binop_flags (binop) in @@ -1451,7 +1450,7 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( } case(CALL (irm) ) -> let (m, rs, ars) = regfp_imm_rm (irm) in { - iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); + ik := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); iR := RFull("RIP") :: RFull("RSP") :: rs; oR := RFull("RSP") :: oR; aR := ars; @@ -1470,14 +1469,14 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( let rk = if locked then Read_X86_locked else Read_plain in let wk = if locked then Write_X86_locked else Write_plain in let (m, rs, aRs) = regfp_rm (r_m) in { - iK := if m then IK_mem_rmw (rk, wk) else IK_simple; + ik := if m then IK_mem_rmw (rk, wk) else IK_simple; iR := RFull("RAX") :: RFull(GPRstr[reg]) :: append(rs, aRs); oR := RFull("RAX") :: append(regfp_binop_flags(Cmp), rs); aR := aRs; } case(DIV (sz, r_m) ) -> let (m, rs, ars) = regfp_rm (r_m) in { - iK := if m then IK_mem_read (Read_plain) else IK_simple; + ik := if m then IK_mem_read (Read_plain) else IK_simple; iR := RFull("RAX") :: RFull("RDX") :: append(rs, ars); oR := RFull("RAX") :: RFull("RDX") :: append(oR, all_flags); aR := ars; @@ -1485,13 +1484,13 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( case(HLT ) -> () case(Jcc (c, imm64) ) -> let flags = regfp_cond(c) in { - iK := IK_cond_branch; + ik := IK_cond_branch; iR := RFull("RIP") :: flags; Nias := NIAFP_concrete_address(RIP + imm64) :: Nias; } case(JMP (r_m) ) -> let (m, rs, ars) = regfp_rm (r_m) in { - iK := if m then IK_mem_read(Read_plain) else IK_simple; + ik := if m then IK_mem_read(Read_plain) else IK_simple; iR := RFull("RIP")::append(rs, ars); aR := ars; (* XXX register name is not important here -- just indicates we don't know the destination yet. *) @@ -1504,54 +1503,55 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( aR := ars; } case(LEAVE ) -> { - iK := IK_mem_read(Read_plain); + ik := IK_mem_read(Read_plain); iR := RFull("RBP") :: iR; oR := RFull("RBP") :: RFull("RSP") :: oR; aR := RFull("RBP") :: aR; } case(LOOP (c, imm64) ) -> let flags = regfp_cond(c) in { - iK := IK_cond_branch; + ik := IK_cond_branch; iR := RFull("RCX") :: flags; oR := RFull("RCX") :: oR; Nias := NIAFP_concrete_address(RIP + imm64) :: Nias; } - case(MFENCE ) -> iK := IK_barrier (Barrier_x86_MFENCE) + case(MFENCE ) -> + ik := IK_barrier (Barrier_x86_MFENCE) case(Monop (locked, monop, sz, r_m) ) -> let rk = if locked then Read_X86_locked else Read_plain in let wk = if locked then Write_X86_locked else Write_plain in let (m, rds, ars) = regfp_rm(r_m) in { - iK := if m then IK_mem_rmw(rk, wk) else IK_simple; + ik := if m then IK_mem_rmw(rk, wk) else IK_simple; iR := append(rds, ars); oR := append(all_flags_but_cf_of, rds); (* XXX fix flags *) aR := ars; } case(MOV (c, sz, ds) ) -> - let (ik, irs, ors, ars) = regfp_dest_src (ds) in + let (ik', irs, ors, ars) = regfp_dest_src (ds) in let flags = regfp_cond(c) in { - iK := ik; + ik := ik'; iR := append(irs, flags); oR := ors; aR := ars; } case(MOVSX (sz1, ds, sz2) ) -> - let (ik, irs, ors, ars) = regfp_dest_src (ds) in { - iK := ik; + let (ik', irs, ors, ars) = regfp_dest_src (ds) in { + ik := ik'; iR := irs; oR := ors; aR := ars; } case(MOVZX (sz1, ds, sz2) ) -> - let (ik, irs, ors, ars) = regfp_dest_src (ds) in { - iK := ik; + let (ik', irs, ors, ars) = regfp_dest_src (ds) in { + ik := ik'; iR := irs; oR := ors; aR := ars; } case(MUL (sz, r_m) ) -> let (m, rs, ars) = regfp_rm (r_m) in { - iK := if m then IK_mem_read (Read_plain) else IK_simple; + ik := if m then IK_mem_read (Read_plain) else IK_simple; iR := RFull("RAX") :: append(rs, ars); oR := RFull("RAX") :: RFull("RDX") :: append(oR, all_flags); aR := ars; @@ -1559,20 +1559,20 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( case(NOP (_) ) -> () case(POP (r_m) ) -> let (m, rd, ars) = regfp_rm (r_m) in { - iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); + ik := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); iR := RFull("RSP") :: ars; oR := RFull("RSP") :: rd; aR := RFull("RSP") :: ars; } case(PUSH (irm) ) -> let (m, rs, ars) = regfp_imm_rm (irm) in { - iK := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); + ik := if m then IK_mem_rmw(Read_plain, Write_plain) else IK_mem_write(Write_plain); iR := RFull("RSP") :: append(rs, ars); oR := RFull("RSP") :: oR; aR := RFull("RSP") :: ars; } case(RET (imm64) ) -> { - iK := IK_mem_read(Read_plain); + ik := IK_mem_read(Read_plain); iR := RFull("RSP") :: iR; oR := RFull("RSP") :: oR; aR := RFull("RSP") :: aR; @@ -1582,7 +1582,7 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( case(SET (c, b, r_m) ) -> let flags = regfp_cond(c) in let (m, rs, ars) = regfp_rm(r_m) in { - iK := if m then IK_mem_write(Write_plain) else IK_simple; + ik := if m then IK_mem_write(Write_plain) else IK_simple; iR := append(flags, ars); oR := rs; aR := ars; @@ -1592,7 +1592,7 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( let rk = if locked then Read_X86_locked else Read_plain in let wk = if locked then Write_X86_locked else Write_plain in let (m, rs, ars) = regfp_rm(r_m) in { - iK := if m then IK_mem_rmw(rk, wk) else IK_simple; + ik := if m then IK_mem_rmw(rk, wk) else IK_simple; iR := RFull(GPRstr[reg]) :: append(rs, ars); oR := RFull(GPRstr[reg]) :: append(rs, all_flags); aR := ars; @@ -1601,7 +1601,7 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( let rk = if locked then Read_X86_locked else Read_plain in let wk = if locked then Write_X86_locked else Write_plain in let (m, rs, ars) = regfp_rm(r_m) in { - iK := if m then IK_mem_rmw(rk, wk) else IK_simple; + ik := if m then IK_mem_rmw(rk, wk) else IK_simple; iR := RFull(GPRstr[reg]) :: append(rs, ars); oR := RFull(GPRstr[reg]) :: rs; aR := ars; -- cgit v1.2.3 From 97b808681f951a962cdb3c087d79aee5556a7089 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 9 Oct 2017 16:14:08 +0100 Subject: add translation of IK_mem_rmw interp_inter_imp. TODO: could we get rid of this and use shallow embedding conversion? --- src/lem_interp/interp_inter_imp.lem | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index c0d2ea4a..1c993ba0 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -571,6 +571,21 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis | Interp_ast.V_ctor (Id_aux (Id "NIAFP_register") _) _ _ reg -> NIA_register (reg_to_reg_name reg) | _ -> failwith "Register footprint analysis did not return nia of expected type" end in + let readk_to_readk = function + | "Read_plain" -> Read_plain + | "Read_reserve" -> Read_reserve + | "Read_acquire" -> Read_acquire + | "Read_exclusive" -> Read_exclusive + | "Read_exclusive_acquire" -> Read_exclusive_acquire + | "Read_stream" -> Read_stream + | r -> failwith ("unknown read kind: " ^ r) end in + let writek_to_writek = function + | "Write_plain" -> Write_plain + | "Write_conditional" -> Write_conditional + | "Write_release" -> Write_release + | "Write_exclusive" -> Write_exclusive + | "Write_exclusive_release" -> Write_exclusive_release + | w -> failwith ("unknown write kind: " ^ w) end in let ik_to_ik = function | Interp_ast.V_ctor (Id_aux (Id "IK_barrier") _) _ _ (Interp_ast.V_ctor (Id_aux (Id b) _) _ _ _) -> @@ -591,23 +606,14 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis end) | Interp_ast.V_ctor (Id_aux (Id "IK_mem_read") _) _ _ (Interp_ast.V_ctor (Id_aux (Id r) _) _ _ _) -> - IK_mem_read (match r with - | "Read_plain" -> Read_plain - | "Read_reserve" -> Read_reserve - | "Read_acquire" -> Read_acquire - | "Read_exclusive" -> Read_exclusive - | "Read_exclusive_acquire" -> Read_exclusive_acquire - | "Read_stream" -> Read_stream - end) + IK_mem_read(readk_to_readk r) | Interp_ast.V_ctor (Id_aux (Id "IK_mem_write") _) _ _ (Interp_ast.V_ctor (Id_aux (Id w) _) _ _ _) -> - IK_mem_write (match w with - | "Write_plain" -> Write_plain - | "Write_conditional" -> Write_conditional - | "Write_release" -> Write_release - | "Write_exclusive" -> Write_exclusive - | "Write_exclusive_release" -> Write_exclusive_release - end) + IK_mem_write(writek_to_writek w) + | Interp_ast.V_ctor (Id_aux (Id "IK_mem_rmw") _) _ _ + (Interp_ast.V_tuple [(Interp_ast.V_ctor (Id_aux (Id readk) _) _ _ _) ; + (Interp_ast.V_ctor (Id_aux (Id writek) _) _ _ _)]) -> + IK_mem_rmw(readk_to_readk readk, writek_to_writek writek) | Interp_ast.V_ctor (Id_aux (Id "IK_cond_branch") _) _ _ _ -> IK_cond_branch | Interp_ast.V_ctor (Id_aux (Id "IK_simple") _) _ _ _ -> -- cgit v1.2.3 From 93dfd61038583eac852e5e3ea66c46817a610bbe Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 9 Oct 2017 16:38:03 +0100 Subject: add translations for missing read/write kinds. --- src/lem_interp/interp_inter_imp.lem | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 1c993ba0..8199f271 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -578,6 +578,12 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis | "Read_exclusive" -> Read_exclusive | "Read_exclusive_acquire" -> Read_exclusive_acquire | "Read_stream" -> Read_stream + | "Read_RISCV_acquire" -> Read_RISCV_acquire + | "Read_RISCV_strong_acquire" -> Read_RISCV_strong_acquire + | "Read_RISCV_reserved" -> Read_RISCV_reserved + | "Read_RISCV_reserved_acquire" -> Read_RISCV_reserved_acquire + | "Read_RISCV_reserved_strong_acquire" -> Read_RISCV_reserved_strong_acquire + | "Read_X86_locked" -> Read_X86_locked | r -> failwith ("unknown read kind: " ^ r) end in let writek_to_writek = function | "Write_plain" -> Write_plain @@ -585,6 +591,12 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis | "Write_release" -> Write_release | "Write_exclusive" -> Write_exclusive | "Write_exclusive_release" -> Write_exclusive_release + | "Write_RISCV_release" -> Write_RISCV_release + | "Write_RISCV_strong_release" -> Write_RISCV_strong_release + | "Write_RISCV_conditional" -> Write_RISCV_conditional + | "Write_RISCV_conditional_release" -> Write_RISCV_conditional_release + | "Write_RISCV_conditional_strong_release" -> Write_RISCV_conditional_strong_release + | "Write_X86_locked" -> Write_X86_locked | w -> failwith ("unknown write kind: " ^ w) end in let ik_to_ik = function | Interp_ast.V_ctor (Id_aux (Id "IK_barrier") _) _ _ -- cgit v1.2.3 From 64468eda2bc40c874cddd4a6d9972af5ec224dc2 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Thu, 12 Oct 2017 17:14:40 +0100 Subject: Work around warning in ocaml shallow embedding of mips caused by buggy code generation for dubious casting enumeration to int. --- mips/mips_prelude.sail | 7 +++++++ mips/mips_tlb.sail | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/mips/mips_prelude.sail b/mips/mips_prelude.sail index a4098486..382e4d7f 100644 --- a/mips/mips_prelude.sail +++ b/mips/mips_prelude.sail @@ -472,6 +472,13 @@ function AccessLevel getAccessLevel() = case _ -> User (* behaviour undefined, assume user *) } +function ([|2|]) int_of_accessLevel((AccessLevel)x) = + switch (x) { + case User -> 0 + case Supervisor -> 1 + case Kernel -> 2 + } + function unit checkCP0Access () = { let accessLevel = getAccessLevel() in diff --git a/mips/mips_tlb.sail b/mips/mips_tlb.sail index 2e40deed..d72e0e75 100644 --- a/mips/mips_tlb.sail +++ b/mips/mips_tlb.sail @@ -108,7 +108,7 @@ function (bit[64], bool) TLBTranslateC ((bit[64]) vAddr, (MemAccessType) accessT case 0b01 -> (Supervisor, None) (* xsseg - supervisor mapped *) case 0b00 -> (User, None) (* xuseg - user mapped *) } in - if (((nat)currentAccessLevel) < ((nat)requiredLevel)) then + if ((int_of_accessLevel(currentAccessLevel)) < (int_of_accessLevel(requiredLevel))) then (SignalExceptionBadAddr(if (accessType == StoreData) then AdES else AdEL, vAddr)) else let (pa, c) = switch(addr) { -- cgit v1.2.3 From 6e2cd26a769b7cce9b9e4dcd15515c3f42ed63cf Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Fri, 13 Oct 2017 15:45:46 +0100 Subject: Add support for new cheri instruction encodings. The order of pattern matching is now significant because register no. fields are re-used as additional function codes in operations with fewer operands so I pulled out all decode clauses to the beginning of file for easier rearranging. Old encodings can co-exist with new encodings as the only overlap is for recently added instructions which already use the new scheme. Eventually the old encodings will go away, however, and the opcode space may be reclaimed." --- cheri/cheri_insts.sail | 232 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 151 insertions(+), 81 deletions(-) diff --git a/cheri/cheri_insts.sail b/cheri/cheri_insts.sail index caa87e55..e126ef64 100644 --- a/cheri/cheri_insts.sail +++ b/cheri/cheri_insts.sail @@ -32,6 +32,157 @@ (* SUCH DAMAGE. *) (*========================================================================*) +(* Old encodings *) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b000) = Some(CGetPerm(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b001) = Some(CGetType(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b010) = Some(CGetBase(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b011) = Some(CGetLen(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b101) = Some(CGetTag(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b110) = Some(CGetSealed(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : 0b00000 : 0b00000000 : 0b100) = Some(CGetCause(rd)) + +function clause decode (0b010010 : 0b00110 : 0b000000000000000000000) = Some(CReturn) + +function clause decode (0b010010 : 0b01101 : (regno) rd : (regno) cb : 0b00000000 : 0b010) = Some(CGetOffset(rd, cb)) (* NB encoding does not follow pattern *) +function clause decode (0b010010 : 0b00100 : 0b00000 : 0b00000 : (regno) rt : 0b000 : 0b100) = Some(CSetCause(rt)) +function clause decode (0b010010 : 0b00100 : (regno) cd : (regno) cb : (regno) rt : 0b000 : 0b000) = Some(CAndPerm(cd, cb, rt)) +function clause decode (0b010010 : 0b01100 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b000) = Some(CToPtr(rd, cb, ct)) + +function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b000) = Some(CPtrCmp(rd, cb, ct, CEQ)) +function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b001) = Some(CPtrCmp(rd, cb, ct, CNE)) +function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b010) = Some(CPtrCmp(rd, cb, ct, CLT)) +function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b011) = Some(CPtrCmp(rd, cb, ct, CLE)) +function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b100) = Some(CPtrCmp(rd, cb, ct, CLTU)) +function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b101) = Some(CPtrCmp(rd, cb, ct, CLEU)) +function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b110) = Some(CPtrCmp(rd, cb, ct, CEXEQ)) +function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b111) = Some(CPtrCmp(rd, cb, ct, CNEXEQ)) +function clause decode (0b010010 : 0b01101 : (regno) cd : (regno) cb : (regno) rt : 0b000 : 0b000) = Some(CIncOffset(cd, cb, rt)) +function clause decode (0b010010 : 0b01101 : (regno) cd : (regno) cb : (regno) rt : 0b000 : 0b001) = Some(CSetOffset(cd, cb, rt)) +function clause decode (0b010010 : 0b00001 : (regno) cd : (regno) cb : (regno) rt : 0b000000) = Some(CSetBounds(cd, cb, rt)) + +function clause decode (0b010010 : 0b00100 : (regno) cd : (regno) cb : 0b00000 : 0b000: 0b101) = Some(CClearTag(cd, cb)) +function clause decode (0b010010 : 0b00100 : (regno) cd : (regno) cb : (regno) rt : 0b000: 0b111) = Some(CFromPtr(cd, cb, rt)) +function clause decode (0b010010 : 0b01011 : (regno) cs : 0b00000 : (regno) rt : 0b000: 0b000) = Some(CCheckPerm(cs, rt)) +function clause decode (0b010010 : 0b01011 : (regno) cs : (regno) cb : 0b00000 : 0b000: 0b001) = Some(CCheckType(cs, cb)) +function clause decode (0b010010 : 0b00010 : (regno) cd : (regno) cs : (regno) ct : 0b000: 0b000) = Some(CSeal(cd, cs, ct)) +function clause decode (0b010010 : 0b00011 : (regno) cd : (regno) cs : (regno) ct : 0b000: 0b000) = Some(CUnseal(cd, cs, ct)) +function clause decode (0b010010 : 0b00111 : (regno) cd : (regno) cb : 0b00000 : 0b000000) = Some(CJALR(cd, cb, true)) (* CJALR *) +function clause decode (0b010010 : 0b01000 : 0b00000 : (regno) cb : 0b00000 : 0b000000) = Some(CJALR(0b00000, cb, false)) (* CJR *) + + +(* +New encodings as per CHERI ISA Appendix B.2. + +NB: Must be careful about order of matching because unused register +fields are re-used as additional function codes. +*) + +(* One arg *) +function clause decode (0b010010 : 0b00000 : (regno) rd : 0b00001 : 0b11111 : 0b111111) = Some(CGetCause(rd)) +function clause decode (0b010010 : 0b00000 : (regno) rs : 0b00010 : 0b11111 : 0b111111) = Some(CSetCause(rs)) +function clause decode (0b010010 : 0b00000 : (regno) cd : 0b00000 : 0b11111 : 0b111111) = Some(CGetPCC(cd)) + +(* Two arg *) +function clause decode (0b010010 : 0b00000 : (regno) cs : (regno) rt : 0b01000 : 0b111111) = Some(CCheckPerm(cs, rt)) +function clause decode (0b010010 : 0b00000 : (regno) cs : (regno) cb : 0b01001 : 0b111111) = Some(CCheckType(cs, cb)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : 0b01011 : 0b111111) = Some(CClearTag(cd, cb)) + +(* Capability Inspection *) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000 : 0b111111) = Some(CGetPerm(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00001 : 0b111111) = Some(CGetType(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00010 : 0b111111) = Some(CGetBase(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00011 : 0b111111) = Some(CGetLen(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00100 : 0b111111) = Some(CGetTag(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00101 : 0b111111) = Some(CGetSealed(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00110 : 0b111111) = Some(CGetOffset(rd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) rs : 0b00111 : 0b111111) = Some(CGetPCCSetOffset(cd, rs)) + +(* Three operand *) + +(* Capability Modification *) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) ct : 0b001011) = Some(CSeal(cd, cs, ct)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) ct : 0b001100) = Some(CUnseal(cd, cs, ct)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) rt : 0b001101) = Some(CAndPerm(cd, cs, rt)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) rt : 0b001111) = Some(CSetOffset(cd, cs, rt)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) rt : 0b001000) = Some(CSetBounds(cd, cs, rt)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) rt : 0b001001) = Some(CSetBoundsExact(cd, cs, rt)) + + +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) rt : 0b010001) = Some(CIncOffset(cd, cb, rt)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) ct : 0b011101) = Some(CBuildCap(cd, cb, ct)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) ct : 0b011110) = Some(CCopyType(cd, cb, ct)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) ct : 0b011111) = Some(CCSeal(cd, cs, ct)) + +(* Pointer Arithmetic *) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) ct : 0b010010) = Some(CToPtr(rd, cb, ct)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) rs : 0b010011) = Some(CFromPtr(cd, cb, rs)) +function clause decode (0b010010 : 0b00000 : (regno) rt : (regno) cb : (regno) cs : 0b001010) = Some(CSub(rt, cb, cs)) +(* XXX function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : 0b01010 : 0b111111) = Some(CMove(cd, cs)) *) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) rs : 0b011011) = Some(CMOVX(cd, cs, rs, false)) (* CMOVZ *) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) rs : 0b011100) = Some(CMOVX(cd, cs, rs, true)) (* CMOVN *) + +(* Pointer Comparison *) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) cs : 0b010100) = Some(CPtrCmp(rd, cb, cs, CEQ)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) cs : 0b010101) = Some(CPtrCmp(rd, cb, cs, CNE)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) cs : 0b010110) = Some(CPtrCmp(rd, cb, cs, CLT)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) cs : 0b010111) = Some(CPtrCmp(rd, cb, cs, CLE)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) cs : 0b011000) = Some(CPtrCmp(rd, cb, cs, CLTU)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) cs : 0b011001) = Some(CPtrCmp(rd, cb, cs, CLEU)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) cs : 0b011010) = Some(CPtrCmp(rd, cb, cs, CEXEQ)) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) cs : 0b100001) = Some(CPtrCmp(rd, cb, cs, CNEXEQ)) + +(* function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) ct : 0b100000) = Some(CTestSubset(rd, cb, ct)) *) + +function clause decode (0b010010 : 0b01001 : (regno) cd : (bit[16]) imm) = Some(CBX(cd, imm, true)) (* CBTU *) +function clause decode (0b010010 : 0b01010 : (regno) cd : (bit[16]) imm) = Some(CBX(cd, imm, false)) (* CBTS *) +(* function clause decode (0b010010 : 0b10001 : (regno) cd : (bit[16]) imm) = Some(CBEZ(cd, imm)) XXX *) +(* function clause decode (0b010010 : 0b10010 : (regno) cd : (bit[16]) imm) = Some(CBNZ(cd, imm)) XXX *) + +function clause decode (0b010010 : 0b00101 : 0b00000 : 0b00000 : 0b11111111111) = Some(CReturn) +function clause decode (0b010010 : 0b00101 : (regno) cs : (regno) cb : (bit[11]) selector) = Some(CCall(cs, cb, selector)) + +function clause decode (0b010010 : 0b01111 : 0b00000 : (bit[16]) imm) = Some(ClearRegs(GPLo, imm)) +function clause decode (0b010010 : 0b01111 : 0b00001 : (bit[16]) imm) = Some(ClearRegs(GPHi, imm)) +function clause decode (0b010010 : 0b01111 : 0b00010 : (bit[16]) imm) = Some(ClearRegs(CLo, imm)) +function clause decode (0b010010 : 0b01111 : 0b00011 : (bit[16]) imm) = Some(ClearRegs(CHi, imm)) + +(* XXX CSetBoundsImmediate *) +(* XXX CIncOffsetImmediate *) + +function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b00) = Some(CLoad(rd, cb, rt, offset, false, B, false)) (* CLBU *) +function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b1 : 0b00) = Some(CLoad(rd, cb, rt, offset, true, B, false)) (* CLB *) +function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b01) = Some(CLoad(rd, cb, rt, offset, false, H, false)) (* CLHU *) +function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b1 : 0b01) = Some(CLoad(rd, cb, rt, offset, true, H, false)) (* CLH *) +function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b10) = Some(CLoad(rd, cb, rt, offset, false, W, false)) (* CLWU *) +function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b1 : 0b10) = Some(CLoad(rd, cb, rt, offset, true, W, false)) (* CLW *) +function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b11) = Some(CLoad(rd, cb, rt, offset, false, D, false)) (* CLD *) + +function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b0 : 0b00) = Some(CLoad(rd, cb, 0b00000, 0b00000000, false, B, true)) (* CLLBU *) +function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b1 : 0b00) = Some(CLoad(rd, cb, 0b00000, 0b00000000, true, B, true)) (* CLLB *) +function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b0 : 0b01) = Some(CLoad(rd, cb, 0b00000, 0b00000000, false, H, true)) (* CLLHU *) +function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b1 : 0b01) = Some(CLoad(rd, cb, 0b00000, 0b00000000, true, H, true)) (* CLLH *) +function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b0 : 0b10) = Some(CLoad(rd, cb, 0b00000, 0b00000000, false, W, true)) (* CLLWU *) +function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b1 : 0b10) = Some(CLoad(rd, cb, 0b00000, 0b00000000, true, W, true)) (* CLLW *) +function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b0 : 0b11) = Some(CLoad(rd, cb, 0b00000, 0b00000000, false, D, true)) (* CLLD *) + +function clause decode (0b111010 : (regno) rs : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b00) = Some(CStore(rs, cb, rt, 0b00000, offset, B, false)) (* CSB *) +function clause decode (0b111010 : (regno) rs : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b01) = Some(CStore(rs, cb, rt, 0b00000, offset, H, false)) (* CSH *) +function clause decode (0b111010 : (regno) rs : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b10) = Some(CStore(rs, cb, rt, 0b00000, offset, W, false)) (* CSW *) +function clause decode (0b111010 : (regno) rs : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b11) = Some(CStore(rs, cb, rt, 0b00000, offset, D, false)) (* CSD *) + +function clause decode (0b010010 : 0b10000 : (regno) rs : (regno) cb : (regno) rd : 0b0000 : 0b00) = Some(CStore(rs, cb, 0b00000, rd, 0b00000000, B, true)) (* CSCB *) +function clause decode (0b010010 : 0b10000 : (regno) rs : (regno) cb : (regno) rd : 0b0000 : 0b01) = Some(CStore(rs, cb, 0b00000, rd, 0b00000000, H, true)) (* CSCH *) +function clause decode (0b010010 : 0b10000 : (regno) rs : (regno) cb : (regno) rd : 0b0000 : 0b10) = Some(CStore(rs, cb, 0b00000, rd, 0b00000000, W, true)) (* CSCW *) +function clause decode (0b010010 : 0b10000 : (regno) rs : (regno) cb : (regno) rd : 0b0000 : 0b11) = Some(CStore(rs, cb, 0b00000, rd, 0b00000000, D, true)) (* CSCD *) + +function clause decode (0b111110 : (regno) cs : (regno) cb: (regno) rt : (bit[11]) offset) = Some(CSC(cs, cb, rt, 0b00000, offset, false)) +function clause decode (0b010010 : 0b10000 : (regno) cs : (regno) cb: (regno) rd : 0b00 : 0b0111) = Some(CSC(cs, cb, 0b00000, rd, 0b00000000000, true)) + +function clause decode (0b110110 : (regno) cd : (regno) cb: (regno) rt : (bit[11]) offset) = Some(CLC(cd, cb, rt, offset, false)) +function clause decode (0b010010 : 0b10000 : (regno) cd : (regno) cb: 0b0000000 : 0b1111) = Some(CLC(cd, cb, 0b00000, 0b00000000000, true)) + +function clause decode (0b010010 : 0b00100 : (regno) rt : 0x0006) = Some(C2Dump(rt)) + (* Operations that extract parts of a capability into GPR *) union ast member (regno, regno) CGetPerm @@ -42,15 +193,6 @@ union ast member (regno, regno) CGetTag union ast member (regno, regno) CGetSealed union ast member (regno, regno) CGetOffset -function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b000) = Some(CGetPerm(rd, cb)) -function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b001) = Some(CGetType(rd, cb)) -function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b010) = Some(CGetBase(rd, cb)) -function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b011) = Some(CGetLen(rd, cb)) -(* NB CGetCause Handled separately *) -function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b101) = Some(CGetTag(rd, cb)) -function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000000 : 0b110) = Some(CGetSealed(rd, cb)) -function clause decode (0b010010 : 0b01101 : (regno) rd : (regno) cb : 0b00000000 : 0b010) = Some(CGetOffset(rd, cb)) (* NB encoding does not follow pattern *) - function clause execute (CGetPerm(rd, cb)) = { (* START_CGetPerms *) @@ -140,7 +282,6 @@ function clause execute (CGetSealed(rd, cb)) = } union ast member regno CGetPCC -function clause decode (0b010010 : 0b00000 : (regno) cd : 0b00000 : 0b11111 : 0b111111) = Some(CGetPCC(cd)) function clause execute (CGetPCC(cd)) = { (* START_CGetPCC *) @@ -157,7 +298,6 @@ function clause execute (CGetPCC(cd)) = union ast member (regno, regno) CGetPCCSetOffset -function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) rs : 0b00111 : 0b111111) = Some(CGetPCCSetOffset(cd, rs)) function clause execute (CGetPCCSetOffset(cd, rs)) = { (* START_CGetPCCSetOffset *) @@ -177,7 +317,6 @@ function clause execute (CGetPCCSetOffset(cd, rs)) = (* Get and Set CP2 cause register *) union ast member regno CGetCause -function clause decode (0b010010 : 0b00000 : (regno) rd : 0b00000 : 0b00000000 : 0b100) = Some(CGetCause(rd)) function clause execute (CGetCause(rd)) = { (* START_CGetCause *) @@ -190,7 +329,6 @@ function clause execute (CGetCause(rd)) = } union ast member (regno) CSetCause -function clause decode (0b010010 : 0b00100 : 0b00000 : 0b00000 : (regno) rt : 0b000 : 0b100) = Some(CSetCause(rt)) function clause execute (CSetCause((regno) rt)) = { (* START_CSetCause *) @@ -207,7 +345,6 @@ function clause execute (CSetCause((regno) rt)) = } union ast member regregreg CAndPerm -function clause decode (0b010010 : 0b00100 : (regno) cd : (regno) cb : (regno) rt : 0b000 : 0b000) = Some(CAndPerm(cd, cb, rt)) function clause execute(CAndPerm(cd, cb, rt)) = { (* START_CAndPerm *) @@ -232,7 +369,6 @@ function clause execute(CAndPerm(cd, cb, rt)) = union ast member regregreg CToPtr -function clause decode (0b010010 : 0b01100 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b000) = Some(CToPtr(rd, cb, ct)) function clause execute(CToPtr(rd, cb, ct)) = { (* START_CToPtr *) @@ -266,7 +402,6 @@ function clause execute(CToPtr(rd, cb, ct)) = union ast member regregreg CSub -function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) ct : 0b001010) = Some(CSub(rd, cb, ct)) function clause execute(CSub(rd, cb, ct)) = { (* START_CSub *) @@ -285,15 +420,6 @@ function clause execute(CSub(rd, cb, ct)) = } union ast member (regno, regno, regno, CPtrCmpOp) CPtrCmp -function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b000) = Some(CPtrCmp(rd, cb, ct, CEQ)) -function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b001) = Some(CPtrCmp(rd, cb, ct, CNE)) -function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b010) = Some(CPtrCmp(rd, cb, ct, CLT)) -function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b011) = Some(CPtrCmp(rd, cb, ct, CLE)) -function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b100) = Some(CPtrCmp(rd, cb, ct, CLTU)) -function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b101) = Some(CPtrCmp(rd, cb, ct, CLEU)) -function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b110) = Some(CPtrCmp(rd, cb, ct, CEXEQ)) -function clause decode (0b010010 : 0b01110 : (regno) rd : (regno) cb : (regno) ct : 0b000 : 0b111) = Some(CPtrCmp(rd, cb, ct, CNEXEQ)) - function clause execute(CPtrCmp(rd, cb, ct, op)) = { (* START_CPtrCmp *) @@ -340,7 +466,6 @@ function clause execute(CPtrCmp(rd, cb, ct, op)) = } union ast member regregreg CIncOffset -function clause decode (0b010010 : 0b01101 : (regno) cd : (regno) cb : (regno) rt : 0b000 : 0b000) = Some(CIncOffset(cd, cb, rt)) function clause execute (CIncOffset(cd, cb, rt)) = { (* START_CIncOffset *) @@ -363,7 +488,6 @@ function clause execute (CIncOffset(cd, cb, rt)) = } union ast member regregreg CSetOffset -function clause decode (0b010010 : 0b01101 : (regno) cd : (regno) cb : (regno) rt : 0b000 : 0b001) = Some(CSetOffset(cd, cb, rt)) function clause execute (CSetOffset(cd, cb, rt)) = { (* START_CSetOffset *) @@ -386,7 +510,6 @@ function clause execute (CSetOffset(cd, cb, rt)) = } union ast member regregreg CSetBounds -function clause decode (0b010010 : 0b00001 : (regno) cd : (regno) cb : (regno) rt : 0b000000) = Some(CSetBounds(cd, cb, rt)) function clause execute (CSetBounds(cd, cb, rt)) = { (* START_CSetBounds *) @@ -417,7 +540,6 @@ function clause execute (CSetBounds(cd, cb, rt)) = union ast member regregreg CSetBoundsExact -function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) rt : 0b001001) = Some(CSetBoundsExact(cd, cb, rt)) function clause execute (CSetBoundsExact(cd, cb, rt)) = { (* START_CSetBoundsExact *) @@ -450,7 +572,6 @@ function clause execute (CSetBoundsExact(cd, cb, rt)) = } union ast member (regno, regno) CClearTag -function clause decode (0b010010 : 0b00100 : (regno) cd : (regno) cb : 0b00000 : 0b000: 0b101) = Some(CClearTag(cd, cb)) function clause execute (CClearTag(cd, cb)) = { (* START_CClearTag *) @@ -468,8 +589,6 @@ function clause execute (CClearTag(cd, cb)) = } union ast member (regno,regno,regno,bool) CMOVX -function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) rt : 0b011100) = Some(CMOVX(cd, cb, rt, true)) (* CMOVN *) -function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) rt : 0b011011) = Some(CMOVX(cd, cb, rt, false)) (* CMOVZ *) function clause execute (CMOVX(cd, cb, rt, ismovn)) = { (* START_CMOVX *) @@ -484,10 +603,6 @@ function clause execute (CMOVX(cd, cb, rt, ismovn)) = } union ast member (ClearRegSet, bit[16]) ClearRegs -function clause decode (0b010010 : 0b01111 : 0b00000 : (bit[16]) imm) = Some(ClearRegs(GPLo, imm)) (* ClearLo *) -function clause decode (0b010010 : 0b01111 : 0b00001 : (bit[16]) imm) = Some(ClearRegs(GPHi, imm)) (* ClearHi *) -function clause decode (0b010010 : 0b01111 : 0b00010 : (bit[16]) imm) = Some(ClearRegs(CLo, imm)) (* CClearLo *) -function clause decode (0b010010 : 0b01111 : 0b00011 : (bit[16]) imm) = Some(ClearRegs(CHi, imm)) (* CClearHi *) function clause execute (ClearRegs(regset, mask)) = { (* START_ClearRegs *) @@ -510,7 +625,6 @@ function clause execute (ClearRegs(regset, mask)) = } union ast member regregreg CFromPtr -function clause decode (0b010010 : 0b00100 : (regno) cd : (regno) cb : (regno) rt : 0b000: 0b111) = Some(CFromPtr(cd, cb, rt)) function clause execute (CFromPtr(cd, cb, rt)) = { (* START_CFromPtr *) @@ -537,7 +651,6 @@ function clause execute (CFromPtr(cd, cb, rt)) = } union ast member regregreg CBuildCap -function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) ct : 0b011101) = Some(CBuildCap(cd, cb, ct)) function clause execute (CBuildCap(cd, cb, ct)) = { (* START_CBuildCap *) @@ -582,7 +695,6 @@ function clause execute (CBuildCap(cd, cb, ct)) = } union ast member regregreg CCopyType -function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) ct : 0b011110) = Some(CCopyType(cd, cb, ct)) function clause execute (CCopyType(cd, cb, ct)) = { (* START_CCopyType *) @@ -618,7 +730,6 @@ function clause execute (CCopyType(cd, cb, ct)) = } union ast member (regno, regno) CCheckPerm -function clause decode (0b010010 : 0b01011 : (regno) cs : 0b00000 : (regno) rt : 0b000: 0b000) = Some(CCheckPerm(cs, rt)) function clause execute (CCheckPerm(cs, rt)) = { (* START_CCheckPerm *) @@ -638,7 +749,6 @@ function clause execute (CCheckPerm(cs, rt)) = } union ast member (regno, regno) CCheckType -function clause decode (0b010010 : 0b01011 : (regno) cs : (regno) cb : 0b00000 : 0b000: 0b001) = Some(CCheckType(cs, cb)) function clause execute (CCheckType(cs, cb)) = { (* START_CCheckType *) @@ -665,7 +775,6 @@ function clause execute (CCheckType(cs, cb)) = } union ast member regregreg CSeal -function clause decode (0b010010 : 0b00010 : (regno) cd : (regno) cs : (regno) ct : 0b000: 0b000) = Some(CSeal(cd, cs, ct)) function clause execute (CSeal(cd, cs, ct)) = { (* START_CSeal *) @@ -707,7 +816,6 @@ function clause execute (CSeal(cd, cs, ct)) = } union ast member regregreg CCSeal -function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) ct : 0b011111) = Some(CCSeal(cd, cs, ct)) function clause execute (CCSeal(cd, cs, ct)) = { (* START_CCSeal *) @@ -749,7 +857,6 @@ function clause execute (CCSeal(cd, cs, ct)) = } union ast member regregreg CUnseal -function clause decode (0b010010 : 0b00011 : (regno) cd : (regno) cs : (regno) ct : 0b000: 0b000) = Some(CUnseal(cd, cs, ct)) function clause execute (CUnseal(cd, cs, ct)) = { (* START_CUnseal *) @@ -789,7 +896,6 @@ function clause execute (CUnseal(cd, cs, ct)) = } union ast member (regno, regno, bit[11]) CCall -function clause decode (0b010010 : 0b00101 : (regno) cs : (regno) cb : (bit[11]) selector) = Some(CCall(cs, cb, selector)) function clause execute (CCall(cs, cb, 0b00000000000)) = (* selector=0 *) { (* Partial implementation of CCall with checks in hardware, but raising a trap to perform trusted stack manipulation *) @@ -876,7 +982,6 @@ function clause execute (CCall(cs, cb, 0b00000000001)) = (* selector=1 *) } union ast member unit CReturn -function clause decode (0b010010 : 0b00110 : 0b000000000000000000000) = Some(CReturn) function clause execute (CReturn) = { (* START_CReturn *) @@ -886,9 +991,6 @@ function clause execute (CReturn) = } union ast member (regno, bit[16], bool) CBX -function clause decode (0b010010 : 0b01001 : (regno) cb : (bit[16]) imm) = Some(CBX(cb, imm, true)) (* CBTU *) -function clause decode (0b010010 : 0b01010 : (regno) cb : (bit[16]) imm) = Some(CBX(cb, imm, false)) (* CBTS *) - function clause execute (CBX(cb, imm, invert)) = { (* START_CBx *) @@ -905,8 +1007,6 @@ function clause execute (CBX(cb, imm, invert)) = } union ast member (regno, regno, bool) CJALR -function clause decode (0b010010 : 0b00111 : (regno) cd : (regno) cb : 0b00000 : 0b000000) = Some(CJALR(cd, cb, true)) (* CJALR *) -function clause decode (0b010010 : 0b01000 : 0b00000 : (regno) cb : 0b00000 : 0b000000) = Some(CJALR(0b00000, cb, false)) (* CJR *) function clause execute(CJALR(cd, cb, link)) = { (* START_CJALR *) @@ -948,22 +1048,6 @@ function clause execute(CJALR(cd, cb, link)) = } union ast member (regno, regno, regno, bit[8], bool, WordType, bool) CLoad -function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b00) = Some(CLoad(rd, cb, rt, offset, false, B, false)) (* CLBU *) -function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b1 : 0b00) = Some(CLoad(rd, cb, rt, offset, true, B, false)) (* CLB *) -function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b01) = Some(CLoad(rd, cb, rt, offset, false, H, false)) (* CLHU *) -function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b1 : 0b01) = Some(CLoad(rd, cb, rt, offset, true, H, false)) (* CLH *) -function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b10) = Some(CLoad(rd, cb, rt, offset, false, W, false)) (* CLWU *) -function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b1 : 0b10) = Some(CLoad(rd, cb, rt, offset, true, W, false)) (* CLW *) -function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b11) = Some(CLoad(rd, cb, rt, offset, false, D, false)) (* CLD *) - -function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b0 : 0b00) = Some(CLoad(rd, cb, 0b00000, 0b00000000, false, B, true)) (* CLLBU *) -function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b1 : 0b00) = Some(CLoad(rd, cb, 0b00000, 0b00000000, true, B, true)) (* CLLB *) -function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b0 : 0b01) = Some(CLoad(rd, cb, 0b00000, 0b00000000, false, H, true)) (* CLLHU *) -function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b1 : 0b01) = Some(CLoad(rd, cb, 0b00000, 0b00000000, true, H, true)) (* CLLH *) -function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b0 : 0b10) = Some(CLoad(rd, cb, 0b00000, 0b00000000, false, W, true)) (* CLLWU *) -function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b1 : 0b10) = Some(CLoad(rd, cb, 0b00000, 0b00000000, true, W, true)) (* CLLW *) -function clause decode (0b010010 : 0b10000 : (regno) rd : (regno) cb : 0b00000001 : 0b0 : 0b11) = Some(CLoad(rd, cb, 0b00000, 0b00000000, false, D, true)) (* CLLD *) - function clause execute (CLoad(rd, cb, rt, offset, signext, width, linked)) = { (* START_CLoad *) @@ -1011,15 +1095,6 @@ function clause execute (CLoad(rd, cb, rt, offset, signext, width, linked)) = } union ast member (regno, regno, regno, regno, bit[8], WordType, bool) CStore -function clause decode (0b111010 : (regno) rs : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b00) = Some(CStore(rs, cb, rt, 0b00000, offset, B, false)) (* CSB *) -function clause decode (0b111010 : (regno) rs : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b01) = Some(CStore(rs, cb, rt, 0b00000, offset, H, false)) (* CSH *) -function clause decode (0b111010 : (regno) rs : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b10) = Some(CStore(rs, cb, rt, 0b00000, offset, W, false)) (* CSW *) -function clause decode (0b111010 : (regno) rs : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b11) = Some(CStore(rs, cb, rt, 0b00000, offset, D, false)) (* CSD *) - -function clause decode (0b010010 : 0b10000 : (regno) rs : (regno) cb : (regno) rd : 0b0000 : 0b00) = Some(CStore(rs, cb, 0b00000, rd, 0b00000000, B, true)) (* CSCB *) -function clause decode (0b010010 : 0b10000 : (regno) rs : (regno) cb : (regno) rd : 0b0000 : 0b01) = Some(CStore(rs, cb, 0b00000, rd, 0b00000000, H, true)) (* CSCH *) -function clause decode (0b010010 : 0b10000 : (regno) rs : (regno) cb : (regno) rd : 0b0000 : 0b10) = Some(CStore(rs, cb, 0b00000, rd, 0b00000000, W, true)) (* CSCW *) -function clause decode (0b010010 : 0b10000 : (regno) rs : (regno) cb : (regno) rd : 0b0000 : 0b11) = Some(CStore(rs, cb, 0b00000, rd, 0b00000000, D, true)) (* CSCD *) function clause execute (CStore(rs, cb, rt, rd, offset, width, conditional)) = { @@ -1078,8 +1153,6 @@ function clause execute (CStore(rs, cb, rt, rd, offset, width, conditional)) = } union ast member (regno, regno, regno, regno, bit[11], bool) CSC -function clause decode (0b111110 : (regno) cs : (regno) cb: (regno) rt : (bit[11]) offset) = Some(CSC(cs, cb, rt, 0b00000, offset, false)) -function clause decode (0b010010 : 0b10000 : (regno) cs : (regno) cb: (regno) rd : 0b00 : 0b0111) = Some(CSC(cs, cb, 0b00000, rd, 0b00000000000, true)) function clause execute (CSC(cs, cb, rt, rd, offset, conditional)) = { (* START_CSC *) @@ -1130,8 +1203,6 @@ function clause execute (CSC(cs, cb, rt, rd, offset, conditional)) = } union ast member (regno, regno, regno, bit[11], bool) CLC -function clause decode (0b110110 : (regno) cd : (regno) cb: (regno) rt : (bit[11]) offset) = Some(CLC(cd, cb, rt, offset, false)) -function clause decode (0b010010 : 0b10000 : (regno) cd : (regno) cb: 0b0000000 : 0b1111) = Some(CLC(cd, cb, 0b00000, 0b00000000000, true)) function clause execute (CLC(cd, cb, rt, offset, linked)) = { (* START_CLC *) @@ -1176,6 +1247,5 @@ function clause execute (CLC(cd, cb, rt, offset, linked)) = } union ast member (regno) C2Dump -function clause decode (0b010010 : 0b00100 : (regno) rt : 0x0006) = Some(C2Dump(rt)) function clause execute (C2Dump (rt)) = () (* Currently a NOP *) -- cgit v1.2.3 From 91c90cba4b0580802b5c4610e1b3dc5d10e3b4ae Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 16 Oct 2017 11:09:13 +0100 Subject: add support for capability branch null instructions. --- cheri/cheri_insts.sail | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/cheri/cheri_insts.sail b/cheri/cheri_insts.sail index e126ef64..d5ba8d06 100644 --- a/cheri/cheri_insts.sail +++ b/cheri/cheri_insts.sail @@ -133,10 +133,10 @@ function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) c (* function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) ct : 0b100000) = Some(CTestSubset(rd, cb, ct)) *) -function clause decode (0b010010 : 0b01001 : (regno) cd : (bit[16]) imm) = Some(CBX(cd, imm, true)) (* CBTU *) +function clause decode (0b010010 : 0b01001 : (regno) cd : (bit[16]) imm) = Some(CBX(cd, imm, true)) (* CBTU *) function clause decode (0b010010 : 0b01010 : (regno) cd : (bit[16]) imm) = Some(CBX(cd, imm, false)) (* CBTS *) -(* function clause decode (0b010010 : 0b10001 : (regno) cd : (bit[16]) imm) = Some(CBEZ(cd, imm)) XXX *) -(* function clause decode (0b010010 : 0b10010 : (regno) cd : (bit[16]) imm) = Some(CBNZ(cd, imm)) XXX *) +function clause decode (0b010010 : 0b10001 : (regno) cd : (bit[16]) imm) = Some(CBZ(cd, imm, false)) (* CBEZ *) +function clause decode (0b010010 : 0b10010 : (regno) cd : (bit[16]) imm) = Some(CBZ(cd, imm, true)) (* CBNZ *) function clause decode (0b010010 : 0b00101 : 0b00000 : 0b00000 : 0b11111111111) = Some(CReturn) function clause decode (0b010010 : 0b00101 : (regno) cs : (regno) cb : (bit[11]) selector) = Some(CCall(cs, cb, selector)) @@ -1006,6 +1006,22 @@ function clause execute (CBX(cb, imm, invert)) = (* END_CBx *) } +union ast member (regno, bit[16], bool) CBZ +function clause execute (CBZ(cb, imm, invert)) = +{ + (* START_CBz *) + checkCP2usable(); + if (register_inaccessible(cb)) then + raise_c2_exception(CapEx_AccessSystemRegsViolation, cb) + else if (((readCapReg(cb)) == null_cap) ^ invert) then + { + let (bit[64]) offset = (EXTS(imm : 0b00) + 4) in + delayedPC := PC + offset; + branchPending := 1; + } + (* END_CBz *) +} + union ast member (regno, regno, bool) CJALR function clause execute(CJALR(cd, cb, link)) = { -- cgit v1.2.3 From 3c678570789fbbe37d25e2b6201b0eefb10fbae2 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 16 Oct 2017 12:17:07 +0100 Subject: add support for CIncOffsetImmediate and CSetBoundsImmediate. --- cheri/cheri_insts.sail | 54 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/cheri/cheri_insts.sail b/cheri/cheri_insts.sail index d5ba8d06..7542e377 100644 --- a/cheri/cheri_insts.sail +++ b/cheri/cheri_insts.sail @@ -146,8 +146,8 @@ function clause decode (0b010010 : 0b01111 : 0b00001 : (bit[16]) imm) = Some(Cle function clause decode (0b010010 : 0b01111 : 0b00010 : (bit[16]) imm) = Some(ClearRegs(CLo, imm)) function clause decode (0b010010 : 0b01111 : 0b00011 : (bit[16]) imm) = Some(ClearRegs(CHi, imm)) -(* XXX CSetBoundsImmediate *) -(* XXX CIncOffsetImmediate *) +function clause decode (0b010010 : 0b10011 : (regno) cd : (regno) cb : (bit[11]) imm) = Some(CIncOffsetImmediate(cd, cb, imm)) +function clause decode (0b010010 : 0b10100 : (regno) cd : (regno) cb : (bit[11]) imm) = Some(CSetBoundsImmediate(cd, cb, imm)) function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b0 : 0b00) = Some(CLoad(rd, cb, rt, offset, false, B, false)) (* CLBU *) function clause decode (0b110010 : (regno) rd : (regno) cb: (regno) rt : (bit[8]) offset : 0b1 : 0b00) = Some(CLoad(rd, cb, rt, offset, true, B, false)) (* CLB *) @@ -487,6 +487,28 @@ function clause execute (CIncOffset(cd, cb, rt)) = (* END_CIncOffset *) } +union ast member (regno, regno, bit[11]) CIncOffsetImmediate +function clause execute (CIncOffsetImmediate(cd, cb, imm)) = +{ + (* START_CIncOffsetImmediate *) + checkCP2usable(); + cb_val := readCapReg(cb); + let (bit[64]) imm64 = EXTZ(imm) in + if (register_inaccessible(cd)) then + raise_c2_exception(CapEx_AccessSystemRegsViolation, cd) + else if (register_inaccessible(cb)) then + raise_c2_exception(CapEx_AccessSystemRegsViolation, cb) + else if ((cb_val.tag) & (cb_val.sealed)) then + raise_c2_exception(CapEx_SealViolation, cb) + else + let (success, newCap) = incCapOffset(cb_val, imm64) in + if (success) then + writeCapReg(cd, newCap) + else + writeCapReg(cd, int_to_cap(getCapBase(cb_val) + imm64)) + (* END_CIncOffsetImmediate *) +} + union ast member regregreg CSetOffset function clause execute (CSetOffset(cd, cb, rt)) = { @@ -538,6 +560,34 @@ function clause execute (CSetBounds(cd, cb, rt)) = (* END_CSetBounds *) } +union ast member (regno, regno, bit[11]) CSetBoundsImmediate +function clause execute (CSetBoundsImmediate(cd, cb, imm)) = +{ + (* START_CSetBoundsImmedate *) + checkCP2usable(); + cb_val := readCapReg(cb); + immU := unsigned(imm); + cursor := getCapCursor(cb_val); + base := getCapBase(cb_val); + top := getCapTop(cb_val); + newTop := cursor + immU; + if (register_inaccessible(cd)) then + raise_c2_exception(CapEx_AccessSystemRegsViolation, cd) + else if (register_inaccessible(cb)) then + raise_c2_exception(CapEx_AccessSystemRegsViolation, cb) + else if not (cb_val.tag) then + raise_c2_exception(CapEx_TagViolation, cb) + else if (cb_val.sealed) then + raise_c2_exception(CapEx_SealViolation, cb) + else if (cursor < base) then + raise_c2_exception(CapEx_LengthViolation, cb) + else if (newTop > top) then + raise_c2_exception(CapEx_LengthViolation, cb) + else + let (_, newCap) = setCapBounds(cb_val, (bit[64]) cursor, (bit[65]) newTop) in + writeCapReg(cd, newCap) (* ignore exact *) + (* END_CSetBoundsImmediate *) +} union ast member regregreg CSetBoundsExact function clause execute (CSetBoundsExact(cd, cb, rt)) = -- cgit v1.2.3 From 27816b955866bd5021cb8534f92480d83d76cc32 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 16 Oct 2017 14:46:50 +0100 Subject: implement CMove as an alias for cmovz with zero register. --- cheri/cheri_insts.sail | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cheri/cheri_insts.sail b/cheri/cheri_insts.sail index 7542e377..3b602d03 100644 --- a/cheri/cheri_insts.sail +++ b/cheri/cheri_insts.sail @@ -86,6 +86,7 @@ function clause decode (0b010010 : 0b00000 : (regno) cd : 0b00000 : 0b1111 function clause decode (0b010010 : 0b00000 : (regno) cs : (regno) rt : 0b01000 : 0b111111) = Some(CCheckPerm(cs, rt)) function clause decode (0b010010 : 0b00000 : (regno) cs : (regno) cb : 0b01001 : 0b111111) = Some(CCheckType(cs, cb)) function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : 0b01011 : 0b111111) = Some(CClearTag(cd, cb)) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : 0b01010 : 0b111111) = Some(CMOVX(cd, cs, 0b00000, false)) (* CMOVE *) (* Capability Inspection *) function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000 : 0b111111) = Some(CGetPerm(rd, cb)) @@ -117,7 +118,6 @@ function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) c function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) ct : 0b010010) = Some(CToPtr(rd, cb, ct)) function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : (regno) rs : 0b010011) = Some(CFromPtr(cd, cb, rs)) function clause decode (0b010010 : 0b00000 : (regno) rt : (regno) cb : (regno) cs : 0b001010) = Some(CSub(rt, cb, cs)) -(* XXX function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : 0b01010 : 0b111111) = Some(CMove(cd, cs)) *) function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) rs : 0b011011) = Some(CMOVX(cd, cs, rs, false)) (* CMOVZ *) function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : (regno) rs : 0b011100) = Some(CMOVX(cd, cs, rs, true)) (* CMOVN *) -- cgit v1.2.3 From 1522c658263cb1f646e44489ba8a19764fe8f4c4 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 16 Oct 2017 16:21:07 +0100 Subject: add missing new encodings for CJR and CJALR. --- cheri/cheri_insts.sail | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cheri/cheri_insts.sail b/cheri/cheri_insts.sail index 3b602d03..1d6c4a13 100644 --- a/cheri/cheri_insts.sail +++ b/cheri/cheri_insts.sail @@ -81,12 +81,14 @@ fields are re-used as additional function codes. function clause decode (0b010010 : 0b00000 : (regno) rd : 0b00001 : 0b11111 : 0b111111) = Some(CGetCause(rd)) function clause decode (0b010010 : 0b00000 : (regno) rs : 0b00010 : 0b11111 : 0b111111) = Some(CSetCause(rs)) function clause decode (0b010010 : 0b00000 : (regno) cd : 0b00000 : 0b11111 : 0b111111) = Some(CGetPCC(cd)) +function clause decode (0b010010 : 0b00000 : (regno) cb : 0b00011 : 0b11111 : 0b111111) = Some(CJALR(0b00000, cb, false)) (* CJR *) (* Two arg *) function clause decode (0b010010 : 0b00000 : (regno) cs : (regno) rt : 0b01000 : 0b111111) = Some(CCheckPerm(cs, rt)) function clause decode (0b010010 : 0b00000 : (regno) cs : (regno) cb : 0b01001 : 0b111111) = Some(CCheckType(cs, cb)) function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : 0b01011 : 0b111111) = Some(CClearTag(cd, cb)) function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cs : 0b01010 : 0b111111) = Some(CMOVX(cd, cs, 0b00000, false)) (* CMOVE *) +function clause decode (0b010010 : 0b00000 : (regno) cd : (regno) cb : 0b01100 : 0b111111) = Some(CJALR(cd, cb, true)) (* CJALR *) (* Capability Inspection *) function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : 0b00000 : 0b111111) = Some(CGetPerm(rd, cb)) -- cgit v1.2.3 From 7bd52dedf93ccaf4811307e12b8402fad6ab2312 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 16 Oct 2017 16:24:59 +0100 Subject: add CTestSubset instruction. --- cheri/cheri_insts.sail | 37 ++++++++++++++++++++++++++++++++++++- 1 file changed, 36 insertions(+), 1 deletion(-) diff --git a/cheri/cheri_insts.sail b/cheri/cheri_insts.sail index 1d6c4a13..c27f6dc7 100644 --- a/cheri/cheri_insts.sail +++ b/cheri/cheri_insts.sail @@ -133,7 +133,7 @@ function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) c function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) cs : 0b011010) = Some(CPtrCmp(rd, cb, cs, CEXEQ)) function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) cs : 0b100001) = Some(CPtrCmp(rd, cb, cs, CNEXEQ)) -(* function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) ct : 0b100000) = Some(CTestSubset(rd, cb, ct)) *) +function clause decode (0b010010 : 0b00000 : (regno) rd : (regno) cb : (regno) ct : 0b100000) = Some(CTestSubset(rd, cb, ct)) function clause decode (0b010010 : 0b01001 : (regno) cd : (bit[16]) imm) = Some(CBX(cd, imm, true)) (* CBTU *) function clause decode (0b010010 : 0b01010 : (regno) cd : (bit[16]) imm) = Some(CBX(cd, imm, false)) (* CBTS *) @@ -826,6 +826,41 @@ function clause execute (CCheckType(cs, cb)) = (* END_CCheckType *) } +union ast member regregreg CTestSubset +function clause execute (CTestSubset(rd, cb, ct)) = +{ + (* START_CTestSubset *) + checkCP2usable(); + cb_val := readCapReg(cb); + ct_val := readCapReg(ct); + ct_top := getCapTop(ct_val); + ct_base := getCapBase(ct_val); + ct_perms := getCapPerms(ct_val); + cb_top := getCapTop(cb_val); + cb_base := getCapBase(cb_val); + cb_perms := getCapPerms(cb_val); + if (register_inaccessible(cb)) then + raise_c2_exception(CapEx_AccessSystemRegsViolation, cb) + else if (register_inaccessible(ct)) then + raise_c2_exception(CapEx_AccessSystemRegsViolation, ct) + else { + (bit[64]) result := EXTZ(if (cb_val.tag != ct_val.tag) then + 0x0 + else if (cb_val.sealed != ct_val.sealed) then + 0x0 + else if (ct_base < cb_base) then + 0x0 + else if (ct_top > cb_top) then + 0x0 + else if ((ct_perms & cb_perms) != cb_perms) then + 0x0 + else + 0x1); + wGPR(rd) := result; + } + (* END_CTestSubset *) +} + union ast member regregreg CSeal function clause execute (CSeal(cd, cs, ct)) = { -- cgit v1.2.3 From 99a7462a88a186faf817e21c065e25f04d30aea7 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 23 Oct 2017 17:47:16 +0100 Subject: cheri: Null capability should have maximum length, because in cheri128 we want all offsets to be representable. To maintain all-zeros as the in-memory representation of the null capability we xor memory bits with null capability when loading and storing. --- cheri/cheri_prelude_128.sail | 26 +++++++++++++++++++------- cheri/cheri_prelude_256.sail | 18 +++++++++++++++--- 2 files changed, 34 insertions(+), 10 deletions(-) diff --git a/cheri/cheri_prelude_128.sail b/cheri/cheri_prelude_128.sail index 98b0a40c..9bc0e2d2 100644 --- a/cheri/cheri_prelude_128.sail +++ b/cheri/cheri_prelude_128.sail @@ -73,10 +73,10 @@ let (CapStruct) null_cap = { permit_execute = false; global = false; reserved = 0; - E = 48; (* encoded as 0 in memory due to xor *) + E = 48; sealed = false; B = 0; - T = 0; + T = 0x10000; otype = 0; address = 0; } @@ -104,7 +104,7 @@ function CapStruct capRegToCapStruct((CapReg) c) = permit_execute = c[114]; global = c[113]; reserved = c[112..111]; - E = c[110..105] ^ 0b110000; + E = c[110..105]; sealed = s; B = B; T = T; @@ -125,13 +125,13 @@ function (bit[11]) getCapHardPerms((CapStruct) cap) = : [cap.permit_execute] : [cap.global]) -function (bit[128]) capStructToMemBits((CapStruct) cap) = +function (bit[128]) capStructToMemBits128((CapStruct) cap) = let (bit[20]) b = if cap.sealed then (cap.B)[19..12] : (cap.otype)[23..12] else cap.B in let (bit[20]) t = if cap.sealed then (cap.T)[19..12] : (cap.otype)[11..0] else cap.T in ( cap.uperms : getCapHardPerms(cap) : cap.reserved - : (cap.E ^ 0b110000) (* XXX brackets required otherwise sail interpreter error *) + : (cap.E) : [cap.sealed] : b : t @@ -139,12 +139,24 @@ function (bit[128]) capStructToMemBits((CapStruct) cap) = ) function (CapReg) capStructToCapReg((CapStruct) cap) = - ([cap.tag] : capStructToMemBits(cap)) + ([cap.tag] : capStructToMemBits128(cap)) (* Reverse of above used when reading from memory *) -function (CapReg) memBitsToCapBits((bool) tag, (bit[128]) b) = +function (CapReg) memBitsToCapBits128((bool) tag, (bit[128]) b) = ([tag] : b) +(* When saving/restoring capabilities xor them with bits of null_cap -- + this ensures that canonical null_cap is always all-zeros in memory + even though it may have bits set logically (e.g. length or exponent *) + +let (bit[128]) null_cap_bits = capStructToMemBits128(null_cap) + +function (bit[128]) capStructToMemBits((CapStruct) cap) = + capStructToMemBits128(cap) ^ null_cap_bits + +function (bit[129]) memBitsToCapBits((bool) tag, (bit[128]) b) = + memBitsToCapBits128(tag, b ^ null_cap_bits) + function (bit[31]) getCapPerms((CapStruct) cap) = let (bit[15]) perms = EXTS(getCapHardPerms(cap)) in (* NB access_system copied into 14-11 *) (0x000 (* uperms 30-19 *) diff --git a/cheri/cheri_prelude_256.sail b/cheri/cheri_prelude_256.sail index f41d9c14..1b13e408 100644 --- a/cheri/cheri_prelude_256.sail +++ b/cheri/cheri_prelude_256.sail @@ -78,7 +78,7 @@ let (CapStruct) null_cap = { sealed = false; offset = 0; base = 0; - length = 0; + length = 0xffffffffffffffff; } def Nat cap_size_t = 32 (* cap size in bytes *) @@ -130,7 +130,7 @@ function (bit[31]) getCapPerms((CapStruct) cap) = - this is the same as register format except for the offset, field which is stored as an absolute cursor on CHERI due to uarch optimisation *) -function (bit[256]) capStructToMemBits((CapStruct) cap) = +function (bit[256]) capStructToMemBits256((CapStruct) cap) = ( cap.padding : cap.otype @@ -144,13 +144,25 @@ function (bit[256]) capStructToMemBits((CapStruct) cap) = (* Reverse of above used when reading from memory *) -function (bit[257]) memBitsToCapBits((bool) tag, (bit[256]) b) = +function (bit[257]) memBitsToCapBits256((bool) tag, (bit[256]) b) = ([tag] : b[255..192] : ((bit[64])(b[191..128] - b[127..64])) : b[127..0] ) +(* When saving/restoring capabilities xor them with bits of null_cap -- + this ensures that canonical null_cap is always all-zeros in memory + even though it may have bits set logically (e.g. length or exponent *) + +let (bit[256]) null_cap_bits = capStructToMemBits256(null_cap) + +function (bit[256]) capStructToMemBits((CapStruct) cap) = + capStructToMemBits256(cap) ^ null_cap_bits + +function (bit[257]) memBitsToCapBits((bool) tag, (bit[256]) b) = + memBitsToCapBits256(tag, b ^ null_cap_bits) + function (CapReg) capStructToCapReg((CapStruct) cap) = ( [cap.tag] -- cgit v1.2.3 From 29182cd14e228529b3e26ef901e927bde8d27345 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Tue, 24 Oct 2017 15:44:10 +0100 Subject: fix default cap value on cheri128 following previous changes -- E stored in registers is no longer xored with 48 so need to initialise it. Also use E and T values used by CHERI hw and adjust decoding functions appropriately. Fix shift functions for ocaml shallow embedding which failed to handle shifts greater than vector length. --- cheri/cheri_prelude_128.sail | 8 ++++---- mips/run_embed.ml | 2 +- src/gen_lib/sail_values.ml | 27 +++++++++++++++++---------- src/lem_interp/run_with_elf_cheri128.ml | 2 +- 4 files changed, 23 insertions(+), 16 deletions(-) diff --git a/cheri/cheri_prelude_128.sail b/cheri/cheri_prelude_128.sail index 9bc0e2d2..fbb4c21c 100644 --- a/cheri/cheri_prelude_128.sail +++ b/cheri/cheri_prelude_128.sail @@ -195,23 +195,23 @@ function [|-1:1|] a_top_correction((bit[20]) a_mid, (bit[20]) R, (bit[20]) bound } function uint64 getCapBase((CapStruct) c) = - let ([|45|]) E = min(unsigned(c.E), 45) in + let ([|48|]) E = min(unsigned(c.E), 48) in let (bit[20]) B = c.B in let (bit[65]) a = EXTZ(c.address) in let (bit[20]) R = B - 0x01000 in (* wraps *) - let (bit[20]) a_mid = a[(E + 19)..E] in + let (bit[20]) a_mid = mask(a >> E) in let correction = a_top_correction(a_mid, R, B) in let a_top = a >> (E+20) in let (bit[64]) base = EXTZ((a_top + correction) : B) << E in unsigned(base) function CapLen getCapTop ((CapStruct) c) = - let ([|45|]) E = min(unsigned(c.E), 45) in + let ([|48|]) E = min(unsigned(c.E), 48) in let (bit[20]) B = c.B in let (bit[20]) T = c.T in let (bit[65]) a = EXTZ(c.address) in let (bit[20]) R = B - 0x01000 in (* wraps *) - let (bit[20]) a_mid = a[(E + 19)..E] in + let (bit[20]) a_mid = mask(a >> E) in let correction = a_top_correction(a_mid, R, T) in let a_top = a >> (E+20) in let (bit[65]) top1 = EXTZ((a_top + correction) : T) in diff --git a/mips/run_embed.ml b/mips/run_embed.ml index 463caffd..9dd063b1 100644 --- a/mips/run_embed.ml +++ b/mips/run_embed.ml @@ -250,7 +250,7 @@ module CHERI128_model : ISA_model = struct let start_addr = (to_vec_dec_big (bi64, big_int_of_string "0x9000000040000000")) in set_register Cheri128_embed._nextPC start_addr; set_register_field_bit Cheri128_embed._CP0Status "BEV" Vone; - let initial_cap_val_int = big_int_of_string "0x1fffe0000000800000000000000000000" in (* hex((0x80000 << 64) + (0x7fff << 113) + (1 << 128)) *) + let initial_cap_val_int = big_int_of_string "0x1fffe6000000100000000000000000000" in (* hex((0x10000 << 64) + (48 << 105) + (0x7fff << 113) + (1 << 128)) T=0x10000 E=48 perms=0x7fff tag=1 *) let initial_cap_vec = to_vec_dec ((bi129), initial_cap_val_int) in set_register Cheri128_embed._PCC initial_cap_vec; set_register Cheri128_embed._nextPCC initial_cap_vec; diff --git a/src/gen_lib/sail_values.ml b/src/gen_lib/sail_values.ml index d160e84a..213acea1 100644 --- a/src/gen_lib/sail_values.ml +++ b/src/gen_lib/sail_values.ml @@ -889,18 +889,25 @@ let shift_op_vec_int op (l,r) = let len = Array.length array in (match op with | "<<" -> - let left = Array.sub array r (len - r) in - let right = Array.make r Vzero in - let result = Array.append left right in - Vvector(result, start, ord) + if (r <= len) then + let left = Array.sub array r (len - r) in + let right = Array.make r Vzero in + let result = Array.append left right in + Vvector(result, start, ord) + else + Vvector(Array.make len Vzero, start, ord) | ">>" -> - let left = Array.make r Vzero in - let right = Array.sub array 0 (len - r) in - let result = Array.append left right in - Vvector(result, start, ord) + if (r <= len) then + let left = Array.make r Vzero in + let right = Array.sub array 0 (len - r) in + let result = Array.append left right in + Vvector(result, start, ord) + else + Vvector(Array.make len Vzero, start, ord) | "<<<" -> - let left = Array.sub array r (len - r) in - let right = Array.sub array 0 r in + let rmod = r mod len in + let left = Array.sub array rmod (len - rmod) in + let right = Array.sub array 0 rmod in let result = Array.append left right in Vvector(result, start, ord) | _ -> assert false) diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index 3ad507bc..f4f319ea 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -665,7 +665,7 @@ let cheri_register_data_all = mips_register_data_all @ [ let initial_stack_and_reg_data_of_MIPS_elf_file e_entry all_data_memory = let initial_stack_data = [] in - let initial_cap_val_int = Nat_big_num.of_string "0x1fffe0000000800000000000000000000" in (* hex((0x80000 << 64) + (0x7fff << 113) + (1 << 128)) *) + let initial_cap_val_int = Nat_big_num.of_string "0x1fffe6000000100000000000000000000" in (* hex((0x10000 << 64) + (48 << 105) + (0x7fff << 113) + (1 << 128)) T=0x10000 E=48 perms=0x7fff tag=1 *) let initial_cap_val_reg = Sail_impl_base.register_value_of_integer 129 128 D_decreasing initial_cap_val_int in let initial_register_abi_data : (string * Sail_impl_base.register_value) list = [ ("CP0Status", Sail_impl_base.register_value_of_integer 32 31 D_decreasing (Nat_big_num.of_string "0x00400000")); -- cgit v1.2.3 From dc62ae8cf283cdf71c0cd2001d57abc77bc52673 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 26 Oct 2017 11:40:35 +0100 Subject: fixed release acquire semantics of AMOs --- risc-v/riscv.sail | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index f36dba57..4938aaca 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -365,14 +365,14 @@ function clause execute (AMO(op, aq, rl, rs2, rs1, width, rd)) = { (bit[64]) addr := rGPR(rs1); switch (width) { - case WORD -> mem_write_ea(addr, 4, aq, rl, true) - case DOUBLE -> mem_write_ea(addr, 8, aq, rl, true) + case WORD -> mem_write_ea(addr, 4, aq & rl, rl, true) + case DOUBLE -> mem_write_ea(addr, 8, aq & rl, rl, true) }; (bit[64]) loaded := switch (width) { - case WORD -> EXTS(mem_read(addr, 4, aq, rl, true)) - case DOUBLE -> mem_read(addr, 8, aq, rl, true) + case WORD -> EXTS(mem_read(addr, 4, aq, aq & rl, true)) + case DOUBLE -> mem_read(addr, 8, aq, aq & rl, true) }; wGPR(rd, loaded); @@ -392,8 +392,8 @@ function clause execute (AMO(op, aq, rl, rs2, rs1, width, rd)) = { }; switch (width) { - case WORD -> mem_write_value(addr, 4, result[31..0], aq, rl, true) - case DOUBLE -> mem_write_value(addr, 8, result, aq, rl, true) + case WORD -> mem_write_value(addr, 4, result[31..0], aq & rl, rl, true) + case DOUBLE -> mem_write_value(addr, 8, result, aq & rl, rl, true) }; } -- cgit v1.2.3 From b41ee79485e155f67099b007650d73f449db1961 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Tue, 31 Oct 2017 11:01:10 +0000 Subject: cheri: ccall selector 1 should have a branch delay slot. TODO we need to throw exception for access to IDC/C26 in branch delay slot. --- cheri/cheri_insts.sail | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cheri/cheri_insts.sail b/cheri/cheri_insts.sail index c27f6dc7..50399785 100644 --- a/cheri/cheri_insts.sail +++ b/cheri/cheri_insts.sail @@ -1057,9 +1057,9 @@ function clause execute (CCall(cs, cb, 0b00000000001)) = (* selector=1 *) sealed=false; otype=0; }) in { - nextPC := (bit[64]) (getCapOffset(cs_val)); - nextPCC := csUnsealed; + delayedPC := (bit[64]) (getCapOffset(cs_val)); delayedPCC := csUnsealed; + branchPending := true; C26 := capStructToCapReg({cb_val with sealed=false; otype=0; -- cgit v1.2.3 From a35692d69681683c2bffe7c824ad230b88679ed9 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Tue, 31 Oct 2017 16:09:46 +0000 Subject: cheri: throw an exception if there is an attempt to access C26/IDC in the delay slot of a ccall selector 1 call. --- cheri/cheri_insts.sail | 1 + cheri/cheri_prelude_common.sail | 12 ++++++++++-- mips/run_embed.ml | 10 ++++++++-- src/lem_interp/run_with_elf_cheri.ml | 2 ++ src/lem_interp/run_with_elf_cheri128.ml | 2 ++ 5 files changed, 23 insertions(+), 4 deletions(-) diff --git a/cheri/cheri_insts.sail b/cheri/cheri_insts.sail index 50399785..5687a275 100644 --- a/cheri/cheri_insts.sail +++ b/cheri/cheri_insts.sail @@ -1060,6 +1060,7 @@ function clause execute (CCall(cs, cb, 0b00000000001)) = (* selector=1 *) delayedPC := (bit[64]) (getCapOffset(cs_val)); delayedPCC := csUnsealed; branchPending := true; + inCCallDelay := true; C26 := capStructToCapReg({cb_val with sealed=false; otype=0; diff --git a/cheri/cheri_prelude_common.sail b/cheri/cheri_prelude_common.sail index dcb56d01..fa36decb 100644 --- a/cheri/cheri_prelude_common.sail +++ b/cheri/cheri_prelude_common.sail @@ -35,6 +35,7 @@ register CapReg PCC register CapReg nextPCC register CapReg delayedPCC +register (bit[1]) inCCallDelay register CapReg C00 (* aka default data capability, DDC *) register CapReg C01 register CapReg C02 @@ -105,6 +106,7 @@ typedef CapEx = enumerate { CapEx_PermitSealViolation; CapEx_AccessSystemRegsViolation; CapEx_PermitCCallViolation; + CapEx_AccessCCallIDCViolation; } typedef CPtrCmpOp = enumerate { @@ -148,6 +150,7 @@ function (bit[8]) CapExCode((CapEx) ex) = case CapEx_PermitSealViolation -> 0x17 case CapEx_AccessSystemRegsViolation -> 0x18 case CapEx_PermitCCallViolation -> 0x19 + case CapEx_AccessCCallIDCViolation -> 0x1a } typedef CapCauseReg = register bits [15:0] { @@ -194,7 +197,11 @@ function forall Type 'o . 'o raise_c2_exception8((CapEx) capEx, (bit[8]) regnum) } function forall Type 'o . 'o raise_c2_exception((CapEx) capEx, (regno) regnum) = - raise_c2_exception8(capEx, 0b000 : regnum) + let reg8 = 0b000 : regnum in + if ((capEx == CapEx_AccessSystemRegsViolation) & (regnum == 26 (* IDC *))) then + raise_c2_exception8(CapEx_AccessCCallIDCViolation, reg8) + else + raise_c2_exception8(capEx, reg8) function forall Type 'o . 'o raise_c2_exception_noreg((CapEx) capEx) = raise_c2_exception8(capEx, 0xff) @@ -203,7 +210,8 @@ function bool pcc_access_system_regs () = let pcc = capRegToCapStruct(PCC) in (pcc.access_system_regs) -function bool register_inaccessible((regno) r) = +function bool register_inaccessible((regno) r) = + if ((r == 26 (* IDC *)) & inCCallDelay) then true else let is_sys_reg = switch(r) { case 0b11011 -> true case 0b11100 -> true diff --git a/mips/run_embed.ml b/mips/run_embed.ml index 9dd063b1..1bb6d5f6 100644 --- a/mips/run_embed.ml +++ b/mips/run_embed.ml @@ -219,7 +219,10 @@ module CHERI_model : ISA_model = struct let pc_vaddr = unsigned_big(Cheri_embed._PC) in let npc_addr = add_int_big_int 4 pc_vaddr in let npc_vec = to_vec_dec_big (bi64, npc_addr) in - set_register Cheri_embed._nextPC npc_vec + begin + set_register Cheri_embed._nextPC npc_vec; + set_register Cheri_embed._inCCallDelay (to_vec_dec_int (1, 0)) + end let get_pc () = unsigned_big (Cheri_embed._PC) @@ -277,7 +280,10 @@ module CHERI128_model : ISA_model = struct let pc_vaddr = unsigned_big(Cheri128_embed._PC) in let npc_addr = add_int_big_int 4 pc_vaddr in let npc_vec = to_vec_dec_big (bi64, npc_addr) in - set_register Cheri128_embed._nextPC npc_vec + begin + set_register Cheri128_embed._nextPC npc_vec; + set_register Cheri128_embed._inCCallDelay (to_vec_dec_int (1, 0)) + end let get_pc () = unsigned_big (Cheri128_embed._PC) diff --git a/src/lem_interp/run_with_elf_cheri.ml b/src/lem_interp/run_with_elf_cheri.ml index b879f702..b50cb01d 100644 --- a/src/lem_interp/run_with_elf_cheri.ml +++ b/src/lem_interp/run_with_elf_cheri.ml @@ -493,6 +493,7 @@ let mips_register_data_all = [ ("PC", (D_decreasing, 64, 63)); ("branchPending", (D_decreasing, 1, 0)); ("inBranchDelay", (D_decreasing, 1, 0)); + ("inCCallDelay", (D_decreasing, 1, 0)); ("delayedPC", (D_decreasing, 64, 63)); ("nextPC", (D_decreasing, 64, 63)); (* General purpose registers *) @@ -1072,6 +1073,7 @@ let set_next_instruction_address model = begin reg := Reg.add "nextPC" n_pc !reg; reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; + reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; end | (Some pc_val, Some 1) -> (* delay slot -- branch to delayed PC and clear branchPending *) diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index f4f319ea..148b29ae 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -493,6 +493,7 @@ let mips_register_data_all = [ ("PC", (D_decreasing, 64, 63)); ("branchPending", (D_decreasing, 1, 0)); ("inBranchDelay", (D_decreasing, 1, 0)); + ("inCCallDelay", (D_decreasing, 1, 0)); ("delayedPC", (D_decreasing, 64, 63)); ("nextPC", (D_decreasing, 64, 63)); (* General purpose registers *) @@ -1072,6 +1073,7 @@ let set_next_instruction_address model = begin reg := Reg.add "nextPC" n_pc !reg; reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; + reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; end | (Some pc_val, Some 1) -> (* delay slot -- branch to delayed PC and clear branchPending *) -- cgit v1.2.3 From 701d572adda905e6b2098a73c9af56f98212b4a3 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Tue, 31 Oct 2017 17:02:16 +0000 Subject: work around interpreter crash by adding cast. Likely this kind of thing will be resolved by merge of new_tc branch. --- cheri/cheri_prelude_common.sail | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cheri/cheri_prelude_common.sail b/cheri/cheri_prelude_common.sail index fa36decb..a84c118f 100644 --- a/cheri/cheri_prelude_common.sail +++ b/cheri/cheri_prelude_common.sail @@ -211,7 +211,7 @@ function bool pcc_access_system_regs () = (pcc.access_system_regs) function bool register_inaccessible((regno) r) = - if ((r == 26 (* IDC *)) & inCCallDelay) then true else + if ((r == 26 (* IDC *)) & ((bool)inCCallDelay)) then true else (* XXX interpreter crash without cast *) let is_sys_reg = switch(r) { case 0b11011 -> true case 0b11100 -> true -- cgit v1.2.3 From 8e5d44d17c71cf946e65e15de8df42de2af4c652 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Wed, 1 Nov 2017 14:17:08 +0000 Subject: added RISC-V "fence r,r" --- etc/regfp.sail | 1 + risc-v/hgen/parser.hgen | 2 +- risc-v/riscv.sail | 1 + risc-v/riscv_extras.lem | 1 + risc-v/riscv_extras_embed.lem | 2 ++ risc-v/riscv_extras_embed_sequential.lem | 2 ++ risc-v/riscv_regfp.sail | 1 + risc-v/riscv_types.sail | 1 + src/gen_lib/deep_shallow_convert.lem | 10 ++++++---- src/lem_interp/sail_impl_base.lem | 11 +++++++---- 10 files changed, 23 insertions(+), 9 deletions(-) diff --git a/etc/regfp.sail b/etc/regfp.sail index 15d1a489..cc057f2e 100644 --- a/etc/regfp.sail +++ b/etc/regfp.sail @@ -74,6 +74,7 @@ typedef barrier_kind = enumerate { Barrier_MIPS_SYNC; Barrier_RISCV_rw_rw; Barrier_RISCV_r_rw; + Barrier_RISCV_r_r; Barrier_RISCV_rw_w; Barrier_RISCV_w_w; Barrier_RISCV_i; diff --git a/risc-v/hgen/parser.hgen b/risc-v/hgen/parser.hgen index 82bb1d5b..cf0ca80b 100644 --- a/risc-v/hgen/parser.hgen +++ b/risc-v/hgen/parser.hgen @@ -26,10 +26,10 @@ { match ($2, $4) with | (Fence_RW, Fence_RW) -> `RISCVFENCE (0b0011, 0b0011) | (Fence_R, Fence_RW) -> `RISCVFENCE (0b0010, 0b0011) + | (Fence_R, Fence_R) -> `RISCVFENCE (0b0010, 0b0010) | (Fence_RW, Fence_W) -> `RISCVFENCE (0b0011, 0b0001) | (Fence_W, Fence_W) -> `RISCVFENCE (0b0001, 0b0001) | (Fence_RW, Fence_R) -> failwith "'fence rw,r' is not supported" - | (Fence_R, Fence_R) -> failwith "'fence r,r' is not supported" | (Fence_R, Fence_W) -> failwith "'fence r,w' is not supported" | (Fence_W, Fence_RW) -> failwith "'fence w,rw' is not supported" | (Fence_W, Fence_R) -> failwith "'fence w,r' is not supported" diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index 4938aaca..e0a6efba 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -260,6 +260,7 @@ function clause execute (FENCE(pred, succ)) = { switch(pred, succ) { case (0b0011, 0b0011) -> MEM_fence_rw_rw() case (0b0010, 0b0011) -> MEM_fence_r_rw() + case (0b0010, 0b0010) -> MEM_fence_r_r() case (0b0011, 0b0001) -> MEM_fence_rw_w() case (0b0001, 0b0001) -> MEM_fence_w_w() case _ -> not_implemented("unsupported fence") diff --git a/risc-v/riscv_extras.lem b/risc-v/riscv_extras.lem index 280095e5..30043779 100644 --- a/risc-v/riscv_extras.lem +++ b/risc-v/riscv_extras.lem @@ -76,6 +76,7 @@ let speculate_conditional_success : excl_res = let barrier_functions = [ ("MEM_fence_rw_rw", Barrier_RISCV_rw_rw); ("MEM_fence_r_rw", Barrier_RISCV_r_rw); + ("MEM_fence_r_r", Barrier_RISCV_r_r); ("MEM_fence_rw_w", Barrier_RISCV_rw_w); ("MEM_fence_w_w", Barrier_RISCV_w_w); ("MEM_fence_i", Barrier_RISCV_i); diff --git a/risc-v/riscv_extras_embed.lem b/risc-v/riscv_extras_embed.lem index d89dc44c..32110079 100644 --- a/risc-v/riscv_extras_embed.lem +++ b/risc-v/riscv_extras_embed.lem @@ -53,12 +53,14 @@ let speculate_conditional_success () = excl_result () >>= fun b -> return (if b val MEM_fence_rw_rw : unit -> M unit val MEM_fence_r_rw : unit -> M unit +val MEM_fence_r_r : unit -> M unit val MEM_fence_rw_w : unit -> M unit val MEM_fence_w_w : unit -> M unit val MEM_fence_i : unit -> M unit let MEM_fence_rw_rw () = barrier Barrier_RISCV_rw_rw let MEM_fence_r_rw () = barrier Barrier_RISCV_r_rw +let MEM_fence_r_r () = barrier Barrier_RISCV_r_r let MEM_fence_rw_w () = barrier Barrier_RISCV_rw_w let MEM_fence_w_w () = barrier Barrier_RISCV_w_w let MEM_fence_i () = barrier Barrier_RISCV_i diff --git a/risc-v/riscv_extras_embed_sequential.lem b/risc-v/riscv_extras_embed_sequential.lem index 1f2a0e47..3c922268 100644 --- a/risc-v/riscv_extras_embed_sequential.lem +++ b/risc-v/riscv_extras_embed_sequential.lem @@ -53,12 +53,14 @@ let speculate_conditional_success () = excl_result () >>= fun b -> return (if b val MEM_fence_rw_rw : unit -> M unit val MEM_fence_r_rw : unit -> M unit +val MEM_fence_r_r : unit -> M unit val MEM_fence_rw_w : unit -> M unit val MEM_fence_w_w : unit -> M unit val MEM_fence_i : unit -> M unit let MEM_fence_rw_rw () = barrier Barrier_RISCV_rw_rw let MEM_fence_r_rw () = barrier Barrier_RISCV_r_rw +let MEM_fence_r_r () = barrier Barrier_RISCV_r_r let MEM_fence_rw_w () = barrier Barrier_RISCV_rw_w let MEM_fence_w_w () = barrier Barrier_RISCV_w_w let MEM_fence_i () = barrier Barrier_RISCV_i diff --git a/risc-v/riscv_regfp.sail b/risc-v/riscv_regfp.sail index 602f0bec..ad341c60 100644 --- a/risc-v/riscv_regfp.sail +++ b/risc-v/riscv_regfp.sail @@ -93,6 +93,7 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( switch(pred, succ) { case (0b0011, 0b0011) -> IK_barrier (Barrier_RISCV_rw_rw) case (0b0010, 0b0011) -> IK_barrier (Barrier_RISCV_r_rw) + case (0b0010, 0b0010) -> IK_barrier (Barrier_RISCV_r_r) case (0b0011, 0b0001) -> IK_barrier (Barrier_RISCV_rw_w) case (0b0001, 0b0001) -> IK_barrier (Barrier_RISCV_w_w) case _ -> exit "not implemented" diff --git a/risc-v/riscv_types.sail b/risc-v/riscv_types.sail index a11d5561..a7cda963 100644 --- a/risc-v/riscv_types.sail +++ b/risc-v/riscv_types.sail @@ -138,6 +138,7 @@ val extern unit -> bool effect {exmem} speculate_conditional_success val extern unit -> unit effect { barr } MEM_fence_rw_rw val extern unit -> unit effect { barr } MEM_fence_r_rw +val extern unit -> unit effect { barr } MEM_fence_r_r val extern unit -> unit effect { barr } MEM_fence_rw_w val extern unit -> unit effect { barr } MEM_fence_w_w val extern unit -> unit effect { barr } MEM_fence_i diff --git a/src/gen_lib/deep_shallow_convert.lem b/src/gen_lib/deep_shallow_convert.lem index 5a0dd99e..76880dbd 100644 --- a/src/gen_lib/deep_shallow_convert.lem +++ b/src/gen_lib/deep_shallow_convert.lem @@ -471,10 +471,11 @@ let barrier_kindToInterpValue = function | Barrier_MIPS_SYNC -> V_ctor (Id_aux (Id "Barrier_MIPS_SYNC") Unknown) (T_id "barrier_kind") (C_Enum 12) (toInterpValue ()) | Barrier_RISCV_rw_rw -> V_ctor (Id_aux (Id "Barrier_RISCV_rw_rw") Unknown) (T_id "barrier_kind") (C_Enum 13) (toInterpValue ()) | Barrier_RISCV_r_rw -> V_ctor (Id_aux (Id "Barrier_RISCV_r_rw") Unknown) (T_id "barrier_kind") (C_Enum 14) (toInterpValue ()) - | Barrier_RISCV_rw_w -> V_ctor (Id_aux (Id "Barrier_RISCV_rw_w") Unknown) (T_id "barrier_kind") (C_Enum 15) (toInterpValue ()) - | Barrier_RISCV_w_w -> V_ctor (Id_aux (Id "Barrier_RISCV_w_w") Unknown) (T_id "barrier_kind") (C_Enum 16) (toInterpValue ()) - | Barrier_RISCV_i -> V_ctor (Id_aux (Id "Barrier_RISCV_i") Unknown) (T_id "barrier_kind") (C_Enum 17) (toInterpValue ()) - | Barrier_x86_MFENCE -> V_ctor (Id_aux (Id "Barrier_x86_MFENCE") Unknown) (T_id "barrier_kind") (C_Enum 18) (toInterpValue ()) + | Barrier_RISCV_r_r -> V_ctor (Id_aux (Id "Barrier_RISCV_r_r") Unknown) (T_id "barrier_kind") (C_Enum 15) (toInterpValue ()) + | Barrier_RISCV_rw_w -> V_ctor (Id_aux (Id "Barrier_RISCV_rw_w") Unknown) (T_id "barrier_kind") (C_Enum 16) (toInterpValue ()) + | Barrier_RISCV_w_w -> V_ctor (Id_aux (Id "Barrier_RISCV_w_w") Unknown) (T_id "barrier_kind") (C_Enum 17) (toInterpValue ()) + | Barrier_RISCV_i -> V_ctor (Id_aux (Id "Barrier_RISCV_i") Unknown) (T_id "barrier_kind") (C_Enum 18) (toInterpValue ()) + | Barrier_x86_MFENCE -> V_ctor (Id_aux (Id "Barrier_x86_MFENCE") Unknown) (T_id "barrier_kind") (C_Enum 19) (toInterpValue ()) end let rec barrier_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Barrier_Sync") _) _ _ v -> Barrier_Sync @@ -492,6 +493,7 @@ let rec barrier_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Barrier_MIPS_SYNC") _) _ _ v -> Barrier_MIPS_SYNC | V_ctor (Id_aux (Id "Barrier_RISCV_rw_rw") _) _ _ v -> Barrier_RISCV_rw_rw | V_ctor (Id_aux (Id "Barrier_RISCV_r_rw") _) _ _ v -> Barrier_RISCV_r_rw + | V_ctor (Id_aux (Id "Barrier_RISCV_r_r") _) _ _ v -> Barrier_RISCV_r_r | V_ctor (Id_aux (Id "Barrier_RISCV_rw_w") _) _ _ v -> Barrier_RISCV_rw_w | V_ctor (Id_aux (Id "Barrier_RISCV_w_w") _) _ _ v -> Barrier_RISCV_w_w | V_ctor (Id_aux (Id "Barrier_RISCV_i") _) _ _ v -> Barrier_RISCV_i diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 4f07f574..c0ec8548 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -501,6 +501,7 @@ type barrier_kind = (* RISC-V barriers *) | Barrier_RISCV_rw_rw | Barrier_RISCV_r_rw + | Barrier_RISCV_r_r | Barrier_RISCV_rw_w | Barrier_RISCV_w_w | Barrier_RISCV_i @@ -525,6 +526,7 @@ instance (Show barrier_kind) | Barrier_MIPS_SYNC -> "Barrier_MIPS_SYNC" | Barrier_RISCV_rw_rw -> "Barrier_RISCV_rw_rw" | Barrier_RISCV_r_rw -> "Barrier_RISCV_r_rw" + | Barrier_RISCV_r_r -> "Barrier_RISCV_r_r" | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" | Barrier_RISCV_w_w -> "Barrier_RISCV_w_w" | Barrier_RISCV_i -> "Barrier_RISCV_i" @@ -621,10 +623,11 @@ instance (EnumerationType barrier_kind) | Barrier_MIPS_SYNC -> 12 | Barrier_RISCV_rw_rw -> 13 | Barrier_RISCV_r_rw -> 14 - | Barrier_RISCV_rw_w -> 15 - | Barrier_RISCV_w_w -> 16 - | Barrier_RISCV_i -> 17 - | Barrier_x86_MFENCE -> 18 + | Barrier_RISCV_r_r -> 15 + | Barrier_RISCV_rw_w -> 16 + | Barrier_RISCV_w_w -> 17 + | Barrier_RISCV_i -> 18 + | Barrier_x86_MFENCE -> 19 end end -- cgit v1.2.3 From 40a85677707395199a005c2742304b80be87e117 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Wed, 1 Nov 2017 18:42:17 +0000 Subject: workaound for another odd interpreter error where top level let variable got truncated to 64 bits... --- cheri/cheri_prelude_256.sail | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cheri/cheri_prelude_256.sail b/cheri/cheri_prelude_256.sail index 1b13e408..b2bc8b1f 100644 --- a/cheri/cheri_prelude_256.sail +++ b/cheri/cheri_prelude_256.sail @@ -155,12 +155,12 @@ function (bit[257]) memBitsToCapBits256((bool) tag, (bit[256]) b) = this ensures that canonical null_cap is always all-zeros in memory even though it may have bits set logically (e.g. length or exponent *) -let (bit[256]) null_cap_bits = capStructToMemBits256(null_cap) - function (bit[256]) capStructToMemBits((CapStruct) cap) = + let (bit[256]) null_cap_bits = capStructToMemBits256(null_cap) in capStructToMemBits256(cap) ^ null_cap_bits function (bit[257]) memBitsToCapBits((bool) tag, (bit[256]) b) = + let (bit[256]) null_cap_bits = capStructToMemBits256(null_cap) in memBitsToCapBits256(tag, b ^ null_cap_bits) function (CapReg) capStructToCapReg((CapStruct) cap) = -- cgit v1.2.3 From d91841f80740b210c673d3138f77b9d4d5684102 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Thu, 2 Nov 2017 14:06:24 +0000 Subject: reset inCCallDelay in code that is not dead. --- src/lem_interp/run_with_elf_cheri.ml | 1 + src/lem_interp/run_with_elf_cheri128.ml | 1 + 2 files changed, 2 insertions(+) diff --git a/src/lem_interp/run_with_elf_cheri.ml b/src/lem_interp/run_with_elf_cheri.ml index b50cb01d..8f7d5505 100644 --- a/src/lem_interp/run_with_elf_cheri.ml +++ b/src/lem_interp/run_with_elf_cheri.ml @@ -1285,6 +1285,7 @@ let rec fde_loop count context model mode track_dependencies addr_trans = let npc_addr = add_address_nat pc_val 4 in let npc_reg = register_value_of_address npc_addr Sail_impl_base.D_decreasing in reg := Reg.add "nextPC" npc_reg !reg; + reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; | Some 1 -> reg := Reg.add "nextPC" (Reg.find "delayedPC" !reg) !reg; reg := Reg.add "nextPCC" (Reg.find "delayedPCC" !reg) !reg; diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index 148b29ae..311d6f69 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -1285,6 +1285,7 @@ let rec fde_loop count context model mode track_dependencies addr_trans = let npc_addr = add_address_nat pc_val 4 in let npc_reg = register_value_of_address npc_addr Sail_impl_base.D_decreasing in reg := Reg.add "nextPC" npc_reg !reg; + reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; | Some 1 -> reg := Reg.add "nextPC" (Reg.find "delayedPC" !reg) !reg; reg := Reg.add "nextPCC" (Reg.find "delayedPCC" !reg) !reg; -- cgit v1.2.3 From 5d59b0c1a477c2d9e1abcfc6fb1b51dff32bd9b5 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Thu, 2 Nov 2017 14:47:30 +0000 Subject: remove a lot of dead code form run_with_elf_cheri* --- src/lem_interp/run_with_elf_cheri.ml | 568 ------------------------------- src/lem_interp/run_with_elf_cheri128.ml | 570 -------------------------------- 2 files changed, 1138 deletions(-) diff --git a/src/lem_interp/run_with_elf_cheri.ml b/src/lem_interp/run_with_elf_cheri.ml index 8f7d5505..7750c16c 100644 --- a/src/lem_interp/run_with_elf_cheri.ml +++ b/src/lem_interp/run_with_elf_cheri.ml @@ -124,369 +124,6 @@ let register_state_zero register_data rbn : register_value = in register_value_zeros dir width start_index type model = PPC | AArch64 | MIPS -(* -let ppc_register_data_all = [ - (*Pseudo registers*) - ("CIA", (D_increasing, 64, 0)); - ("NIA", (D_increasing, 64, 0)); - ("mode64bit", (D_increasing, 1, 0)); - ("bigendianmode", (D_increasing, 1, 0)); - (* special registers *) - ("CR", (D_increasing, 32, 32)); - ("CTR", (D_increasing, 64, 0 )); - ("LR", (D_increasing, 64, 0 )); - ("XER", (D_increasing, 64, 0 )); - ("VRSAVE",(D_increasing, 32, 32)); - ("FPSCR", (D_increasing, 64, 0 )); - ("VSCR", (D_increasing, 32, 96)); - - (* general purpose registers *) - ("GPR0", (D_increasing, 64, 0 )); - ("GPR1", (D_increasing, 64, 0 )); - ("GPR2", (D_increasing, 64, 0 )); - ("GPR3", (D_increasing, 64, 0 )); - ("GPR4", (D_increasing, 64, 0 )); - ("GPR5", (D_increasing, 64, 0 )); - ("GPR6", (D_increasing, 64, 0 )); - ("GPR7", (D_increasing, 64, 0 )); - ("GPR8", (D_increasing, 64, 0 )); - ("GPR9", (D_increasing, 64, 0 )); - ("GPR10", (D_increasing, 64, 0 )); - ("GPR11", (D_increasing, 64, 0 )); - ("GPR12", (D_increasing, 64, 0 )); - ("GPR13", (D_increasing, 64, 0 )); - ("GPR14", (D_increasing, 64, 0 )); - ("GPR15", (D_increasing, 64, 0 )); - ("GPR16", (D_increasing, 64, 0 )); - ("GPR17", (D_increasing, 64, 0 )); - ("GPR18", (D_increasing, 64, 0 )); - ("GPR19", (D_increasing, 64, 0 )); - ("GPR20", (D_increasing, 64, 0 )); - ("GPR21", (D_increasing, 64, 0 )); - ("GPR22", (D_increasing, 64, 0 )); - ("GPR23", (D_increasing, 64, 0 )); - ("GPR24", (D_increasing, 64, 0 )); - ("GPR25", (D_increasing, 64, 0 )); - ("GPR26", (D_increasing, 64, 0 )); - ("GPR27", (D_increasing, 64, 0 )); - ("GPR28", (D_increasing, 64, 0 )); - ("GPR29", (D_increasing, 64, 0 )); - ("GPR30", (D_increasing, 64, 0 )); - ("GPR31", (D_increasing, 64, 0 )); - (* vector registers *) - ("VR0", (D_increasing, 128, 0 )); - ("VR1", (D_increasing, 128, 0 )); - ("VR2", (D_increasing, 128, 0 )); - ("VR3", (D_increasing, 128, 0 )); - ("VR4", (D_increasing, 128, 0 )); - ("VR5", (D_increasing, 128, 0 )); - ("VR6", (D_increasing, 128, 0 )); - ("VR7", (D_increasing, 128, 0 )); - ("VR8", (D_increasing, 128, 0 )); - ("VR9", (D_increasing, 128, 0 )); - ("VR10", (D_increasing, 128, 0 )); - ("VR11", (D_increasing, 128, 0 )); - ("VR12", (D_increasing, 128, 0 )); - ("VR13", (D_increasing, 128, 0 )); - ("VR14", (D_increasing, 128, 0 )); - ("VR15", (D_increasing, 128, 0 )); - ("VR16", (D_increasing, 128, 0 )); - ("VR17", (D_increasing, 128, 0 )); - ("VR18", (D_increasing, 128, 0 )); - ("VR19", (D_increasing, 128, 0 )); - ("VR20", (D_increasing, 128, 0 )); - ("VR21", (D_increasing, 128, 0 )); - ("VR22", (D_increasing, 128, 0 )); - ("VR23", (D_increasing, 128, 0 )); - ("VR24", (D_increasing, 128, 0 )); - ("VR25", (D_increasing, 128, 0 )); - ("VR26", (D_increasing, 128, 0 )); - ("VR27", (D_increasing, 128, 0 )); - ("VR28", (D_increasing, 128, 0 )); - ("VR29", (D_increasing, 128, 0 )); - ("VR30", (D_increasing, 128, 0 )); - ("VR31", (D_increasing, 128, 0 )); - (* floating-point registers *) - ("FPR0", (D_increasing, 64, 0 )); - ("FPR1", (D_increasing, 64, 0 )); - ("FPR2", (D_increasing, 64, 0 )); - ("FPR3", (D_increasing, 64, 0 )); - ("FPR4", (D_increasing, 64, 0 )); - ("FPR5", (D_increasing, 64, 0 )); - ("FPR6", (D_increasing, 64, 0 )); - ("FPR7", (D_increasing, 64, 0 )); - ("FPR8", (D_increasing, 64, 0 )); - ("FPR9", (D_increasing, 64, 0 )); - ("FPR10", (D_increasing, 64, 0 )); - ("FPR11", (D_increasing, 64, 0 )); - ("FPR12", (D_increasing, 64, 0 )); - ("FPR13", (D_increasing, 64, 0 )); - ("FPR14", (D_increasing, 64, 0 )); - ("FPR15", (D_increasing, 64, 0 )); - ("FPR16", (D_increasing, 64, 0 )); - ("FPR17", (D_increasing, 64, 0 )); - ("FPR18", (D_increasing, 64, 0 )); - ("FPR19", (D_increasing, 64, 0 )); - ("FPR20", (D_increasing, 64, 0 )); - ("FPR21", (D_increasing, 64, 0 )); - ("FPR22", (D_increasing, 64, 0 )); - ("FPR23", (D_increasing, 64, 0 )); - ("FPR24", (D_increasing, 64, 0 )); - ("FPR25", (D_increasing, 64, 0 )); - ("FPR26", (D_increasing, 64, 0 )); - ("FPR27", (D_increasing, 64, 0 )); - ("FPR28", (D_increasing, 64, 0 )); - ("FPR29", (D_increasing, 64, 0 )); - ("FPR30", (D_increasing, 64, 0 )); - ("FPR31", (D_increasing, 64, 0 )); -] - -let initial_stack_and_reg_data_of_PPC_elf_file e_entry all_data_memory = - (* set up initial registers, per 3.4.1 of 64-bit PowerPC ELF Application Binary Interface Supplement 1.9 *) - - let auxiliary_vector_space = Nat_big_num.of_string "17592186042368" (*"0xffffffff800"*) in - (* notionally there should be at least an AT_NULL auxiliary vector entry there, but our examples will never read it *) - - (* take start of stack roughly where running gdb on hello5 on bim says it is*) - let initial_GPR1_stack_pointer = Nat_big_num.of_string "17592186040320" (*"0xffffffff000"*) in - let initial_GPR1_stack_pointer_value = - Sail_impl_base.register_value_of_integer 64 0 Sail_impl_base.D_increasing initial_GPR1_stack_pointer in - (* ELF says we need an initial zero doubleword there *) - let initial_stack_data = - (* the code actually uses the stack, both above and below, so we map a bit more memory*) - (* this is a fairly big but arbitrary chunk *) - (* let initial_stack_data_address = Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128) in - [("initial_stack_data", initial_stack_data_address, Lem_list.replicate (128+32) 0 ))] in *) - (* this is the stack memory that test 1938 actually uses *) - [ ("initial_stack_data1", Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128), - Lem_list.replicate 8 0 ); - ("initial_stack_data2", Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 8), - Lem_list.replicate 8 0 ); - ("initial_stack_data3", Nat_big_num.add initial_GPR1_stack_pointer (Nat_big_num.of_int 16), - Lem_list.replicate 8 0 )] in - - (* read TOC from the second field of the function descriptor pointed to by e_entry*) - let initial_GPR2_TOC = - Sail_impl_base.register_value_of_address - (Sail_impl_base.address_of_byte_list - (List.map (fun b -> match b with Some b -> b | None -> failwith "Address had undefined") - (List.map byte_of_byte_lifted - (read_mem all_data_memory - (Nat_big_num.add (Nat_big_num.of_int 8) e_entry) 8)))) - Sail_impl_base.D_increasing in - (* these initial register values are all mandated to be zero, but that's handled by the generic zeroing below - let initial_GPR3_argc = (Nat_big_num.of_int 0) in - let initial_GPR4_argv = (Nat_big_num.of_int 0) in - let initial_GPR5_envp = (Nat_big_num.of_int 0) in - let initial_FPSCR = (Nat_big_num.of_int 0) in - *) - let initial_register_abi_data : (string * Sail_impl_base.register_value) list = - [ ("GPR1", initial_GPR1_stack_pointer_value); - ("GPR2", initial_GPR2_TOC); - (* - ("GPR3", initial_GPR3_argc); - ("GPR4", initial_GPR4_argv); - ("GPR5", initial_GPR5_envp); - ("FPSCR", initial_FPSCR); - *) - ] in - - (initial_stack_data, initial_register_abi_data) - - -let aarch64_reg bit_count name = (name, (D_decreasing, bit_count, bit_count - 1)) - -let aarch64_PC_data = [aarch64_reg 64 "_PC"] - -(* most of the PSTATE fields are aliases to other registers so they - don't appear here *) -let aarch64_PSTATE_data = [ - aarch64_reg 1 "PSTATE_nRW"; - aarch64_reg 1 "PSTATE_E"; - aarch64_reg 5 "PSTATE_M"; -] - -let aarch64_general_purpose_registers_data = [ - aarch64_reg 64 "R0"; - aarch64_reg 64 "R1"; - aarch64_reg 64 "R2"; - aarch64_reg 64 "R3"; - aarch64_reg 64 "R4"; - aarch64_reg 64 "R5"; - aarch64_reg 64 "R6"; - aarch64_reg 64 "R7"; - aarch64_reg 64 "R8"; - aarch64_reg 64 "R9"; - aarch64_reg 64 "R10"; - aarch64_reg 64 "R11"; - aarch64_reg 64 "R12"; - aarch64_reg 64 "R13"; - aarch64_reg 64 "R14"; - aarch64_reg 64 "R15"; - aarch64_reg 64 "R16"; - aarch64_reg 64 "R17"; - aarch64_reg 64 "R18"; - aarch64_reg 64 "R19"; - aarch64_reg 64 "R20"; - aarch64_reg 64 "R21"; - aarch64_reg 64 "R22"; - aarch64_reg 64 "R23"; - aarch64_reg 64 "R24"; - aarch64_reg 64 "R25"; - aarch64_reg 64 "R26"; - aarch64_reg 64 "R27"; - aarch64_reg 64 "R28"; - aarch64_reg 64 "R29"; - aarch64_reg 64 "R30"; -] - -let aarch64_SIMD_registers_data = [ - aarch64_reg 128 "V0"; - aarch64_reg 128 "V1"; - aarch64_reg 128 "V2"; - aarch64_reg 128 "V3"; - aarch64_reg 128 "V4"; - aarch64_reg 128 "V5"; - aarch64_reg 128 "V6"; - aarch64_reg 128 "V7"; - aarch64_reg 128 "V8"; - aarch64_reg 128 "V9"; - aarch64_reg 128 "V10"; - aarch64_reg 128 "V11"; - aarch64_reg 128 "V12"; - aarch64_reg 128 "V13"; - aarch64_reg 128 "V14"; - aarch64_reg 128 "V15"; - aarch64_reg 128 "V16"; - aarch64_reg 128 "V17"; - aarch64_reg 128 "V18"; - aarch64_reg 128 "V19"; - aarch64_reg 128 "V20"; - aarch64_reg 128 "V21"; - aarch64_reg 128 "V22"; - aarch64_reg 128 "V23"; - aarch64_reg 128 "V24"; - aarch64_reg 128 "V25"; - aarch64_reg 128 "V26"; - aarch64_reg 128 "V27"; - aarch64_reg 128 "V28"; - aarch64_reg 128 "V29"; - aarch64_reg 128 "V30"; - aarch64_reg 128 "V31"; -] - -let aarch64_special_purpose_registers_data = [ - aarch64_reg 32 "CurrentEL"; - aarch64_reg 32 "DAIF"; - aarch64_reg 32 "NZCV"; - aarch64_reg 64 "SP_EL0"; - aarch64_reg 64 "SP_EL1"; - aarch64_reg 64 "SP_EL2"; - aarch64_reg 64 "SP_EL3"; - aarch64_reg 32 "SPSel"; - aarch64_reg 32 "SPSR_EL1"; - aarch64_reg 32 "SPSR_EL2"; - aarch64_reg 32 "SPSR_EL3"; - aarch64_reg 64 "ELR_EL1"; - aarch64_reg 64 "ELR_EL2"; - aarch64_reg 64 "ELR_EL3"; -] - -let aarch64_general_system_control_registers_data = [ - aarch64_reg 64 "HCR_EL2"; - aarch64_reg 64 "ID_AA64MMFR0_EL1"; - aarch64_reg 64 "RVBAR_EL1"; - aarch64_reg 64 "RVBAR_EL2"; - aarch64_reg 64 "RVBAR_EL3"; - aarch64_reg 32 "SCR_EL3"; - aarch64_reg 32 "SCTLR_EL1"; - aarch64_reg 32 "SCTLR_EL2"; - aarch64_reg 32 "SCTLR_EL3"; - aarch64_reg 64 "TCR_EL1"; - aarch64_reg 32 "TCR_EL2"; - aarch64_reg 32 "TCR_EL3"; -] - -let aarch64_debug_registers_data = [ - aarch64_reg 32 "DBGPRCR_EL1"; - aarch64_reg 32 "OSDLR_EL1"; -] - -let aarch64_performance_monitors_registers_data = [] -let aarch64_generic_timer_registers_data = [] -let aarch64_generic_interrupt_controller_CPU_interface_registers_data = [] - -let aarch64_external_debug_registers_data = [ - aarch64_reg 32 "EDSCR"; -] - -let aarch32_general_system_control_registers_data = [ - aarch64_reg 32 "SCR"; -] - -let aarch32_debug_registers_data = [ - aarch64_reg 32 "DBGOSDLR"; - aarch64_reg 32 "DBGPRCR"; -] - -let aarch64_register_data_all = - aarch64_PC_data @ - aarch64_PSTATE_data @ - aarch64_general_purpose_registers_data @ - aarch64_SIMD_registers_data @ - aarch64_special_purpose_registers_data @ - aarch64_general_system_control_registers_data @ - aarch64_debug_registers_data @ - aarch64_performance_monitors_registers_data @ - aarch64_generic_timer_registers_data @ - aarch64_generic_interrupt_controller_CPU_interface_registers_data @ - aarch64_external_debug_registers_data @ - aarch32_general_system_control_registers_data @ - aarch32_debug_registers_data - -let initial_stack_and_reg_data_of_AAarch64_elf_file e_entry all_data_memory = - let (reg_SP_EL0_direction, reg_SP_EL0_width, reg_SP_EL0_initial_index) = - List.assoc "SP_EL0" aarch64_register_data_all in - - (* we compiled a small program that prints out SP and run it a few - times on the Nexus9, these are the results: - 0x0000007fe7f903e0 - 0x0000007fdcdbf3f0 - 0x0000007fcbe1ba90 - 0x0000007fcf378280 - 0x0000007fdd54b8d0 - 0x0000007fd961bc10 - 0x0000007ff3be6350 - 0x0000007fd6bf6ef0 - 0x0000007fff7676f0 - 0x0000007ff2c34560 *) - let initial_SP_EL0 = Nat_big_num.of_string "549739036672" (*"0x0000007fff000000"*) in - let initial_SP_EL0_value = - Sail_impl_base.register_value_of_integer - reg_SP_EL0_width - reg_SP_EL0_initial_index - reg_SP_EL0_direction - initial_SP_EL0 - in - - (* ELF says we need an initial zero doubleword there *) - (* the code actually uses the stack, both above and below, so we map a bit more memory*) - let initial_stack_data = - (* this is a fairly big but arbitrary chunk: *) - (* let initial_stack_data_address = Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128) in - [("initial_stack_data", initial_stack_data_address, Lem_list.replicate (128+32) 0 ))] in *) - - [ ("initial_stack_data1", Nat_big_num.sub initial_SP_EL0 (Nat_big_num.of_int 16), Lem_list.replicate 8 0); - ("initial_stack_data2", Nat_big_num.sub initial_SP_EL0 (Nat_big_num.of_int 8), Lem_list.replicate 8 0) - ] - in - - let initial_register_abi_data : (string * Sail_impl_base.register_value) list = - [("SP_EL0", initial_SP_EL0_value)] - in - - (initial_stack_data, initial_register_abi_data) -*) let mips_register_data_all = [ (*Pseudo registers*) @@ -749,50 +386,6 @@ let initial_system_state_of_elf_file name = let (isa_defs, isa_memory_access, isa_externs, isa_model, model_reg_d, startaddr, initial_stack_data, initial_register_abi_data, register_data_all) = match Nat_big_num.to_int e_machine with -(* | 21 (* EM_PPC64 *) -> - let startaddr = - let e_entry = Uint64.of_int64 (Nat_big_num.to_int64 e_entry) in - match Abi_power64.abi_power64_compute_program_entry_point segments e_entry with - | Error.Fail s -> failwith "Failed computing entry point" - | Error.Success s -> Nat_big_num.of_int64 (Uint64.to_int64 s) - in - let (initial_stack_data, initial_register_abi_data) = - initial_stack_and_reg_data_of_PPC_elf_file e_entry !data_mem in - - (Power.defs, - (Power_extras.read_memory_functions,Power_extras.memory_writes,[],[],Power_extras.barrier_functions), - Power_extras.power_externs, - PPC, - D_increasing, - startaddr, - initial_stack_data, - initial_register_abi_data, - ppc_register_data_all) - - | 183 (* EM_AARCH64 *) -> - let startaddr = - let e_entry = Uint64.of_int64 (Nat_big_num.to_int64 e_entry) in - match Abi_aarch64_le.abi_aarch64_le_compute_program_entry_point segments e_entry with - | Error.Fail s -> failwith "Failed computing entry point" - | Error.Success s -> Nat_big_num.of_int64 (Uint64.to_int64 s) - in - - let (initial_stack_data, initial_register_abi_data) = - initial_stack_and_reg_data_of_AAarch64_elf_file e_entry !data_mem in - - (ArmV8.defs, - (ArmV8_extras.aArch64_read_memory_functions, - ArmV8_extras.aArch64_memory_writes, - ArmV8_extras.aArch64_memory_eas, - ArmV8_extras.aArch64_memory_vals, - ArmV8_extras.aArch64_barrier_functions), - [], - AArch64, - D_decreasing, - startaddr, - initial_stack_data, - initial_register_abi_data, - aarch64_register_data_all) *) | 8 (* EM_MIPS *) -> let startaddr = let e_entry = Uint64.of_string (Nat_big_num.to_string e_entry) in @@ -889,50 +482,6 @@ let initial_system_state_of_elf_file name = in - (* Now we examine the rest of the data memory, - removing the footprint of the symbols and chunking it into aligned chunks *) - - let rec remove_symbols_from_data_memory data_mem symbols = - match symbols with - | [] -> data_mem - | (name,address,size,bs)::symbols' -> - let data_mem' = - Mem.filter - (fun a v -> - not (Nat_big_num.greater_equal a address && - Nat_big_num.less a (Nat_big_num.add (Nat_big_num.of_int (List.length bs)) address))) - data_mem in - remove_symbols_from_data_memory data_mem' symbols' in - - let trimmed_data_memory : (Nat_big_num.num * memory_byte) list = - Mem.bindings (remove_symbols_from_data_memory !data_mem symbol_table) in - - (* make sure that's ordered increasingly.... *) - let trimmed_data_memory = - List.sort (fun (a,b) (a',b') -> Nat_big_num.compare a a') trimmed_data_memory in - - let aligned a n = (* a mod n = 0 *) - let n_big = Nat_big_num.of_int n in - Nat_big_num.equal (Nat_big_num.modulus a n_big) ((Nat_big_num.of_int 0)) in - - let isplus a' a n = (* a' = a+n *) - Nat_big_num.equal a' (Nat_big_num.add (Nat_big_num.of_int n) a) in - - let rec chunk_data_memory dm = - match dm with - | (a0,b0)::(a1,b1)::(a2,b2)::(a3,b3)::(a4,b4)::(a5,b5)::(a6,b6)::(a7,b7)::dm' when - (aligned a0 8 && isplus a1 a0 1 && isplus a2 a0 2 && isplus a3 a0 3 && - isplus a4 a0 4 && isplus a5 a0 5 && isplus a6 a0 6 && isplus a7 a0 7) -> - (a0,8,[b0;b1;b2;b3;b4;b5;b6;b7]) :: chunk_data_memory dm' - | (a0,b0)::(a1,b1)::(a2,b2)::(a3,b3)::dm' when - (aligned a0 4 && isplus a1 a0 1 && isplus a2 a0 2 && isplus a3 a0 3) -> - (a0,4,[b0;b1;b2;b3]) :: chunk_data_memory dm' - | (a0,b0)::(a1,b1)::dm' when - (aligned a0 2 && isplus a1 a0 1) -> - (a0,2,[b0;b1]) :: chunk_data_memory dm' - | (a0,b0)::dm' -> - (a0,1,[b0]):: chunk_data_memory dm' - | [] -> [] in let initial_register_state = fun rbn -> @@ -1022,69 +571,10 @@ let stop_condition_met model instr = true | _ -> false) -let is_branch model instruction = - let (name,_,_) = instruction in - match (model , name) with - | (PPC, "B") -> true - | (PPC, "Bc") -> true - | (PPC, "Bclr") -> true - | (PPC, "Bcctr") -> true - | (PPC, _) -> false - | (AArch64, "BranchImmediate") -> true - | (AArch64, "BranchConditional") -> true - | (AArch64, "CompareAndBranch") -> true - | (AArch64, "TestBitAndBranch") -> true - | (AArch64, "BranchRegister") -> true - | (AArch64, _) -> false - | (MIPS, _) -> false (*todo,fill this in*) - let option_int_of_option_integer i = match i with | Some i -> Some (Nat_big_num.to_int i) | None -> None -let set_next_instruction_address model = - match model with - | PPC -> - let cia = Reg.find "CIA" !reg in - let cia_addr = address_of_register_value cia in - (match cia_addr with - | Some cia_addr -> - let nia_addr = add_address_nat cia_addr 4 in - let nia = register_value_of_address nia_addr Sail_impl_base.D_increasing in - reg := Reg.add "NIA" nia !reg - | _ -> failwith "CIA address contains unknown or undefined") - | AArch64 -> - let pc = Reg.find "_PC" !reg in - let pc_addr = address_of_register_value pc in - (match pc_addr with - | Some pc_addr -> - let n_addr = add_address_nat pc_addr 4 in - let n_pc = register_value_of_address n_addr D_decreasing in - reg := Reg.add "_PC" n_pc !reg - | _ -> failwith "_PC address contains unknown or undefined") - | MIPS -> - let pc_addr = address_of_register_value (Reg.find "PC" !reg) in - let branchPending = integer_of_register_value (Reg.find "branchPending" !reg) in - (match (pc_addr, option_int_of_option_integer branchPending) with - | (Some pc_val, Some 0) -> - (* normal -- increment PC *) - let n_addr = add_address_nat pc_val 4 in - let n_pc = register_value_of_address n_addr D_decreasing in - begin - reg := Reg.add "nextPC" n_pc !reg; - reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - end - | (Some pc_val, Some 1) -> - (* delay slot -- branch to delayed PC and clear branchPending *) - begin - reg := Reg.add "nextPC" (Reg.find "delayedPC" !reg) !reg; - reg := Reg.add "nextPCC" (Reg.find "delayedPCC" !reg) !reg; - reg := Reg.add "branchPending" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing (Nat_big_num.of_int 1)) !reg; - end - | (_, _) -> errorf "PC address contains unknown or undefined"; exit 1) - let add1 = Nat_big_num.add (Nat_big_num.of_int 1) let get_addr_trans_regs _ = @@ -1194,68 +684,10 @@ let rec write_events = function | _ -> failwith "Only register write events expected"); write_events events -let fetch_instruction_opcode_and_update_ia model addr_trans = - match model with - | PPC -> - let cia = Reg.find "CIA" !reg in - let cia_addr = address_of_register_value cia in - (match cia_addr with - | Some cia_addr -> - let cia_a = integer_of_address cia_addr in - let opcode = (get_opcode cia_a) in - begin - reg := Reg.add "CIA" (Reg.find "NIA" !reg) !reg; - Opcode opcode - end - | None -> failwith "CIA address contains unknown or undefined") - | AArch64 -> - let pc = Reg.find "_PC" !reg in - let pc_addr = address_of_register_value pc in - (match pc_addr with - | Some pc_addr -> - let pc_a = integer_of_address pc_addr in - let opcode = (get_opcode pc_a) in - Opcode opcode - | None -> failwith "_PC address contains unknown or undefined") - | MIPS -> - begin - reg := Reg.add "PCC" (Reg.find "nextPCC" !reg) !reg; - let nextPC = Reg.find "nextPC" !reg in - let pc_addr = address_of_register_value nextPC in - (*let unused = interactf "PC: %s\n" (Printing_functions.register_value_to_string nextPC) in*) - (match pc_addr with - | Some pc_addr -> - let pc_a = match addr_trans (get_addr_trans_regs ()) pc_addr with - | Some a, Some events -> write_events (List.rev events); integer_of_address a - | Some a, None -> integer_of_address a - | None, Some events -> - write_events (List.rev events); - let nextPC = Reg.find "nextPC" !reg in - reg := Reg.add "PCC" (Reg.find "nextPCC" !reg) !reg; - let pc_addr = address_of_register_value nextPC in - (match pc_addr with - | Some pc_addr -> - (match addr_trans (get_addr_trans_regs ()) pc_addr with - | Some a, Some events -> write_events (List.rev events); integer_of_address a - | Some a, None -> integer_of_address a - | None, _ -> failwith "Address translation failed twice") - | None -> failwith "no nextPc address") - | _ -> failwith "No address and no events from translate address" - in - let opcode = (get_opcode pc_a) in - begin - reg := Reg.add "PC" (Reg.find "nextPC" !reg) !reg; - Opcode opcode - end - | None -> errorf "nextPC contains unknown or undefined"; exit 1) - end - | _ -> assert false - let get_pc_address = function | MIPS -> Reg.find "PC" !reg | PPC -> Reg.find "CIA" !reg | AArch64 -> Reg.find "_PC" !reg - let option_int_of_reg str = option_int_of_option_integer (integer_of_register_value (Reg.find str !reg)) diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index 311d6f69..6dca80f4 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -124,369 +124,6 @@ let register_state_zero register_data rbn : register_value = in register_value_zeros dir width start_index type model = PPC | AArch64 | MIPS -(* -let ppc_register_data_all = [ - (*Pseudo registers*) - ("CIA", (D_increasing, 64, 0)); - ("NIA", (D_increasing, 64, 0)); - ("mode64bit", (D_increasing, 1, 0)); - ("bigendianmode", (D_increasing, 1, 0)); - (* special registers *) - ("CR", (D_increasing, 32, 32)); - ("CTR", (D_increasing, 64, 0 )); - ("LR", (D_increasing, 64, 0 )); - ("XER", (D_increasing, 64, 0 )); - ("VRSAVE",(D_increasing, 32, 32)); - ("FPSCR", (D_increasing, 64, 0 )); - ("VSCR", (D_increasing, 32, 96)); - - (* general purpose registers *) - ("GPR0", (D_increasing, 64, 0 )); - ("GPR1", (D_increasing, 64, 0 )); - ("GPR2", (D_increasing, 64, 0 )); - ("GPR3", (D_increasing, 64, 0 )); - ("GPR4", (D_increasing, 64, 0 )); - ("GPR5", (D_increasing, 64, 0 )); - ("GPR6", (D_increasing, 64, 0 )); - ("GPR7", (D_increasing, 64, 0 )); - ("GPR8", (D_increasing, 64, 0 )); - ("GPR9", (D_increasing, 64, 0 )); - ("GPR10", (D_increasing, 64, 0 )); - ("GPR11", (D_increasing, 64, 0 )); - ("GPR12", (D_increasing, 64, 0 )); - ("GPR13", (D_increasing, 64, 0 )); - ("GPR14", (D_increasing, 64, 0 )); - ("GPR15", (D_increasing, 64, 0 )); - ("GPR16", (D_increasing, 64, 0 )); - ("GPR17", (D_increasing, 64, 0 )); - ("GPR18", (D_increasing, 64, 0 )); - ("GPR19", (D_increasing, 64, 0 )); - ("GPR20", (D_increasing, 64, 0 )); - ("GPR21", (D_increasing, 64, 0 )); - ("GPR22", (D_increasing, 64, 0 )); - ("GPR23", (D_increasing, 64, 0 )); - ("GPR24", (D_increasing, 64, 0 )); - ("GPR25", (D_increasing, 64, 0 )); - ("GPR26", (D_increasing, 64, 0 )); - ("GPR27", (D_increasing, 64, 0 )); - ("GPR28", (D_increasing, 64, 0 )); - ("GPR29", (D_increasing, 64, 0 )); - ("GPR30", (D_increasing, 64, 0 )); - ("GPR31", (D_increasing, 64, 0 )); - (* vector registers *) - ("VR0", (D_increasing, 128, 0 )); - ("VR1", (D_increasing, 128, 0 )); - ("VR2", (D_increasing, 128, 0 )); - ("VR3", (D_increasing, 128, 0 )); - ("VR4", (D_increasing, 128, 0 )); - ("VR5", (D_increasing, 128, 0 )); - ("VR6", (D_increasing, 128, 0 )); - ("VR7", (D_increasing, 128, 0 )); - ("VR8", (D_increasing, 128, 0 )); - ("VR9", (D_increasing, 128, 0 )); - ("VR10", (D_increasing, 128, 0 )); - ("VR11", (D_increasing, 128, 0 )); - ("VR12", (D_increasing, 128, 0 )); - ("VR13", (D_increasing, 128, 0 )); - ("VR14", (D_increasing, 128, 0 )); - ("VR15", (D_increasing, 128, 0 )); - ("VR16", (D_increasing, 128, 0 )); - ("VR17", (D_increasing, 128, 0 )); - ("VR18", (D_increasing, 128, 0 )); - ("VR19", (D_increasing, 128, 0 )); - ("VR20", (D_increasing, 128, 0 )); - ("VR21", (D_increasing, 128, 0 )); - ("VR22", (D_increasing, 128, 0 )); - ("VR23", (D_increasing, 128, 0 )); - ("VR24", (D_increasing, 128, 0 )); - ("VR25", (D_increasing, 128, 0 )); - ("VR26", (D_increasing, 128, 0 )); - ("VR27", (D_increasing, 128, 0 )); - ("VR28", (D_increasing, 128, 0 )); - ("VR29", (D_increasing, 128, 0 )); - ("VR30", (D_increasing, 128, 0 )); - ("VR31", (D_increasing, 128, 0 )); - (* floating-point registers *) - ("FPR0", (D_increasing, 64, 0 )); - ("FPR1", (D_increasing, 64, 0 )); - ("FPR2", (D_increasing, 64, 0 )); - ("FPR3", (D_increasing, 64, 0 )); - ("FPR4", (D_increasing, 64, 0 )); - ("FPR5", (D_increasing, 64, 0 )); - ("FPR6", (D_increasing, 64, 0 )); - ("FPR7", (D_increasing, 64, 0 )); - ("FPR8", (D_increasing, 64, 0 )); - ("FPR9", (D_increasing, 64, 0 )); - ("FPR10", (D_increasing, 64, 0 )); - ("FPR11", (D_increasing, 64, 0 )); - ("FPR12", (D_increasing, 64, 0 )); - ("FPR13", (D_increasing, 64, 0 )); - ("FPR14", (D_increasing, 64, 0 )); - ("FPR15", (D_increasing, 64, 0 )); - ("FPR16", (D_increasing, 64, 0 )); - ("FPR17", (D_increasing, 64, 0 )); - ("FPR18", (D_increasing, 64, 0 )); - ("FPR19", (D_increasing, 64, 0 )); - ("FPR20", (D_increasing, 64, 0 )); - ("FPR21", (D_increasing, 64, 0 )); - ("FPR22", (D_increasing, 64, 0 )); - ("FPR23", (D_increasing, 64, 0 )); - ("FPR24", (D_increasing, 64, 0 )); - ("FPR25", (D_increasing, 64, 0 )); - ("FPR26", (D_increasing, 64, 0 )); - ("FPR27", (D_increasing, 64, 0 )); - ("FPR28", (D_increasing, 64, 0 )); - ("FPR29", (D_increasing, 64, 0 )); - ("FPR30", (D_increasing, 64, 0 )); - ("FPR31", (D_increasing, 64, 0 )); -] - -let initial_stack_and_reg_data_of_PPC_elf_file e_entry all_data_memory = - (* set up initial registers, per 3.4.1 of 64-bit PowerPC ELF Application Binary Interface Supplement 1.9 *) - - let auxiliary_vector_space = Nat_big_num.of_string "17592186042368" (*"0xffffffff800"*) in - (* notionally there should be at least an AT_NULL auxiliary vector entry there, but our examples will never read it *) - - (* take start of stack roughly where running gdb on hello5 on bim says it is*) - let initial_GPR1_stack_pointer = Nat_big_num.of_string "17592186040320" (*"0xffffffff000"*) in - let initial_GPR1_stack_pointer_value = - Sail_impl_base.register_value_of_integer 64 0 Sail_impl_base.D_increasing initial_GPR1_stack_pointer in - (* ELF says we need an initial zero doubleword there *) - let initial_stack_data = - (* the code actually uses the stack, both above and below, so we map a bit more memory*) - (* this is a fairly big but arbitrary chunk *) - (* let initial_stack_data_address = Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128) in - [("initial_stack_data", initial_stack_data_address, Lem_list.replicate (128+32) 0 ))] in *) - (* this is the stack memory that test 1938 actually uses *) - [ ("initial_stack_data1", Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128), - Lem_list.replicate 8 0 ); - ("initial_stack_data2", Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 8), - Lem_list.replicate 8 0 ); - ("initial_stack_data3", Nat_big_num.add initial_GPR1_stack_pointer (Nat_big_num.of_int 16), - Lem_list.replicate 8 0 )] in - - (* read TOC from the second field of the function descriptor pointed to by e_entry*) - let initial_GPR2_TOC = - Sail_impl_base.register_value_of_address - (Sail_impl_base.address_of_byte_list - (List.map (fun b -> match b with Some b -> b | None -> failwith "Address had undefined") - (List.map byte_of_byte_lifted - (read_mem all_data_memory - (Nat_big_num.add (Nat_big_num.of_int 8) e_entry) 8)))) - Sail_impl_base.D_increasing in - (* these initial register values are all mandated to be zero, but that's handled by the generic zeroing below - let initial_GPR3_argc = (Nat_big_num.of_int 0) in - let initial_GPR4_argv = (Nat_big_num.of_int 0) in - let initial_GPR5_envp = (Nat_big_num.of_int 0) in - let initial_FPSCR = (Nat_big_num.of_int 0) in - *) - let initial_register_abi_data : (string * Sail_impl_base.register_value) list = - [ ("GPR1", initial_GPR1_stack_pointer_value); - ("GPR2", initial_GPR2_TOC); - (* - ("GPR3", initial_GPR3_argc); - ("GPR4", initial_GPR4_argv); - ("GPR5", initial_GPR5_envp); - ("FPSCR", initial_FPSCR); - *) - ] in - - (initial_stack_data, initial_register_abi_data) - - -let aarch64_reg bit_count name = (name, (D_decreasing, bit_count, bit_count - 1)) - -let aarch64_PC_data = [aarch64_reg 64 "_PC"] - -(* most of the PSTATE fields are aliases to other registers so they - don't appear here *) -let aarch64_PSTATE_data = [ - aarch64_reg 1 "PSTATE_nRW"; - aarch64_reg 1 "PSTATE_E"; - aarch64_reg 5 "PSTATE_M"; -] - -let aarch64_general_purpose_registers_data = [ - aarch64_reg 64 "R0"; - aarch64_reg 64 "R1"; - aarch64_reg 64 "R2"; - aarch64_reg 64 "R3"; - aarch64_reg 64 "R4"; - aarch64_reg 64 "R5"; - aarch64_reg 64 "R6"; - aarch64_reg 64 "R7"; - aarch64_reg 64 "R8"; - aarch64_reg 64 "R9"; - aarch64_reg 64 "R10"; - aarch64_reg 64 "R11"; - aarch64_reg 64 "R12"; - aarch64_reg 64 "R13"; - aarch64_reg 64 "R14"; - aarch64_reg 64 "R15"; - aarch64_reg 64 "R16"; - aarch64_reg 64 "R17"; - aarch64_reg 64 "R18"; - aarch64_reg 64 "R19"; - aarch64_reg 64 "R20"; - aarch64_reg 64 "R21"; - aarch64_reg 64 "R22"; - aarch64_reg 64 "R23"; - aarch64_reg 64 "R24"; - aarch64_reg 64 "R25"; - aarch64_reg 64 "R26"; - aarch64_reg 64 "R27"; - aarch64_reg 64 "R28"; - aarch64_reg 64 "R29"; - aarch64_reg 64 "R30"; -] - -let aarch64_SIMD_registers_data = [ - aarch64_reg 128 "V0"; - aarch64_reg 128 "V1"; - aarch64_reg 128 "V2"; - aarch64_reg 128 "V3"; - aarch64_reg 128 "V4"; - aarch64_reg 128 "V5"; - aarch64_reg 128 "V6"; - aarch64_reg 128 "V7"; - aarch64_reg 128 "V8"; - aarch64_reg 128 "V9"; - aarch64_reg 128 "V10"; - aarch64_reg 128 "V11"; - aarch64_reg 128 "V12"; - aarch64_reg 128 "V13"; - aarch64_reg 128 "V14"; - aarch64_reg 128 "V15"; - aarch64_reg 128 "V16"; - aarch64_reg 128 "V17"; - aarch64_reg 128 "V18"; - aarch64_reg 128 "V19"; - aarch64_reg 128 "V20"; - aarch64_reg 128 "V21"; - aarch64_reg 128 "V22"; - aarch64_reg 128 "V23"; - aarch64_reg 128 "V24"; - aarch64_reg 128 "V25"; - aarch64_reg 128 "V26"; - aarch64_reg 128 "V27"; - aarch64_reg 128 "V28"; - aarch64_reg 128 "V29"; - aarch64_reg 128 "V30"; - aarch64_reg 128 "V31"; -] - -let aarch64_special_purpose_registers_data = [ - aarch64_reg 32 "CurrentEL"; - aarch64_reg 32 "DAIF"; - aarch64_reg 32 "NZCV"; - aarch64_reg 64 "SP_EL0"; - aarch64_reg 64 "SP_EL1"; - aarch64_reg 64 "SP_EL2"; - aarch64_reg 64 "SP_EL3"; - aarch64_reg 32 "SPSel"; - aarch64_reg 32 "SPSR_EL1"; - aarch64_reg 32 "SPSR_EL2"; - aarch64_reg 32 "SPSR_EL3"; - aarch64_reg 64 "ELR_EL1"; - aarch64_reg 64 "ELR_EL2"; - aarch64_reg 64 "ELR_EL3"; -] - -let aarch64_general_system_control_registers_data = [ - aarch64_reg 64 "HCR_EL2"; - aarch64_reg 64 "ID_AA64MMFR0_EL1"; - aarch64_reg 64 "RVBAR_EL1"; - aarch64_reg 64 "RVBAR_EL2"; - aarch64_reg 64 "RVBAR_EL3"; - aarch64_reg 32 "SCR_EL3"; - aarch64_reg 32 "SCTLR_EL1"; - aarch64_reg 32 "SCTLR_EL2"; - aarch64_reg 32 "SCTLR_EL3"; - aarch64_reg 64 "TCR_EL1"; - aarch64_reg 32 "TCR_EL2"; - aarch64_reg 32 "TCR_EL3"; -] - -let aarch64_debug_registers_data = [ - aarch64_reg 32 "DBGPRCR_EL1"; - aarch64_reg 32 "OSDLR_EL1"; -] - -let aarch64_performance_monitors_registers_data = [] -let aarch64_generic_timer_registers_data = [] -let aarch64_generic_interrupt_controller_CPU_interface_registers_data = [] - -let aarch64_external_debug_registers_data = [ - aarch64_reg 32 "EDSCR"; -] - -let aarch32_general_system_control_registers_data = [ - aarch64_reg 32 "SCR"; -] - -let aarch32_debug_registers_data = [ - aarch64_reg 32 "DBGOSDLR"; - aarch64_reg 32 "DBGPRCR"; -] - -let aarch64_register_data_all = - aarch64_PC_data @ - aarch64_PSTATE_data @ - aarch64_general_purpose_registers_data @ - aarch64_SIMD_registers_data @ - aarch64_special_purpose_registers_data @ - aarch64_general_system_control_registers_data @ - aarch64_debug_registers_data @ - aarch64_performance_monitors_registers_data @ - aarch64_generic_timer_registers_data @ - aarch64_generic_interrupt_controller_CPU_interface_registers_data @ - aarch64_external_debug_registers_data @ - aarch32_general_system_control_registers_data @ - aarch32_debug_registers_data - -let initial_stack_and_reg_data_of_AAarch64_elf_file e_entry all_data_memory = - let (reg_SP_EL0_direction, reg_SP_EL0_width, reg_SP_EL0_initial_index) = - List.assoc "SP_EL0" aarch64_register_data_all in - - (* we compiled a small program that prints out SP and run it a few - times on the Nexus9, these are the results: - 0x0000007fe7f903e0 - 0x0000007fdcdbf3f0 - 0x0000007fcbe1ba90 - 0x0000007fcf378280 - 0x0000007fdd54b8d0 - 0x0000007fd961bc10 - 0x0000007ff3be6350 - 0x0000007fd6bf6ef0 - 0x0000007fff7676f0 - 0x0000007ff2c34560 *) - let initial_SP_EL0 = Nat_big_num.of_string "549739036672" (*"0x0000007fff000000"*) in - let initial_SP_EL0_value = - Sail_impl_base.register_value_of_integer - reg_SP_EL0_width - reg_SP_EL0_initial_index - reg_SP_EL0_direction - initial_SP_EL0 - in - - (* ELF says we need an initial zero doubleword there *) - (* the code actually uses the stack, both above and below, so we map a bit more memory*) - let initial_stack_data = - (* this is a fairly big but arbitrary chunk: *) - (* let initial_stack_data_address = Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128) in - [("initial_stack_data", initial_stack_data_address, Lem_list.replicate (128+32) 0 ))] in *) - - [ ("initial_stack_data1", Nat_big_num.sub initial_SP_EL0 (Nat_big_num.of_int 16), Lem_list.replicate 8 0); - ("initial_stack_data2", Nat_big_num.sub initial_SP_EL0 (Nat_big_num.of_int 8), Lem_list.replicate 8 0) - ] - in - - let initial_register_abi_data : (string * Sail_impl_base.register_value) list = - [("SP_EL0", initial_SP_EL0_value)] - in - - (initial_stack_data, initial_register_abi_data) -*) let mips_register_data_all = [ (*Pseudo registers*) @@ -749,50 +386,6 @@ let initial_system_state_of_elf_file name = let (isa_defs, isa_memory_access, isa_externs, isa_model, model_reg_d, startaddr, initial_stack_data, initial_register_abi_data, register_data_all) = match Nat_big_num.to_int e_machine with -(* | 21 (* EM_PPC64 *) -> - let startaddr = - let e_entry = Uint64.of_int64 (Nat_big_num.to_int64 e_entry) in - match Abi_power64.abi_power64_compute_program_entry_point segments e_entry with - | Error.Fail s -> failwith "Failed computing entry point" - | Error.Success s -> Nat_big_num.of_int64 (Uint64.to_int64 s) - in - let (initial_stack_data, initial_register_abi_data) = - initial_stack_and_reg_data_of_PPC_elf_file e_entry !data_mem in - - (Power.defs, - (Power_extras.read_memory_functions,Power_extras.memory_writes,[],[],Power_extras.barrier_functions), - Power_extras.power_externs, - PPC, - D_increasing, - startaddr, - initial_stack_data, - initial_register_abi_data, - ppc_register_data_all) - - | 183 (* EM_AARCH64 *) -> - let startaddr = - let e_entry = Uint64.of_int64 (Nat_big_num.to_int64 e_entry) in - match Abi_aarch64_le.abi_aarch64_le_compute_program_entry_point segments e_entry with - | Error.Fail s -> failwith "Failed computing entry point" - | Error.Success s -> Nat_big_num.of_int64 (Uint64.to_int64 s) - in - - let (initial_stack_data, initial_register_abi_data) = - initial_stack_and_reg_data_of_AAarch64_elf_file e_entry !data_mem in - - (ArmV8.defs, - (ArmV8_extras.aArch64_read_memory_functions, - ArmV8_extras.aArch64_memory_writes, - ArmV8_extras.aArch64_memory_eas, - ArmV8_extras.aArch64_memory_vals, - ArmV8_extras.aArch64_barrier_functions), - [], - AArch64, - D_decreasing, - startaddr, - initial_stack_data, - initial_register_abi_data, - aarch64_register_data_all) *) | 8 (* EM_MIPS *) -> let startaddr = let e_entry = Uint64.of_string (Nat_big_num.to_string e_entry) in @@ -888,52 +481,6 @@ let initial_system_state_of_elf_file name = List.map (fun (name, (binding, fp)) -> (fp, name)) (StringMap.bindings map) in - - (* Now we examine the rest of the data memory, - removing the footprint of the symbols and chunking it into aligned chunks *) - - let rec remove_symbols_from_data_memory data_mem symbols = - match symbols with - | [] -> data_mem - | (name,address,size,bs)::symbols' -> - let data_mem' = - Mem.filter - (fun a v -> - not (Nat_big_num.greater_equal a address && - Nat_big_num.less a (Nat_big_num.add (Nat_big_num.of_int (List.length bs)) address))) - data_mem in - remove_symbols_from_data_memory data_mem' symbols' in - - let trimmed_data_memory : (Nat_big_num.num * memory_byte) list = - Mem.bindings (remove_symbols_from_data_memory !data_mem symbol_table) in - - (* make sure that's ordered increasingly.... *) - let trimmed_data_memory = - List.sort (fun (a,b) (a',b') -> Nat_big_num.compare a a') trimmed_data_memory in - - let aligned a n = (* a mod n = 0 *) - let n_big = Nat_big_num.of_int n in - Nat_big_num.equal (Nat_big_num.modulus a n_big) ((Nat_big_num.of_int 0)) in - - let isplus a' a n = (* a' = a+n *) - Nat_big_num.equal a' (Nat_big_num.add (Nat_big_num.of_int n) a) in - - let rec chunk_data_memory dm = - match dm with - | (a0,b0)::(a1,b1)::(a2,b2)::(a3,b3)::(a4,b4)::(a5,b5)::(a6,b6)::(a7,b7)::dm' when - (aligned a0 8 && isplus a1 a0 1 && isplus a2 a0 2 && isplus a3 a0 3 && - isplus a4 a0 4 && isplus a5 a0 5 && isplus a6 a0 6 && isplus a7 a0 7) -> - (a0,8,[b0;b1;b2;b3;b4;b5;b6;b7]) :: chunk_data_memory dm' - | (a0,b0)::(a1,b1)::(a2,b2)::(a3,b3)::dm' when - (aligned a0 4 && isplus a1 a0 1 && isplus a2 a0 2 && isplus a3 a0 3) -> - (a0,4,[b0;b1;b2;b3]) :: chunk_data_memory dm' - | (a0,b0)::(a1,b1)::dm' when - (aligned a0 2 && isplus a1 a0 1) -> - (a0,2,[b0;b1]) :: chunk_data_memory dm' - | (a0,b0)::dm' -> - (a0,1,[b0]):: chunk_data_memory dm' - | [] -> [] in - let initial_register_state = fun rbn -> try @@ -1022,69 +569,10 @@ let stop_condition_met model instr = true | _ -> false) -let is_branch model instruction = - let (name,_,_) = instruction in - match (model , name) with - | (PPC, "B") -> true - | (PPC, "Bc") -> true - | (PPC, "Bclr") -> true - | (PPC, "Bcctr") -> true - | (PPC, _) -> false - | (AArch64, "BranchImmediate") -> true - | (AArch64, "BranchConditional") -> true - | (AArch64, "CompareAndBranch") -> true - | (AArch64, "TestBitAndBranch") -> true - | (AArch64, "BranchRegister") -> true - | (AArch64, _) -> false - | (MIPS, _) -> false (*todo,fill this in*) - let option_int_of_option_integer i = match i with | Some i -> Some (Nat_big_num.to_int i) | None -> None -let set_next_instruction_address model = - match model with - | PPC -> - let cia = Reg.find "CIA" !reg in - let cia_addr = address_of_register_value cia in - (match cia_addr with - | Some cia_addr -> - let nia_addr = add_address_nat cia_addr 4 in - let nia = register_value_of_address nia_addr Sail_impl_base.D_increasing in - reg := Reg.add "NIA" nia !reg - | _ -> failwith "CIA address contains unknown or undefined") - | AArch64 -> - let pc = Reg.find "_PC" !reg in - let pc_addr = address_of_register_value pc in - (match pc_addr with - | Some pc_addr -> - let n_addr = add_address_nat pc_addr 4 in - let n_pc = register_value_of_address n_addr D_decreasing in - reg := Reg.add "_PC" n_pc !reg - | _ -> failwith "_PC address contains unknown or undefined") - | MIPS -> - let pc_addr = address_of_register_value (Reg.find "PC" !reg) in - let branchPending = integer_of_register_value (Reg.find "branchPending" !reg) in - (match (pc_addr, option_int_of_option_integer branchPending) with - | (Some pc_val, Some 0) -> - (* normal -- increment PC *) - let n_addr = add_address_nat pc_val 4 in - let n_pc = register_value_of_address n_addr D_decreasing in - begin - reg := Reg.add "nextPC" n_pc !reg; - reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - end - | (Some pc_val, Some 1) -> - (* delay slot -- branch to delayed PC and clear branchPending *) - begin - reg := Reg.add "nextPC" (Reg.find "delayedPC" !reg) !reg; - reg := Reg.add "nextPCC" (Reg.find "delayedPCC" !reg) !reg; - reg := Reg.add "branchPending" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing (Nat_big_num.of_int 1)) !reg; - end - | (_, _) -> errorf "PC address contains unknown or undefined"; exit 1) - let add1 = Nat_big_num.add (Nat_big_num.of_int 1) let get_addr_trans_regs _ = @@ -1194,68 +682,10 @@ let rec write_events = function | _ -> failwith "Only register write events expected"); write_events events -let fetch_instruction_opcode_and_update_ia model addr_trans = - match model with - | PPC -> - let cia = Reg.find "CIA" !reg in - let cia_addr = address_of_register_value cia in - (match cia_addr with - | Some cia_addr -> - let cia_a = integer_of_address cia_addr in - let opcode = (get_opcode cia_a) in - begin - reg := Reg.add "CIA" (Reg.find "NIA" !reg) !reg; - Opcode opcode - end - | None -> failwith "CIA address contains unknown or undefined") - | AArch64 -> - let pc = Reg.find "_PC" !reg in - let pc_addr = address_of_register_value pc in - (match pc_addr with - | Some pc_addr -> - let pc_a = integer_of_address pc_addr in - let opcode = (get_opcode pc_a) in - Opcode opcode - | None -> failwith "_PC address contains unknown or undefined") - | MIPS -> - begin - reg := Reg.add "PCC" (Reg.find "nextPCC" !reg) !reg; - let nextPC = Reg.find "nextPC" !reg in - let pc_addr = address_of_register_value nextPC in - (*let unused = interactf "PC: %s\n" (Printing_functions.register_value_to_string nextPC) in*) - (match pc_addr with - | Some pc_addr -> - let pc_a = match addr_trans (get_addr_trans_regs ()) pc_addr with - | Some a, Some events -> write_events (List.rev events); integer_of_address a - | Some a, None -> integer_of_address a - | None, Some events -> - write_events (List.rev events); - let nextPC = Reg.find "nextPC" !reg in - reg := Reg.add "PCC" (Reg.find "nextPCC" !reg) !reg; - let pc_addr = address_of_register_value nextPC in - (match pc_addr with - | Some pc_addr -> - (match addr_trans (get_addr_trans_regs ()) pc_addr with - | Some a, Some events -> write_events (List.rev events); integer_of_address a - | Some a, None -> integer_of_address a - | None, _ -> failwith "Address translation failed twice") - | None -> failwith "no nextPc address") - | _ -> failwith "No address and no events from translate address" - in - let opcode = (get_opcode pc_a) in - begin - reg := Reg.add "PC" (Reg.find "nextPC" !reg) !reg; - Opcode opcode - end - | None -> errorf "nextPC contains unknown or undefined"; exit 1) - end - | _ -> assert false - let get_pc_address = function | MIPS -> Reg.find "PC" !reg | PPC -> Reg.find "CIA" !reg | AArch64 -> Reg.find "_PC" !reg - let option_int_of_reg str = option_int_of_option_integer (integer_of_register_value (Reg.find str !reg)) -- cgit v1.2.3 From 6b86efcb6e1042d4933b67eaf3a7b3eff1fac256 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Tue, 7 Nov 2017 11:45:06 +0000 Subject: RISC-V parser checks --- risc-v/hgen/lexer.hgen | 4 ++++ risc-v/hgen/parser.hgen | 57 ++++++++++++++++++++++++++++++-------------- risc-v/hgen/token_types.hgen | 4 ++++ risc-v/hgen/tokens.hgen | 3 ++- 4 files changed, 49 insertions(+), 19 deletions(-) diff --git a/risc-v/hgen/lexer.hgen b/risc-v/hgen/lexer.hgen index 27df99f4..e42b8a62 100644 --- a/risc-v/hgen/lexer.hgen +++ b/risc-v/hgen/lexer.hgen @@ -184,3 +184,7 @@ "amomin.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMIN}; "amomaxu.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMAXU}; "amominu.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMINU}; + +(** pseudo instructions *********************************************) + +"li", LI () diff --git a/risc-v/hgen/parser.hgen b/risc-v/hgen/parser.hgen index cf0ca80b..210e38fb 100644 --- a/risc-v/hgen/parser.hgen +++ b/risc-v/hgen/parser.hgen @@ -1,25 +1,41 @@ | UTYPE reg COMMA NUM - { `RISCVUTYPE($4, $2, $1.op) } + { (* it's not clear if NUM here should be before or after filling the + lowest 12 bits with zeros, or if it should be signed or unsigned; + currently assuming: NUM does not include the 12 zeros, and is unsigned *) + if not (iskbituimm 20 $4) then failwith "immediate is not 20bit" + else `RISCVUTYPE ($4, $2, $1.op) } | JAL reg COMMA NUM - { `RISCVJAL($4, $2) } + { if not ($4 mod 2 = 0) then failwith "odd offset" + else if not (iskbitsimm 21 $4) then failwith "offset is not 21bit" + else `RISCVJAL ($4, $2) } | JALR reg COMMA reg COMMA NUM - { `RISCVJALR($6, $4, $2) } + { if not (iskbitsimm 12 $6) then failwith "offset is not 12bit" + else `RISCVJALR ($6, $4, $2) } | BTYPE reg COMMA reg COMMA NUM - { `RISCVBType($6, $4, $2, $1.op) } + { if not ($6 mod 2 = 0) then failwith "odd offset" + else if not (iskbitsimm 13 $6) then failwith "offset is not 13bit" + else `RISCVBType ($6, $4, $2, $1.op) } | ITYPE reg COMMA reg COMMA NUM - { `RISCVIType($6, $4, $2, $1.op) } + { if $1.op <> RISCVSLTIU && not (iskbitsimm 12 $6) then failwith "immediate is not 12bit" + else if $1.op = RISCVSLTIU && not (iskbituimm 12 $6) then failwith "unsigned immediate is not 12bit" + else `RISCVIType ($6, $4, $2, $1.op) } +| ADDIW reg COMMA reg COMMA NUM + { if not (iskbitsimm 12 $6) then failwith "immediate is not 12bit" + else `RISCVADDIW ($6, $4, $2) } | SHIFTIOP reg COMMA reg COMMA NUM - { `RISCVShiftIop($6, $4, $2, $1.op) } + { if not (iskbituimm 6 $6) then failwith "unsigned immediate is not 6bit" + else `RISCVShiftIop ($6, $4, $2, $1.op) } +| SHIFTW reg COMMA reg COMMA NUM + { if not (iskbituimm 5 $6) then failwith "unsigned immediate is not 5bit" + else `RISCVSHIFTW ($6, $4, $2, $1.op) } | RTYPE reg COMMA reg COMMA reg { `RISCVRType ($6, $4, $2, $1.op) } | LOAD reg COMMA NUM LPAR reg RPAR - { `RISCVLoad($4, $6, $2, $1.unsigned, $1.width, $1.aq, $1.rl) } + { if not (iskbitsimm 12 $4) then failwith "offset is not 12bit" + else `RISCVLoad ($4, $6, $2, $1.unsigned, $1.width, $1.aq, $1.rl) } | STORE reg COMMA NUM LPAR reg RPAR - { `RISCVStore($4, $2, $6, $1.width, $1.aq, $1.rl) } -| ADDIW reg COMMA reg COMMA NUM - { `RISCVADDIW ($6, $4, $2) } -| SHIFTW reg COMMA reg COMMA NUM - { `RISCVSHIFTW ($6, $4, $2, $1.op) } + { if not (iskbitsimm 12 $4) then failwith "offset is not 12bit" + else `RISCVStore ($4, $2, $6, $1.width, $1.aq, $1.rl) } | RTYPEW reg COMMA reg COMMA reg { `RISCVRTYPEW ($6, $4, $2, $1.op) } | FENCE FENCEOPTION COMMA FENCEOPTION @@ -37,17 +53,22 @@ | FENCEI { `RISCVFENCEI } | LOADRES reg COMMA LPAR reg RPAR - { `RISCVLoadRes($1.aq, $1.rl, $5, $1.width, $2) } + { `RISCVLoadRes ($1.aq, $1.rl, $5, $1.width, $2) } | LOADRES reg COMMA NUM LPAR reg RPAR { if $4 <> 0 then failwith "'lr' offset must be 0" else - `RISCVLoadRes($1.aq, $1.rl, $6, $1.width, $2) } + `RISCVLoadRes ($1.aq, $1.rl, $6, $1.width, $2) } | STORECON reg COMMA reg COMMA LPAR reg RPAR - { `RISCVStoreCon($1.aq, $1.rl, $4, $7, $1.width, $2) } + { `RISCVStoreCon ($1.aq, $1.rl, $4, $7, $1.width, $2) } | STORECON reg COMMA reg COMMA NUM LPAR reg RPAR { if $6 <> 0 then failwith "'sc' offset must be 0" else - `RISCVStoreCon($1.aq, $1.rl, $4, $8, $1.width, $2) } + `RISCVStoreCon ($1.aq, $1.rl, $4, $8, $1.width, $2) } | AMO reg COMMA reg COMMA LPAR reg RPAR - { `RISCVAMO($1.op, $1.aq, $1.rl, $4, $7, $1.width, $2) } + { `RISCVAMO ($1.op, $1.aq, $1.rl, $4, $7, $1.width, $2) } | AMO reg COMMA reg COMMA NUM LPAR reg RPAR { if $6 <> 0 then failwith "'amo' offset must be 0" else - `RISCVAMO($1.op, $1.aq, $1.rl, $4, $8, $1.width, $2) } + `RISCVAMO ($1.op, $1.aq, $1.rl, $4, $8, $1.width, $2) } + +/* pseudo-ops */ +| LI reg COMMA NUM + { if not (iskbitsimm 12 $4) then failwith "immediate is not 12bit (li is currently implemented only with small immediate)" + else `RISCVIType ($4, IReg R0, $2, RISCVORI) } diff --git a/risc-v/hgen/token_types.hgen b/risc-v/hgen/token_types.hgen index d338d865..f29e318d 100644 --- a/risc-v/hgen/token_types.hgen +++ b/risc-v/hgen/token_types.hgen @@ -17,3 +17,7 @@ type token_StoreCon = {width : wordWidth; aq: bool; rl: bool } type token_AMO = {width : wordWidth; aq: bool; rl: bool; op: riscvAmoop } type token_FENCEOPTION = Fence_R | Fence_W | Fence_RW + +(* pseudo-ops *) + +type token_LI = unit diff --git a/risc-v/hgen/tokens.hgen b/risc-v/hgen/tokens.hgen index b0cf1d88..f812adbd 100644 --- a/risc-v/hgen/tokens.hgen +++ b/risc-v/hgen/tokens.hgen @@ -15,4 +15,5 @@ %token FENCEI %token LOADRES %token STORECON -%token AMO +%token AMO +%token LI -- cgit v1.2.3 From 9ab1c6514c38968bcbdf5847ecb811072f731982 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 23 Nov 2017 13:32:42 +0000 Subject: added RISCV_ prefix to some values to stop Lem from renaming them --- risc-v/hgen/herdtools_types_to_shallow_types.hgen | 64 +++++----- risc-v/hgen/shallow_types_to_herdtools_types.hgen | 64 +++++----- risc-v/riscv.sail | 140 +++++++++++----------- risc-v/riscv_types.sail | 12 +- 4 files changed, 140 insertions(+), 140 deletions(-) diff --git a/risc-v/hgen/herdtools_types_to_shallow_types.hgen b/risc-v/hgen/herdtools_types_to_shallow_types.hgen index a63f9aed..e6edd24d 100644 --- a/risc-v/hgen/herdtools_types_to_shallow_types.hgen +++ b/risc-v/hgen/herdtools_types_to_shallow_types.hgen @@ -4,48 +4,48 @@ let translate_reg name value = Sail_values.to_vec0 is_inc (Nat_big_num.of_int 5,Nat_big_num.of_int (reg_to_int value)) let translate_uop op = match op with - | RISCVLUI -> LUI0 - | RISCVAUIPC -> AUIPC + | RISCVLUI -> RISCV_LUI + | RISCVAUIPC -> RISCV_AUIPC let translate_bop op = match op with - | RISCVBEQ -> BEQ0 - | RISCVBNE -> BNE - | RISCVBLT -> BLT - | RISCVBGE -> BGE - | RISCVBLTU -> BLTU - | RISCVBGEU -> BGEU + | RISCVBEQ -> RISCV_BEQ + | RISCVBNE -> RISCV_BNE + | RISCVBLT -> RISCV_BLT + | RISCVBGE -> RISCV_BGE + | RISCVBLTU -> RISCV_BLTU + | RISCVBGEU -> RISCV_BGEU let translate_iop op = match op with - | RISCVADDI -> ADDI0 - | RISCVSLTI -> SLTI0 - | RISCVSLTIU -> SLTIU0 - | RISCVXORI -> XORI0 - | RISCVORI -> ORI0 - | RISCVANDI -> ANDI0 + | RISCVADDI -> RISCV_ADDI + | RISCVSLTI -> RISCV_SLTI + | RISCVSLTIU -> RISCV_SLTIU + | RISCVXORI -> RISCV_XORI + | RISCVORI -> RISCV_ORI + | RISCVANDI -> RISCV_ANDI let translate_sop op = match op with - | RISCVSLLI -> SLLI - | RISCVSRLI -> SRLI - | RISCVSRAI -> SRAI + | RISCVSLLI -> RISCV_SLLI + | RISCVSRLI -> RISCV_SRLI + | RISCVSRAI -> RISCV_SRAI let translate_rop op = match op with - | RISCVADD -> ADD0 - | RISCVSUB -> SUB0 - | RISCVSLL -> SLL0 - | RISCVSLT -> SLT0 - | RISCVSLTU -> SLTU0 - | RISCVXOR -> XOR0 - | RISCVSRL -> SRL0 - | RISCVSRA -> SRA0 - | RISCVOR -> OR0 - | RISCVAND -> AND0 + | RISCVADD -> RISCV_ADD + | RISCVSUB -> RISCV_SUB + | RISCVSLL -> RISCV_SLL + | RISCVSLT -> RISCV_SLT + | RISCVSLTU -> RISCV_SLTU + | RISCVXOR -> RISCV_XOR + | RISCVSRL -> RISCV_SRL + | RISCVSRA -> RISCV_SRA + | RISCVOR -> RISCV_OR + | RISCVAND -> RISCV_AND let translate_ropw op = match op with - | RISCVADDW -> ADDW - | RISCVSUBW -> SUBW - | RISCVSLLW -> SLLW - | RISCVSRLW -> SRLW - | RISCVSRAW -> SRAW + | RISCVADDW -> RISCV_ADDW + | RISCVSUBW -> RISCV_SUBW + | RISCVSLLW -> RISCV_SLLW + | RISCVSRLW -> RISCV_SRLW + | RISCVSRAW -> RISCV_SRAW let translate_amoop op = match op with | RISCVAMOSWAP -> AMOSWAP diff --git a/risc-v/hgen/shallow_types_to_herdtools_types.hgen b/risc-v/hgen/shallow_types_to_herdtools_types.hgen index 03b8820c..6b3b7f51 100644 --- a/risc-v/hgen/shallow_types_to_herdtools_types.hgen +++ b/risc-v/hgen/shallow_types_to_herdtools_types.hgen @@ -10,48 +10,48 @@ let translate_out_signed_int inst bits = let translate_out_ireg ireg = IReg (int_to_ireg (translate_out_int ireg)) let translate_out_uop op = match op with - | LUI0 -> RISCVLUI - | AUIPC -> RISCVAUIPC + | RISCV_LUI -> RISCVLUI + | RISCV_AUIPC -> RISCVAUIPC let translate_out_bop op = match op with - | BEQ0 -> RISCVBEQ - | BNE -> RISCVBNE - | BLT -> RISCVBLT - | BGE -> RISCVBGE - | BLTU -> RISCVBLTU - | BGEU -> RISCVBGEU + | RISCV_BEQ -> RISCVBEQ + | RISCV_BNE -> RISCVBNE + | RISCV_BLT -> RISCVBLT + | RISCV_BGE -> RISCVBGE + | RISCV_BLTU -> RISCVBLTU + | RISCV_BGEU -> RISCVBGEU let translate_out_iop op = match op with - | ADDI0 -> RISCVADDI - | SLTI0 -> RISCVSLTI - | SLTIU0 -> RISCVSLTIU - | XORI0 -> RISCVXORI - | ORI0 -> RISCVORI - | ANDI0 -> RISCVANDI + | RISCV_ADDI -> RISCVADDI + | RISCV_SLTI -> RISCVSLTI + | RISCV_SLTIU -> RISCVSLTIU + | RISCV_XORI -> RISCVXORI + | RISCV_ORI -> RISCVORI + | RISCV_ANDI -> RISCVANDI let translate_out_sop op = match op with - | SLLI -> RISCVSLLI - | SRLI -> RISCVSRLI - | SRAI -> RISCVSRAI + | RISCV_SLLI -> RISCVSLLI + | RISCV_SRLI -> RISCVSRLI + | RISCV_SRAI -> RISCVSRAI let translate_out_rop op = match op with - | ADD0 -> RISCVADD - | SUB0 -> RISCVSUB - | SLL0 -> RISCVSLL - | SLT0 -> RISCVSLT - | SLTU0 -> RISCVSLTU - | XOR0 -> RISCVXOR - | SRL0 -> RISCVSRL - | SRA0 -> RISCVSRA - | OR0 -> RISCVOR - | AND0 -> RISCVAND + | RISCV_ADD -> RISCVADD + | RISCV_SUB -> RISCVSUB + | RISCV_SLL -> RISCVSLL + | RISCV_SLT -> RISCVSLT + | RISCV_SLTU -> RISCVSLTU + | RISCV_XOR -> RISCVXOR + | RISCV_SRL -> RISCVSRL + | RISCV_SRA -> RISCVSRA + | RISCV_OR -> RISCVOR + | RISCV_AND -> RISCVAND let translate_out_ropw op = match op with - | ADDW -> RISCVADDW - | SUBW -> RISCVSUBW - | SLLW -> RISCVSLLW - | SRLW -> RISCVSRLW - | SRAW -> RISCVSRAW + | RISCV_ADDW -> RISCVADDW + | RISCV_SUBW -> RISCVSUBW + | RISCV_SLLW -> RISCVSLLW + | RISCV_SRLW -> RISCVSRLW + | RISCV_SRAW -> RISCVSRAW let translate_out_amoop op = match op with | AMOSWAP -> RISCVAMOSWAP diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index e0a6efba..3a54e0c8 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -8,14 +8,14 @@ scattered function unit execute (********************************************************************) union ast member ((bit[20]), regno, uop) UTYPE -function clause decode ((bit[20]) imm : (regno) rd : 0b0110111) = Some(UTYPE(imm, rd, LUI)) -function clause decode ((bit[20]) imm : (regno) rd : 0b0010111) = Some(UTYPE(imm, rd, AUIPC)) +function clause decode ((bit[20]) imm : (regno) rd : 0b0110111) = Some(UTYPE(imm, rd, RISCV_LUI)) +function clause decode ((bit[20]) imm : (regno) rd : 0b0010111) = Some(UTYPE(imm, rd, RISCV_AUIPC)) function clause execute (UTYPE(imm, rd, op)) = let (bit[64]) off = EXTS(imm : 0x000) in let ret = switch (op) { - case LUI -> off - case AUIPC -> PC + off + case RISCV_LUI -> off + case RISCV_AUIPC -> PC + off } in wGPR(rd, ret) @@ -48,28 +48,28 @@ function clause execute (JALR(imm, rs1, rd)) = { union ast member ((bit[13]), regno, regno, bop) BTYPE function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b000 : (bit[5]) imm5 : 0b1100011) = - Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BEQ)) + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, RISCV_BEQ)) function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b001 : (bit[5]) imm5 : 0b1100011) = - Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BNE)) + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, RISCV_BNE)) function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b100 : (bit[5]) imm5 : 0b1100011) = - Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BLT)) + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, RISCV_BLT)) function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b101 : (bit[5]) imm5 : 0b1100011) = - Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BGE)) + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, RISCV_BGE)) function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b110 : (bit[5]) imm5 : 0b1100011) = - Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BLTU)) + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, RISCV_BLTU)) function clause decode ((bit[7]) imm7 : (regno) rs2 : (regno) rs1 : 0b111 : (bit[5]) imm5 : 0b1100011) = - Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, BGEU)) + Some(BTYPE(imm7[6] : imm5[0] : imm7[5..0] : imm5[4..1] : 0b0, rs2, rs1, RISCV_BGEU)) function clause execute (BTYPE(imm, rs2, rs1, op)) = let rs1_val = rGPR(rs1) in let rs2_val = rGPR(rs2) in let taken = switch(op) { - case BEQ -> rs1_val == rs2_val - case BNE -> rs1_val != rs2_val - case BLT -> rs1_val <_s rs2_val - case BGE -> rs1_val >=_s rs2_val - case BLTU -> rs1_val <_u rs2_val - case BGEU -> unsigned(rs1_val) >= unsigned(rs2_val) (* XXX sail missing >=_u *) + case RISCV_BEQ -> rs1_val == rs2_val + case RISCV_BNE -> rs1_val != rs2_val + case RISCV_BLT -> rs1_val <_s rs2_val + case RISCV_BGE -> rs1_val >=_s rs2_val + case RISCV_BLTU -> rs1_val <_u rs2_val + case RISCV_BGEU -> unsigned(rs1_val) >= unsigned(rs2_val) (* XXX sail missing >=_u *) } in if (taken) then nextPC := PC + EXTS(imm) @@ -77,70 +77,70 @@ function clause execute (BTYPE(imm, rs2, rs1, op)) = (********************************************************************) union ast member ((bit[12]), regno, regno, iop) ITYPE -function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, ADDI)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b010 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, SLTI)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b011 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, SLTIU)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b100 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, XORI)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b110 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, ORI)) -function clause decode ((bit[12]) imm : (regno) rs1 : 0b111 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, ANDI)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, RISCV_ADDI)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b010 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, RISCV_SLTI)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b011 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, RISCV_SLTIU)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b100 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, RISCV_XORI)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b110 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, RISCV_ORI)) +function clause decode ((bit[12]) imm : (regno) rs1 : 0b111 : (regno) rd : 0b0010011) = Some(ITYPE(imm, rs1, rd, RISCV_ANDI)) function clause execute (ITYPE (imm, rs1, rd, op)) = let rs1_val = rGPR(rs1) in let imm64 = (bit[64]) (EXTS(imm)) in let (bit[64]) result = switch(op) { - case ADDI -> rs1_val + imm64 - case SLTI -> EXTZ(rs1_val <_s imm64) - case SLTIU -> EXTZ(rs1_val <_u imm64) - case XORI -> rs1_val ^ imm64 - case ORI -> rs1_val | imm64 - case ANDI -> rs1_val & imm64 + case RISCV_ADDI -> rs1_val + imm64 + case RISCV_SLTI -> EXTZ(rs1_val <_s imm64) + case RISCV_SLTIU -> EXTZ(rs1_val <_u imm64) + case RISCV_XORI -> rs1_val ^ imm64 + case RISCV_ORI -> rs1_val | imm64 + case RISCV_ANDI -> rs1_val & imm64 } in wGPR(rd, result) (********************************************************************) union ast member ((bit[6]), regno, regno, sop) SHIFTIOP -function clause decode (0b000000 : (bit[6]) shamt : (regno) rs1 : 0b001 : (regno) rd : 0b0010011) = Some(SHIFTIOP(shamt, rs1, rd, SLLI)) -function clause decode (0b000000 : (bit[6]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0010011) = Some(SHIFTIOP(shamt, rs1, rd, SRLI)) -function clause decode (0b010000 : (bit[6]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0010011) = Some(SHIFTIOP(shamt, rs1, rd, SRAI)) +function clause decode (0b000000 : (bit[6]) shamt : (regno) rs1 : 0b001 : (regno) rd : 0b0010011) = Some(SHIFTIOP(shamt, rs1, rd, RISCV_SLLI)) +function clause decode (0b000000 : (bit[6]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0010011) = Some(SHIFTIOP(shamt, rs1, rd, RISCV_SRLI)) +function clause decode (0b010000 : (bit[6]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0010011) = Some(SHIFTIOP(shamt, rs1, rd, RISCV_SRAI)) function clause execute (SHIFTIOP(shamt, rs1, rd, op)) = let rs1_val = rGPR(rs1) in let result = switch(op) { - case SLLI -> rs1_val >> shamt - case SRLI -> rs1_val << shamt - case SRAI -> shift_right_arith64(rs1_val, shamt) + case RISCV_SLLI -> rs1_val >> shamt + case RISCV_SRLI -> rs1_val << shamt + case RISCV_SRAI -> shift_right_arith64(rs1_val, shamt) } in wGPR(rd, result) (********************************************************************) union ast member (regno, regno, regno, rop) RTYPE -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, ADD)) -function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, SUB)) -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b001 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, SLL)) -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, SLT)) -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, SLTU)) -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b100 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, XOR)) -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, SRL)) -function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, SRA)) -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b110 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, OR)) -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b111 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, AND)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, RISCV_ADD)) +function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, RISCV_SUB)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b001 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, RISCV_SLL)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b010 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, RISCV_SLT)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b011 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, RISCV_SLTU)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b100 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, RISCV_XOR)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, RISCV_SRL)) +function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, RISCV_SRA)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b110 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, RISCV_OR)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b111 : (regno) rd : 0b0110011) = Some(RTYPE(rs2, rs1, rd, RISCV_AND)) function clause execute (RTYPE(rs2, rs1, rd, op)) = let rs1_val = rGPR(rs1) in let rs2_val = rGPR(rs2) in let (bit[64]) result = switch(op) { - case ADD -> rs1_val + rs2_val - case SUB -> rs1_val - rs2_val - case SLL -> rs1_val << (rs2_val[5..0]) - case SLT -> EXTZ(rs1_val <_s rs2_val) - case SLTU -> EXTZ(rs1_val <_u rs2_val) - case XOR -> rs1_val ^ rs2_val - case SRL -> rs1_val >> (rs2_val[5..0]) - case SRA -> shift_right_arith64(rs1_val, rs2_val[5..0]) - case OR -> rs1_val | rs2_val - case AND -> rs1_val & rs2_val + case RISCV_ADD -> rs1_val + rs2_val + case RISCV_SUB -> rs1_val - rs2_val + case RISCV_SLL -> rs1_val << (rs2_val[5..0]) + case RISCV_SLT -> EXTZ(rs1_val <_s rs2_val) + case RISCV_SLTU -> EXTZ(rs1_val <_u rs2_val) + case RISCV_XOR -> rs1_val ^ rs2_val + case RISCV_SRL -> rs1_val >> (rs2_val[5..0]) + case RISCV_SRA -> shift_right_arith64(rs1_val, rs2_val[5..0]) + case RISCV_OR -> rs1_val | rs2_val + case RISCV_AND -> rs1_val & rs2_val } in wGPR(rd, result) @@ -217,37 +217,37 @@ function clause execute (ADDIW(imm, rs1, rd)) = (********************************************************************) union ast member ((bit[5]), regno, regno, sop) SHIFTW -function clause decode (0b0000000 : (bit[5]) shamt : (regno) rs1 : 0b001 : (regno) rd : 0b0011011) = Some(SHIFTW(shamt, rs1, rd, SLLI)) -function clause decode (0b0000000 : (bit[5]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0011011) = Some(SHIFTW(shamt, rs1, rd, SRLI)) -function clause decode (0b0100000 : (bit[5]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0011011) = Some(SHIFTW(shamt, rs1, rd, SRAI)) +function clause decode (0b0000000 : (bit[5]) shamt : (regno) rs1 : 0b001 : (regno) rd : 0b0011011) = Some(SHIFTW(shamt, rs1, rd, RISCV_SLLI)) +function clause decode (0b0000000 : (bit[5]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0011011) = Some(SHIFTW(shamt, rs1, rd, RISCV_SRLI)) +function clause decode (0b0100000 : (bit[5]) shamt : (regno) rs1 : 0b101 : (regno) rd : 0b0011011) = Some(SHIFTW(shamt, rs1, rd, RISCV_SRAI)) function clause execute (SHIFTW(shamt, rs1, rd, op)) = let rs1_val = (rGPR(rs1))[31..0] in let result = switch(op) { - case SLLI -> rs1_val >> shamt - case SRLI -> rs1_val << shamt - case SRAI -> shift_right_arith32(rs1_val, shamt) + case RISCV_SLLI -> rs1_val >> shamt + case RISCV_SRLI -> rs1_val << shamt + case RISCV_SRAI -> shift_right_arith32(rs1_val, shamt) } in wGPR(rd, EXTS(result)) (********************************************************************) union ast member (regno, regno, regno, ropw) RTYPEW -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, ADDW)) -function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, SUBW)) -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b001 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, SLLW)) -function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, SRLW)) -function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, SRAW)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, RISCV_ADDW)) +function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b000 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, RISCV_SUBW)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b001 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, RISCV_SLLW)) +function clause decode (0b0000000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, RISCV_SRLW)) +function clause decode (0b0100000 : (regno) rs2 : (regno) rs1 : 0b101 : (regno) rd : 0b0111011) = Some(RTYPEW(rs2, rs1, rd, RISCV_SRAW)) function clause execute (RTYPEW(rs2, rs1, rd, op)) = let rs1_val = (rGPR(rs1))[31..0] in let rs2_val = (rGPR(rs2))[31..0] in let (bit[32]) result = switch(op) { - case ADDW -> rs1_val + rs2_val - case SUBW -> rs1_val - rs2_val - case SLLW -> rs1_val << (rs2_val[4..0]) - case SRLW -> rs1_val >> (rs2_val[4..0]) - case SRAW -> shift_right_arith32(rs1_val, rs2_val[4..0]) + case RISCV_ADDW -> rs1_val + rs2_val + case RISCV_SUBW -> rs1_val - rs2_val + case RISCV_SLLW -> rs1_val << (rs2_val[4..0]) + case RISCV_SRLW -> rs1_val >> (rs2_val[4..0]) + case RISCV_SRAW -> shift_right_arith32(rs1_val, rs2_val[4..0]) } in wGPR(rd, EXTS(result)) diff --git a/risc-v/riscv_types.sail b/risc-v/riscv_types.sail index a7cda963..b584ae9b 100644 --- a/risc-v/riscv_types.sail +++ b/risc-v/riscv_types.sail @@ -143,12 +143,12 @@ val extern unit -> unit effect { barr } MEM_fence_rw_w val extern unit -> unit effect { barr } MEM_fence_w_w val extern unit -> unit effect { barr } MEM_fence_i -typedef uop = enumerate {LUI; AUIPC} (* upper immediate ops *) -typedef bop = enumerate {BEQ; BNE; BLT; BGE; BLTU; BGEU} (* branch ops *) -typedef iop = enumerate {ADDI; SLTI; SLTIU; XORI; ORI; ANDI} (* immediate ops *) -typedef sop = enumerate {SLLI; SRLI; SRAI} (* shift ops *) -typedef rop = enumerate {ADD; SUB; SLL; SLT; SLTU; XOR; SRL; SRA; OR; AND} (* reg-reg ops *) -typedef ropw = enumerate {ADDW; SUBW; SLLW; SRLW; SRAW} (* reg-reg 32-bit ops *) +typedef uop = enumerate {RISCV_LUI; RISCV_AUIPC} (* upper immediate ops *) +typedef bop = enumerate {RISCV_BEQ; RISCV_BNE; RISCV_BLT; RISCV_BGE; RISCV_BLTU; RISCV_BGEU} (* branch ops *) +typedef iop = enumerate {RISCV_ADDI; RISCV_SLTI; RISCV_SLTIU; RISCV_XORI; RISCV_ORI; RISCV_ANDI} (* immediate ops *) +typedef sop = enumerate {RISCV_SLLI; RISCV_SRLI; RISCV_SRAI} (* shift ops *) +typedef rop = enumerate {RISCV_ADD; RISCV_SUB; RISCV_SLL; RISCV_SLT; RISCV_SLTU; RISCV_XOR; RISCV_SRL; RISCV_SRA; RISCV_OR; RISCV_AND} (* reg-reg ops *) +typedef ropw = enumerate {RISCV_ADDW; RISCV_SUBW; RISCV_SLLW; RISCV_SRLW; RISCV_SRAW} (* reg-reg 32-bit ops *) typedef amoop = enumerate {AMOSWAP; AMOADD; AMOXOR; AMOAND; AMOOR; AMOMIN; AMOMAX; AMOMINU; AMOMAXU} (* AMO ops *) -- cgit v1.2.3 From 16c269d6f26fd69d8788c448b87f4bb479a6ef66 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 23 Nov 2017 15:50:13 +0000 Subject: renaming --- risc-v/hgen/herdtools_ast_to_shallow_ast.hgen | 4 +- risc-v/hgen/shallow_ast_to_herdtools_ast.hgen | 4 +- risc-v/riscv.sail | 12 +- risc-v/riscv_regfp.sail | 4 +- x86/x64.sail | 234 +++++++++++++------------- 5 files changed, 130 insertions(+), 128 deletions(-) diff --git a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen index e66608e6..07c1d082 100644 --- a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen +++ b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen @@ -3,10 +3,10 @@ translate_imm20 "imm" imm, translate_reg "rd" rd, translate_uop op) -| `RISCVJAL(imm, rd) -> JAL0( +| `RISCVJAL(imm, rd) -> RISCV_JAL( translate_imm21 "imm" imm, translate_reg "rd" rd) -| `RISCVJALR(imm, rs, rd) -> JALR0( +| `RISCVJALR(imm, rs, rd) -> RISCV_JALR( translate_imm12 "imm" imm, translate_reg "rs" rd, translate_reg "rd" rd) diff --git a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen index 23bcc4cb..3025992e 100644 --- a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen +++ b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen @@ -1,7 +1,7 @@ | EBREAK -> `RISCVStopFetching | UTYPE( imm, rd, op) -> `RISCVUTYPE(translate_out_simm20 imm, translate_out_ireg rd, translate_out_uop op) -| JAL0( imm, rd) -> `RISCVJAL(translate_out_simm21 imm, translate_out_ireg rd) -| JALR0( imm, rs, rd) -> `RISCVJALR(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) +| RISCV_JAL( imm, rd) -> `RISCVJAL(translate_out_simm21 imm, translate_out_ireg rd) +| RISCV_JALR( imm, rs, rd) -> `RISCVJALR(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) | BTYPE( imm, rs2, rs1, op) -> `RISCVBType(translate_out_simm13 imm, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_bop op) | ITYPE( imm, rs1, rd, op) -> `RISCVIType(translate_out_simm12 imm, translate_out_ireg rs1, translate_out_ireg rd, translate_out_iop op) | SHIFTIOP( imm, rs, rd, op) -> `RISCVShiftIop(translate_out_imm6 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail index 3a54e0c8..3d52d111 100644 --- a/risc-v/riscv.sail +++ b/risc-v/riscv.sail @@ -20,11 +20,11 @@ function clause execute (UTYPE(imm, rd, op)) = wGPR(rd, ret) (********************************************************************) -union ast member ((bit[21]), regno) JAL +union ast member ((bit[21]), regno) RISCV_JAL -function clause decode ((bit[20]) imm : (regno) rd : 0b1101111) = Some (JAL(imm[19] : imm[7..0] : imm[8] : imm[18..13] : imm[12..9] : 0b0, rd)) +function clause decode ((bit[20]) imm : (regno) rd : 0b1101111) = Some (RISCV_JAL(imm[19] : imm[7..0] : imm[8] : imm[18..13] : imm[12..9] : 0b0, rd)) -function clause execute (JAL(imm, rd)) = { +function clause execute (RISCV_JAL(imm, rd)) = { (bit[64]) pc := PC; wGPR(rd, pc + 4); (bit[64]) offset := EXTS(imm); @@ -32,12 +32,12 @@ function clause execute (JAL(imm, rd)) = { } (********************************************************************) -union ast member((bit[12]), regno, regno) JALR +union ast member((bit[12]), regno, regno) RISCV_JALR function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b1100111) = - Some(JALR(imm, rs1, rd)) + Some(RISCV_JALR(imm, rs1, rd)) -function clause execute (JALR(imm, rs1, rd)) = { +function clause execute (RISCV_JALR(imm, rs1, rd)) = { (* write rd before anything else to prevent unintended strength *) wGPR(rd, PC + 4); (bit[64]) newPC := rGPR(rs1) + EXTS(imm); diff --git a/risc-v/riscv_regfp.sail b/risc-v/riscv_regfp.sail index ad341c60..dee9cc8e 100644 --- a/risc-v/riscv_regfp.sail +++ b/risc-v/riscv_regfp.sail @@ -20,12 +20,12 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( case (UTYPE ( imm, rd, op)) -> { if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; } - case (JAL ( imm, rd)) -> { + case (RISCV_JAL ( imm, rd)) -> { if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; let (bit[64]) offset = EXTS(imm) in Nias := [|| NIAFP_concrete_address (PC + offset) ||] } - case (JALR ( imm, rs, rd)) -> { + case (RISCV_JALR ( imm, rs, rd)) -> { if (rs == 0) then () else iR := RFull(GPRstr[rs]) :: iR; if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; let (bit[64]) offset = EXTS(imm) in diff --git a/x86/x64.sail b/x86/x64.sail index 16ba0f41..9fa0b838 100644 --- a/x86/x64.sail +++ b/x86/x64.sail @@ -147,7 +147,7 @@ typedef base = const union { typedef scale_index = (bit[2],regn) typedef rm = const union { - regn Reg; + regn X86_Reg; (option,base,qword) Mem; } @@ -167,10 +167,11 @@ typedef bit_offset = const union { (rm, regn) Bit_rm_r; } -typedef monop_name = enumerate { Dec; Inc; Not; Neg } +typedef monop_name = enumerate { X86_Dec; X86_Inc; X86_Not; X86_Neg } typedef binop_name = enumerate { - Add; Or; Adc; Sbb; And; Sub; Xor; Cmp; Rol; Ror; Rcl; Rcr; Shl; Shr; Test; Sar + X86_Add; X86_Or; X86_Adc; X86_Sbb; X86_And; X86_Sub; X86_Xor; X86_Cmp; + X86_Rol; X86_Ror; X86_Rcl; X86_Rcr; X86_Shl; X86_Shr; X86_Test; X86_Sar; } typedef bitop_name = enumerate { Bts; Btc; Btr } @@ -178,47 +179,48 @@ typedef bitop_name = enumerate { Bts; Btc; Btr } function binop_name opc_to_binop_name ((bit[4]) opc) = switch opc { - case 0x0 -> Add - case 0x1 -> Or - case 0x2 -> Adc - case 0x3 -> Sbb - case 0x4 -> And - case 0x5 -> Sub - case 0x6 -> Xor - case 0x7 -> Cmp - case 0x8 -> Rol - case 0x9 -> Ror - case 0xa -> Rcl - case 0xb -> Rcr - case 0xc -> Shl - case 0xd -> Shr - case 0xe -> Test - case 0xf -> Sar + case 0x0 -> X86_Add + case 0x1 -> X86_Or + case 0x2 -> X86_Adc + case 0x3 -> X86_Sbb + case 0x4 -> X86_And + case 0x5 -> X86_Sub + case 0x6 -> X86_Xor + case 0x7 -> X86_Cmp + case 0x8 -> X86_Rol + case 0x9 -> X86_Ror + case 0xa -> X86_Rcl + case 0xb -> X86_Rcr + case 0xc -> X86_Shl + case 0xd -> X86_Shr + case 0xe -> X86_Test + case 0xf -> X86_Sar } typedef cond = enumerate { - O; NO; B; NB; E; NE; NA; A; S; NS; P; NP; L; NL; NG; G; ALWAYS + X86_O; X86_NO; X86_B; X86_NB; X86_E; X86_NE; X86_NA; X86_A; X86_S; + X86_NS; X86_P; X86_NP; X86_L; X86_NL; X86_NG; X86_G; X86_ALWAYS; } function cond bv_to_cond ((bit[4]) v) = switch v { - case 0x0 -> O - case 0x1 -> NO - case 0x2 -> B - case 0x3 -> NB - case 0x4 -> E - case 0x5 -> NE - case 0x6 -> NA - case 0x7 -> A - case 0x8 -> S - case 0x9 -> NS - case 0xa -> P - case 0xb -> NP - case 0xc -> L - case 0xd -> NL - case 0xe -> NG - case 0xf -> G + case 0x0 -> X86_O + case 0x1 -> X86_NO + case 0x2 -> X86_B + case 0x3 -> X86_NB + case 0x4 -> X86_E + case 0x5 -> X86_NE + case 0x6 -> X86_NA + case 0x7 -> X86_A + case 0x8 -> X86_S + case 0x9 -> X86_NS + case 0xa -> X86_P + case 0xb -> X86_NP + case 0xc -> X86_L + case 0xd -> X86_NL + case 0xe -> X86_NG + case 0xf -> X86_G } (* Effective addresses *) @@ -248,7 +250,7 @@ function qword ea_base ((base) b) = function ea ea_rm ((wsize) sz, (rm) r) = switch r { - case (Reg(n)) -> Ea_r (sz, n) + case (X86_Reg(n)) -> Ea_r (sz, n) case (Mem(idx, b, d)) -> Ea_m (sz, ea_index(idx) + (qword) (ea_base(b) + d)) } @@ -509,22 +511,22 @@ function qword sar ((wsize) sz, (qword) a, (qword) b) = function unit write_binop ((bool) locked, (wsize) sz, (binop_name) bop, (qword) a, (qword) b, (ea) e) = switch bop { - case Add -> let (w,c,x) = add_with_carry_out (sz, a, b) in + case X86_Add -> let (w,c,x) = add_with_carry_out (sz, a, b) in write_arith_result (locked, sz, w, c, x, e) - case Sub -> let (w,c,x) = sub_with_borrow (sz, a, b) in + case X86_Sub -> let (w,c,x) = sub_with_borrow (sz, a, b) in write_arith_result (locked, sz, w, c, x, e) - case Cmp -> let (w,c,x) = sub_with_borrow (sz, a, b) in + case X86_Cmp -> let (w,c,x) = sub_with_borrow (sz, a, b) in write_arith_eflags (sz, w, c, x) - case Test -> write_logical_eflags (sz, a & b) - case And -> write_logical_result (locked, sz, a & b, e) (* XXX rmn30 wrong flags? *) - case Xor -> write_logical_result (locked, sz, a ^ b, e) - case Or -> write_logical_result (locked, sz, a | b, e) - case Rol -> write_result_erase_eflags (locked, rol (sz, a, b), e) - case Ror -> write_result_erase_eflags (locked, ror (sz, a, b), e) - case Sar -> write_result_erase_eflags (locked, sar (sz, a, b), e) - case Shl -> write_result_erase_eflags (locked, a << mask_shift (sz, b), e) - case Shr -> write_result_erase_eflags (locked, a >> mask_shift (sz, b), e) - case Adc -> + case X86_Test -> write_logical_eflags (sz, a & b) + case X86_And -> write_logical_result (locked, sz, a & b, e) (* XXX rmn30 wrong flags? *) + case X86_Xor -> write_logical_result (locked, sz, a ^ b, e) + case X86_Or -> write_logical_result (locked, sz, a | b, e) + case X86_Rol -> write_result_erase_eflags (locked, rol (sz, a, b), e) + case X86_Ror -> write_result_erase_eflags (locked, ror (sz, a, b), e) + case X86_Sar -> write_result_erase_eflags (locked, sar (sz, a, b), e) + case X86_Shl -> write_result_erase_eflags (locked, a << mask_shift (sz, b), e) + case X86_Shr -> write_result_erase_eflags (locked, a >> mask_shift (sz, b), e) + case X86_Adc -> { let carry = (bit) CF in let (qword) result = a + (qword) (b + carry) in @@ -534,7 +536,7 @@ function unit write_binop ((bool) locked, (wsize) sz, (binop_name) bop, (qword) write_arith_result_no_CF_OF (locked, sz, result, e); } } - case Sbb -> + case X86_Sbb -> { let carry = (bit) CF in let (qword) result = a - (qword) (b + carry) in @@ -549,33 +551,33 @@ function unit write_binop ((bool) locked, (wsize) sz, (binop_name) bop, (qword) function unit write_monop ((bool) locked, (wsize) sz, (monop_name) mop, (qword) a, (ea) e) = switch mop { - case Not -> wEA(locked, e) := ~(a) - case Dec -> write_arith_result_no_CF_OF (locked, sz, a - 1, e) - case Inc -> write_arith_result_no_CF_OF (locked, sz, a + 1, e)(* XXX rmn30 should set OF *) - case Neg -> { write_arith_result_no_CF_OF (locked, sz, 0 - a, e); - CF := undefined; - } + case X86_Not -> wEA(locked, e) := ~(a) + case X86_Dec -> write_arith_result_no_CF_OF (locked, sz, a - 1, e) + case X86_Inc -> write_arith_result_no_CF_OF (locked, sz, a + 1, e)(* XXX rmn30 should set OF *) + case X86_Neg -> { write_arith_result_no_CF_OF (locked, sz, 0 - a, e); + CF := undefined; + } } function bool read_cond ((cond) c) = switch c { - case A -> ~(CF) & ~(ZF) - case NB -> ~(CF) - case B -> CF - case NA -> CF | (bit) ZF - case E -> ZF - case G -> ~(ZF) & (SF == OF) - case NL -> SF == OF - case L -> SF != OF - case NG -> ZF | SF != OF - case NE -> ~(ZF) - case NO -> ~(OF) - case NP -> ~(PF) - case NS -> ~(SF) - case O -> OF - case P -> PF - case S -> SF - case ALWAYS -> true + case X86_A -> ~(CF) & ~(ZF) + case X86_NB -> ~(CF) + case X86_B -> CF + case X86_NA -> CF | (bit) ZF + case X86_E -> ZF + case X86_G -> ~(ZF) & (SF == OF) + case X86_NL -> SF == OF + case X86_L -> SF != OF + case X86_NG -> ZF | SF != OF + case X86_NE -> ~(ZF) + case X86_NO -> ~(OF) + case X86_NP -> ~(PF) + case X86_NS -> ~(SF) + case X86_O -> OF + case X86_P -> PF + case X86_S -> SF + case X86_ALWAYS -> true } function qword pop_aux () = @@ -677,7 +679,7 @@ function clause execute (CMPXCHG (locked, sz,r,n)) = let val_dst = EA(locked, dst) in let val_acc = EA(false, acc) in { - write_binop (locked, sz, Cmp, val_acc, val_dst, src); + write_binop (locked, sz, X86_Cmp, val_acc, val_dst, src); if val_acc == val_dst then wEA(locked, dst) := EA (false, src) else { @@ -692,9 +694,9 @@ function clause execute (CMPXCHG (locked, sz,r,n)) = DIV ========================================================================== *) -union ast member (wsize,rm) DIV +union ast member (wsize,rm) X86_DIV -function clause execute (DIV (sz,r)) = +function clause execute (X86_DIV (sz,r)) = let w = (int) (value_width(sz)) in let eax = Ea_r(sz, 0) in (* RAX *) let edx = Ea_r(sz, 2) in (* RDX *) @@ -756,7 +758,7 @@ union ast member unit LEAVE function clause execute LEAVE = { RSP := RBP; - pop (Reg (5)); (* RBP *) + pop (X86_Reg (5)); (* RBP *) } (* ========================================================================== @@ -828,9 +830,9 @@ function clause execute (MOVZX (sz1,ds,sz2)) = MUL ========================================================================== *) -union ast member (wsize,rm) MUL +union ast member (wsize,rm) X86_MUL -function clause execute (MUL (sz,r)) = +function clause execute (X86_MUL (sz,r)) = let eax = Ea_r (sz, 0) in (* RAX *) let val_eax = EA(false, eax) in let val_src = EA(false, ea_rm (sz, r)) in @@ -911,7 +913,7 @@ function clause execute (XADD (locked,sz,r,n)) = let val_dst = EA(locked, dst) in { wEA(false, src) := val_dst; - write_binop (locked, sz, Add, val_src, val_dst, dst); + write_binop (locked, sz, X86_Add, val_src, val_dst, dst); } (* ========================================================================== @@ -1326,7 +1328,7 @@ function (regfps) regfp_idx ((option) idx) = function (bool, regfps, regfps) regfp_rm ((rm) r) = switch r { - case (Reg(n)) -> + case (X86_Reg(n)) -> (false, [|| RFull(GPRstr[n]) ||], [|| ||]) case (Mem(idx, b, d)) -> { (true, [|| ||], append(regfp_idx(idx), regfp_base(b))) @@ -1374,40 +1376,40 @@ let all_flags = append([|| RFull("CF"), RFull("OF") ||], all_flags_but_cf_of) function (regfps) regfp_binop_flags ((binop_name) op) = switch (op) { - case Add -> all_flags - case Sub -> all_flags - case Cmp -> all_flags - case Test -> all_flags_but_cf_of - case And -> all_flags_but_cf_of - case Xor -> all_flags_but_cf_of - case Or -> all_flags_but_cf_of - case Rol -> all_flags - case Ror -> all_flags - case Sar -> all_flags - case Shl -> all_flags - case Shr -> all_flags - case Adc -> all_flags - case Sbb -> all_flags + case X86_Add -> all_flags + case X86_Sub -> all_flags + case X86_Cmp -> all_flags + case X86_Test -> all_flags_but_cf_of + case X86_And -> all_flags_but_cf_of + case X86_Xor -> all_flags_but_cf_of + case X86_Or -> all_flags_but_cf_of + case X86_Rol -> all_flags + case X86_Ror -> all_flags + case X86_Sar -> all_flags + case X86_Shl -> all_flags + case X86_Shr -> all_flags + case X86_Adc -> all_flags + case X86_Sbb -> all_flags } function (regfps) regfp_cond ((cond) c) = switch c { - case A -> [|| RFull("CF"), RFull("ZF") ||] - case NB -> [|| RFull("CF") ||] - case B -> [|| RFull("CF") ||] - case NA -> [|| RFull("CF"), RFull("ZF") ||] - case E -> [|| RFull("ZF") ||] - case G -> [|| RFull("ZF"), RFull("SF"), RFull("OF") ||] - case NL -> [|| RFull("SF"), RFull("OF") ||] - case L -> [|| RFull("SF"), RFull("OF") ||] - case NG -> [|| RFull("ZF"), RFull("SF"), RFull("OF") ||] - case NE -> [|| RFull("ZF") ||] - case NO -> [|| RFull("OF") ||] - case NP -> [|| RFull("PF") ||] - case NS -> [|| RFull("SF") ||] - case O -> [|| RFull("OF") ||] - case P -> [|| RFull("PF") ||] - case S -> [|| RFull("SF") ||] - case ALWAYS -> [|| ||] + case X86_A -> [|| RFull("CF"), RFull("ZF") ||] + case X86_NB -> [|| RFull("CF") ||] + case X86_B -> [|| RFull("CF") ||] + case X86_NA -> [|| RFull("CF"), RFull("ZF") ||] + case X86_E -> [|| RFull("ZF") ||] + case X86_G -> [|| RFull("ZF"), RFull("SF"), RFull("OF") ||] + case X86_NL -> [|| RFull("SF"), RFull("OF") ||] + case X86_L -> [|| RFull("SF"), RFull("OF") ||] + case X86_NG -> [|| RFull("ZF"), RFull("SF"), RFull("OF") ||] + case X86_NE -> [|| RFull("ZF") ||] + case X86_NO -> [|| RFull("OF") ||] + case X86_NP -> [|| RFull("PF") ||] + case X86_NS -> [|| RFull("SF") ||] + case X86_O -> [|| RFull("OF") ||] + case X86_P -> [|| RFull("PF") ||] + case X86_S -> [|| RFull("SF") ||] + case X86_ALWAYS -> [|| ||] } function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis (instr) = { @@ -1471,10 +1473,10 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( let (m, rs, aRs) = regfp_rm (r_m) in { ik := if m then IK_mem_rmw (rk, wk) else IK_simple; iR := RFull("RAX") :: RFull(GPRstr[reg]) :: append(rs, aRs); - oR := RFull("RAX") :: append(regfp_binop_flags(Cmp), rs); + oR := RFull("RAX") :: append(regfp_binop_flags(X86_Cmp), rs); aR := aRs; } - case(DIV (sz, r_m) ) -> + case(X86_DIV (sz, r_m) ) -> let (m, rs, ars) = regfp_rm (r_m) in { ik := if m then IK_mem_read (Read_plain) else IK_simple; iR := RFull("RAX") :: RFull("RDX") :: append(rs, ars); @@ -1549,7 +1551,7 @@ function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis ( oR := ors; aR := ars; } - case(MUL (sz, r_m) ) -> + case(X86_MUL (sz, r_m) ) -> let (m, rs, ars) = regfp_rm (r_m) in { ik := if m then IK_mem_read (Read_plain) else IK_simple; iR := RFull("RAX") :: append(rs, ars); -- cgit v1.2.3 From 4de5d52ee0f525d7c472e8aa3ee2a8158d888148 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 27 Nov 2017 17:30:03 +0000 Subject: Split rewriter into separate rewriting library and rewrite passes As discussed previously, we wanted to start refactoring the re-writer to make it a bit less monolithic, and in the future potentially break it into separate files for backend-specific rewrites and stuff. - rewriter.ml now contains the generic re-writing code - rewrites.ml contains the rewriting passes themselves It would be nice if the generic rewriting code didn't depend on the typechecker, because then it could be used in ASL parser on untyped code. --- src/ast_util.ml | 2 + src/ast_util.mli | 1 + src/ocaml_backend.ml | 6 +- src/process_file.ml | 8 +- src/rewriter.ml | 2871 +------------------------------------------------- src/rewriter.mli | 43 +- src/rewrites.ml | 2767 ++++++++++++++++++++++++++++++++++++++++++++++++ src/rewrites.mli | 60 ++ 8 files changed, 2885 insertions(+), 2873 deletions(-) create mode 100644 src/rewrites.ml create mode 100644 src/rewrites.mli diff --git a/src/ast_util.ml b/src/ast_util.ml index d26e12ed..b9e03987 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -48,6 +48,8 @@ open Big_int let no_annot = (Parse_ast.Unknown, ()) +let gen_loc l = Parse_ast.Generated l + let inc_ord = Ord_aux (Ord_inc, Parse_ast.Unknown) let dec_ord = Ord_aux (Ord_dec, Parse_ast.Unknown) diff --git a/src/ast_util.mli b/src/ast_util.mli index 2059bb7f..66d87c71 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -46,6 +46,7 @@ open Ast open Big_int val no_annot : unit annot +val gen_loc : Parse_ast.l -> Parse_ast.l val mk_id : string -> id val mk_kid : string -> kid diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index bf5ce83c..333505e0 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -197,7 +197,7 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = ^/^ ocaml_exp ctx exp | E_internal_let (lexp, exp1, exp2) -> separate space [string "let"; ocaml_atomic_lexp ctx lexp; - equals; string "ref"; parens (ocaml_atomic_exp ctx exp1 ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx (Rewriter.simple_typ (typ_of exp1))); string "in"] + equals; string "ref"; parens (ocaml_atomic_exp ctx exp1 ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx (Rewrites.simple_typ (typ_of exp1))); string "in"] ^/^ ocaml_exp ctx exp2 | E_loop (Until, cond, body) -> let loop_body = @@ -274,7 +274,7 @@ and ocaml_atomic_exp ctx (E_aux (exp_aux, _) as exp) = | Register typ -> if !opt_trace_ocaml then let var = gensym () in - let str_typ = parens (ocaml_string_typ (Rewriter.simple_typ typ) var) in + let str_typ = parens (ocaml_string_typ (Rewrites.simple_typ typ) var) in parens (separate space [string "let"; var; equals; bang ^^ zencode ctx id; string "in"; string "trace_read" ^^ space ^^ string_lit (string_of_id id) ^^ space ^^ str_typ ^^ semi; var]) else bang ^^ zencode ctx id @@ -293,7 +293,7 @@ and ocaml_assignment ctx (LEXP_aux (lexp_aux, _) as lexp) exp = let traced_exp = if !opt_trace_ocaml then let var = gensym () in - let str_typ = parens (ocaml_string_typ (Rewriter.simple_typ typ) var) in + let str_typ = parens (ocaml_string_typ (Rewrites.simple_typ typ) var) in parens (separate space [string "let"; var; equals; ocaml_atomic_exp ctx exp; string "in"; string "trace_write" ^^ space ^^ string_lit (string_of_id id) ^^ space ^^ str_typ ^^ semi; var]) else ocaml_atomic_exp ctx exp diff --git a/src/process_file.ml b/src/process_file.ml index 344e5951..e4518837 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -226,7 +226,7 @@ let rewrite rewriters defs = exit 1 let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)] -let rewrite_undefined = rewrite [("undefined", fun x -> Rewriter.rewrite_undefined !opt_lem_mwords x)] -let rewrite_ast_lem = rewrite Rewriter.rewrite_defs_lem -let rewrite_ast_ocaml = rewrite Rewriter.rewrite_defs_ocaml -let rewrite_ast_check = rewrite Rewriter.rewrite_defs_check +let rewrite_undefined = rewrite [("undefined", fun x -> Rewrites.rewrite_undefined !opt_lem_mwords x)] +let rewrite_ast_lem = rewrite Rewrites.rewrite_defs_lem +let rewrite_ast_ocaml = rewrite Rewrites.rewrite_defs_ocaml +let rewrite_ast_check = rewrite Rewrites.rewrite_defs_check diff --git a/src/rewriter.ml b/src/rewriter.ml index fd1479a7..c483cf9b 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -58,8 +58,6 @@ type 'a rewriters = { } -let (>>) f g = fun x -> g(f(x)) - let effect_of_fpat (FP_aux (_,(_,a))) = effect_of_annot a let effect_of_lexp (LEXP_aux (_,(_,a))) = effect_of_annot a let effect_of_fexp (FE_aux (_,(_,a))) = effect_of_annot a @@ -75,19 +73,7 @@ let effect_of_pexp (Pat_aux (pexp,(_,a))) = match a with | Pat_when (_, g, e) -> union_effects (effect_of g) (effect_of e)) let effect_of_lb (LB_aux (_,(_,a))) = effect_of_annot a -let get_loc_exp (E_aux (_,(l,_))) = l -let gen_loc l = Parse_ast.Generated l - let simple_annot l typ = (gen_loc l, Some (Env.empty, typ, no_effect)) -let simple_num l n = E_aux ( - E_lit (L_aux (L_num n, gen_loc l)), - simple_annot (gen_loc l) - (atom_typ (Nexp_aux (Nexp_constant n, gen_loc l)))) -let annot_exp_effect e_aux l env typ effect = E_aux (e_aux, (l, Some (env, typ, effect))) -let annot_exp e_aux l env typ = annot_exp_effect e_aux l env typ no_effect -let annot_pat p_aux l env typ = P_aux (p_aux, (l, Some (env, typ, no_effect))) -let annot_letbind (p_aux, exp) l env typ = - LB_aux (LB_val (annot_pat p_aux l env typ, exp), (l, Some (env, typ, effect_of exp))) let rec small (E_aux (exp,_)) = match exp with | E_id _ @@ -98,27 +84,6 @@ let rec small (E_aux (exp,_)) = match exp with | E_sizeof _ -> true | _ -> false -let fresh_name_counter = ref 0 - -let fresh_name () = - let current = !fresh_name_counter in - let () = fresh_name_counter := (current + 1) in - current -let reset_fresh_name_counter () = - fresh_name_counter := 0 - -let fresh_id pre l = - let current = fresh_name () in - Id_aux (Id (pre ^ string_of_int current), gen_loc l) - -let fresh_id_exp pre ((l,annot)) = - let id = fresh_id pre l in - E_aux (E_id id, (gen_loc l, annot)) - -let fresh_id_pat pre ((l,annot)) = - let id = fresh_id pre l in - P_aux (P_id id, (gen_loc l, annot)) - let union_eff_exps es = List.fold_left union_effects no_effect (List.map effect_of es) @@ -258,78 +223,10 @@ let updates_vars_effs = function let updates_vars eaux = updates_vars_effs (effect_of eaux) -let id_to_string (Id_aux(id,l)) = - match id with - | Id(s) -> s - | DeIid(s) -> s - - -(*let rec partial_assoc (eq: 'a -> 'a -> bool) (v: 'a) (ls : ('a *'b) list ) : 'b option = match ls with - | [] -> None - | (v1,v2)::ls -> if (eq v1 v) then Some v2 else partial_assoc eq v ls - -let mk_atom_typ i = {t=Tapp("atom",[TA_nexp i])} - -let simple_num l n : tannot exp = - let typ = simple_annot (mk_atom_typ (mk_c (big_int_of_int n))) in - E_aux (E_lit (L_aux (L_num n,l)), (l,typ)) - -let rec rewrite_nexp_to_exp program_vars l nexp = - let rewrite n = rewrite_nexp_to_exp program_vars l n in - let typ = mk_atom_typ nexp in - let actual_rewrite_n nexp = - match nexp.nexp with - | Nconst i -> E_aux (E_lit (L_aux (L_num (int_of_big_int i),l)), (l,simple_annot typ)) - | Nadd (n1,n2) -> E_aux (E_app_infix (rewrite n1,(Id_aux (Id "+",l)),rewrite n2), - (l, (tag_annot typ (External (Some "add"))))) - | Nmult (n1,n2) -> E_aux (E_app_infix (rewrite n1,(Id_aux (Id "*",l)),rewrite n2), - (l, tag_annot typ (External (Some "multiply")))) - | Nsub (n1,n2) -> E_aux (E_app_infix (rewrite n1,(Id_aux (Id "-",l)),rewrite n2), - (l, tag_annot typ (External (Some "minus")))) - | N2n (n, _) -> E_aux (E_app_infix (E_aux (E_lit (L_aux (L_num 2,l)), (l, simple_annot (mk_atom_typ n_two))), - (Id_aux (Id "**",l)), - rewrite n), (l, tag_annot typ (External (Some "power")))) - | Npow(n,i) -> E_aux (E_app_infix - (rewrite n, (Id_aux (Id "**",l)), - E_aux (E_lit (L_aux (L_num i,l)), - (l, simple_annot (mk_atom_typ (mk_c_int i))))), - (l, tag_annot typ (External (Some "power")))) - | Nneg(n) -> E_aux (E_app_infix (E_aux (E_lit (L_aux (L_num 0,l)), (l, simple_annot (mk_atom_typ n_zero))), - (Id_aux (Id "-",l)), - rewrite n), - (l, tag_annot typ (External (Some "minus")))) - | Nvar v -> (*TODO these need to generate an error as it's a place where there's insufficient specification. - But, for now I need to permit this to make power.sail compile, and most errors are in trap - or vectors *) - (*let _ = Printf.eprintf "unbound variable here %s\n" v in*) - E_aux (E_id (Id_aux (Id v,l)),(l,simple_annot typ)) - | _ -> raise (Reporting_basic.err_unreachable l ("rewrite_nexp given n that can't be rewritten: " ^ (n_to_string nexp))) in - match program_vars with - | None -> actual_rewrite_n nexp - | Some program_vars -> - (match partial_assoc nexp_eq_check nexp program_vars with - | None -> actual_rewrite_n nexp - | Some(None,ev) -> - (*let _ = Printf.eprintf "var case of rewrite, %s\n" ev in*) - E_aux (E_id (Id_aux (Id ev,l)), (l, simple_annot typ)) - | Some(Some f,ev) -> - E_aux (E_app ((Id_aux (Id f,l)), [ (E_aux (E_id (Id_aux (Id ev,l)), (l,simple_annot typ)))]), - (l, tag_annot typ (External (Some f))))) - -let rec match_to_program_vars ns bounds = - match ns with - | [] -> [] - | n::ns -> match find_var_from_nexp n bounds with - | None -> match_to_program_vars ns bounds - | Some(augment,ev) -> - (*let _ = Printf.eprintf "adding n %s to program var %s\n" (n_to_string n) ev in*) - (n,(augment,ev))::(match_to_program_vars ns bounds)*) - let explode s = let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in exp (String.length s - 1) [] - let vector_string_to_bit_list l lit = let hexchar_to_binlist = function @@ -350,14 +247,14 @@ let vector_string_to_bit_list l lit = | 'E' -> ['1';'1';'1';'0'] | 'F' -> ['1';'1';'1';'1'] | _ -> raise (Reporting_basic.err_unreachable l "hexchar_to_binlist given unrecognized character") in - + let s_bin = match lit with | L_hex s_hex -> List.flatten (List.map hexchar_to_binlist (explode (String.uppercase s_hex))) | L_bin s_bin -> explode s_bin | _ -> raise (Reporting_basic.err_unreachable l "s_bin given non vector literal") in List.map (function '0' -> L_aux (L_zero, gen_loc l) - | '1' -> L_aux (L_one,gen_loc l) + | '1' -> L_aux (L_one, gen_loc l) | _ -> raise (Reporting_basic.err_unreachable (gen_loc l) "binary had non-zero or one")) s_bin let rewrite_pat rewriters (P_aux (pat,(l,annot))) = @@ -381,7 +278,7 @@ let rewrite_pat rewriters (P_aux (pat,(l,annot))) = | P_list pats -> rewrap (P_list (List.map rewrite pats)) | P_cons (pat1, pat2) -> rewrap (P_cons (rewrite pat1, rewrite pat2)) -let rewrite_exp rewriters (E_aux (exp,(l,annot))) = +let rewrite_exp rewriters (E_aux (exp,(l,annot))) = let rewrap e = E_aux (e,(l,annot)) in let rewrite = rewriters.rewrite_exp rewriters in match exp with @@ -406,22 +303,22 @@ let rewrite_exp rewriters (E_aux (exp,(l,annot))) = | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite vec,rewrite index)) | E_vector_subrange (vec,i1,i2) -> rewrap (E_vector_subrange (rewrite vec,rewrite i1,rewrite i2)) - | E_vector_update (vec,index,new_v) -> + | E_vector_update (vec,index,new_v) -> rewrap (E_vector_update (rewrite vec,rewrite index,rewrite new_v)) | E_vector_update_subrange (vec,i1,i2,new_v) -> rewrap (E_vector_update_subrange (rewrite vec,rewrite i1,rewrite i2,rewrite new_v)) | E_vector_append (v1,v2) -> rewrap (E_vector_append (rewrite v1,rewrite v2)) - | E_list exps -> rewrap (E_list (List.map rewrite exps)) + | E_list exps -> rewrap (E_list (List.map rewrite exps)) | E_cons(h,t) -> rewrap (E_cons (rewrite h,rewrite t)) - | E_record (FES_aux (FES_Fexps(fexps, bool),fannot)) -> - rewrap (E_record - (FES_aux (FES_Fexps - (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> + | E_record (FES_aux (FES_Fexps(fexps, bool),fannot)) -> + rewrap (E_record + (FES_aux (FES_Fexps + (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> FE_aux(FE_Fexp(id,rewrite e),fannot)) fexps, bool), fannot))) | E_record_update (re,(FES_aux (FES_Fexps(fexps, bool),fannot))) -> rewrap (E_record_update ((rewrite re), - (FES_aux (FES_Fexps - (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> + (FES_aux (FES_Fexps + (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> FE_aux(FE_Fexp(id,rewrite e),fannot)) fexps, bool), fannot)))) | E_field(exp,id) -> rewrap (E_field(rewrite exp,id)) | E_case (exp,pexps) -> @@ -439,102 +336,6 @@ let rewrite_exp rewriters (E_aux (exp,(l,annot))) = | E_assert(e1,e2) -> rewrap (E_assert(rewrite e1,rewrite e2)) | E_internal_cast (casted_annot,exp) -> rewrap (E_internal_cast (casted_annot, rewrite exp)) - (* check_exp (env_of exp) (strip_exp exp) (typ_of_annot casted_annot) *) - (*let new_exp = rewrite exp in - (*let _ = Printf.eprintf "Removing an internal_cast with %s\n" (tannot_to_string casted_annot) in*) - (match casted_annot,exp with - | Base((_,t),_,_,_,_,_),E_aux(ec,(ecl,Base((_,exp_t),_,_,_,_,_))) -> - (*let _ = Printf.eprintf "Considering removing an internal cast where the two types are %s and %s\n" - (t_to_string t) (t_to_string exp_t) in*) - (match t.t,exp_t.t with - (*TODO should pass d_env into here so that I can look at the abbreviations if there are any here*) - | Tapp("vector",[TA_nexp n1;TA_nexp nw1;TA_ord o1;_]), - Tapp("vector",[TA_nexp n2;TA_nexp nw2;TA_ord o2;_]) - | Tapp("vector",[TA_nexp n1;TA_nexp nw1;TA_ord o1;_]), - Tapp("reg",[TA_typ {t=(Tapp("vector",[TA_nexp n2; TA_nexp nw2; TA_ord o2;_]))}]) -> - (match n1.nexp with - | Nconst i1 -> if nexp_eq n1 n2 then new_exp else rewrap (E_cast (t_to_typ t,new_exp)) - | _ -> (match o1.order with - | Odec -> - (*let _ = Printf.eprintf "Considering removing a cast or not: %s %s, %b\n" - (n_to_string nw1) (n_to_string n1) (nexp_one_more_than nw1 n1) in*) - rewrap (E_cast (Typ_aux (Typ_var (Kid_aux((Var "length"),Parse_ast.Generated l)), - Parse_ast.Generated l),new_exp)) - | _ -> new_exp)) - | _ -> new_exp - | Base((_,t),_,_,_,_,_),_ -> - (*let _ = Printf.eprintf "Considering removing an internal cast where the remaining type is %s\n%!" - (t_to_string t) in*) - (match t.t with - | Tapp("vector",[TA_nexp n1;TA_nexp nw1;TA_ord o1;_]) -> - (match o1.order with - | Odec -> - let _ = Printf.eprintf "Considering removing a cast or not: %s %s, %b\n" - (n_to_string nw1) (n_to_string n1) (nexp_one_more_than nw1 n1) in - rewrap (E_cast (Typ_aux (Typ_var (Kid_aux((Var "length"), Parse_ast.Generated l)), - Parse_ast.Generated l), new_exp)) - | _ -> new_exp) - | _ -> new_exp) - | _ -> (*let _ = Printf.eprintf "Not a base match?\n" in*) new_exp*) - (*| E_internal_exp (l,impl) -> - match impl with - | Base((_,t),_,_,_,_,bounds) -> - (*let _ = Printf.eprintf "Rewriting internal expression, with type %s, and bounds %s\n" - (t_to_string t) (bounds_to_string bounds) in*) - let bounds = match nmap with | None -> bounds | Some (nm,_) -> add_map_to_bounds nm bounds in - (*let _ = Printf.eprintf "Bounds after looking at nmap %s\n" (bounds_to_string bounds) in*) - (match t.t with - (*Old case; should possibly be removed*) - | Tapp("register",[TA_typ {t= Tapp("vector",[ _; TA_nexp r;_;_])}]) - | Tapp("vector", [_;TA_nexp r;_;_]) - | Tabbrev(_, {t=Tapp("vector",[_;TA_nexp r;_;_])}) -> - (*let _ = Printf.eprintf "vector case with %s, bounds are %s\n" - (n_to_string r) (bounds_to_string bounds) in*) - let nexps = expand_nexp r in - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l r - | map -> rewrite_nexp_to_exp (Some map) l r) - | Tapp("implicit", [TA_nexp i]) -> - (*let _ = Printf.eprintf "Implicit case with %s\n" (n_to_string i) in*) - let nexps = expand_nexp i in - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l i - | map -> rewrite_nexp_to_exp (Some map) l i) - | _ -> - raise (Reporting_basic.err_unreachable l - ("Internal_exp given unexpected types " ^ (t_to_string t)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Internal_exp given none Base annot"))*) - (*| E_sizeof_internal (l,impl) -> - (match impl with - | Base((_,t),_,_,_,_,bounds) -> - let bounds = match nmap with | None -> bounds | Some (nm,_) -> add_map_to_bounds nm bounds in - (match t.t with - | Tapp("atom",[TA_nexp n]) -> - let nexps = expand_nexp n in - (*let _ = Printf.eprintf "Removing sizeof_internal with type %s\n" (t_to_string t) in*) - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l n - | map -> rewrite_nexp_to_exp (Some map) l n) - | _ -> raise (Reporting_basic.err_unreachable l ("Sizeof internal had non-atom type " ^ (t_to_string t)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Sizeof internal had none base annot"))*) - (*| E_internal_exp_user ((l,user_spec),(_,impl)) -> - (match (user_spec,impl) with - | (Base((_,tu),_,_,_,_,_), Base((_,ti),_,_,_,_,bounds)) -> - (*let _ = Printf.eprintf "E_interal_user getting rewritten two types are %s and %s\n" - (t_to_string tu) (t_to_string ti) in*) - let bounds = match nmap with | None -> bounds | Some (nm,_) -> add_map_to_bounds nm bounds in - (match (tu.t,ti.t) with - | (Tapp("implicit", [TA_nexp u]),Tapp("implicit",[TA_nexp i])) -> - (*let _ = Printf.eprintf "Implicit case with %s\n" (n_to_string i) in*) - let nexps = expand_nexp i in - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l i - (*add u to program_vars env; for now it will work out properly by accident*) - | map -> rewrite_nexp_to_exp (Some map) l i) - | _ -> - raise (Reporting_basic.err_unreachable l - ("Internal_exp_user given unexpected types " ^ (t_to_string tu) ^ ", " ^ (t_to_string ti)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Internal_exp_user given none Base annot")))*) | E_internal_let _ -> raise (Reporting_basic.err_unreachable l "Internal let found before it should have been introduced") | E_internal_return _ -> raise (Reporting_basic.err_unreachable l "Internal return found before it should have been introduced") | E_internal_plet _ -> raise (Reporting_basic.err_unreachable l " Internal plet found before it should have been introduced") @@ -563,7 +364,6 @@ let rewrite_lexp rewriters (LEXP_aux(lexp,(l,annot))) = let rewrite_fun rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),(l,annot))) = - let _ = reset_fresh_name_counter () in (FCL_aux (FCL_Funcl (id,rewriters.rewrite_pat rewriters pat, rewriters.rewrite_exp rewriters exp),(l,annot))) in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) @@ -589,7 +389,7 @@ let rewriters_base = rewrite_fun = rewrite_fun; rewrite_def = rewrite_def; rewrite_defs = rewrite_defs_base} - + let rewrite_defs (Defs defs) = rewrite_defs_base rewriters_base (Defs defs) module Envmap = Finite_map.Fmap_map(String) @@ -986,2650 +786,3 @@ let compute_exp_alg bot join = ; lB_aux = (fun ((vl,lb),annot) -> (vl,LB_aux (lb,annot))) ; pat_alg = compute_pat_alg bot join } - -let rec rewrite_nexp_ids env (Nexp_aux (nexp, l) as nexp_aux) = match nexp with -| Nexp_id id -> rewrite_nexp_ids env (Env.get_num_def id env) -| Nexp_times (nexp1, nexp2) -> Nexp_aux (Nexp_times (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) -| Nexp_sum (nexp1, nexp2) -> Nexp_aux (Nexp_sum (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) -| Nexp_minus (nexp1, nexp2) -> Nexp_aux (Nexp_minus (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) -| Nexp_exp nexp -> Nexp_aux (Nexp_exp (rewrite_nexp_ids env nexp), l) -| Nexp_neg nexp -> Nexp_aux (Nexp_neg (rewrite_nexp_ids env nexp), l) -| _ -> nexp_aux - -let rewrite_defs_nexp_ids, rewrite_typ_nexp_ids = - let rec rewrite_typ env (Typ_aux (typ, l) as typ_aux) = match typ with - | Typ_fn (arg_t, ret_t, eff) -> - Typ_aux (Typ_fn (rewrite_typ env arg_t, rewrite_typ env ret_t, eff), l) - | Typ_tup ts -> - Typ_aux (Typ_tup (List.map (rewrite_typ env) ts), l) - | Typ_exist (kids, c, typ) -> - Typ_aux (Typ_exist (kids, c, rewrite_typ env typ), l) - | Typ_app (id, targs) -> - Typ_aux (Typ_app (id, List.map (rewrite_typ_arg env) targs), l) - | _ -> typ_aux - and rewrite_typ_arg env (Typ_arg_aux (targ, l) as targ_aux) = match targ with - | Typ_arg_nexp nexp -> - Typ_arg_aux (Typ_arg_nexp (rewrite_nexp_ids env nexp), l) - | Typ_arg_typ typ -> - Typ_arg_aux (Typ_arg_typ (rewrite_typ env typ), l) - | Typ_arg_order ord -> - Typ_arg_aux (Typ_arg_order ord, l) - in - - let rewrite_annot = function - | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_typ env typ, eff)) - | (l, None) -> (l, None) - in - - rewrite_defs_base { - rewriters_base with rewrite_exp = (fun _ -> map_exp_annot rewrite_annot) - }, - rewrite_typ - - -(* Re-write trivial sizeof expressions - trivial meaning that the - value of the sizeof can be directly inferred from the type - variables in scope. *) -let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = - let extract_typ_var l env nexp (id, (_, typ)) = - let var = E_aux (E_id id, (l, Some (env, typ, no_effect))) in - match destruct_atom_nexp env typ with - | Some size when prove env (nc_eq size nexp) -> Some var - | _ -> - begin - match destruct_vector env typ with - | Some (_, len, _, _) when prove env (nc_eq len nexp) -> - Some (E_aux (E_app (mk_id "length", [var]), (l, Some (env, atom_typ len, no_effect)))) - | _ -> None - end - in - let rec split_nexp (Nexp_aux (nexp_aux, l) as nexp) = - match nexp_aux with - | Nexp_sum (n1, n2) -> - mk_exp (E_app (mk_id "add_range", [split_nexp n1; split_nexp n2])) - | Nexp_minus (n1, n2) -> - mk_exp (E_app (mk_id "sub_range", [split_nexp n1; split_nexp n2])) - | Nexp_times (n1, n2) -> - mk_exp (E_app (mk_id "mult_range", [split_nexp n1; split_nexp n2])) - | Nexp_neg nexp -> mk_exp (E_app (mk_id "negate_range", [split_nexp nexp])) - | _ -> mk_exp (E_sizeof nexp) - in - let rec rewrite_e_aux split_sizeof (E_aux (e_aux, (l, _)) as orig_exp) = - let env = env_of orig_exp in - match e_aux with - | E_sizeof (Nexp_aux (Nexp_constant c, _) as nexp) -> - E_aux (E_lit (L_aux (L_num c, l)), (l, Some (env, atom_typ nexp, no_effect))) - | E_sizeof nexp -> - begin - match nexp_simp (rewrite_nexp_ids (env_of orig_exp) nexp) with - | Nexp_aux (Nexp_constant c, _) -> - E_aux (E_lit (L_aux (L_num c, l)), (l, Some (env, atom_typ nexp, no_effect))) - | _ -> - let locals = Env.get_locals env in - let exps = Bindings.bindings locals - |> List.map (extract_typ_var l env nexp) - |> List.map (fun opt -> match opt with Some x -> [x] | None -> []) - |> List.concat - in - match exps with - | (exp :: _) -> check_exp env (strip_exp exp) (typ_of exp) - | [] when split_sizeof -> - fold_exp (rewrite_e_sizeof false) (check_exp env (split_nexp nexp) (typ_of orig_exp)) - | [] -> orig_exp - end - | _ -> orig_exp - and rewrite_e_sizeof split_sizeof = - { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux split_sizeof (E_aux (exp, annot))) } - in - rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rewrite_e_sizeof true)) }, rewrite_e_aux true - -(* Rewrite sizeof expressions with type-level variables to - term-level expressions - - For each type-level variable used in a sizeof expressions whose value cannot - be directly extracted from existing parameters of the surrounding function, - a further parameter is added; calls to the function are rewritten - accordingly (possibly causing further rewriting in the calling function) *) -let rewrite_sizeof (Defs defs) = - let sizeof_frees exp = - fst (fold_exp - { (compute_exp_alg KidSet.empty KidSet.union) with - e_sizeof = (fun nexp -> (nexp_frees nexp, E_sizeof nexp)) } - exp) in - - (* Collect nexps whose values can be obtained directly from a pattern bind *) - let nexps_from_params pat = - fst (fold_pat - { (compute_pat_alg [] (@)) with - p_aux = (fun ((v,pat),((l,_) as annot)) -> - let v' = match pat with - | P_id id | P_as (_, id) -> - let (Typ_aux (typ,_) as typ_aux) = typ_of_annot annot in - (match typ with - | Typ_app (atom, [Typ_arg_aux (Typ_arg_nexp nexp, _)]) - when string_of_id atom = "atom" -> - [nexp, E_id id] - | Typ_app (vector, _) when string_of_id vector = "vector" -> - let id_length = Id_aux (Id "length", gen_loc l) in - (try - (match Env.get_val_spec id_length (env_of_annot annot) with - | _ -> - let (_,len,_,_) = vector_typ_args_of typ_aux in - let exp = E_app (id_length, [E_aux (E_id id, annot)]) in - [len, exp]) - with - | _ -> []) - | _ -> []) - | _ -> [] in - (v @ v', P_aux (pat,annot)))} pat) in - - (* Substitute collected values in sizeof expressions *) - let rec e_sizeof nmap (Nexp_aux (nexp, l) as nexp_aux) = - try snd (List.find (fun (nexp,_) -> nexp_identical nexp nexp_aux) nmap) - with - | Not_found -> - let binop nexp1 op nexp2 = E_app_infix ( - E_aux (e_sizeof nmap nexp1, simple_annot l (atom_typ nexp1)), - Id_aux (Id op, Parse_ast.Unknown), - E_aux (e_sizeof nmap nexp2, simple_annot l (atom_typ nexp2)) - ) in - let (Nexp_aux (nexp, l) as nexp_aux) = nexp_simp nexp_aux in - (match nexp with - | Nexp_constant i -> E_lit (L_aux (L_num i, l)) - | Nexp_times (nexp1, nexp2) -> binop nexp1 "*" nexp2 - | Nexp_sum (nexp1, nexp2) -> binop nexp1 "+" nexp2 - | Nexp_minus (nexp1, nexp2) -> binop nexp1 "-" nexp2 - | _ -> E_sizeof nexp_aux) in - - let ex_regex = Str.regexp "'ex[0-9]+" in - - (* Rewrite calls to functions which have had parameters added to pass values - of type-level variables; these are added as sizeof expressions first, and - then further rewritten as above. *) - let e_app_aux param_map ((exp, exp_orig), ((l, _) as annot)) = - let env = env_of_annot annot in - let full_exp = E_aux (exp, annot) in - let orig_exp = E_aux (exp_orig, annot) in - match exp with - | E_app (f, args) -> - if Bindings.mem f param_map then - (* Retrieve instantiation of the type variables of the called function - for the given parameters in the original environment *) - let inst = - try instantiation_of orig_exp with - | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (string_of_type_error err)) in - (* Rewrite the inst using orig_kid so that each type variable has it's - original name rather than a mangled typechecker name *) - let inst = KBindings.fold (fun kid uvar b -> KBindings.add (orig_kid kid) uvar b) inst KBindings.empty in - let kid_exp kid = begin - (* We really don't want to see an existential here! *) - assert (not (Str.string_match ex_regex (string_of_kid kid) 0)); - let uvar = try Some (KBindings.find (orig_kid kid) inst) with Not_found -> None in - match uvar with - | Some (U_nexp nexp) -> - let sizeof = E_aux (E_sizeof nexp, (l, Some (env, atom_typ nexp, no_effect))) in - (try rewrite_trivial_sizeof_exp sizeof with - | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (string_of_type_error err))) - (* If the type variable is Not_found then it was probably - introduced by a P_var pattern, so it likely exists as - a variable in scope. It can't be an existential because the assert rules that out. *) - | None -> annot_exp (E_id (id_of_kid (orig_kid kid))) l env (atom_typ (nvar (orig_kid kid))) - | _ -> - raise (Reporting_basic.err_unreachable l - ("failed to infer nexp for type variable " ^ string_of_kid kid ^ - " of function " ^ string_of_id f)) - end in - let kid_exps = List.map kid_exp (KidSet.elements (Bindings.find f param_map)) in - (E_aux (E_app (f, kid_exps @ args), annot), orig_exp) - else (full_exp, orig_exp) - | _ -> (full_exp, orig_exp) in - - (* Plug this into a folding algorithm that also keeps around a copy of the - original expressions, which we use to infer instantiations of type variables - in the original environments *) - let copy_exp_alg = - { e_block = (fun es -> let (es, es') = List.split es in (E_block es, E_block es')) - ; e_nondet = (fun es -> let (es, es') = List.split es in (E_nondet es, E_nondet es')) - ; e_id = (fun id -> (E_id id, E_id id)) - ; e_lit = (fun lit -> (E_lit lit, E_lit lit)) - ; e_cast = (fun (typ,(e,e')) -> (E_cast (typ,e), E_cast (typ,e'))) - ; e_app = (fun (id,es) -> let (es, es') = List.split es in (E_app (id,es), E_app (id,es'))) - ; e_app_infix = (fun ((e1,e1'),id,(e2,e2')) -> (E_app_infix (e1,id,e2), E_app_infix (e1',id,e2'))) - ; e_tuple = (fun es -> let (es, es') = List.split es in (E_tuple es, E_tuple es')) - ; e_if = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_if (e1,e2,e3), E_if (e1',e2',e3'))) - ; e_for = (fun (id,(e1,e1'),(e2,e2'),(e3,e3'),order,(e4,e4')) -> (E_for (id,e1,e2,e3,order,e4), E_for (id,e1',e2',e3',order,e4'))) - ; e_loop = (fun (lt, (e1, e1'), (e2, e2')) -> (E_loop (lt, e1, e2), E_loop (lt, e1', e2'))) - ; e_vector = (fun es -> let (es, es') = List.split es in (E_vector es, E_vector es')) - ; e_vector_access = (fun ((e1,e1'),(e2,e2')) -> (E_vector_access (e1,e2), E_vector_access (e1',e2'))) - ; e_vector_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_subrange (e1,e2,e3), E_vector_subrange (e1',e2',e3'))) - ; e_vector_update = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_update (e1,e2,e3), E_vector_update (e1',e2',e3'))) - ; e_vector_update_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3'),(e4,e4')) -> (E_vector_update_subrange (e1,e2,e3,e4), E_vector_update_subrange (e1',e2',e3',e4'))) - ; e_vector_append = (fun ((e1,e1'),(e2,e2')) -> (E_vector_append (e1,e2), E_vector_append (e1',e2'))) - ; e_list = (fun es -> let (es, es') = List.split es in (E_list es, E_list es')) - ; e_cons = (fun ((e1,e1'),(e2,e2')) -> (E_cons (e1,e2), E_cons (e1',e2'))) - ; e_record = (fun (fexps, fexps') -> (E_record fexps, E_record fexps')) - ; e_record_update = (fun ((e1,e1'),(fexp,fexp')) -> (E_record_update (e1,fexp), E_record_update (e1',fexp'))) - ; e_field = (fun ((e1,e1'),id) -> (E_field (e1,id), E_field (e1',id))) - ; e_case = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_case (e1,pexps), E_case (e1',pexps'))) - ; e_let = (fun ((lb,lb'),(e2,e2')) -> (E_let (lb,e2), E_let (lb',e2'))) - ; e_assign = (fun ((lexp,lexp'),(e2,e2')) -> (E_assign (lexp,e2), E_assign (lexp',e2'))) - ; e_sizeof = (fun nexp -> (E_sizeof nexp, E_sizeof nexp)) - ; e_constraint = (fun nc -> (E_constraint nc, E_constraint nc)) - ; e_exit = (fun (e1,e1') -> (E_exit (e1), E_exit (e1'))) - ; e_return = (fun (e1,e1') -> (E_return e1, E_return e1')) - ; e_assert = (fun ((e1,e1'),(e2,e2')) -> (E_assert(e1,e2), E_assert(e1',e2')) ) - ; e_internal_cast = (fun (a,(e1,e1')) -> (E_internal_cast (a,e1), E_internal_cast (a,e1'))) - ; e_internal_exp = (fun a -> (E_internal_exp a, E_internal_exp a)) - ; e_internal_exp_user = (fun (a1,a2) -> (E_internal_exp_user (a1,a2), E_internal_exp_user (a1,a2))) - ; e_comment = (fun c -> (E_comment c, E_comment c)) - ; e_comment_struc = (fun (e,e') -> (E_comment_struc e, E_comment_struc e')) - ; e_internal_let = (fun ((lexp,lexp'), (e2,e2'), (e3,e3')) -> (E_internal_let (lexp,e2,e3), E_internal_let (lexp',e2',e3'))) - ; e_internal_plet = (fun (pat, (e1,e1'), (e2,e2')) -> (E_internal_plet (pat,e1,e2), E_internal_plet (pat,e1',e2'))) - ; e_internal_return = (fun (e,e') -> (E_internal_return e, E_internal_return e')) - ; e_aux = (fun ((e,e'),annot) -> (E_aux (e,annot), E_aux (e',annot))) - ; lEXP_id = (fun id -> (LEXP_id id, LEXP_id id)) - ; lEXP_memory = (fun (id,es) -> let (es, es') = List.split es in (LEXP_memory (id,es), LEXP_memory (id,es'))) - ; lEXP_cast = (fun (typ,id) -> (LEXP_cast (typ,id), LEXP_cast (typ,id))) - ; lEXP_tup = (fun tups -> let (tups,tups') = List.split tups in (LEXP_tup tups, LEXP_tup tups')) - ; lEXP_vector = (fun ((lexp,lexp'),(e2,e2')) -> (LEXP_vector (lexp,e2), LEXP_vector (lexp',e2'))) - ; lEXP_vector_range = (fun ((lexp,lexp'),(e2,e2'),(e3,e3')) -> (LEXP_vector_range (lexp,e2,e3), LEXP_vector_range (lexp',e2',e3'))) - ; lEXP_field = (fun ((lexp,lexp'),id) -> (LEXP_field (lexp,id), LEXP_field (lexp',id))) - ; lEXP_aux = (fun ((lexp,lexp'),annot) -> (LEXP_aux (lexp,annot), LEXP_aux (lexp',annot))) - ; fE_Fexp = (fun (id,(e,e')) -> (FE_Fexp (id,e), FE_Fexp (id,e'))) - ; fE_aux = (fun ((fexp,fexp'),annot) -> (FE_aux (fexp,annot), FE_aux (fexp',annot))) - ; fES_Fexps = (fun (fexps,b) -> let (fexps, fexps') = List.split fexps in (FES_Fexps (fexps,b), FES_Fexps (fexps',b))) - ; fES_aux = (fun ((fexp,fexp'),annot) -> (FES_aux (fexp,annot), FES_aux (fexp',annot))) - ; def_val_empty = (Def_val_empty, Def_val_empty) - ; def_val_dec = (fun (e,e') -> (Def_val_dec e, Def_val_dec e')) - ; def_val_aux = (fun ((defval,defval'),aux) -> (Def_val_aux (defval,aux), Def_val_aux (defval',aux))) - ; pat_exp = (fun (pat,(e,e')) -> (Pat_exp (pat,e), Pat_exp (pat,e'))) - ; pat_when = (fun (pat,(e1,e1'),(e2,e2')) -> (Pat_when (pat,e1,e2), Pat_when (pat,e1',e2'))) - ; pat_aux = (fun ((pexp,pexp'),a) -> (Pat_aux (pexp,a), Pat_aux (pexp',a))) - ; lB_val = (fun (pat,(e,e')) -> (LB_val (pat,e), LB_val (pat,e'))) - ; lB_aux = (fun ((lb,lb'),annot) -> (LB_aux (lb,annot), LB_aux (lb',annot))) - ; pat_alg = id_pat_alg - } in - - let rewrite_sizeof_fun params_map - (FD_aux (FD_function (rec_opt,tannot,eff,funcls),((l,_) as annot))) = - let rewrite_funcl_body (FCL_aux (FCL_Funcl (id,pat,exp), annot)) (funcls,nvars) = - let body_env = env_of exp in - let body_typ = typ_of exp in - let nmap = nexps_from_params pat in - (* first rewrite calls to other functions... *) - let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in - (* ... then rewrite sizeof expressions in current function body *) - let exp'' = fold_exp { id_exp_alg with e_sizeof = e_sizeof nmap } exp' in - (FCL_aux (FCL_Funcl (id,pat,exp''), annot) :: funcls, - KidSet.union nvars (sizeof_frees exp'')) in - let (funcls, nvars) = List.fold_right rewrite_funcl_body funcls ([], KidSet.empty) in - (* Add a parameter for each remaining free type-level variable in a - sizeof expression *) - let kid_typ kid = atom_typ (nvar kid) in - let kid_annot kid = simple_annot l (kid_typ kid) in - let kid_pat kid = - P_aux (P_typ (kid_typ kid, - P_aux (P_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)), - kid_annot kid)), kid_annot kid) in - let kid_eaux kid = E_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)) in - let kid_typs = List.map kid_typ (KidSet.elements nvars) in - let kid_pats = List.map kid_pat (KidSet.elements nvars) in - let kid_nmap = List.map (fun kid -> (nvar kid, kid_eaux kid)) (KidSet.elements nvars) in - let rewrite_funcl_params (FCL_aux (FCL_Funcl (id, pat, exp), annot) as funcl) = - let rec rewrite_pat (P_aux (pat, ((l, _) as pannot)) as paux) = - let penv = env_of_annot pannot in - let peff = effect_of_annot (snd pannot) in - if KidSet.is_empty nvars then paux else - match pat_typ_of paux with - | Typ_aux (Typ_tup typs, _) -> - let ptyp' = Typ_aux (Typ_tup (kid_typs @ typs), l) in - (match pat with - | P_tup pats -> - P_aux (P_tup (kid_pats @ pats), (l, Some (penv, ptyp', peff))) - | P_wild -> P_aux (pat, (l, Some (penv, ptyp', peff))) - | P_typ (Typ_aux (Typ_tup typs, l), pat) -> - P_aux (P_typ (Typ_aux (Typ_tup (kid_typs @ typs), l), - rewrite_pat pat), (l, Some (penv, ptyp', peff))) - | P_as (_, id) | P_id id -> - (* adding parameters here would change the type of id; - we should remove the P_as/P_id here and add a let-binding to the body *) - raise (Reporting_basic.err_todo l - "rewriting as- or id-patterns for sizeof expressions not yet implemented") - | _ -> - raise (Reporting_basic.err_unreachable l - "unexpected pattern while rewriting function parameters for sizeof expressions")) - | ptyp -> - let ptyp' = Typ_aux (Typ_tup (kid_typs @ [ptyp]), l) in - P_aux (P_tup (kid_pats @ [paux]), (l, Some (penv, ptyp', peff))) in - let exp' = fold_exp { id_exp_alg with e_sizeof = e_sizeof kid_nmap } exp in - FCL_aux (FCL_Funcl (id, rewrite_pat pat, exp'), annot) in - let funcls = List.map rewrite_funcl_params funcls in - (nvars, FD_aux (FD_function (rec_opt,tannot,eff,funcls),annot)) in - - let rewrite_sizeof_def (params_map, defs) = function - | DEF_fundef fd as def -> - let (nvars, fd') = rewrite_sizeof_fun params_map fd in - let id = id_of_fundef fd in - let params_map' = - if KidSet.is_empty nvars then params_map - else Bindings.add id nvars params_map in - (params_map', defs @ [DEF_fundef fd']) - | DEF_val (LB_aux (lb, annot)) -> - begin - let lb' = match lb with - | LB_val (pat, exp) -> - let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in - LB_val (pat, exp') in - (params_map, defs @ [DEF_val (LB_aux (lb', annot))]) - end - | def -> - (params_map, defs @ [def]) in - - let rewrite_sizeof_valspec params_map def = - let rewrite_typschm (TypSchm_aux (TypSchm_ts (tq, typ), l) as ts) id = - if Bindings.mem id params_map then - let kid_typs = List.map (fun kid -> atom_typ (nvar kid)) - (KidSet.elements (Bindings.find id params_map)) in - let typ' = match typ with - | Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) -> - let vtyp_arg' = begin - match vtyp_arg with - | Typ_aux (Typ_tup typs, vl) -> - Typ_aux (Typ_tup (kid_typs @ typs), vl) - | _ -> Typ_aux (Typ_tup (kid_typs @ [vtyp_arg]), vl) - end in - Typ_aux (Typ_fn (vtyp_arg', vtyp_ret, declared_eff), vl) - | _ -> - raise (Reporting_basic.err_typ l "val spec with non-function type") in - TypSchm_aux (TypSchm_ts (tq, typ'), l) - else ts in - match def with - | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext, is_cast), a)) -> - DEF_spec (VS_aux (VS_val_spec (rewrite_typschm typschm id, id, ext, is_cast), a)) - | def -> def - in - - let (params_map, defs) = List.fold_left rewrite_sizeof_def - (Bindings.empty, []) defs in - let defs = List.map (rewrite_sizeof_valspec params_map) defs in - Defs defs - (* FIXME: Won't re-check due to flow typing and E_constraint re-write before E_sizeof re-write. - Requires the typechecker to be more smart about different representations for valid flow typing constraints. - fst (check initial_env (Defs defs)) - *) - -let remove_vector_concat_pat pat = - - (* ivc: bool that indicates whether the exp is in a vector_concat pattern *) - let remove_typed_patterns = - fold_pat { id_pat_alg with - p_aux = (function - | (P_typ (_,P_aux (p,_)),annot) - | (p,annot) -> - P_aux (p,annot) - ) - } in - - (* let pat = remove_typed_patterns pat in *) - - let fresh_id_v = fresh_id "v__" in - - (* expects that P_typ elements have been removed from AST, - that the length of all vectors involved is known, - that we don't have indexed vectors *) - - (* introduce names for all patterns of form P_vector_concat *) - let name_vector_concat_roots = - { p_lit = (fun lit -> P_lit lit) - ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) (* cannot happen *) - ; p_wild = P_wild - ; p_as = (fun (pat,id) -> P_as (pat true,id)) - ; p_id = (fun id -> P_id id) - ; p_var = (fun (pat,kid) -> P_var (pat true,kid)) - ; p_app = (fun (id,ps) -> P_app (id, List.map (fun p -> p false) ps)) - ; p_record = (fun (fpats,b) -> P_record (fpats, b)) - ; p_vector = (fun ps -> P_vector (List.map (fun p -> p false) ps)) - ; p_vector_concat = (fun ps -> P_vector_concat (List.map (fun p -> p false) ps)) - ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) - ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) - ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) - ; p_aux = - (fun (pat,((l,_) as annot)) contained_in_p_as -> - match pat with - | P_vector_concat pats -> - (if contained_in_p_as - then P_aux (pat,annot) - else P_aux (P_as (P_aux (pat,annot),fresh_id_v l),annot)) - | _ -> P_aux (pat,annot) - ) - ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) - ; fP_Fpat = (fun (id,p) -> FP_Fpat (id,p false)) - } in - - let pat = (fold_pat name_vector_concat_roots pat) false in - - (* introduce names for all unnamed child nodes of P_vector_concat *) - let name_vector_concat_elements = - let p_vector_concat pats = - let rec aux ((P_aux (p,((l,_) as a))) as pat) = match p with - | P_vector _ -> P_aux (P_as (pat,fresh_id_v l),a) - | P_id id -> P_aux (P_id id,a) - | P_as (p,id) -> P_aux (P_as (p,id),a) - | P_typ (typ, pat) -> P_aux (P_typ (typ, aux pat),a) - | P_wild -> P_aux (P_wild,a) - | _ -> - raise - (Reporting_basic.err_unreachable - l "name_vector_concat_elements: Non-vector in vector-concat pattern") in - P_vector_concat (List.map aux pats) in - {id_pat_alg with p_vector_concat = p_vector_concat} in - - let pat = fold_pat name_vector_concat_elements pat in - - - - let rec tag_last = function - | x :: xs -> let is_last = xs = [] in (x,is_last) :: tag_last xs - | _ -> [] in - - (* remove names from vectors in vector_concat patterns and collect them as declarations for the - function body or expression *) - let unname_vector_concat_elements = (* : - ('a, - 'a pat * ((tannot exp -> tannot exp) list), - 'a pat_aux * ((tannot exp -> tannot exp) list), - 'a fpat * ((tannot exp -> tannot exp) list), - 'a fpat_aux * ((tannot exp -> tannot exp) list)) - pat_alg = *) - - (* build a let-expression of the form "let child = root[i..j] in body" *) - let letbind_vec typ_opt (rootid,rannot) (child,cannot) (i,j) = - let (l,_) = cannot in - let env = env_of_annot rannot in - let rootname = string_of_id rootid in - let childname = string_of_id child in - - let root = E_aux (E_id rootid, rannot) in - let index_i = simple_num l i in - let index_j = simple_num l j in - - (* FIXME *) - let subv = fix_eff_exp (E_aux (E_vector_subrange (root, index_i, index_j), cannot)) in - (* let (_, _, ord, _) = vector_typ_args_of (Env.base_typ_of (env_of root) (typ_of root)) in - let subrange_id = if is_order_inc ord then "bitvector_subrange_inc" else "bitvector_subrange_dec" in - let subv = fix_eff_exp (E_aux (E_app (mk_id subrange_id, [root; index_i; index_j]), cannot)) in *) - - let id_pat = - match typ_opt with - | Some typ -> P_aux (P_typ (typ, P_aux (P_id child,cannot)), cannot) - | None -> P_aux (P_id child,cannot) in - let letbind = fix_eff_lb (LB_aux (LB_val (id_pat,subv),cannot)) in - (letbind, - (fun body -> fix_eff_exp (annot_exp (E_let (letbind,body)) l env (typ_of body))), - (rootname,childname)) in - - let p_aux = function - | ((P_as (P_aux (P_vector_concat pats,rannot'),rootid),decls),rannot) -> - let rtyp = Env.base_typ_of (env_of_annot rannot') (typ_of_annot rannot') in - let (start,last_idx) = (match vector_typ_args_of rtyp with - | (Nexp_aux (Nexp_constant start,_), Nexp_aux (Nexp_constant length,_), ord, _) -> - (start, if is_order_inc ord - then sub_big_int (add_big_int start length) unit_big_int - else add_big_int (sub_big_int start length) unit_big_int) - | _ -> - raise (Reporting_basic.err_unreachable (fst rannot') - ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern"))) in - let rec aux typ_opt (pos,pat_acc,decl_acc) (P_aux (p,cannot),is_last) = - let ctyp = Env.base_typ_of (env_of_annot cannot) (typ_of_annot cannot) in - let (_,length,ord,_) = vector_typ_args_of ctyp in - let (pos',index_j) = match length with - | Nexp_aux (Nexp_constant i,_) -> - if is_order_inc ord - then (add_big_int pos i, sub_big_int (add_big_int pos i) unit_big_int) - else (sub_big_int pos i, add_big_int (sub_big_int pos i) unit_big_int) - | Nexp_aux (_,l) -> - if is_last then (pos,last_idx) - else - raise - (Reporting_basic.err_unreachable - l ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern")) in - (match p with - (* if we see a named vector pattern, remove the name and remember to - declare it later *) - | P_as (P_aux (p,cannot),cname) -> - let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in - (pos', pat_acc @ [P_aux (p,cannot)], decl_acc @ [((lb,decl),info)]) - (* if we see a P_id variable, remember to declare it later *) - | P_id cname -> - let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in - (pos', pat_acc @ [P_aux (P_id cname,cannot)], decl_acc @ [((lb,decl),info)]) - | P_typ (typ, pat) -> aux (Some typ) (pos,pat_acc,decl_acc) (pat, is_last) - (* normal vector patterns are fine *) - | _ -> (pos', pat_acc @ [P_aux (p,cannot)],decl_acc)) in - let pats_tagged = tag_last pats in - let (_,pats',decls') = List.fold_left (aux None) (start,[],[]) pats_tagged in - - (* abuse P_vector_concat as a P_vector_const pattern: it has the of - patterns as an argument but they're meant to be consed together *) - (P_aux (P_as (P_aux (P_vector_concat pats',rannot'),rootid),rannot), decls @ decls') - | ((p,decls),annot) -> (P_aux (p,annot),decls) in - - { p_lit = (fun lit -> (P_lit lit,[])) - ; p_wild = (P_wild,[]) - ; p_as = (fun ((pat,decls),id) -> (P_as (pat,id),decls)) - ; p_typ = (fun (typ,(pat,decls)) -> (P_typ (typ,pat),decls)) - ; p_id = (fun id -> (P_id id,[])) - ; p_var = (fun ((pat,decls),kid) -> (P_var (pat,kid),decls)) - ; p_app = (fun (id,ps) -> let (ps,decls) = List.split ps in - (P_app (id,ps),List.flatten decls)) - ; p_record = (fun (ps,b) -> let (ps,decls) = List.split ps in - (P_record (ps,b),List.flatten decls)) - ; p_vector = (fun ps -> let (ps,decls) = List.split ps in - (P_vector ps,List.flatten decls)) - ; p_vector_concat = (fun ps -> let (ps,decls) = List.split ps in - (P_vector_concat ps,List.flatten decls)) - ; p_tup = (fun ps -> let (ps,decls) = List.split ps in - (P_tup ps,List.flatten decls)) - ; p_list = (fun ps -> let (ps,decls) = List.split ps in - (P_list ps,List.flatten decls)) - ; p_cons = (fun ((p,decls),(p',decls')) -> (P_cons (p,p'), decls @ decls')) - ; p_aux = (fun ((pat,decls),annot) -> p_aux ((pat,decls),annot)) - ; fP_aux = (fun ((fpat,decls),annot) -> (FP_aux (fpat,annot),decls)) - ; fP_Fpat = (fun (id,(pat,decls)) -> (FP_Fpat (id,pat),decls)) - } in - - let (pat,decls) = fold_pat unname_vector_concat_elements pat in - - let decls = - let module S = Set.Make(String) in - - let roots_needed = - List.fold_right - (fun (_,(rootid,childid)) roots_needed -> - if S.mem childid roots_needed then - (* let _ = print_endline rootid in *) - S.add rootid roots_needed - else if String.length childid >= 3 && String.sub childid 0 2 = String.sub "v__" 0 2 then - roots_needed - else - S.add rootid roots_needed - ) decls S.empty in - List.filter - (fun (_,(_,childid)) -> - S.mem childid roots_needed || - String.length childid < 3 || - not (String.sub childid 0 2 = String.sub "v__" 0 2)) - decls in - - let (letbinds,decls) = - let (decls,_) = List.split decls in - List.split decls in - - let decls = List.fold_left (fun f g x -> f (g x)) (fun b -> b) decls in - - - (* at this point shouldn't have P_as patterns in P_vector_concat patterns any more, - all P_as and P_id vectors should have their declarations in decls. - Now flatten all vector_concat patterns *) - - let flatten = - let p_vector_concat ps = - let aux p acc = match p with - | (P_aux (P_vector_concat pats,_)) -> pats @ acc - | pat -> pat :: acc in - P_vector_concat (List.fold_right aux ps []) in - {id_pat_alg with p_vector_concat = p_vector_concat} in - - let pat = fold_pat flatten pat in - - (* at this point pat should be a flat pattern: no vector_concat patterns - with vector_concats patterns as direct child-nodes anymore *) - - let range a b = - let rec aux a b = if gt_big_int a b then [] else a :: aux (add_big_int a unit_big_int) b in - if gt_big_int a b then List.rev (aux b a) else aux a b in - - let remove_vector_concats = - let p_vector_concat ps = - let aux acc (P_aux (p,annot),is_last) = - let env = env_of_annot annot in - let typ = Env.base_typ_of env (typ_of_annot annot) in - let eff = effect_of_annot (snd annot) in - let (l,_) = annot in - let wild _ = P_aux (P_wild,(gen_loc l, Some (env, bit_typ, eff))) in - if is_vector_typ typ then - match p, vector_typ_args_of typ with - | P_vector ps,_ -> acc @ ps - | _, (_,Nexp_aux (Nexp_constant length,_),_,_) -> - acc @ (List.map wild (range zero_big_int (sub_big_int length unit_big_int))) - | _, _ -> - (*if is_last then*) acc @ [wild zero_big_int] - else raise - (Reporting_basic.err_unreachable l - ("remove_vector_concats: Non-vector in vector-concat pattern " ^ - string_of_typ (typ_of_annot annot))) in - - let has_length (P_aux (p,annot)) = - let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in - match vector_typ_args_of typ with - | (_,Nexp_aux (Nexp_constant length,_),_,_) -> true - | _ -> false in - - let ps_tagged = tag_last ps in - let ps' = List.fold_left aux [] ps_tagged in - let last_has_length ps = List.exists (fun (p,b) -> b && has_length p) ps_tagged in - - if last_has_length ps then - P_vector ps' - else - (* If the last vector pattern in the vector_concat pattern has unknown - length we misuse the P_vector_concat constructor's argument to place in - the following way: P_vector_concat [x;y; ... ;z] should be mapped to the - pattern-match x :: y :: .. z, i.e. if x : 'a, then z : vector 'a. *) - P_vector_concat ps' in - - {id_pat_alg with p_vector_concat = p_vector_concat} in - - let pat = fold_pat remove_vector_concats pat in - - (pat,letbinds,decls) - -(* assumes there are no more E_internal expressions *) -let rewrite_exp_remove_vector_concat_pat rewriters (E_aux (exp,(l,annot)) as full_exp) = - let rewrap e = E_aux (e,(l,annot)) in - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - match exp with - | E_case (e,ps) -> - let aux = function - | (Pat_aux (Pat_exp (pat,body),annot')) -> - let (pat,_,decls) = remove_vector_concat_pat pat in - Pat_aux (Pat_exp (pat, decls (rewrite_rec body)),annot') - | (Pat_aux (Pat_when (pat,guard,body),annot')) -> - let (pat,_,decls) = remove_vector_concat_pat pat in - Pat_aux (Pat_when (pat, decls (rewrite_rec guard), decls (rewrite_rec body)),annot') in - rewrap (E_case (rewrite_rec e, List.map aux ps)) - | E_let (LB_aux (LB_val (pat,v),annot'),body) -> - let (pat,_,decls) = remove_vector_concat_pat pat in - rewrap (E_let (LB_aux (LB_val (pat,rewrite_rec v),annot'), - decls (rewrite_rec body))) - | exp -> rewrite_base full_exp - -let rewrite_fun_remove_vector_concat_pat - rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = - let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),(l,annot))) = - let (pat',_,decls) = remove_vector_concat_pat pat in - let exp' = decls (rewriters.rewrite_exp rewriters exp) in - (FCL_aux (FCL_Funcl (id,pat',exp'),(l,annot))) - in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) - -let rewrite_defs_remove_vector_concat (Defs defs) = - let rewriters = - {rewrite_exp = rewrite_exp_remove_vector_concat_pat; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; - rewrite_lexp = rewrite_lexp; - rewrite_fun = rewrite_fun_remove_vector_concat_pat; - rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base} in - let rewrite_def d = - let d = rewriters.rewrite_def rewriters d in - match d with - | DEF_val (LB_aux (LB_val (pat,exp),a)) -> - let (pat,letbinds,_) = remove_vector_concat_pat pat in - let defvals = List.map (fun lb -> DEF_val lb) letbinds in - [DEF_val (LB_aux (LB_val (pat,exp),a))] @ defvals - | d -> [d] in - Defs (List.flatten (List.map rewrite_def defs)) - -(* A few helper functions for rewriting guarded pattern clauses. - Used both by the rewriting of P_when and separately by the rewriting of - bitvectors in parameter patterns of function clauses *) - -let remove_wildcards pre (P_aux (_,(l,_)) as pat) = - fold_pat - {id_pat_alg with - p_aux = function - | (P_wild,(l,annot)) -> P_aux (P_id (fresh_id pre l),(l,annot)) - | (p,annot) -> P_aux (p,annot) } - pat - -(* Check if one pattern subsumes the other, and if so, calculate a - substitution of variables that are used in the same position. - TODO: Check somewhere that there are no variable clashes (the same variable - name used in different positions of the patterns) - *) -let rec subsumes_pat (P_aux (p1,annot1) as pat1) (P_aux (p2,annot2) as pat2) = - let rewrap p = P_aux (p,annot1) in - let subsumes_list s pats1 pats2 = - if List.length pats1 = List.length pats2 - then - let subs = List.map2 s pats1 pats2 in - List.fold_right - (fun p acc -> match p, acc with - | Some subst, Some substs -> Some (subst @ substs) - | _ -> None) - subs (Some []) - else None in - match p1, p2 with - | P_lit (L_aux (lit1,_)), P_lit (L_aux (lit2,_)) -> - if lit1 = lit2 then Some [] else None - | P_as (pat1,_), _ -> subsumes_pat pat1 pat2 - | _, P_as (pat2,_) -> subsumes_pat pat1 pat2 - | P_typ (_,pat1), _ -> subsumes_pat pat1 pat2 - | _, P_typ (_,pat2) -> subsumes_pat pat1 pat2 - | P_id (Id_aux (id1,_) as aid1), P_id (Id_aux (id2,_) as aid2) -> - if id1 = id2 then Some [] - else if Env.lookup_id aid1 (env_of_annot annot1) = Unbound && - Env.lookup_id aid2 (env_of_annot annot2) = Unbound - then Some [(id2,id1)] else None - | P_id id1, _ -> - if Env.lookup_id id1 (env_of_annot annot1) = Unbound then Some [] else None - | P_wild, _ -> Some [] - | P_app (Id_aux (id1,l1),args1), P_app (Id_aux (id2,_),args2) -> - if id1 = id2 then subsumes_list subsumes_pat args1 args2 else None - | P_record (fps1,b1), P_record (fps2,b2) -> - if b1 = b2 then subsumes_list subsumes_fpat fps1 fps2 else None - | P_vector pats1, P_vector pats2 - | P_vector_concat pats1, P_vector_concat pats2 - | P_tup pats1, P_tup pats2 - | P_list pats1, P_list pats2 -> - subsumes_list subsumes_pat pats1 pats2 - | P_list (pat1 :: pats1), P_cons _ -> - subsumes_pat (rewrap (P_cons (pat1, rewrap (P_list pats1)))) pat2 - | P_cons _, P_list (pat2 :: pats2)-> - subsumes_pat pat1 (rewrap (P_cons (pat2, rewrap (P_list pats2)))) - | P_cons (pat1, pats1), P_cons (pat2, pats2) -> - (match subsumes_pat pat1 pat2, subsumes_pat pats1 pats2 with - | Some substs1, Some substs2 -> Some (substs1 @ substs2) - | _ -> None) - | _ -> None -and subsumes_fpat (FP_aux (FP_Fpat (id1,pat1),_)) (FP_aux (FP_Fpat (id2,pat2),_)) = - if id1 = id2 then subsumes_pat pat1 pat2 else None - -let equiv_pats pat1 pat2 = - match subsumes_pat pat1 pat2, subsumes_pat pat2 pat1 with - | Some _, Some _ -> true - | _, _ -> false - -let subst_id_pat pat (id1,id2) = - let p_id (Id_aux (id,l)) = (if id = id1 then P_id (Id_aux (id2,l)) else P_id (Id_aux (id,l))) in - fold_pat {id_pat_alg with p_id = p_id} pat - -let subst_id_exp exp (id1,id2) = - (* TODO Don't substitute bound occurrences inside let expressions etc *) - let e_id (Id_aux (id,l)) = (if id = id1 then E_id (Id_aux (id2,l)) else E_id (Id_aux (id,l))) in - fold_exp {id_exp_alg with e_id = e_id} exp - -let rec pat_to_exp (P_aux (pat,(l,annot))) = - let rewrap e = E_aux (e,(l,annot)) in - match pat with - | P_lit lit -> rewrap (E_lit lit) - | P_wild -> raise (Reporting_basic.err_unreachable l - "pat_to_exp given wildcard pattern") - | P_as (pat,id) -> rewrap (E_id id) - | P_typ (_,pat) -> pat_to_exp pat - | P_id id -> rewrap (E_id id) - | P_app (id,pats) -> rewrap (E_app (id, List.map pat_to_exp pats)) - | P_record (fpats,b) -> - rewrap (E_record (FES_aux (FES_Fexps (List.map fpat_to_fexp fpats,b),(l,annot)))) - | P_vector pats -> rewrap (E_vector (List.map pat_to_exp pats)) - | P_vector_concat pats -> raise (Reporting_basic.err_unreachable l - "pat_to_exp not implemented for P_vector_concat") - (* We assume that vector concatenation patterns have been transformed - away already *) - | P_tup pats -> rewrap (E_tuple (List.map pat_to_exp pats)) - | P_list pats -> rewrap (E_list (List.map pat_to_exp pats)) - | P_cons (p,ps) -> rewrap (E_cons (pat_to_exp p, pat_to_exp ps)) -and fpat_to_fexp (FP_aux (FP_Fpat (id,pat),(l,annot))) = - FE_aux (FE_Fexp (id, pat_to_exp pat),(l,annot)) - -let case_exp e t cs = - let l = get_loc_exp e in - let env = env_of e in - let annot = (get_loc_exp e, Some (env_of e, t, no_effect)) in - match cs with - | [(P_aux (P_id id, pannot) as pat, body, _)] -> - fix_eff_exp (annot_exp (E_let (LB_aux (LB_val (pat, e), pannot), body)) l env t) - | _ -> - let pexp (pat,body,annot) = Pat_aux (Pat_exp (pat,body),annot) in - let ps = List.map pexp cs in - (* let efr = union_effs (List.map effect_of_pexp ps) in *) - fix_eff_exp (annot_exp (E_case (e,ps)) l env t) - -let rewrite_guarded_clauses l cs = - let rec group clauses = - let add_clause (pat,cls,annot) c = (pat,cls @ [c],annot) in - let rec group_aux current acc = (function - | ((pat,guard,body,annot) as c) :: cs -> - let (current_pat,_,_) = current in - (match subsumes_pat current_pat pat with - | Some substs -> - let pat' = List.fold_left subst_id_pat pat substs in - let guard' = (match guard with - | Some exp -> Some (List.fold_left subst_id_exp exp substs) - | None -> None) in - let body' = List.fold_left subst_id_exp body substs in - let c' = (pat',guard',body',annot) in - group_aux (add_clause current c') acc cs - | None -> - let pat = remove_wildcards "g__" pat in - group_aux (pat,[c],annot) (acc @ [current]) cs) - | [] -> acc @ [current]) in - let groups = match clauses with - | ((pat,guard,body,annot) as c) :: cs -> - group_aux (remove_wildcards "g__" pat, [c], annot) [] cs - | _ -> - raise (Reporting_basic.err_unreachable l - "group given empty list in rewrite_guarded_clauses") in - List.map (fun cs -> if_pexp cs) groups - and if_pexp (pat,cs,annot) = (match cs with - | c :: _ -> - (* fix_eff_pexp (pexp *) - let body = if_exp pat cs in - let pexp = fix_eff_pexp (Pat_aux (Pat_exp (pat,body),annot)) in - let (Pat_aux (_,annot)) = pexp in - (pat, body, annot) - | [] -> - raise (Reporting_basic.err_unreachable l - "if_pexp given empty list in rewrite_guarded_clauses")) - and if_exp current_pat = (function - | (pat,guard,body,annot) :: ((pat',guard',body',annot') as c') :: cs -> - (match guard with - | Some exp -> - let else_exp = - if equiv_pats current_pat pat' - then if_exp current_pat (c' :: cs) - else case_exp (pat_to_exp current_pat) (typ_of body') (group (c' :: cs)) in - fix_eff_exp (annot_exp (E_if (exp,body,else_exp)) (fst annot) (env_of exp) (typ_of body)) - | None -> body) - | [(pat,guard,body,annot)] -> body - | [] -> - raise (Reporting_basic.err_unreachable l - "if_exp given empty list in rewrite_guarded_clauses")) in - group cs - -let bitwise_and_exp exp1 exp2 = - let (E_aux (_,(l,_))) = exp1 in - let andid = Id_aux (Id "and_bool", gen_loc l) in - annot_exp (E_app(andid,[exp1;exp2])) l (env_of exp1) bool_typ - -let rec contains_bitvector_pat (P_aux (pat,annot)) = match pat with -| P_lit _ | P_wild | P_id _ -> false -| P_as (pat,_) | P_typ (_,pat) -> contains_bitvector_pat pat -| P_vector _ | P_vector_concat _ -> - let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in - is_bitvector_typ typ -| P_app (_,pats) | P_tup pats | P_list pats -> - List.exists contains_bitvector_pat pats -| P_cons (p,ps) -> contains_bitvector_pat p || contains_bitvector_pat ps -| P_record (fpats,_) -> - List.exists (fun (FP_aux (FP_Fpat (_,pat),_)) -> contains_bitvector_pat pat) fpats - -let contains_bitvector_pexp = function -| Pat_aux (Pat_exp (pat,_),_) | Pat_aux (Pat_when (pat,_,_),_) -> - contains_bitvector_pat pat - -(* Rewrite bitvector patterns to guarded patterns *) - -let remove_bitvector_pat pat = - - let env = try pat_env_of pat with _ -> Env.empty in - - (* first introduce names for bitvector patterns *) - let name_bitvector_roots = - { p_lit = (fun lit -> P_lit lit) - ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) - ; p_wild = P_wild - ; p_as = (fun (pat,id) -> P_as (pat true,id)) - ; p_id = (fun id -> P_id id) - ; p_var = (fun (pat,kid) -> P_var (pat true,kid)) - ; p_app = (fun (id,ps) -> P_app (id, List.map (fun p -> p false) ps)) - ; p_record = (fun (fpats,b) -> P_record (fpats, b)) - ; p_vector = (fun ps -> P_vector (List.map (fun p -> p false) ps)) - ; p_vector_concat = (fun ps -> P_vector_concat (List.map (fun p -> p false) ps)) - ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) - ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) - ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) - ; p_aux = - (fun (pat,annot) contained_in_p_as -> - let env = env_of_annot annot in - let t = Env.base_typ_of env (typ_of_annot annot) in - let (l,_) = annot in - match pat, is_bitvector_typ t, contained_in_p_as with - | P_vector _, true, false -> - P_aux (P_as (P_aux (pat,annot),fresh_id "b__" l), annot) - | _ -> P_aux (pat,annot) - ) - ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) - ; fP_Fpat = (fun (id,p) -> FP_Fpat (id,p false)) - } in - let pat = (fold_pat name_bitvector_roots pat) false in - - (* Then collect guard expressions testing whether the literal bits of a - bitvector pattern match those of a given bitvector, and collect let - bindings for the bits bound by P_id or P_as patterns *) - - (* Helper functions for generating guard expressions *) - let access_bit_exp rootid l typ idx = - let root = annot_exp (E_id rootid) l env typ in - (* FIXME *) - annot_exp (E_vector_access (root, simple_num l idx)) l env bit_typ in - (*let env = env_of_annot rannot in - let t = Env.base_typ_of env (typ_of_annot rannot) in - let (_, _, ord, _) = vector_typ_args_of t in - let access_id = if is_order_inc ord then "bitvector_access_inc" else "bitvector_access_dec" in - E_aux (E_app (mk_id access_id, [root; simple_num l idx]), simple_annot l bit_typ) in*) - - let test_bit_exp rootid l typ idx exp = - let rannot = (l, Some (env_of exp, typ, no_effect)) in - let elem = access_bit_exp rootid l typ idx in - Some (annot_exp (E_app (mk_id "eq", [elem; exp])) l env bool_typ) in - - let test_subvec_exp rootid l typ i j lits = - let (start, length, ord, _) = vector_typ_args_of typ in - let length' = nint (List.length lits) in - let start' = - if is_order_inc ord then nint 0 - else nminus length' (nint 1) in - let typ' = vector_typ start' length' ord bit_typ in - let subvec_exp = - match start, length with - | Nexp_aux (Nexp_constant s, _), Nexp_aux (Nexp_constant l, _) - when eq_big_int s i && eq_big_int l (big_int_of_int (List.length lits)) -> - E_id rootid - | _ -> - (*if vec_start t = i && vec_length t = List.length lits - then E_id rootid - else*) - E_vector_subrange ( - annot_exp (E_id rootid) l env typ, - simple_num l i, - simple_num l j) in - (* let subrange_id = if is_order_inc ord then "bitvector_subrange_inc" else "bitvector_subrange_dec" in - E_app (mk_id subrange_id, [E_aux (E_id rootid, simple_annot l typ); simple_num l i; simple_num l j]) in *) - annot_exp (E_app( - Id_aux (Id "eq_vec", gen_loc l), - [annot_exp subvec_exp l env typ'; - annot_exp (E_vector lits) l env typ'])) l env bool_typ in - - let letbind_bit_exp rootid l typ idx id = - let rannot = simple_annot l typ in - let elem = access_bit_exp rootid l typ idx in - let e = annot_pat (P_id id) l env bit_typ in - let letbind = LB_aux (LB_val (e,elem), (l, Some (env, bit_typ, no_effect))) in - let letexp = (fun body -> - let (E_aux (_,(_,bannot))) = body in - annot_exp (E_let (letbind,body)) l env (typ_of body)) in - (letexp, letbind) in - - let compose_guards guards = - let conj g1 g2 = match g1, g2 with - | Some g1, Some g2 -> Some (bitwise_and_exp g1 g2) - | Some g1, None -> Some g1 - | None, Some g2 -> Some g2 - | None, None -> None in - List.fold_right conj guards None in - - let flatten_guards_decls gd = - let (guards,decls,letbinds) = Util.split3 gd in - (compose_guards guards, (List.fold_right (@@) decls), List.flatten letbinds) in - - (* Collect guards and let bindings *) - let guard_bitvector_pat = - let collect_guards_decls ps rootid t = - let (start,_,ord,_) = vector_typ_args_of t in - let rec collect current (guards,dls) idx ps = - let idx' = if is_order_inc ord then add_big_int idx unit_big_int else sub_big_int idx unit_big_int in - (match ps with - | pat :: ps' -> - (match pat with - | P_aux (P_lit lit, (l,annot)) -> - let e = E_aux (E_lit lit, (gen_loc l, annot)) in - let current' = (match current with - | Some (l,i,j,lits) -> Some (l,i,idx,lits @ [e]) - | None -> Some (l,idx,idx,[e])) in - collect current' (guards, dls) idx' ps' - | P_aux (P_as (pat',id), (l,annot)) -> - let dl = letbind_bit_exp rootid l t idx id in - collect current (guards, dls @ [dl]) idx (pat' :: ps') - | _ -> - let dls' = (match pat with - | P_aux (P_id id, (l,annot)) -> - dls @ [letbind_bit_exp rootid l t idx id] - | _ -> dls) in - let guards' = (match current with - | Some (l,i,j,lits) -> - guards @ [Some (test_subvec_exp rootid l t i j lits)] - | None -> guards) in - collect None (guards', dls') idx' ps') - | [] -> - let guards' = (match current with - | Some (l,i,j,lits) -> - guards @ [Some (test_subvec_exp rootid l t i j lits)] - | None -> guards) in - (guards',dls)) in - let (guards,dls) = match start with - | Nexp_aux (Nexp_constant s, _) -> - collect None ([],[]) s ps - | _ -> - let (P_aux (_, (l,_))) = pat in - raise (Reporting_basic.err_unreachable l - "guard_bitvector_pat called on pattern with non-constant start index") in - let (decls,letbinds) = List.split dls in - (compose_guards guards, List.fold_right (@@) decls, letbinds) in - - let collect_guards_decls_indexed ips rootid t = - let rec guard_decl (idx,pat) = (match pat with - | P_aux (P_lit lit, (l,annot)) -> - let exp = E_aux (E_lit lit, (l,annot)) in - (test_bit_exp rootid l t idx exp, (fun b -> b), []) - | P_aux (P_as (pat',id), (l,annot)) -> - let (guard,decls,letbinds) = guard_decl (idx,pat') in - let (letexp,letbind) = letbind_bit_exp rootid l t idx id in - (guard, decls >> letexp, letbind :: letbinds) - | P_aux (P_id id, (l,annot)) -> - let (letexp,letbind) = letbind_bit_exp rootid l t idx id in - (None, letexp, [letbind]) - | _ -> (None, (fun b -> b), [])) in - let (guards,decls,letbinds) = Util.split3 (List.map guard_decl ips) in - (compose_guards guards, List.fold_right (@@) decls, List.flatten letbinds) in - - { p_lit = (fun lit -> (P_lit lit, (None, (fun b -> b), []))) - ; p_wild = (P_wild, (None, (fun b -> b), [])) - ; p_as = (fun ((pat,gdls),id) -> (P_as (pat,id), gdls)) - ; p_typ = (fun (typ,(pat,gdls)) -> (P_typ (typ,pat), gdls)) - ; p_id = (fun id -> (P_id id, (None, (fun b -> b), []))) - ; p_var = (fun ((pat,gdls),kid) -> (P_var (pat,kid), gdls)) - ; p_app = (fun (id,ps) -> let (ps,gdls) = List.split ps in - (P_app (id,ps), flatten_guards_decls gdls)) - ; p_record = (fun (ps,b) -> let (ps,gdls) = List.split ps in - (P_record (ps,b), flatten_guards_decls gdls)) - ; p_vector = (fun ps -> let (ps,gdls) = List.split ps in - (P_vector ps, flatten_guards_decls gdls)) - ; p_vector_concat = (fun ps -> let (ps,gdls) = List.split ps in - (P_vector_concat ps, flatten_guards_decls gdls)) - ; p_tup = (fun ps -> let (ps,gdls) = List.split ps in - (P_tup ps, flatten_guards_decls gdls)) - ; p_list = (fun ps -> let (ps,gdls) = List.split ps in - (P_list ps, flatten_guards_decls gdls)) - ; p_cons = (fun ((p,gdls),(p',gdls')) -> - (P_cons (p,p'), flatten_guards_decls [gdls;gdls'])) - ; p_aux = (fun ((pat,gdls),annot) -> - let env = env_of_annot annot in - let t = Env.base_typ_of env (typ_of_annot annot) in - (match pat, is_bitvector_typ t with - | P_as (P_aux (P_vector ps, _), id), true -> - (P_aux (P_id id, annot), collect_guards_decls ps id t) - | _, _ -> (P_aux (pat,annot), gdls))) - ; fP_aux = (fun ((fpat,gdls),annot) -> (FP_aux (fpat,annot), gdls)) - ; fP_Fpat = (fun (id,(pat,gdls)) -> (FP_Fpat (id,pat), gdls)) - } in - fold_pat guard_bitvector_pat pat - -let rewrite_exp_remove_bitvector_pat rewriters (E_aux (exp,(l,annot)) as full_exp) = - let rewrap e = E_aux (e,(l,annot)) in - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - match exp with - | E_case (e,ps) - when List.exists contains_bitvector_pexp ps -> - let rewrite_pexp = function - | Pat_aux (Pat_exp (pat,body),annot') -> - let (pat',(guard',decls,_)) = remove_bitvector_pat pat in - let body' = decls (rewrite_rec body) in - (match guard' with - | Some guard' -> Pat_aux (Pat_when (pat', guard', body'), annot') - | None -> Pat_aux (Pat_exp (pat', body'), annot')) - | Pat_aux (Pat_when (pat,guard,body),annot') -> - let (pat',(guard',decls,_)) = remove_bitvector_pat pat in - let body' = decls (rewrite_rec body) in - (match guard' with - | Some guard' -> Pat_aux (Pat_when (pat', bitwise_and_exp guard guard', body'), annot') - | None -> Pat_aux (Pat_when (pat', guard, body'), annot')) in - rewrap (E_case (e, List.map rewrite_pexp ps)) - | E_let (LB_aux (LB_val (pat,v),annot'),body) -> - let (pat,(_,decls,_)) = remove_bitvector_pat pat in - rewrap (E_let (LB_aux (LB_val (pat,rewrite_rec v),annot'), - decls (rewrite_rec body))) - | _ -> rewrite_base full_exp - -let rewrite_fun_remove_bitvector_pat - rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = - let _ = reset_fresh_name_counter () in - (* TODO Can there be clauses with different id's in one FD_function? *) - let funcls = match funcls with - | (FCL_aux (FCL_Funcl(id,_,_),_) :: _) -> - let clause (FCL_aux (FCL_Funcl(_,pat,exp),annot)) = - let (pat,(guard,decls,_)) = remove_bitvector_pat pat in - let exp = decls (rewriters.rewrite_exp rewriters exp) in - (pat,guard,exp,annot) in - let cs = rewrite_guarded_clauses l (List.map clause funcls) in - List.map (fun (pat,exp,annot) -> FCL_aux (FCL_Funcl(id,pat,exp),annot)) cs - | _ -> funcls (* TODO is the empty list possible here? *) in - FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot)) - -let rewrite_defs_remove_bitvector_pats (Defs defs) = - let rewriters = - {rewrite_exp = rewrite_exp_remove_bitvector_pat; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; - rewrite_lexp = rewrite_lexp; - rewrite_fun = rewrite_fun_remove_bitvector_pat; - rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base } in - let rewrite_def d = - let d = rewriters.rewrite_def rewriters d in - match d with - | DEF_val (LB_aux (LB_val (pat,exp),a)) -> - let (pat',(_,_,letbinds)) = remove_bitvector_pat pat in - let defvals = List.map (fun lb -> DEF_val lb) letbinds in - [DEF_val (LB_aux (LB_val (pat',exp),a))] @ defvals - | d -> [d] in - (* FIXME See above in rewrite_sizeof *) - (* fst (check initial_env ( *) - Defs (List.flatten (List.map rewrite_def defs)) - (* )) *) - - -(* Remove pattern guards by rewriting them to if-expressions within the - pattern expression. Shares code with the rewriting of bitvector patterns. *) -let rewrite_exp_guarded_pats rewriters (E_aux (exp,(l,annot)) as full_exp) = - let rewrap e = E_aux (e,(l,annot)) in - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - let is_guarded_pexp = function - | Pat_aux (Pat_when (_,_,_),_) -> true - | _ -> false in - match exp with - | E_case (e,ps) - when List.exists is_guarded_pexp ps -> - let clause = function - | Pat_aux (Pat_exp (pat, body), annot) -> - (pat, None, rewrite_rec body, annot) - | Pat_aux (Pat_when (pat, guard, body), annot) -> - (pat, Some guard, rewrite_rec body, annot) in - let clauses = rewrite_guarded_clauses l (List.map clause ps) in - if (effectful e) then - let e = rewrite_rec e in - let (E_aux (_,(el,eannot))) = e in - let pat_e' = fresh_id_pat "p__" (el, Some (env_of e, typ_of e, no_effect)) in - let exp_e' = pat_to_exp pat_e' in - let letbind_e = LB_aux (LB_val (pat_e',e), (el,eannot)) in - let exp' = case_exp exp_e' (typ_of full_exp) clauses in - rewrap (E_let (letbind_e, exp')) - else case_exp e (typ_of full_exp) clauses - | _ -> rewrite_base full_exp - -let rewrite_defs_guarded_pats = - rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp_guarded_pats } - - -let id_is_local_var id env = match Env.lookup_id id env with - | Local _ -> true - | _ -> false - -let rec lexp_is_local (LEXP_aux (lexp, _)) env = match lexp with - | LEXP_memory _ -> false - | LEXP_id id - | LEXP_cast (_, id) -> id_is_local_var id env - | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local lexp env) lexps - | LEXP_vector (lexp,_) - | LEXP_vector_range (lexp,_,_) - | LEXP_field (lexp,_) -> lexp_is_local lexp env - -let id_is_unbound id env = match Env.lookup_id id env with - | Unbound -> true - | _ -> false - -let rec lexp_is_local_intro (LEXP_aux (lexp, _)) env = match lexp with - | LEXP_memory _ -> false - | LEXP_id id - | LEXP_cast (_, id) -> id_is_unbound id env - | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local_intro lexp env) lexps - | LEXP_vector (lexp,_) - | LEXP_vector_range (lexp,_,_) - | LEXP_field (lexp,_) -> lexp_is_local_intro lexp env - -let lexp_is_effectful (LEXP_aux (_, (_, annot))) = match annot with - | Some (_, _, eff) -> effectful_effs eff - | _ -> false - -let rec rewrite_local_lexp ((LEXP_aux(lexp,((l,_) as annot))) as le) = - match lexp with - | LEXP_id _ | LEXP_cast (_, _) | LEXP_tup _ -> (le, (fun exp -> exp)) - | LEXP_vector (lexp, e) -> - let (lhs, rhs) = rewrite_local_lexp lexp in - (lhs, (fun exp -> rhs (E_aux (E_vector_update (lexp_to_exp lexp, e, exp), annot)))) - | LEXP_vector_range (lexp, e1, e2) -> - let (lhs, rhs) = rewrite_local_lexp lexp in - (lhs, (fun exp -> rhs (E_aux (E_vector_update_subrange (lexp_to_exp lexp, e1, e2, exp), annot)))) - | LEXP_field (lexp, id) -> - let (lhs, rhs) = rewrite_local_lexp lexp in - let (LEXP_aux (_, recannot)) = lexp in - let field_update exp = FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), annot)], false), annot) in - (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), recannot)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Unsupported lexp: " ^ string_of_lexp le)) - -(*Expects to be called after rewrite_defs; thus the following should not appear: - internal_exp of any form - lit vectors in patterns or expressions - *) -let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = - let rewrap e = E_aux (e,annot) in - let rewrap_effects e eff = - E_aux (e, (l,Some (env_of_annot annot, typ_of_annot annot, eff))) in - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - match exp with - | E_block exps -> - let rec walker exps = match exps with - | [] -> [] - | (E_aux(E_assign(le,e), ((l, Some (env,typ,eff)) as annot)) as exp)::exps - when lexp_is_local_intro le env && not (lexp_is_effectful le) -> - let (le', re') = rewrite_local_lexp le in - let e' = re' (rewrite_base e) in - let exps' = walker exps in - let effects = union_eff_exps exps' in - let block = E_aux (E_block exps', (l, Some (env, unit_typ, effects))) in - [fix_eff_exp (E_aux (E_internal_let(le', e', block), annot))] - (*| ((E_aux(E_if(c,t,e),(l,annot))) as exp)::exps -> - let vars_t = introduced_variables t in - let vars_e = introduced_variables e in - let new_vars = Envmap.intersect vars_t vars_e in - if Envmap.is_empty new_vars - then (rewrite_base exp)::walker exps - else - let new_nmap = match nmap with - | None -> Some(Nexpmap.empty,new_vars) - | Some(nm,s) -> Some(nm, Envmap.union new_vars s) in - let c' = rewrite_base c in - let t' = rewriters.rewrite_exp rewriters new_nmap t in - let e' = rewriters.rewrite_exp rewriters new_nmap e in - let exps' = walker exps in - fst ((Envmap.fold - (fun (res,effects) i (t,e) -> - let bitlit = E_aux (E_lit (L_aux(L_zero, Parse_ast.Generated l)), - (Parse_ast.Generated l, simple_annot bit_t)) in - let rangelit = E_aux (E_lit (L_aux (L_num 0, Parse_ast.Generated l)), - (Parse_ast.Generated l, simple_annot nat_t)) in - let set_exp = - match t.t with - | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) -> bitlit - | Tapp("range", _) | Tapp("atom", _) -> rangelit - | Tapp("vector", [_;_;_;TA_typ ( {t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})})]) - | Tapp(("reg"|"register"),[TA_typ ({t = Tapp("vector", - [_;_;_;TA_typ ( {t=Tid "bit"} - | {t=Tabbrev(_,{t=Tid "bit"})})])})]) - | Tabbrev(_,{t = Tapp("vector", - [_;_;_;TA_typ ( {t=Tid "bit"} - | {t=Tabbrev(_,{t=Tid "bit"})})])}) -> - E_aux (E_vector_indexed([], Def_val_aux(Def_val_dec bitlit, - (Parse_ast.Generated l,simple_annot bit_t))), - (Parse_ast.Generated l, simple_annot t)) - | _ -> e in - let unioneffs = union_effects effects (get_effsum_exp set_exp) in - ([E_aux (E_internal_let (LEXP_aux (LEXP_id (Id_aux (Id i, Parse_ast.Generated l)), - (Parse_ast.Generated l, (tag_annot t Emp_intro))), - set_exp, - E_aux (E_block res, (Parse_ast.Generated l, (simple_annot_efr unit_t effects)))), - (Parse_ast.Generated l, simple_annot_efr unit_t unioneffs))],unioneffs))) - (E_aux(E_if(c',t',e'),(Parse_ast.Generated l, annot))::exps',eff_union_exps (c'::t'::e'::exps')) new_vars)*) - | e::exps -> (rewrite_rec e)::(walker exps) - in - rewrap (E_block (walker exps)) - | E_assign(le,e) - when lexp_is_local_intro le (env_of full_exp) && not (lexp_is_effectful le) -> - let (le', re') = rewrite_local_lexp le in - let e' = re' (rewrite_base e) in - let block = annot_exp (E_block []) l (env_of full_exp) unit_typ in - fix_eff_exp (E_aux (E_internal_let(le', e', block), annot)) - | _ -> rewrite_base full_exp - -let rewrite_lexp_lift_assign_intro rewriters ((LEXP_aux(lexp,annot)) as le) = - let rewrap le = LEXP_aux(le,annot) in - let rewrite_base = rewrite_lexp rewriters in - match lexp, annot with - | (LEXP_id id | LEXP_cast (_,id)), (l, Some (env, typ, eff)) -> - (match Env.lookup_id id env with - | Unbound | Local _ -> - LEXP_aux (lexp, (l, Some (env, typ, union_effects eff (mk_effect [BE_lset])))) - | _ -> rewrap lexp) - | _ -> rewrite_base le - - -let rewrite_defs_exp_lift_assign defs = rewrite_defs_base - {rewrite_exp = rewrite_exp_lift_assign_intro; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; - rewrite_lexp = rewrite_lexp_lift_assign_intro; - rewrite_fun = rewrite_fun; - rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base} defs - -(*let rewrite_exp_separate_ints rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = - (*let tparms,t,tag,nexps,eff,cum_eff,bounds = match annot with - | Base((tparms,t),tag,nexps,eff,cum_eff,bounds) -> tparms,t,tag,nexps,eff,cum_eff,bounds - | _ -> [],unit_t,Emp_local,[],pure_e,pure_e,nob in*) - let rewrap e = E_aux (e,annot) in - (*let rewrap_effects e effsum = - E_aux (e,(l,Base ((tparms,t),tag,nexps,eff,effsum,bounds))) in*) - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - match exp with - | E_lit (L_aux (((L_num _) as lit),_)) -> - (match (is_within_machine64 t nexps) with - | Yes -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int yes\n" in rewrite_base full_exp - | Maybe -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int maybe\n" in rewrite_base full_exp - | No -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int no\n" in E_aux(E_app(Id_aux (Id "integer_of_int",l),[rewrite_base full_exp]), - (l, Base((tparms,t),External(None),nexps,eff,cum_eff,bounds)))) - | E_cast (typ, exp) -> rewrap (E_cast (typ, rewrite_rec exp)) - | E_app (id,exps) -> rewrap (E_app (id,List.map rewrite_rec exps)) - | E_app_infix(el,id,er) -> rewrap (E_app_infix(rewrite_rec el,id,rewrite_rec er)) - | E_for (id, e1, e2, e3, o, body) -> - rewrap (E_for (id, rewrite_rec e1, rewrite_rec e2, rewrite_rec e3, o, rewrite_rec body)) - | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite_rec vec,rewrite_rec index)) - | E_vector_subrange (vec,i1,i2) -> - rewrap (E_vector_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2)) - | E_vector_update (vec,index,new_v) -> - rewrap (E_vector_update (rewrite_rec vec,rewrite_rec index,rewrite_rec new_v)) - | E_vector_update_subrange (vec,i1,i2,new_v) -> - rewrap (E_vector_update_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2,rewrite_rec new_v)) - | E_case (exp ,pexps) -> - rewrap (E_case (rewrite_rec exp, - (List.map - (fun (Pat_aux (Pat_exp(p,e),pannot)) -> - Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters nmap p,rewrite_rec e),pannot)) pexps))) - | E_let (letbind,body) -> rewrap (E_let(rewriters.rewrite_let rewriters nmap letbind,rewrite_rec body)) - | E_internal_let (lexp,exp,body) -> - rewrap (E_internal_let (rewriters.rewrite_lexp rewriters nmap lexp, rewrite_rec exp, rewrite_rec body)) - | _ -> rewrite_base full_exp - -let rewrite_defs_separate_numbs defs = rewrite_defs_base - {rewrite_exp = rewrite_exp_separate_ints; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; (*will likely need a new one?*) - rewrite_lexp = rewrite_lexp; (*will likely need a new one?*) - rewrite_fun = rewrite_fun; - rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base} defs*) - -let rewrite_defs_early_return = - let is_return (E_aux (exp, _)) = match exp with - | E_return _ -> true - | _ -> false in - - let get_return (E_aux (e, (l, _)) as exp) = match e with - | E_return e -> e - | _ -> exp in - - let e_block es = - match es with - | [E_aux (e, _)] -> e - | _ :: _ when is_return (Util.last es) -> - let (E_aux (_, annot) as e) = get_return (Util.last es) in - E_return (E_aux (E_block (Util.butlast es @ [get_return e]), annot)) - | _ -> E_block es in - - let e_if (e1, e2, e3) = - if is_return e2 && is_return e3 then - let (E_aux (_, annot)) = get_return e2 in - E_return (E_aux (E_if (e1, get_return e2, get_return e3), annot)) - else E_if (e1, e2, e3) in - - let e_case (e, pes) = - let is_return_pexp (Pat_aux (pexp, _)) = match pexp with - | Pat_exp (_, e) | Pat_when (_, _, e) -> is_return e in - let get_return_pexp (Pat_aux (pexp, a)) = match pexp with - | Pat_exp (p, e) -> Pat_aux (Pat_exp (p, get_return e), a) - | Pat_when (p, g, e) -> Pat_aux (Pat_when (p, g, get_return e), a) in - let annot = match List.map get_return_pexp pes with - | Pat_aux (Pat_exp (_, E_aux (_, annot)), _) :: _ -> annot - | Pat_aux (Pat_when (_, _, E_aux (_, annot)), _) :: _ -> annot - | [] -> (Parse_ast.Unknown, None) in - if List.for_all is_return_pexp pes - then E_return (E_aux (E_case (e, List.map get_return_pexp pes), annot)) - else E_case (e, pes) in - - let e_aux (exp, (l, annot)) = - let full_exp = fix_eff_exp (E_aux (exp, (l, annot))) in - match annot with - | Some (env, typ, eff) when is_return full_exp -> - (* Add escape effect annotation, since we use the exception mechanism - of the state monad to implement early return in the Lem backend *) - let annot' = Some (env, typ, union_effects eff (mk_effect [BE_escape])) in - E_aux (exp, (l, annot')) - | _ -> full_exp in - - let rewrite_funcl_early_return _ (FCL_aux (FCL_Funcl (id, pat, exp), a)) = - let exp = - exp - (* Pull early returns out as far as possible *) - |> fold_exp { id_exp_alg with e_block = e_block; e_if = e_if; e_case = e_case } - (* Remove singleton E_return *) - |> get_return - (* Fix effect annotations *) - |> fold_exp { id_exp_alg with e_aux = e_aux } in - let a = match a with - | (l, Some (env, typ, eff)) -> - (l, Some (env, typ, union_effects eff (effect_of exp))) - | _ -> a in - FCL_aux (FCL_Funcl (id, pat, exp), a) in - - let rewrite_fun_early_return rewriters - (FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, funcls), a)) = - FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, - List.map (rewrite_funcl_early_return rewriters) funcls), a) in - - rewrite_defs_base { rewriters_base with rewrite_fun = rewrite_fun_early_return } - -(* Propagate effects of functions, if effect checking and propagation - have not been performed already by the type checker. *) -let rewrite_fix_val_specs (Defs defs) = - let find_vs env val_specs id = - try Bindings.find id val_specs with - | Not_found -> - begin - try Env.get_val_spec id env with - | _ -> - raise (Reporting_basic.err_unreachable (Parse_ast.Unknown) - ("No val spec found for " ^ string_of_id id)) - end - in - - let add_eff_to_vs eff = function - | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff'), a)) -> - (tq, Typ_aux (Typ_fn (args_t, ret_t, union_effects eff eff'), a)) - | vs -> vs - in - - let eff_of_vs = function - | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff), a)) -> eff - | _ -> no_effect - in - - let e_aux val_specs (exp, (l, annot)) = - match fix_eff_exp (E_aux (exp, (l, annot))) with - | E_aux (E_app_infix (_, f, _) as exp, (l, Some (env, typ, eff))) - | E_aux (E_app (f, _) as exp, (l, Some (env, typ, eff))) -> - let vs = find_vs env val_specs f in - let env = Env.update_val_spec f vs env in - E_aux (exp, (l, Some (env, typ, union_effects eff (eff_of_vs vs)))) - | e_aux -> e_aux - in - - let rewrite_exp val_specs = fold_exp { id_exp_alg with e_aux = e_aux val_specs } in - - let rewrite_funcl (val_specs, funcls) (FCL_aux (FCL_Funcl (id, pat, exp), (l, annot))) = - let exp = propagate_exp_effect (rewrite_exp val_specs exp) in - let vs, eff = match find_vs (env_of_annot (l, annot)) val_specs id with - | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff), a)) -> - let eff' = union_effects eff (effect_of exp) in - let args_t' = rewrite_typ_nexp_ids (env_of exp) (pat_typ_of pat) in - let ret_t' = rewrite_typ_nexp_ids (env_of exp) (typ_of exp) in - (tq, Typ_aux (Typ_fn (args_t', ret_t', eff'), a)), eff' - in - let annot = add_effect_annot annot eff in - (Bindings.add id vs val_specs, - funcls @ [FCL_aux (FCL_Funcl (id, pat, exp), (l, annot))]) - in - - let rewrite_fundef (val_specs, FD_aux (FD_function (recopt, tannotopt, effopt, funcls), a)) = - let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in - (* Repeat once to cross-propagate effects between clauses *) - let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in - let is_funcl_rec (FCL_aux (FCL_Funcl (id, _, exp), _)) = - fst (fold_exp - { (compute_exp_alg false (||) ) with - e_app = (fun (f, es) -> - let (rs, es) = List.split es in - (List.fold_left (||) (string_of_id f = string_of_id id) rs, - E_app (f, es))); - e_app_infix = (fun ((r1,e1), f, (r2,e2)) -> - (r1 || r2 || (string_of_id f = string_of_id id), - E_app_infix (e1, f, e2))) } - exp) - in - let recopt = - if List.exists is_funcl_rec funcls then - Rec_aux (Rec_rec, Parse_ast.Unknown) - else recopt - in - (val_specs, FD_aux (FD_function (recopt, tannotopt, effopt, funcls), a)) in - - let rec rewrite_fundefs (val_specs, fundefs) = - match fundefs with - | fundef :: fundefs -> - let (val_specs, fundef) = rewrite_fundef (val_specs, fundef) in - let (val_specs, fundefs) = rewrite_fundefs (val_specs, fundefs) in - (val_specs, fundef :: fundefs) - | [] -> (val_specs, []) in - - let rewrite_def (val_specs, defs) = function - | DEF_fundef fundef -> - let (val_specs, fundef) = rewrite_fundef (val_specs, fundef) in - (val_specs, defs @ [DEF_fundef fundef]) - | DEF_internal_mutrec fundefs -> - let (val_specs, fundefs) = rewrite_fundefs (val_specs, fundefs) in - (val_specs, defs @ [DEF_internal_mutrec fundefs]) - | DEF_val (LB_aux (LB_val (pat, exp), a)) -> - (val_specs, defs @ [DEF_val (LB_aux (LB_val (pat, rewrite_exp val_specs exp), a))]) - | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) -> - let typschm, val_specs = - if Bindings.mem id val_specs then begin - let (tq, typ) = Bindings.find id val_specs in - TypSchm_aux (TypSchm_ts (tq, typ), Parse_ast.Unknown), val_specs - end else begin - let (TypSchm_aux (TypSchm_ts (tq, typ), _)) = typschm in - typschm, Bindings.add id (tq, typ) val_specs - end - in - (val_specs, defs @ [DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a))]) - | def -> (val_specs, defs @ [def]) - in - - let rewrite_val_specs val_specs = function - | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) - when Bindings.mem id val_specs -> - let typschm = match typschm with - | TypSchm_aux (TypSchm_ts (tq, typ), l) -> - let (tq, typ) = Bindings.find id val_specs in - TypSchm_aux (TypSchm_ts (tq, typ), l) - in - DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) - | def -> def - in - - let (val_specs, defs) = List.fold_left rewrite_def (Bindings.empty, []) defs in - let defs = List.map (rewrite_val_specs val_specs) defs in - - (* if !Type_check.opt_no_effects - then *) - Defs defs - (* else Defs defs *) - -(* Turn constraints into numeric expressions with sizeof *) -let rewrite_constraint = - let rec rewrite_nc (NC_aux (nc_aux, l)) = mk_exp (rewrite_nc_aux nc_aux) - and rewrite_nc_aux = function - | NC_bounded_ge (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id ">=", mk_exp (E_sizeof n2)) - | NC_bounded_le (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "<=", mk_exp (E_sizeof n2)) - | NC_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "==", mk_exp (E_sizeof n2)) - | NC_not_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "!=", mk_exp (E_sizeof n2)) - | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "&", rewrite_nc nc2) - | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "|", rewrite_nc nc2) - | NC_false -> E_lit (mk_lit L_false) - | NC_true -> E_lit (mk_lit L_true) - | NC_set (kid, ints) -> - unaux_exp (rewrite_nc (List.fold_left (fun nc int -> nc_or nc (nc_eq (nvar kid) (nconstant int))) nc_true ints)) - in - let rewrite_e_aux (E_aux (e_aux, _) as exp) = - match e_aux with - | E_constraint nc -> - check_exp (env_of exp) (rewrite_nc nc) bool_typ - | _ -> exp - in - - let rewrite_e_constraint = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in - - rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_e_constraint) } - -let rewrite_type_union_typs rw_typ (Tu_aux (tu, annot)) = - match tu with - | Tu_id id -> Tu_aux (Tu_id id, annot) - | Tu_ty_id (typ, id) -> Tu_aux (Tu_ty_id (rw_typ typ, id), annot) - -let rewrite_type_def_typs rw_typ rw_typquant rw_typschm (TD_aux (td, annot)) = - match td with - | TD_abbrev (id, nso, typschm) -> TD_aux (TD_abbrev (id, nso, rw_typschm typschm), annot) - | TD_record (id, nso, typq, typ_ids, flag) -> - TD_aux (TD_record (id, nso, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot) - | TD_variant (id, nso, typq, tus, flag) -> - TD_aux (TD_variant (id, nso, rw_typquant typq, List.map (rewrite_type_union_typs rw_typ) tus, flag), annot) - | TD_enum (id, nso, ids, flag) -> TD_aux (TD_enum (id, nso, ids, flag), annot) - | TD_register (id, n1, n2, ranges) -> TD_aux (TD_register (id, n1, n2, ranges), annot) - -(* FIXME: other reg_dec types *) -let rewrite_dec_spec_typs rw_typ (DEC_aux (ds, annot)) = - match ds with - | DEC_reg (typ, id) -> DEC_aux (DEC_reg (rw_typ typ, id), annot) - | _ -> assert false - -(* Remove overload definitions and cast val specs from the - specification because the interpreter doesn't know about them.*) -let rewrite_overload_cast (Defs defs) = - let remove_cast_vs (VS_aux (vs_aux, annot)) = - match vs_aux with - | VS_val_spec (typschm, id, ext, _) -> VS_aux (VS_val_spec (typschm, id, ext, false), annot) - in - let simple_def = function - | DEF_spec vs -> DEF_spec (remove_cast_vs vs) - | def -> def - in - let is_overload = function - | DEF_overload _ -> true - | _ -> false - in - let defs = List.map simple_def defs in - Defs (List.filter (fun def -> not (is_overload def)) defs) - - -let rewrite_undefined mwords = - let rewrite_e_aux (E_aux (e_aux, _) as exp) = - match e_aux with - | E_lit (L_aux (L_undef, l)) -> - check_exp (env_of exp) (undefined_of_typ mwords l (fun _ -> ()) (Env.expand_synonyms (env_of exp) (typ_of exp))) (typ_of exp) - | _ -> exp - in - let rewrite_exp_undefined = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in - rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp_undefined) } - -let rec simple_typ (Typ_aux (typ_aux, l) as typ) = Typ_aux (simple_typ_aux typ_aux, l) -and simple_typ_aux = function - | Typ_id id -> Typ_id id - | Typ_app (id, [_; _; _; Typ_arg_aux (Typ_arg_typ typ, l)]) when Id.compare id (mk_id "vector") = 0 -> - Typ_app (mk_id "list", [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)]) - | Typ_app (id, [_]) when Id.compare id (mk_id "atom") = 0 -> - Typ_id (mk_id "int") - | Typ_app (id, [_; _]) when Id.compare id (mk_id "range") = 0 -> - Typ_id (mk_id "int") - | Typ_app (id, args) -> Typ_app (id, List.concat (List.map simple_typ_arg args)) - | Typ_fn (typ1, typ2, effs) -> Typ_fn (simple_typ typ1, simple_typ typ2, effs) - | Typ_tup typs -> Typ_tup (List.map simple_typ typs) - | Typ_exist (_, _, Typ_aux (typ, l)) -> simple_typ_aux typ - | typ_aux -> typ_aux -and simple_typ_arg (Typ_arg_aux (typ_arg_aux, l)) = - match typ_arg_aux with - | Typ_arg_typ typ -> [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)] - | _ -> [] - -(* This pass aims to remove all the Num quantifiers from the specification. *) -let rewrite_simple_types (Defs defs) = - let is_simple = function - | QI_aux (QI_id kopt, annot) as qi when is_typ_kopt kopt || is_order_kopt kopt -> true - | _ -> false - in - let simple_typquant (TypQ_aux (tq_aux, annot)) = - match tq_aux with - | TypQ_no_forall -> TypQ_aux (TypQ_no_forall, annot) - | TypQ_tq quants -> TypQ_aux (TypQ_tq (List.filter (fun q -> is_simple q) quants), annot) - in - let simple_typschm (TypSchm_aux (TypSchm_ts (typq, typ), annot)) = - TypSchm_aux (TypSchm_ts (simple_typquant typq, simple_typ typ), annot) - in - let simple_vs (VS_aux (vs_aux, annot)) = - match vs_aux with - | VS_val_spec (typschm, id, ext, is_cast) -> VS_aux (VS_val_spec (simple_typschm typschm, id, ext, is_cast), annot) - in - let rec simple_lit (L_aux (lit_aux, l) as lit) = - match lit_aux with - | L_bin _ | L_hex _ -> - E_list (List.map (fun b -> E_aux (E_lit b, simple_annot l bit_typ)) (vector_string_to_bit_list l lit_aux)) - | _ -> E_lit lit - in - let simple_def = function - | DEF_spec vs -> DEF_spec (simple_vs vs) - | DEF_type td -> DEF_type (rewrite_type_def_typs simple_typ simple_typquant simple_typschm td) - | DEF_reg_dec ds -> DEF_reg_dec (rewrite_dec_spec_typs simple_typ ds) - | def -> def - in - let simple_pat = { - id_pat_alg with - p_typ = (fun (typ, pat) -> P_typ (simple_typ typ, pat)); - p_var = (fun (pat, kid) -> unaux_pat pat); - p_vector = (fun pats -> P_list pats) - } in - let simple_exp = { - id_exp_alg with - e_lit = simple_lit; - e_vector = (fun exps -> E_list exps); - e_cast = (fun (typ, exp) -> E_cast (simple_typ typ, exp)); - (* e_assert = (fun (E_aux (_, annot), str) -> E_assert (E_aux (E_lit (mk_lit L_true), annot), str)); *) - lEXP_cast = (fun (typ, lexp) -> LEXP_cast (simple_typ typ, lexp)); - pat_alg = simple_pat - } in - let simple_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp simple_exp); - rewrite_pat = (fun _ -> fold_pat simple_pat) } - in - let defs = Defs (List.map simple_def defs) in - rewrite_defs_base simple_defs defs - -let rewrite_tuple_vector_assignments defs = - let assign_tuple e_aux annot = - let env = env_of_annot annot in - match e_aux with - | E_assign (LEXP_aux (LEXP_tup lexps, lannot), exp) -> - let typ = Env.base_typ_of env (typ_of exp) in - if is_vector_typ typ then - (* let _ = Pretty_print_common.print stderr (Pretty_print_sail.doc_exp (E_aux (e_aux, annot))) in *) - let (start, _, ord, etyp) = vector_typ_args_of typ in - let len (LEXP_aux (le, lannot)) = - let ltyp = Env.base_typ_of env (typ_of_annot lannot) in - if is_vector_typ ltyp then - let (_, len, _, _) = vector_typ_args_of ltyp in - match nexp_simp len with - | Nexp_aux (Nexp_constant len, _) -> len - | _ -> unit_big_int - else unit_big_int in - let next i step = - if is_order_inc ord - then (sub_big_int (add_big_int i step) unit_big_int, add_big_int i step) - else (add_big_int (sub_big_int i step) unit_big_int, sub_big_int i step) in - let i = match nexp_simp start with - | (Nexp_aux (Nexp_constant i, _)) -> i - | _ -> if is_order_inc ord then zero_big_int else big_int_of_int (List.length lexps - 1) in - let l = gen_loc (fst annot) in - let exp' = - if small exp then strip_exp exp - else mk_exp (E_id (mk_id "split_vec")) in - let lexp_to_exp (i, exps) lexp = - let (j, i') = next i (len lexp) in - let i_exp = mk_exp (E_lit (mk_lit (L_num i))) in - let j_exp = mk_exp (E_lit (mk_lit (L_num j))) in - let sub = mk_exp (E_vector_subrange (exp', i_exp, j_exp)) in - (i', exps @ [sub]) in - let (_, exps) = List.fold_left lexp_to_exp (i, []) lexps in - let tup = mk_exp (E_tuple exps) in - let lexp = LEXP_aux (LEXP_tup (List.map strip_lexp lexps), (l, ())) in - let e_aux = - if small exp then mk_exp (E_assign (lexp, tup)) - else mk_exp ( - E_let ( - mk_letbind (mk_pat (P_id (mk_id "split_vec"))) (strip_exp exp), - mk_exp (E_assign (lexp, tup)))) in - begin - try check_exp env e_aux unit_typ with - | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (string_of_type_error err)) - end - else E_aux (e_aux, annot) - | _ -> E_aux (e_aux, annot) - in - let assign_exp = { - id_exp_alg with - e_aux = (fun (e_aux, annot) -> assign_tuple e_aux annot) - } in - let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in - rewrite_defs_base assign_defs defs - -let rewrite_tuple_assignments defs = - let assign_tuple e_aux annot = - let env = env_of_annot annot in - match e_aux with - | E_assign (LEXP_aux (LEXP_tup lexps, _), exp) -> - (* let _ = Pretty_print_common.print stderr (Pretty_print_sail.doc_exp (E_aux (e_aux, annot))) in *) - let (_, ids) = List.fold_left (fun (n, ids) _ -> (n + 1, ids @ [mk_id ("tup__" ^ string_of_int n)])) (0, []) lexps in - let block_assign i lexp = mk_exp (E_assign (strip_lexp lexp, mk_exp (E_id (mk_id ("tup__" ^ string_of_int i))))) in - let block = mk_exp (E_block (List.mapi block_assign lexps)) in - let letbind = mk_letbind (mk_pat (P_tup (List.map (fun id -> mk_pat (P_id id)) ids))) (strip_exp exp) in - let let_exp = mk_exp (E_let (letbind, block)) in - begin - try check_exp env let_exp unit_typ with - | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (string_of_type_error err)) - end - | _ -> E_aux (e_aux, annot) - in - let assign_exp = { - id_exp_alg with - e_aux = (fun (e_aux, annot) -> assign_tuple e_aux annot) - } in - let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in - rewrite_defs_base assign_defs defs - -let rewrite_simple_assignments defs = - let assign_e_aux e_aux annot = - let env = env_of_annot annot in - match e_aux with - | E_assign (lexp, exp) -> - let (lexp, rhs) = rewrite_local_lexp lexp in - let assign = mk_exp (E_assign (strip_lexp lexp, strip_exp (rhs exp))) in - check_exp env assign unit_typ - | _ -> E_aux (e_aux, annot) - in - let assign_exp = { - id_exp_alg with - e_aux = (fun (e_aux, annot) -> assign_e_aux e_aux annot) - } in - let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in - rewrite_defs_base assign_defs defs - -let rewrite_defs_remove_blocks = - let letbind_wild v body = - let l = get_loc_exp v in - let env = env_of v in - let typ = typ_of v in - annot_exp (E_let (annot_letbind (P_wild, v) l env typ, body)) l env (typ_of body) in - (* let pat = annot_pat P_wild l env typ in - let (E_aux (_,(l,tannot))) = v in - let annot_pat = (simple_annot l (typ_of v)) in - let annot_lb = (gen_loc l, tannot) in - let annot_let = (gen_loc l, Some (env_of body, typ_of body, union_eff_exps [v;body])) in - E_aux (E_let (LB_aux (LB_val (P_aux (P_wild,annot_pat),v),annot_lb),body),annot_let) in *) - - let rec f l = function - | [] -> E_aux (E_lit (L_aux (L_unit,gen_loc l)), (simple_annot l unit_typ)) - | [e] -> e (* check with Kathy if that annotation is fine *) - | e :: es -> letbind_wild e (f l es) in - - let e_aux = function - | (E_block es,(l,_)) -> f l es - | (e,annot) -> E_aux (e,annot) in - - let alg = { id_exp_alg with e_aux = e_aux } in - - rewrite_defs_base - {rewrite_exp = (fun _ -> fold_exp alg) - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - - - -let letbind (v : 'a exp) (body : 'a exp -> 'a exp) : 'a exp = - (* body is a function : E_id variable -> actual body *) - let (E_aux (_,(l,annot))) = v in - match annot with - | Some (env, Typ_aux (Typ_id tid, _), eff) when string_of_id tid = "unit" -> - let body = body (annot_exp (E_lit (mk_lit L_unit)) l env unit_typ) in - let body_typ = try typ_of body with _ -> unit_typ in - let lb = annot_letbind (P_wild, v) l env unit_typ in - propagate_exp_effect (annot_exp (E_let (lb, body)) l env body_typ) - | Some (env, typ, eff) -> - let id = fresh_id "w__" l in - let lb = annot_letbind (P_id id, v) l env typ in - let body = body (annot_exp (E_id id) l env typ) in - propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) - | None -> - raise (Reporting_basic.err_unreachable l "no type information") - - -let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list -> 'a exp) : 'a exp = - match l with - | [] -> k [] - | exp :: exps -> f exp (fun exp -> mapCont f exps (fun exps -> k (exp :: exps))) - -let rewrite_defs_letbind_effects = - - let rec value ((E_aux (exp_aux,_)) as exp) = - not (effectful exp || updates_vars exp) - and value_optdefault (Def_val_aux (o,_)) = match o with - | Def_val_empty -> true - | Def_val_dec e -> value e - and value_fexps (FES_aux (FES_Fexps (fexps,_),_)) = - List.fold_left (fun b (FE_aux (FE_Fexp (_,e),_)) -> b && value e) true fexps in - - - let rec n_exp_name (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = - n_exp exp (fun exp -> if value exp then k exp else letbind exp k) - - and n_exp_pure (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = - n_exp exp (fun exp -> if value exp then k exp else letbind exp k) - - and n_exp_nameL (exps : 'a exp list) (k : 'a exp list -> 'a exp) : 'a exp = - mapCont n_exp_name exps k - - and n_fexp (fexp : 'a fexp) (k : 'a fexp -> 'a exp) : 'a exp = - let (FE_aux (FE_Fexp (id,exp),annot)) = fexp in - n_exp_name exp (fun exp -> - k (fix_eff_fexp (FE_aux (FE_Fexp (id,exp),annot)))) - - and n_fexpL (fexps : 'a fexp list) (k : 'a fexp list -> 'a exp) : 'a exp = - mapCont n_fexp fexps k - - and n_pexp (newreturn : bool) (pexp : 'a pexp) (k : 'a pexp -> 'a exp) : 'a exp = - match pexp with - | Pat_aux (Pat_exp (pat,exp),annot) -> - k (fix_eff_pexp (Pat_aux (Pat_exp (pat,n_exp_term newreturn exp), annot))) - | Pat_aux (Pat_when (pat,guard,exp),annot) -> - k (fix_eff_pexp (Pat_aux (Pat_when (pat,n_exp_term newreturn guard,n_exp_term newreturn exp), annot))) - - and n_pexpL (newreturn : bool) (pexps : 'a pexp list) (k : 'a pexp list -> 'a exp) : 'a exp = - mapCont (n_pexp newreturn) pexps k - - and n_fexps (fexps : 'a fexps) (k : 'a fexps -> 'a exp) : 'a exp = - let (FES_aux (FES_Fexps (fexps_aux,b),annot)) = fexps in - n_fexpL fexps_aux (fun fexps_aux -> - k (fix_eff_fexps (FES_aux (FES_Fexps (fexps_aux,b),annot)))) - - and n_opt_default (opt_default : 'a opt_default) (k : 'a opt_default -> 'a exp) : 'a exp = - let (Def_val_aux (opt_default,annot)) = opt_default in - match opt_default with - | Def_val_empty -> k (Def_val_aux (Def_val_empty,annot)) - | Def_val_dec exp -> - n_exp_name exp (fun exp -> - k (fix_eff_opt_default (Def_val_aux (Def_val_dec exp,annot)))) - - and n_lb (lb : 'a letbind) (k : 'a letbind -> 'a exp) : 'a exp = - let (LB_aux (lb,annot)) = lb in - match lb with - | LB_val (pat,exp1) -> - n_exp exp1 (fun exp1 -> - k (fix_eff_lb (LB_aux (LB_val (pat,exp1),annot)))) - - and n_lexp (lexp : 'a lexp) (k : 'a lexp -> 'a exp) : 'a exp = - let (LEXP_aux (lexp_aux,annot)) = lexp in - match lexp_aux with - | LEXP_id _ -> k lexp - | LEXP_memory (id,es) -> - n_exp_nameL es (fun es -> - k (fix_eff_lexp (LEXP_aux (LEXP_memory (id,es),annot)))) - | LEXP_tup es -> - n_lexpL es (fun es -> - k (fix_eff_lexp (LEXP_aux (LEXP_tup es,annot)))) - | LEXP_cast (typ,id) -> - k (fix_eff_lexp (LEXP_aux (LEXP_cast (typ,id),annot))) - | LEXP_vector (lexp,e) -> - n_lexp lexp (fun lexp -> - n_exp_name e (fun e -> - k (fix_eff_lexp (LEXP_aux (LEXP_vector (lexp,e),annot))))) - | LEXP_vector_range (lexp,e1,e2) -> - n_lexp lexp (fun lexp -> - n_exp_name e1 (fun e1 -> - n_exp_name e2 (fun e2 -> - k (fix_eff_lexp (LEXP_aux (LEXP_vector_range (lexp,e1,e2),annot)))))) - | LEXP_field (lexp,id) -> - n_lexp lexp (fun lexp -> - k (fix_eff_lexp (LEXP_aux (LEXP_field (lexp,id),annot)))) - - and n_lexpL (lexps : 'a lexp list) (k : 'a lexp list -> 'a exp) : 'a exp = - mapCont n_lexp lexps k - - and n_exp_term (newreturn : bool) (exp : 'a exp) : 'a exp = - let (E_aux (_,(l,tannot))) = exp in - let exp = - if newreturn then - (* let typ = try typ_of exp with _ -> unit_typ in *) - annot_exp (E_internal_return exp) l (env_of exp) (typ_of exp) - else - exp in - (* n_exp_term forces an expression to be translated into a form - "let .. let .. let .. in EXP" where EXP has no effect and does not update - variables *) - n_exp_pure exp (fun exp -> exp) - - and n_exp (E_aux (exp_aux,annot) as exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = - - let rewrap e = fix_eff_exp (E_aux (e,annot)) in - - match exp_aux with - | E_block es -> failwith "E_block should have been removed till now" - | E_nondet _ -> failwith "E_nondet not supported" - | E_id id -> k exp - | E_lit _ -> k exp - | E_cast (typ,exp') -> - n_exp_name exp' (fun exp' -> - k (rewrap (E_cast (typ,exp')))) - | E_app (id,exps) -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_app (id,exps)))) - | E_app_infix (exp1,id,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_app_infix (exp1,id,exp2))))) - | E_tuple exps -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_tuple exps))) - | E_if (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - let (E_aux (_,annot2)) = exp2 in - let (E_aux (_,annot3)) = exp3 in - let newreturn = effectful exp2 || effectful exp3 in - let exp2 = n_exp_term newreturn exp2 in - let exp3 = n_exp_term newreturn exp3 in - k (rewrap (E_if (exp1,exp2,exp3)))) - | E_for (id,start,stop,by,dir,body) -> - n_exp_name start (fun start -> - n_exp_name stop (fun stop -> - n_exp_name by (fun by -> - let body = n_exp_term (effectful body) body in - k (rewrap (E_for (id,start,stop,by,dir,body)))))) - | E_loop (loop, cond, body) -> - let cond = n_exp_term (effectful cond) cond in - let body = n_exp_term (effectful body) body in - k (rewrap (E_loop (loop,cond,body))) - | E_vector exps -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_vector exps))) - | E_vector_access (exp1,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_vector_access (exp1,exp2))))) - | E_vector_subrange (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - n_exp_name exp3 (fun exp3 -> - k (rewrap (E_vector_subrange (exp1,exp2,exp3)))))) - | E_vector_update (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - n_exp_name exp3 (fun exp3 -> - k (rewrap (E_vector_update (exp1,exp2,exp3)))))) - | E_vector_update_subrange (exp1,exp2,exp3,exp4) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - n_exp_name exp3 (fun exp3 -> - n_exp_name exp4 (fun exp4 -> - k (rewrap (E_vector_update_subrange (exp1,exp2,exp3,exp4))))))) - | E_vector_append (exp1,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_vector_append (exp1,exp2))))) - | E_list exps -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_list exps))) - | E_cons (exp1,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_cons (exp1,exp2))))) - | E_record fexps -> - n_fexps fexps (fun fexps -> - k (rewrap (E_record fexps))) - | E_record_update (exp1,fexps) -> - n_exp_name exp1 (fun exp1 -> - n_fexps fexps (fun fexps -> - k (rewrap (E_record_update (exp1,fexps))))) - | E_field (exp1,id) -> - n_exp_name exp1 (fun exp1 -> - k (rewrap (E_field (exp1,id)))) - | E_case (exp1,pexps) -> - let newreturn = List.exists effectful_pexp pexps in - n_exp_name exp1 (fun exp1 -> - n_pexpL newreturn pexps (fun pexps -> - k (rewrap (E_case (exp1,pexps))))) - | E_let (lb,body) -> - n_lb lb (fun lb -> - rewrap (E_let (lb,n_exp body k))) - | E_sizeof nexp -> - k (rewrap (E_sizeof nexp)) - | E_constraint nc -> - k (rewrap (E_constraint nc)) - | E_sizeof_internal annot -> - k (rewrap (E_sizeof_internal annot)) - | E_assign (lexp,exp1) -> - n_lexp lexp (fun lexp -> - n_exp_name exp1 (fun exp1 -> - k (rewrap (E_assign (lexp,exp1))))) - | E_exit exp' -> k (E_aux (E_exit (n_exp_term (effectful exp') exp'),annot)) - | E_assert (exp1,exp2) -> - n_exp exp1 (fun exp1 -> - n_exp exp2 (fun exp2 -> - k (rewrap (E_assert (exp1,exp2))))) - | E_internal_cast (annot',exp') -> - n_exp_name exp' (fun exp' -> - k (rewrap (E_internal_cast (annot',exp')))) - | E_internal_exp _ -> k exp - | E_internal_exp_user _ -> k exp - | E_internal_let (lexp,exp1,exp2) -> - n_lexp lexp (fun lexp -> - n_exp exp1 (fun exp1 -> - rewrap (E_internal_let (lexp,exp1,n_exp exp2 k)))) - | E_internal_return exp1 -> - n_exp_name exp1 (fun exp1 -> - k (rewrap (E_internal_return exp1))) - | E_comment str -> - k (rewrap (E_comment str)) - | E_comment_struc exp' -> - n_exp exp' (fun exp' -> - k (rewrap (E_comment_struc exp'))) - | E_return exp' -> - n_exp_name exp' (fun exp' -> - k (rewrap (E_return exp'))) - | E_internal_plet _ -> failwith "E_internal_plet should not be here yet" in - - let rewrite_fun _ (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),fdannot)) = - let effectful_funcl (FCL_aux (FCL_Funcl(_, _, exp), _)) = effectful exp in - let newreturn = List.exists effectful_funcl funcls in - let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),annot)) = - let _ = reset_fresh_name_counter () in - FCL_aux (FCL_Funcl (id,pat,n_exp_term newreturn exp),annot) - in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),fdannot) in - let rewrite_def rewriters def = - (* let _ = Pretty_print_sail.pp_defs stderr (Defs [def]) in *) - match def with - | DEF_val (LB_aux (lb, annot)) -> - let rewrap lb = DEF_val (LB_aux (lb, annot)) in - begin - match lb with - | LB_val (pat, exp) -> - rewrap (LB_val (pat, n_exp_term (effectful exp) exp)) - end - | DEF_fundef fdef -> DEF_fundef (rewrite_fun rewriters fdef) - | DEF_internal_mutrec fdefs -> - DEF_internal_mutrec (List.map (rewrite_fun rewriters) fdefs) - | d -> d in - rewrite_defs_base - {rewrite_exp = rewrite_exp - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - -let rewrite_defs_effectful_let_expressions = - - let rec pat_of_local_lexp (LEXP_aux (lexp, ((l, _) as annot))) = match lexp with - | LEXP_id id -> P_aux (P_id id, annot) - | LEXP_cast (typ, id) -> P_aux (P_typ (typ, P_aux (P_id id, annot)), annot) - | LEXP_tup lexps -> P_aux (P_tup (List.map pat_of_local_lexp lexps), annot) - | _ -> raise (Reporting_basic.err_unreachable l "unexpected local lexp") in - - let e_let (lb,body) = - match lb with - | LB_aux (LB_val (P_aux (P_wild, _), E_aux (E_assign ((LEXP_aux (_, annot) as le), exp), _)), _) - when lexp_is_local le (env_of_annot annot) && not (lexp_is_effectful le) -> - (* Rewrite assignments to local variables into let bindings *) - let (lhs, rhs) = rewrite_local_lexp le in - E_let (LB_aux (LB_val (pat_of_local_lexp lhs, rhs exp), annot), body) - | LB_aux (LB_val (pat,exp'),annot') -> - if effectful exp' - then E_internal_plet (pat,exp',body) - else E_let (lb,body) in - - let e_internal_let = fun (lexp,exp1,exp2) -> - match lexp with - | LEXP_aux (LEXP_id id,annot) - | LEXP_aux (LEXP_cast (_,id),annot) -> - if effectful exp1 then - E_internal_plet (P_aux (P_id id,annot),exp1,exp2) - else - let lb = LB_aux (LB_val (P_aux (P_id id,annot), exp1), annot) in - E_let (lb, exp2) - | _ -> failwith "E_internal_let with unexpected lexp" in - - let alg = { id_exp_alg with e_let = e_let; e_internal_let = e_internal_let } in - rewrite_defs_base - { rewrite_exp = (fun _ -> fold_exp alg) - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - - -(* Now all expressions have no blocks anymore, any term is a sequence of let-expressions, - * internal let-expressions, or internal plet-expressions ended by a term that does not - * access memory or registers and does not update variables *) - -let dedup eq = - List.fold_left (fun acc e -> if List.exists (eq e) acc then acc else e :: acc) [] - -let eqidtyp (id1,_) (id2,_) = - let name1 = match id1 with Id_aux ((Id name | DeIid name),_) -> name in - let name2 = match id2 with Id_aux ((Id name | DeIid name),_) -> name in - name1 = name2 - -let find_introduced_vars exp = - let e_aux ((ids,e_aux),annot) = - let ids = match e_aux, annot with - | E_internal_let (LEXP_aux (LEXP_id id, _), _, _), (_, Some (env, _, _)) - | E_internal_let (LEXP_aux (LEXP_cast (_, id), _), _, _), (_, Some (env, _, _)) - when id_is_unbound id env -> IdSet.add id ids - | _ -> ids in - (ids, E_aux (e_aux, annot)) in - fst (fold_exp - { (compute_exp_alg IdSet.empty IdSet.union) with e_aux = e_aux } exp) - -let find_updated_vars exp = - let intros = find_introduced_vars exp in - let e_aux ((ids,e_aux),annot) = - let ids = match e_aux, annot with - | E_assign (LEXP_aux (LEXP_id id, _), _), (_, Some (env, _, _)) - | E_assign (LEXP_aux (LEXP_cast (_, id), _), _), (_, Some (env, _, _)) - when id_is_local_var id env && not (IdSet.mem id intros) -> - (id, annot) :: ids - | _ -> ids in - (ids, E_aux (e_aux, annot)) in - dedup eqidtyp (fst (fold_exp - { (compute_exp_alg [] (@)) with e_aux = e_aux } exp)) - -let swaptyp typ (l,tannot) = match tannot with - | Some (env, typ', eff) -> (l, Some (env, typ, eff)) - | _ -> raise (Reporting_basic.err_unreachable l "swaptyp called with empty type annotation") - -let mktup l es = - match es with - | [] -> annot_exp (E_lit (mk_lit L_unit)) (gen_loc l) Env.empty unit_typ - | [e] -> e - | e :: _ -> - let typ = mk_typ (Typ_tup (List.map typ_of es)) in - propagate_exp_effect (annot_exp (E_tuple es) (gen_loc l) (env_of e) typ) - -let mktup_pat l es = - match es with - | [] -> annot_pat P_wild (gen_loc l) Env.empty unit_typ - | [E_aux (E_id id,_) as exp] -> - annot_pat (P_id id) (gen_loc l) (env_of exp) (typ_of exp) - | exp :: _ -> - let typ = mk_typ (Typ_tup (List.map typ_of es)) in - let pats = List.map (function - | (E_aux (E_id id,_) as exp) -> - annot_pat (P_id id) (gen_loc l) (env_of exp) (typ_of exp) - | exp -> - annot_pat P_wild (gen_loc l) (env_of exp) (typ_of exp)) es in - annot_pat (P_tup pats) (gen_loc l) (env_of exp) typ - - -type 'a updated_term = - | Added_vars of 'a exp * 'a pat - | Same_vars of 'a exp - -let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = - - let env = env_of exp in - - let rec add_vars overwrite ((E_aux (expaux,annot)) as exp) vars = - match expaux with - | E_let (lb,exp) -> - let exp = add_vars overwrite exp vars in - E_aux (E_let (lb,exp),swaptyp (typ_of exp) annot) - | E_internal_let (lexp,exp1,exp2) -> - let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_let (lexp,exp1,exp2), swaptyp (typ_of exp2) annot) - | E_internal_plet (pat,exp1,exp2) -> - let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_plet (pat,exp1,exp2), swaptyp (typ_of exp2) annot) - | E_internal_return exp2 -> - let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_return exp2,swaptyp (typ_of exp2) annot) - | _ -> - (* after rewrite_defs_letbind_effects there cannot be terms that have - effects/update local variables in "tail-position": check n_exp_term - and where it is used. *) - if overwrite then - match typ_of exp with - | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> vars - | _ -> raise (Reporting_basic.err_unreachable l - "add_vars: trying to overwrite a non-unit expression in tail-position") - else - let typ' = Typ_aux (Typ_tup [typ_of exp;typ_of vars], gen_loc l) in - E_aux (E_tuple [exp;vars],swaptyp typ' annot) in - - let rewrite (E_aux (expaux,((el,_) as annot))) (P_aux (_,(pl,pannot)) as pat) = - let overwrite = match typ_of_annot annot with - | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> true - | _ -> false in - match expaux with - | E_for(id,exp1,exp2,exp3,order,exp4) -> - (* Translate for loops into calls to one of the foreach combinators. - The loop body becomes a function of the loop variable and any - mutable local variables that are updated inside the loop. - Since the foreach* combinators are higher-order functions, - they cannot be represented faithfully in the AST. The following - code abuses the parameters of an E_app node, embedding the loop body - function as an expression followed by the list of variables it - expects. In (Lem) pretty-printing, this turned into an anonymous - function and passed to foreach*. *) - let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) (find_updated_vars exp4) in - let vartuple = mktup el vars in - let exp4 = rewrite_var_updates (add_vars overwrite exp4 vartuple) in - let (E_aux (_,(_,annot4))) = exp4 in - let fname = match effectful exp4,order with - | false, Ord_aux (Ord_inc,_) -> "foreach_inc" - | false, Ord_aux (Ord_dec,_) -> "foreach_dec" - | true, Ord_aux (Ord_inc,_) -> "foreachM_inc" - | true, Ord_aux (Ord_dec,_) -> "foreachM_dec" - | _ -> raise (Reporting_basic.err_unreachable el - "Could not determine foreach combinator") in - let funcl = Id_aux (Id fname,gen_loc el) in - let loopvar = - (* Don't bother with creating a range type annotation, since the - Lem pretty-printing does not use it. *) - (* let (bf,tf) = match typ_of exp1 with - | {t = Tapp ("atom",[TA_nexp f])} -> (TA_nexp f,TA_nexp f) - | {t = Tapp ("reg", [TA_typ {t = Tapp ("atom",[TA_nexp f])}])} -> (TA_nexp f,TA_nexp f) - | {t = Tapp ("range",[TA_nexp bf;TA_nexp tf])} -> (TA_nexp bf,TA_nexp tf) - | {t = Tapp ("reg", [TA_typ {t = Tapp ("range",[TA_nexp bf;TA_nexp tf])}])} -> (TA_nexp bf,TA_nexp tf) - | {t = Tapp (name,_)} -> failwith (name ^ " shouldn't be here") in - let (bt,tt) = match typ_of exp2 with - | {t = Tapp ("atom",[TA_nexp t])} -> (TA_nexp t,TA_nexp t) - | {t = Tapp ("atom",[TA_typ {t = Tapp ("atom", [TA_nexp t])}])} -> (TA_nexp t,TA_nexp t) - | {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])} -> (TA_nexp bt,TA_nexp tt) - | {t = Tapp ("atom",[TA_typ {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])}])} -> (TA_nexp bt,TA_nexp tt) - | {t = Tapp (name,_)} -> failwith (name ^ " shouldn't be here") in - let t = {t = Tapp ("range",match order with - | Ord_aux (Ord_inc,_) -> [bf;tt] - | Ord_aux (Ord_dec,_) -> [tf;bt])} in *) - annot_exp (E_id id) l env int_typ in - let v = E_aux (E_app (funcl,[loopvar;mktup el [exp1;exp2;exp3];exp4;vartuple]), - (gen_loc el, annot4)) in - let pat = - if overwrite then mktup_pat el vars - else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in - Added_vars (v,pat) - | E_loop(loop,cond,body) -> - let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) (find_updated_vars body) in - let vartuple = mktup el vars in - (* let cond = rewrite_var_updates (add_vars false cond vartuple) in *) - let body = rewrite_var_updates (add_vars overwrite body vartuple) in - let (E_aux (_,(_,bannot))) = body in - let fname = match loop, effectful cond, effectful body with - | While, false, false -> "while_PP" - | While, false, true -> "while_PM" - | While, true, false -> "while_MP" - | While, true, true -> "while_MM" - | Until, false, false -> "until_PP" - | Until, false, true -> "until_PM" - | Until, true, false -> "until_MP" - | Until, true, true -> "until_MM" in - let funcl = Id_aux (Id fname,gen_loc el) in - let v = E_aux (E_app (funcl,[cond;body;vartuple]), (gen_loc el, bannot)) in - let pat = - if overwrite then mktup_pat el vars - else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in - Added_vars (v,pat) - | E_if (c,e1,e2) -> - let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) - (dedup eqidtyp (find_updated_vars e1 @ find_updated_vars e2)) in - if vars = [] then - (Same_vars (E_aux (E_if (c,rewrite_var_updates e1,rewrite_var_updates e2),annot))) - else - let vartuple = mktup el vars in - let e1 = rewrite_var_updates (add_vars overwrite e1 vartuple) in - let e2 = rewrite_var_updates (add_vars overwrite e2 vartuple) in - (* after rewrite_defs_letbind_effects c has no variable updates *) - let env = env_of_annot annot in - let typ = typ_of e1 in - let eff = union_eff_exps [e1;e2] in - let v = E_aux (E_if (c,e1,e2), (gen_loc el, Some (env, typ, eff))) in - let pat = - if overwrite then mktup_pat el vars - else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in - Added_vars (v,pat) - | E_case (e1,ps) -> - (* after rewrite_defs_letbind_effects e1 needs no rewriting *) - let vars = - let f acc (Pat_aux ((Pat_exp (_,e)|Pat_when (_,_,e)),_)) = - acc @ find_updated_vars e in - List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) - (dedup eqidtyp (List.fold_left f [] ps)) in - if vars = [] then - let ps = List.map (function - | Pat_aux (Pat_exp (p,e),a) -> - Pat_aux (Pat_exp (p,rewrite_var_updates e),a) - | Pat_aux (Pat_when (p,g,e),a) -> - Pat_aux (Pat_when (p,g,rewrite_var_updates e),a)) ps in - Same_vars (E_aux (E_case (e1,ps),annot)) - else - let vartuple = mktup el vars in - let rewrite_pexp (Pat_aux (pexp, (l, _))) = match pexp with - | Pat_exp (pat, exp) -> - let exp = rewrite_var_updates (add_vars overwrite exp vartuple) in - let pannot = (l, Some (env_of exp, typ_of exp, effect_of exp)) in - Pat_aux (Pat_exp (pat, exp), pannot) - | Pat_when _ -> - raise (Reporting_basic.err_unreachable l - "Guarded patterns should have been rewritten already") in - let typ = match ps with - | Pat_aux ((Pat_exp (_,first)|Pat_when (_,_,first)),_) :: _ -> typ_of first - | _ -> unit_typ in - let v = propagate_exp_effect (annot_exp (E_case (e1, List.map rewrite_pexp ps)) pl env typ) in - (* let (ps,typ,effs) = - let f (acc,typ,effs) (Pat_aux (Pat_exp (p,e),pannot)) = - let etyp = typ_of e in - let () = assert (string_of_typ etyp = string_of_typ typ) in - let e = rewrite_var_updates (add_vars overwrite e vartuple) in - let pannot = simple_annot pl (typ_of e) in - let effs = union_effects effs (effect_of e) in - let pat' = Pat_aux (Pat_exp (p,e),pannot) in - (acc @ [pat'],typ,effs) in - List.fold_left f ([],typ,no_effect) ps in - let v = E_aux (E_case (e1,ps), (gen_loc pl, Some (env_of_annot annot, typ, effs))) in *) - let pat = - if overwrite then mktup_pat el vars - else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in - Added_vars (v,pat) - | E_assign (lexp,vexp) -> - let effs = match effect_of_annot (snd annot) with - | Effect_aux (Effect_set effs, _) -> effs - | _ -> - raise (Reporting_basic.err_unreachable l - "assignment without effects annotation") in - if effectful exp then - Same_vars (E_aux (E_assign (lexp,vexp),annot)) - else - (match lexp with - | LEXP_aux (LEXP_id id,annot) -> - let pat = annot_pat (P_id id) pl env (typ_of vexp) in - Added_vars (vexp,pat) - | LEXP_aux (LEXP_cast (_,id),annot) -> - let pat = annot_pat (P_id id) pl env (typ_of vexp) in - Added_vars (vexp,pat) - | LEXP_aux (LEXP_vector (LEXP_aux (LEXP_id id,((l2,_) as annot2)),i),((l1,_) as annot)) -> - let eid = annot_exp (E_id id) l2 env (typ_of_annot annot2) in - let vexp = annot_exp (E_vector_update (eid,i,vexp)) l1 env (typ_of_annot annot) in - let pat = annot_pat (P_id id) pl env (typ_of vexp) in - Added_vars (vexp,pat) - | LEXP_aux (LEXP_vector_range (LEXP_aux (LEXP_id id,((l2,_) as annot2)),i,j), - ((l,_) as annot)) -> - let eid = annot_exp (E_id id) l2 env (typ_of_annot annot2) in - let vexp = annot_exp (E_vector_update_subrange (eid,i,j,vexp)) l env (typ_of_annot annot) in - let pat = annot_pat (P_id id) pl env (typ_of vexp) in - Added_vars (vexp,pat) - | _ -> Same_vars (E_aux (E_assign (lexp,vexp),annot))) - | _ -> - (* after rewrite_defs_letbind_effects this expression is pure and updates - no variables: check n_exp_term and where it's used. *) - Same_vars (E_aux (expaux,annot)) in - - match expaux with - | E_let (lb,body) -> - let body = rewrite_var_updates body in - let (LB_aux (LB_val (pat, v), lbannot)) = lb in - let lb = match rewrite v pat with - | Added_vars (v, P_aux (pat, _)) -> - annot_letbind (pat, v) (get_loc_exp v) env (typ_of v) - | Same_vars v -> LB_aux (LB_val (pat, v),lbannot) in - propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) - | E_internal_let (lexp,v,body) -> - (* Rewrite E_internal_let into E_let and call recursively *) - let id = match lexp with - | LEXP_aux (LEXP_id id,_) -> id - | LEXP_aux (LEXP_cast (_,id),_) -> id - | _ -> - raise (Reporting_basic.err_unreachable l - "E_internal_let with a lexp that is not a variable") in - let pat = annot_pat (P_id id) l env (typ_of v) in - let lb = annot_letbind (P_id id, v) l env (typ_of v) in - let exp = propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) in - rewrite_var_updates exp - (* let env = env_of_annot annot in - let vtyp = typ_of v in - let veff = effect_of v in - let bodyenv = env_of body in - let bodytyp = typ_of body in - let bodyeff = effect_of body in - let pat = P_aux (P_id id, (simple_annot l vtyp)) in - let lbannot = (gen_loc l, Some (env, vtyp, veff)) in - let lb = LB_aux (LB_val (pat,v),lbannot) in - let exp = E_aux (E_let (lb,body),(gen_loc l, Some (bodyenv, bodytyp, union_effects veff bodyeff))) in - rewrite_var_updates exp *) - | E_internal_plet (pat,v,body) -> - failwith "rewrite_var_updates: E_internal_plet shouldn't be introduced yet" - (* There are no expressions that have effects or variable updates in - "tail-position": check the definition nexp_term and where it is used. *) - | _ -> exp - -let replace_memwrite_e_assign exp = - let e_aux = fun (expaux,annot) -> - match expaux with - | E_assign (LEXP_aux (LEXP_memory (id,args),_),v) -> E_aux (E_app (id,args @ [v]),annot) - | _ -> E_aux (expaux,annot) in - fold_exp { id_exp_alg with e_aux = e_aux } exp - - - -let remove_reference_types exp = - - let rec rewrite_t (Typ_aux (t_aux,a)) = (Typ_aux (rewrite_t_aux t_aux,a)) - and rewrite_t_aux t_aux = match t_aux with - | Typ_app (Id_aux (Id "reg",_), [Typ_arg_aux (Typ_arg_typ (Typ_aux (t_aux2, _)), _)]) -> - rewrite_t_aux t_aux2 - | Typ_app (name,t_args) -> Typ_app (name,List.map rewrite_t_arg t_args) - | Typ_fn (t1,t2,eff) -> Typ_fn (rewrite_t t1,rewrite_t t2,eff) - | Typ_tup ts -> Typ_tup (List.map rewrite_t ts) - | _ -> t_aux - and rewrite_t_arg t_arg = match t_arg with - | Typ_arg_aux (Typ_arg_typ t, a) -> Typ_arg_aux (Typ_arg_typ (rewrite_t t), a) - | _ -> t_arg in - - let rec rewrite_annot = function - | (l, None) -> (l, None) - | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_t typ, eff)) in - - map_exp_annot rewrite_annot exp - - - -let rewrite_defs_remove_superfluous_letbinds = - - let e_aux (exp,annot) = match exp with - | E_let (lb,exp2) -> - begin match lb,exp2 with - (* 'let x = EXP1 in x' can be replaced with 'EXP1' *) - | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_id (Id_aux (id',_)),_) - | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_cast (_,E_aux (E_id (Id_aux (id',_)),_)),_) - when id = id' -> - exp1 - (* "let x = EXP1 in return x" can be replaced with 'return (EXP1)', at - least when EXP1 is 'small' enough *) - | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) - when id = id' && small exp1 -> - let (E_aux (_,e1annot)) = exp1 in - E_aux (E_internal_return (exp1),e1annot) - | _ -> E_aux (exp,annot) - end - | _ -> E_aux (exp,annot) in - - let alg = { id_exp_alg with e_aux = e_aux } in - rewrite_defs_base - { rewrite_exp = (fun _ -> fold_exp alg) - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - - -let rewrite_defs_remove_superfluous_returns = - - let has_unittype e = match typ_of e with - | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> true - | _ -> false in - - let e_aux (exp,annot) = match exp with - | E_internal_plet (pat,exp1,exp2) when effectful exp1 -> - begin match pat,exp2 with - | P_aux (P_lit (L_aux (lit,_)),_), - E_aux (E_internal_return (E_aux (E_lit (L_aux (lit',_)),_)),_) - when lit = lit' -> - exp1 - | P_aux (P_wild,pannot), - E_aux (E_internal_return (E_aux (E_lit (L_aux (L_unit,_)),_)),_) - when has_unittype exp1 -> - exp1 - | P_aux (P_id (Id_aux (id,_)),_), - E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) - when id = id' -> - exp1 - | _ -> E_aux (exp,annot) - end - | _ -> E_aux (exp,annot) in - - let alg = { id_exp_alg with e_aux = e_aux } in - rewrite_defs_base - { rewrite_exp = (fun _ -> fold_exp alg) - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - - -let rewrite_defs_remove_e_assign = - let rewrite_exp _ e = - replace_memwrite_e_assign (remove_reference_types (rewrite_var_updates e)) in - rewrite_defs_base - { rewrite_exp = rewrite_exp - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - -let recheck_defs defs = fst (check initial_env defs) - -let rewrite_defs_lem = [ - ("top_sort_defs", top_sort_defs); - ("tuple_vector_assignments", rewrite_tuple_vector_assignments); - ("tuple_assignments", rewrite_tuple_assignments); - (* ("simple_assignments", rewrite_simple_assignments); *) - ("constraint", rewrite_constraint); - ("trivial_sizeof", rewrite_trivial_sizeof); - ("sizeof", rewrite_sizeof); - ("remove_vector_concat", rewrite_defs_remove_vector_concat); - ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); - ("guarded_pats", rewrite_defs_guarded_pats); - (* ("recheck_defs", recheck_defs); *) - ("early_return", rewrite_defs_early_return); - ("nexp_ids", rewrite_defs_nexp_ids); - ("fix_val_specs", rewrite_fix_val_specs); - ("exp_lift_assign", rewrite_defs_exp_lift_assign); - ("remove_blocks", rewrite_defs_remove_blocks); - ("letbind_effects", rewrite_defs_letbind_effects); - ("remove_e_assign", rewrite_defs_remove_e_assign); - ("effectful_let_expressions", rewrite_defs_effectful_let_expressions); - ("remove_superfluous_letbinds", rewrite_defs_remove_superfluous_letbinds); - ("remove_superfluous_returns", rewrite_defs_remove_superfluous_returns) - ] - -let rewrite_defs_ocaml = [ - (* ("top_sort_defs", top_sort_defs); *) - (* ("undefined", rewrite_undefined); *) - ("tuple_vector_assignments", rewrite_tuple_vector_assignments); - ("tuple_assignments", rewrite_tuple_assignments); - ("simple_assignments", rewrite_simple_assignments); - ("remove_vector_concat", rewrite_defs_remove_vector_concat); - ("constraint", rewrite_constraint); - ("trivial_sizeof", rewrite_trivial_sizeof); - ("sizeof", rewrite_sizeof); - ("simple_types", rewrite_simple_types); - ("overload_cast", rewrite_overload_cast); - ("exp_lift_assign", rewrite_defs_exp_lift_assign); - (* ("separate_numbs", rewrite_defs_separate_numbs) *) - ] - -let rewrite_check_annot = - let check_annot exp = - try - prerr_endline ("CHECKING: " ^ string_of_exp exp ^ " : " ^ string_of_typ (typ_of exp)); - let _ = check_exp (env_of exp) (strip_exp exp) (typ_of exp) in - exp - with - Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) - in - let rewrite_exp = { id_exp_alg with e_aux = (fun (exp, annot) -> check_annot (E_aux (exp, annot))) } in - rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp) } - -let rewrite_defs_check = [ - ("check_annotations", rewrite_check_annot); - ] diff --git a/src/rewriter.mli b/src/rewriter.mli index c107be25..514ed034 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -55,13 +55,23 @@ type 'a rewriters = { rewrite_exp : 'a rewriters -> 'a exp -> 'a exp; } val rewrite_exp : tannot rewriters -> tannot exp -> tannot exp + +val rewriters_base : tannot rewriters + +(* The identity re-writer *) val rewrite_defs : tannot defs -> tannot defs -val rewrite_undefined : bool -> tannot defs -> tannot defs -val rewrite_defs_ocaml : (string * (tannot defs -> tannot defs)) list (*Perform rewrites to exclude AST nodes not supported for ocaml out*) -val rewrite_defs_lem : (string * (tannot defs -> tannot defs)) list (*Perform rewrites to exclude AST nodes not supported for lem out*) -val rewrite_defs_check : (string * (tannot defs -> tannot defs)) list -val simple_typ : typ -> typ +val rewrite_defs_base : tannot rewriters -> tannot defs -> tannot defs + +val rewrite_lexp : tannot rewriters -> tannot lexp -> tannot lexp + +val rewrite_pat : tannot rewriters -> tannot pat -> tannot pat + +val rewrite_let : tannot rewriters -> tannot letbind -> tannot letbind + +val rewrite_def : tannot rewriters -> tannot def -> tannot def + +val rewrite_fun : tannot rewriters -> tannot fundef -> tannot fundef (* the type of interpretations of pattern-matching expressions *) type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = @@ -82,10 +92,8 @@ type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = ; fP_aux : 'fpat_aux * 'a annot -> 'fpat ; fP_Fpat : id * 'pat -> 'fpat_aux } - (* fold over pat_aux expressions *) - (* the type of interpretations of expressions *) type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, @@ -177,3 +185,24 @@ val compute_exp_alg : 'b -> ('b -> 'b -> 'b) -> ('b * 'a opt_default_aux),('b * 'a opt_default),('b * 'a pexp),('b * 'a pexp_aux), ('b * 'a letbind_aux),('b * 'a letbind), ('b * 'a pat),('b * 'a pat_aux),('b * 'a fpat),('b * 'a fpat_aux)) exp_alg + +val simple_annot : Parse_ast.l -> typ -> Parse_ast.l * tannot + +val union_eff_exps : (tannot exp) list -> effect + +val fix_eff_exp : tannot exp -> tannot exp + +val fix_eff_lexp : tannot lexp -> tannot lexp + +val fix_eff_lb : tannot letbind -> tannot letbind + +val fix_eff_pexp : tannot pexp -> tannot pexp + +val fix_eff_fexp : tannot fexp -> tannot fexp + +val fix_eff_fexps : tannot fexps -> tannot fexps + +val fix_eff_opt_default : tannot opt_default -> tannot opt_default + +(* AA: How this is used in rewrite_pat seems suspect to me *) +val vector_string_to_bit_list : Parse_ast.l -> lit_aux -> lit list diff --git a/src/rewrites.ml b/src/rewrites.ml new file mode 100644 index 00000000..74f252f4 --- /dev/null +++ b/src/rewrites.ml @@ -0,0 +1,2767 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Thomas Bauereiss *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Big_int +open Ast +open Ast_util +open Type_check +open Spec_analysis +open Rewriter + +let (>>) f g = fun x -> g(f(x)) + +let fresh_name_counter = ref 0 + +let fresh_name () = + let current = !fresh_name_counter in + let () = fresh_name_counter := (current + 1) in + current + +let reset_fresh_name_counter () = + fresh_name_counter := 0 + +let fresh_id pre l = + let current = fresh_name () in + Id_aux (Id (pre ^ string_of_int current), gen_loc l) + +let fresh_id_exp pre ((l,annot)) = + let id = fresh_id pre l in + E_aux (E_id id, (gen_loc l, annot)) + +let fresh_id_pat pre ((l,annot)) = + let id = fresh_id pre l in + P_aux (P_id id, (gen_loc l, annot)) + +let get_loc_exp (E_aux (_,(l,_))) = l + +let annot_exp_effect e_aux l env typ effect = E_aux (e_aux, (l, Some (env, typ, effect))) +let annot_exp e_aux l env typ = annot_exp_effect e_aux l env typ no_effect +let annot_pat p_aux l env typ = P_aux (p_aux, (l, Some (env, typ, no_effect))) +let annot_letbind (p_aux, exp) l env typ = + LB_aux (LB_val (annot_pat p_aux l env typ, exp), (l, Some (env, typ, effect_of exp))) + +let simple_num l n = E_aux ( + E_lit (L_aux (L_num n, gen_loc l)), + simple_annot (gen_loc l) + (atom_typ (Nexp_aux (Nexp_constant n, gen_loc l)))) + +let effectful_effs = function + | Effect_aux (Effect_set effs, _) -> + List.exists + (fun (BE_aux (be,_)) -> + match be with + | BE_nondet | BE_unspec | BE_undef | BE_lset -> false + | _ -> true + ) effs + | _ -> true + +let effectful eaux = effectful_effs (effect_of (propagate_exp_effect eaux)) +let effectful_pexp pexp = effectful_effs (snd (propagate_pexp_effect pexp)) + +let updates_vars_effs = function + | Effect_aux (Effect_set effs, _) -> + List.exists + (fun (BE_aux (be,_)) -> + match be with + | BE_lset -> true + | _ -> false + ) effs + | _ -> true + +let updates_vars eaux = updates_vars_effs (effect_of eaux) + +let rec small (E_aux (exp,_)) = match exp with + | E_id _ + | E_lit _ -> true + | E_cast (_,e) -> small e + | E_list es -> List.for_all small es + | E_cons (e1,e2) -> small e1 && small e2 + | E_sizeof _ -> true + | _ -> false + +let rec rewrite_nexp_ids env (Nexp_aux (nexp, l) as nexp_aux) = match nexp with +| Nexp_id id -> rewrite_nexp_ids env (Env.get_num_def id env) +| Nexp_times (nexp1, nexp2) -> Nexp_aux (Nexp_times (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) +| Nexp_sum (nexp1, nexp2) -> Nexp_aux (Nexp_sum (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) +| Nexp_minus (nexp1, nexp2) -> Nexp_aux (Nexp_minus (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) +| Nexp_exp nexp -> Nexp_aux (Nexp_exp (rewrite_nexp_ids env nexp), l) +| Nexp_neg nexp -> Nexp_aux (Nexp_neg (rewrite_nexp_ids env nexp), l) +| _ -> nexp_aux + +let rewrite_defs_nexp_ids, rewrite_typ_nexp_ids = + let rec rewrite_typ env (Typ_aux (typ, l) as typ_aux) = match typ with + | Typ_fn (arg_t, ret_t, eff) -> + Typ_aux (Typ_fn (rewrite_typ env arg_t, rewrite_typ env ret_t, eff), l) + | Typ_tup ts -> + Typ_aux (Typ_tup (List.map (rewrite_typ env) ts), l) + | Typ_exist (kids, c, typ) -> + Typ_aux (Typ_exist (kids, c, rewrite_typ env typ), l) + | Typ_app (id, targs) -> + Typ_aux (Typ_app (id, List.map (rewrite_typ_arg env) targs), l) + | _ -> typ_aux + and rewrite_typ_arg env (Typ_arg_aux (targ, l) as targ_aux) = match targ with + | Typ_arg_nexp nexp -> + Typ_arg_aux (Typ_arg_nexp (rewrite_nexp_ids env nexp), l) + | Typ_arg_typ typ -> + Typ_arg_aux (Typ_arg_typ (rewrite_typ env typ), l) + | Typ_arg_order ord -> + Typ_arg_aux (Typ_arg_order ord, l) + in + + let rewrite_annot = function + | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_typ env typ, eff)) + | (l, None) -> (l, None) + in + + rewrite_defs_base { + rewriters_base with rewrite_exp = (fun _ -> map_exp_annot rewrite_annot) + }, + rewrite_typ + + +(* Re-write trivial sizeof expressions - trivial meaning that the + value of the sizeof can be directly inferred from the type + variables in scope. *) +let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = + let extract_typ_var l env nexp (id, (_, typ)) = + let var = E_aux (E_id id, (l, Some (env, typ, no_effect))) in + match destruct_atom_nexp env typ with + | Some size when prove env (nc_eq size nexp) -> Some var + | _ -> + begin + match destruct_vector env typ with + | Some (_, len, _, _) when prove env (nc_eq len nexp) -> + Some (E_aux (E_app (mk_id "length", [var]), (l, Some (env, atom_typ len, no_effect)))) + | _ -> None + end + in + let rec split_nexp (Nexp_aux (nexp_aux, l) as nexp) = + match nexp_aux with + | Nexp_sum (n1, n2) -> + mk_exp (E_app (mk_id "add_range", [split_nexp n1; split_nexp n2])) + | Nexp_minus (n1, n2) -> + mk_exp (E_app (mk_id "sub_range", [split_nexp n1; split_nexp n2])) + | Nexp_times (n1, n2) -> + mk_exp (E_app (mk_id "mult_range", [split_nexp n1; split_nexp n2])) + | Nexp_neg nexp -> mk_exp (E_app (mk_id "negate_range", [split_nexp nexp])) + | _ -> mk_exp (E_sizeof nexp) + in + let rec rewrite_e_aux split_sizeof (E_aux (e_aux, (l, _)) as orig_exp) = + let env = env_of orig_exp in + match e_aux with + | E_sizeof (Nexp_aux (Nexp_constant c, _) as nexp) -> + E_aux (E_lit (L_aux (L_num c, l)), (l, Some (env, atom_typ nexp, no_effect))) + | E_sizeof nexp -> + begin + match nexp_simp (rewrite_nexp_ids (env_of orig_exp) nexp) with + | Nexp_aux (Nexp_constant c, _) -> + E_aux (E_lit (L_aux (L_num c, l)), (l, Some (env, atom_typ nexp, no_effect))) + | _ -> + let locals = Env.get_locals env in + let exps = Bindings.bindings locals + |> List.map (extract_typ_var l env nexp) + |> List.map (fun opt -> match opt with Some x -> [x] | None -> []) + |> List.concat + in + match exps with + | (exp :: _) -> check_exp env (strip_exp exp) (typ_of exp) + | [] when split_sizeof -> + fold_exp (rewrite_e_sizeof false) (check_exp env (split_nexp nexp) (typ_of orig_exp)) + | [] -> orig_exp + end + | _ -> orig_exp + and rewrite_e_sizeof split_sizeof = + { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux split_sizeof (E_aux (exp, annot))) } + in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rewrite_e_sizeof true)) }, rewrite_e_aux true + +(* Rewrite sizeof expressions with type-level variables to + term-level expressions + + For each type-level variable used in a sizeof expressions whose value cannot + be directly extracted from existing parameters of the surrounding function, + a further parameter is added; calls to the function are rewritten + accordingly (possibly causing further rewriting in the calling function) *) +let rewrite_sizeof (Defs defs) = + let sizeof_frees exp = + fst (fold_exp + { (compute_exp_alg KidSet.empty KidSet.union) with + e_sizeof = (fun nexp -> (nexp_frees nexp, E_sizeof nexp)) } + exp) in + + (* Collect nexps whose values can be obtained directly from a pattern bind *) + let nexps_from_params pat = + fst (fold_pat + { (compute_pat_alg [] (@)) with + p_aux = (fun ((v,pat),((l,_) as annot)) -> + let v' = match pat with + | P_id id | P_as (_, id) -> + let (Typ_aux (typ,_) as typ_aux) = typ_of_annot annot in + (match typ with + | Typ_app (atom, [Typ_arg_aux (Typ_arg_nexp nexp, _)]) + when string_of_id atom = "atom" -> + [nexp, E_id id] + | Typ_app (vector, _) when string_of_id vector = "vector" -> + let id_length = Id_aux (Id "length", gen_loc l) in + (try + (match Env.get_val_spec id_length (env_of_annot annot) with + | _ -> + let (_,len,_,_) = vector_typ_args_of typ_aux in + let exp = E_app (id_length, [E_aux (E_id id, annot)]) in + [len, exp]) + with + | _ -> []) + | _ -> []) + | _ -> [] in + (v @ v', P_aux (pat,annot)))} pat) in + + (* Substitute collected values in sizeof expressions *) + let rec e_sizeof nmap (Nexp_aux (nexp, l) as nexp_aux) = + try snd (List.find (fun (nexp,_) -> nexp_identical nexp nexp_aux) nmap) + with + | Not_found -> + let binop nexp1 op nexp2 = E_app_infix ( + E_aux (e_sizeof nmap nexp1, simple_annot l (atom_typ nexp1)), + Id_aux (Id op, Parse_ast.Unknown), + E_aux (e_sizeof nmap nexp2, simple_annot l (atom_typ nexp2)) + ) in + let (Nexp_aux (nexp, l) as nexp_aux) = nexp_simp nexp_aux in + (match nexp with + | Nexp_constant i -> E_lit (L_aux (L_num i, l)) + | Nexp_times (nexp1, nexp2) -> binop nexp1 "*" nexp2 + | Nexp_sum (nexp1, nexp2) -> binop nexp1 "+" nexp2 + | Nexp_minus (nexp1, nexp2) -> binop nexp1 "-" nexp2 + | _ -> E_sizeof nexp_aux) in + + let ex_regex = Str.regexp "'ex[0-9]+" in + + (* Rewrite calls to functions which have had parameters added to pass values + of type-level variables; these are added as sizeof expressions first, and + then further rewritten as above. *) + let e_app_aux param_map ((exp, exp_orig), ((l, _) as annot)) = + let env = env_of_annot annot in + let full_exp = E_aux (exp, annot) in + let orig_exp = E_aux (exp_orig, annot) in + match exp with + | E_app (f, args) -> + if Bindings.mem f param_map then + (* Retrieve instantiation of the type variables of the called function + for the given parameters in the original environment *) + let inst = + try instantiation_of orig_exp with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err)) in + (* Rewrite the inst using orig_kid so that each type variable has it's + original name rather than a mangled typechecker name *) + let inst = KBindings.fold (fun kid uvar b -> KBindings.add (orig_kid kid) uvar b) inst KBindings.empty in + let kid_exp kid = begin + (* We really don't want to see an existential here! *) + assert (not (Str.string_match ex_regex (string_of_kid kid) 0)); + let uvar = try Some (KBindings.find (orig_kid kid) inst) with Not_found -> None in + match uvar with + | Some (U_nexp nexp) -> + let sizeof = E_aux (E_sizeof nexp, (l, Some (env, atom_typ nexp, no_effect))) in + (try rewrite_trivial_sizeof_exp sizeof with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err))) + (* If the type variable is Not_found then it was probably + introduced by a P_var pattern, so it likely exists as + a variable in scope. It can't be an existential because the assert rules that out. *) + | None -> annot_exp (E_id (id_of_kid (orig_kid kid))) l env (atom_typ (nvar (orig_kid kid))) + | _ -> + raise (Reporting_basic.err_unreachable l + ("failed to infer nexp for type variable " ^ string_of_kid kid ^ + " of function " ^ string_of_id f)) + end in + let kid_exps = List.map kid_exp (KidSet.elements (Bindings.find f param_map)) in + (E_aux (E_app (f, kid_exps @ args), annot), orig_exp) + else (full_exp, orig_exp) + | _ -> (full_exp, orig_exp) in + + (* Plug this into a folding algorithm that also keeps around a copy of the + original expressions, which we use to infer instantiations of type variables + in the original environments *) + let copy_exp_alg = + { e_block = (fun es -> let (es, es') = List.split es in (E_block es, E_block es')) + ; e_nondet = (fun es -> let (es, es') = List.split es in (E_nondet es, E_nondet es')) + ; e_id = (fun id -> (E_id id, E_id id)) + ; e_lit = (fun lit -> (E_lit lit, E_lit lit)) + ; e_cast = (fun (typ,(e,e')) -> (E_cast (typ,e), E_cast (typ,e'))) + ; e_app = (fun (id,es) -> let (es, es') = List.split es in (E_app (id,es), E_app (id,es'))) + ; e_app_infix = (fun ((e1,e1'),id,(e2,e2')) -> (E_app_infix (e1,id,e2), E_app_infix (e1',id,e2'))) + ; e_tuple = (fun es -> let (es, es') = List.split es in (E_tuple es, E_tuple es')) + ; e_if = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_if (e1,e2,e3), E_if (e1',e2',e3'))) + ; e_for = (fun (id,(e1,e1'),(e2,e2'),(e3,e3'),order,(e4,e4')) -> (E_for (id,e1,e2,e3,order,e4), E_for (id,e1',e2',e3',order,e4'))) + ; e_loop = (fun (lt, (e1, e1'), (e2, e2')) -> (E_loop (lt, e1, e2), E_loop (lt, e1', e2'))) + ; e_vector = (fun es -> let (es, es') = List.split es in (E_vector es, E_vector es')) + ; e_vector_access = (fun ((e1,e1'),(e2,e2')) -> (E_vector_access (e1,e2), E_vector_access (e1',e2'))) + ; e_vector_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_subrange (e1,e2,e3), E_vector_subrange (e1',e2',e3'))) + ; e_vector_update = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_update (e1,e2,e3), E_vector_update (e1',e2',e3'))) + ; e_vector_update_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3'),(e4,e4')) -> (E_vector_update_subrange (e1,e2,e3,e4), E_vector_update_subrange (e1',e2',e3',e4'))) + ; e_vector_append = (fun ((e1,e1'),(e2,e2')) -> (E_vector_append (e1,e2), E_vector_append (e1',e2'))) + ; e_list = (fun es -> let (es, es') = List.split es in (E_list es, E_list es')) + ; e_cons = (fun ((e1,e1'),(e2,e2')) -> (E_cons (e1,e2), E_cons (e1',e2'))) + ; e_record = (fun (fexps, fexps') -> (E_record fexps, E_record fexps')) + ; e_record_update = (fun ((e1,e1'),(fexp,fexp')) -> (E_record_update (e1,fexp), E_record_update (e1',fexp'))) + ; e_field = (fun ((e1,e1'),id) -> (E_field (e1,id), E_field (e1',id))) + ; e_case = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_case (e1,pexps), E_case (e1',pexps'))) + ; e_let = (fun ((lb,lb'),(e2,e2')) -> (E_let (lb,e2), E_let (lb',e2'))) + ; e_assign = (fun ((lexp,lexp'),(e2,e2')) -> (E_assign (lexp,e2), E_assign (lexp',e2'))) + ; e_sizeof = (fun nexp -> (E_sizeof nexp, E_sizeof nexp)) + ; e_constraint = (fun nc -> (E_constraint nc, E_constraint nc)) + ; e_exit = (fun (e1,e1') -> (E_exit (e1), E_exit (e1'))) + ; e_return = (fun (e1,e1') -> (E_return e1, E_return e1')) + ; e_assert = (fun ((e1,e1'),(e2,e2')) -> (E_assert(e1,e2), E_assert(e1',e2')) ) + ; e_internal_cast = (fun (a,(e1,e1')) -> (E_internal_cast (a,e1), E_internal_cast (a,e1'))) + ; e_internal_exp = (fun a -> (E_internal_exp a, E_internal_exp a)) + ; e_internal_exp_user = (fun (a1,a2) -> (E_internal_exp_user (a1,a2), E_internal_exp_user (a1,a2))) + ; e_comment = (fun c -> (E_comment c, E_comment c)) + ; e_comment_struc = (fun (e,e') -> (E_comment_struc e, E_comment_struc e')) + ; e_internal_let = (fun ((lexp,lexp'), (e2,e2'), (e3,e3')) -> (E_internal_let (lexp,e2,e3), E_internal_let (lexp',e2',e3'))) + ; e_internal_plet = (fun (pat, (e1,e1'), (e2,e2')) -> (E_internal_plet (pat,e1,e2), E_internal_plet (pat,e1',e2'))) + ; e_internal_return = (fun (e,e') -> (E_internal_return e, E_internal_return e')) + ; e_aux = (fun ((e,e'),annot) -> (E_aux (e,annot), E_aux (e',annot))) + ; lEXP_id = (fun id -> (LEXP_id id, LEXP_id id)) + ; lEXP_memory = (fun (id,es) -> let (es, es') = List.split es in (LEXP_memory (id,es), LEXP_memory (id,es'))) + ; lEXP_cast = (fun (typ,id) -> (LEXP_cast (typ,id), LEXP_cast (typ,id))) + ; lEXP_tup = (fun tups -> let (tups,tups') = List.split tups in (LEXP_tup tups, LEXP_tup tups')) + ; lEXP_vector = (fun ((lexp,lexp'),(e2,e2')) -> (LEXP_vector (lexp,e2), LEXP_vector (lexp',e2'))) + ; lEXP_vector_range = (fun ((lexp,lexp'),(e2,e2'),(e3,e3')) -> (LEXP_vector_range (lexp,e2,e3), LEXP_vector_range (lexp',e2',e3'))) + ; lEXP_field = (fun ((lexp,lexp'),id) -> (LEXP_field (lexp,id), LEXP_field (lexp',id))) + ; lEXP_aux = (fun ((lexp,lexp'),annot) -> (LEXP_aux (lexp,annot), LEXP_aux (lexp',annot))) + ; fE_Fexp = (fun (id,(e,e')) -> (FE_Fexp (id,e), FE_Fexp (id,e'))) + ; fE_aux = (fun ((fexp,fexp'),annot) -> (FE_aux (fexp,annot), FE_aux (fexp',annot))) + ; fES_Fexps = (fun (fexps,b) -> let (fexps, fexps') = List.split fexps in (FES_Fexps (fexps,b), FES_Fexps (fexps',b))) + ; fES_aux = (fun ((fexp,fexp'),annot) -> (FES_aux (fexp,annot), FES_aux (fexp',annot))) + ; def_val_empty = (Def_val_empty, Def_val_empty) + ; def_val_dec = (fun (e,e') -> (Def_val_dec e, Def_val_dec e')) + ; def_val_aux = (fun ((defval,defval'),aux) -> (Def_val_aux (defval,aux), Def_val_aux (defval',aux))) + ; pat_exp = (fun (pat,(e,e')) -> (Pat_exp (pat,e), Pat_exp (pat,e'))) + ; pat_when = (fun (pat,(e1,e1'),(e2,e2')) -> (Pat_when (pat,e1,e2), Pat_when (pat,e1',e2'))) + ; pat_aux = (fun ((pexp,pexp'),a) -> (Pat_aux (pexp,a), Pat_aux (pexp',a))) + ; lB_val = (fun (pat,(e,e')) -> (LB_val (pat,e), LB_val (pat,e'))) + ; lB_aux = (fun ((lb,lb'),annot) -> (LB_aux (lb,annot), LB_aux (lb',annot))) + ; pat_alg = id_pat_alg + } in + + let rewrite_sizeof_fun params_map + (FD_aux (FD_function (rec_opt,tannot,eff,funcls),((l,_) as annot))) = + let rewrite_funcl_body (FCL_aux (FCL_Funcl (id,pat,exp), annot)) (funcls,nvars) = + let body_env = env_of exp in + let body_typ = typ_of exp in + let nmap = nexps_from_params pat in + (* first rewrite calls to other functions... *) + let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in + (* ... then rewrite sizeof expressions in current function body *) + let exp'' = fold_exp { id_exp_alg with e_sizeof = e_sizeof nmap } exp' in + (FCL_aux (FCL_Funcl (id,pat,exp''), annot) :: funcls, + KidSet.union nvars (sizeof_frees exp'')) in + let (funcls, nvars) = List.fold_right rewrite_funcl_body funcls ([], KidSet.empty) in + (* Add a parameter for each remaining free type-level variable in a + sizeof expression *) + let kid_typ kid = atom_typ (nvar kid) in + let kid_annot kid = simple_annot l (kid_typ kid) in + let kid_pat kid = + P_aux (P_typ (kid_typ kid, + P_aux (P_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)), + kid_annot kid)), kid_annot kid) in + let kid_eaux kid = E_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)) in + let kid_typs = List.map kid_typ (KidSet.elements nvars) in + let kid_pats = List.map kid_pat (KidSet.elements nvars) in + let kid_nmap = List.map (fun kid -> (nvar kid, kid_eaux kid)) (KidSet.elements nvars) in + let rewrite_funcl_params (FCL_aux (FCL_Funcl (id, pat, exp), annot) as funcl) = + let rec rewrite_pat (P_aux (pat, ((l, _) as pannot)) as paux) = + let penv = env_of_annot pannot in + let peff = effect_of_annot (snd pannot) in + if KidSet.is_empty nvars then paux else + match pat_typ_of paux with + | Typ_aux (Typ_tup typs, _) -> + let ptyp' = Typ_aux (Typ_tup (kid_typs @ typs), l) in + (match pat with + | P_tup pats -> + P_aux (P_tup (kid_pats @ pats), (l, Some (penv, ptyp', peff))) + | P_wild -> P_aux (pat, (l, Some (penv, ptyp', peff))) + | P_typ (Typ_aux (Typ_tup typs, l), pat) -> + P_aux (P_typ (Typ_aux (Typ_tup (kid_typs @ typs), l), + rewrite_pat pat), (l, Some (penv, ptyp', peff))) + | P_as (_, id) | P_id id -> + (* adding parameters here would change the type of id; + we should remove the P_as/P_id here and add a let-binding to the body *) + raise (Reporting_basic.err_todo l + "rewriting as- or id-patterns for sizeof expressions not yet implemented") + | _ -> + raise (Reporting_basic.err_unreachable l + "unexpected pattern while rewriting function parameters for sizeof expressions")) + | ptyp -> + let ptyp' = Typ_aux (Typ_tup (kid_typs @ [ptyp]), l) in + P_aux (P_tup (kid_pats @ [paux]), (l, Some (penv, ptyp', peff))) in + let exp' = fold_exp { id_exp_alg with e_sizeof = e_sizeof kid_nmap } exp in + FCL_aux (FCL_Funcl (id, rewrite_pat pat, exp'), annot) in + let funcls = List.map rewrite_funcl_params funcls in + (nvars, FD_aux (FD_function (rec_opt,tannot,eff,funcls),annot)) in + + let rewrite_sizeof_def (params_map, defs) = function + | DEF_fundef fd as def -> + let (nvars, fd') = rewrite_sizeof_fun params_map fd in + let id = id_of_fundef fd in + let params_map' = + if KidSet.is_empty nvars then params_map + else Bindings.add id nvars params_map in + (params_map', defs @ [DEF_fundef fd']) + | DEF_val (LB_aux (lb, annot)) -> + begin + let lb' = match lb with + | LB_val (pat, exp) -> + let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in + LB_val (pat, exp') in + (params_map, defs @ [DEF_val (LB_aux (lb', annot))]) + end + | def -> + (params_map, defs @ [def]) in + + let rewrite_sizeof_valspec params_map def = + let rewrite_typschm (TypSchm_aux (TypSchm_ts (tq, typ), l) as ts) id = + if Bindings.mem id params_map then + let kid_typs = List.map (fun kid -> atom_typ (nvar kid)) + (KidSet.elements (Bindings.find id params_map)) in + let typ' = match typ with + | Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) -> + let vtyp_arg' = begin + match vtyp_arg with + | Typ_aux (Typ_tup typs, vl) -> + Typ_aux (Typ_tup (kid_typs @ typs), vl) + | _ -> Typ_aux (Typ_tup (kid_typs @ [vtyp_arg]), vl) + end in + Typ_aux (Typ_fn (vtyp_arg', vtyp_ret, declared_eff), vl) + | _ -> + raise (Reporting_basic.err_typ l "val spec with non-function type") in + TypSchm_aux (TypSchm_ts (tq, typ'), l) + else ts in + match def with + | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext, is_cast), a)) -> + DEF_spec (VS_aux (VS_val_spec (rewrite_typschm typschm id, id, ext, is_cast), a)) + | def -> def + in + + let (params_map, defs) = List.fold_left rewrite_sizeof_def + (Bindings.empty, []) defs in + let defs = List.map (rewrite_sizeof_valspec params_map) defs in + Defs defs + (* FIXME: Won't re-check due to flow typing and E_constraint re-write before E_sizeof re-write. + Requires the typechecker to be more smart about different representations for valid flow typing constraints. + fst (check initial_env (Defs defs)) + *) + +let remove_vector_concat_pat pat = + + (* ivc: bool that indicates whether the exp is in a vector_concat pattern *) + let remove_typed_patterns = + fold_pat { id_pat_alg with + p_aux = (function + | (P_typ (_,P_aux (p,_)),annot) + | (p,annot) -> + P_aux (p,annot) + ) + } in + + (* let pat = remove_typed_patterns pat in *) + + let fresh_id_v = fresh_id "v__" in + + (* expects that P_typ elements have been removed from AST, + that the length of all vectors involved is known, + that we don't have indexed vectors *) + + (* introduce names for all patterns of form P_vector_concat *) + let name_vector_concat_roots = + { p_lit = (fun lit -> P_lit lit) + ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) (* cannot happen *) + ; p_wild = P_wild + ; p_as = (fun (pat,id) -> P_as (pat true,id)) + ; p_id = (fun id -> P_id id) + ; p_var = (fun (pat,kid) -> P_var (pat true,kid)) + ; p_app = (fun (id,ps) -> P_app (id, List.map (fun p -> p false) ps)) + ; p_record = (fun (fpats,b) -> P_record (fpats, b)) + ; p_vector = (fun ps -> P_vector (List.map (fun p -> p false) ps)) + ; p_vector_concat = (fun ps -> P_vector_concat (List.map (fun p -> p false) ps)) + ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) + ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) + ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) + ; p_aux = + (fun (pat,((l,_) as annot)) contained_in_p_as -> + match pat with + | P_vector_concat pats -> + (if contained_in_p_as + then P_aux (pat,annot) + else P_aux (P_as (P_aux (pat,annot),fresh_id_v l),annot)) + | _ -> P_aux (pat,annot) + ) + ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) + ; fP_Fpat = (fun (id,p) -> FP_Fpat (id,p false)) + } in + + let pat = (fold_pat name_vector_concat_roots pat) false in + + (* introduce names for all unnamed child nodes of P_vector_concat *) + let name_vector_concat_elements = + let p_vector_concat pats = + let rec aux ((P_aux (p,((l,_) as a))) as pat) = match p with + | P_vector _ -> P_aux (P_as (pat,fresh_id_v l),a) + | P_id id -> P_aux (P_id id,a) + | P_as (p,id) -> P_aux (P_as (p,id),a) + | P_typ (typ, pat) -> P_aux (P_typ (typ, aux pat),a) + | P_wild -> P_aux (P_wild,a) + | _ -> + raise + (Reporting_basic.err_unreachable + l "name_vector_concat_elements: Non-vector in vector-concat pattern") in + P_vector_concat (List.map aux pats) in + {id_pat_alg with p_vector_concat = p_vector_concat} in + + let pat = fold_pat name_vector_concat_elements pat in + + + + let rec tag_last = function + | x :: xs -> let is_last = xs = [] in (x,is_last) :: tag_last xs + | _ -> [] in + + (* remove names from vectors in vector_concat patterns and collect them as declarations for the + function body or expression *) + let unname_vector_concat_elements = (* : + ('a, + 'a pat * ((tannot exp -> tannot exp) list), + 'a pat_aux * ((tannot exp -> tannot exp) list), + 'a fpat * ((tannot exp -> tannot exp) list), + 'a fpat_aux * ((tannot exp -> tannot exp) list)) + pat_alg = *) + + (* build a let-expression of the form "let child = root[i..j] in body" *) + let letbind_vec typ_opt (rootid,rannot) (child,cannot) (i,j) = + let (l,_) = cannot in + let env = env_of_annot rannot in + let rootname = string_of_id rootid in + let childname = string_of_id child in + + let root = E_aux (E_id rootid, rannot) in + let index_i = simple_num l i in + let index_j = simple_num l j in + + (* FIXME *) + let subv = fix_eff_exp (E_aux (E_vector_subrange (root, index_i, index_j), cannot)) in + (* let (_, _, ord, _) = vector_typ_args_of (Env.base_typ_of (env_of root) (typ_of root)) in + let subrange_id = if is_order_inc ord then "bitvector_subrange_inc" else "bitvector_subrange_dec" in + let subv = fix_eff_exp (E_aux (E_app (mk_id subrange_id, [root; index_i; index_j]), cannot)) in *) + + let id_pat = + match typ_opt with + | Some typ -> P_aux (P_typ (typ, P_aux (P_id child,cannot)), cannot) + | None -> P_aux (P_id child,cannot) in + let letbind = fix_eff_lb (LB_aux (LB_val (id_pat,subv),cannot)) in + (letbind, + (fun body -> fix_eff_exp (annot_exp (E_let (letbind,body)) l env (typ_of body))), + (rootname,childname)) in + + let p_aux = function + | ((P_as (P_aux (P_vector_concat pats,rannot'),rootid),decls),rannot) -> + let rtyp = Env.base_typ_of (env_of_annot rannot') (typ_of_annot rannot') in + let (start,last_idx) = (match vector_typ_args_of rtyp with + | (Nexp_aux (Nexp_constant start,_), Nexp_aux (Nexp_constant length,_), ord, _) -> + (start, if is_order_inc ord + then sub_big_int (add_big_int start length) unit_big_int + else add_big_int (sub_big_int start length) unit_big_int) + | _ -> + raise (Reporting_basic.err_unreachable (fst rannot') + ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern"))) in + let rec aux typ_opt (pos,pat_acc,decl_acc) (P_aux (p,cannot),is_last) = + let ctyp = Env.base_typ_of (env_of_annot cannot) (typ_of_annot cannot) in + let (_,length,ord,_) = vector_typ_args_of ctyp in + let (pos',index_j) = match length with + | Nexp_aux (Nexp_constant i,_) -> + if is_order_inc ord + then (add_big_int pos i, sub_big_int (add_big_int pos i) unit_big_int) + else (sub_big_int pos i, add_big_int (sub_big_int pos i) unit_big_int) + | Nexp_aux (_,l) -> + if is_last then (pos,last_idx) + else + raise + (Reporting_basic.err_unreachable + l ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern")) in + (match p with + (* if we see a named vector pattern, remove the name and remember to + declare it later *) + | P_as (P_aux (p,cannot),cname) -> + let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in + (pos', pat_acc @ [P_aux (p,cannot)], decl_acc @ [((lb,decl),info)]) + (* if we see a P_id variable, remember to declare it later *) + | P_id cname -> + let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in + (pos', pat_acc @ [P_aux (P_id cname,cannot)], decl_acc @ [((lb,decl),info)]) + | P_typ (typ, pat) -> aux (Some typ) (pos,pat_acc,decl_acc) (pat, is_last) + (* normal vector patterns are fine *) + | _ -> (pos', pat_acc @ [P_aux (p,cannot)],decl_acc)) in + let pats_tagged = tag_last pats in + let (_,pats',decls') = List.fold_left (aux None) (start,[],[]) pats_tagged in + + (* abuse P_vector_concat as a P_vector_const pattern: it has the of + patterns as an argument but they're meant to be consed together *) + (P_aux (P_as (P_aux (P_vector_concat pats',rannot'),rootid),rannot), decls @ decls') + | ((p,decls),annot) -> (P_aux (p,annot),decls) in + + { p_lit = (fun lit -> (P_lit lit,[])) + ; p_wild = (P_wild,[]) + ; p_as = (fun ((pat,decls),id) -> (P_as (pat,id),decls)) + ; p_typ = (fun (typ,(pat,decls)) -> (P_typ (typ,pat),decls)) + ; p_id = (fun id -> (P_id id,[])) + ; p_var = (fun ((pat,decls),kid) -> (P_var (pat,kid),decls)) + ; p_app = (fun (id,ps) -> let (ps,decls) = List.split ps in + (P_app (id,ps),List.flatten decls)) + ; p_record = (fun (ps,b) -> let (ps,decls) = List.split ps in + (P_record (ps,b),List.flatten decls)) + ; p_vector = (fun ps -> let (ps,decls) = List.split ps in + (P_vector ps,List.flatten decls)) + ; p_vector_concat = (fun ps -> let (ps,decls) = List.split ps in + (P_vector_concat ps,List.flatten decls)) + ; p_tup = (fun ps -> let (ps,decls) = List.split ps in + (P_tup ps,List.flatten decls)) + ; p_list = (fun ps -> let (ps,decls) = List.split ps in + (P_list ps,List.flatten decls)) + ; p_cons = (fun ((p,decls),(p',decls')) -> (P_cons (p,p'), decls @ decls')) + ; p_aux = (fun ((pat,decls),annot) -> p_aux ((pat,decls),annot)) + ; fP_aux = (fun ((fpat,decls),annot) -> (FP_aux (fpat,annot),decls)) + ; fP_Fpat = (fun (id,(pat,decls)) -> (FP_Fpat (id,pat),decls)) + } in + + let (pat,decls) = fold_pat unname_vector_concat_elements pat in + + let decls = + let module S = Set.Make(String) in + + let roots_needed = + List.fold_right + (fun (_,(rootid,childid)) roots_needed -> + if S.mem childid roots_needed then + (* let _ = print_endline rootid in *) + S.add rootid roots_needed + else if String.length childid >= 3 && String.sub childid 0 2 = String.sub "v__" 0 2 then + roots_needed + else + S.add rootid roots_needed + ) decls S.empty in + List.filter + (fun (_,(_,childid)) -> + S.mem childid roots_needed || + String.length childid < 3 || + not (String.sub childid 0 2 = String.sub "v__" 0 2)) + decls in + + let (letbinds,decls) = + let (decls,_) = List.split decls in + List.split decls in + + let decls = List.fold_left (fun f g x -> f (g x)) (fun b -> b) decls in + + + (* at this point shouldn't have P_as patterns in P_vector_concat patterns any more, + all P_as and P_id vectors should have their declarations in decls. + Now flatten all vector_concat patterns *) + + let flatten = + let p_vector_concat ps = + let aux p acc = match p with + | (P_aux (P_vector_concat pats,_)) -> pats @ acc + | pat -> pat :: acc in + P_vector_concat (List.fold_right aux ps []) in + {id_pat_alg with p_vector_concat = p_vector_concat} in + + let pat = fold_pat flatten pat in + + (* at this point pat should be a flat pattern: no vector_concat patterns + with vector_concats patterns as direct child-nodes anymore *) + + let range a b = + let rec aux a b = if gt_big_int a b then [] else a :: aux (add_big_int a unit_big_int) b in + if gt_big_int a b then List.rev (aux b a) else aux a b in + + let remove_vector_concats = + let p_vector_concat ps = + let aux acc (P_aux (p,annot),is_last) = + let env = env_of_annot annot in + let typ = Env.base_typ_of env (typ_of_annot annot) in + let eff = effect_of_annot (snd annot) in + let (l,_) = annot in + let wild _ = P_aux (P_wild,(gen_loc l, Some (env, bit_typ, eff))) in + if is_vector_typ typ then + match p, vector_typ_args_of typ with + | P_vector ps,_ -> acc @ ps + | _, (_,Nexp_aux (Nexp_constant length,_),_,_) -> + acc @ (List.map wild (range zero_big_int (sub_big_int length unit_big_int))) + | _, _ -> + (*if is_last then*) acc @ [wild zero_big_int] + else raise + (Reporting_basic.err_unreachable l + ("remove_vector_concats: Non-vector in vector-concat pattern " ^ + string_of_typ (typ_of_annot annot))) in + + let has_length (P_aux (p,annot)) = + let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in + match vector_typ_args_of typ with + | (_,Nexp_aux (Nexp_constant length,_),_,_) -> true + | _ -> false in + + let ps_tagged = tag_last ps in + let ps' = List.fold_left aux [] ps_tagged in + let last_has_length ps = List.exists (fun (p,b) -> b && has_length p) ps_tagged in + + if last_has_length ps then + P_vector ps' + else + (* If the last vector pattern in the vector_concat pattern has unknown + length we misuse the P_vector_concat constructor's argument to place in + the following way: P_vector_concat [x;y; ... ;z] should be mapped to the + pattern-match x :: y :: .. z, i.e. if x : 'a, then z : vector 'a. *) + P_vector_concat ps' in + + {id_pat_alg with p_vector_concat = p_vector_concat} in + + let pat = fold_pat remove_vector_concats pat in + + (pat,letbinds,decls) + +(* assumes there are no more E_internal expressions *) +let rewrite_exp_remove_vector_concat_pat rewriters (E_aux (exp,(l,annot)) as full_exp) = + let rewrap e = E_aux (e,(l,annot)) in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + match exp with + | E_case (e,ps) -> + let aux = function + | (Pat_aux (Pat_exp (pat,body),annot')) -> + let (pat,_,decls) = remove_vector_concat_pat pat in + Pat_aux (Pat_exp (pat, decls (rewrite_rec body)),annot') + | (Pat_aux (Pat_when (pat,guard,body),annot')) -> + let (pat,_,decls) = remove_vector_concat_pat pat in + Pat_aux (Pat_when (pat, decls (rewrite_rec guard), decls (rewrite_rec body)),annot') in + rewrap (E_case (rewrite_rec e, List.map aux ps)) + | E_let (LB_aux (LB_val (pat,v),annot'),body) -> + let (pat,_,decls) = remove_vector_concat_pat pat in + rewrap (E_let (LB_aux (LB_val (pat,rewrite_rec v),annot'), + decls (rewrite_rec body))) + | exp -> rewrite_base full_exp + +let rewrite_fun_remove_vector_concat_pat + rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = + let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),(l,annot))) = + let (pat',_,decls) = remove_vector_concat_pat pat in + let exp' = decls (rewriters.rewrite_exp rewriters exp) in + (FCL_aux (FCL_Funcl (id,pat',exp'),(l,annot))) + in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) + +let rewrite_defs_remove_vector_concat (Defs defs) = + let rewriters = + {rewrite_exp = rewrite_exp_remove_vector_concat_pat; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; + rewrite_lexp = rewrite_lexp; + rewrite_fun = rewrite_fun_remove_vector_concat_pat; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base} in + let rewrite_def d = + let d = rewriters.rewrite_def rewriters d in + match d with + | DEF_val (LB_aux (LB_val (pat,exp),a)) -> + let (pat,letbinds,_) = remove_vector_concat_pat pat in + let defvals = List.map (fun lb -> DEF_val lb) letbinds in + [DEF_val (LB_aux (LB_val (pat,exp),a))] @ defvals + | d -> [d] in + Defs (List.flatten (List.map rewrite_def defs)) + +(* A few helper functions for rewriting guarded pattern clauses. + Used both by the rewriting of P_when and separately by the rewriting of + bitvectors in parameter patterns of function clauses *) + +let remove_wildcards pre (P_aux (_,(l,_)) as pat) = + fold_pat + {id_pat_alg with + p_aux = function + | (P_wild,(l,annot)) -> P_aux (P_id (fresh_id pre l),(l,annot)) + | (p,annot) -> P_aux (p,annot) } + pat + +(* Check if one pattern subsumes the other, and if so, calculate a + substitution of variables that are used in the same position. + TODO: Check somewhere that there are no variable clashes (the same variable + name used in different positions of the patterns) + *) +let rec subsumes_pat (P_aux (p1,annot1) as pat1) (P_aux (p2,annot2) as pat2) = + let rewrap p = P_aux (p,annot1) in + let subsumes_list s pats1 pats2 = + if List.length pats1 = List.length pats2 + then + let subs = List.map2 s pats1 pats2 in + List.fold_right + (fun p acc -> match p, acc with + | Some subst, Some substs -> Some (subst @ substs) + | _ -> None) + subs (Some []) + else None in + match p1, p2 with + | P_lit (L_aux (lit1,_)), P_lit (L_aux (lit2,_)) -> + if lit1 = lit2 then Some [] else None + | P_as (pat1,_), _ -> subsumes_pat pat1 pat2 + | _, P_as (pat2,_) -> subsumes_pat pat1 pat2 + | P_typ (_,pat1), _ -> subsumes_pat pat1 pat2 + | _, P_typ (_,pat2) -> subsumes_pat pat1 pat2 + | P_id (Id_aux (id1,_) as aid1), P_id (Id_aux (id2,_) as aid2) -> + if id1 = id2 then Some [] + else if Env.lookup_id aid1 (env_of_annot annot1) = Unbound && + Env.lookup_id aid2 (env_of_annot annot2) = Unbound + then Some [(id2,id1)] else None + | P_id id1, _ -> + if Env.lookup_id id1 (env_of_annot annot1) = Unbound then Some [] else None + | P_wild, _ -> Some [] + | P_app (Id_aux (id1,l1),args1), P_app (Id_aux (id2,_),args2) -> + if id1 = id2 then subsumes_list subsumes_pat args1 args2 else None + | P_record (fps1,b1), P_record (fps2,b2) -> + if b1 = b2 then subsumes_list subsumes_fpat fps1 fps2 else None + | P_vector pats1, P_vector pats2 + | P_vector_concat pats1, P_vector_concat pats2 + | P_tup pats1, P_tup pats2 + | P_list pats1, P_list pats2 -> + subsumes_list subsumes_pat pats1 pats2 + | P_list (pat1 :: pats1), P_cons _ -> + subsumes_pat (rewrap (P_cons (pat1, rewrap (P_list pats1)))) pat2 + | P_cons _, P_list (pat2 :: pats2)-> + subsumes_pat pat1 (rewrap (P_cons (pat2, rewrap (P_list pats2)))) + | P_cons (pat1, pats1), P_cons (pat2, pats2) -> + (match subsumes_pat pat1 pat2, subsumes_pat pats1 pats2 with + | Some substs1, Some substs2 -> Some (substs1 @ substs2) + | _ -> None) + | _ -> None +and subsumes_fpat (FP_aux (FP_Fpat (id1,pat1),_)) (FP_aux (FP_Fpat (id2,pat2),_)) = + if id1 = id2 then subsumes_pat pat1 pat2 else None + +let equiv_pats pat1 pat2 = + match subsumes_pat pat1 pat2, subsumes_pat pat2 pat1 with + | Some _, Some _ -> true + | _, _ -> false + +let subst_id_pat pat (id1,id2) = + let p_id (Id_aux (id,l)) = (if id = id1 then P_id (Id_aux (id2,l)) else P_id (Id_aux (id,l))) in + fold_pat {id_pat_alg with p_id = p_id} pat + +let subst_id_exp exp (id1,id2) = + (* TODO Don't substitute bound occurrences inside let expressions etc *) + let e_id (Id_aux (id,l)) = (if id = id1 then E_id (Id_aux (id2,l)) else E_id (Id_aux (id,l))) in + fold_exp {id_exp_alg with e_id = e_id} exp + +let rec pat_to_exp (P_aux (pat,(l,annot))) = + let rewrap e = E_aux (e,(l,annot)) in + match pat with + | P_lit lit -> rewrap (E_lit lit) + | P_wild -> raise (Reporting_basic.err_unreachable l + "pat_to_exp given wildcard pattern") + | P_as (pat,id) -> rewrap (E_id id) + | P_typ (_,pat) -> pat_to_exp pat + | P_id id -> rewrap (E_id id) + | P_app (id,pats) -> rewrap (E_app (id, List.map pat_to_exp pats)) + | P_record (fpats,b) -> + rewrap (E_record (FES_aux (FES_Fexps (List.map fpat_to_fexp fpats,b),(l,annot)))) + | P_vector pats -> rewrap (E_vector (List.map pat_to_exp pats)) + | P_vector_concat pats -> raise (Reporting_basic.err_unreachable l + "pat_to_exp not implemented for P_vector_concat") + (* We assume that vector concatenation patterns have been transformed + away already *) + | P_tup pats -> rewrap (E_tuple (List.map pat_to_exp pats)) + | P_list pats -> rewrap (E_list (List.map pat_to_exp pats)) + | P_cons (p,ps) -> rewrap (E_cons (pat_to_exp p, pat_to_exp ps)) +and fpat_to_fexp (FP_aux (FP_Fpat (id,pat),(l,annot))) = + FE_aux (FE_Fexp (id, pat_to_exp pat),(l,annot)) + +let case_exp e t cs = + let l = get_loc_exp e in + let env = env_of e in + let annot = (get_loc_exp e, Some (env_of e, t, no_effect)) in + match cs with + | [(P_aux (P_id id, pannot) as pat, body, _)] -> + fix_eff_exp (annot_exp (E_let (LB_aux (LB_val (pat, e), pannot), body)) l env t) + | _ -> + let pexp (pat,body,annot) = Pat_aux (Pat_exp (pat,body),annot) in + let ps = List.map pexp cs in + (* let efr = union_effs (List.map effect_of_pexp ps) in *) + fix_eff_exp (annot_exp (E_case (e,ps)) l env t) + +let rewrite_guarded_clauses l cs = + let rec group clauses = + let add_clause (pat,cls,annot) c = (pat,cls @ [c],annot) in + let rec group_aux current acc = (function + | ((pat,guard,body,annot) as c) :: cs -> + let (current_pat,_,_) = current in + (match subsumes_pat current_pat pat with + | Some substs -> + let pat' = List.fold_left subst_id_pat pat substs in + let guard' = (match guard with + | Some exp -> Some (List.fold_left subst_id_exp exp substs) + | None -> None) in + let body' = List.fold_left subst_id_exp body substs in + let c' = (pat',guard',body',annot) in + group_aux (add_clause current c') acc cs + | None -> + let pat = remove_wildcards "g__" pat in + group_aux (pat,[c],annot) (acc @ [current]) cs) + | [] -> acc @ [current]) in + let groups = match clauses with + | ((pat,guard,body,annot) as c) :: cs -> + group_aux (remove_wildcards "g__" pat, [c], annot) [] cs + | _ -> + raise (Reporting_basic.err_unreachable l + "group given empty list in rewrite_guarded_clauses") in + List.map (fun cs -> if_pexp cs) groups + and if_pexp (pat,cs,annot) = (match cs with + | c :: _ -> + (* fix_eff_pexp (pexp *) + let body = if_exp pat cs in + let pexp = fix_eff_pexp (Pat_aux (Pat_exp (pat,body),annot)) in + let (Pat_aux (_,annot)) = pexp in + (pat, body, annot) + | [] -> + raise (Reporting_basic.err_unreachable l + "if_pexp given empty list in rewrite_guarded_clauses")) + and if_exp current_pat = (function + | (pat,guard,body,annot) :: ((pat',guard',body',annot') as c') :: cs -> + (match guard with + | Some exp -> + let else_exp = + if equiv_pats current_pat pat' + then if_exp current_pat (c' :: cs) + else case_exp (pat_to_exp current_pat) (typ_of body') (group (c' :: cs)) in + fix_eff_exp (annot_exp (E_if (exp,body,else_exp)) (fst annot) (env_of exp) (typ_of body)) + | None -> body) + | [(pat,guard,body,annot)] -> body + | [] -> + raise (Reporting_basic.err_unreachable l + "if_exp given empty list in rewrite_guarded_clauses")) in + group cs + +let bitwise_and_exp exp1 exp2 = + let (E_aux (_,(l,_))) = exp1 in + let andid = Id_aux (Id "and_bool", gen_loc l) in + annot_exp (E_app(andid,[exp1;exp2])) l (env_of exp1) bool_typ + +let rec contains_bitvector_pat (P_aux (pat,annot)) = match pat with +| P_lit _ | P_wild | P_id _ -> false +| P_as (pat,_) | P_typ (_,pat) -> contains_bitvector_pat pat +| P_vector _ | P_vector_concat _ -> + let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in + is_bitvector_typ typ +| P_app (_,pats) | P_tup pats | P_list pats -> + List.exists contains_bitvector_pat pats +| P_cons (p,ps) -> contains_bitvector_pat p || contains_bitvector_pat ps +| P_record (fpats,_) -> + List.exists (fun (FP_aux (FP_Fpat (_,pat),_)) -> contains_bitvector_pat pat) fpats + +let contains_bitvector_pexp = function +| Pat_aux (Pat_exp (pat,_),_) | Pat_aux (Pat_when (pat,_,_),_) -> + contains_bitvector_pat pat + +(* Rewrite bitvector patterns to guarded patterns *) + +let remove_bitvector_pat pat = + + let env = try pat_env_of pat with _ -> Env.empty in + + (* first introduce names for bitvector patterns *) + let name_bitvector_roots = + { p_lit = (fun lit -> P_lit lit) + ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) + ; p_wild = P_wild + ; p_as = (fun (pat,id) -> P_as (pat true,id)) + ; p_id = (fun id -> P_id id) + ; p_var = (fun (pat,kid) -> P_var (pat true,kid)) + ; p_app = (fun (id,ps) -> P_app (id, List.map (fun p -> p false) ps)) + ; p_record = (fun (fpats,b) -> P_record (fpats, b)) + ; p_vector = (fun ps -> P_vector (List.map (fun p -> p false) ps)) + ; p_vector_concat = (fun ps -> P_vector_concat (List.map (fun p -> p false) ps)) + ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) + ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) + ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) + ; p_aux = + (fun (pat,annot) contained_in_p_as -> + let env = env_of_annot annot in + let t = Env.base_typ_of env (typ_of_annot annot) in + let (l,_) = annot in + match pat, is_bitvector_typ t, contained_in_p_as with + | P_vector _, true, false -> + P_aux (P_as (P_aux (pat,annot),fresh_id "b__" l), annot) + | _ -> P_aux (pat,annot) + ) + ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) + ; fP_Fpat = (fun (id,p) -> FP_Fpat (id,p false)) + } in + let pat = (fold_pat name_bitvector_roots pat) false in + + (* Then collect guard expressions testing whether the literal bits of a + bitvector pattern match those of a given bitvector, and collect let + bindings for the bits bound by P_id or P_as patterns *) + + (* Helper functions for generating guard expressions *) + let access_bit_exp rootid l typ idx = + let root = annot_exp (E_id rootid) l env typ in + (* FIXME *) + annot_exp (E_vector_access (root, simple_num l idx)) l env bit_typ in + (*let env = env_of_annot rannot in + let t = Env.base_typ_of env (typ_of_annot rannot) in + let (_, _, ord, _) = vector_typ_args_of t in + let access_id = if is_order_inc ord then "bitvector_access_inc" else "bitvector_access_dec" in + E_aux (E_app (mk_id access_id, [root; simple_num l idx]), simple_annot l bit_typ) in*) + + let test_bit_exp rootid l typ idx exp = + let rannot = (l, Some (env_of exp, typ, no_effect)) in + let elem = access_bit_exp rootid l typ idx in + Some (annot_exp (E_app (mk_id "eq", [elem; exp])) l env bool_typ) in + + let test_subvec_exp rootid l typ i j lits = + let (start, length, ord, _) = vector_typ_args_of typ in + let length' = nint (List.length lits) in + let start' = + if is_order_inc ord then nint 0 + else nminus length' (nint 1) in + let typ' = vector_typ start' length' ord bit_typ in + let subvec_exp = + match start, length with + | Nexp_aux (Nexp_constant s, _), Nexp_aux (Nexp_constant l, _) + when eq_big_int s i && eq_big_int l (big_int_of_int (List.length lits)) -> + E_id rootid + | _ -> + (*if vec_start t = i && vec_length t = List.length lits + then E_id rootid + else*) + E_vector_subrange ( + annot_exp (E_id rootid) l env typ, + simple_num l i, + simple_num l j) in + (* let subrange_id = if is_order_inc ord then "bitvector_subrange_inc" else "bitvector_subrange_dec" in + E_app (mk_id subrange_id, [E_aux (E_id rootid, simple_annot l typ); simple_num l i; simple_num l j]) in *) + annot_exp (E_app( + Id_aux (Id "eq_vec", gen_loc l), + [annot_exp subvec_exp l env typ'; + annot_exp (E_vector lits) l env typ'])) l env bool_typ in + + let letbind_bit_exp rootid l typ idx id = + let rannot = simple_annot l typ in + let elem = access_bit_exp rootid l typ idx in + let e = annot_pat (P_id id) l env bit_typ in + let letbind = LB_aux (LB_val (e,elem), (l, Some (env, bit_typ, no_effect))) in + let letexp = (fun body -> + let (E_aux (_,(_,bannot))) = body in + annot_exp (E_let (letbind,body)) l env (typ_of body)) in + (letexp, letbind) in + + let compose_guards guards = + let conj g1 g2 = match g1, g2 with + | Some g1, Some g2 -> Some (bitwise_and_exp g1 g2) + | Some g1, None -> Some g1 + | None, Some g2 -> Some g2 + | None, None -> None in + List.fold_right conj guards None in + + let flatten_guards_decls gd = + let (guards,decls,letbinds) = Util.split3 gd in + (compose_guards guards, (List.fold_right (@@) decls), List.flatten letbinds) in + + (* Collect guards and let bindings *) + let guard_bitvector_pat = + let collect_guards_decls ps rootid t = + let (start,_,ord,_) = vector_typ_args_of t in + let rec collect current (guards,dls) idx ps = + let idx' = if is_order_inc ord then add_big_int idx unit_big_int else sub_big_int idx unit_big_int in + (match ps with + | pat :: ps' -> + (match pat with + | P_aux (P_lit lit, (l,annot)) -> + let e = E_aux (E_lit lit, (gen_loc l, annot)) in + let current' = (match current with + | Some (l,i,j,lits) -> Some (l,i,idx,lits @ [e]) + | None -> Some (l,idx,idx,[e])) in + collect current' (guards, dls) idx' ps' + | P_aux (P_as (pat',id), (l,annot)) -> + let dl = letbind_bit_exp rootid l t idx id in + collect current (guards, dls @ [dl]) idx (pat' :: ps') + | _ -> + let dls' = (match pat with + | P_aux (P_id id, (l,annot)) -> + dls @ [letbind_bit_exp rootid l t idx id] + | _ -> dls) in + let guards' = (match current with + | Some (l,i,j,lits) -> + guards @ [Some (test_subvec_exp rootid l t i j lits)] + | None -> guards) in + collect None (guards', dls') idx' ps') + | [] -> + let guards' = (match current with + | Some (l,i,j,lits) -> + guards @ [Some (test_subvec_exp rootid l t i j lits)] + | None -> guards) in + (guards',dls)) in + let (guards,dls) = match start with + | Nexp_aux (Nexp_constant s, _) -> + collect None ([],[]) s ps + | _ -> + let (P_aux (_, (l,_))) = pat in + raise (Reporting_basic.err_unreachable l + "guard_bitvector_pat called on pattern with non-constant start index") in + let (decls,letbinds) = List.split dls in + (compose_guards guards, List.fold_right (@@) decls, letbinds) in + + let collect_guards_decls_indexed ips rootid t = + let rec guard_decl (idx,pat) = (match pat with + | P_aux (P_lit lit, (l,annot)) -> + let exp = E_aux (E_lit lit, (l,annot)) in + (test_bit_exp rootid l t idx exp, (fun b -> b), []) + | P_aux (P_as (pat',id), (l,annot)) -> + let (guard,decls,letbinds) = guard_decl (idx,pat') in + let (letexp,letbind) = letbind_bit_exp rootid l t idx id in + (guard, decls >> letexp, letbind :: letbinds) + | P_aux (P_id id, (l,annot)) -> + let (letexp,letbind) = letbind_bit_exp rootid l t idx id in + (None, letexp, [letbind]) + | _ -> (None, (fun b -> b), [])) in + let (guards,decls,letbinds) = Util.split3 (List.map guard_decl ips) in + (compose_guards guards, List.fold_right (@@) decls, List.flatten letbinds) in + + { p_lit = (fun lit -> (P_lit lit, (None, (fun b -> b), []))) + ; p_wild = (P_wild, (None, (fun b -> b), [])) + ; p_as = (fun ((pat,gdls),id) -> (P_as (pat,id), gdls)) + ; p_typ = (fun (typ,(pat,gdls)) -> (P_typ (typ,pat), gdls)) + ; p_id = (fun id -> (P_id id, (None, (fun b -> b), []))) + ; p_var = (fun ((pat,gdls),kid) -> (P_var (pat,kid), gdls)) + ; p_app = (fun (id,ps) -> let (ps,gdls) = List.split ps in + (P_app (id,ps), flatten_guards_decls gdls)) + ; p_record = (fun (ps,b) -> let (ps,gdls) = List.split ps in + (P_record (ps,b), flatten_guards_decls gdls)) + ; p_vector = (fun ps -> let (ps,gdls) = List.split ps in + (P_vector ps, flatten_guards_decls gdls)) + ; p_vector_concat = (fun ps -> let (ps,gdls) = List.split ps in + (P_vector_concat ps, flatten_guards_decls gdls)) + ; p_tup = (fun ps -> let (ps,gdls) = List.split ps in + (P_tup ps, flatten_guards_decls gdls)) + ; p_list = (fun ps -> let (ps,gdls) = List.split ps in + (P_list ps, flatten_guards_decls gdls)) + ; p_cons = (fun ((p,gdls),(p',gdls')) -> + (P_cons (p,p'), flatten_guards_decls [gdls;gdls'])) + ; p_aux = (fun ((pat,gdls),annot) -> + let env = env_of_annot annot in + let t = Env.base_typ_of env (typ_of_annot annot) in + (match pat, is_bitvector_typ t with + | P_as (P_aux (P_vector ps, _), id), true -> + (P_aux (P_id id, annot), collect_guards_decls ps id t) + | _, _ -> (P_aux (pat,annot), gdls))) + ; fP_aux = (fun ((fpat,gdls),annot) -> (FP_aux (fpat,annot), gdls)) + ; fP_Fpat = (fun (id,(pat,gdls)) -> (FP_Fpat (id,pat), gdls)) + } in + fold_pat guard_bitvector_pat pat + +let rewrite_exp_remove_bitvector_pat rewriters (E_aux (exp,(l,annot)) as full_exp) = + let rewrap e = E_aux (e,(l,annot)) in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + match exp with + | E_case (e,ps) + when List.exists contains_bitvector_pexp ps -> + let rewrite_pexp = function + | Pat_aux (Pat_exp (pat,body),annot') -> + let (pat',(guard',decls,_)) = remove_bitvector_pat pat in + let body' = decls (rewrite_rec body) in + (match guard' with + | Some guard' -> Pat_aux (Pat_when (pat', guard', body'), annot') + | None -> Pat_aux (Pat_exp (pat', body'), annot')) + | Pat_aux (Pat_when (pat,guard,body),annot') -> + let (pat',(guard',decls,_)) = remove_bitvector_pat pat in + let body' = decls (rewrite_rec body) in + (match guard' with + | Some guard' -> Pat_aux (Pat_when (pat', bitwise_and_exp guard guard', body'), annot') + | None -> Pat_aux (Pat_when (pat', guard, body'), annot')) in + rewrap (E_case (e, List.map rewrite_pexp ps)) + | E_let (LB_aux (LB_val (pat,v),annot'),body) -> + let (pat,(_,decls,_)) = remove_bitvector_pat pat in + rewrap (E_let (LB_aux (LB_val (pat,rewrite_rec v),annot'), + decls (rewrite_rec body))) + | _ -> rewrite_base full_exp + +let rewrite_fun_remove_bitvector_pat + rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = + let _ = reset_fresh_name_counter () in + (* TODO Can there be clauses with different id's in one FD_function? *) + let funcls = match funcls with + | (FCL_aux (FCL_Funcl(id,_,_),_) :: _) -> + let clause (FCL_aux (FCL_Funcl(_,pat,exp),annot)) = + let (pat,(guard,decls,_)) = remove_bitvector_pat pat in + let exp = decls (rewriters.rewrite_exp rewriters exp) in + (pat,guard,exp,annot) in + let cs = rewrite_guarded_clauses l (List.map clause funcls) in + List.map (fun (pat,exp,annot) -> FCL_aux (FCL_Funcl(id,pat,exp),annot)) cs + | _ -> funcls (* TODO is the empty list possible here? *) in + FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot)) + +let rewrite_defs_remove_bitvector_pats (Defs defs) = + let rewriters = + {rewrite_exp = rewrite_exp_remove_bitvector_pat; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; + rewrite_lexp = rewrite_lexp; + rewrite_fun = rewrite_fun_remove_bitvector_pat; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base } in + let rewrite_def d = + let d = rewriters.rewrite_def rewriters d in + match d with + | DEF_val (LB_aux (LB_val (pat,exp),a)) -> + let (pat',(_,_,letbinds)) = remove_bitvector_pat pat in + let defvals = List.map (fun lb -> DEF_val lb) letbinds in + [DEF_val (LB_aux (LB_val (pat',exp),a))] @ defvals + | d -> [d] in + (* FIXME See above in rewrite_sizeof *) + (* fst (check initial_env ( *) + Defs (List.flatten (List.map rewrite_def defs)) + (* )) *) + + +(* Remove pattern guards by rewriting them to if-expressions within the + pattern expression. Shares code with the rewriting of bitvector patterns. *) +let rewrite_exp_guarded_pats rewriters (E_aux (exp,(l,annot)) as full_exp) = + let rewrap e = E_aux (e,(l,annot)) in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + let is_guarded_pexp = function + | Pat_aux (Pat_when (_,_,_),_) -> true + | _ -> false in + match exp with + | E_case (e,ps) + when List.exists is_guarded_pexp ps -> + let clause = function + | Pat_aux (Pat_exp (pat, body), annot) -> + (pat, None, rewrite_rec body, annot) + | Pat_aux (Pat_when (pat, guard, body), annot) -> + (pat, Some guard, rewrite_rec body, annot) in + let clauses = rewrite_guarded_clauses l (List.map clause ps) in + if (effectful e) then + let e = rewrite_rec e in + let (E_aux (_,(el,eannot))) = e in + let pat_e' = fresh_id_pat "p__" (el, Some (env_of e, typ_of e, no_effect)) in + let exp_e' = pat_to_exp pat_e' in + let letbind_e = LB_aux (LB_val (pat_e',e), (el,eannot)) in + let exp' = case_exp exp_e' (typ_of full_exp) clauses in + rewrap (E_let (letbind_e, exp')) + else case_exp e (typ_of full_exp) clauses + | _ -> rewrite_base full_exp + +let rewrite_defs_guarded_pats = + rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp_guarded_pats } + + +let id_is_local_var id env = match Env.lookup_id id env with + | Local _ -> true + | _ -> false + +let rec lexp_is_local (LEXP_aux (lexp, _)) env = match lexp with + | LEXP_memory _ -> false + | LEXP_id id + | LEXP_cast (_, id) -> id_is_local_var id env + | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local lexp env) lexps + | LEXP_vector (lexp,_) + | LEXP_vector_range (lexp,_,_) + | LEXP_field (lexp,_) -> lexp_is_local lexp env + +let id_is_unbound id env = match Env.lookup_id id env with + | Unbound -> true + | _ -> false + +let rec lexp_is_local_intro (LEXP_aux (lexp, _)) env = match lexp with + | LEXP_memory _ -> false + | LEXP_id id + | LEXP_cast (_, id) -> id_is_unbound id env + | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local_intro lexp env) lexps + | LEXP_vector (lexp,_) + | LEXP_vector_range (lexp,_,_) + | LEXP_field (lexp,_) -> lexp_is_local_intro lexp env + +let lexp_is_effectful (LEXP_aux (_, (_, annot))) = match annot with + | Some (_, _, eff) -> effectful_effs eff + | _ -> false + +let rec rewrite_local_lexp ((LEXP_aux(lexp,((l,_) as annot))) as le) = + match lexp with + | LEXP_id _ | LEXP_cast (_, _) | LEXP_tup _ -> (le, (fun exp -> exp)) + | LEXP_vector (lexp, e) -> + let (lhs, rhs) = rewrite_local_lexp lexp in + (lhs, (fun exp -> rhs (E_aux (E_vector_update (lexp_to_exp lexp, e, exp), annot)))) + | LEXP_vector_range (lexp, e1, e2) -> + let (lhs, rhs) = rewrite_local_lexp lexp in + (lhs, (fun exp -> rhs (E_aux (E_vector_update_subrange (lexp_to_exp lexp, e1, e2, exp), annot)))) + | LEXP_field (lexp, id) -> + let (lhs, rhs) = rewrite_local_lexp lexp in + let (LEXP_aux (_, recannot)) = lexp in + let field_update exp = FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), annot)], false), annot) in + (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), recannot)))) + | _ -> raise (Reporting_basic.err_unreachable l ("Unsupported lexp: " ^ string_of_lexp le)) + +(*Expects to be called after rewrite_defs; thus the following should not appear: + internal_exp of any form + lit vectors in patterns or expressions + *) +let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = + let rewrap e = E_aux (e,annot) in + let rewrap_effects e eff = + E_aux (e, (l,Some (env_of_annot annot, typ_of_annot annot, eff))) in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + match exp with + | E_block exps -> + let rec walker exps = match exps with + | [] -> [] + | (E_aux(E_assign(le,e), ((l, Some (env,typ,eff)) as annot)) as exp)::exps + when lexp_is_local_intro le env && not (lexp_is_effectful le) -> + let (le', re') = rewrite_local_lexp le in + let e' = re' (rewrite_base e) in + let exps' = walker exps in + let effects = union_eff_exps exps' in + let block = E_aux (E_block exps', (l, Some (env, unit_typ, effects))) in + [fix_eff_exp (E_aux (E_internal_let(le', e', block), annot))] + (*| ((E_aux(E_if(c,t,e),(l,annot))) as exp)::exps -> + let vars_t = introduced_variables t in + let vars_e = introduced_variables e in + let new_vars = Envmap.intersect vars_t vars_e in + if Envmap.is_empty new_vars + then (rewrite_base exp)::walker exps + else + let new_nmap = match nmap with + | None -> Some(Nexpmap.empty,new_vars) + | Some(nm,s) -> Some(nm, Envmap.union new_vars s) in + let c' = rewrite_base c in + let t' = rewriters.rewrite_exp rewriters new_nmap t in + let e' = rewriters.rewrite_exp rewriters new_nmap e in + let exps' = walker exps in + fst ((Envmap.fold + (fun (res,effects) i (t,e) -> + let bitlit = E_aux (E_lit (L_aux(L_zero, Parse_ast.Generated l)), + (Parse_ast.Generated l, simple_annot bit_t)) in + let rangelit = E_aux (E_lit (L_aux (L_num 0, Parse_ast.Generated l)), + (Parse_ast.Generated l, simple_annot nat_t)) in + let set_exp = + match t.t with + | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) -> bitlit + | Tapp("range", _) | Tapp("atom", _) -> rangelit + | Tapp("vector", [_;_;_;TA_typ ( {t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})})]) + | Tapp(("reg"|"register"),[TA_typ ({t = Tapp("vector", + [_;_;_;TA_typ ( {t=Tid "bit"} + | {t=Tabbrev(_,{t=Tid "bit"})})])})]) + | Tabbrev(_,{t = Tapp("vector", + [_;_;_;TA_typ ( {t=Tid "bit"} + | {t=Tabbrev(_,{t=Tid "bit"})})])}) -> + E_aux (E_vector_indexed([], Def_val_aux(Def_val_dec bitlit, + (Parse_ast.Generated l,simple_annot bit_t))), + (Parse_ast.Generated l, simple_annot t)) + | _ -> e in + let unioneffs = union_effects effects (get_effsum_exp set_exp) in + ([E_aux (E_internal_let (LEXP_aux (LEXP_id (Id_aux (Id i, Parse_ast.Generated l)), + (Parse_ast.Generated l, (tag_annot t Emp_intro))), + set_exp, + E_aux (E_block res, (Parse_ast.Generated l, (simple_annot_efr unit_t effects)))), + (Parse_ast.Generated l, simple_annot_efr unit_t unioneffs))],unioneffs))) + (E_aux(E_if(c',t',e'),(Parse_ast.Generated l, annot))::exps',eff_union_exps (c'::t'::e'::exps')) new_vars)*) + | e::exps -> (rewrite_rec e)::(walker exps) + in + rewrap (E_block (walker exps)) + | E_assign(le,e) + when lexp_is_local_intro le (env_of full_exp) && not (lexp_is_effectful le) -> + let (le', re') = rewrite_local_lexp le in + let e' = re' (rewrite_base e) in + let block = annot_exp (E_block []) l (env_of full_exp) unit_typ in + fix_eff_exp (E_aux (E_internal_let(le', e', block), annot)) + | _ -> rewrite_base full_exp + +let rewrite_lexp_lift_assign_intro rewriters ((LEXP_aux(lexp,annot)) as le) = + let rewrap le = LEXP_aux(le,annot) in + let rewrite_base = rewrite_lexp rewriters in + match lexp, annot with + | (LEXP_id id | LEXP_cast (_,id)), (l, Some (env, typ, eff)) -> + (match Env.lookup_id id env with + | Unbound | Local _ -> + LEXP_aux (lexp, (l, Some (env, typ, union_effects eff (mk_effect [BE_lset])))) + | _ -> rewrap lexp) + | _ -> rewrite_base le + + +let rewrite_defs_exp_lift_assign defs = rewrite_defs_base + {rewrite_exp = rewrite_exp_lift_assign_intro; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; + rewrite_lexp = rewrite_lexp_lift_assign_intro; + rewrite_fun = rewrite_fun; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base} defs + +(*let rewrite_exp_separate_ints rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = + (*let tparms,t,tag,nexps,eff,cum_eff,bounds = match annot with + | Base((tparms,t),tag,nexps,eff,cum_eff,bounds) -> tparms,t,tag,nexps,eff,cum_eff,bounds + | _ -> [],unit_t,Emp_local,[],pure_e,pure_e,nob in*) + let rewrap e = E_aux (e,annot) in + (*let rewrap_effects e effsum = + E_aux (e,(l,Base ((tparms,t),tag,nexps,eff,effsum,bounds))) in*) + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + match exp with + | E_lit (L_aux (((L_num _) as lit),_)) -> + (match (is_within_machine64 t nexps) with + | Yes -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int yes\n" in rewrite_base full_exp + | Maybe -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int maybe\n" in rewrite_base full_exp + | No -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int no\n" in E_aux(E_app(Id_aux (Id "integer_of_int",l),[rewrite_base full_exp]), + (l, Base((tparms,t),External(None),nexps,eff,cum_eff,bounds)))) + | E_cast (typ, exp) -> rewrap (E_cast (typ, rewrite_rec exp)) + | E_app (id,exps) -> rewrap (E_app (id,List.map rewrite_rec exps)) + | E_app_infix(el,id,er) -> rewrap (E_app_infix(rewrite_rec el,id,rewrite_rec er)) + | E_for (id, e1, e2, e3, o, body) -> + rewrap (E_for (id, rewrite_rec e1, rewrite_rec e2, rewrite_rec e3, o, rewrite_rec body)) + | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite_rec vec,rewrite_rec index)) + | E_vector_subrange (vec,i1,i2) -> + rewrap (E_vector_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2)) + | E_vector_update (vec,index,new_v) -> + rewrap (E_vector_update (rewrite_rec vec,rewrite_rec index,rewrite_rec new_v)) + | E_vector_update_subrange (vec,i1,i2,new_v) -> + rewrap (E_vector_update_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2,rewrite_rec new_v)) + | E_case (exp ,pexps) -> + rewrap (E_case (rewrite_rec exp, + (List.map + (fun (Pat_aux (Pat_exp(p,e),pannot)) -> + Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters nmap p,rewrite_rec e),pannot)) pexps))) + | E_let (letbind,body) -> rewrap (E_let(rewriters.rewrite_let rewriters nmap letbind,rewrite_rec body)) + | E_internal_let (lexp,exp,body) -> + rewrap (E_internal_let (rewriters.rewrite_lexp rewriters nmap lexp, rewrite_rec exp, rewrite_rec body)) + | _ -> rewrite_base full_exp + +let rewrite_defs_separate_numbs defs = rewrite_defs_base + {rewrite_exp = rewrite_exp_separate_ints; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; (*will likely need a new one?*) + rewrite_lexp = rewrite_lexp; (*will likely need a new one?*) + rewrite_fun = rewrite_fun; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base} defs*) + +let rewrite_defs_early_return = + let is_return (E_aux (exp, _)) = match exp with + | E_return _ -> true + | _ -> false in + + let get_return (E_aux (e, (l, _)) as exp) = match e with + | E_return e -> e + | _ -> exp in + + let e_block es = + match es with + | [E_aux (e, _)] -> e + | _ :: _ when is_return (Util.last es) -> + let (E_aux (_, annot) as e) = get_return (Util.last es) in + E_return (E_aux (E_block (Util.butlast es @ [get_return e]), annot)) + | _ -> E_block es in + + let e_if (e1, e2, e3) = + if is_return e2 && is_return e3 then + let (E_aux (_, annot)) = get_return e2 in + E_return (E_aux (E_if (e1, get_return e2, get_return e3), annot)) + else E_if (e1, e2, e3) in + + let e_case (e, pes) = + let is_return_pexp (Pat_aux (pexp, _)) = match pexp with + | Pat_exp (_, e) | Pat_when (_, _, e) -> is_return e in + let get_return_pexp (Pat_aux (pexp, a)) = match pexp with + | Pat_exp (p, e) -> Pat_aux (Pat_exp (p, get_return e), a) + | Pat_when (p, g, e) -> Pat_aux (Pat_when (p, g, get_return e), a) in + let annot = match List.map get_return_pexp pes with + | Pat_aux (Pat_exp (_, E_aux (_, annot)), _) :: _ -> annot + | Pat_aux (Pat_when (_, _, E_aux (_, annot)), _) :: _ -> annot + | [] -> (Parse_ast.Unknown, None) in + if List.for_all is_return_pexp pes + then E_return (E_aux (E_case (e, List.map get_return_pexp pes), annot)) + else E_case (e, pes) in + + let e_aux (exp, (l, annot)) = + let full_exp = fix_eff_exp (E_aux (exp, (l, annot))) in + match annot with + | Some (env, typ, eff) when is_return full_exp -> + (* Add escape effect annotation, since we use the exception mechanism + of the state monad to implement early return in the Lem backend *) + let annot' = Some (env, typ, union_effects eff (mk_effect [BE_escape])) in + E_aux (exp, (l, annot')) + | _ -> full_exp in + + let rewrite_funcl_early_return _ (FCL_aux (FCL_Funcl (id, pat, exp), a)) = + let exp = + exp + (* Pull early returns out as far as possible *) + |> fold_exp { id_exp_alg with e_block = e_block; e_if = e_if; e_case = e_case } + (* Remove singleton E_return *) + |> get_return + (* Fix effect annotations *) + |> fold_exp { id_exp_alg with e_aux = e_aux } in + let a = match a with + | (l, Some (env, typ, eff)) -> + (l, Some (env, typ, union_effects eff (effect_of exp))) + | _ -> a in + FCL_aux (FCL_Funcl (id, pat, exp), a) in + + let rewrite_fun_early_return rewriters + (FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, funcls), a)) = + FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, + List.map (rewrite_funcl_early_return rewriters) funcls), a) in + + rewrite_defs_base { rewriters_base with rewrite_fun = rewrite_fun_early_return } + +(* Propagate effects of functions, if effect checking and propagation + have not been performed already by the type checker. *) +let rewrite_fix_val_specs (Defs defs) = + let find_vs env val_specs id = + try Bindings.find id val_specs with + | Not_found -> + begin + try Env.get_val_spec id env with + | _ -> + raise (Reporting_basic.err_unreachable (Parse_ast.Unknown) + ("No val spec found for " ^ string_of_id id)) + end + in + + let add_eff_to_vs eff = function + | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff'), a)) -> + (tq, Typ_aux (Typ_fn (args_t, ret_t, union_effects eff eff'), a)) + | vs -> vs + in + + let eff_of_vs = function + | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff), a)) -> eff + | _ -> no_effect + in + + let e_aux val_specs (exp, (l, annot)) = + match fix_eff_exp (E_aux (exp, (l, annot))) with + | E_aux (E_app_infix (_, f, _) as exp, (l, Some (env, typ, eff))) + | E_aux (E_app (f, _) as exp, (l, Some (env, typ, eff))) -> + let vs = find_vs env val_specs f in + let env = Env.update_val_spec f vs env in + E_aux (exp, (l, Some (env, typ, union_effects eff (eff_of_vs vs)))) + | e_aux -> e_aux + in + + let rewrite_exp val_specs = fold_exp { id_exp_alg with e_aux = e_aux val_specs } in + + let rewrite_funcl (val_specs, funcls) (FCL_aux (FCL_Funcl (id, pat, exp), (l, annot))) = + let exp = propagate_exp_effect (rewrite_exp val_specs exp) in + let vs, eff = match find_vs (env_of_annot (l, annot)) val_specs id with + | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff), a)) -> + let eff' = union_effects eff (effect_of exp) in + let args_t' = rewrite_typ_nexp_ids (env_of exp) (pat_typ_of pat) in + let ret_t' = rewrite_typ_nexp_ids (env_of exp) (typ_of exp) in + (tq, Typ_aux (Typ_fn (args_t', ret_t', eff'), a)), eff' + in + let annot = add_effect_annot annot eff in + (Bindings.add id vs val_specs, + funcls @ [FCL_aux (FCL_Funcl (id, pat, exp), (l, annot))]) + in + + let rewrite_fundef (val_specs, FD_aux (FD_function (recopt, tannotopt, effopt, funcls), a)) = + let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in + (* Repeat once to cross-propagate effects between clauses *) + let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in + let is_funcl_rec (FCL_aux (FCL_Funcl (id, _, exp), _)) = + fst (fold_exp + { (compute_exp_alg false (||) ) with + e_app = (fun (f, es) -> + let (rs, es) = List.split es in + (List.fold_left (||) (string_of_id f = string_of_id id) rs, + E_app (f, es))); + e_app_infix = (fun ((r1,e1), f, (r2,e2)) -> + (r1 || r2 || (string_of_id f = string_of_id id), + E_app_infix (e1, f, e2))) } + exp) + in + let recopt = + if List.exists is_funcl_rec funcls then + Rec_aux (Rec_rec, Parse_ast.Unknown) + else recopt + in + (val_specs, FD_aux (FD_function (recopt, tannotopt, effopt, funcls), a)) in + + let rec rewrite_fundefs (val_specs, fundefs) = + match fundefs with + | fundef :: fundefs -> + let (val_specs, fundef) = rewrite_fundef (val_specs, fundef) in + let (val_specs, fundefs) = rewrite_fundefs (val_specs, fundefs) in + (val_specs, fundef :: fundefs) + | [] -> (val_specs, []) in + + let rewrite_def (val_specs, defs) = function + | DEF_fundef fundef -> + let (val_specs, fundef) = rewrite_fundef (val_specs, fundef) in + (val_specs, defs @ [DEF_fundef fundef]) + | DEF_internal_mutrec fundefs -> + let (val_specs, fundefs) = rewrite_fundefs (val_specs, fundefs) in + (val_specs, defs @ [DEF_internal_mutrec fundefs]) + | DEF_val (LB_aux (LB_val (pat, exp), a)) -> + (val_specs, defs @ [DEF_val (LB_aux (LB_val (pat, rewrite_exp val_specs exp), a))]) + | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) -> + let typschm, val_specs = + if Bindings.mem id val_specs then begin + let (tq, typ) = Bindings.find id val_specs in + TypSchm_aux (TypSchm_ts (tq, typ), Parse_ast.Unknown), val_specs + end else begin + let (TypSchm_aux (TypSchm_ts (tq, typ), _)) = typschm in + typschm, Bindings.add id (tq, typ) val_specs + end + in + (val_specs, defs @ [DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a))]) + | def -> (val_specs, defs @ [def]) + in + + let rewrite_val_specs val_specs = function + | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) + when Bindings.mem id val_specs -> + let typschm = match typschm with + | TypSchm_aux (TypSchm_ts (tq, typ), l) -> + let (tq, typ) = Bindings.find id val_specs in + TypSchm_aux (TypSchm_ts (tq, typ), l) + in + DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) + | def -> def + in + + let (val_specs, defs) = List.fold_left rewrite_def (Bindings.empty, []) defs in + let defs = List.map (rewrite_val_specs val_specs) defs in + + (* if !Type_check.opt_no_effects + then *) + Defs defs + (* else Defs defs *) + +(* Turn constraints into numeric expressions with sizeof *) +let rewrite_constraint = + let rec rewrite_nc (NC_aux (nc_aux, l)) = mk_exp (rewrite_nc_aux nc_aux) + and rewrite_nc_aux = function + | NC_bounded_ge (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id ">=", mk_exp (E_sizeof n2)) + | NC_bounded_le (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "<=", mk_exp (E_sizeof n2)) + | NC_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "==", mk_exp (E_sizeof n2)) + | NC_not_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "!=", mk_exp (E_sizeof n2)) + | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "&", rewrite_nc nc2) + | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "|", rewrite_nc nc2) + | NC_false -> E_lit (mk_lit L_false) + | NC_true -> E_lit (mk_lit L_true) + | NC_set (kid, ints) -> + unaux_exp (rewrite_nc (List.fold_left (fun nc int -> nc_or nc (nc_eq (nvar kid) (nconstant int))) nc_true ints)) + in + let rewrite_e_aux (E_aux (e_aux, _) as exp) = + match e_aux with + | E_constraint nc -> + check_exp (env_of exp) (rewrite_nc nc) bool_typ + | _ -> exp + in + + let rewrite_e_constraint = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in + + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_e_constraint) } + +let rewrite_type_union_typs rw_typ (Tu_aux (tu, annot)) = + match tu with + | Tu_id id -> Tu_aux (Tu_id id, annot) + | Tu_ty_id (typ, id) -> Tu_aux (Tu_ty_id (rw_typ typ, id), annot) + +let rewrite_type_def_typs rw_typ rw_typquant rw_typschm (TD_aux (td, annot)) = + match td with + | TD_abbrev (id, nso, typschm) -> TD_aux (TD_abbrev (id, nso, rw_typschm typschm), annot) + | TD_record (id, nso, typq, typ_ids, flag) -> + TD_aux (TD_record (id, nso, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot) + | TD_variant (id, nso, typq, tus, flag) -> + TD_aux (TD_variant (id, nso, rw_typquant typq, List.map (rewrite_type_union_typs rw_typ) tus, flag), annot) + | TD_enum (id, nso, ids, flag) -> TD_aux (TD_enum (id, nso, ids, flag), annot) + | TD_register (id, n1, n2, ranges) -> TD_aux (TD_register (id, n1, n2, ranges), annot) + +(* FIXME: other reg_dec types *) +let rewrite_dec_spec_typs rw_typ (DEC_aux (ds, annot)) = + match ds with + | DEC_reg (typ, id) -> DEC_aux (DEC_reg (rw_typ typ, id), annot) + | _ -> assert false + +(* Remove overload definitions and cast val specs from the + specification because the interpreter doesn't know about them.*) +let rewrite_overload_cast (Defs defs) = + let remove_cast_vs (VS_aux (vs_aux, annot)) = + match vs_aux with + | VS_val_spec (typschm, id, ext, _) -> VS_aux (VS_val_spec (typschm, id, ext, false), annot) + in + let simple_def = function + | DEF_spec vs -> DEF_spec (remove_cast_vs vs) + | def -> def + in + let is_overload = function + | DEF_overload _ -> true + | _ -> false + in + let defs = List.map simple_def defs in + Defs (List.filter (fun def -> not (is_overload def)) defs) + + +let rewrite_undefined mwords = + let rewrite_e_aux (E_aux (e_aux, _) as exp) = + match e_aux with + | E_lit (L_aux (L_undef, l)) -> + check_exp (env_of exp) (undefined_of_typ mwords l (fun _ -> ()) (Env.expand_synonyms (env_of exp) (typ_of exp))) (typ_of exp) + | _ -> exp + in + let rewrite_exp_undefined = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp_undefined) } + +let rec simple_typ (Typ_aux (typ_aux, l) as typ) = Typ_aux (simple_typ_aux typ_aux, l) +and simple_typ_aux = function + | Typ_id id -> Typ_id id + | Typ_app (id, [_; _; _; Typ_arg_aux (Typ_arg_typ typ, l)]) when Id.compare id (mk_id "vector") = 0 -> + Typ_app (mk_id "list", [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)]) + | Typ_app (id, [_]) when Id.compare id (mk_id "atom") = 0 -> + Typ_id (mk_id "int") + | Typ_app (id, [_; _]) when Id.compare id (mk_id "range") = 0 -> + Typ_id (mk_id "int") + | Typ_app (id, args) -> Typ_app (id, List.concat (List.map simple_typ_arg args)) + | Typ_fn (typ1, typ2, effs) -> Typ_fn (simple_typ typ1, simple_typ typ2, effs) + | Typ_tup typs -> Typ_tup (List.map simple_typ typs) + | Typ_exist (_, _, Typ_aux (typ, l)) -> simple_typ_aux typ + | typ_aux -> typ_aux +and simple_typ_arg (Typ_arg_aux (typ_arg_aux, l)) = + match typ_arg_aux with + | Typ_arg_typ typ -> [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)] + | _ -> [] + +(* This pass aims to remove all the Num quantifiers from the specification. *) +let rewrite_simple_types (Defs defs) = + let is_simple = function + | QI_aux (QI_id kopt, annot) as qi when is_typ_kopt kopt || is_order_kopt kopt -> true + | _ -> false + in + let simple_typquant (TypQ_aux (tq_aux, annot)) = + match tq_aux with + | TypQ_no_forall -> TypQ_aux (TypQ_no_forall, annot) + | TypQ_tq quants -> TypQ_aux (TypQ_tq (List.filter (fun q -> is_simple q) quants), annot) + in + let simple_typschm (TypSchm_aux (TypSchm_ts (typq, typ), annot)) = + TypSchm_aux (TypSchm_ts (simple_typquant typq, simple_typ typ), annot) + in + let simple_vs (VS_aux (vs_aux, annot)) = + match vs_aux with + | VS_val_spec (typschm, id, ext, is_cast) -> VS_aux (VS_val_spec (simple_typschm typschm, id, ext, is_cast), annot) + in + let rec simple_lit (L_aux (lit_aux, l) as lit) = + match lit_aux with + | L_bin _ | L_hex _ -> + E_list (List.map (fun b -> E_aux (E_lit b, simple_annot l bit_typ)) (vector_string_to_bit_list l lit_aux)) + | _ -> E_lit lit + in + let simple_def = function + | DEF_spec vs -> DEF_spec (simple_vs vs) + | DEF_type td -> DEF_type (rewrite_type_def_typs simple_typ simple_typquant simple_typschm td) + | DEF_reg_dec ds -> DEF_reg_dec (rewrite_dec_spec_typs simple_typ ds) + | def -> def + in + let simple_pat = { + id_pat_alg with + p_typ = (fun (typ, pat) -> P_typ (simple_typ typ, pat)); + p_var = (fun (pat, kid) -> unaux_pat pat); + p_vector = (fun pats -> P_list pats) + } in + let simple_exp = { + id_exp_alg with + e_lit = simple_lit; + e_vector = (fun exps -> E_list exps); + e_cast = (fun (typ, exp) -> E_cast (simple_typ typ, exp)); + (* e_assert = (fun (E_aux (_, annot), str) -> E_assert (E_aux (E_lit (mk_lit L_true), annot), str)); *) + lEXP_cast = (fun (typ, lexp) -> LEXP_cast (simple_typ typ, lexp)); + pat_alg = simple_pat + } in + let simple_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp simple_exp); + rewrite_pat = (fun _ -> fold_pat simple_pat) } + in + let defs = Defs (List.map simple_def defs) in + rewrite_defs_base simple_defs defs + +let rewrite_tuple_vector_assignments defs = + let assign_tuple e_aux annot = + let env = env_of_annot annot in + match e_aux with + | E_assign (LEXP_aux (LEXP_tup lexps, lannot), exp) -> + let typ = Env.base_typ_of env (typ_of exp) in + if is_vector_typ typ then + (* let _ = Pretty_print_common.print stderr (Pretty_print_sail.doc_exp (E_aux (e_aux, annot))) in *) + let (start, _, ord, etyp) = vector_typ_args_of typ in + let len (LEXP_aux (le, lannot)) = + let ltyp = Env.base_typ_of env (typ_of_annot lannot) in + if is_vector_typ ltyp then + let (_, len, _, _) = vector_typ_args_of ltyp in + match nexp_simp len with + | Nexp_aux (Nexp_constant len, _) -> len + | _ -> unit_big_int + else unit_big_int in + let next i step = + if is_order_inc ord + then (sub_big_int (add_big_int i step) unit_big_int, add_big_int i step) + else (add_big_int (sub_big_int i step) unit_big_int, sub_big_int i step) in + let i = match nexp_simp start with + | (Nexp_aux (Nexp_constant i, _)) -> i + | _ -> if is_order_inc ord then zero_big_int else big_int_of_int (List.length lexps - 1) in + let l = gen_loc (fst annot) in + let exp' = + if small exp then strip_exp exp + else mk_exp (E_id (mk_id "split_vec")) in + let lexp_to_exp (i, exps) lexp = + let (j, i') = next i (len lexp) in + let i_exp = mk_exp (E_lit (mk_lit (L_num i))) in + let j_exp = mk_exp (E_lit (mk_lit (L_num j))) in + let sub = mk_exp (E_vector_subrange (exp', i_exp, j_exp)) in + (i', exps @ [sub]) in + let (_, exps) = List.fold_left lexp_to_exp (i, []) lexps in + let tup = mk_exp (E_tuple exps) in + let lexp = LEXP_aux (LEXP_tup (List.map strip_lexp lexps), (l, ())) in + let e_aux = + if small exp then mk_exp (E_assign (lexp, tup)) + else mk_exp ( + E_let ( + mk_letbind (mk_pat (P_id (mk_id "split_vec"))) (strip_exp exp), + mk_exp (E_assign (lexp, tup)))) in + begin + try check_exp env e_aux unit_typ with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err)) + end + else E_aux (e_aux, annot) + | _ -> E_aux (e_aux, annot) + in + let assign_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> assign_tuple e_aux annot) + } in + let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in + rewrite_defs_base assign_defs defs + +let rewrite_tuple_assignments defs = + let assign_tuple e_aux annot = + let env = env_of_annot annot in + match e_aux with + | E_assign (LEXP_aux (LEXP_tup lexps, _), exp) -> + (* let _ = Pretty_print_common.print stderr (Pretty_print_sail.doc_exp (E_aux (e_aux, annot))) in *) + let (_, ids) = List.fold_left (fun (n, ids) _ -> (n + 1, ids @ [mk_id ("tup__" ^ string_of_int n)])) (0, []) lexps in + let block_assign i lexp = mk_exp (E_assign (strip_lexp lexp, mk_exp (E_id (mk_id ("tup__" ^ string_of_int i))))) in + let block = mk_exp (E_block (List.mapi block_assign lexps)) in + let letbind = mk_letbind (mk_pat (P_tup (List.map (fun id -> mk_pat (P_id id)) ids))) (strip_exp exp) in + let let_exp = mk_exp (E_let (letbind, block)) in + begin + try check_exp env let_exp unit_typ with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err)) + end + | _ -> E_aux (e_aux, annot) + in + let assign_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> assign_tuple e_aux annot) + } in + let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in + rewrite_defs_base assign_defs defs + +let rewrite_simple_assignments defs = + let assign_e_aux e_aux annot = + let env = env_of_annot annot in + match e_aux with + | E_assign (lexp, exp) -> + let (lexp, rhs) = rewrite_local_lexp lexp in + let assign = mk_exp (E_assign (strip_lexp lexp, strip_exp (rhs exp))) in + check_exp env assign unit_typ + | _ -> E_aux (e_aux, annot) + in + let assign_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> assign_e_aux e_aux annot) + } in + let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in + rewrite_defs_base assign_defs defs + +let rewrite_defs_remove_blocks = + let letbind_wild v body = + let l = get_loc_exp v in + let env = env_of v in + let typ = typ_of v in + annot_exp (E_let (annot_letbind (P_wild, v) l env typ, body)) l env (typ_of body) in + (* let pat = annot_pat P_wild l env typ in + let (E_aux (_,(l,tannot))) = v in + let annot_pat = (simple_annot l (typ_of v)) in + let annot_lb = (gen_loc l, tannot) in + let annot_let = (gen_loc l, Some (env_of body, typ_of body, union_eff_exps [v;body])) in + E_aux (E_let (LB_aux (LB_val (P_aux (P_wild,annot_pat),v),annot_lb),body),annot_let) in *) + + let rec f l = function + | [] -> E_aux (E_lit (L_aux (L_unit,gen_loc l)), (simple_annot l unit_typ)) + | [e] -> e (* check with Kathy if that annotation is fine *) + | e :: es -> letbind_wild e (f l es) in + + let e_aux = function + | (E_block es,(l,_)) -> f l es + | (e,annot) -> E_aux (e,annot) in + + let alg = { id_exp_alg with e_aux = e_aux } in + + rewrite_defs_base + {rewrite_exp = (fun _ -> fold_exp alg) + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + + + +let letbind (v : 'a exp) (body : 'a exp -> 'a exp) : 'a exp = + (* body is a function : E_id variable -> actual body *) + let (E_aux (_,(l,annot))) = v in + match annot with + | Some (env, Typ_aux (Typ_id tid, _), eff) when string_of_id tid = "unit" -> + let body = body (annot_exp (E_lit (mk_lit L_unit)) l env unit_typ) in + let body_typ = try typ_of body with _ -> unit_typ in + let lb = annot_letbind (P_wild, v) l env unit_typ in + propagate_exp_effect (annot_exp (E_let (lb, body)) l env body_typ) + | Some (env, typ, eff) -> + let id = fresh_id "w__" l in + let lb = annot_letbind (P_id id, v) l env typ in + let body = body (annot_exp (E_id id) l env typ) in + propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) + | None -> + raise (Reporting_basic.err_unreachable l "no type information") + + +let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list -> 'a exp) : 'a exp = + match l with + | [] -> k [] + | exp :: exps -> f exp (fun exp -> mapCont f exps (fun exps -> k (exp :: exps))) + +let rewrite_defs_letbind_effects = + + let rec value ((E_aux (exp_aux,_)) as exp) = + not (effectful exp || updates_vars exp) + and value_optdefault (Def_val_aux (o,_)) = match o with + | Def_val_empty -> true + | Def_val_dec e -> value e + and value_fexps (FES_aux (FES_Fexps (fexps,_),_)) = + List.fold_left (fun b (FE_aux (FE_Fexp (_,e),_)) -> b && value e) true fexps in + + + let rec n_exp_name (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = + n_exp exp (fun exp -> if value exp then k exp else letbind exp k) + + and n_exp_pure (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = + n_exp exp (fun exp -> if value exp then k exp else letbind exp k) + + and n_exp_nameL (exps : 'a exp list) (k : 'a exp list -> 'a exp) : 'a exp = + mapCont n_exp_name exps k + + and n_fexp (fexp : 'a fexp) (k : 'a fexp -> 'a exp) : 'a exp = + let (FE_aux (FE_Fexp (id,exp),annot)) = fexp in + n_exp_name exp (fun exp -> + k (fix_eff_fexp (FE_aux (FE_Fexp (id,exp),annot)))) + + and n_fexpL (fexps : 'a fexp list) (k : 'a fexp list -> 'a exp) : 'a exp = + mapCont n_fexp fexps k + + and n_pexp (newreturn : bool) (pexp : 'a pexp) (k : 'a pexp -> 'a exp) : 'a exp = + match pexp with + | Pat_aux (Pat_exp (pat,exp),annot) -> + k (fix_eff_pexp (Pat_aux (Pat_exp (pat,n_exp_term newreturn exp), annot))) + | Pat_aux (Pat_when (pat,guard,exp),annot) -> + k (fix_eff_pexp (Pat_aux (Pat_when (pat,n_exp_term newreturn guard,n_exp_term newreturn exp), annot))) + + and n_pexpL (newreturn : bool) (pexps : 'a pexp list) (k : 'a pexp list -> 'a exp) : 'a exp = + mapCont (n_pexp newreturn) pexps k + + and n_fexps (fexps : 'a fexps) (k : 'a fexps -> 'a exp) : 'a exp = + let (FES_aux (FES_Fexps (fexps_aux,b),annot)) = fexps in + n_fexpL fexps_aux (fun fexps_aux -> + k (fix_eff_fexps (FES_aux (FES_Fexps (fexps_aux,b),annot)))) + + and n_opt_default (opt_default : 'a opt_default) (k : 'a opt_default -> 'a exp) : 'a exp = + let (Def_val_aux (opt_default,annot)) = opt_default in + match opt_default with + | Def_val_empty -> k (Def_val_aux (Def_val_empty,annot)) + | Def_val_dec exp -> + n_exp_name exp (fun exp -> + k (fix_eff_opt_default (Def_val_aux (Def_val_dec exp,annot)))) + + and n_lb (lb : 'a letbind) (k : 'a letbind -> 'a exp) : 'a exp = + let (LB_aux (lb,annot)) = lb in + match lb with + | LB_val (pat,exp1) -> + n_exp exp1 (fun exp1 -> + k (fix_eff_lb (LB_aux (LB_val (pat,exp1),annot)))) + + and n_lexp (lexp : 'a lexp) (k : 'a lexp -> 'a exp) : 'a exp = + let (LEXP_aux (lexp_aux,annot)) = lexp in + match lexp_aux with + | LEXP_id _ -> k lexp + | LEXP_memory (id,es) -> + n_exp_nameL es (fun es -> + k (fix_eff_lexp (LEXP_aux (LEXP_memory (id,es),annot)))) + | LEXP_tup es -> + n_lexpL es (fun es -> + k (fix_eff_lexp (LEXP_aux (LEXP_tup es,annot)))) + | LEXP_cast (typ,id) -> + k (fix_eff_lexp (LEXP_aux (LEXP_cast (typ,id),annot))) + | LEXP_vector (lexp,e) -> + n_lexp lexp (fun lexp -> + n_exp_name e (fun e -> + k (fix_eff_lexp (LEXP_aux (LEXP_vector (lexp,e),annot))))) + | LEXP_vector_range (lexp,e1,e2) -> + n_lexp lexp (fun lexp -> + n_exp_name e1 (fun e1 -> + n_exp_name e2 (fun e2 -> + k (fix_eff_lexp (LEXP_aux (LEXP_vector_range (lexp,e1,e2),annot)))))) + | LEXP_field (lexp,id) -> + n_lexp lexp (fun lexp -> + k (fix_eff_lexp (LEXP_aux (LEXP_field (lexp,id),annot)))) + + and n_lexpL (lexps : 'a lexp list) (k : 'a lexp list -> 'a exp) : 'a exp = + mapCont n_lexp lexps k + + and n_exp_term (newreturn : bool) (exp : 'a exp) : 'a exp = + let (E_aux (_,(l,tannot))) = exp in + let exp = + if newreturn then + (* let typ = try typ_of exp with _ -> unit_typ in *) + annot_exp (E_internal_return exp) l (env_of exp) (typ_of exp) + else + exp in + (* n_exp_term forces an expression to be translated into a form + "let .. let .. let .. in EXP" where EXP has no effect and does not update + variables *) + n_exp_pure exp (fun exp -> exp) + + and n_exp (E_aux (exp_aux,annot) as exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = + + let rewrap e = fix_eff_exp (E_aux (e,annot)) in + + match exp_aux with + | E_block es -> failwith "E_block should have been removed till now" + | E_nondet _ -> failwith "E_nondet not supported" + | E_id id -> k exp + | E_lit _ -> k exp + | E_cast (typ,exp') -> + n_exp_name exp' (fun exp' -> + k (rewrap (E_cast (typ,exp')))) + | E_app (id,exps) -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_app (id,exps)))) + | E_app_infix (exp1,id,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_app_infix (exp1,id,exp2))))) + | E_tuple exps -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_tuple exps))) + | E_if (exp1,exp2,exp3) -> + n_exp_name exp1 (fun exp1 -> + let (E_aux (_,annot2)) = exp2 in + let (E_aux (_,annot3)) = exp3 in + let newreturn = effectful exp2 || effectful exp3 in + let exp2 = n_exp_term newreturn exp2 in + let exp3 = n_exp_term newreturn exp3 in + k (rewrap (E_if (exp1,exp2,exp3)))) + | E_for (id,start,stop,by,dir,body) -> + n_exp_name start (fun start -> + n_exp_name stop (fun stop -> + n_exp_name by (fun by -> + let body = n_exp_term (effectful body) body in + k (rewrap (E_for (id,start,stop,by,dir,body)))))) + | E_loop (loop, cond, body) -> + let cond = n_exp_term (effectful cond) cond in + let body = n_exp_term (effectful body) body in + k (rewrap (E_loop (loop,cond,body))) + | E_vector exps -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_vector exps))) + | E_vector_access (exp1,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_vector_access (exp1,exp2))))) + | E_vector_subrange (exp1,exp2,exp3) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + n_exp_name exp3 (fun exp3 -> + k (rewrap (E_vector_subrange (exp1,exp2,exp3)))))) + | E_vector_update (exp1,exp2,exp3) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + n_exp_name exp3 (fun exp3 -> + k (rewrap (E_vector_update (exp1,exp2,exp3)))))) + | E_vector_update_subrange (exp1,exp2,exp3,exp4) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + n_exp_name exp3 (fun exp3 -> + n_exp_name exp4 (fun exp4 -> + k (rewrap (E_vector_update_subrange (exp1,exp2,exp3,exp4))))))) + | E_vector_append (exp1,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_vector_append (exp1,exp2))))) + | E_list exps -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_list exps))) + | E_cons (exp1,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_cons (exp1,exp2))))) + | E_record fexps -> + n_fexps fexps (fun fexps -> + k (rewrap (E_record fexps))) + | E_record_update (exp1,fexps) -> + n_exp_name exp1 (fun exp1 -> + n_fexps fexps (fun fexps -> + k (rewrap (E_record_update (exp1,fexps))))) + | E_field (exp1,id) -> + n_exp_name exp1 (fun exp1 -> + k (rewrap (E_field (exp1,id)))) + | E_case (exp1,pexps) -> + let newreturn = List.exists effectful_pexp pexps in + n_exp_name exp1 (fun exp1 -> + n_pexpL newreturn pexps (fun pexps -> + k (rewrap (E_case (exp1,pexps))))) + | E_let (lb,body) -> + n_lb lb (fun lb -> + rewrap (E_let (lb,n_exp body k))) + | E_sizeof nexp -> + k (rewrap (E_sizeof nexp)) + | E_constraint nc -> + k (rewrap (E_constraint nc)) + | E_sizeof_internal annot -> + k (rewrap (E_sizeof_internal annot)) + | E_assign (lexp,exp1) -> + n_lexp lexp (fun lexp -> + n_exp_name exp1 (fun exp1 -> + k (rewrap (E_assign (lexp,exp1))))) + | E_exit exp' -> k (E_aux (E_exit (n_exp_term (effectful exp') exp'),annot)) + | E_assert (exp1,exp2) -> + n_exp exp1 (fun exp1 -> + n_exp exp2 (fun exp2 -> + k (rewrap (E_assert (exp1,exp2))))) + | E_internal_cast (annot',exp') -> + n_exp_name exp' (fun exp' -> + k (rewrap (E_internal_cast (annot',exp')))) + | E_internal_exp _ -> k exp + | E_internal_exp_user _ -> k exp + | E_internal_let (lexp,exp1,exp2) -> + n_lexp lexp (fun lexp -> + n_exp exp1 (fun exp1 -> + rewrap (E_internal_let (lexp,exp1,n_exp exp2 k)))) + | E_internal_return exp1 -> + n_exp_name exp1 (fun exp1 -> + k (rewrap (E_internal_return exp1))) + | E_comment str -> + k (rewrap (E_comment str)) + | E_comment_struc exp' -> + n_exp exp' (fun exp' -> + k (rewrap (E_comment_struc exp'))) + | E_return exp' -> + n_exp_name exp' (fun exp' -> + k (rewrap (E_return exp'))) + | E_internal_plet _ -> failwith "E_internal_plet should not be here yet" in + + let rewrite_fun _ (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),fdannot)) = + let effectful_funcl (FCL_aux (FCL_Funcl(_, _, exp), _)) = effectful exp in + let newreturn = List.exists effectful_funcl funcls in + let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),annot)) = + let _ = reset_fresh_name_counter () in + FCL_aux (FCL_Funcl (id,pat,n_exp_term newreturn exp),annot) + in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),fdannot) in + let rewrite_def rewriters def = + (* let _ = Pretty_print_sail.pp_defs stderr (Defs [def]) in *) + match def with + | DEF_val (LB_aux (lb, annot)) -> + let rewrap lb = DEF_val (LB_aux (lb, annot)) in + begin + match lb with + | LB_val (pat, exp) -> + rewrap (LB_val (pat, n_exp_term (effectful exp) exp)) + end + | DEF_fundef fdef -> DEF_fundef (rewrite_fun rewriters fdef) + | DEF_internal_mutrec fdefs -> + DEF_internal_mutrec (List.map (rewrite_fun rewriters) fdefs) + | d -> d in + rewrite_defs_base + {rewrite_exp = rewrite_exp + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + +let rewrite_defs_effectful_let_expressions = + + let rec pat_of_local_lexp (LEXP_aux (lexp, ((l, _) as annot))) = match lexp with + | LEXP_id id -> P_aux (P_id id, annot) + | LEXP_cast (typ, id) -> P_aux (P_typ (typ, P_aux (P_id id, annot)), annot) + | LEXP_tup lexps -> P_aux (P_tup (List.map pat_of_local_lexp lexps), annot) + | _ -> raise (Reporting_basic.err_unreachable l "unexpected local lexp") in + + let e_let (lb,body) = + match lb with + | LB_aux (LB_val (P_aux (P_wild, _), E_aux (E_assign ((LEXP_aux (_, annot) as le), exp), _)), _) + when lexp_is_local le (env_of_annot annot) && not (lexp_is_effectful le) -> + (* Rewrite assignments to local variables into let bindings *) + let (lhs, rhs) = rewrite_local_lexp le in + E_let (LB_aux (LB_val (pat_of_local_lexp lhs, rhs exp), annot), body) + | LB_aux (LB_val (pat,exp'),annot') -> + if effectful exp' + then E_internal_plet (pat,exp',body) + else E_let (lb,body) in + + let e_internal_let = fun (lexp,exp1,exp2) -> + match lexp with + | LEXP_aux (LEXP_id id,annot) + | LEXP_aux (LEXP_cast (_,id),annot) -> + if effectful exp1 then + E_internal_plet (P_aux (P_id id,annot),exp1,exp2) + else + let lb = LB_aux (LB_val (P_aux (P_id id,annot), exp1), annot) in + E_let (lb, exp2) + | _ -> failwith "E_internal_let with unexpected lexp" in + + let alg = { id_exp_alg with e_let = e_let; e_internal_let = e_internal_let } in + rewrite_defs_base + { rewrite_exp = (fun _ -> fold_exp alg) + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + + +(* Now all expressions have no blocks anymore, any term is a sequence of let-expressions, + * internal let-expressions, or internal plet-expressions ended by a term that does not + * access memory or registers and does not update variables *) + +let dedup eq = + List.fold_left (fun acc e -> if List.exists (eq e) acc then acc else e :: acc) [] + +let eqidtyp (id1,_) (id2,_) = + let name1 = match id1 with Id_aux ((Id name | DeIid name),_) -> name in + let name2 = match id2 with Id_aux ((Id name | DeIid name),_) -> name in + name1 = name2 + +let find_introduced_vars exp = + let e_aux ((ids,e_aux),annot) = + let ids = match e_aux, annot with + | E_internal_let (LEXP_aux (LEXP_id id, _), _, _), (_, Some (env, _, _)) + | E_internal_let (LEXP_aux (LEXP_cast (_, id), _), _, _), (_, Some (env, _, _)) + when id_is_unbound id env -> IdSet.add id ids + | _ -> ids in + (ids, E_aux (e_aux, annot)) in + fst (fold_exp + { (compute_exp_alg IdSet.empty IdSet.union) with e_aux = e_aux } exp) + +let find_updated_vars exp = + let intros = find_introduced_vars exp in + let e_aux ((ids,e_aux),annot) = + let ids = match e_aux, annot with + | E_assign (LEXP_aux (LEXP_id id, _), _), (_, Some (env, _, _)) + | E_assign (LEXP_aux (LEXP_cast (_, id), _), _), (_, Some (env, _, _)) + when id_is_local_var id env && not (IdSet.mem id intros) -> + (id, annot) :: ids + | _ -> ids in + (ids, E_aux (e_aux, annot)) in + dedup eqidtyp (fst (fold_exp + { (compute_exp_alg [] (@)) with e_aux = e_aux } exp)) + +let swaptyp typ (l,tannot) = match tannot with + | Some (env, typ', eff) -> (l, Some (env, typ, eff)) + | _ -> raise (Reporting_basic.err_unreachable l "swaptyp called with empty type annotation") + +let mktup l es = + match es with + | [] -> annot_exp (E_lit (mk_lit L_unit)) (gen_loc l) Env.empty unit_typ + | [e] -> e + | e :: _ -> + let typ = mk_typ (Typ_tup (List.map typ_of es)) in + propagate_exp_effect (annot_exp (E_tuple es) (gen_loc l) (env_of e) typ) + +let mktup_pat l es = + match es with + | [] -> annot_pat P_wild (gen_loc l) Env.empty unit_typ + | [E_aux (E_id id,_) as exp] -> + annot_pat (P_id id) (gen_loc l) (env_of exp) (typ_of exp) + | exp :: _ -> + let typ = mk_typ (Typ_tup (List.map typ_of es)) in + let pats = List.map (function + | (E_aux (E_id id,_) as exp) -> + annot_pat (P_id id) (gen_loc l) (env_of exp) (typ_of exp) + | exp -> + annot_pat P_wild (gen_loc l) (env_of exp) (typ_of exp)) es in + annot_pat (P_tup pats) (gen_loc l) (env_of exp) typ + + +type 'a updated_term = + | Added_vars of 'a exp * 'a pat + | Same_vars of 'a exp + +let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = + + let env = env_of exp in + + let rec add_vars overwrite ((E_aux (expaux,annot)) as exp) vars = + match expaux with + | E_let (lb,exp) -> + let exp = add_vars overwrite exp vars in + E_aux (E_let (lb,exp),swaptyp (typ_of exp) annot) + | E_internal_let (lexp,exp1,exp2) -> + let exp2 = add_vars overwrite exp2 vars in + E_aux (E_internal_let (lexp,exp1,exp2), swaptyp (typ_of exp2) annot) + | E_internal_plet (pat,exp1,exp2) -> + let exp2 = add_vars overwrite exp2 vars in + E_aux (E_internal_plet (pat,exp1,exp2), swaptyp (typ_of exp2) annot) + | E_internal_return exp2 -> + let exp2 = add_vars overwrite exp2 vars in + E_aux (E_internal_return exp2,swaptyp (typ_of exp2) annot) + | _ -> + (* after rewrite_defs_letbind_effects there cannot be terms that have + effects/update local variables in "tail-position": check n_exp_term + and where it is used. *) + if overwrite then + match typ_of exp with + | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> vars + | _ -> raise (Reporting_basic.err_unreachable l + "add_vars: trying to overwrite a non-unit expression in tail-position") + else + let typ' = Typ_aux (Typ_tup [typ_of exp;typ_of vars], gen_loc l) in + E_aux (E_tuple [exp;vars],swaptyp typ' annot) in + + let rewrite (E_aux (expaux,((el,_) as annot))) (P_aux (_,(pl,pannot)) as pat) = + let overwrite = match typ_of_annot annot with + | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> true + | _ -> false in + match expaux with + | E_for(id,exp1,exp2,exp3,order,exp4) -> + (* Translate for loops into calls to one of the foreach combinators. + The loop body becomes a function of the loop variable and any + mutable local variables that are updated inside the loop. + Since the foreach* combinators are higher-order functions, + they cannot be represented faithfully in the AST. The following + code abuses the parameters of an E_app node, embedding the loop body + function as an expression followed by the list of variables it + expects. In (Lem) pretty-printing, this turned into an anonymous + function and passed to foreach*. *) + let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) (find_updated_vars exp4) in + let vartuple = mktup el vars in + let exp4 = rewrite_var_updates (add_vars overwrite exp4 vartuple) in + let (E_aux (_,(_,annot4))) = exp4 in + let fname = match effectful exp4,order with + | false, Ord_aux (Ord_inc,_) -> "foreach_inc" + | false, Ord_aux (Ord_dec,_) -> "foreach_dec" + | true, Ord_aux (Ord_inc,_) -> "foreachM_inc" + | true, Ord_aux (Ord_dec,_) -> "foreachM_dec" + | _ -> raise (Reporting_basic.err_unreachable el + "Could not determine foreach combinator") in + let funcl = Id_aux (Id fname,gen_loc el) in + let loopvar = + (* Don't bother with creating a range type annotation, since the + Lem pretty-printing does not use it. *) + (* let (bf,tf) = match typ_of exp1 with + | {t = Tapp ("atom",[TA_nexp f])} -> (TA_nexp f,TA_nexp f) + | {t = Tapp ("reg", [TA_typ {t = Tapp ("atom",[TA_nexp f])}])} -> (TA_nexp f,TA_nexp f) + | {t = Tapp ("range",[TA_nexp bf;TA_nexp tf])} -> (TA_nexp bf,TA_nexp tf) + | {t = Tapp ("reg", [TA_typ {t = Tapp ("range",[TA_nexp bf;TA_nexp tf])}])} -> (TA_nexp bf,TA_nexp tf) + | {t = Tapp (name,_)} -> failwith (name ^ " shouldn't be here") in + let (bt,tt) = match typ_of exp2 with + | {t = Tapp ("atom",[TA_nexp t])} -> (TA_nexp t,TA_nexp t) + | {t = Tapp ("atom",[TA_typ {t = Tapp ("atom", [TA_nexp t])}])} -> (TA_nexp t,TA_nexp t) + | {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])} -> (TA_nexp bt,TA_nexp tt) + | {t = Tapp ("atom",[TA_typ {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])}])} -> (TA_nexp bt,TA_nexp tt) + | {t = Tapp (name,_)} -> failwith (name ^ " shouldn't be here") in + let t = {t = Tapp ("range",match order with + | Ord_aux (Ord_inc,_) -> [bf;tt] + | Ord_aux (Ord_dec,_) -> [tf;bt])} in *) + annot_exp (E_id id) l env int_typ in + let v = E_aux (E_app (funcl,[loopvar;mktup el [exp1;exp2;exp3];exp4;vartuple]), + (gen_loc el, annot4)) in + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_loop(loop,cond,body) -> + let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) (find_updated_vars body) in + let vartuple = mktup el vars in + (* let cond = rewrite_var_updates (add_vars false cond vartuple) in *) + let body = rewrite_var_updates (add_vars overwrite body vartuple) in + let (E_aux (_,(_,bannot))) = body in + let fname = match loop, effectful cond, effectful body with + | While, false, false -> "while_PP" + | While, false, true -> "while_PM" + | While, true, false -> "while_MP" + | While, true, true -> "while_MM" + | Until, false, false -> "until_PP" + | Until, false, true -> "until_PM" + | Until, true, false -> "until_MP" + | Until, true, true -> "until_MM" in + let funcl = Id_aux (Id fname,gen_loc el) in + let v = E_aux (E_app (funcl,[cond;body;vartuple]), (gen_loc el, bannot)) in + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_if (c,e1,e2) -> + let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) + (dedup eqidtyp (find_updated_vars e1 @ find_updated_vars e2)) in + if vars = [] then + (Same_vars (E_aux (E_if (c,rewrite_var_updates e1,rewrite_var_updates e2),annot))) + else + let vartuple = mktup el vars in + let e1 = rewrite_var_updates (add_vars overwrite e1 vartuple) in + let e2 = rewrite_var_updates (add_vars overwrite e2 vartuple) in + (* after rewrite_defs_letbind_effects c has no variable updates *) + let env = env_of_annot annot in + let typ = typ_of e1 in + let eff = union_eff_exps [e1;e2] in + let v = E_aux (E_if (c,e1,e2), (gen_loc el, Some (env, typ, eff))) in + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_case (e1,ps) -> + (* after rewrite_defs_letbind_effects e1 needs no rewriting *) + let vars = + let f acc (Pat_aux ((Pat_exp (_,e)|Pat_when (_,_,e)),_)) = + acc @ find_updated_vars e in + List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) + (dedup eqidtyp (List.fold_left f [] ps)) in + if vars = [] then + let ps = List.map (function + | Pat_aux (Pat_exp (p,e),a) -> + Pat_aux (Pat_exp (p,rewrite_var_updates e),a) + | Pat_aux (Pat_when (p,g,e),a) -> + Pat_aux (Pat_when (p,g,rewrite_var_updates e),a)) ps in + Same_vars (E_aux (E_case (e1,ps),annot)) + else + let vartuple = mktup el vars in + let rewrite_pexp (Pat_aux (pexp, (l, _))) = match pexp with + | Pat_exp (pat, exp) -> + let exp = rewrite_var_updates (add_vars overwrite exp vartuple) in + let pannot = (l, Some (env_of exp, typ_of exp, effect_of exp)) in + Pat_aux (Pat_exp (pat, exp), pannot) + | Pat_when _ -> + raise (Reporting_basic.err_unreachable l + "Guarded patterns should have been rewritten already") in + let typ = match ps with + | Pat_aux ((Pat_exp (_,first)|Pat_when (_,_,first)),_) :: _ -> typ_of first + | _ -> unit_typ in + let v = propagate_exp_effect (annot_exp (E_case (e1, List.map rewrite_pexp ps)) pl env typ) in + (* let (ps,typ,effs) = + let f (acc,typ,effs) (Pat_aux (Pat_exp (p,e),pannot)) = + let etyp = typ_of e in + let () = assert (string_of_typ etyp = string_of_typ typ) in + let e = rewrite_var_updates (add_vars overwrite e vartuple) in + let pannot = simple_annot pl (typ_of e) in + let effs = union_effects effs (effect_of e) in + let pat' = Pat_aux (Pat_exp (p,e),pannot) in + (acc @ [pat'],typ,effs) in + List.fold_left f ([],typ,no_effect) ps in + let v = E_aux (E_case (e1,ps), (gen_loc pl, Some (env_of_annot annot, typ, effs))) in *) + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_assign (lexp,vexp) -> + let effs = match effect_of_annot (snd annot) with + | Effect_aux (Effect_set effs, _) -> effs + | _ -> + raise (Reporting_basic.err_unreachable l + "assignment without effects annotation") in + if effectful exp then + Same_vars (E_aux (E_assign (lexp,vexp),annot)) + else + (match lexp with + | LEXP_aux (LEXP_id id,annot) -> + let pat = annot_pat (P_id id) pl env (typ_of vexp) in + Added_vars (vexp,pat) + | LEXP_aux (LEXP_cast (_,id),annot) -> + let pat = annot_pat (P_id id) pl env (typ_of vexp) in + Added_vars (vexp,pat) + | LEXP_aux (LEXP_vector (LEXP_aux (LEXP_id id,((l2,_) as annot2)),i),((l1,_) as annot)) -> + let eid = annot_exp (E_id id) l2 env (typ_of_annot annot2) in + let vexp = annot_exp (E_vector_update (eid,i,vexp)) l1 env (typ_of_annot annot) in + let pat = annot_pat (P_id id) pl env (typ_of vexp) in + Added_vars (vexp,pat) + | LEXP_aux (LEXP_vector_range (LEXP_aux (LEXP_id id,((l2,_) as annot2)),i,j), + ((l,_) as annot)) -> + let eid = annot_exp (E_id id) l2 env (typ_of_annot annot2) in + let vexp = annot_exp (E_vector_update_subrange (eid,i,j,vexp)) l env (typ_of_annot annot) in + let pat = annot_pat (P_id id) pl env (typ_of vexp) in + Added_vars (vexp,pat) + | _ -> Same_vars (E_aux (E_assign (lexp,vexp),annot))) + | _ -> + (* after rewrite_defs_letbind_effects this expression is pure and updates + no variables: check n_exp_term and where it's used. *) + Same_vars (E_aux (expaux,annot)) in + + match expaux with + | E_let (lb,body) -> + let body = rewrite_var_updates body in + let (LB_aux (LB_val (pat, v), lbannot)) = lb in + let lb = match rewrite v pat with + | Added_vars (v, P_aux (pat, _)) -> + annot_letbind (pat, v) (get_loc_exp v) env (typ_of v) + | Same_vars v -> LB_aux (LB_val (pat, v),lbannot) in + propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) + | E_internal_let (lexp,v,body) -> + (* Rewrite E_internal_let into E_let and call recursively *) + let id = match lexp with + | LEXP_aux (LEXP_id id,_) -> id + | LEXP_aux (LEXP_cast (_,id),_) -> id + | _ -> + raise (Reporting_basic.err_unreachable l + "E_internal_let with a lexp that is not a variable") in + let pat = annot_pat (P_id id) l env (typ_of v) in + let lb = annot_letbind (P_id id, v) l env (typ_of v) in + let exp = propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) in + rewrite_var_updates exp + (* let env = env_of_annot annot in + let vtyp = typ_of v in + let veff = effect_of v in + let bodyenv = env_of body in + let bodytyp = typ_of body in + let bodyeff = effect_of body in + let pat = P_aux (P_id id, (simple_annot l vtyp)) in + let lbannot = (gen_loc l, Some (env, vtyp, veff)) in + let lb = LB_aux (LB_val (pat,v),lbannot) in + let exp = E_aux (E_let (lb,body),(gen_loc l, Some (bodyenv, bodytyp, union_effects veff bodyeff))) in + rewrite_var_updates exp *) + | E_internal_plet (pat,v,body) -> + failwith "rewrite_var_updates: E_internal_plet shouldn't be introduced yet" + (* There are no expressions that have effects or variable updates in + "tail-position": check the definition nexp_term and where it is used. *) + | _ -> exp + +let replace_memwrite_e_assign exp = + let e_aux = fun (expaux,annot) -> + match expaux with + | E_assign (LEXP_aux (LEXP_memory (id,args),_),v) -> E_aux (E_app (id,args @ [v]),annot) + | _ -> E_aux (expaux,annot) in + fold_exp { id_exp_alg with e_aux = e_aux } exp + + + +let remove_reference_types exp = + + let rec rewrite_t (Typ_aux (t_aux,a)) = (Typ_aux (rewrite_t_aux t_aux,a)) + and rewrite_t_aux t_aux = match t_aux with + | Typ_app (Id_aux (Id "reg",_), [Typ_arg_aux (Typ_arg_typ (Typ_aux (t_aux2, _)), _)]) -> + rewrite_t_aux t_aux2 + | Typ_app (name,t_args) -> Typ_app (name,List.map rewrite_t_arg t_args) + | Typ_fn (t1,t2,eff) -> Typ_fn (rewrite_t t1,rewrite_t t2,eff) + | Typ_tup ts -> Typ_tup (List.map rewrite_t ts) + | _ -> t_aux + and rewrite_t_arg t_arg = match t_arg with + | Typ_arg_aux (Typ_arg_typ t, a) -> Typ_arg_aux (Typ_arg_typ (rewrite_t t), a) + | _ -> t_arg in + + let rec rewrite_annot = function + | (l, None) -> (l, None) + | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_t typ, eff)) in + + map_exp_annot rewrite_annot exp + + + +let rewrite_defs_remove_superfluous_letbinds = + + let e_aux (exp,annot) = match exp with + | E_let (lb,exp2) -> + begin match lb,exp2 with + (* 'let x = EXP1 in x' can be replaced with 'EXP1' *) + | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), + E_aux (E_id (Id_aux (id',_)),_) + | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), + E_aux (E_cast (_,E_aux (E_id (Id_aux (id',_)),_)),_) + when id = id' -> + exp1 + (* "let x = EXP1 in return x" can be replaced with 'return (EXP1)', at + least when EXP1 is 'small' enough *) + | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), + E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) + when id = id' && small exp1 -> + let (E_aux (_,e1annot)) = exp1 in + E_aux (E_internal_return (exp1),e1annot) + | _ -> E_aux (exp,annot) + end + | _ -> E_aux (exp,annot) in + + let alg = { id_exp_alg with e_aux = e_aux } in + rewrite_defs_base + { rewrite_exp = (fun _ -> fold_exp alg) + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + + +let rewrite_defs_remove_superfluous_returns = + + let has_unittype e = match typ_of e with + | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> true + | _ -> false in + + let e_aux (exp,annot) = match exp with + | E_internal_plet (pat,exp1,exp2) when effectful exp1 -> + begin match pat,exp2 with + | P_aux (P_lit (L_aux (lit,_)),_), + E_aux (E_internal_return (E_aux (E_lit (L_aux (lit',_)),_)),_) + when lit = lit' -> + exp1 + | P_aux (P_wild,pannot), + E_aux (E_internal_return (E_aux (E_lit (L_aux (L_unit,_)),_)),_) + when has_unittype exp1 -> + exp1 + | P_aux (P_id (Id_aux (id,_)),_), + E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) + when id = id' -> + exp1 + | _ -> E_aux (exp,annot) + end + | _ -> E_aux (exp,annot) in + + let alg = { id_exp_alg with e_aux = e_aux } in + rewrite_defs_base + { rewrite_exp = (fun _ -> fold_exp alg) + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + + +let rewrite_defs_remove_e_assign = + let rewrite_exp _ e = + replace_memwrite_e_assign (remove_reference_types (rewrite_var_updates e)) in + rewrite_defs_base + { rewrite_exp = rewrite_exp + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + +let recheck_defs defs = fst (check initial_env defs) + +let rewrite_defs_lem = [ + ("top_sort_defs", top_sort_defs); + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + (* ("simple_assignments", rewrite_simple_assignments); *) + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); + ("guarded_pats", rewrite_defs_guarded_pats); + (* ("recheck_defs", recheck_defs); *) + ("early_return", rewrite_defs_early_return); + ("nexp_ids", rewrite_defs_nexp_ids); + ("fix_val_specs", rewrite_fix_val_specs); + ("exp_lift_assign", rewrite_defs_exp_lift_assign); + ("remove_blocks", rewrite_defs_remove_blocks); + ("letbind_effects", rewrite_defs_letbind_effects); + ("remove_e_assign", rewrite_defs_remove_e_assign); + ("effectful_let_expressions", rewrite_defs_effectful_let_expressions); + ("remove_superfluous_letbinds", rewrite_defs_remove_superfluous_letbinds); + ("remove_superfluous_returns", rewrite_defs_remove_superfluous_returns) + ] + +let rewrite_defs_ocaml = [ + (* ("top_sort_defs", top_sort_defs); *) + (* ("undefined", rewrite_undefined); *) + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + ("simple_assignments", rewrite_simple_assignments); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ("simple_types", rewrite_simple_types); + ("overload_cast", rewrite_overload_cast); + ("exp_lift_assign", rewrite_defs_exp_lift_assign); + (* ("separate_numbs", rewrite_defs_separate_numbs) *) + ] + +let rewrite_check_annot = + let check_annot exp = + try + prerr_endline ("CHECKING: " ^ string_of_exp exp ^ " : " ^ string_of_typ (typ_of exp)); + let _ = check_exp (env_of exp) (strip_exp exp) (typ_of exp) in + exp + with + Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) + in + let rewrite_exp = { id_exp_alg with e_aux = (fun (exp, annot) -> check_annot (E_aux (exp, annot))) } in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp) } + +let rewrite_defs_check = [ + ("check_annotations", rewrite_check_annot); + ] diff --git a/src/rewrites.mli b/src/rewrites.mli new file mode 100644 index 00000000..628296ec --- /dev/null +++ b/src/rewrites.mli @@ -0,0 +1,60 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Thomas Bauereiss *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Type_check + +(* Re-write undefined to functions created by -undefined_gen flag *) +val rewrite_undefined : bool -> tannot defs -> tannot defs + +(* Perform rewrites to exclude AST nodes not supported for ocaml out*) +val rewrite_defs_ocaml : (string * (tannot defs -> tannot defs)) list + +(* Perform rewrites to exclude AST nodes not supported for lem out*) +val rewrite_defs_lem : (string * (tannot defs -> tannot defs)) list + +(* This is a special rewriter pass that checks AST invariants without + actually doing any re-writing *) +val rewrite_defs_check : (string * (tannot defs -> tannot defs)) list + +val simple_typ : typ -> typ -- cgit v1.2.3 From 1dcd59b9cb80f879dff96061ba7ee8111dcff0f9 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 27 Nov 2017 18:51:37 +0000 Subject: Added test for short-circuiting of boolean operations --- test/ocaml/short_circuit/expect | 1 + test/ocaml/short_circuit/sc.sail | 15 +++++++++++++++ 2 files changed, 16 insertions(+) create mode 100644 test/ocaml/short_circuit/expect create mode 100644 test/ocaml/short_circuit/sc.sail diff --git a/test/ocaml/short_circuit/expect b/test/ocaml/short_circuit/expect new file mode 100644 index 00000000..9766475a --- /dev/null +++ b/test/ocaml/short_circuit/expect @@ -0,0 +1 @@ +ok diff --git a/test/ocaml/short_circuit/sc.sail b/test/ocaml/short_circuit/sc.sail new file mode 100644 index 00000000..a0f4941d --- /dev/null +++ b/test/ocaml/short_circuit/sc.sail @@ -0,0 +1,15 @@ + +val fail : unit -> bool effect {escape} + +function fail () = { + assert(false); + true +} + +val main : unit -> unit effect {escape} + +function main () = { + assert(~(false & fail())); + assert(true | fail()); + print("ok") +} \ No newline at end of file -- cgit v1.2.3 From 9f83f2c0e59eda827c0dce50c087b561f73062d8 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 27 Nov 2017 19:37:56 +0000 Subject: Utility functions in ast_util for asl_parser --- src/ast_util.ml | 3 ++- src/ast_util.mli | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/ast_util.ml b/src/ast_util.ml index b9e03987..1bce4ce5 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -251,7 +251,8 @@ let npow2 n = Nexp_aux (Nexp_exp n, Parse_ast.Unknown) let nvar kid = Nexp_aux (Nexp_var kid, Parse_ast.Unknown) let nid id = Nexp_aux (Nexp_id id, Parse_ast.Unknown) -let nc_set kid ints = mk_nc (NC_set (kid, ints)) +let nc_set kid nums = mk_nc (NC_set (kid, nums)) +let nc_int_set kid ints = mk_nc (NC_set (kid, List.map big_int_of_int ints)) let nc_eq n1 n2 = mk_nc (NC_equal (n1, n2)) let nc_neq n1 n2 = mk_nc (NC_not_equal (n1, n2)) let nc_lteq n1 n2 = NC_aux (NC_bounded_le (n1, n2), Parse_ast.Unknown) diff --git a/src/ast_util.mli b/src/ast_util.mli index 66d87c71..8206637c 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -133,6 +133,7 @@ val nc_or : n_constraint -> n_constraint -> n_constraint val nc_true : n_constraint val nc_false : n_constraint val nc_set : kid -> big_int list -> n_constraint +val nc_int_set : kid -> int list -> n_constraint (* Negate a n_constraint. Note that there's no NC_not constructor, so this flips all the inequalites a the n_constraint leaves and uses -- cgit v1.2.3 From 32a659a025cb239a32e8a831200e458af3c54c52 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 28 Nov 2017 16:33:34 +0000 Subject: Fix issue where statements in blocks had incorrect environments --- src/rewrites.ml | 3 +++ src/type_check.ml | 5 ++++- src/type_check.mli | 2 ++ 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/src/rewrites.ml b/src/rewrites.ml index 74f252f4..363761f5 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2755,6 +2755,9 @@ let rewrite_check_annot = try prerr_endline ("CHECKING: " ^ string_of_exp exp ^ " : " ^ string_of_typ (typ_of exp)); let _ = check_exp (env_of exp) (strip_exp exp) (typ_of exp) in + (if not (alpha_equivalent (env_of exp) (typ_of exp) (Env.expand_synonyms (env_of exp) (typ_of exp))) + then raise (Reporting_basic.err_typ Parse_ast.Unknown "Found synonym in annotation") + else ()); exp with Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) diff --git a/src/type_check.ml b/src/type_check.ml index 2260416d..6c158f9e 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -1994,7 +1994,10 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ match (exp_aux, typ_aux) with | E_block exps, _ -> begin - let rec check_block l env exps typ = match exps with + let rec check_block l env exps typ = + let annot_exp_effect exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in + let annot_exp exp typ = annot_exp_effect exp typ no_effect in + match exps with | [] -> typ_equality l env typ unit_typ; [] | [exp] -> [crule check_exp env exp typ] | (E_aux (E_assign (lexp, bind), _) :: exps) -> diff --git a/src/type_check.mli b/src/type_check.mli index 99385b31..355740dc 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -231,6 +231,8 @@ val string_of_uvar : uvar -> string val unify : l -> Env.t -> typ -> typ -> uvar KBindings.t * kid list * n_constraint option +val alpha_equivalent : Env.t -> typ -> typ -> bool + (* Throws Invalid_argument if the argument is not a E_app expression *) val instantiation_of : tannot exp -> uvar KBindings.t -- cgit v1.2.3 From 0952ebb7800fe1c396f6916c33bbc19a3b895308 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 28 Nov 2017 18:48:19 +0000 Subject: Small update to trivial sizeof rewrites so we can handle all cases in aarch64 vector instructions. There's maybe a better more general way to do this but I'm not sure what that would be. --- editors/sail2-mode.el | 2 +- lib/ocaml_rts/sail_lib.ml | 3 +++ src/rewrites.ml | 7 +++++++ 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/editors/sail2-mode.el b/editors/sail2-mode.el index b93542b5..8dde96df 100644 --- a/editors/sail2-mode.el +++ b/editors/sail2-mode.el @@ -8,7 +8,7 @@ "else" "match" "in" "return" "register" "forall" "operator" "effect" "overload" "cast" "sizeof" "constraint" "default" "assert" "pure" "infixl" "infixr" "infix" "scattered" "end" "try" "catch" "and" - "throw" "clause" "as" "repeat" "until" "while" "do")) + "throw" "clause" "as" "repeat" "until" "while" "do" "foreach")) (defconst sail2-kinds '("Int" "Type" "Order" "inc" "dec" diff --git a/lib/ocaml_rts/sail_lib.ml b/lib/ocaml_rts/sail_lib.ml index 3cf4505d..dfdd1db9 100644 --- a/lib/ocaml_rts/sail_lib.ml +++ b/lib/ocaml_rts/sail_lib.ml @@ -413,6 +413,8 @@ let real_power (x, y) = Num.power_num x (Num.num_of_big_int y) let add_real (x, y) = Num.add_num x y let sub_real (x, y) = Num.sub_num x y +let abs_real x = Num.abs_num x + let lt (x, y) = lt_big_int x y let gt (x, y) = gt_big_int x y let lteq (x, y) = le_big_int x y @@ -422,6 +424,7 @@ let pow2 x = power_big_int_positive_int x 2 let max_int (x, y) = max_big_int x y let min_int (x, y) = min_big_int x y +let abs_int x = abs_big_int x let undefined_real () = Num.num_of_int 0 diff --git a/src/rewrites.ml b/src/rewrites.ml index 363761f5..13d811e4 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -167,6 +167,13 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = let var = E_aux (E_id id, (l, Some (env, typ, no_effect))) in match destruct_atom_nexp env typ with | Some size when prove env (nc_eq size nexp) -> Some var + (* AA: This next case is a bit of a hack... is there a more + general way to deal with trivial nexps that are offset by + constants? This will resolve a 'n - 1 sizeof when 'n is in + scope. *) + | Some size when prove env (nc_eq (nsum size (nint 1)) nexp) -> + let one_exp = infer_exp env (mk_lit_exp (L_num unit_big_int)) in + Some (E_aux (E_app (mk_id "add_range", [var; one_exp]), (gen_loc l, Some (env, atom_typ (nsum size (nint 1)), no_effect)))) | _ -> begin match destruct_vector env typ with -- cgit v1.2.3 From 4469f1295fcdf567edcc71c823fdec6a8194ca94 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 28 Nov 2017 19:56:25 +0000 Subject: Make pretty printer able to print several internal constructs for debugging --- src/pretty_print_sail2.ml | 4 ++++ src/process_file.ml | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/pretty_print_sail2.ml b/src/pretty_print_sail2.ml index e354fe58..8c8b5661 100644 --- a/src/pretty_print_sail2.ml +++ b/src/pretty_print_sail2.ml @@ -194,6 +194,8 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = separate space [string "match"; doc_exp exp; doc_pexps pexps] | E_let (LB_aux (LB_val (pat, binding), _), exp) -> separate space [string "let"; doc_pat pat; equals; doc_exp binding; string "in"; doc_exp exp] + | E_internal_let (lexp, binding, exp) -> + separate space [string "var"; doc_lexp lexp; equals; doc_exp binding; string "in"; doc_exp exp] | E_assign (lexp, exp) -> separate space [doc_lexp lexp; equals; doc_exp exp] | E_for (id, exp1, exp2, exp3, order, exp4) -> @@ -247,6 +249,8 @@ and doc_block = function | [] -> string "()" | [E_aux (E_let (LB_aux (LB_val (pat, binding), _), E_aux (E_block exps, _)), _)] -> separate space [string "let"; doc_pat pat; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps + | [E_aux (E_internal_let (lexp, binding, E_aux (E_block exps, _)), _)] -> + separate space [string "var"; doc_lexp lexp; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps | [exp] -> doc_exp exp | exp :: exps -> doc_exp exp ^^ semi ^^ hardline ^^ doc_block exps and doc_lexp (LEXP_aux (l_aux, _) as lexp) = diff --git a/src/process_file.ml b/src/process_file.ml index e4518837..92b3f328 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -210,7 +210,7 @@ let rewrite_step defs (name,rewriter) = | Some (f, i) -> begin let filename = f ^ "_rewrite_" ^ string_of_int i ^ "_" ^ name ^ ".sail" in - output "" Lem_ast_out [filename, defs]; + (* output "" Lem_ast_out [filename, defs]; *) let ((ot,_, _) as ext_ot) = open_output_with_check_unformatted filename in Pretty_print_sail2.pp_defs ot defs; close_output_with_check ext_ot; -- cgit v1.2.3 From bc29b556b76f4f7f16f4256201bb50fda72da54f Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 29 Nov 2017 14:33:32 +0000 Subject: Added location information for fixity and overloads in ast_util.ml --- src/ast_util.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/ast_util.ml b/src/ast_util.ml index 1bce4ce5..d2712133 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -415,12 +415,12 @@ let def_loc = function | DEF_spec (VS_aux (_, (l, _))) | DEF_default (DT_aux (_, l)) | DEF_scattered (SD_aux (_, (l, _))) - | DEF_reg_dec (DEC_aux (_, (l, _))) -> + | DEF_reg_dec (DEC_aux (_, (l, _))) + | DEF_fixity (_, _, Id_aux (_, l)) + | DEF_overload (Id_aux (_, l), _) -> l | DEF_internal_mutrec _ - | DEF_comm _ - | DEF_overload _ - | DEF_fixity _ -> + | DEF_comm _ -> Parse_ast.Unknown let string_of_id = function -- cgit v1.2.3 From d25a996750978e7624902852bde90a679b50261e Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 29 Nov 2017 16:08:57 +0000 Subject: Fix lem_ast output bugs --- src/pretty_print_lem_ast.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index a91a6f08..443a2c63 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -74,7 +74,7 @@ let lemnum default n = "int" ^ string_of_big_int n else if ge_big_int n zero_big_int then default n - else ("(zero - " ^ (default (abs_big_int n)) ^ ")") + else ("(int0 - " ^ (default (abs_big_int n)) ^ ")") let pp_format_id (Id_aux(i,_)) = match i with @@ -300,9 +300,14 @@ let rec pp_format_nes nes = nes) ^*) "]" let pp_format_annot = function + | _ -> "Nothing" + + (* | None -> "Nothing" | Some (_, typ, eff) -> "(Just (" ^ pp_format_typ_lem typ ^ ", " ^ pp_format_effects_lem eff ^ "))" + *) + (* | NoTyp -> "Nothing" | Base((_,t),tag,nes,efct,efctsum,_) -> @@ -471,7 +476,7 @@ and pp_lem_case ppf = function | Pat_aux(Pat_exp(pat,exp),(l,annot)) -> fprintf ppf "@[<1>(Pat_aux (Pat_exp %a@ %a) (%a, %a))@]" pp_lem_pat pat pp_lem_exp exp pp_lem_l l pp_annot annot | Pat_aux(Pat_when(pat,guard,exp),(l,annot)) -> - fprintf ppf "@[<1>(Pat_aux (Pat_exp %a@ %a %a) (%a, %a))@]" pp_lem_pat pat pp_lem_exp guard pp_lem_exp exp pp_lem_l l pp_annot annot + fprintf ppf "@[<1>(Pat_aux (Pat_when %a@ %a %a) (%a, %a))@]" pp_lem_pat pat pp_lem_exp guard pp_lem_exp exp pp_lem_l l pp_annot annot and pp_semi_lem_case ppf case = fprintf ppf "@[<1>%a %a@]" pp_lem_case case kwd ";" and pp_lem_lexp ppf (LEXP_aux(lexp,(l,annot))) = -- cgit v1.2.3 From 636d81ee6afba69b7a2516e8149eeef3691cd67e Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 29 Nov 2017 18:13:17 +0000 Subject: Switched to bytecode compiler for executing interpreter to avoid stack overflow --- src/Makefile | 8 ++++++-- src/lem_interp/instruction_extractor.lem | 5 ++++- src/pretty_print_lem_ast.ml | 12 +++++++----- 3 files changed, 17 insertions(+), 8 deletions(-) diff --git a/src/Makefile b/src/Makefile index 298d22c8..e0c1e45c 100644 --- a/src/Makefile +++ b/src/Makefile @@ -79,7 +79,8 @@ LEM = $(BITBUCKET_ROOT)/lem/lem LEMLIBOCAML = $(BITBUCKET_ROOT)/lem/ocaml-lib ELFDIR= $(BITBUCKET_ROOT)/linksem ZARITH_DIR=$(LEMLIBOCAML)/dependencies/zarith -ZARITH_LIB=$(ZARITH_DIR)/zarith.cmxa +ZARITH_LIB=$(ZARITH_DIR)/zarith.cma +# ZARITH_LIB=$(ZARITH_DIR)/zarith.cmxa SAIL_LIB_DIR:=$(SAIL_DIR)/lib MIPS_SAIL_DIR:=$(SAIL_DIR)/mips_new_tc @@ -204,8 +205,11 @@ count: _build/cheri_trimmed.sail _build/mips_trimmed.sail %.ml: %.lem $(LEM) -only_changed_output -ocaml -lib lem_interp/ $< +#run_mips.native: _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml interpreter +# env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_mips.native + run_mips.native: _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml interpreter - env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_mips.native + env OCAMLRUNPARAM=l=100M ocamlfind ocamlc $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cma $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cma $(ELFDIR)/src/linksem.cma _build/pprint/src/PPrintLib.cma _build/lem_interp/extract.cma _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_mips.native run_cheri.native: _build/cheri.ml _build/mips_extras.ml _build/run_with_elf_cheri.ml interpreter env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/cheri.ml _build/mips_extras.ml _build/run_with_elf_cheri.ml -o run_cheri.native diff --git a/src/lem_interp/instruction_extractor.lem b/src/lem_interp/instruction_extractor.lem index 8bc19f8c..056f0100 100644 --- a/src/lem_interp/instruction_extractor.lem +++ b/src/lem_interp/instruction_extractor.lem @@ -127,7 +127,10 @@ let rec extract_patt_parm (P_aux p (_,tannot)) = let rec extract_from_execute fcls = match fcls with | [] -> [] | FCL_aux (FCL_Funcl _ (P_aux (P_app (Id_aux (Id i) _) parms) _) _) (_,Just(_,_,_,Effect_aux(Effect_set efs) _,_))::fcls -> - (Instr_form i (List.map extract_patt_parm parms) efs)::extract_from_execute fcls + (Instr_form i (List.map extract_patt_parm parms) efs)::extract_from_execute fcls + | _ :: fcls -> + (* AA: Find out what breaks this *) + extract_from_execute fcls end let rec extract_effects instrs execute = diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index 443a2c63..65d99780 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -300,13 +300,15 @@ let rec pp_format_nes nes = nes) ^*) "]" let pp_format_annot = function - | _ -> "Nothing" - - (* | None -> "Nothing" | Some (_, typ, eff) -> - "(Just (" ^ pp_format_typ_lem typ ^ ", " ^ pp_format_effects_lem eff ^ "))" - *) + "(Just (" + ^ pp_format_typ_lem typ ^ ", " + ^ "Tag_empty" ^ ", " + ^ "[], " + ^ pp_format_effects_lem eff ^ ", " + ^ pp_format_effects_lem eff + ^ "))" (* | NoTyp -> "Nothing" -- cgit v1.2.3 From 16c475fff5b1942eacc4f399ff14a0bca0c9cec2 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 29 Nov 2017 19:29:48 +0000 Subject: Better lem_ast tagging and interpreter tweaks --- src/lem_interp/interp_inter_imp.lem | 3 ++- src/lem_interp/run_interp_model.ml | 8 +++---- src/pretty_print_lem_ast.ml | 46 ++++++++++++------------------------- 3 files changed, 21 insertions(+), 36 deletions(-) diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 68f82ccb..e9533a2a 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -440,7 +440,8 @@ let rec interp_to_value_helper debug arg ivh_mode err_str instr direction regist (Ivh_error (Interp_interface.Internal_error ("Write memory value request in a " ^ errk_str)), events_out) | (Interp.Action (Interp.Write_memv_tagged _ _ _ _) _,_,_) -> (Ivh_error (Interp_interface.Internal_error ("Write memory value tagged request in a " ^ errk_str)), events_out) - | _ -> (Ivh_error (Interp_interface.Internal_error ("Non expected action in a " ^ errk_str)), events_out) + | (outcome, _, _) -> + (Ivh_error (Interp_interface.Internal_error ("Non expected action in a " ^ errk_str ^ " " ^ Interp.string_of_outcome outcome)), events_out) end let call_external_functions direction outcome = diff --git a/src/lem_interp/run_interp_model.ml b/src/lem_interp/run_interp_model.ml index 6978aeb9..81f0a5fd 100644 --- a/src/lem_interp/run_interp_model.ml +++ b/src/lem_interp/run_interp_model.ml @@ -433,7 +433,7 @@ let run (List.combine nondets (List.map (fun _ -> Random.bits ()) nondets)) in show "nondeterministic evaluation begun" "" "" ""; let (_,_,_,env') = List.fold_right (fun (next,_) (_,_,_,env') -> - loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies false) next)) + loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies true) next)) choose_order (false,mode,!track_dependencies,env'); in show "nondeterministic evaluation ended" "" "" ""; (step next,env',next) @@ -445,7 +445,7 @@ let run else begin show "undefined triggered a non_det" "" "" ""; let (_,_,_,env') = List.fold_right (fun (next,_) (_,_,_,env') -> - loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies false) next)) + loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies true) next)) choose_order (false,mode,!track_dependencies,env'); in (step i_state,env',i_state) end | Escape0(Some e,_) -> @@ -462,11 +462,11 @@ let run | Write_memv1 _ -> assert false) (*| _ -> assert false*) in - loop mode' env' (Interp_inter_imp.interp0 (make_mode (mode' = Run) !track_dependencies false) next) in + loop mode' env' (Interp_inter_imp.interp0 (make_mode (mode' = Run) !track_dependencies true) next) in let mode = match mode with | None -> if eager_eval then Run else Step | Some m -> m in - let imode = make_mode eager_eval !track_dependencies false in + let imode = make_mode eager_eval !track_dependencies true in let (IState(instr_state,context)) = istate in let (top_exp,(top_env,top_mem)) = top_frame_exp_state instr_state in interactf "%s: %s %s\n" (grey name) (blue "evaluate") diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index 65d99780..65fa5d25 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -281,45 +281,28 @@ let pp_format_lit_lem (L_aux(lit,l)) = let pp_lem_lit ppf l = base ppf (pp_format_lit_lem l) -let rec pp_format_nes nes = - "[" ^ (* - (list_format "; " - (fun ne -> match ne with - | LtEq(_,n1,n2) -> "(Nec_lteq " ^ pp_format_n_lem n1 ^ " " ^ pp_format_n_lem n2 ^ ")" - | Eq(_,n1,n2) -> "(Nec_eq " ^ pp_format_n_lem n1 ^ " " ^ pp_format_n_lem n2 ^ ")" - | GtEq(_,n1,n2) -> "(Nec_gteq " ^ pp_format_n_lem n1 ^ " " ^ pp_format_n_lem n2 ^ ")" - | In(_,i,ns) | InS(_,{nexp=Nvar i},ns) -> - "(Nec_in \"" ^ i ^ "\" [" ^ (list_format "; " string_of_int ns)^ "])" - | InS(_,_,ns) -> - "(Nec_in \"fresh\" [" ^ (list_format "; " string_of_int ns)^ "])" - | CondCons(_,nes_c,nes_t) -> - "(Nec_cond " ^ (pp_format_nes nes_c) ^ " " ^ (pp_format_nes nes_t) ^ ")" - | BranchCons(_,nes_b) -> - "(Nec_branch " ^ (pp_format_nes nes_b) ^ ")" - ) - nes) ^*) "]" - -let pp_format_annot = function +let tag_id id env = + if Env.is_extern id env "lem_ast" then + "Tag_extern (Just \"" ^ Ast_util.string_of_id id ^ "\")" + else if Env.is_union_constructor id env then + "Tag_ctor" + else + "Tag_empty" + +let pp_format_annot ?tag:(t="Tag_empty") = function | None -> "Nothing" | Some (_, typ, eff) -> "(Just (" ^ pp_format_typ_lem typ ^ ", " - ^ "Tag_empty" ^ ", " + ^ t ^ ", " ^ "[], " ^ pp_format_effects_lem eff ^ ", " ^ pp_format_effects_lem eff ^ "))" -(* - | NoTyp -> "Nothing" - | Base((_,t),tag,nes,efct,efctsum,_) -> - (*TODO print out bindings for use in pattern match in interpreter*) - "(Just (" ^ pp_format_t_lem t ^ ", " ^ pp_format_tag tag ^ ", " ^ pp_format_nes nes ^ ", " ^ - pp_format_e_lem efct ^ ", " ^ pp_format_e_lem efctsum ^ "))" - | Overload _ -> "Nothing" *) - let pp_annot ppf ant = base ppf (pp_format_annot ant) +let pp_annot_tag tag ppf ant = base ppf (pp_format_annot ~tag:tag ant) let rec pp_format_pat_lem (P_aux(p,(l,annot))) = "(P_aux " ^ @@ -352,7 +335,8 @@ let rec pp_lem_let ppf (LB_aux(lb,(l,annot))) = fprintf ppf "@[<0>(%a %a %a)@]" kwd "LB_val" pp_lem_pat pat pp_lem_exp exp in fprintf ppf "@[<0>(LB_aux %a (%a, %a))@]" print_lb lb pp_lem_l l pp_annot annot -and pp_lem_exp ppf (E_aux(e,(l,annot))) = +and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = + let env = env_of exp in let print_e ppf e = match e with | E_block(exps) -> fprintf ppf "@[<0>(E_aux %a [%a] %a (%a, %a))@]" @@ -363,13 +347,13 @@ and pp_lem_exp ppf (E_aux(e,(l,annot))) = kwd "(E_nondet" (list_pp pp_semi_lem_exp pp_lem_exp) exps kwd ")" pp_lem_l l pp_annot annot - | E_id(id) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_id" pp_lem_id id pp_lem_l l pp_annot annot + | E_id(id) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_id" pp_lem_id id pp_lem_l l (pp_annot_tag (tag_id id env)) annot | E_lit(lit) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_lit" pp_lem_lit lit pp_lem_l l pp_annot annot | E_cast(typ,exp) -> fprintf ppf "@[<0>(E_aux (E_cast %a %a) (%a, %a))@]" pp_lem_typ typ pp_lem_exp exp pp_lem_l l pp_annot annot | E_internal_cast((_,None),e) -> pp_lem_exp ppf e | E_app(f,args) -> fprintf ppf "@[<0>(E_aux (E_app %a [%a]) (%a, %a))@]" - pp_lem_id f (list_pp pp_semi_lem_exp pp_lem_exp) args pp_lem_l l pp_annot annot + pp_lem_id f (list_pp pp_semi_lem_exp pp_lem_exp) args pp_lem_l l (pp_annot_tag (tag_id f env)) annot | E_app_infix(l',op,r) -> fprintf ppf "@[<0>(E_aux (E_app_infix %a %a %a) (%a, %a))@]" pp_lem_exp l' pp_lem_id op pp_lem_exp r pp_lem_l l pp_annot annot | E_tuple(exps) -> fprintf ppf "@[<0>(E_aux (E_tuple [%a]) (%a, %a))@]" -- cgit v1.2.3 From 9e1309ab7c1a137324c88c272c5a76c4c8bce016 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 30 Nov 2017 15:40:43 +0000 Subject: match what rmem (ppcmem2) expects from ISA Makefiles --- mips/Makefile | 23 + mips/mips_extras.lem | 14 +- risc-v/Makefile | 24 +- risc-v/riscv_extras.lem | 12 +- x86/Makefile | 23 +- x86/gen/ast.hgen | 26 ++ x86/gen/fold.hgen | 26 ++ x86/gen/herdtools_ast_to_shallow_ast.hgen | 28 ++ x86/gen/herdtools_types_to_shallow_types.hgen | 93 ++++ x86/gen/lexer.hgen | 399 +++++++++++++++++ x86/gen/lexer_intel.hgen | 161 +++++++ x86/gen/map.hgen | 26 ++ x86/gen/parser.hgen | 600 +++++++++++++++++++++++++ x86/gen/parser_intel.hgen | 601 ++++++++++++++++++++++++++ x86/gen/pretty.hgen | 50 +++ x86/gen/sail_trans_out.hgen | 1 + x86/gen/shallow_ast_to_herdtools_ast.hgen | 27 ++ x86/gen/shallow_types_to_herdtools_types.hgen | 97 +++++ x86/gen/token_types.hgen | 29 ++ x86/gen/tokens.hgen | 28 ++ x86/gen/trans_sail.hgen | 28 ++ x86/gen/types.hgen | 134 ++++++ x86/gen/types_sail_trans_out.hgen | 1 + x86/gen/types_trans_sail.hgen | 61 +++ x86/x86_extras.lem | 53 +++ x86/x86_extras_embed.lem | 24 + x86/x86_extras_embed_sequential.lem | 24 + 27 files changed, 2589 insertions(+), 24 deletions(-) create mode 100644 mips/Makefile create mode 100644 x86/gen/ast.hgen create mode 100644 x86/gen/fold.hgen create mode 100644 x86/gen/herdtools_ast_to_shallow_ast.hgen create mode 100644 x86/gen/herdtools_types_to_shallow_types.hgen create mode 100644 x86/gen/lexer.hgen create mode 100644 x86/gen/lexer_intel.hgen create mode 100644 x86/gen/map.hgen create mode 100644 x86/gen/parser.hgen create mode 100644 x86/gen/parser_intel.hgen create mode 100644 x86/gen/pretty.hgen create mode 100644 x86/gen/sail_trans_out.hgen create mode 100644 x86/gen/shallow_ast_to_herdtools_ast.hgen create mode 100644 x86/gen/shallow_types_to_herdtools_types.hgen create mode 100644 x86/gen/token_types.hgen create mode 100644 x86/gen/tokens.hgen create mode 100644 x86/gen/trans_sail.hgen create mode 100644 x86/gen/types.hgen create mode 100644 x86/gen/types_sail_trans_out.hgen create mode 100644 x86/gen/types_trans_sail.hgen create mode 100644 x86/x86_extras.lem create mode 100644 x86/x86_extras_embed.lem create mode 100644 x86/x86_extras_embed_sequential.lem diff --git a/mips/Makefile b/mips/Makefile new file mode 100644 index 00000000..03d7ae15 --- /dev/null +++ b/mips/Makefile @@ -0,0 +1,23 @@ +SAIL:=../src/sail.native +LEM:=../../lem/lem + +# SOURCES:=mips_prelude.sail mips_tlb.sail mips_wrappers.sail mips_insts.sail mips_ri.sail mips_epilogue.sail ../etc/regfp.sail mips_regfp.sail +SOURCES:=mips_prelude.sail mips_tlb_stub.sail mips_wrappers.sail mips_insts.sail mips_epilogue.sail ../etc/regfp.sail mips_regfp.sail + + +all: mips.lem mips.ml mips_embed.lem + +mips.lem: $(SOURCES) + $(SAIL) -lem_ast -o $(BUILD)/mips $(SOURCES) + +mips.ml: mips.lem ../src/lem_interp/interp_ast.lem + $(LEM) -ocaml -lib ../src/lem_interp/ $< + + +mips_embed.lem: $(SOURCES) +# also generates mips_embed_sequential.lem, mips_embed_types.lem, mips_toFromInterp.lem + $(SAIL) -lem -lem_lib Mips_extras_embed -o mips $(SOURCES) + +clean: + rm -f mips.lem mips.ml + rm -f mips_embed*.lem mips_toFromInterp.lem diff --git a/mips/mips_extras.lem b/mips/mips_extras.lem index 1fbba038..be576fb2 100644 --- a/mips/mips_extras.lem +++ b/mips/mips_extras.lem @@ -31,25 +31,25 @@ let memory_parameter_transformer_option_address _mode v = end -let read_memory_functions : memory_reads = +let mips_read_memory_functions : memory_reads = [ ("MEMr", (MR Read_plain memory_parameter_transformer)); ("MEMr_reserve", (MR Read_reserve memory_parameter_transformer)); ] -let read_memory_tagged_functions : memory_read_taggeds = +let mips_read_memory_tagged_functions : memory_read_taggeds = [ ("MEMr_tag", (MRT Read_plain memory_parameter_transformer)); ("MEMr_tag_reserve", (MRT Read_reserve memory_parameter_transformer)); ] -let memory_writes : memory_writes = +let mips_memory_writes : memory_writes = [] -let memory_eas : memory_write_eas = +let mips_memory_eas : memory_write_eas = [ ("MEMea", (MEA Write_plain memory_parameter_transformer)); ("MEMea_conditional", (MEA Write_conditional memory_parameter_transformer)); ] -let memory_vals : memory_write_vals = +let mips_memory_vals : memory_write_vals = [ ("MEMval", (MV memory_parameter_transformer_option_address Nothing)); ("MEMval_conditional", (MV memory_parameter_transformer_option_address (Just @@ -58,7 +58,7 @@ let memory_vals : memory_write_vals = (IState (Interp.add_answer_to_stack interp bit) context))))); ] -let memory_vals_tagged : memory_write_vals_tagged = +let mips_memory_vals_tagged : memory_write_vals_tagged = [ ("MEMval_tag", (MVT memory_parameter_transformer_option_address Nothing)); ("MEMval_tag_conditional", (MVT memory_parameter_transformer_option_address @@ -68,6 +68,6 @@ let memory_vals_tagged : memory_write_vals_tagged = (IState (Interp.add_answer_to_stack interp bit) context))))); ] -let barrier_functions = [ +let mips_barrier_functions = [ ("MEM_sync", Barrier_MIPS_SYNC); ] diff --git a/risc-v/Makefile b/risc-v/Makefile index 8449c7c4..bc46e4c2 100644 --- a/risc-v/Makefile +++ b/risc-v/Makefile @@ -1,14 +1,22 @@ - SAIL:=../src/sail.native +LEM:=../../lem/lem + SOURCES:=riscv_types.sail riscv.sail ../etc/regfp.sail riscv_regfp.sail -all: lem_ast shallow -lem_ast: $(SOURCES) $(SAIL) - $(SAIL) -lem_ast $(SOURCES) -o riscv -shallow: $(SOURCES) $(SAIL) - $(SAIL) -lem_lib Riscv_extras_embed -lem $(SOURCES) -o riscv +all: riscv.lem riscv.ml riscv_embed.lem + +riscv.lem: $(SOURCES) + $(SAIL) -lem_ast -o riscv $(SOURCES) + +riscv.ml: riscv.lem ../src/lem_interp/interp_ast.lem + $(LEM) -ocaml -lib ../src/lem_interp/ $< + + +riscv_embed.lem: $(SOURCES) +# also generates riscv_embed_sequential.lem, riscv_embed_types.lem, riscv_toFromInterp.lem + $(SAIL) -lem -lem_lib Riscv_extras_embed -o riscv $(SOURCES) clean: - rm -f riscv.lem riscv_embed*.lem riscv_toFromInterp.lem - rm -f riscv_type*.lem + rm -f riscv.lem riscv.ml + rm -f riscv_embed*.lem riscv_toFromInterp.lem diff --git a/risc-v/riscv_extras.lem b/risc-v/riscv_extras.lem index 30043779..4ca5f9b7 100644 --- a/risc-v/riscv_extras.lem +++ b/risc-v/riscv_extras.lem @@ -31,7 +31,7 @@ let memory_parameter_transformer_option_address _mode v = end -let read_memory_functions : memory_reads = +let riscv_read_memory_functions : memory_reads = [ ("MEMr", (MR Read_plain memory_parameter_transformer)); ("MEMr_acquire", (MR Read_RISCV_acquire memory_parameter_transformer)); ("MEMr_strong_acquire", (MR Read_RISCV_strong_acquire memory_parameter_transformer)); @@ -41,10 +41,10 @@ let read_memory_functions : memory_reads = (MR Read_RISCV_reserved_acquire memory_parameter_transformer)); ] -let memory_writes : memory_writes = +let riscv_memory_writes : memory_writes = [] -let memory_eas : memory_write_eas = +let riscv_memory_eas : memory_write_eas = [ ("MEMea", (MEA Write_plain memory_parameter_transformer)); ("MEMea_release", (MEA Write_RISCV_release memory_parameter_transformer)); ("MEMea_strong_release", (MEA Write_RISCV_strong_release memory_parameter_transformer)); @@ -55,7 +55,7 @@ let memory_eas : memory_write_eas = memory_parameter_transformer)); ] -let memory_vals : memory_write_vals = +let riscv_memory_vals : memory_write_vals = [ ("MEMval", (MV memory_parameter_transformer_option_address Nothing)); ("MEMval_release", (MV memory_parameter_transformer_option_address Nothing)); ("MEMval_strong_release", (MV memory_parameter_transformer_option_address Nothing)); @@ -66,14 +66,14 @@ let memory_vals : memory_write_vals = ] -let speculate_conditional_success : excl_res = +let riscv_speculate_conditional_success : excl_res = let f = fun (IState interp context) b -> let bool_res = Interp_ast.V_lit (L_aux (if b then L_one else L_zero) Interp_ast.Unknown) in IState (Interp.add_answer_to_stack interp bool_res) context in Just ("speculate_conditional_success", (ER (Just f))) -let barrier_functions = +let riscv_barrier_functions = [ ("MEM_fence_rw_rw", Barrier_RISCV_rw_rw); ("MEM_fence_r_rw", Barrier_RISCV_r_rw); ("MEM_fence_r_r", Barrier_RISCV_r_r); diff --git a/x86/Makefile b/x86/Makefile index 2bc4c1a4..6863714d 100644 --- a/x86/Makefile +++ b/x86/Makefile @@ -1,3 +1,20 @@ -all: - ../src/sail.native -o x86 -lem -lem_lib X86_extras_embed ../etc/regfp.sail x64.sail - ../src/sail.native -o x86 -lem_ast ../etc/regfp.sail x64.sail +SAIL=../src/sail.native +LEM:=../../lem/lem + +SOURCES=../etc/regfp.sail x64.sail + +all: x86.lem x86.ml x86_embed.lem + +x86.lem: + $(SAIL) -lem_ast -o x86 $(SOURCES) + +x86.ml: x86.lem ../src/lem_interp/interp_ast.lem + $(LEM) -ocaml -lib ../src/lem_interp/ $< + +x86_embed.lem: $(SOURCES) +# also generates x86_embed_sequential.lem, x86_embed_types.lem, x86_toFromInterp.lem + $(SAIL) -lem -lem_lib X86_extras_embed -o x86 $(SOURCES) + +clean: + rm -f x86.lem x86.ml + rm -f x86_embed*.lem x86_toFromInterp.lem diff --git a/x86/gen/ast.hgen b/x86/gen/ast.hgen new file mode 100644 index 00000000..83488eda --- /dev/null +++ b/x86/gen/ast.hgen @@ -0,0 +1,26 @@ +| `X86BINOP of bool * x86Binop * x86Size * x86Dest_src +| `X86BITOP of bool * x86Bitop * x86Size * x86Bit_offset +| `X86CALL of x86Imm_rm +| `X86CLC +| `X86CMC +| `X86CMPXCHG of bool * x86Size * x86Rm * reg +| `X86DIV of x86Size * x86Rm +| `X86JCC of x86Cond * bit64 +| `X86JMP of x86Rm +| `X86LEA of x86Size * x86Dest_src +| `X86LEAVE +| `X86LOOP of x86Cond * bit64 +| `X86MFENCE +| `X86MONOP of bool * x86Monop * x86Size * x86Rm +| `X86MOV of x86Cond * x86Size * x86Dest_src +| `X86MOVSX of x86Size * x86Dest_src * x86Size +| `X86MOVZX of x86Size * x86Dest_src * x86Size +| `X86MUL of x86Size * x86Rm +| `X86NOP +| `X86POP of x86Rm +| `X86PUSH of x86Imm_rm +| `X86RET of bit64 +| `X86SET of x86Cond * bool * x86Rm +| `X86STC +| `X86XADD of bool * x86Size * x86Rm * reg +| `X86XCHG of bool * x86Size * x86Rm * reg diff --git a/x86/gen/fold.hgen b/x86/gen/fold.hgen new file mode 100644 index 00000000..df546a13 --- /dev/null +++ b/x86/gen/fold.hgen @@ -0,0 +1,26 @@ +| `X86BINOP (_, _, _, ds) -> fold_dest_src ds c +| `X86BITOP (_, _, _, bo) -> fold_bit_offset bo c +| `X86CALL irm -> fold_imm_rm irm c +| `X86CLC -> c +| `X86CMC -> c +| `X86CMPXCHG (_, _, rm, r) -> fold_rm rm (fold_reg r c) +| `X86DIV (_, rm) -> fold_rm rm c +| `X86JCC _ -> c +| `X86JMP rm -> fold_rm rm c +| `X86LEA (_, ds) -> fold_dest_src ds c +| `X86LEAVE -> c +| `X86LOOP _ -> c +| `X86MFENCE -> c +| `X86MONOP (_, _, _, rm) -> fold_rm rm c +| `X86MOV (_, _, ds) -> fold_dest_src ds c +| `X86MOVSX (_, ds, _) -> fold_dest_src ds c +| `X86MOVZX (_, ds, _) -> fold_dest_src ds c +| `X86MUL (_, rm) -> fold_rm rm c +| `X86NOP -> c +| `X86POP rm -> fold_rm rm c +| `X86PUSH irm -> fold_imm_rm irm c +| `X86RET _ -> c +| `X86SET (_, _, rm) -> fold_rm rm c +| `X86STC -> c +| `X86XADD (_, _, rm, r) -> fold_rm rm (fold_reg r c) +| `X86XCHG (_, _, rm, r) -> fold_rm rm (fold_reg r c) diff --git a/x86/gen/herdtools_ast_to_shallow_ast.hgen b/x86/gen/herdtools_ast_to_shallow_ast.hgen new file mode 100644 index 00000000..c709ee6c --- /dev/null +++ b/x86/gen/herdtools_ast_to_shallow_ast.hgen @@ -0,0 +1,28 @@ +| `X86BINOP(locked, binop, sz, dest_src) -> Binop (translate_bool locked, translate_binop binop, translate_size sz, translate_dest_src dest_src) +| `X86BITOP(locked, op, sz, bo) -> Bitop (translate_bool locked, translate_bitop op, translate_size sz, translate_bitoffset bo) +| `X86CALL (imm_rm) -> CALL (translate_imm_rm imm_rm) +| `X86CLC -> CLC +| `X86CMC -> CMC +| `X86CMPXCHG (locked, sz, rm , reg) -> CMPXCHG (translate_bool locked, translate_size sz, translate_rm rm, translate_reg reg) +| `X86DIV (sz, rm) -> X86_DIV (translate_size sz, translate_rm rm) +| `X86StopFetching -> HLT +| `X86JCC (cond, imm64) -> Jcc (translate_cond cond, translate_imm64 imm64) +| `X86JMP (rm) -> JMP (translate_rm rm) +| `X86LEA (sz, dest_src) -> LEA (translate_size sz, translate_dest_src dest_src) +| `X86LEAVE -> LEAVE +| `X86LOOP (cond, imm64) -> LOOP (translate_cond cond, translate_imm64 imm64) +| `X86MFENCE -> MFENCE +| `X86MONOP (locked, monop, sz, rm) -> Monop (translate_bool locked, translate_monop monop, translate_size sz, translate_rm rm) +| `X86MOV (cond, sz, dest_src) -> MOV (translate_cond cond, translate_size sz, translate_dest_src dest_src) +| `X86MOVSX (sz1, dest_src, sz2) -> MOVSX (translate_size sz1, translate_dest_src dest_src, translate_size sz2) +| `X86MOVZX (sz1, dest_src, sz2) -> MOVZX (translate_size sz1, translate_dest_src dest_src, translate_size sz2) +| `X86MUL (sz, rm) -> X86_MUL (translate_size sz, translate_rm rm) +| `X86NOP -> NOP (Nat_big_num.of_int 0) +| `X86POP (rm) -> POP (translate_rm rm) +| `X86PUSH (imm_rm) -> PUSH (translate_imm_rm imm_rm) +| `X86RET (imm64) -> RET (translate_imm64 imm64) +| `X86SET (cond, b, rm) -> SET (translate_cond cond, translate_bool b, translate_rm rm) +| `X86STC -> STC +| `X86XADD (locked, sz, rm, reg) -> XADD (translate_bool locked, translate_size sz, translate_rm rm, translate_reg reg) +| `X86XCHG (locked, sz, rm, reg) -> XCHG (translate_bool locked, translate_size sz, translate_rm rm, translate_reg reg) + diff --git a/x86/gen/herdtools_types_to_shallow_types.hgen b/x86/gen/herdtools_types_to_shallow_types.hgen new file mode 100644 index 00000000..44e16991 --- /dev/null +++ b/x86/gen/herdtools_types_to_shallow_types.hgen @@ -0,0 +1,93 @@ +let is_inc = false + +let translate_bool = function + | true -> Sail_values.B1 + | false -> Sail_values.B0 + +let translate_binop = function + | X86ADD -> X86_Add + | X86OR -> X86_Or + | X86ADC -> X86_Adc + | X86SBB -> X86_Sbb + | X86AND -> X86_And + | X86SUB -> X86_Sub + | X86XOR -> X86_Xor + | X86CMP -> X86_Cmp + | X86ROL -> X86_Rol + | X86ROR -> X86_Ror + | X86RCL -> X86_Rcl + | X86RCR -> X86_Rcr + | X86SHL -> X86_Shl + | X86SHR -> X86_Shr + | X86TEST -> X86_Test + | X86SAR -> X86_Sar + +let translate_bitop = function + | X86Btc -> Btc + | X86Bts -> Bts + | X86Btr -> Btr + +let translate_size = function + | X86S8(high) -> Sz8 (translate_bool high) + | X86S16 -> Sz16 + | X86S32 -> Sz32 + | X86S64 -> Sz64 + +let translate_reg r = Nat_big_num.of_int (reg_to_int r) + +let translate_scale s = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 2, Nat_big_num.of_int s) + +let translate_imm64 i = Sail_values.to_vec0 is_inc (Nat_big_num.of_int 64, i) + +let translate_msi = function + | Some (scale, reg) -> Some (translate_scale scale, translate_reg reg) + | None -> None + +let translate_base = function + | X86HGenBase.NoBase -> X86_embed_types.NoBase + | X86HGenBase.RegBase(r) -> X86_embed_types.RegBase (translate_reg r) + | X86HGenBase.RipBase -> X86_embed_types.RipBase + +let translate_rm = function + | X86HGenBase.Reg (r) -> X86_embed_types.X86_Reg (translate_reg r) + | X86HGenBase.Mem (m_si, base, imm) -> X86_embed_types.Mem (translate_msi m_si, translate_base base, translate_imm64 imm) + | X86HGenBase.Sym (s) -> X86_embed_types.Mem (None, X86_embed_types.NoBase, translate_imm64 Nat_big_num.zero) + +let translate_dest_src = function + | X86HGenBase.R_rm (reg, rm) -> X86_embed_types.R_rm (translate_reg reg, translate_rm rm) + | X86HGenBase.Rm_i (rm, imm64) -> X86_embed_types.Rm_i (translate_rm rm, translate_imm64 imm64) + | X86HGenBase.Rm_r (rm, reg) -> X86_embed_types.Rm_r (translate_rm rm, translate_reg reg) + +let translate_imm_rm = function + | X86HGenBase.Imm (imm) -> X86_embed_types.Imm (translate_imm64 imm) + | X86HGenBase.Rm (rm) -> X86_embed_types.Rm (translate_rm rm) + +let translate_bitoffset = function + | X86HGenBase.Bit_rm_imm (rm, imm) -> Bit_rm_imm (translate_rm rm, translate_imm64 (Nat_big_num.of_int imm)) + | X86HGenBase.Bit_rm_r (rm, r) -> Bit_rm_r (translate_rm rm, translate_reg r) + +let translate_cond = function + | X86O -> X86_O + | X86NO -> X86_NO + | X86B -> X86_B + | X86NB -> X86_NB + | X86E -> X86_E + | X86NE -> X86_NE + | X86NA -> X86_NA + | X86A -> X86_A + | X86S -> X86_S + | X86NS -> X86_NS + | X86P -> X86_P + | X86NP -> X86_NP + | X86L -> X86_L + | X86NL -> X86_NL + | X86NG -> X86_NG + | X86G -> X86_G + | X86ALWAYS -> X86_ALWAYS + +let translate_monop = function + | X86DEC -> X86_Dec + | X86INC -> X86_Inc + | X86NOT -> X86_Not + | X86NEG -> X86_Neg diff --git a/x86/gen/lexer.hgen b/x86/gen/lexer.hgen new file mode 100644 index 00000000..56944e6d --- /dev/null +++ b/x86/gen/lexer.hgen @@ -0,0 +1,399 @@ +"addb" , BINOP { txt = "ADDB"; op = X86ADD; sz = X86BYTE }; +"orb" , BINOP { txt = "ORB"; op = X86OR; sz = X86BYTE }; +"adcb" , BINOP { txt = "ADCB"; op = X86ADC; sz = X86BYTE }; +"sbbb" , BINOP { txt = "SBBB"; op = X86SBB; sz = X86BYTE }; +"andb" , BINOP { txt = "ANDB"; op = X86AND; sz = X86BYTE }; +"subb" , BINOP { txt = "SUBB"; op = X86SUB; sz = X86BYTE }; +"xorb" , BINOP { txt = "XORB"; op = X86XOR; sz = X86BYTE }; +"cmpb" , BINOP { txt = "CMPB"; op = X86CMP; sz = X86BYTE }; +"rolb" , BINOP { txt = "ROLB"; op = X86ROL; sz = X86BYTE }; +"rorb" , BINOP { txt = "RORB"; op = X86ROR; sz = X86BYTE }; +"shlb" , BINOP { txt = "SHLB"; op = X86SHL; sz = X86BYTE }; +"shrb" , BINOP { txt = "SHRB"; op = X86SHR; sz = X86BYTE }; +"testb" , BINOP { txt = "TESTB"; op = X86TEST; sz = X86BYTE }; +"sarb" , BINOP { txt = "SARB"; op = X86SAR; sz = X86BYTE }; +"addw" , BINOP { txt = "ADDW"; op = X86ADD; sz = X86WORD }; +"orw" , BINOP { txt = "ORW"; op = X86OR; sz = X86WORD }; +"adcw" , BINOP { txt = "ADCW"; op = X86ADC; sz = X86WORD }; +"sbbw" , BINOP { txt = "SBBW"; op = X86SBB; sz = X86WORD }; +"andw" , BINOP { txt = "ANDW"; op = X86AND; sz = X86WORD }; +"subw" , BINOP { txt = "SUBW"; op = X86SUB; sz = X86WORD }; +"xorw" , BINOP { txt = "XORW"; op = X86XOR; sz = X86WORD }; +"cmpw" , BINOP { txt = "CMPW"; op = X86CMP; sz = X86WORD }; +"rolw" , BINOP { txt = "ROLW"; op = X86ROL; sz = X86WORD }; +"rorw" , BINOP { txt = "RORW"; op = X86ROR; sz = X86WORD }; +"shlw" , BINOP { txt = "SHLW"; op = X86SHL; sz = X86WORD }; +"shrw" , BINOP { txt = "SHRW"; op = X86SHR; sz = X86WORD }; +"testw" , BINOP { txt = "TESTW"; op = X86TEST; sz = X86WORD }; +"sarw" , BINOP { txt = "SARW"; op = X86SAR; sz = X86WORD }; +"addl" , BINOP { txt = "ADDL"; op = X86ADD; sz = X86LONG }; +"orl" , BINOP { txt = "ORL"; op = X86OR; sz = X86LONG }; +"adcl" , BINOP { txt = "ADCL"; op = X86ADC; sz = X86LONG }; +"sbbl" , BINOP { txt = "SBBL"; op = X86SBB; sz = X86LONG }; +"andl" , BINOP { txt = "ANDL"; op = X86AND; sz = X86LONG }; +"subl" , BINOP { txt = "SUBL"; op = X86SUB; sz = X86LONG }; +"xorl" , BINOP { txt = "XORL"; op = X86XOR; sz = X86LONG }; +"cmpl" , BINOP { txt = "CMPL"; op = X86CMP; sz = X86LONG }; +"roll" , BINOP { txt = "ROLL"; op = X86ROL; sz = X86LONG }; +"rorl" , BINOP { txt = "RORL"; op = X86ROR; sz = X86LONG }; +"shll" , BINOP { txt = "SHLL"; op = X86SHL; sz = X86LONG }; +"shrl" , BINOP { txt = "SHRL"; op = X86SHR; sz = X86LONG }; +"testl" , BINOP { txt = "TESTL"; op = X86TEST; sz = X86LONG }; +"sarl" , BINOP { txt = "SARL"; op = X86SAR; sz = X86LONG }; +"addq" , BINOP { txt = "ADDQ"; op = X86ADD; sz = X86QUAD }; +"orq" , BINOP { txt = "ORQ"; op = X86OR; sz = X86QUAD }; +"adcq" , BINOP { txt = "ADCQ"; op = X86ADC; sz = X86QUAD }; +"sbbq" , BINOP { txt = "SBBQ"; op = X86SBB; sz = X86QUAD }; +"andq" , BINOP { txt = "ANDQ"; op = X86AND; sz = X86QUAD }; +"subq" , BINOP { txt = "SUBQ"; op = X86SUB; sz = X86QUAD }; +"xorq" , BINOP { txt = "XORQ"; op = X86XOR; sz = X86QUAD }; +"cmpq" , BINOP { txt = "CMPQ"; op = X86CMP; sz = X86QUAD }; +"rolq" , BINOP { txt = "ROLQ"; op = X86ROL; sz = X86QUAD }; +"rorq" , BINOP { txt = "RORQ"; op = X86ROR; sz = X86QUAD }; +"shlq" , BINOP { txt = "SHLQ"; op = X86SHL; sz = X86QUAD }; +"shrq" , BINOP { txt = "SHRQ"; op = X86SHR; sz = X86QUAD }; +"testq" , BINOP { txt = "TESTQ"; op = X86TEST; sz = X86QUAD }; +"sarq" , BINOP { txt = "SARQ"; op = X86SAR; sz = X86QUAD }; +"add" , BINOP { txt = "ADDQ"; op = X86ADD; sz = X86NONE }; +"or" , BINOP { txt = "OR"; op = X86OR; sz = X86NONE }; +"adc" , BINOP { txt = "ADC"; op = X86ADC; sz = X86NONE }; +"sbb" , BINOP { txt = "SBB"; op = X86SBB; sz = X86NONE }; +"and" , BINOP { txt = "AND"; op = X86AND; sz = X86NONE }; +"sub" , BINOP { txt = "SUB"; op = X86SUB; sz = X86NONE }; +"xor" , BINOP { txt = "XOR"; op = X86XOR; sz = X86NONE }; +"cmp" , BINOP { txt = "CMP"; op = X86CMP; sz = X86NONE }; +"rol" , BINOP { txt = "ROL"; op = X86ROL; sz = X86NONE }; +"ror" , BINOP { txt = "ROR"; op = X86ROR; sz = X86NONE }; +"shl" , BINOP { txt = "SHL"; op = X86SHL; sz = X86NONE }; +"shr" , BINOP { txt = "SHR"; op = X86SHR; sz = X86NONE }; +"test" , BINOP { txt = "TEST"; op = X86TEST; sz = X86NONE }; +"sar" , BINOP { txt = "SAR"; op = X86SAR; sz = X86NONE }; +"btcw" , BITOP { txt = "BTSW"; op = X86Btc; sz = X86WORD }; +"btsw" , BITOP { txt = "BTCW"; op = X86Bts; sz = X86WORD }; +"btrw" , BITOP { txt = "BTRW"; op = X86Btr; sz = X86WORD }; +"btcl" , BITOP { txt = "BTSL"; op = X86Btc; sz = X86LONG }; +"btsl" , BITOP { txt = "BTCL"; op = X86Bts; sz = X86LONG }; +"btrl" , BITOP { txt = "BTRL"; op = X86Btr; sz = X86LONG }; +"btcq" , BITOP { txt = "BTSQ"; op = X86Btc; sz = X86QUAD }; +"btsq" , BITOP { txt = "BTCQ"; op = X86Bts; sz = X86QUAD }; +"btrq" , BITOP { txt = "BTRQ"; op = X86Btr; sz = X86QUAD }; +"btc" , BITOP { txt = "BTS"; op = X86Btc; sz = X86NONE }; +"bts" , BITOP { txt = "BTC"; op = X86Bts; sz = X86NONE }; +"btr" , BITOP { txt = "BTR"; op = X86Btr; sz = X86NONE }; +"call" , CALL { txt = "CALL" }; +"clc" , CLC { txt = "CLC" }; +"cmc" , CMC { txt = "CMC" }; +"cmpxchgb" , CMPXCHG { txt = "CMPXCHGB"; sz = X86BYTE }; +"cmpxchgw" , CMPXCHG { txt = "CMPXCHGW"; sz = X86WORD }; +"cmpxchgl" , CMPXCHG { txt = "CMPXCHGL"; sz = X86LONG }; +"cmpxchgq" , CMPXCHG { txt = "CMPXCHGQ"; sz = X86QUAD }; +"cmpxchg" , CMPXCHG { txt = "CMPXCHG"; sz = X86NONE }; +"divb" , DIV { txt = "DIVB"; sz = X86BYTE }; +"divw" , DIV { txt = "DIVW"; sz = X86WORD }; +"divl" , DIV { txt = "DIVL"; sz = X86LONG }; +"divq" , DIV { txt = "DIVQ"; sz = X86QUAD }; +"div" , DIV { txt = "DIV"; sz = X86NONE }; +"jo" , JCC { txt = "JO"; cond = X86O }; +"jb" , JCC { txt = "JB"; cond = X86B }; +"jc" , JCC { txt = "JC"; cond = X86B }; +"jnae" , JCC { txt = "JNAE"; cond = X86B }; +"je" , JCC { txt = "JE"; cond = X86E }; +"jz" , JCC { txt = "JZ"; cond = X86E }; +"ja" , JCC { txt = "JA"; cond = X86A }; +"jnbe" , JCC { txt = "JNBE"; cond = X86A }; +"js" , JCC { txt = "JS"; cond = X86S }; +"jp" , JCC { txt = "JP"; cond = X86P }; +"jpe" , JCC { txt = "JPE"; cond = X86P }; +"jl" , JCC { txt = "JL"; cond = X86L }; +"jnge" , JCC { txt = "JNGE"; cond = X86L }; +"jg" , JCC { txt = "JG"; cond = X86G }; +"jnle" , JCC { txt = "JNLE"; cond = X86G }; +"jno" , JCC { txt = "JNO"; cond = X86NO }; +"jnb" , JCC { txt = "JNB"; cond = X86NB }; +"jnc" , JCC { txt = "JNC"; cond = X86NB }; +"jae" , JCC { txt = "JAE"; cond = X86NB }; +"jne" , JCC { txt = "JNE"; cond = X86NE }; +"jnz" , JCC { txt = "JNZ"; cond = X86NE }; +"jna" , JCC { txt = "JNA"; cond = X86NA }; +"jbe" , JCC { txt = "JBE"; cond = X86NA }; +"jns" , JCC { txt = "JNS"; cond = X86NS }; +"jnp" , JCC { txt = "JNP"; cond = X86NP }; +"jpo" , JCC { txt = "JPO"; cond = X86NP }; +"jnl" , JCC { txt = "JNL"; cond = X86NL }; +"jge" , JCC { txt = "JGE"; cond = X86NL }; +"jng" , JCC { txt = "JNG"; cond = X86NG }; +"jle" , JCC { txt = "JLE"; cond = X86NG }; +"jmp" , JMP { txt = "JMP" }; +"leaw" , LEA { txt = "LEAW"; sz = X86BYTE }; +"leal" , LEA { txt = "LEAL"; sz = X86LONG }; +"leaq" , LEA { txt = "LEAQ"; sz = X86QUAD }; +"lea" , LEA { txt = "LEA"; sz = X86NONE }; +"leave" , LEAVE { txt = "LEAVE" }; +"loopo" , LOOP { txt = "LOOPO"; cond = X86O }; +"loopb" , LOOP { txt = "LOOPB"; cond = X86B }; +"loopc" , LOOP { txt = "LOOPC"; cond = X86B }; +"loopnae" , LOOP { txt = "LOOPNAE"; cond = X86B }; +"loope" , LOOP { txt = "LOOPE"; cond = X86E }; +"loopz" , LOOP { txt = "LOOPZ"; cond = X86E }; +"loopa" , LOOP { txt = "LOOPA"; cond = X86A }; +"loopnbe" , LOOP { txt = "LOOPNBE"; cond = X86A }; +"loops" , LOOP { txt = "LOOPS"; cond = X86S }; +"loopp" , LOOP { txt = "LOOPP"; cond = X86P }; +"looppe" , LOOP { txt = "LOOPPE"; cond = X86P }; +"loopl" , LOOP { txt = "LOOPL"; cond = X86L }; +"loopnge" , LOOP { txt = "LOOPNGE"; cond = X86L }; +"loopg" , LOOP { txt = "LOOPG"; cond = X86G }; +"loopnle" , LOOP { txt = "LOOPNLE"; cond = X86G }; +"loopno" , LOOP { txt = "LOOPNO"; cond = X86NO }; +"loopnb" , LOOP { txt = "LOOPNB"; cond = X86NB }; +"loopnc" , LOOP { txt = "LOOPNC"; cond = X86NB }; +"loopae" , LOOP { txt = "LOOPAE"; cond = X86NB }; +"loopne" , LOOP { txt = "LOOPNE"; cond = X86NE }; +"loopnz" , LOOP { txt = "LOOPNZ"; cond = X86NE }; +"loopna" , LOOP { txt = "LOOPNA"; cond = X86NA }; +"loopbe" , LOOP { txt = "LOOPBE"; cond = X86NA }; +"loopns" , LOOP { txt = "LOOPNS"; cond = X86NS }; +"loopnp" , LOOP { txt = "LOOPNP"; cond = X86NP }; +"looppo" , LOOP { txt = "LOOPPO"; cond = X86NP }; +"loopnl" , LOOP { txt = "LOOPNL"; cond = X86NL }; +"loopge" , LOOP { txt = "LOOPGE"; cond = X86NL }; +"loopng" , LOOP { txt = "LOOPNG"; cond = X86NG }; +"loople" , LOOP { txt = "LOOPLE"; cond = X86NG }; +"mfence" , MFENCE { txt = "MFENCE" }; +"decb" , MONOP { txt = "DECB"; op = X86DEC; sz = X86BYTE }; +"incb" , MONOP { txt = "INCB"; op = X86INC; sz = X86BYTE }; +"notb" , MONOP { txt = "NOTB"; op = X86NOT; sz = X86BYTE }; +"negb" , MONOP { txt = "NEGB"; op = X86NEG; sz = X86BYTE }; +"decw" , MONOP { txt = "DECW"; op = X86DEC; sz = X86WORD }; +"incw" , MONOP { txt = "INCW"; op = X86INC; sz = X86WORD }; +"notw" , MONOP { txt = "NOTW"; op = X86NOT; sz = X86WORD }; +"negw" , MONOP { txt = "NEGW"; op = X86NEG; sz = X86WORD }; +"decl" , MONOP { txt = "DECL"; op = X86DEC; sz = X86LONG }; +"incl" , MONOP { txt = "INCL"; op = X86INC; sz = X86LONG }; +"notl" , MONOP { txt = "NOTL"; op = X86NOT; sz = X86LONG }; +"negl" , MONOP { txt = "NEGL"; op = X86NEG; sz = X86LONG }; +"decq" , MONOP { txt = "DECQ"; op = X86DEC; sz = X86QUAD }; +"incq" , MONOP { txt = "INCQ"; op = X86INC; sz = X86QUAD }; +"notq" , MONOP { txt = "NOTQ"; op = X86NOT; sz = X86QUAD }; +"negq" , MONOP { txt = "NEGQ"; op = X86NEG; sz = X86QUAD }; +"dec" , MONOP { txt = "DEC"; op = X86DEC; sz = X86NONE }; +"inc" , MONOP { txt = "INC"; op = X86INC; sz = X86NONE }; +"not" , MONOP { txt = "NOT"; op = X86NOT; sz = X86NONE }; +"neg" , MONOP { txt = "NEG"; op = X86NEG; sz = X86NONE }; +"cmovow" , CMOV { txt = "CMOVOW"; cond = X86O; sz = X86WORD }; +"cmovbw" , CMOV { txt = "CMOVBW"; cond = X86B; sz = X86WORD }; +"cmovcw" , CMOV { txt = "CMOVCW"; cond = X86B; sz = X86WORD }; +"cmovnaew" , CMOV { txt = "CMOVNAEW"; cond = X86B; sz = X86WORD }; +"cmovew" , CMOV { txt = "CMOVEW"; cond = X86E; sz = X86WORD }; +"cmovzw" , CMOV { txt = "CMOVZW"; cond = X86E; sz = X86WORD }; +"cmovaw" , CMOV { txt = "CMOVAW"; cond = X86A; sz = X86WORD }; +"cmovnbew" , CMOV { txt = "CMOVNBEW"; cond = X86A; sz = X86WORD }; +"cmovsw" , CMOV { txt = "CMOVSW"; cond = X86S; sz = X86WORD }; +"cmovpw" , CMOV { txt = "CMOVPW"; cond = X86P; sz = X86WORD }; +"cmovpew" , CMOV { txt = "CMOVPEW"; cond = X86P; sz = X86WORD }; +"cmovlw" , CMOV { txt = "CMOVLW"; cond = X86L; sz = X86WORD }; +"cmovngew" , CMOV { txt = "CMOVNGEW"; cond = X86L; sz = X86WORD }; +"cmovgw" , CMOV { txt = "CMOVGW"; cond = X86G; sz = X86WORD }; +"cmovnlew" , CMOV { txt = "CMOVNLEW"; cond = X86G; sz = X86WORD }; +"cmovnow" , CMOV { txt = "CMOVNOW"; cond = X86NO; sz = X86WORD }; +"cmovnbw" , CMOV { txt = "CMOVNBW"; cond = X86NB; sz = X86WORD }; +"cmovncw" , CMOV { txt = "CMOVNCW"; cond = X86NB; sz = X86WORD }; +"cmovaew" , CMOV { txt = "CMOVAEW"; cond = X86NB; sz = X86WORD }; +"cmovnew" , CMOV { txt = "CMOVNEW"; cond = X86NE; sz = X86WORD }; +"cmovnzw" , CMOV { txt = "CMOVNZW"; cond = X86NE; sz = X86WORD }; +"cmovnaw" , CMOV { txt = "CMOVNAW"; cond = X86NA; sz = X86WORD }; +"cmovbew" , CMOV { txt = "CMOVBEW"; cond = X86NA; sz = X86WORD }; +"cmovnsw" , CMOV { txt = "CMOVNSW"; cond = X86NS; sz = X86WORD }; +"cmovnpw" , CMOV { txt = "CMOVNPW"; cond = X86NP; sz = X86WORD }; +"cmovpow" , CMOV { txt = "CMOVPOW"; cond = X86NP; sz = X86WORD }; +"cmovnlw" , CMOV { txt = "CMOVNLW"; cond = X86NL; sz = X86WORD }; +"cmovgew" , CMOV { txt = "CMOVGEW"; cond = X86NL; sz = X86WORD }; +"cmovngw" , CMOV { txt = "CMOVNGW"; cond = X86NG; sz = X86WORD }; +"cmovlew" , CMOV { txt = "CMOVLEW"; cond = X86NG; sz = X86WORD }; +"cmovol" , CMOV { txt = "CMOVOL"; cond = X86O; sz = X86LONG }; +"cmovbl" , CMOV { txt = "CMOVBL"; cond = X86B; sz = X86LONG }; +"cmovcl" , CMOV { txt = "CMOVCL"; cond = X86B; sz = X86LONG }; +"cmovnael" , CMOV { txt = "CMOVNAEL"; cond = X86B; sz = X86LONG }; +"cmovel" , CMOV { txt = "CMOVEL"; cond = X86E; sz = X86LONG }; +"cmovzl" , CMOV { txt = "CMOVZL"; cond = X86E; sz = X86LONG }; +"cmoval" , CMOV { txt = "CMOVAL"; cond = X86A; sz = X86LONG }; +"cmovnbel" , CMOV { txt = "CMOVNBEL"; cond = X86A; sz = X86LONG }; +"cmovsl" , CMOV { txt = "CMOVSL"; cond = X86S; sz = X86LONG }; +"cmovpl" , CMOV { txt = "CMOVPL"; cond = X86P; sz = X86LONG }; +"cmovpel" , CMOV { txt = "CMOVPEL"; cond = X86P; sz = X86LONG }; +"cmovll" , CMOV { txt = "CMOVLL"; cond = X86L; sz = X86LONG }; +"cmovngel" , CMOV { txt = "CMOVNGEL"; cond = X86L; sz = X86LONG }; +"cmovgl" , CMOV { txt = "CMOVGL"; cond = X86G; sz = X86LONG }; +"cmovnlel" , CMOV { txt = "CMOVNLEL"; cond = X86G; sz = X86LONG }; +"cmovnol" , CMOV { txt = "CMOVNOL"; cond = X86NO; sz = X86LONG }; +"cmovnbl" , CMOV { txt = "CMOVNBL"; cond = X86NB; sz = X86LONG }; +"cmovncl" , CMOV { txt = "CMOVNCL"; cond = X86NB; sz = X86LONG }; +"cmovael" , CMOV { txt = "CMOVAEL"; cond = X86NB; sz = X86LONG }; +"cmovnel" , CMOV { txt = "CMOVNEL"; cond = X86NE; sz = X86LONG }; +"cmovnzl" , CMOV { txt = "CMOVNZL"; cond = X86NE; sz = X86LONG }; +"cmovnal" , CMOV { txt = "CMOVNAL"; cond = X86NA; sz = X86LONG }; +"cmovbel" , CMOV { txt = "CMOVBEL"; cond = X86NA; sz = X86LONG }; +"cmovnsl" , CMOV { txt = "CMOVNSL"; cond = X86NS; sz = X86LONG }; +"cmovnpl" , CMOV { txt = "CMOVNPL"; cond = X86NP; sz = X86LONG }; +"cmovpol" , CMOV { txt = "CMOVPOL"; cond = X86NP; sz = X86LONG }; +"cmovnll" , CMOV { txt = "CMOVNLL"; cond = X86NL; sz = X86LONG }; +"cmovgel" , CMOV { txt = "CMOVGEL"; cond = X86NL; sz = X86LONG }; +"cmovngl" , CMOV { txt = "CMOVNGL"; cond = X86NG; sz = X86LONG }; +"cmovlel" , CMOV { txt = "CMOVLEL"; cond = X86NG; sz = X86LONG }; +"cmovoq" , CMOV { txt = "CMOVOQ"; cond = X86O; sz = X86QUAD }; +"cmovbq" , CMOV { txt = "CMOVBQ"; cond = X86B; sz = X86QUAD }; +"cmovcq" , CMOV { txt = "CMOVCQ"; cond = X86B; sz = X86QUAD }; +"cmovnaeq" , CMOV { txt = "CMOVNAEQ"; cond = X86B; sz = X86QUAD }; +"cmoveq" , CMOV { txt = "CMOVEQ"; cond = X86E; sz = X86QUAD }; +"cmovzq" , CMOV { txt = "CMOVZQ"; cond = X86E; sz = X86QUAD }; +"cmovaq" , CMOV { txt = "CMOVAQ"; cond = X86A; sz = X86QUAD }; +"cmovnbeq" , CMOV { txt = "CMOVNBEQ"; cond = X86A; sz = X86QUAD }; +"cmovsq" , CMOV { txt = "CMOVSQ"; cond = X86S; sz = X86QUAD }; +"cmovpq" , CMOV { txt = "CMOVPQ"; cond = X86P; sz = X86QUAD }; +"cmovpeq" , CMOV { txt = "CMOVPEQ"; cond = X86P; sz = X86QUAD }; +"cmovlq" , CMOV { txt = "CMOVLQ"; cond = X86L; sz = X86QUAD }; +"cmovngeq" , CMOV { txt = "CMOVNGEQ"; cond = X86L; sz = X86QUAD }; +"cmovgq" , CMOV { txt = "CMOVGQ"; cond = X86G; sz = X86QUAD }; +"cmovnleq" , CMOV { txt = "CMOVNLEQ"; cond = X86G; sz = X86QUAD }; +"cmovnoq" , CMOV { txt = "CMOVNOQ"; cond = X86NO; sz = X86QUAD }; +"cmovnbq" , CMOV { txt = "CMOVNBQ"; cond = X86NB; sz = X86QUAD }; +"cmovncq" , CMOV { txt = "CMOVNCQ"; cond = X86NB; sz = X86QUAD }; +"cmovaeq" , CMOV { txt = "CMOVAEQ"; cond = X86NB; sz = X86QUAD }; +"cmovneq" , CMOV { txt = "CMOVNEQ"; cond = X86NE; sz = X86QUAD }; +"cmovnzq" , CMOV { txt = "CMOVNZQ"; cond = X86NE; sz = X86QUAD }; +"cmovnaq" , CMOV { txt = "CMOVNAQ"; cond = X86NA; sz = X86QUAD }; +"cmovbeq" , CMOV { txt = "CMOVBEQ"; cond = X86NA; sz = X86QUAD }; +"cmovnsq" , CMOV { txt = "CMOVNSQ"; cond = X86NS; sz = X86QUAD }; +"cmovnpq" , CMOV { txt = "CMOVNPQ"; cond = X86NP; sz = X86QUAD }; +"cmovpoq" , CMOV { txt = "CMOVPOQ"; cond = X86NP; sz = X86QUAD }; +"cmovnlq" , CMOV { txt = "CMOVNLQ"; cond = X86NL; sz = X86QUAD }; +"cmovgeq" , CMOV { txt = "CMOVGEQ"; cond = X86NL; sz = X86QUAD }; +"cmovngq" , CMOV { txt = "CMOVNGQ"; cond = X86NG; sz = X86QUAD }; +"cmovleq" , CMOV { txt = "CMOVLEQ"; cond = X86NG; sz = X86QUAD }; +"cmovo" , CMOV { txt = "CMOVO"; cond = X86O; sz = X86NONE }; +"cmovb" , CMOV { txt = "CMOVB"; cond = X86B; sz = X86NONE }; +"cmovc" , CMOV { txt = "CMOVC"; cond = X86B; sz = X86NONE }; +"cmovnae" , CMOV { txt = "CMOVNAE"; cond = X86B; sz = X86NONE }; +"cmove" , CMOV { txt = "CMOVE"; cond = X86E; sz = X86NONE }; +"cmovz" , CMOV { txt = "CMOVZ"; cond = X86E; sz = X86NONE }; +"cmova" , CMOV { txt = "CMOVA"; cond = X86A; sz = X86NONE }; +"cmovnbe" , CMOV { txt = "CMOVNBE"; cond = X86A; sz = X86NONE }; +"cmovs" , CMOV { txt = "CMOVS"; cond = X86S; sz = X86NONE }; +"cmovp" , CMOV { txt = "CMOVP"; cond = X86P; sz = X86NONE }; +"cmovpe" , CMOV { txt = "CMOVPE"; cond = X86P; sz = X86NONE }; +"cmovl" , CMOV { txt = "CMOVL"; cond = X86L; sz = X86NONE }; +"cmovnge" , CMOV { txt = "CMOVNGE"; cond = X86L; sz = X86NONE }; +"cmovg" , CMOV { txt = "CMOVG"; cond = X86G; sz = X86NONE }; +"cmovnle" , CMOV { txt = "CMOVNLE"; cond = X86G; sz = X86NONE }; +"cmovno" , CMOV { txt = "CMOVNO"; cond = X86NO; sz = X86NONE }; +"cmovnb" , CMOV { txt = "CMOVNB"; cond = X86NB; sz = X86NONE }; +"cmovnc" , CMOV { txt = "CMOVNC"; cond = X86NB; sz = X86NONE }; +"cmovae" , CMOV { txt = "CMOVAE"; cond = X86NB; sz = X86NONE }; +"cmovne" , CMOV { txt = "CMOVNE"; cond = X86NE; sz = X86NONE }; +"cmovnz" , CMOV { txt = "CMOVNZ"; cond = X86NE; sz = X86NONE }; +"cmovna" , CMOV { txt = "CMOVNA"; cond = X86NA; sz = X86NONE }; +"cmovbe" , CMOV { txt = "CMOVBE"; cond = X86NA; sz = X86NONE }; +"cmovns" , CMOV { txt = "CMOVNS"; cond = X86NS; sz = X86NONE }; +"cmovnp" , CMOV { txt = "CMOVNP"; cond = X86NP; sz = X86NONE }; +"cmovpo" , CMOV { txt = "CMOVPO"; cond = X86NP; sz = X86NONE }; +"cmovnl" , CMOV { txt = "CMOVNL"; cond = X86NL; sz = X86NONE }; +"cmovge" , CMOV { txt = "CMOVGE"; cond = X86NL; sz = X86NONE }; +"cmovng" , CMOV { txt = "CMOVNG"; cond = X86NG; sz = X86NONE }; +"cmovle" , CMOV { txt = "CMOVLE"; cond = X86NG; sz = X86NONE }; +"movb" , MOV { txt = "MOVB"; sz = X86BYTE }; +"movw" , MOV { txt = "MOVW"; sz = X86WORD }; +"movl" , MOV { txt = "MOVL"; sz = X86LONG }; +"movq" , MOV { txt = "MOVQ"; sz = X86QUAD }; +"mov" , MOV { txt = "MOV"; sz = X86NONE }; +"movabs" , MOV { txt = "MOVABS"; sz = X86QUAD }; +"movsbw" , MOVSX { txt = "MOVSBW"; sz1 = X86BYTE; sz2 = X86WORD }; +"movsbl" , MOVSX { txt = "MOVSBL"; sz1 = X86BYTE; sz2 = X86LONG }; +"movsbq" , MOVSX { txt = "MOVSBQ"; sz1 = X86BYTE; sz2 = X86QUAD }; +"movswl" , MOVSX { txt = "MOVSWL"; sz1 = X86WORD; sz2 = X86LONG }; +"movswq" , MOVSX { txt = "MOVSWQ"; sz1 = X86WORD; sz2 = X86QUAD }; +"movslq" , MOVSX { txt = "MOVSWQ"; sz1 = X86LONG; sz2 = X86QUAD }; +"movzbw" , MOVZX { txt = "MOVZBW"; sz1 = X86BYTE; sz2 = X86WORD }; +"movzbl" , MOVZX { txt = "MOVZBL"; sz1 = X86BYTE; sz2 = X86LONG }; +"movzbq" , MOVZX { txt = "MOVZBQ"; sz1 = X86BYTE; sz2 = X86QUAD }; +"movzwl" , MOVZX { txt = "MOVZWL"; sz1 = X86WORD; sz2 = X86LONG }; +"movzwq" , MOVZX { txt = "MOVZWQ"; sz1 = X86WORD; sz2 = X86QUAD }; +"mulb" , MUL { txt = "MULB"; sz = X86BYTE }; +"mulw" , MUL { txt = "MULW"; sz = X86WORD }; +"mull" , MUL { txt = "MULL"; sz = X86LONG }; +"mulq" , MUL { txt = "MULQ"; sz = X86QUAD }; +"mul" , MUL { txt = "MUL"; sz = X86NONE }; +"nop" , NOP { txt = "NOP" }; +"pop" , POP { txt = "POP" }; +"push" , PUSH { txt = "PUSH" }; +"ret" , PUSH { txt = "RET" }; +"setob" , SET { txt = "SETOB"; cond = X86O }; +"setbb" , SET { txt = "SETBB"; cond = X86B }; +"setcb" , SET { txt = "SETCB"; cond = X86B }; +"setnaeb" , SET { txt = "SETNAEB"; cond = X86B }; +"seteb" , SET { txt = "SETEB"; cond = X86E }; +"setzb" , SET { txt = "SETZB"; cond = X86E }; +"setab" , SET { txt = "SETAB"; cond = X86A }; +"setnbeb" , SET { txt = "SETNBEB"; cond = X86A }; +"setsb" , SET { txt = "SETSB"; cond = X86S }; +"setpb" , SET { txt = "SETPB"; cond = X86P }; +"setpeb" , SET { txt = "SETPEB"; cond = X86P }; +"setlb" , SET { txt = "SETLB"; cond = X86L }; +"setngeb" , SET { txt = "SETNGEB"; cond = X86L }; +"setgb" , SET { txt = "SETGB"; cond = X86G }; +"setnleb" , SET { txt = "SETNLEB"; cond = X86G }; +"setnob" , SET { txt = "SETNOB"; cond = X86NO }; +"setnbb" , SET { txt = "SETNBB"; cond = X86NB }; +"setncb" , SET { txt = "SETNCB"; cond = X86NB }; +"setaeb" , SET { txt = "SETAEB"; cond = X86NB }; +"setneb" , SET { txt = "SETNEB"; cond = X86NE }; +"setnzb" , SET { txt = "SETNZB"; cond = X86NE }; +"setnab" , SET { txt = "SETNAB"; cond = X86NA }; +"setbeb" , SET { txt = "SETBEB"; cond = X86NA }; +"setnsb" , SET { txt = "SETNSB"; cond = X86NS }; +"setnpb" , SET { txt = "SETNPB"; cond = X86NP }; +"setpob" , SET { txt = "SETPOB"; cond = X86NP }; +"setnlb" , SET { txt = "SETNLB"; cond = X86NL }; +"setgeb" , SET { txt = "SETGEB"; cond = X86NL }; +"setngb" , SET { txt = "SETNGB"; cond = X86NG }; +"setleb" , SET { txt = "SETLEB"; cond = X86NG }; +"seto" , SET { txt = "SETO"; cond = X86O }; +"setb" , SET { txt = "SETB"; cond = X86B }; +"setc" , SET { txt = "SETC"; cond = X86B }; +"setnae" , SET { txt = "SETNAE"; cond = X86B }; +"sete" , SET { txt = "SETE"; cond = X86E }; +"setz" , SET { txt = "SETZ"; cond = X86E }; +"seta" , SET { txt = "SETA"; cond = X86A }; +"setnbe" , SET { txt = "SETNBE"; cond = X86A }; +"sets" , SET { txt = "SETS"; cond = X86S }; +"setp" , SET { txt = "SETP"; cond = X86P }; +"setpe" , SET { txt = "SETPE"; cond = X86P }; +"setl" , SET { txt = "SETL"; cond = X86L }; +"setnge" , SET { txt = "SETNGE"; cond = X86L }; +"setg" , SET { txt = "SETG"; cond = X86G }; +"setnle" , SET { txt = "SETNLE"; cond = X86G }; +"setno" , SET { txt = "SETNO"; cond = X86NO }; +"setnb" , SET { txt = "SETNB"; cond = X86NB }; +"setnc" , SET { txt = "SETNC"; cond = X86NB }; +"setae" , SET { txt = "SETAE"; cond = X86NB }; +"setne" , SET { txt = "SETNE"; cond = X86NE }; +"setnz" , SET { txt = "SETNZ"; cond = X86NE }; +"setna" , SET { txt = "SETNA"; cond = X86NA }; +"setbe" , SET { txt = "SETBE"; cond = X86NA }; +"setns" , SET { txt = "SETNS"; cond = X86NS }; +"setnp" , SET { txt = "SETNP"; cond = X86NP }; +"setpo" , SET { txt = "SETPO"; cond = X86NP }; +"setnl" , SET { txt = "SETNL"; cond = X86NL }; +"setge" , SET { txt = "SETGE"; cond = X86NL }; +"setng" , SET { txt = "SETNG"; cond = X86NG }; +"setle" , SET { txt = "SETLE"; cond = X86NG }; +"stc" , STC { txt = "STC" }; +"xaddb" , XADD { txt = "XADDB"; sz = X86BYTE }; +"xaddw" , XADD { txt = "XADDW"; sz = X86WORD }; +"xaddl" , XADD { txt = "XADDL"; sz = X86LONG }; +"xaddq" , XADD { txt = "XADDQ"; sz = X86QUAD }; +"xadd" , XADD { txt = "XADD"; sz = X86NONE }; +"xchgb" , XCHG { txt = "XCHGB"; sz = X86BYTE }; +"xchgw" , XCHG { txt = "XCHGW"; sz = X86WORD }; +"xchgl" , XCHG { txt = "XCHGL"; sz = X86LONG }; +"xchgq" , XCHG { txt = "XCHGQ"; sz = X86QUAD }; +"xchg" , XCHG { txt = "XCHG"; sz = X86NONE }; diff --git a/x86/gen/lexer_intel.hgen b/x86/gen/lexer_intel.hgen new file mode 100644 index 00000000..e1854a14 --- /dev/null +++ b/x86/gen/lexer_intel.hgen @@ -0,0 +1,161 @@ +"add" , BINOP { txt = "ADDQ"; op = X86ADD; sz = X86NONE }; +"or" , BINOP { txt = "OR"; op = X86OR; sz = X86NONE }; +"adc" , BINOP { txt = "ADC"; op = X86ADC; sz = X86NONE }; +"sbb" , BINOP { txt = "SBB"; op = X86SBB; sz = X86NONE }; +"and" , BINOP { txt = "AND"; op = X86AND; sz = X86NONE }; +"sub" , BINOP { txt = "SUB"; op = X86SUB; sz = X86NONE }; +"xor" , BINOP { txt = "XOR"; op = X86XOR; sz = X86NONE }; +"cmp" , BINOP { txt = "CMP"; op = X86CMP; sz = X86NONE }; +"rol" , BINOP { txt = "ROL"; op = X86ROL; sz = X86NONE }; +"ror" , BINOP { txt = "ROR"; op = X86ROR; sz = X86NONE }; +"shl" , BINOP { txt = "SHL"; op = X86SHL; sz = X86NONE }; +"shr" , BINOP { txt = "SHR"; op = X86SHR; sz = X86NONE }; +"test" , BINOP { txt = "TEST"; op = X86TEST; sz = X86NONE }; +"sar" , BINOP { txt = "SAR"; op = X86SAR; sz = X86NONE }; +"btc" , BITOP { txt = "BTS"; op = X86Btc; sz = X86NONE }; +"bts" , BITOP { txt = "BTC"; op = X86Bts; sz = X86NONE }; +"btr" , BITOP { txt = "BTR"; op = X86Btr; sz = X86NONE }; +"call" , CALL { txt = "CALL" }; +"clc" , CLC { txt = "CLC" }; +"cmc" , CMC { txt = "CMC" }; +"cmpxchg" , CMPXCHG { txt = "CMPXCHG"; sz = X86NONE }; +"div" , DIV { txt = "DIV"; sz = X86NONE }; +"jo" , JCC { txt = "JO"; cond = X86O }; +"jb" , JCC { txt = "JB"; cond = X86B }; +"jc" , JCC { txt = "JC"; cond = X86B }; +"jnae" , JCC { txt = "JNAE"; cond = X86B }; +"je" , JCC { txt = "JE"; cond = X86E }; +"jz" , JCC { txt = "JZ"; cond = X86E }; +"ja" , JCC { txt = "JA"; cond = X86A }; +"jnbe" , JCC { txt = "JNBE"; cond = X86A }; +"js" , JCC { txt = "JS"; cond = X86S }; +"jp" , JCC { txt = "JP"; cond = X86P }; +"jpe" , JCC { txt = "JPE"; cond = X86P }; +"jl" , JCC { txt = "JL"; cond = X86L }; +"jnge" , JCC { txt = "JNGE"; cond = X86L }; +"jg" , JCC { txt = "JG"; cond = X86G }; +"jnle" , JCC { txt = "JNLE"; cond = X86G }; +"jno" , JCC { txt = "JNO"; cond = X86NO }; +"jnb" , JCC { txt = "JNB"; cond = X86NB }; +"jnc" , JCC { txt = "JNC"; cond = X86NB }; +"jae" , JCC { txt = "JAE"; cond = X86NB }; +"jne" , JCC { txt = "JNE"; cond = X86NE }; +"jnz" , JCC { txt = "JNZ"; cond = X86NE }; +"jna" , JCC { txt = "JNA"; cond = X86NA }; +"jbe" , JCC { txt = "JBE"; cond = X86NA }; +"jns" , JCC { txt = "JNS"; cond = X86NS }; +"jnp" , JCC { txt = "JNP"; cond = X86NP }; +"jpo" , JCC { txt = "JPO"; cond = X86NP }; +"jnl" , JCC { txt = "JNL"; cond = X86NL }; +"jge" , JCC { txt = "JGE"; cond = X86NL }; +"jng" , JCC { txt = "JNG"; cond = X86NG }; +"jle" , JCC { txt = "JLE"; cond = X86NG }; +"jmp" , JMP { txt = "JMP" }; +"lea" , LEA { txt = "LEA"; sz = X86NONE }; +"leave" , LEAVE { txt = "LEAVE" }; +"loopo" , LOOP { txt = "LOOPO"; cond = X86O }; +"loopb" , LOOP { txt = "LOOPB"; cond = X86B }; +"loopc" , LOOP { txt = "LOOPC"; cond = X86B }; +"loopnae" , LOOP { txt = "LOOPNAE"; cond = X86B }; +"loope" , LOOP { txt = "LOOPE"; cond = X86E }; +"loopz" , LOOP { txt = "LOOPZ"; cond = X86E }; +"loopa" , LOOP { txt = "LOOPA"; cond = X86A }; +"loopnbe" , LOOP { txt = "LOOPNBE"; cond = X86A }; +"loops" , LOOP { txt = "LOOPS"; cond = X86S }; +"loopp" , LOOP { txt = "LOOPP"; cond = X86P }; +"looppe" , LOOP { txt = "LOOPPE"; cond = X86P }; +"loopl" , LOOP { txt = "LOOPL"; cond = X86L }; +"loopnge" , LOOP { txt = "LOOPNGE"; cond = X86L }; +"loopg" , LOOP { txt = "LOOPG"; cond = X86G }; +"loopnle" , LOOP { txt = "LOOPNLE"; cond = X86G }; +"loopno" , LOOP { txt = "LOOPNO"; cond = X86NO }; +"loopnb" , LOOP { txt = "LOOPNB"; cond = X86NB }; +"loopnc" , LOOP { txt = "LOOPNC"; cond = X86NB }; +"loopae" , LOOP { txt = "LOOPAE"; cond = X86NB }; +"loopne" , LOOP { txt = "LOOPNE"; cond = X86NE }; +"loopnz" , LOOP { txt = "LOOPNZ"; cond = X86NE }; +"loopna" , LOOP { txt = "LOOPNA"; cond = X86NA }; +"loopbe" , LOOP { txt = "LOOPBE"; cond = X86NA }; +"loopns" , LOOP { txt = "LOOPNS"; cond = X86NS }; +"loopnp" , LOOP { txt = "LOOPNP"; cond = X86NP }; +"looppo" , LOOP { txt = "LOOPPO"; cond = X86NP }; +"loopnl" , LOOP { txt = "LOOPNL"; cond = X86NL }; +"loopge" , LOOP { txt = "LOOPGE"; cond = X86NL }; +"loopng" , LOOP { txt = "LOOPNG"; cond = X86NG }; +"loople" , LOOP { txt = "LOOPLE"; cond = X86NG }; +"mfence" , MFENCE { txt = "MFENCE" }; +"dec" , MONOP { txt = "DEC"; op = X86DEC; sz = X86NONE }; +"inc" , MONOP { txt = "INC"; op = X86INC; sz = X86NONE }; +"not" , MONOP { txt = "NOT"; op = X86NOT; sz = X86NONE }; +"neg" , MONOP { txt = "NEG"; op = X86NEG; sz = X86NONE }; +"cmovo" , CMOV { txt = "CMOVO"; cond = X86O; sz = X86NONE }; +"cmovb" , CMOV { txt = "CMOVB"; cond = X86B; sz = X86NONE }; +"cmovc" , CMOV { txt = "CMOVC"; cond = X86B; sz = X86NONE }; +"cmovnae" , CMOV { txt = "CMOVNAE"; cond = X86B; sz = X86NONE }; +"cmove" , CMOV { txt = "CMOVE"; cond = X86E; sz = X86NONE }; +"cmovz" , CMOV { txt = "CMOVZ"; cond = X86E; sz = X86NONE }; +"cmova" , CMOV { txt = "CMOVA"; cond = X86A; sz = X86NONE }; +"cmovnbe" , CMOV { txt = "CMOVNBE"; cond = X86A; sz = X86NONE }; +"cmovs" , CMOV { txt = "CMOVS"; cond = X86S; sz = X86NONE }; +"cmovp" , CMOV { txt = "CMOVP"; cond = X86P; sz = X86NONE }; +"cmovpe" , CMOV { txt = "CMOVPE"; cond = X86P; sz = X86NONE }; +"cmovl" , CMOV { txt = "CMOVL"; cond = X86L; sz = X86NONE }; +"cmovnge" , CMOV { txt = "CMOVNGE"; cond = X86L; sz = X86NONE }; +"cmovg" , CMOV { txt = "CMOVG"; cond = X86G; sz = X86NONE }; +"cmovnle" , CMOV { txt = "CMOVNLE"; cond = X86G; sz = X86NONE }; +"cmovno" , CMOV { txt = "CMOVNO"; cond = X86NO; sz = X86NONE }; +"cmovnb" , CMOV { txt = "CMOVNB"; cond = X86NB; sz = X86NONE }; +"cmovnc" , CMOV { txt = "CMOVNC"; cond = X86NB; sz = X86NONE }; +"cmovae" , CMOV { txt = "CMOVAE"; cond = X86NB; sz = X86NONE }; +"cmovne" , CMOV { txt = "CMOVNE"; cond = X86NE; sz = X86NONE }; +"cmovnz" , CMOV { txt = "CMOVNZ"; cond = X86NE; sz = X86NONE }; +"cmovna" , CMOV { txt = "CMOVNA"; cond = X86NA; sz = X86NONE }; +"cmovbe" , CMOV { txt = "CMOVBE"; cond = X86NA; sz = X86NONE }; +"cmovns" , CMOV { txt = "CMOVNS"; cond = X86NS; sz = X86NONE }; +"cmovnp" , CMOV { txt = "CMOVNP"; cond = X86NP; sz = X86NONE }; +"cmovpo" , CMOV { txt = "CMOVPO"; cond = X86NP; sz = X86NONE }; +"cmovnl" , CMOV { txt = "CMOVNL"; cond = X86NL; sz = X86NONE }; +"cmovge" , CMOV { txt = "CMOVGE"; cond = X86NL; sz = X86NONE }; +"cmovng" , CMOV { txt = "CMOVNG"; cond = X86NG; sz = X86NONE }; +"cmovle" , CMOV { txt = "CMOVLE"; cond = X86NG; sz = X86NONE }; +"mov" , MOV { txt = "MOV"; sz = X86NONE }; +"movsx" , MOVSX { txt = "MOVSBW"; sz1 = X86NONE; sz2 = X86NONE }; +"movzx" , MOVZX { txt = "MOVZBW"; sz1 = X86NONE; sz2 = X86NONE }; +"mul" , MUL { txt = "MUL"; sz = X86NONE }; +"nop" , NOP { txt = "NOP" }; +"pop" , POP { txt = "POP" }; +"push" , PUSH { txt = "PUSH" }; +"ret" , PUSH { txt = "RET" }; +"seto" , SET { txt = "SETO"; cond = X86O }; +"setb" , SET { txt = "SETB"; cond = X86B }; +"setc" , SET { txt = "SETC"; cond = X86B }; +"setnae" , SET { txt = "SETNAE"; cond = X86B }; +"sete" , SET { txt = "SETE"; cond = X86E }; +"setz" , SET { txt = "SETZ"; cond = X86E }; +"seta" , SET { txt = "SETA"; cond = X86A }; +"setnbe" , SET { txt = "SETNBE"; cond = X86A }; +"sets" , SET { txt = "SETS"; cond = X86S }; +"setp" , SET { txt = "SETP"; cond = X86P }; +"setpe" , SET { txt = "SETPE"; cond = X86P }; +"setl" , SET { txt = "SETL"; cond = X86L }; +"setnge" , SET { txt = "SETNGE"; cond = X86L }; +"setg" , SET { txt = "SETG"; cond = X86G }; +"setnle" , SET { txt = "SETNLE"; cond = X86G }; +"setno" , SET { txt = "SETNO"; cond = X86NO }; +"setnb" , SET { txt = "SETNB"; cond = X86NB }; +"setnc" , SET { txt = "SETNC"; cond = X86NB }; +"setae" , SET { txt = "SETAE"; cond = X86NB }; +"setne" , SET { txt = "SETNE"; cond = X86NE }; +"setnz" , SET { txt = "SETNZ"; cond = X86NE }; +"setna" , SET { txt = "SETNA"; cond = X86NA }; +"setbe" , SET { txt = "SETBE"; cond = X86NA }; +"setns" , SET { txt = "SETNS"; cond = X86NS }; +"setnp" , SET { txt = "SETNP"; cond = X86NP }; +"setpo" , SET { txt = "SETPO"; cond = X86NP }; +"setnl" , SET { txt = "SETNL"; cond = X86NL }; +"setge" , SET { txt = "SETGE"; cond = X86NL }; +"setng" , SET { txt = "SETNG"; cond = X86NG }; +"setle" , SET { txt = "SETLE"; cond = X86NG }; +"stc" , STC { txt = "STC" }; +"xadd" , XADD { txt = "XADD"; sz = X86NONE }; +"xchg" , XCHG { txt = "XCHG"; sz = X86NONE }; diff --git a/x86/gen/map.hgen b/x86/gen/map.hgen new file mode 100644 index 00000000..843e8832 --- /dev/null +++ b/x86/gen/map.hgen @@ -0,0 +1,26 @@ +| `X86BINOP (locked, bop, sz, ds) -> `X86BINOP (locked, bop, sz, map_dest_src ds) +| `X86BITOP (locked, bop, sz, bo) -> `X86BITOP (locked, bop, sz, map_bit_offset bo) +| `X86CALL irm -> `X86CALL (map_imm_rm irm) +| `X86CLC -> `X86CLC +| `X86CMC -> `X86CMC +| `X86CMPXCHG (locked, sz, rm, r) -> `X86CMPXCHG (locked, sz, map_rm rm, map_reg r) +| `X86DIV (sz, rm) -> `X86DIV (sz, map_rm rm) +| `X86JCC x -> `X86JCC x +| `X86JMP rm -> `X86JMP (map_rm rm) +| `X86LEA (sz, ds) -> `X86LEA (sz, map_dest_src ds) +| `X86LEAVE -> `X86LEAVE +| `X86LOOP x -> `X86LOOP x +| `X86MFENCE -> `X86MFENCE +| `X86MONOP (locked, mop, sz, rm) -> `X86MONOP (locked, mop, sz, map_rm rm) +| `X86MOV (cnd, sz, ds) -> `X86MOV (cnd, sz, map_dest_src ds) +| `X86MOVSX (sz1, ds, sz2) -> `X86MOVSX (sz1, map_dest_src ds, sz2) +| `X86MOVZX (sz1, ds, sz2) -> `X86MOVZX (sz1, map_dest_src ds, sz2) +| `X86MUL (sz, rm) -> `X86MUL (sz, map_rm rm) +| `X86NOP -> `X86NOP +| `X86POP rm -> `X86POP (map_rm rm) +| `X86PUSH irm -> `X86PUSH (map_imm_rm irm) +| `X86RET i -> `X86RET i +| `X86SET (cnd, b, rm) -> `X86SET (cnd, b, map_rm rm) +| `X86STC -> `X86STC +| `X86XADD (locked, sz, rm, r) -> `X86XADD (locked, sz, map_rm rm, map_reg r) +| `X86XCHG (locked, sz, rm, r) -> `X86XCHG (locked, sz, map_rm rm, map_reg r) diff --git a/x86/gen/parser.hgen b/x86/gen/parser.hgen new file mode 100644 index 00000000..b3c9dc72 --- /dev/null +++ b/x86/gen/parser.hgen @@ -0,0 +1,600 @@ +| BINOP imm COMMA addr + { `X86BINOP (false, $1.op, suffix_size $1.sz, Rm_i ($4, bit64_of_int $2)) } +| LOCK BINOP imm COMMA addr + { check_binop_lockable $2.op + ; `X86BINOP (true, $2.op, suffix_size $2.sz, Rm_i ($5, bit64_of_int $3)) } +| BINOP imm COMMA breg + { check_size ($1.sz, X86BYTE) + ; `X86BINOP (false, $1.op, X86S8 ($4.high), Rm_i (Reg (IReg ($4.reg)), bit64_of_int $2)) + } +| BINOP breg COMMA breg + { check_size ($1.sz, X86BYTE) + ; check_byte_regs ($2, $4) + ; `X86BINOP (false, $1.op, X86S8 ($4.high), Rm_r (Reg (IReg ($4.reg)), IReg ($2.reg))) + } +| BINOP addr COMMA breg + { check_size ($1.sz, X86BYTE) + ; `X86BINOP (false, $1.op, X86S8 ($4.high), R_rm (IReg ($4.reg), $2)) + } +| BINOP breg COMMA addr + { check_size ($1.sz, X86BYTE) + ; `X86BINOP (false, $1.op, X86S8 ($2.high), Rm_r ($4, IReg ($2.reg))) + } +| LOCK BINOP breg COMMA addr + { check_binop_lockable $2.op + ; check_size ($2.sz, X86BYTE) + ; `X86BINOP (true, $2.op, X86S8 ($3.high), Rm_r ($5, IReg ($3.reg))) + } +| BINOP imm COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86BINOP (false, $1.op, X86S16, Rm_i (Reg $4, bit64_of_int $2)) + } +| BINOP wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86BINOP (false, $1.op, X86S16, Rm_r (Reg $4, $2)) + } +| BINOP addr COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86BINOP (false, $1.op, X86S16, R_rm ($4, $2)) + } +| BINOP wreg COMMA addr + { check_size ($1.sz, X86WORD) + ; `X86BINOP (false, $1.op, X86S16, Rm_r ($4, $2)) + } +| LOCK BINOP wreg COMMA addr + { check_binop_lockable $2.op + ; check_size ($2.sz, X86WORD) + ; `X86BINOP (true, $2.op, X86S16, Rm_r ($5, $3)) + } +| BINOP imm COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86BINOP (false, $1.op, X86S32, Rm_i (Reg $4, bit64_of_int $2)) + } +| BINOP lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86BINOP (false, $1.op, X86S32, Rm_r (Reg $4, $2)) + } +| BINOP addr COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86BINOP (false, $1.op, X86S32, R_rm ($4, $2)) + } +| BINOP lreg COMMA addr + { check_size ($1.sz, X86LONG) + ; `X86BINOP (false, $1.op, X86S32, Rm_r ($4, $2)) + } +| LOCK BINOP lreg COMMA addr + { check_binop_lockable $2.op + ; check_size ($2.sz, X86LONG) + ; `X86BINOP (true, $2.op, X86S32, Rm_r ($5, $3)) + } +| BINOP imm COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86BINOP (false, $1.op, X86S64, Rm_i (Reg $4, bit64_of_int $2)) + } +| BINOP qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86BINOP (false, $1.op, X86S64, Rm_r (Reg $4, $2)) + } +| BINOP addr COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86BINOP (false, $1.op, X86S64, R_rm ($4, $2)) + } +| BINOP qreg COMMA addr + { check_size ($1.sz, X86QUAD) + ; `X86BINOP (false, $1.op, X86S64, Rm_r ($4, $2)) + } +| LOCK BINOP qreg COMMA addr + { check_binop_lockable $2.op + ; check_size ($2.sz, X86QUAD) + ; `X86BINOP (true, $2.op, X86S64, Rm_r ($5, $3)) + } +| BITOP imm COMMA addr + { `X86BITOP (false, $1.op, suffix_size $1.sz, Bit_rm_imm ($4, $2)) + } +| LOCK BITOP imm COMMA addr + { `X86BITOP (true, $2.op, suffix_size $2.sz, Bit_rm_imm ($5, $3)) + } +| BITOP imm COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86BITOP (false, $1.op, X86S16, Bit_rm_imm (Reg $4, $2)) + } +| LOCK BITOP imm COMMA wreg + { check_size ($2.sz, X86WORD) + ; `X86BITOP (true, $2.op, X86S16, Bit_rm_imm (Reg $5, $3)) + } +| BITOP wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86BITOP (true, $1.op, X86S16, Bit_rm_r (Reg $4, $2)) + } +| LOCK BITOP wreg COMMA wreg + { check_size ($2.sz, X86WORD) + ; `X86BITOP (false, $2.op, X86S16, Bit_rm_r (Reg $5, $3)) + } +| BITOP wreg COMMA addr + { check_size ($1.sz, X86WORD) + ; `X86BITOP (false, $1.op, X86S16, Bit_rm_r ($4, $2)) + } +| LOCK BITOP wreg COMMA addr + { check_size ($2.sz, X86WORD) + ; `X86BITOP (true, $2.op, X86S16, Bit_rm_r ($5, $3)) + } +| BITOP imm COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86BITOP (false, $1.op, X86S32, Bit_rm_imm (Reg $4, $2)) + } +| LOCK BITOP imm COMMA lreg + { check_size ($2.sz, X86LONG) + ; `X86BITOP (true, $2.op, X86S32, Bit_rm_imm (Reg $5, $3)) + } +| BITOP lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86BITOP (false, $1.op, X86S32, Bit_rm_r (Reg $4, $2)) + } +| LOCK BITOP lreg COMMA lreg + { check_size ($2.sz, X86LONG) + ; `X86BITOP (true, $2.op, X86S32, Bit_rm_r (Reg $5, $3)) + } +| BITOP lreg COMMA addr + { check_size ($1.sz, X86LONG) + ; `X86BITOP (false, $1.op, X86S32, Bit_rm_r ($4, $2)) + } +| LOCK BITOP lreg COMMA addr + { check_size ($2.sz, X86LONG) + ; `X86BITOP (true, $2.op, X86S32, Bit_rm_r ($5, $3)) + } +| BITOP imm COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86BITOP (false, $1.op, X86S64, Bit_rm_imm (Reg $4, $2)) + } +| LOCK BITOP imm COMMA qreg + { check_size ($2.sz, X86QUAD) + ; `X86BITOP (true, $2.op, X86S64, Bit_rm_imm (Reg $5, $3)) + } +| BITOP qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86BITOP (false, $1.op, X86S64, Bit_rm_r (Reg $4, $2)) + } +| LOCK BITOP qreg COMMA qreg + { check_size ($2.sz, X86QUAD) + ; `X86BITOP (true, $2.op, X86S64, Bit_rm_r (Reg $5, $3)) + } +| BITOP qreg COMMA addr + { check_size ($1.sz, X86QUAD) + ; `X86BITOP (false, $1.op, X86S64, Bit_rm_r ($4, $2)) + } +| LOCK BITOP qreg COMMA addr + { check_size ($2.sz, X86QUAD) + ; `X86BITOP (true, $2.op, X86S64, Bit_rm_r ($5, $3)) + } +| CALL big_imm + { `X86CALL (Imm $2) } +| CALL addr + { `X86CALL (Rm $2) } +| CALL qreg + { `X86CALL (Rm (Reg $2)) } +| CLC + { `X86CLC } +| CMC + { `X86CMC } +| CMOV addr COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86MOV ($1.cond, X86S16, R_rm ($4, $2)) + } +| CMOV addr COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86MOV ($1.cond, X86S32, R_rm ($4, $2)) + } +| CMOV addr COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86MOV ($1.cond, X86S64, R_rm ($4, $2)) + } +| CMOV wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86MOV ($1.cond, X86S16, R_rm ($4, Reg $2)) + } +| CMOV lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86MOV ($1.cond, X86S32, R_rm ($4, Reg $2)) + } +| CMOV qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86MOV ($1.cond, X86S64, R_rm ($4, Reg $2)) + } +| CMPXCHG breg COMMA breg + { check_size ($1.sz, X86BYTE) + ; check_byte_regs ($2, $4) + ; `X86CMPXCHG (false, X86S8 ($2.high), Reg (IReg ($4.reg)), IReg ($2.reg)) + } +| CMPXCHG breg COMMA addr + { check_size ($1.sz, X86BYTE) + ; `X86CMPXCHG (false, X86S8 ($2.high), $4, IReg ($2.reg)) + } +| LOCK CMPXCHG breg COMMA addr + { check_size ($2.sz, X86BYTE) + ; `X86CMPXCHG (true, X86S8 ($3.high), $5, IReg ($3.reg)) + } +| CMPXCHG wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86CMPXCHG (false, X86S16, Reg $4, $2) + } +| CMPXCHG wreg COMMA addr + { check_size ($1.sz, X86WORD) + ; `X86CMPXCHG (false, X86S16, $4, $2) + } +| LOCK CMPXCHG wreg COMMA addr + { check_size ($2.sz, X86WORD) + ; `X86CMPXCHG (true, X86S16, $5, $3) + } +| CMPXCHG lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86CMPXCHG (false, X86S32, Reg $4, $2) + } +| CMPXCHG lreg COMMA addr + { check_size ($1.sz, X86LONG) + ; `X86CMPXCHG (false, X86S32, $4, $2) + } +| LOCK CMPXCHG lreg COMMA addr + { check_size ($2.sz, X86LONG) + ; `X86CMPXCHG (true, X86S32, $5, $3) + } +| CMPXCHG qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86CMPXCHG (false, X86S64, Reg $4, $2) + } +| CMPXCHG qreg COMMA addr + { check_size ($1.sz, X86QUAD) + ; `X86CMPXCHG (false, X86S64, $4, $2) + } +| LOCK CMPXCHG qreg COMMA addr + { check_size ($2.sz, X86QUAD) + ; `X86CMPXCHG (true, X86S64, $5, $3) + } +| DIV addr + { `X86DIV (suffix_size $1.sz, $2) } +| DIV breg + { check_size ($1.sz, X86BYTE) + ; `X86DIV (X86S8 ($2.high), Reg (IReg ($2.reg))) + } +| DIV wreg + { check_size ($1.sz, X86WORD) + ; `X86DIV (X86S16, Reg $2) + } +| DIV lreg + { check_size ($1.sz, X86LONG) + ; `X86DIV (X86S32, Reg $2) + } +| DIV qreg + { check_size ($1.sz, X86QUAD) + ; `X86DIV (X86S64, Reg $2) + } +| JCC big_num + { `X86JCC ($1.cond, $2) } +| JMP big_num + { `X86JCC (X86ALWAYS, $2) } +| JMP addr + { `X86JMP $2 } +| JMP qreg + { `X86JMP (Reg $2) } +| LEA addr COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86LEA (X86S16, R_rm ($4, $2)) + } +| LEA addr COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86LEA (X86S32, R_rm ($4, $2)) + } +| LEA addr COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86LEA (X86S64, R_rm ($4, $2)) + } +| LEAVE + { `X86LEAVE } +| LOOP big_num + { `X86LOOP ($1.cond, $2) } +| MFENCE + { `X86MFENCE } +| MONOP addr + { `X86MONOP (false, $1.op, suffix_size $1.sz, $2) } +| LOCK MONOP addr + { `X86MONOP (true, $2.op, suffix_size $2.sz, $3) } +| MONOP breg + { check_size ($1.sz, X86BYTE) + ; `X86MONOP (false, $1.op, X86S8 ($2.high), Reg (IReg $2.reg)) + } +| MONOP wreg + { check_size ($1.sz, X86WORD) + ; `X86MONOP (false, $1.op, X86S16, Reg $2) + } +| MONOP lreg + { check_size ($1.sz, X86LONG) + ; `X86MONOP (false, $1.op, X86S32, Reg $2) + } +| MONOP qreg + { check_size ($1.sz, X86QUAD) + ; `X86MONOP (false, $1.op, X86S64, Reg $2) + } +| MOV big_imm COMMA addr + { `X86MOV (X86ALWAYS, suffix_size $1.sz, Rm_i ($4, $2)) } +| MOV imm COMMA breg + { check_size ($1.sz, X86BYTE) + ; `X86MOV (X86ALWAYS, X86S8 ($4.high), Rm_i (Reg (IReg $4.reg), bit64_of_int $2)) + } +| MOV breg COMMA breg + { check_size ($1.sz, X86BYTE) + ; check_byte_regs ($2, $4) + ; `X86MOV (X86ALWAYS, X86S8 ($4.high), Rm_r (Reg (IReg $4.reg), (IReg $2.reg))) + } +| MOV addr COMMA breg + { check_size ($1.sz, X86BYTE) + ; `X86MOV (X86ALWAYS, X86S8 ($4.high), R_rm (IReg $4.reg, $2)) + } +| MOV breg COMMA addr + { check_size ($1.sz, X86BYTE) + ; `X86MOV (X86ALWAYS, X86S8 ($2.high), Rm_r ($4, IReg $2.reg)) + } +| MOV imm COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86MOV (X86ALWAYS, X86S16, Rm_i (Reg $4, bit64_of_int $2)) + } +| MOV wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86MOV (X86ALWAYS, X86S16, Rm_r (Reg $4, $2)) + } +| MOV addr COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86MOV (X86ALWAYS, X86S16, R_rm ($4, $2)) + } +| MOV wreg COMMA addr + { check_size ($1.sz, X86WORD) + ; `X86MOV (X86ALWAYS, X86S16, Rm_r ($4, $2)) + } +| MOV imm COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86MOV (X86ALWAYS, X86S32, Rm_i (Reg $4, bit64_of_int $2)) + } +| MOV lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86MOV (X86ALWAYS, X86S32, Rm_r (Reg $4, $2)) + } +| MOV addr COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86MOV (X86ALWAYS, X86S32, R_rm ($4, $2)) + } +| MOV lreg COMMA addr + { check_size ($1.sz, X86LONG) + ; `X86MOV (X86ALWAYS, X86S32, Rm_r ($4, $2)) + } +| MOV big_imm COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86MOV (X86ALWAYS, X86S64, Rm_i (Reg $4, $2)) + } +| MOV qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; if $1.txt = "MOVABS" then failwith "movabs expects and immediate" else () + ; `X86MOV (X86ALWAYS, X86S64, Rm_r (Reg $4, $2)) + } +| MOV addr COMMA qreg + { check_size ($1.sz, X86QUAD) + ; if $1.txt = "MOVABS" then failwith "movabs expects and immediate" else () + ; `X86MOV (X86ALWAYS, X86S64, R_rm ($4, $2)) + } +| MOV qreg COMMA addr + { check_size ($1.sz, X86QUAD) + ; if $1.txt = "MOVABS" then failwith "movabs expects and immediate" else () + ; `X86MOV (X86ALWAYS, X86S64, Rm_r ($4, $2)) + } +| MOVSX breg COMMA wreg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86WORD) + ; `X86MOVSX (X86S16, R_rm ($4, Reg (IReg $2.reg)), X86S8 $2.high) + } +| MOVSX breg COMMA lreg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86LONG) + ; `X86MOVSX (X86S32, R_rm ($4, Reg (IReg $2.reg)), X86S8 $2.high) + } +| MOVSX breg COMMA qreg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86QUAD) + ; `X86MOVSX (X86S64, R_rm ($4, Reg (IReg $2.reg)), X86S8 $2.high) + } +| MOVSX wreg COMMA lreg + { check_size ($1.sz1, X86WORD) + ; check_size ($1.sz2, X86LONG) + ; `X86MOVSX (X86S32, R_rm ($4, Reg $2), X86S16) + } +| MOVSX wreg COMMA qreg + { check_size ($1.sz1, X86WORD) + ; check_size ($1.sz2, X86QUAD) + ; `X86MOVSX (X86S64, R_rm ($4, Reg $2), X86S16) + } +| MOVSX lreg COMMA qreg + { check_size ($1.sz1, X86LONG) + ; check_size ($1.sz2, X86QUAD) + ; `X86MOVSX (X86S64, R_rm ($4, Reg $2), X86S32) + } +| MOVSX addr COMMA wreg + { check_size ($1.sz2, X86WORD) + ; `X86MOVSX (X86S16, R_rm ($4, $2), suffix_size $1.sz1) + } +| MOVSX addr COMMA lreg + { check_size ($1.sz2, X86LONG) + ; `X86MOVSX (X86S32, R_rm ($4, $2), suffix_size $1.sz1) + } +| MOVSX addr COMMA qreg + { check_size ($1.sz2, X86QUAD) + ; `X86MOVSX (X86S64, R_rm ($4, $2), suffix_size $1.sz1) + } +| MOVZX breg COMMA wreg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86WORD) + ; `X86MOVZX (X86S16, R_rm ($4, Reg (IReg $2.reg)), X86S8 $2.high) + } +| MOVZX breg COMMA lreg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86LONG) + ; `X86MOVZX (X86S32, R_rm ($4, Reg (IReg $2.reg)), X86S8 $2.high) + } +| MOVZX breg COMMA qreg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86QUAD) + ; `X86MOVZX (X86S64, R_rm ($4, Reg (IReg $2.reg)), X86S8 $2.high) + } +| MOVZX wreg COMMA lreg + { check_size ($1.sz1, X86WORD) + ; check_size ($1.sz2, X86LONG) + ; `X86MOVZX (X86S32, R_rm ($4, Reg $2), X86S16) + } +| MOVZX wreg COMMA qreg + { check_size ($1.sz1, X86WORD) + ; check_size ($1.sz2, X86QUAD) + ; `X86MOVZX (X86S64, R_rm ($4, Reg $2), X86S16) + } +| MOVZX addr COMMA wreg + { check_size ($1.sz2, X86WORD) + ; `X86MOVZX (X86S16, R_rm ($4, $2), suffix_size $1.sz1) + } +| MOVZX addr COMMA lreg + { check_size ($1.sz2, X86LONG) + ; `X86MOVZX (X86S32, R_rm ($4, $2), suffix_size $1.sz1) + } +| MOVZX addr COMMA qreg + { check_size ($1.sz2, X86QUAD) + ; `X86MOVZX (X86S64, R_rm ($4, $2), suffix_size $1.sz1) + } +| MUL addr + { `X86MUL (suffix_size $1.sz, $2) } +| MUL breg + { check_size ($1.sz, X86BYTE) + ; `X86MUL (X86S8 ($2.high), Reg (IReg $2.reg)) + } +| MUL wreg + { check_size ($1.sz, X86WORD) + ; `X86MUL (X86S16, Reg $2) + } +| MUL lreg + { check_size ($1.sz, X86LONG) + ; `X86MUL (X86S32, Reg $2) + } +| MUL qreg + { check_size ($1.sz, X86QUAD) + ; `X86MUL (X86S64, Reg $2) + } +| NOP + { `X86NOP } +| POP qreg + { `X86POP (Reg $2) } +| POP addr + { `X86POP $2 } +| PUSH big_imm + { `X86PUSH (Imm $2) } +| PUSH addr + { `X86PUSH (Rm $2) } +| PUSH qreg + { `X86PUSH (Rm (Reg $2)) } +| RET big_imm + { `X86RET $2 } +| SET breg + { `X86SET ($1.cond, $2.high, Reg (IReg $2.reg)) } +| SET addr + { `X86SET ($1.cond, false, $2) } +| STC + { `X86STC } +| XADD breg COMMA breg + { check_size ($1.sz, X86BYTE) + ; check_byte_regs ($2, $4) + ; `X86XADD (false, X86S8 ($2.high), Reg (IReg $4.reg), (IReg $2.reg)) + } +| XADD breg COMMA addr + { check_size ($1.sz, X86BYTE) + ; `X86XADD (false, X86S8 ($2.high), $4, (IReg $2.reg)) + } +| LOCK XADD breg COMMA addr + { check_size ($2.sz, X86BYTE) + ; `X86XADD (true, X86S8 ($3.high), $5, (IReg $3.reg)) + } +| XADD wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86XADD (false, X86S16, Reg $4, $2) + } +| XADD wreg COMMA addr + { check_size ($1.sz, X86WORD) + ; `X86XADD (false, X86S16, $4, $2) + } +| LOCK XADD wreg COMMA addr + { check_size ($2.sz, X86WORD) + ; `X86XADD (true, X86S16, $5, $3) + } +| XADD lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86XADD (false, X86S32, Reg $4, $2) + } +| XADD lreg COMMA addr + { check_size ($1.sz, X86LONG) + ; `X86XADD (false, X86S32, $4, $2) + } +| LOCK XADD lreg COMMA addr + { check_size ($2.sz, X86LONG) + ; `X86XADD (true, X86S32, $5, $3) + } +| XADD qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86XADD (false, X86S64, Reg $4, $2) + } +| XADD qreg COMMA addr + { check_size ($1.sz, X86QUAD) + ; `X86XADD (false, X86S64, $4, $2) + } +| LOCK XADD qreg COMMA addr + { check_size ($2.sz, X86QUAD) + ; `X86XADD (true, X86S64, $5, $3) + } +| XCHG breg COMMA breg + { check_size ($1.sz, X86BYTE) + ; check_byte_regs ($2, $4) + ; `X86XCHG (false, X86S8 ($2.high), Reg (IReg $4.reg), IReg $2.reg) + } +| XCHG breg COMMA addr + { check_size ($1.sz, X86BYTE) + ; `X86XCHG (false, X86S8 ($2.high), $4, (IReg $2.reg)) + } +| LOCK XCHG breg COMMA addr + { check_size ($2.sz, X86BYTE) + ; `X86XCHG (true, X86S8 ($3.high), $5, (IReg $3.reg)) + } +| XCHG wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86XCHG (false, X86S16, Reg $4, $2) + } +| XCHG wreg COMMA addr + { check_size ($1.sz, X86WORD) + ; `X86XCHG (false, X86S16, $4, $2) + } +| LOCK XCHG wreg COMMA addr + { check_size ($2.sz, X86WORD) + ; `X86XCHG (true, X86S16, $5, $3) + } +| XCHG lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86XCHG (false, X86S32, Reg $4, $2) + } +| XCHG lreg COMMA addr + { check_size ($1.sz, X86LONG) + ; `X86XCHG (false, X86S32, $4, $2) + } +| LOCK XCHG lreg COMMA addr + { check_size ($2.sz, X86LONG) + ; `X86XCHG (true, X86S32, $5, $3) + } +| XCHG qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86XCHG (false, X86S64, Reg $4, $2) + } +| XCHG qreg COMMA addr + { check_size ($1.sz, X86QUAD) + ; `X86XCHG (false, X86S64, $4, $2) + } +| LOCK XCHG qreg COMMA addr + { check_size ($2.sz, X86QUAD) + ; `X86XCHG (true, X86S64, $5, $3) + } diff --git a/x86/gen/parser_intel.hgen b/x86/gen/parser_intel.hgen new file mode 100644 index 00000000..72fa0ede --- /dev/null +++ b/x86/gen/parser_intel.hgen @@ -0,0 +1,601 @@ +| BINOP addr COMMA imm + { `X86BINOP (false, $1.op, suffix_size $1.sz, Rm_i ($2, bit64_of_int $4)) + (* XXX size is ambigious -- should require anotation *) } +| LOCK BINOP addr COMMA imm + { check_binop_lockable $2.op + ; `X86BINOP (true, $2.op, suffix_size $2.sz, Rm_i ($3, bit64_of_int $5)) } +| BINOP breg COMMA imm + { check_size ($1.sz, X86BYTE) + ; `X86BINOP (false, $1.op, X86S8 ($2.high), Rm_i (Reg (IReg ($2.reg)), bit64_of_int $4)) + } +| BINOP breg COMMA breg + { check_size ($1.sz, X86BYTE) + ; check_byte_regs ($2, $4) + ; `X86BINOP (false, $1.op, X86S8 ($2.high), Rm_r (Reg (IReg ($2.reg)), IReg ($4.reg))) + } +| BINOP addr COMMA breg + { check_size ($1.sz, X86BYTE) + ; `X86BINOP (false, $1.op, X86S8 ($4.high), Rm_r ($2, IReg ($4.reg))) + } +| LOCK BINOP addr COMMA breg + { check_binop_lockable $2.op; + check_size ($2.sz, X86BYTE) + ; `X86BINOP (true, $2.op, X86S8 ($5.high), Rm_r ($3, IReg ($5.reg))) + } +| BINOP breg COMMA addr + { check_size ($1.sz, X86BYTE) + ; `X86BINOP (false, $1.op, X86S8 ($2.high), R_rm (IReg ($2.reg), $4)) + } +| BINOP wreg COMMA imm + { check_size ($1.sz, X86WORD) + ; `X86BINOP (false, $1.op, X86S16, Rm_i (Reg $2, bit64_of_int $4)) + } +| BINOP wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86BINOP (false, $1.op, X86S16, Rm_r (Reg $2, $4)) + } +| BINOP addr COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86BINOP (false, $1.op, X86S16, Rm_r ($2, $4)) + } +| LOCK BINOP addr COMMA wreg + { check_binop_lockable $2.op; + check_size ($2.sz, X86WORD) + ; `X86BINOP (true, $2.op, X86S16, Rm_r ($3, $5)) + } +| BINOP wreg COMMA addr + { check_size ($1.sz, X86WORD) + ; `X86BINOP (false, $1.op, X86S16, R_rm ($2, $4)) + } +| BINOP lreg COMMA imm + { check_size ($1.sz, X86LONG) + ; `X86BINOP (false, $1.op, X86S32, Rm_i (Reg $2, bit64_of_int $4)) + } +| BINOP lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86BINOP (false, $1.op, X86S32, Rm_r (Reg $2, $4)) + } +| BINOP addr COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86BINOP (false, $1.op, X86S32, Rm_r ($2, $4)) + } +| LOCK BINOP addr COMMA lreg + { check_binop_lockable $2.op; + check_size ($2.sz, X86LONG) + ; `X86BINOP (true, $2.op, X86S32, Rm_r ($3, $5)) + } +| BINOP lreg COMMA addr + { check_size ($1.sz, X86LONG) + ; `X86BINOP (false, $1.op, X86S32, R_rm ($2, $4)) + } +| BINOP qreg COMMA imm + { check_size ($1.sz, X86QUAD) + ; `X86BINOP (false, $1.op, X86S64, Rm_i (Reg $2, bit64_of_int $4)) + } +| BINOP qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86BINOP (false, $1.op, X86S64, Rm_r (Reg $2, $4)) + } +| BINOP addr COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86BINOP (false, $1.op, X86S64, Rm_r ($2, $4)) + } +| LOCK BINOP addr COMMA qreg + { check_binop_lockable $2.op; + check_size ($2.sz, X86QUAD) + ; `X86BINOP (true, $2.op, X86S64, Rm_r ($3, $5)) + } +| BINOP qreg COMMA addr + { check_size ($1.sz, X86QUAD) + ; `X86BINOP (false, $1.op, X86S64, R_rm ($2, $4)) + } +| BITOP addr COMMA imm + { `X86BITOP (false, $1.op, suffix_size $1.sz, Bit_rm_imm ($2, $4)) + } +| LOCK BITOP addr COMMA imm + { `X86BITOP (true, $2.op, suffix_size $2.sz, Bit_rm_imm ($3, $5)) + } +| BITOP wreg COMMA imm + { check_size ($1.sz, X86WORD) + ; `X86BITOP (false, $1.op, X86S16, Bit_rm_imm (Reg $2, $4)) + } +| LOCK BITOP wreg COMMA imm + { check_size ($2.sz, X86WORD) + ; `X86BITOP (true, $2.op, X86S16, Bit_rm_imm (Reg $3, $5)) + } +| BITOP wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86BITOP (true, $1.op, X86S16, Bit_rm_r (Reg $2, $4)) + } +| LOCK BITOP wreg COMMA wreg + { check_size ($2.sz, X86WORD) + ; `X86BITOP (false, $2.op, X86S16, Bit_rm_r (Reg $3, $5)) + } +| BITOP addr COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86BITOP (false, $1.op, X86S16, Bit_rm_r ($2, $4)) + } +| LOCK BITOP addr COMMA wreg + { check_size ($2.sz, X86WORD) + ; `X86BITOP (true, $2.op, X86S16, Bit_rm_r ($3, $5)) + } +| BITOP lreg COMMA imm + { check_size ($1.sz, X86LONG) + ; `X86BITOP (false, $1.op, X86S32, Bit_rm_imm (Reg $2, $4)) + } +| LOCK BITOP lreg COMMA imm + { check_size ($2.sz, X86LONG) + ; `X86BITOP (true, $2.op, X86S32, Bit_rm_imm (Reg $3, $5)) + } +| BITOP lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86BITOP (false, $1.op, X86S32, Bit_rm_r (Reg $2, $4)) + } +| LOCK BITOP lreg COMMA lreg + { check_size ($2.sz, X86LONG) + ; `X86BITOP (true, $2.op, X86S32, Bit_rm_r (Reg $3, $5)) + } +| BITOP addr COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86BITOP (false, $1.op, X86S32, Bit_rm_r ($2, $4)) + } +| LOCK BITOP addr COMMA lreg + { check_size ($2.sz, X86LONG) + ; `X86BITOP (true, $2.op, X86S32, Bit_rm_r ($3, $5)) + } +| BITOP qreg COMMA imm + { check_size ($1.sz, X86QUAD) + ; `X86BITOP (false, $1.op, X86S64, Bit_rm_imm (Reg $2, $4)) + } +| LOCK BITOP qreg COMMA imm + { check_size ($2.sz, X86QUAD) + ; `X86BITOP (true, $2.op, X86S64, Bit_rm_imm (Reg $3, $5)) + } +| BITOP qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86BITOP (false, $1.op, X86S64, Bit_rm_r (Reg $2, $4)) + } +| LOCK BITOP qreg COMMA qreg + { check_size ($2.sz, X86QUAD) + ; `X86BITOP (true, $2.op, X86S64, Bit_rm_r (Reg $3, $5)) + } +| BITOP addr COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86BITOP (false, $1.op, X86S64, Bit_rm_r ($2, $4)) + } +| LOCK BITOP addr COMMA qreg + { check_size ($2.sz, X86QUAD) + ; `X86BITOP (true, $2.op, X86S64, Bit_rm_r ($3, $5)) + } +| CALL big_imm + { `X86CALL (Imm $2) } +| CALL addr + { `X86CALL (Rm $2) } +| CALL qreg + { `X86CALL (Rm (Reg $2)) } +| CLC + { `X86CLC } +| CMC + { `X86CMC } +| CMOV wreg COMMA addr + { check_size ($1.sz, X86WORD) + ; `X86MOV ($1.cond, X86S16, R_rm ($2, $4)) + } +| CMOV lreg COMMA addr + { check_size ($1.sz, X86LONG) + ; `X86MOV ($1.cond, X86S32, R_rm ($2, $4)) + } +| CMOV qreg COMMA addr + { check_size ($1.sz, X86QUAD) + ; `X86MOV ($1.cond, X86S64, R_rm ($2, $4)) + } +| CMOV wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86MOV ($1.cond, X86S16, R_rm ($2, Reg $4)) + } +| CMOV lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86MOV ($1.cond, X86S32, R_rm ($2, Reg $4)) + } +| CMOV qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86MOV ($1.cond, X86S64, R_rm ($2, Reg $4)) + } +| CMPXCHG breg COMMA breg + { check_size ($1.sz, X86BYTE) + ; check_byte_regs ($2, $4) + ; `X86CMPXCHG (false, X86S8 ($2.high), Reg (IReg ($2.reg)), IReg ($4.reg)) + } +| CMPXCHG addr COMMA breg + { check_size ($1.sz, X86BYTE) + ; `X86CMPXCHG (false, X86S8 ($4.high), $2, IReg ($4.reg)) + } +| LOCK CMPXCHG addr COMMA breg + { check_size ($2.sz, X86BYTE) + ; `X86CMPXCHG (true, X86S8 ($5.high), $3, IReg ($5.reg)) + } +| CMPXCHG wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86CMPXCHG (false, X86S16, Reg $2, $4) + } +| CMPXCHG addr COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86CMPXCHG (false, X86S16, $2, $4) + } +| LOCK CMPXCHG addr COMMA wreg + { check_size ($2.sz, X86WORD) + ; `X86CMPXCHG (true, X86S16, $3, $5) + } +| CMPXCHG lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86CMPXCHG (false, X86S32, Reg $2, $4) + } +| CMPXCHG addr COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86CMPXCHG (false, X86S32, $2, $4) + } +| LOCK CMPXCHG addr COMMA lreg + { check_size ($2.sz, X86LONG) + ; `X86CMPXCHG (true, X86S32, $3, $5) + } +| CMPXCHG qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86CMPXCHG (false, X86S64, Reg $2, $4) + } +| CMPXCHG addr COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86CMPXCHG (false, X86S64, $2, $4) + } +| LOCK CMPXCHG addr COMMA qreg + { check_size ($2.sz, X86QUAD) + ; `X86CMPXCHG (true, X86S64, $3, $5) + } +| DIV addr + { `X86DIV (suffix_size $1.sz, $2) } +| DIV breg + { check_size ($1.sz, X86BYTE) + ; `X86DIV (X86S8 ($2.high), Reg (IReg ($2.reg))) + } +| DIV wreg + { check_size ($1.sz, X86WORD) + ; `X86DIV (X86S16, Reg $2) + } +| DIV lreg + { check_size ($1.sz, X86LONG) + ; `X86DIV (X86S32, Reg $2) + } +| DIV qreg + { check_size ($1.sz, X86QUAD) + ; `X86DIV (X86S64, Reg $2) + } +| JCC big_num + { `X86JCC ($1.cond, $2) } +| JMP big_num + { `X86JCC (X86ALWAYS, $2) } +| JMP addr + { `X86JMP $2 } +| JMP qreg + { `X86JMP (Reg $2) } +| LEA wreg COMMA addr + { check_size ($1.sz, X86WORD) + ; `X86LEA (X86S16, R_rm ($2, $4)) + } +| LEA lreg COMMA addr + { check_size ($1.sz, X86LONG) + ; `X86LEA (X86S32, R_rm ($2, $4)) + } +| LEA qreg COMMA addr + { check_size ($1.sz, X86QUAD) + ; `X86LEA (X86S64, R_rm ($2, $4)) + } +| LEAVE + { `X86LEAVE } +| LOOP big_num + { `X86LOOP ($1.cond, $2) } +| MFENCE + { `X86MFENCE } +| MONOP addr + { `X86MONOP (false, $1.op, suffix_size $1.sz, $2) } +| LOCK MONOP addr + { `X86MONOP (true, $2.op, suffix_size $2.sz, $3) } +| MONOP breg + { check_size ($1.sz, X86BYTE) + ; `X86MONOP (false, $1.op, X86S8 ($2.high), Reg (IReg $2.reg)) + } +| MONOP wreg + { check_size ($1.sz, X86WORD) + ; `X86MONOP (false, $1.op, X86S16, Reg $2) + } +| MONOP lreg + { check_size ($1.sz, X86LONG) + ; `X86MONOP (false, $1.op, X86S32, Reg $2) + } +| MONOP qreg + { check_size ($1.sz, X86QUAD) + ; `X86MONOP (false, $1.op, X86S64, Reg $2) + } +| MOV addr COMMA big_imm + { `X86MOV (X86ALWAYS, suffix_size $1.sz, Rm_i ($2, $4)) } +| MOV breg COMMA imm + { check_size ($1.sz, X86BYTE) + ; `X86MOV (X86ALWAYS, X86S8 ($2.high), Rm_i (Reg (IReg $2.reg), bit64_of_int $4)) + } +| MOV breg COMMA breg + { check_size ($1.sz, X86BYTE) + ; check_byte_regs ($2, $4) + ; `X86MOV (X86ALWAYS, X86S8 ($2.high), Rm_r (Reg (IReg $2.reg), (IReg $4.reg))) + } +| MOV addr COMMA breg + { check_size ($1.sz, X86BYTE) + ; `X86MOV (X86ALWAYS, X86S8 ($4.high), Rm_r ($2, IReg $4.reg)) + } +| MOV breg COMMA addr + { check_size ($1.sz, X86BYTE) + ; `X86MOV (X86ALWAYS, X86S8 ($2.high), R_rm (IReg $2.reg, $4)) + } +| MOV wreg COMMA imm + { check_size ($1.sz, X86WORD) + ; `X86MOV (X86ALWAYS, X86S16, Rm_i (Reg $2, bit64_of_int $4)) + } +| MOV wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86MOV (X86ALWAYS, X86S16, Rm_r (Reg $2, $4)) + } +| MOV addr COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86MOV (X86ALWAYS, X86S16, Rm_r ($2, $4)) + } +| MOV wreg COMMA addr + { check_size ($1.sz, X86WORD) + ; `X86MOV (X86ALWAYS, X86S16, R_rm ($2, $4)) + } +| MOV lreg COMMA imm + { check_size ($1.sz, X86LONG) + ; `X86MOV (X86ALWAYS, X86S32, Rm_i (Reg $2, bit64_of_int $4)) + } +| MOV lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86MOV (X86ALWAYS, X86S32, Rm_r (Reg $2, $4)) + } +| MOV addr COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86MOV (X86ALWAYS, X86S32, Rm_r ($2, $4)) + } +| MOV lreg COMMA addr + { check_size ($1.sz, X86LONG) + ; `X86MOV (X86ALWAYS, X86S32, R_rm ($2, $4)) + } +| MOV qreg COMMA big_imm + { check_size ($1.sz, X86QUAD) + ; `X86MOV (X86ALWAYS, X86S64, Rm_i (Reg $2, $4)) + } +| MOV qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; if $1.txt = "MOVABS" then failwith "movabs expects an immediate" else () + ; `X86MOV (X86ALWAYS, X86S64, Rm_r (Reg $2, $4)) + } +| MOV addr COMMA qreg + { check_size ($1.sz, X86QUAD) + ; if $1.txt = "MOVABS" then failwith "movabs expects an immediate" else () + ; `X86MOV (X86ALWAYS, X86S64, Rm_r ($2, $4)) + } +| MOV qreg COMMA addr + { check_size ($1.sz, X86QUAD) + ; if $1.txt = "MOVABS" then failwith "movabs expects an immediate" else () + ; `X86MOV (X86ALWAYS, X86S64, R_rm ($2, $4)) + } +| MOVSX wreg COMMA breg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86WORD) + ; `X86MOVSX (X86S16, R_rm ($2, Reg (IReg $4.reg)), X86S8 $4.high) + } +| MOVSX lreg COMMA breg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86LONG) + ; `X86MOVSX (X86S32, R_rm ($2, Reg (IReg $4.reg)), X86S8 $4.high) + } +| MOVSX qreg COMMA breg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86QUAD) + ; `X86MOVSX (X86S64, R_rm ($2, Reg (IReg $4.reg)), X86S8 $4.high) + } +| MOVSX lreg COMMA wreg + { check_size ($1.sz1, X86WORD) + ; check_size ($1.sz2, X86LONG) + ; `X86MOVSX (X86S32, R_rm ($2, Reg $4), X86S16) + } +| MOVSX qreg COMMA wreg + { check_size ($1.sz1, X86WORD) + ; check_size ($1.sz2, X86QUAD) + ; `X86MOVSX (X86S64, R_rm ($2, Reg $4), X86S16) + } +| MOVSX qreg COMMA lreg + { check_size ($1.sz1, X86LONG) + ; check_size ($1.sz2, X86QUAD) + ; `X86MOVSX (X86S64, R_rm ($2, Reg $4), X86S32) + } +| MOVSX wreg COMMA addr + { check_size ($1.sz2, X86WORD) + ; `X86MOVSX (X86S16, R_rm ($2, $4), suffix_size $1.sz1) (* XXX size *) + } +| MOVSX lreg COMMA addr + { check_size ($1.sz2, X86LONG) + ; `X86MOVSX (X86S32, R_rm ($2, $4), suffix_size $1.sz1) + } +| MOVSX qreg COMMA addr + { check_size ($1.sz2, X86QUAD) + ; `X86MOVSX (X86S64, R_rm ($2, $4), suffix_size $1.sz1) + } +| MOVZX wreg COMMA breg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86WORD) + ; `X86MOVZX (X86S16, R_rm ($2, Reg (IReg $4.reg)), X86S8 $4.high) + } +| MOVZX lreg COMMA breg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86LONG) + ; `X86MOVZX (X86S32, R_rm ($2, Reg (IReg $4.reg)), X86S8 $4.high) + } +| MOVZX qreg COMMA breg + { check_size ($1.sz1, X86BYTE) + ; check_size ($1.sz2, X86QUAD) + ; `X86MOVZX (X86S64, R_rm ($2, Reg (IReg $4.reg)), X86S8 $4.high) + } +| MOVZX lreg COMMA wreg + { check_size ($1.sz1, X86WORD) + ; check_size ($1.sz2, X86LONG) + ; `X86MOVZX (X86S32, R_rm ($2, Reg $4), X86S16) + } +| MOVZX qreg COMMA wreg + { check_size ($1.sz1, X86WORD) + ; check_size ($1.sz2, X86QUAD) + ; `X86MOVZX (X86S64, R_rm ($2, Reg $4), X86S16) + } +| MOVZX wreg COMMA addr + { check_size ($1.sz2, X86WORD) + ; `X86MOVZX (X86S16, R_rm ($2, $4), suffix_size $1.sz1) (* XXX size *) + } +| MOVZX lreg COMMA addr + { check_size ($1.sz2, X86LONG) + ; `X86MOVZX (X86S32, R_rm ($2, $4), suffix_size $1.sz1) + } +| MOVZX qreg COMMA addr + { check_size ($1.sz2, X86QUAD) + ; `X86MOVZX (X86S64, R_rm ($2, $4), suffix_size $1.sz1) + } +| MUL addr + { `X86MUL (suffix_size $1.sz, $2) } +| MUL breg + { check_size ($1.sz, X86BYTE) + ; `X86MUL (X86S8 ($2.high), Reg (IReg $2.reg)) + } +| MUL wreg + { check_size ($1.sz, X86WORD) + ; `X86MUL (X86S16, Reg $2) + } +| MUL lreg + { check_size ($1.sz, X86LONG) + ; `X86MUL (X86S32, Reg $2) + } +| MUL qreg + { check_size ($1.sz, X86QUAD) + ; `X86MUL (X86S64, Reg $2) + } +| NOP + { `X86NOP } +| POP qreg + { `X86POP (Reg $2) } +| POP addr + { `X86POP $2 } +| PUSH big_imm + { `X86PUSH (Imm $2) } +| PUSH addr + { `X86PUSH (Rm $2) } +| PUSH qreg + { `X86PUSH (Rm (Reg $2)) } +| RET big_imm + { `X86RET $2 } +| SET breg + { `X86SET ($1.cond, $2.high, Reg (IReg $2.reg)) } +| SET addr + { `X86SET ($1.cond, false, $2) } +| STC + { `X86STC } +| XADD breg COMMA breg + { check_size ($1.sz, X86BYTE) + ; check_byte_regs ($2, $4) + ; `X86XADD (false, X86S8 ($2.high), Reg (IReg $2.reg), (IReg $4.reg)) + } +| XADD addr COMMA breg + { check_size ($1.sz, X86BYTE) + ; `X86XADD (false, X86S8 ($4.high), $2, (IReg $4.reg)) + } +| LOCK XADD addr COMMA breg + { check_size ($2.sz, X86BYTE) + ; `X86XADD (true, X86S8 ($5.high), $3, (IReg $5.reg)) + } +| XADD wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86XADD (false, X86S16, Reg $2, $4) + } +| XADD addr COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86XADD (false, X86S16, $2, $4) + } +| LOCK XADD addr COMMA wreg + { check_size ($2.sz, X86WORD) + ; `X86XADD (true, X86S16, $3, $5) + } +| XADD lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86XADD (false, X86S32, Reg $2, $4) + } +| XADD addr COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86XADD (false, X86S32, $2, $4) + } +| LOCK XADD addr COMMA lreg + { check_size ($2.sz, X86LONG) + ; `X86XADD (true, X86S32, $3, $5) + } +| XADD qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86XADD (false, X86S64, Reg $2, $4) + } +| XADD addr COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86XADD (false, X86S64, $2, $4) + } +| LOCK XADD addr COMMA qreg + { check_size ($2.sz, X86QUAD) + ; `X86XADD (true, X86S64, $3, $5) + } +| XCHG breg COMMA breg + { check_size ($1.sz, X86BYTE) + ; check_byte_regs ($2, $4) + ; `X86XCHG (false, X86S8 ($2.high), Reg (IReg $2.reg), IReg $4.reg) + } +| XCHG addr COMMA breg + { check_size ($1.sz, X86BYTE) + ; `X86XCHG (false, X86S8 ($4.high), $2, (IReg $4.reg)) + } +| LOCK XCHG addr COMMA breg + { check_size ($2.sz, X86BYTE) + ; `X86XCHG (true, X86S8 ($5.high), $3, (IReg $5.reg)) + } +| XCHG wreg COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86XCHG (false, X86S16, Reg $2, $4) + } +| XCHG addr COMMA wreg + { check_size ($1.sz, X86WORD) + ; `X86XCHG (false, X86S16, $2, $4) + } +| LOCK XCHG addr COMMA wreg + { check_size ($2.sz, X86WORD) + ; `X86XCHG (true, X86S16, $3, $5) + } +| XCHG lreg COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86XCHG (false, X86S32, Reg $2, $4) + } +| XCHG addr COMMA lreg + { check_size ($1.sz, X86LONG) + ; `X86XCHG (false, X86S32, $2, $4) + } +| LOCK XCHG addr COMMA lreg + { check_size ($2.sz, X86LONG) + ; `X86XCHG (true, X86S32, $3, $5) + } +| XCHG qreg COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86XCHG (false, X86S64, Reg $2, $4) + } +| XCHG addr COMMA qreg + { check_size ($1.sz, X86QUAD) + ; `X86XCHG (false, X86S64, $2, $4) + } +| LOCK XCHG addr COMMA qreg + { check_size ($2.sz, X86QUAD) + ; `X86XCHG (true, X86S64, $3, $5) + } diff --git a/x86/gen/pretty.hgen b/x86/gen/pretty.hgen new file mode 100644 index 00000000..fc0c59d4 --- /dev/null +++ b/x86/gen/pretty.hgen @@ -0,0 +1,50 @@ +| `X86BINOP (locked, bop, sz, dst_src) -> + pp_locked locked ^ pp_x86Binop bop ^ pp_x86Size sz ^ " " ^ pp_x86Dest_src (sz, dst_src) +| `X86BITOP (locked, bop, sz, bo) -> + pp_locked locked ^ pp_x86Bitop bop ^ pp_x86Size sz ^ " " ^ pp_x86Bit_offset (sz, bo) +| `X86CALL (Imm i) -> "call " ^ " $" ^ bit64_to_string i +| `X86CALL (Rm rm) -> "call " ^ pp_x86Rm (X86S64, rm) +| `X86CLC -> "clc" +| `X86CMC -> "cmc" +| `X86CMPXCHG (locked, sz, rm, r) -> + sprintf "%scmpxchg%s %s, %s" + (pp_locked locked) (pp_x86Size sz) (pp_size_reg sz r) (pp_x86Rm (sz, rm)) +| `X86DIV (sz, rm) -> "div" ^ pp_x86Size sz ^ " " ^ pp_x86Rm (sz, rm) +| `X86JCC (X86ALWAYS, i) -> "jmp " ^ bit64_to_string i +| `X86JCC (cnd, i) -> "j" ^ pp_x86Cond cnd ^ " " ^ bit64_to_string i +| `X86JMP (rm) -> "jmp " ^ pp_x86Rm(X86S64, rm) +| `X86LEA (sz, dst_src) -> + "lea" ^ (pp_x86Size sz) ^ " " ^ pp_x86Dest_src (sz, dst_src) +| `X86LEAVE -> "leave" +| `X86LOOP (cnd, i) -> "loop" ^ pp_x86Cond cnd ^ " " ^ bit64_to_string i +| `X86MFENCE -> "mfence" +| `X86MONOP (locked, mop, sz, rm) -> + pp_x86Monop mop ^ pp_x86Size sz ^ " " ^ pp_x86Rm (sz, rm) +| `X86MOV (X86ALWAYS, sz, dst_src) -> + "mov" ^ pp_x86Size sz ^ " " ^ pp_x86Dest_src (sz, dst_src) +| `X86MOV (cnd, sz, dst_src) -> + "cmov" ^ pp_x86Cond cnd ^ pp_x86Size sz ^ " " ^ pp_x86Dest_src (sz, dst_src) +| `X86MOVSX (sz1, R_rm (r, rm), sz2) -> + "movs" ^ pp_x86Size sz1 ^ pp_x86Size sz2 ^ " " ^ pp_x86Rm (sz1, rm) ^ + ", " ^ pp_size_reg sz2 r +| `X86MOVSX (sz1, _, sz2) -> failwith "bad movsx instruction" +| `X86MOVZX (sz1, R_rm (r, rm), sz2) -> + "movz" ^ pp_x86Size sz1 ^ pp_x86Size sz2 ^ " " ^ pp_x86Rm (sz1, rm) ^ + ", " ^ pp_size_reg sz2 r +| `X86MOVZX (sz1, _, sz2) -> failwith "bad movzx instruction" +| `X86MUL (sz, rm) -> "mul" ^ pp_x86Size sz ^ " " ^ pp_x86Rm (sz, rm) +| `X86NOP -> "nop" +| `X86POP rm -> "pop " ^ (pp_x86Rm (X86S64, rm)) +| `X86PUSH (Imm i) -> "push $" ^ bit64_to_string i +| `X86PUSH (Rm rm) -> "push " ^ pp_x86Rm (X86S64, rm) +| `X86RET i -> "ret " ^ bit64_to_string i +| `X86SET (cnd, b, rm) -> "set" ^ pp_x86Cond cnd ^ " " ^ pp_x86Rm (X86S8 b, rm) +| `X86STC -> "stc" +| `X86XADD (locked, sz, rm, r) -> + sprintf "%s xadd%s %s, %s" + (pp_locked locked) (pp_x86Size sz) (pp_size_reg sz r) (pp_x86Rm (sz, rm)) +| `X86XCHG (locked, sz, rm, r) -> + sprintf "%sxchg%s %s, %s" + (pp_locked locked) (pp_x86Size sz) (pp_size_reg sz r) (pp_x86Rm (sz, rm)) +| `X86ThreadStart -> "start" +| `X86StopFetching -> "hlt" diff --git a/x86/gen/sail_trans_out.hgen b/x86/gen/sail_trans_out.hgen new file mode 100644 index 00000000..948db8fa --- /dev/null +++ b/x86/gen/sail_trans_out.hgen @@ -0,0 +1 @@ +(* *) diff --git a/x86/gen/shallow_ast_to_herdtools_ast.hgen b/x86/gen/shallow_ast_to_herdtools_ast.hgen new file mode 100644 index 00000000..ed5d6680 --- /dev/null +++ b/x86/gen/shallow_ast_to_herdtools_ast.hgen @@ -0,0 +1,27 @@ +| Binop (locked, binop, sz, dest_src) -> `X86BINOP (translate_out_bool locked, translate_out_binop binop, translate_out_size sz, translate_out_dest_src dest_src) +| Bitop (locked, bitop, sz, bo) -> `X86BITOP (translate_out_bool locked, translate_out_bitop bitop, translate_out_size sz, translate_out_bitoffset bo) +| CALL (imm_rm) -> `X86CALL (translate_out_imm_rm imm_rm) +| CLC -> `X86CLC +| CMC -> `X86CMC +| CMPXCHG (locked, sz, rm , reg) -> `X86CMPXCHG (translate_out_bool locked, translate_out_size sz, translate_out_rm rm, translate_out_reg reg) +| X86_DIV (sz, rm) -> `X86DIV (translate_out_size sz, translate_out_rm rm) +| HLT -> `X86StopFetching +| Jcc (cond, imm64) -> `X86JCC (translate_out_cond cond, translate_out_imm64 imm64) +| JMP (rm) -> `X86JMP (translate_out_rm rm) +| LEA (sz, dest_src) -> `X86LEA (translate_out_size sz, translate_out_dest_src dest_src) +| LEAVE -> `X86LEAVE +| LOOP (cond, imm64) -> `X86LOOP (translate_out_cond cond, translate_out_imm64 imm64) +| MFENCE -> `X86MFENCE +| Monop (locked, monop, sz, rm) -> `X86MONOP (translate_out_bool locked, translate_out_monop monop, translate_out_size sz, translate_out_rm rm) +| MOV (cond, sz, dest_src) -> `X86MOV (translate_out_cond cond, translate_out_size sz, translate_out_dest_src dest_src) +| MOVSX (sz1, dest_src, sz2) -> `X86MOVSX (translate_out_size sz1, translate_out_dest_src dest_src, translate_out_size sz2) +| MOVZX (sz1, dest_src, sz2) -> `X86MOVZX (translate_out_size sz1, translate_out_dest_src dest_src, translate_out_size sz2) +| X86_MUL (sz, rm) -> `X86MUL (translate_out_size sz, translate_out_rm rm) +| NOP (_) -> `X86NOP +| POP (rm) -> `X86POP (translate_out_rm rm) +| PUSH (imm_rm) -> `X86PUSH (translate_out_imm_rm imm_rm) +| RET (imm64) -> `X86RET (translate_out_imm64 imm64) +| SET (cond, b, rm) -> `X86SET (translate_out_cond cond, translate_out_bool b, translate_out_rm rm) +| STC -> `X86STC +| XADD (locked, sz, rm, reg) -> `X86XADD (translate_out_bool locked, translate_out_size sz, translate_out_rm rm, translate_out_reg reg) +| XCHG (locked, sz, rm, reg) -> `X86XCHG (translate_out_bool locked, translate_out_size sz, translate_out_rm rm, translate_out_reg reg) diff --git a/x86/gen/shallow_types_to_herdtools_types.hgen b/x86/gen/shallow_types_to_herdtools_types.hgen new file mode 100644 index 00000000..ba4eccaa --- /dev/null +++ b/x86/gen/shallow_types_to_herdtools_types.hgen @@ -0,0 +1,97 @@ +let is_inc = false + +let translate_out_bool = function + | Sail_values.B1 -> true + | Sail_values.B0 -> false + | _ -> failwith "translate_out_bool Undef" + +let translate_out_binop = function + | X86_Add -> X86ADD + | X86_Or -> X86OR + | X86_Adc -> X86ADC + | X86_Sbb -> X86SBB + | X86_And -> X86AND + | X86_Sub -> X86SUB + | X86_Xor -> X86XOR + | X86_Cmp -> X86CMP + | X86_Rol -> X86ROL + | X86_Ror -> X86ROR + | X86_Rcl -> X86RCL + | X86_Rcr -> X86RCR + | X86_Shl -> X86SHL + | X86_Shr -> X86SHR + | X86_Test -> X86TEST + | X86_Sar -> X86SAR + +let translate_out_bitop = function + | Btc -> X86Btc + | Bts -> X86Bts + | Btr -> X86Btr + +let translate_out_size = function + | Sz8 (high) -> X86S8 (translate_out_bool high) + | Sz16 -> X86S16 + | Sz32 -> X86S32 + | Sz64 -> X86S64 + +let translate_out_big_bit = Sail_values.unsigned + +let translate_out_int inst = (Nat_big_num.to_int (translate_out_big_bit inst)) + +let translate_out_reg r = IReg (int_to_ireg (Nat_big_num.to_int r)) + +let translate_out_scale = translate_out_int + +let translate_out_imm64 i = translate_out_big_bit i + +let translate_out_msi = function + | Some (scale, reg) -> Some (translate_out_scale scale, translate_out_reg reg) + | None -> None + +let translate_out_base = function + | X86_embed_types.NoBase -> X86HGenBase.NoBase + | X86_embed_types.RegBase(r) -> X86HGenBase.RegBase (translate_out_reg r) + | X86_embed_types.RipBase -> X86HGenBase.RipBase + +let translate_out_rm = function + | X86_embed_types.X86_Reg (r) -> X86HGenBase.Reg (translate_out_reg r) + | X86_embed_types.Mem (m_si, base, imm) -> X86HGenBase.Mem (translate_out_msi m_si, translate_out_base base, translate_out_imm64 imm) + +let translate_out_dest_src = function + | X86_embed_types.R_rm (reg, rm) -> X86HGenBase.R_rm (translate_out_reg reg, translate_out_rm rm) + | X86_embed_types.Rm_i (rm, imm64) -> X86HGenBase.Rm_i (translate_out_rm rm, translate_out_imm64 imm64) + | X86_embed_types.Rm_r (rm, reg) -> X86HGenBase.Rm_r (translate_out_rm rm, translate_out_reg reg) + +let translate_out_imm_rm = function + | X86_embed_types.Imm (imm) -> X86HGenBase.Imm (translate_out_imm64 imm) + | X86_embed_types.Rm (rm) -> X86HGenBase.Rm (translate_out_rm rm) + +let translate_out_bitoffset = function + | Bit_rm_imm (rm, imm) -> X86HGenBase.Bit_rm_imm (translate_out_rm rm, Nat_big_num.to_int (translate_out_imm64 imm)) + | Bit_rm_r (rm, r) -> X86HGenBase.Bit_rm_r (translate_out_rm rm, translate_out_reg r) + +let translate_out_cond = function + | X86_O -> X86O + | X86_NO -> X86NO + | X86_B -> X86B + | X86_NB -> X86NB + | X86_E -> X86E + | X86_NE -> X86NE + | X86_NA -> X86NA + | X86_A -> X86A + | X86_S -> X86S + | X86_NS -> X86NS + | X86_P -> X86P + | X86_NP -> X86NP + | X86_L -> X86L + | X86_NL -> X86NL + | X86_NG -> X86NG + | X86_G -> X86G + | X86_ALWAYS -> X86ALWAYS + +let translate_out_monop = function + | X86_Dec -> X86DEC + | X86_Inc -> X86INC + | X86_Not -> X86NOT + | X86_Neg -> X86NEG + diff --git a/x86/gen/token_types.hgen b/x86/gen/token_types.hgen new file mode 100644 index 00000000..9485e544 --- /dev/null +++ b/x86/gen/token_types.hgen @@ -0,0 +1,29 @@ +type token_BINOP = { txt : string; op : x86Binop; sz : x86Suffix } +type token_BITOP = { txt : string; op : x86Bitop; sz : x86Suffix } +type token_CALL = { txt : string } +type token_CLC = { txt : string } +type token_CMC = { txt : string } +type token_CMOV = { txt : string; cond : x86Cond; sz : x86Suffix } +type token_CMPXCHG = { txt : string; sz : x86Suffix } +type token_DIV = { txt : string; sz : x86Suffix } +type token_JCC = { txt : string; cond : x86Cond } +type token_JMP = { txt : string } +type token_LEA = { txt : string; sz : x86Suffix } +type token_LEAVE = { txt : string } +type token_LOOP = { txt : string; cond : x86Cond } +type token_MFENCE = { txt : string; } +type token_MONOP = { txt : string; op : x86Monop; sz : x86Suffix } +type token_MOV = { txt : string; sz : x86Suffix } +type token_MOVABS = { txt : string } +type token_MOVSX = { txt : string; sz1 : x86Suffix; sz2 : x86Suffix } +type token_MOVZX = { txt : string; sz1 : x86Suffix; sz2 : x86Suffix } +type token_MUL = { txt : string; sz : x86Suffix } +type token_NOP = { txt : string } +type token_POP = { txt : string } +type token_PUSH = { txt : string } +type token_RET = { txt : string } +type token_SET = { txt : string; cond : x86Cond } +type token_STC = { txt : string } +type token_XADD = { txt : string; sz : x86Suffix } +type token_XCHG = { txt : string; sz : x86Suffix } + diff --git a/x86/gen/tokens.hgen b/x86/gen/tokens.hgen new file mode 100644 index 00000000..7aa5256f --- /dev/null +++ b/x86/gen/tokens.hgen @@ -0,0 +1,28 @@ +%token BINOP +%token BITOP +%token CALL +%token CLC +%token CMC +%token CMPXCHG +%token DIV +%token JCC +%token JMP +%token LEA +%token LEAVE +%token LOOP +%token MFENCE +%token MONOP +%token CMOV +%token MOV +%token MOVABS +%token MOVSX +%token MOVZX +%token MUL +%token NOP +%token POP +%token PUSH +%token RET +%token SET +%token STC +%token XADD +%token XCHG diff --git a/x86/gen/trans_sail.hgen b/x86/gen/trans_sail.hgen new file mode 100644 index 00000000..0fdfc803 --- /dev/null +++ b/x86/gen/trans_sail.hgen @@ -0,0 +1,28 @@ +(*| `X86BINOP(binop, sz, dest_src) -> ("Binop", [translate_binop binop; translate_size sz; translate_dest_src dest_src], []) +| `X86CALL (imm_rm) -> ("CALL", [translate_imm_rm imm_rm], []) +| `X86CLC -> ("CLC", [], []) +| `X86CMC -> ("CMC", [], []) +| `X86CMPXCHG (sz, rm , reg) -> ("CMPXCHG", [translate_size sz; translate_rm rm; translate_reg reg], []) +| `X86DIV (sz, rm) -> ("DIV", [translate_size sz; translate_rm rm], []) +| `X86StopFetching -> ("HLT", [], []) +| `X86JCC (cond, imm64) -> ("Jcc", [translate_cond cond; translate_imm64 imm64], []) +| `X86JMP (rm) -> ("JMP", [translate_rm rm], []) +| `X86LEA (sz, dest_src) -> ("LEA", [translate_size sz; translate_dest_src dest_src], []) +| `X86LEAVE -> ("LEAVE", [], []) +| `X86LOOP (cond, imm64) -> ("LOOP", [translate_cond cond; translate_imm64 imm64], []) +| `X86MFENCE -> ("MFENCE", [], []) +| `X86MONOP (monop, sz, rm) -> ("Monop", [translate_monop monop; translate_size sz; translate_rm rm], []) +| `X86MOV (cond, sz, dest_src) -> ("MOV", [translate_cond cond; translate_size sz; translate_dest_src dest_src], []) +| `X86MOVSX (sz1, dest_src, sz2) -> ("MOVSX", [translate_size sz1; translate_dest_src dest_src; translate_size sz2], []) +| `X86MOVZX (sz1, dest_src, sz2) -> ("MOVZX", [translate_size sz1; translate_dest_src dest_src; translate_size sz2], []) +| `X86MUL (sz, rm) -> ("MUL", [translate_size sz; translate_rm rm], []) +| `X86NOP -> ("NOP", [Nat_big_num.of_int 0], []) +| `X86POP (rm) -> ("POP", [translate_rm rm], []) +| `X86PUSH (imm_rm) -> ("PUSH", [translate_imm_rm imm_rm], []) +| `X86RET (imm64) -> ("RET", [translate_imm64 imm64], []) +| `X86SET (cond, b, rm) -> ("SET", [translate_cond cond; translate_bool b; translate_rm rm], []) +| `X86STC -> ("STC", [], []) +| `X86XADD (sz, rm, reg) -> ("XADD", [translate_size sz; translate_rm rm; translate_reg reg], []) +| `X86XCHG (sz, rm, reg) -> ("XCHG", [translate_size sz; translate_rm rm; translate_reg reg], []) + +*) \ No newline at end of file diff --git a/x86/gen/types.hgen b/x86/gen/types.hgen new file mode 100644 index 00000000..117f0f4d --- /dev/null +++ b/x86/gen/types.hgen @@ -0,0 +1,134 @@ +type bit2 = int +type bit64 = Nat_big_num.num +let bit64_of_int = Nat_big_num.of_int +let bit64_to_int = Nat_big_num.to_int +let bit64_to_string = Nat_big_num.to_string +let eq_bit64 = Nat_big_num.equal + +type x86Binop = +| X86ADD +| X86OR +| X86ADC +| X86SBB +| X86AND +| X86SUB +| X86XOR +| X86CMP +| X86ROL +| X86ROR +| X86RCL +| X86RCR +| X86SHL +| X86SHR +| X86TEST +| X86SAR + +let pp_x86Binop = function +| X86ADD -> "add" +| X86OR -> "or" +| X86ADC -> "adc" +| X86SBB -> "sbb" +| X86AND -> "and" +| X86SUB -> "sub" +| X86XOR -> "xor" +| X86CMP -> "cmp" +| X86ROL -> "rol" +| X86ROR -> "ror" +| X86RCL -> "rcl" +| X86RCR -> "rcr" +| X86SHL -> "shl" +| X86SHR -> "shr" +| X86TEST -> "test" +| X86SAR -> "sar" + +type x86Bitop = X86Bts | X86Btc | X86Btr + +let pp_x86Bitop = function +| X86Bts -> "bts" +| X86Btc -> "btc" +| X86Btr -> "btr" + +type x86Monop = +| X86DEC +| X86INC +| X86NOT +| X86NEG + +let pp_x86Monop = function +| X86DEC -> "dec" +| X86INC -> "inc" +| X86NOT -> "not" +| X86NEG -> "neg" + +type x86Cond = +| X86O +| X86NO +| X86B +| X86NB +| X86E +| X86NE +| X86NA +| X86A +| X86S +| X86NS +| X86P +| X86NP +| X86L +| X86NL +| X86NG +| X86G +| X86ALWAYS + +let pp_x86Cond = function +| X86O -> "o" +| X86NO -> "no" +| X86B -> "b" +| X86NB -> "nb" +| X86E -> "e" +| X86NE -> "ne" +| X86NA -> "na" +| X86A -> "a" +| X86S -> "s" +| X86NS -> "ns" +| X86P -> "p" +| X86NP -> "np" +| X86L -> "l" +| X86NL -> "nl" +| X86NG -> "ng" +| X86G -> "g" +| X86ALWAYS -> "" + +type x86Suffix = +| X86BYTE +| X86WORD +| X86LONG +| X86QUAD +| X86NONE + +let pp_x86Suffix = function +| X86BYTE -> "byte" +| X86WORD -> "word" +| X86LONG -> "long" +| X86QUAD -> "quad" +| X86NONE -> "" + +type x86Size = +| X86S8 of bool +| X86S16 +| X86S32 +| X86S64 + +let pp_x86Size = function +| X86S8(_) -> "b" +| X86S16 -> "w" +| X86S32 -> "l" +| X86S64 -> "q" + +let pp_locked l = if l then "lock " else "" + +let suffix_size = function +| X86BYTE -> X86S8 false +| X86WORD -> X86S16 +| X86LONG -> X86S32 +| X86QUAD -> X86S64 +| X86NONE -> X86S64 diff --git a/x86/gen/types_sail_trans_out.hgen b/x86/gen/types_sail_trans_out.hgen new file mode 100644 index 00000000..948db8fa --- /dev/null +++ b/x86/gen/types_sail_trans_out.hgen @@ -0,0 +1 @@ +(* *) diff --git a/x86/gen/types_trans_sail.hgen b/x86/gen/types_trans_sail.hgen new file mode 100644 index 00000000..f088db39 --- /dev/null +++ b/x86/gen/types_trans_sail.hgen @@ -0,0 +1,61 @@ +(*let translate_enum enum_values name value = + let rec bit_count n = + if n = 0 then 0 + else 1 + (bit_count (n lsr 1)) in + let rec find_index element = function + | h::tail -> if h = element then 0 else 1 + (find_index element tail) + | _ -> failwith "translate_enum could not find value" + in + let size = bit_count (List.length enum_values) in + let index = find_index value enum_values in + (name, Range0 (Some size), IInt.bit_list_of_integer size (Nat_big_num.of_int index)) + +let translate_binop = translate_enum [X86ADD ; X86OR ; X86ADC ; X86SBB ; X86AND ; X86SUB ; X86XOR ; X86CMP ; X86ROL ; X86ROR ; X86RCL ; X86RCR ; X86SHL ; X86SHR ; X86TEST; X86SAR] + +let translate_cond = translate_enum [X86O ; X86NO ; X86B ; X86NB ; X86E ; X86NE ; X86NA ; X86A ; X86S ; X86NS ; X86P ; X86NP ; X86L ; X86NL ; X86NG ; X86G ; X86ALWAYS ] + +let translate_monop = translate_enum [X86DEC; X86INC; X86NOT; X86NEG] + +let translate_bool value = + ("bool", Bit, [if value then Bitc_one else Bitc_zero]) + +let translate_size = function + | X86S8(high) -> ("Sz8", [translate_bool high], []) + | X86S16 -> ("Sz16", [], []) + | X86S32 -> ("Sz32", [], []) + | X86S64 -> ("Sz64", [], []) + +let translate_bits bits value = + ("bits", Bvector (Some bits), IInt.bit_list_of_integer bits (Nat_big_num.of_int value)) + +let translate_bits_big bits value = + ("bits", Bvector (Some bits), IInt.bit_list_of_integer bits value) + +let translate_reg r = translate_bits 4 (reg_to_int r) + +let translate_scale s = translate_bits 2 s + +let translate_imm64 i = translate_bits_big 64 i + +let translate_msi = function + | Some (scale, reg) -> ("Some", [translate_scale scale; translate_reg reg], []) + | None -> ("None", [], []) + +let translate_base = function + | X86HGenBase.NoBase -> ("NoBase", [], []) + | X86HGenBase.RegBase(r) -> ("RegBase", [translate_reg r], []) + | X86HGenBase.RipBase -> ("RipBase", [], []) + +let translate_rm = function + | X86HGenBase.Reg (r) -> ("Reg", [translate_reg r], []) + | X86HGenBase.Mem (m_si, base, imm) -> ("Mem", [translate_msi m_si; translate_base base; translate_imm64 imm], []) + +let translate_dest_src = function + | X86HGenBase.R_rm (reg, rm) -> ("R_rm", [translate_reg reg; translate_rm rm], []) + | X86HGenBase.Rm_i (rm, imm64) -> ("Rm_i", [translate_rm rm; translate_imm64 imm64], []) + | X86HGenBase.Rm_r (rm, reg) -> ("Rm_r", [translate_rm rm; translate_reg reg], []) + +let translate_imm_rm = function + | X86HGenBase.Imm (imm) -> ("Imm", [translate_imm64 imm], []) + | X86HGenBase.Rm (rm) -> ("Rm", [translate_rm rm], []) + *) diff --git a/x86/x86_extras.lem b/x86/x86_extras.lem new file mode 100644 index 00000000..d6498d87 --- /dev/null +++ b/x86/x86_extras.lem @@ -0,0 +1,53 @@ +open import Pervasives +open import Interp_ast +open import Interp_interface +open import Sail_impl_base +open import Interp_inter_imp +import Set_extra + +let memory_parameter_transformer mode v = + match v with + | Interp_ast.V_tuple [location;length] -> + let (v,loc_regs) = extern_with_track mode extern_vector_value location in + + match length with + | Interp_ast.V_lit (L_aux (L_num len) _) -> + (v,(natFromInteger len),loc_regs) + | Interp_ast.V_track (Interp_ast.V_lit (L_aux (L_num len) _)) size_regs -> + match loc_regs with + | Nothing -> (v,(natFromInteger len),Just (List.map (fun r -> extern_reg r Nothing) (Set_extra.toList size_regs))) + | Just loc_regs -> (v,(natFromInteger len),Just (loc_regs++(List.map (fun r -> extern_reg r Nothing) (Set_extra.toList size_regs)))) + end + | _ -> Assert_extra.failwith "expected 'V_lit (L_aux (L_num _) _)' or 'V_track (V_lit (L_aux (L_num len) _)) _'" + end + | _ -> Assert_extra.failwith ("memory_parameter_transformer: expected 'V_tuple [_;_]' given " ^ (Interp.string_of_value v)) + end + +let memory_parameter_transformer_option_address _mode v = + match v with + | Interp_ast.V_tuple [location;_] -> + Just (extern_vector_value location) + | _ -> Assert_extra.failwith ("memory_parameter_transformer_option_address: expected 'V_tuple [_;_]' given " ^ (Interp.string_of_value v)) + end + +let x86_read_memory_functions : memory_reads = + [ ("rMEM", (MR Read_plain memory_parameter_transformer)); + ("rMEM_locked", (MR Read_X86_locked memory_parameter_transformer)); + ] + +let x86_memory_writes : memory_writes = + [] + +let x86_memory_eas : memory_write_eas = + [ ("MEMea", (MEA Write_plain memory_parameter_transformer)); + ("MEMea_locked", (MEA Write_X86_locked memory_parameter_transformer)); + ] + +let x86_memory_vals : memory_write_vals = + [ ("MEMval", (MV memory_parameter_transformer_option_address Nothing)); + ] + +let x86_barrier_functions = + [ + ("X86_MFENCE", Barrier_x86_MFENCE); + ] diff --git a/x86/x86_extras_embed.lem b/x86/x86_extras_embed.lem new file mode 100644 index 00000000..f5130995 --- /dev/null +++ b/x86/x86_extras_embed.lem @@ -0,0 +1,24 @@ +open import Pervasives +open import Pervasives_extra +open import Sail_impl_base +open import Sail_values +open import Prompt + +val rMEM : (vector bitU * integer) -> M (vector bitU) +val rMEM_locked : (vector bitU * integer) -> M (vector bitU) + +let rMEM (addr,size) = read_mem false Read_plain addr size +let rMEM_locked (addr,size) = read_mem false Read_X86_locked addr size + +val MEMea : (vector bitU * integer) -> M unit +val MEMea_locked : (vector bitU * integer) -> M unit + +let MEMea (addr,size) = write_mem_ea Write_plain addr size +let MEMea_locked (addr,size) = write_mem_ea Write_X86_locked addr size + +val MEMval : (vector bitU * integer * vector bitU) -> M unit +val MEMval_conditional : (vector bitU * integer * vector bitU) -> M bitU + +let MEMval (_,_,v) = write_mem_val v >>= fun _ -> return () + +let X86_MFENCE () = barrier Barrier_x86_MFENCE diff --git a/x86/x86_extras_embed_sequential.lem b/x86/x86_extras_embed_sequential.lem new file mode 100644 index 00000000..2703b6c4 --- /dev/null +++ b/x86/x86_extras_embed_sequential.lem @@ -0,0 +1,24 @@ +open import Pervasives +open import Pervasives_extra +open import Sail_impl_base +open import Sail_values +open import State + +val rMEM : (vector bitU * integer) -> M (vector bitU) +val rMEM_locked : (vector bitU * integer) -> M (vector bitU) + +let rMEM (addr,size) = read_mem false Read_plain addr size +let rMEM_locked (addr,size) = read_mem false Read_X86_locked addr size + +val MEMea : (vector bitU * integer) -> M unit +val MEMea_locked : (vector bitU * integer) -> M unit + +let MEMea (addr,size) = write_mem_ea Write_plain addr size +let MEMea_locked (addr,size) = write_mem_ea Write_X86_locked addr size + +val MEMval : (vector bitU * integer * vector bitU) -> M unit +val MEMval_conditional : (vector bitU * integer * vector bitU) -> M bitU + +let MEMval (_,_,v) = write_mem_val v >>= fun _ -> return () + +let X86_MFENCE () = barrier Barrier_x86_MFENCE -- cgit v1.2.3 From dd00feacb373defbcfd8c50b9a8381c4a7db7cba Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 30 Nov 2017 19:35:35 +0000 Subject: Improvements to enable parsing and checking intermediate rewriting steps Parser now has syntax for mutual recusion blocks mutual { ... fundefs ... } which is used for parsing and pretty printing DEF_internal_mutrec. It's stripped away by the initial_check, so the typechecker never sees DEF_internal_mutrec. Maybe this could change, as forcing mutual recursion to be explicit would probably be a good thing. Added record syntax to the new parser New option -dmagic_hash is similar to GHC's -XMagicHash in that it allows for identifiers to contain the special hash character, which is used to introduce new autogenerated variables in a way that doesn't clash with existing names. Option -sil compiles sail down to the intermediate language defined in sil.ott (not complete yet). --- src/initial_check.ml | 33 ++++++++++++++++++++++++++++----- src/initial_check.mli | 1 + src/lexer2.mll | 6 +++++- src/parse_ast.ml | 3 ++- src/parser2.mly | 28 ++++++++++++++++++++++++++-- src/pretty_print_sail2.ml | 24 +++++++++++------------- src/process_file.ml | 1 + src/process_file.mli | 1 + src/rewrites.ml | 12 ++++++++++++ src/rewrites.mli | 3 +++ src/sail.ml | 12 ++++++++++++ 11 files changed, 102 insertions(+), 22 deletions(-) diff --git a/src/initial_check.ml b/src/initial_check.ml index de5b625b..2764c30b 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -46,6 +46,7 @@ open Ast_util open Big_int let opt_undefined_gen = ref false +let opt_magic_hash = ref false module Envmap = Finite_map.Fmap_map(String) module Nameset' = Set.Make(String) @@ -117,10 +118,21 @@ let typ_error l msg opt_id opt_var opt_kind = | None,None,Some(kind) -> " " ^ (kind_to_string kind) | _ -> ""))) -let to_ast_id (Parse_ast.Id_aux(id,l)) = - Id_aux( (match id with - | Parse_ast.Id(x) -> Id(x) - | Parse_ast.DeIid(x) -> DeIid(x)) , l) +let string_of_parse_id_aux = function + | Parse_ast.Id v -> v + | Parse_ast.DeIid v -> v + +let string_contains str char = + try (String.index str char; true) with + | Not_found -> false + +let to_ast_id (Parse_ast.Id_aux(id, l)) = + if string_contains (string_of_parse_id_aux id) '#' && not (!opt_magic_hash) + then typ_error l "Identifier contains hash character" None None None + else Id_aux ((match id with + | Parse_ast.Id(x) -> Id(x) + | Parse_ast.DeIid(x) -> DeIid(x)), + l) let to_ast_var (Parse_ast.Kid_aux(Parse_ast.Var v,l)) = Kid_aux(Var v,l) @@ -483,7 +495,10 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | Parse_ast.E_vector_append(e1,e2) -> E_vector_append(to_ast_exp k_env def_ord e1,to_ast_exp k_env def_ord e2) | Parse_ast.E_list(exps) -> E_list(List.map (to_ast_exp k_env def_ord) exps) | Parse_ast.E_cons(e1,e2) -> E_cons(to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2) - | Parse_ast.E_record _ -> raise (Reporting_basic.err_unreachable l "parser generated an E_record") + | Parse_ast.E_record fexps -> + (match to_ast_fexps true k_env def_ord fexps with + | Some fexps -> E_record fexps + | None -> raise (Reporting_basic.err_unreachable l "to_ast_fexps with true returned none")) | Parse_ast.E_record_update(exp,fexps) -> (match to_ast_fexps true k_env def_ord fexps with | Some(fexps) -> E_record_update(to_ast_exp k_env def_ord exp, fexps) @@ -886,7 +901,15 @@ let rec to_ast_defs_helper envs partial_defs = function then (fst !d) :: defs, envs, partial_defs else typ_error l "Scattered type definition never ended" (Some id) None None)) +let rec remove_mutrec = function + | [] -> [] + | Parse_ast.DEF_internal_mutrec fundefs :: defs -> + List.map (fun fdef -> Parse_ast.DEF_fundef fdef) fundefs @ remove_mutrec defs + | def :: defs -> + def :: remove_mutrec defs + let to_ast (default_names : Nameset.t) (kind_env : kind Envmap.t) (def_ord : order) (Parse_ast.Defs(defs)) = + let defs = remove_mutrec defs in let defs,(_,k_env,def_ord),partial_defs = to_ast_defs_helper (default_names,kind_env,def_ord) [] defs in List.iter (fun (id,(d,k)) -> diff --git a/src/initial_check.mli b/src/initial_check.mli index feb9cb83..cfbea3e1 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -44,6 +44,7 @@ open Ast open Ast_util val opt_undefined_gen : bool ref +val opt_magic_hash : bool ref val process_ast : order -> Parse_ast.defs -> unit defs diff --git a/src/lexer2.mll b/src/lexer2.mll index 40e7eec6..a8dbaaf3 100644 --- a/src/lexer2.mll +++ b/src/lexer2.mll @@ -121,6 +121,7 @@ let kw_table = ("in", (fun x -> In)); ("inc", (fun _ -> Inc)); ("let", (fun x -> Let_)); + ("record", (fun _ -> Record)); ("Int", (fun x -> Int)); ("Order", (fun x -> Order)); ("pure", (fun x -> Pure)); @@ -142,6 +143,7 @@ let kw_table = ("until", (fun _ -> Until)); ("while", (fun _ -> While)); ("do", (fun _ -> Do)); + ("mutual", (fun _ -> Mutual)); ("barr", (fun x -> Barr)); ("depend", (fun x -> Depend)); @@ -169,7 +171,7 @@ let binarydigit = ['0'-'1'] let hexdigit = ['0'-'9''A'-'F''a'-'f'] let alphanum = letter|digit let startident = letter|'_' -let ident = alphanum|['_''\''] +let ident = alphanum|['_''\'''#'] let tyvar_start = '\'' let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''@''^''|'] let operator = (oper_char+ ('_' ident)?) @@ -200,6 +202,8 @@ rule token = parse | ";" { Semi } | "*" { (Star(r"*")) } | "_" { Under } + | "[|" { LsquareBar } + | "|]" { RsquareBar } | "{|" { LcurlyBar } | "|}" { RcurlyBar } | "|" { Bar } diff --git a/src/parse_ast.ml b/src/parse_ast.ml index bdf56cc8..aceba3b6 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -275,7 +275,7 @@ exp_aux = (* Expression *) | E_vector_append of exp * exp (* vector concatenation *) | E_list of (exp) list (* list *) | E_cons of exp * exp (* cons *) - | E_record of fexps (* struct *) + | E_record of exp list (* struct *) | E_record_update of exp * (exp) list (* functional update of struct *) | E_field of exp * id (* field projection from struct *) | E_case of exp * (pexp) list (* pattern matching *) @@ -498,6 +498,7 @@ def = (* Top-level definition *) | DEF_default of default_typing_spec (* default kind and type assumptions *) | DEF_scattered of scattered_def (* scattered definition *) | DEF_reg_dec of dec_spec (* register declaration *) + | DEF_internal_mutrec of fundef list type diff --git a/src/parser2.mly b/src/parser2.mly index a752e5c1..1444f6cd 100644 --- a/src/parser2.mly +++ b/src/parser2.mly @@ -142,13 +142,13 @@ let rec desugar_rchain chain s e = %token Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef %token Undefined Union With Val Constraint Throw Try Catch Exit %token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape -%token Repeat Until While Do +%token Repeat Until While Do Record Mutual %nonassoc Then %nonassoc Else %token Bar Comma Dot Eof Minus Semi Under DotDot -%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar +%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar LsquareBar RsquareBar %token MinusGt /*Terminals with content*/ @@ -957,17 +957,33 @@ atomic_exp: { mk_exp (E_vector_access ($1, $3)) $startpos $endpos } | atomic_exp Lsquare exp DotDot exp Rsquare { mk_exp (E_vector_subrange ($1, $3, $5)) $startpos $endpos } + | Record Lcurly fexp_exp_list Rcurly + { mk_exp (E_record $3) $startpos $endpos } + | Lcurly exp With fexp_exp_list Rcurly + { mk_exp (E_record_update ($2, $4)) $startpos $endpos } | Lsquare exp_list Rsquare { mk_exp (E_vector $2) $startpos $endpos } | Lsquare exp With atomic_exp Eq exp Rsquare { mk_exp (E_vector_update ($2, $4, $6)) $startpos $endpos } | Lsquare exp With atomic_exp DotDot atomic_exp Eq exp Rsquare { mk_exp (E_vector_update_subrange ($2, $4, $6, $8)) $startpos $endpos } + | LsquareBar exp_list RsquareBar + { mk_exp (E_list $2) $startpos $endpos } | Lparen exp Rparen { $2 } | Lparen exp Comma exp_list Rparen { mk_exp (E_tuple ($2 :: $4)) $startpos $endpos } +fexp_exp: + | atomic_exp Eq exp + { mk_exp (E_app_infix ($1, mk_id (Id "=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + +fexp_exp_list: + | fexp_exp + { [$1] } + | fexp_exp Comma fexp_exp_list + { $1 :: $3 } + exp_list: | exp { [$1] } @@ -1042,6 +1058,12 @@ fun_def: | Function_ funcls { mk_fun (FD_function (mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } +fun_def_list: + | fun_def + { [$1] } + | fun_def fun_def_list + { $1 :: $2 } + let_def: | Let_ letbind { $2 } @@ -1115,6 +1137,8 @@ def: { DEF_scattered (mk_sd (SD_scattered_end $2) $startpos $endpos) } | default_def { DEF_default $1 } + | Mutual Lcurly fun_def_list Rcurly + { DEF_internal_mutrec $3 } defs_list: | def diff --git a/src/pretty_print_sail2.ml b/src/pretty_print_sail2.ml index 8c8b5661..8ebef0f0 100644 --- a/src/pretty_print_sail2.ml +++ b/src/pretty_print_sail2.ml @@ -183,12 +183,13 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = group (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp; string "else"; doc_exp else_exp]) | E_list exps -> string "[|" ^^ separate_map (comma ^^ space) doc_exp exps ^^ string "|]" | E_cons (exp1, exp2) -> string "E_cons" - | E_record fexps -> string "E_record" + | E_record fexps -> separate space [string "record"; string "{"; doc_fexps fexps; string "}"] | E_loop (While, cond, exp) -> separate space [string "while"; doc_exp cond; string "do"; doc_exp exp] | E_loop (Until, cond, exp) -> separate space [string "repeat"; doc_exp exp; string "until"; doc_exp cond] - | E_record_update (exp, fexps) -> string "E_record_update" + | E_record_update (exp, fexps) -> + separate space [string "{"; doc_exp exp; string "with"; doc_fexps fexps; string "}"] | E_vector_append (exp1, exp2) -> separate space [doc_atomic_exp exp1; string "@"; doc_atomic_exp exp2] | E_case (exp, pexps) -> separate space [string "match"; doc_exp exp; doc_pexps pexps] @@ -245,6 +246,10 @@ and doc_atomic_exp (E_aux (e_aux, _) as exp) = | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; string ".."; doc_atomic_exp exp3; equals; doc_exp exp4]) | _ -> parens (doc_exp exp) +and doc_fexps (FES_aux (FES_Fexps (fexps, _), _)) = + separate_map (comma ^^ space) doc_fexp fexps +and doc_fexp (FE_aux (FE_Fexp (id, exp), _)) = + separate space [doc_id id; equals; doc_exp exp] and doc_block = function | [] -> string "()" | [E_aux (E_let (LB_aux (LB_val (pat, binding), _), E_aux (E_block exps, _)), _)] -> @@ -336,17 +341,7 @@ let doc_spec (VS_aux(v,_)) = let doc_backend b = Util.option_map (fun id -> string (b ^ ":") ^^ space ^^ utf8string ("\"" ^ String.escaped id ^ "\"")) (ext b) in let docs = Util.option_these (List.map doc_backend ["ocaml"; "lem"]) in - if docs = [] then empty else braces (separate (comma ^^ space) docs) - (* function - | Some s -> - let ext_for backend = utf8string ("\"" ^ String.escaped (s backend) ^ "\"") in - let extern = - if s "ocaml" = s "lem" - then ext_for "ocaml" - else separate space [lbrace; string "ocaml:"; ext_for "ocaml"; string "lem:"; ext_for "lem"; rbrace] - in - equals ^^ space ^^ extern ^^ space - | None -> empty *) + if docs = [] then empty else equals ^^ space ^^ braces (separate (comma ^^ space) docs) in match v with | VS_val_spec(ts,id,ext,is_cast) -> @@ -382,6 +377,9 @@ let rec doc_def def = group (match def with | DEF_kind k_def -> doc_kind_def k_def | DEF_fundef f_def -> doc_fundef f_def | DEF_val lbind -> string "let" ^^ space ^^ doc_letbind lbind + | DEF_internal_mutrec fundefs -> + (string "mutual {" ^//^ separate_map (hardline ^^ hardline) doc_fundef fundefs) + ^^ hardline ^^ string "}" | DEF_reg_dec dec -> doc_dec dec | DEF_scattered sdef -> doc_scattered sdef | DEF_fixity (prec, n, id) -> diff --git a/src/process_file.ml b/src/process_file.ml index 92b3f328..75e3092f 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -229,4 +229,5 @@ let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)] let rewrite_undefined = rewrite [("undefined", fun x -> Rewrites.rewrite_undefined !opt_lem_mwords x)] let rewrite_ast_lem = rewrite Rewrites.rewrite_defs_lem let rewrite_ast_ocaml = rewrite Rewrites.rewrite_defs_ocaml +let rewrite_ast_sil = rewrite Rewrites.rewrite_defs_sil let rewrite_ast_check = rewrite Rewrites.rewrite_defs_check diff --git a/src/process_file.mli b/src/process_file.mli index b575bd14..116df06e 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -48,6 +48,7 @@ val rewrite_ast: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_undefined: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_lem : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_ocaml : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_sil : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_check : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val load_file_no_check : Ast.order -> string -> unit Ast.defs diff --git a/src/rewrites.ml b/src/rewrites.ml index 13d811e4..80e09e9a 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2757,6 +2757,18 @@ let rewrite_defs_ocaml = [ (* ("separate_numbs", rewrite_defs_separate_numbs) *) ] +let rewrite_defs_sil = [ + ("top_sort_defs", top_sort_defs); + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + ("simple_assignments", rewrite_simple_assignments); + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); + ] + let rewrite_check_annot = let check_annot exp = try diff --git a/src/rewrites.mli b/src/rewrites.mli index 628296ec..432a2bd8 100644 --- a/src/rewrites.mli +++ b/src/rewrites.mli @@ -53,6 +53,9 @@ val rewrite_defs_ocaml : (string * (tannot defs -> tannot defs)) list (* Perform rewrites to exclude AST nodes not supported for lem out*) val rewrite_defs_lem : (string * (tannot defs -> tannot defs)) list +(* Perform rewrites to sail intermediate language *) +val rewrite_defs_sil : (string * (tannot defs -> tannot defs)) list + (* This is a special rewriter pass that checks AST invariants without actually doing any re-writing *) val rewrite_defs_check : (string * (tannot defs -> tannot defs)) list diff --git a/src/sail.ml b/src/sail.ml index e7e965ba..dbd95f1d 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -49,6 +49,7 @@ let opt_print_initial_env = ref false let opt_print_verbose = ref false let opt_print_lem_ast = ref false let opt_print_lem = ref false +let opt_print_sil = ref false let opt_print_ocaml = ref false let opt_convert = ref false let opt_memo_z3 = ref false @@ -74,6 +75,9 @@ let options = Arg.align ([ ( "-lem_ast", Arg.Set opt_print_lem_ast, " output a Lem AST representation of the input"); + ( "-sil", + Arg.Tuple [Arg.Set opt_print_sil; Arg.Set Initial_check.opt_undefined_gen], + " output a SIL translated version of the input"); ( "-lem", Arg.Set opt_print_lem, " output a Lem translated version of the input"); @@ -138,6 +142,9 @@ let options = Arg.align ([ ( "-dsanity", Arg.Set opt_sanity, " (debug) sanity check the AST (slow)"); + ( "-dmagic_hash", + Arg.Set Initial_check.opt_magic_hash, + " (debug) allow special character # in identifiers"); ( "-v", Arg.Set opt_print_version, " print version"); @@ -204,6 +211,11 @@ let main() = (if !(opt_print_lem_ast) then output "" Lem_ast_out [out_name,ast] else ()); + (if !(opt_print_sil) + then + let ast = rewrite_ast_sil ast in + Pretty_print_sail2.pp_defs stdout ast + else ()); (if !(opt_print_ocaml) then let ast_ocaml = rewrite_ast_ocaml ast in -- cgit v1.2.3 From ff514f618bc64980e08d201ec971ccf38421e586 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 30 Nov 2017 20:33:07 +0000 Subject: Use doc_typdef_lem from experiments --- src/pretty_print_lem.ml | 80 ++++++++++++++++++++++++++----------------------- 1 file changed, 42 insertions(+), 38 deletions(-) diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index ef91c684..4b0091bd 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -1294,9 +1294,9 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with (concat [string "type"; space; doc_id_lem_type id; space; doc_typquant_items_lem None typq]) ((*doc_typquant_lem typq*) ar_doc) in let make_id pat id = - separate space [string "Interp_ast.Id_aux"; - parens (string "Interp_ast.Id " ^^ string_lit (doc_id id)); - if pat then underscore else string "Interp_ast.Unknown"] in + separate space [string "SIA.Id_aux"; + parens (string "SIA.Id " ^^ string_lit (doc_id id)); + if pat then underscore else string "SIA.Unknown"] in let fromInterpValueF = concat [doc_id_lem_type id;string "FromInterpValue"] in let toInterpValueF = concat [doc_id_lem_type id;string "ToInterpValue"] in let fromInterpValuePP = @@ -1308,18 +1308,18 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with match tu with | Tu_ty_id (ty,cid) -> (separate space) - [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow; doc_id_lem_ctor cid; parens (string "fromInterpValue v")] | Tu_id cid -> (separate space) - [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow; doc_id_lem_ctor cid]) ar) ^/^ - ((separate space) [pipe;string "Interp_ast.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ + ((separate space) [pipe;string "SI.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ let failmessage = (string_lit @@ -1338,40 +1338,43 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with | Tu_ty_id (ty,cid) -> (separate space) [pipe;doc_id_lem_ctor cid;string "v";arrow; - string "Interp_ast.V_ctor"; + string "SI.V_ctor"; parens (make_id false cid); - parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); - string "Interp_ast.C_Union"; + parens (string "SIA.T_id " ^^ string_lit (doc_id id)); + string "SI.C_Union"; parens (string "toInterpValue v")] | Tu_id cid -> (separate space) [pipe;doc_id_lem_ctor cid;arrow; - string "Interp_ast.V_ctor"; + string "SI.V_ctor"; parens (make_id false cid); - parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); - string "Interp_ast.C_Union"; + parens (string "SIA.T_id " ^^ string_lit (doc_id id)); + string "SI.C_Union"; parens (string "toInterpValue ()")]) ar) ^/^ string "end") in let fromToInterpValuePP = - toInterpValuePP ^^ hardline ^^ hardline ^^ - fromInterpValuePP ^^ hardline ^^ hardline ^^ ((prefix 2 1) (concat [string "instance ";parens (string "ToFromInterpValue " ^^ doc_id_lem_type id)]) (concat [string "let toInterpValue = ";toInterpValueF;hardline; string "let fromInterpValue = ";fromInterpValueF])) ^/^ string "end" in - (typ_pp ^^ hardline,fromToInterpValuePP ^^ hardline)) + typ_pp ^^ hardline ^^ hardline ^^ + if !print_to_from_interp_value then + toInterpValuePP ^^ hardline ^^ hardline ^^ + fromInterpValuePP ^^ hardline ^^ hardline ^^ + fromToInterpValuePP ^^ hardline + else empty) | TD_enum(id,nm,enums,_) -> (match id with - | Id_aux ((Id "read_kind"),_) -> (empty,empty) - | Id_aux ((Id "write_kind"),_) -> (empty,empty) - | Id_aux ((Id "barrier_kind"),_) -> (empty,empty) - | Id_aux ((Id "trans_kind"),_) -> (empty,empty) - | Id_aux ((Id "instruction_kind"),_) -> (empty,empty) - | Id_aux ((Id "regfp"),_) -> (empty,empty) - | Id_aux ((Id "niafp"),_) -> (empty,empty) - | Id_aux ((Id "diafp"),_) -> (empty,empty) + | Id_aux ((Id "read_kind"),_) -> empty + | Id_aux ((Id "write_kind"),_) -> empty + | Id_aux ((Id "barrier_kind"),_) -> empty + | Id_aux ((Id "trans_kind"),_) -> empty + | Id_aux ((Id "instruction_kind"),_) -> empty + | Id_aux ((Id "regfp"),_) -> empty + | Id_aux ((Id "niafp"),_) -> empty + | Id_aux ((Id "diafp"),_) -> empty | _ -> let rec range i j = if i > j then [] else i :: (range (i+1) j) in let nats = range 0 in @@ -1382,9 +1385,9 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with let fromInterpValueF = concat [doc_id_lem_type id;string "FromInterpValue"] in let toInterpValueF = concat [doc_id_lem_type id;string "ToInterpValue"] in let make_id pat id = - separate space [string "Interp_ast.Id_aux"; - parens (string "Interp_ast.Id " ^^ string_lit (doc_id id)); - if pat then underscore else string "Interp_ast.Unknown"] in + separate space [string "SIA.Id_aux"; + parens (string "SIA.Id " ^^ string_lit (doc_id id)); + if pat then underscore else string "SIA.Unknown"] in let fromInterpValuePP = (prefix 2 1) (separate space [string "let rec";fromInterpValueF;string "v";equals;string "match v with"]) @@ -1392,7 +1395,7 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with ((separate_map (break 1)) (fun (cid) -> (separate space) - [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow;doc_id_lem_ctor cid] ) enums @@ -1400,7 +1403,7 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with ( (align ((prefix 3 1) - (separate space [pipe;string ("Interp_ast.V_lit (Interp_ast.L_aux (Interp_ast.L_num n) _)");arrow]) + (separate space [pipe;string ("SI.V_lit (SIA.L_aux (SIA.L_num n) _)");arrow]) (separate space [string "match";parens(string "natFromInteger n");string "with"] ^/^ ( ((separate_map (break 1)) @@ -1416,7 +1419,7 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with ) ) ^/^ - ((separate space) [pipe;string "Interp_ast.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ + ((separate space) [pipe;string "SI.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ let failmessage = (string_lit @@ -1434,25 +1437,27 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with (fun (cid,number) -> (separate space) [pipe;doc_id_lem_ctor cid;arrow; - string "Interp_ast.V_ctor"; + string "SI.V_ctor"; parens (make_id false cid); - parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); - parens (string ("Interp_ast.C_Enum " ^ string_of_int number)); + parens (string "SIA.T_id " ^^ string_lit (doc_id id)); + parens (string ("SI.C_Enum " ^ string_of_int number)); parens (string "toInterpValue ()")]) (List.combine enums (nats ((List.length enums) - 1)))) ^/^ string "end") in let fromToInterpValuePP = - toInterpValuePP ^^ hardline ^^ hardline ^^ - fromInterpValuePP ^^ hardline ^^ hardline ^^ ((prefix 2 1) (concat [string "instance ";parens (string "ToFromInterpValue " ^^ doc_id_lem_type id)]) (concat [string "let toInterpValue = ";toInterpValueF;hardline; string "let fromInterpValue = ";fromInterpValueF])) ^/^ string "end" in - (typ_pp ^^ hardline, - fromToInterpValuePP ^^ hardline)) + typ_pp ^^ hardline ^^ hardline ^^ + if !print_to_from_interp_value + then toInterpValuePP ^^ hardline ^^ hardline ^^ + fromInterpValuePP ^^ hardline ^^ hardline ^^ + fromToInterpValuePP ^^ hardline + else empty) | TD_register(id,n1,n2,rs) -> - match n1,n2 with + match n1, n2 with | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> let dir_b = i1 < i2 in let dir = (if dir_b then "true" else "false") in @@ -1533,7 +1538,6 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with separate_map hardline doc_field rs*) | _ -> raise (Reporting_basic.err_unreachable l "register with non-constant indices") - let doc_rec_lem (Rec_aux(r,_)) = match r with | Rec_nonrec -> space | Rec_rec -> space ^^ string "rec" ^^ space -- cgit v1.2.3 From 748318f8af7b82a01bb151f1bfcb466d0fc8291f Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Mon, 4 Dec 2017 14:47:38 +0000 Subject: renamed hgen to gen --- etc/power_header | 30 ++++ mips/gen/ast.hgen | 18 ++ mips/gen/fold.hgen | 19 ++ mips/gen/herdtools_ast_to_shallow_ast.hgen | 121 +++++++++++++ mips/gen/herdtools_types_to_shallow_types.hgen | 120 +++++++++++++ mips/gen/lexer.hgen | 116 ++++++++++++ mips/gen/map.hgen | 19 ++ mips/gen/parser.hgen | 34 ++++ mips/gen/pretty.hgen | 36 ++++ mips/gen/sail_trans_out.hgen | 98 ++++++++++ mips/gen/shallow_ast_to_herdtools_ast.hgen | 98 ++++++++++ mips/gen/shallow_types_to_herdtools_types.hgen | 39 ++++ mips/gen/token_types.hgen | 39 ++++ mips/gen/tokens.hgen | 17 ++ mips/gen/trans_sail.hgen | 122 +++++++++++++ mips/gen/types.hgen | 209 ++++++++++++++++++++++ mips/gen/types_sail_trans_out.hgen | 47 +++++ mips/gen/types_trans_sail.hgen | 44 +++++ mips/hgen/ast.hgen | 18 -- mips/hgen/fold.hgen | 19 -- mips/hgen/herdtools_ast_to_shallow_ast.hgen | 121 ------------- mips/hgen/herdtools_types_to_shallow_types.hgen | 120 ------------- mips/hgen/lexer.hgen | 116 ------------ mips/hgen/map.hgen | 19 -- mips/hgen/parser.hgen | 34 ---- mips/hgen/pretty.hgen | 36 ---- mips/hgen/sail_trans_out.hgen | 98 ---------- mips/hgen/shallow_ast_to_herdtools_ast.hgen | 98 ---------- mips/hgen/shallow_types_to_herdtools_types.hgen | 39 ---- mips/hgen/token_types.hgen | 39 ---- mips/hgen/tokens.hgen | 17 -- mips/hgen/trans_sail.hgen | 122 ------------- mips/hgen/types.hgen | 209 ---------------------- mips/hgen/types_sail_trans_out.hgen | 47 ----- mips/hgen/types_trans_sail.hgen | 44 ----- risc-v/gen/ast.hgen | 17 ++ risc-v/gen/fold.hgen | 16 ++ risc-v/gen/herdtools_ast_to_shallow_ast.hgen | 86 +++++++++ risc-v/gen/herdtools_types_to_shallow_types.hgen | 90 ++++++++++ risc-v/gen/lexer.hgen | 190 ++++++++++++++++++++ risc-v/gen/map.hgen | 15 ++ risc-v/gen/parser.hgen | 74 ++++++++ risc-v/gen/pretty.hgen | 30 ++++ risc-v/gen/pretty_xml.hgen | 137 ++++++++++++++ risc-v/gen/sail_trans_out.hgen | 23 +++ risc-v/gen/shallow_ast_to_herdtools_ast.hgen | 23 +++ risc-v/gen/shallow_types_to_herdtools_types.hgen | 84 +++++++++ risc-v/gen/token_types.hgen | 23 +++ risc-v/gen/tokens.hgen | 19 ++ risc-v/gen/trans_sail.hgen | 153 ++++++++++++++++ risc-v/gen/types.hgen | 172 ++++++++++++++++++ risc-v/gen/types_sail_trans_out.hgen | 98 ++++++++++ risc-v/gen/types_trans_sail.hgen | 57 ++++++ risc-v/hgen/ast.hgen | 17 -- risc-v/hgen/fold.hgen | 16 -- risc-v/hgen/herdtools_ast_to_shallow_ast.hgen | 86 --------- risc-v/hgen/herdtools_types_to_shallow_types.hgen | 90 ---------- risc-v/hgen/lexer.hgen | 190 -------------------- risc-v/hgen/map.hgen | 15 -- risc-v/hgen/parser.hgen | 74 -------- risc-v/hgen/pretty.hgen | 30 ---- risc-v/hgen/pretty_xml.hgen | 137 -------------- risc-v/hgen/sail_trans_out.hgen | 23 --- risc-v/hgen/shallow_ast_to_herdtools_ast.hgen | 23 --- risc-v/hgen/shallow_types_to_herdtools_types.hgen | 84 --------- risc-v/hgen/token_types.hgen | 23 --- risc-v/hgen/tokens.hgen | 19 -- risc-v/hgen/trans_sail.hgen | 153 ---------------- risc-v/hgen/types.hgen | 172 ------------------ risc-v/hgen/types_sail_trans_out.hgen | 98 ---------- risc-v/hgen/types_trans_sail.hgen | 57 ------ 71 files changed, 2533 insertions(+), 2503 deletions(-) create mode 100644 etc/power_header create mode 100644 mips/gen/ast.hgen create mode 100644 mips/gen/fold.hgen create mode 100644 mips/gen/herdtools_ast_to_shallow_ast.hgen create mode 100644 mips/gen/herdtools_types_to_shallow_types.hgen create mode 100644 mips/gen/lexer.hgen create mode 100644 mips/gen/map.hgen create mode 100644 mips/gen/parser.hgen create mode 100644 mips/gen/pretty.hgen create mode 100644 mips/gen/sail_trans_out.hgen create mode 100644 mips/gen/shallow_ast_to_herdtools_ast.hgen create mode 100644 mips/gen/shallow_types_to_herdtools_types.hgen create mode 100644 mips/gen/token_types.hgen create mode 100644 mips/gen/tokens.hgen create mode 100644 mips/gen/trans_sail.hgen create mode 100644 mips/gen/types.hgen create mode 100644 mips/gen/types_sail_trans_out.hgen create mode 100644 mips/gen/types_trans_sail.hgen delete mode 100644 mips/hgen/ast.hgen delete mode 100644 mips/hgen/fold.hgen delete mode 100644 mips/hgen/herdtools_ast_to_shallow_ast.hgen delete mode 100644 mips/hgen/herdtools_types_to_shallow_types.hgen delete mode 100644 mips/hgen/lexer.hgen delete mode 100644 mips/hgen/map.hgen delete mode 100644 mips/hgen/parser.hgen delete mode 100644 mips/hgen/pretty.hgen delete mode 100644 mips/hgen/sail_trans_out.hgen delete mode 100644 mips/hgen/shallow_ast_to_herdtools_ast.hgen delete mode 100644 mips/hgen/shallow_types_to_herdtools_types.hgen delete mode 100644 mips/hgen/token_types.hgen delete mode 100644 mips/hgen/tokens.hgen delete mode 100644 mips/hgen/trans_sail.hgen delete mode 100644 mips/hgen/types.hgen delete mode 100644 mips/hgen/types_sail_trans_out.hgen delete mode 100644 mips/hgen/types_trans_sail.hgen create mode 100644 risc-v/gen/ast.hgen create mode 100644 risc-v/gen/fold.hgen create mode 100644 risc-v/gen/herdtools_ast_to_shallow_ast.hgen create mode 100644 risc-v/gen/herdtools_types_to_shallow_types.hgen create mode 100644 risc-v/gen/lexer.hgen create mode 100644 risc-v/gen/map.hgen create mode 100644 risc-v/gen/parser.hgen create mode 100644 risc-v/gen/pretty.hgen create mode 100644 risc-v/gen/pretty_xml.hgen create mode 100644 risc-v/gen/sail_trans_out.hgen create mode 100644 risc-v/gen/shallow_ast_to_herdtools_ast.hgen create mode 100644 risc-v/gen/shallow_types_to_herdtools_types.hgen create mode 100644 risc-v/gen/token_types.hgen create mode 100644 risc-v/gen/tokens.hgen create mode 100644 risc-v/gen/trans_sail.hgen create mode 100644 risc-v/gen/types.hgen create mode 100644 risc-v/gen/types_sail_trans_out.hgen create mode 100644 risc-v/gen/types_trans_sail.hgen delete mode 100644 risc-v/hgen/ast.hgen delete mode 100644 risc-v/hgen/fold.hgen delete mode 100644 risc-v/hgen/herdtools_ast_to_shallow_ast.hgen delete mode 100644 risc-v/hgen/herdtools_types_to_shallow_types.hgen delete mode 100644 risc-v/hgen/lexer.hgen delete mode 100644 risc-v/hgen/map.hgen delete mode 100644 risc-v/hgen/parser.hgen delete mode 100644 risc-v/hgen/pretty.hgen delete mode 100644 risc-v/hgen/pretty_xml.hgen delete mode 100644 risc-v/hgen/sail_trans_out.hgen delete mode 100644 risc-v/hgen/shallow_ast_to_herdtools_ast.hgen delete mode 100644 risc-v/hgen/shallow_types_to_herdtools_types.hgen delete mode 100644 risc-v/hgen/token_types.hgen delete mode 100644 risc-v/hgen/tokens.hgen delete mode 100644 risc-v/hgen/trans_sail.hgen delete mode 100644 risc-v/hgen/types.hgen delete mode 100644 risc-v/hgen/types_sail_trans_out.hgen delete mode 100644 risc-v/hgen/types_trans_sail.hgen diff --git a/etc/power_header b/etc/power_header new file mode 100644 index 00000000..7eaf7da9 --- /dev/null +++ b/etc/power_header @@ -0,0 +1,30 @@ + +Copyright (c) 2015-2017 ??? +All rights reserved. + +This software was developed by the University of Cambridge Computer +Laboratory as part of the Rigorous Engineering of Mainstream Systems +(REMS) project, funded by EPSRC grant EP/K008528/1. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/mips/gen/ast.hgen b/mips/gen/ast.hgen new file mode 100644 index 00000000..a251adff --- /dev/null +++ b/mips/gen/ast.hgen @@ -0,0 +1,18 @@ +| `MIPSThreadStart +| `MIPSRType of mipsRTypeOp * reg * reg * reg +| `MIPSIType of mipsITypeOp * reg * reg * bit16 +| `MIPSShiftI of mipsShiftIOp * reg * reg * bit5 +| `MIPSShiftV of mipsShiftVOp * reg * reg * reg +| `MIPSMulDiv of mipsMulDivOp * reg * reg +| `MIPSMFHiLo of mipsMFHiLoOp * reg +| `MIPSLUI of reg * bit16 +| `MIPSLoad of mipsWordWidth * bool * bool * reg * reg * bit16 (* width, signed, linked, base, rt, offset *) +| `MIPSStore of mipsWordWidth * bool * reg * reg * bit16 (* width, conditional, base, rt, offset *) +| `MIPSLSLR of bool * bool * bool * reg * reg * bit16 (* store, double, left, base, rt, offset *) +| `MIPSSYNC +| `MIPSBEQ of reg * reg * bit16 * bool * bool (* rs, rt, offset, not equal, likely *) +| `MIPSBCMPZ of reg * bit16 * mipsCmp * bool * bool (* rs, offset, cmp, link, likely *) +| `MIPSJ of bit26 +| `MIPSJAL of bit26 +| `MIPSJR of reg +| `MIPSJALR of reg * reg (* rs, rd *) diff --git a/mips/gen/fold.hgen b/mips/gen/fold.hgen new file mode 100644 index 00000000..05b9c808 --- /dev/null +++ b/mips/gen/fold.hgen @@ -0,0 +1,19 @@ +| `MIPSThreadStart -> (y_reg, y_sreg) +| `MIPSRType (op, rd, rs, rt) -> fold_reg rt (fold_reg rs (fold_reg rd (y_reg, y_sreg))) +| `MIPSIType (op, rs, rt, imm) -> fold_reg rs (fold_reg rt (y_reg, y_sreg)) +| `MIPSShiftI (op, rd, rt, imm) -> fold_reg rt (fold_reg rd (y_reg, y_sreg)) +| `MIPSShiftV (op, rd, rt, rs) -> fold_reg rs (fold_reg rt (fold_reg rd (y_reg, y_sreg))) +| `MIPSMulDiv (op, rs, rt) -> fold_reg rs (fold_reg rt (y_reg, y_sreg)) +| `MIPSMFHiLo (op, rs) -> fold_reg rs (y_reg, y_sreg) +| `MIPSLUI (rt, imm) -> fold_reg rt (y_reg, y_sreg) +| `MIPSLoad (width, signed, linked, base, rt, offset) -> fold_reg rt (fold_reg base (y_reg, y_sreg)) +| `MIPSStore (width, conditional, base, rt, offset) -> fold_reg rt (fold_reg base (y_reg, y_sreg)) +| `MIPSLSLR (store, double, left, base, rt, offset) -> fold_reg rt (fold_reg base (y_reg, y_sreg)) +| `MIPSSYNC -> (y_reg, y_sreg) +| `MIPSBEQ (rs, rt, offset, ne, likely) -> fold_reg rs (fold_reg rt (y_reg, y_sreg)) +| `MIPSBCMPZ (rs, offset, cmp, link, likely) -> fold_reg rs (y_reg, y_sreg) +| `MIPSJ (offset) -> (y_reg, y_sreg) +| `MIPSJAL (offset) -> fold_reg (IReg(R31)) (y_reg, y_sreg) +| `MIPSJR (rd) -> fold_reg rd (y_reg, y_sreg) +| `MIPSJALR (rd, rs) -> fold_reg rd (fold_reg rs (y_reg, y_sreg)) + diff --git a/mips/gen/herdtools_ast_to_shallow_ast.hgen b/mips/gen/herdtools_ast_to_shallow_ast.hgen new file mode 100644 index 00000000..7b1a58d9 --- /dev/null +++ b/mips/gen/herdtools_ast_to_shallow_ast.hgen @@ -0,0 +1,121 @@ +| `MIPSThreadStart -> + SYSCALL_THREAD_START + +| `MIPSStopFetching -> + ImplementationDefinedStopFetching0 + +(* Note different argument order, which reflects difference + between instruction encoding and asm format *) +| `MIPSRType (op, rd, rs, rt) -> + (translate_rtype_op op) + ( + translate_reg "rs" rs, + translate_reg "rt" rt, + translate_reg "rd" rd + ) + + +(* Note different argument order similar to above *) +| `MIPSIType (op, rt, rs, imm) -> + (translate_itype_op op) + ( + translate_reg "rs" rs, + translate_reg "rt" rt, + translate_imm16 "imm" imm + ) + + +| `MIPSShiftI (op, rd, rt, sa) -> + (translate_shifti_op op) + ( + translate_reg "rt" rt, + translate_reg "rd" rd, + translate_imm5 "sa" sa + ) + + +| `MIPSShiftV (op, rd, rt, rs) -> + (translate_shiftv_op op) + ( + translate_reg "rs" rs, + translate_reg "rt" rt, + translate_reg "rd" rd + ) + + +| `MIPSMulDiv (op, rs, rt) -> + (translate_muldiv_op op) + ( + translate_reg "rs" rs, + translate_reg "rt" rt + ) + + +| `MIPSMFHiLo (op, rs) -> + (translate_mfhilo_op op) + ( + translate_reg "rs" rs + ) + +| `MIPSLUI (rt, imm) -> + LUI + ( + translate_reg "rt" rt, + translate_imm16 "imm" imm + ) + +| `MIPSLoad (width, signed, linked, base, rt, offset) -> + Load + ( + translate_wordsize "width" width, + translate_bool "signed" signed, + translate_bool "linked" linked, + translate_reg "base" base, + translate_reg "rt" rt, + translate_imm16 "offset" offset + ) + +| `MIPSStore (width, conditional, base, rt, offset) -> + Store + ( + translate_wordsize "width" width, + translate_bool "conditional" conditional, + translate_reg "base" base, + translate_reg "rt" rt, + translate_imm16 "offset" offset + ) + +| `MIPSLSLR (store, double, left, base, rt, offset) -> + (translate_lslr_op store double left) + ( + translate_reg "base" base, + translate_reg "rt" rt, + translate_imm16 "offset" offset + ) + +| `MIPSSYNC -> SYNC +| `MIPSBEQ (rs, rt, offset, ne, likely) -> + BEQ + (translate_reg "rs" rs, + translate_reg "rt" rt, + translate_imm16 "offset" offset, + translate_bool "ne" ne, + translate_bool "likely" likely + ) + +| `MIPSBCMPZ (rs, offset, cmp, link, likely) -> + BCMPZ + (translate_reg "rs" rs, + translate_imm16 "offset" offset, + translate_cmp "cmp" cmp, + translate_bool "link" link, + translate_bool "likely" likely + ) +| `MIPSJ (offset) -> + J (translate_imm26 "offset" offset) +| `MIPSJAL (offset) -> + JAL (translate_imm26 "offset" offset) +| `MIPSJR(rd) -> + JR (translate_reg "rd" rd) +| `MIPSJALR(rd, rs) -> + JALR (translate_reg "rd" rd, translate_reg "rs" rs) diff --git a/mips/gen/herdtools_types_to_shallow_types.hgen b/mips/gen/herdtools_types_to_shallow_types.hgen new file mode 100644 index 00000000..5a0e3bfc --- /dev/null +++ b/mips/gen/herdtools_types_to_shallow_types.hgen @@ -0,0 +1,120 @@ +let is_inc = false + +let translate_rtype_op op = uppercase (pp_rtype_op op) + +let translate_rtype_op op x = match op with + | MIPSROpADD -> ADD x + | MIPSROpADDU -> ADDU x + | MIPSROpAND -> AND x + | MIPSROpDADD -> DADD x + | MIPSROpDADDU -> DADDU x + | MIPSROpDSUB -> DSUB x + | MIPSROpDSUBU -> DSUBU x + | MIPSROpMOVN -> MOVN x + | MIPSROpMOVZ -> MOVZ x + | MIPSROpMUL -> MUL x + | MIPSROpNOR -> NOR x + | MIPSROpOR -> OR x + | MIPSROpSLT -> SLT x + | MIPSROpSLTU -> SLTU x + | MIPSROpSUB -> SUB x + | MIPSROpSUBU -> SUBU x + | MIPSROpXOR -> XOR x + +let translate_itype_op op x = match op with + | MIPSIOpADDI -> ADDI x + | MIPSIOpADDIU -> ADDIU x + | MIPSIOpANDI -> ANDI x + | MIPSIOpDADDI -> DADDI x + | MIPSIOpDADDIU -> DADDIU x + | MIPSIOpORI -> ORI x + | MIPSIOpSLTI -> SLTI x + | MIPSIOpSLTIU -> SLTIU x + | MIPSIOpXORI -> XORI x + +let translate_shifti_op op x = match op with + | MIPSDSLL -> DSLL x + | MIPSDSLL32 -> DSLL32 x + | MIPSDSRA -> DSRA x + | MIPSDSRA32 -> DSRA32 x + | MIPSDSRL -> DSRL x + | MIPSDSRL32 -> DSRL32 x + | MIPSSLL -> SLL x + | MIPSSRA -> SRA x + | MIPSSRL -> SRL x + +let translate_shiftv_op op x = match op with + | MIPSDSLLV -> DSLLV x + | MIPSDSRAV -> DSRAV x + | MIPSDSRLV -> DSRLV x + | MIPSSLLV -> SLLV x + | MIPSSRAV -> SRAV x + | MIPSSRLV -> SRLV x + +let translate_muldiv_op op x = match op with + | MIPSDDIV -> DDIV x + | MIPSDDIVU -> DDIVU x + | MIPSDIV -> DIV x + | MIPSDIVU -> DIVU x + | MIPSDMULT -> DMULT x + | MIPSDMULTU -> DMULTU x + | MIPSMADD -> MADD x + | MIPSMADDU -> MADDU x + | MIPSMSUB -> MSUB x + | MIPSMSUBU -> MSUBU x + | MIPSMULT -> MULT x + | MIPSMULTU -> MULTU x + +let translate_mfhilo_op op x = match op with + | MIPSMFHI -> MFHI x + | MIPSMFLO -> MFLO x + | MIPSMTHI -> MTHI x + | MIPSMTLO -> MTLO x + +let translate_load_op width signed linked = uppercase (pp_load_op width signed linked) + +let translate_store_op width conditional = uppercase (pp_store_op width conditional) + +let translate_lslr_op store double left x = match (store,double,left) with + | (false, false, true ) -> LWL x + | (false, false, false) -> LWR x + | (false, true , true ) -> LDL x + | (false, true , false) -> LDR x + | (true , false, true ) -> SWL x + | (true , false, false) -> SWR x + | (true , true , true ) -> SDL x + | (true , true , false) -> SDR x + +let translate_beq_op ne likely = uppercase (pp_beq_op ne likely) + +let translate_bcmpz_op cmp link likely = uppercase (pp_bcmpz_op cmp link likely) + + +let translate_reg name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 5,Nat_big_num.of_int (reg_to_int value)) + +let translate_imm26 name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 26,Nat_big_num.of_int value) +let translate_imm16 name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 16,Nat_big_num.of_int value) +let translate_imm5 name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 5,Nat_big_num.of_int value) +let translate_bool name = function + | true -> Sail_values.B1 + | false -> Sail_values.B0 + +let translate_wordsize _ = function + | MIPSByte -> Mips_embed_types.B2 + | MIPSHalf -> Mips_embed_types.H + | MIPSWord -> Mips_embed_types.W + | MIPSDouble -> Mips_embed_types.D + +let translate_cmp _ = function + | MIPS_EQ -> EQ' + | MIPS_NE -> NE + | MIPS_GE -> GE + | MIPS_GEU -> GEU + | MIPS_GT -> GT' + | MIPS_LE -> LE + | MIPS_LT -> LT' + | MIPS_LTU -> LTU diff --git a/mips/gen/lexer.hgen b/mips/gen/lexer.hgen new file mode 100644 index 00000000..c01b14cc --- /dev/null +++ b/mips/gen/lexer.hgen @@ -0,0 +1,116 @@ +"add" , RTYPE {txt="ADD" ; op=MIPSROpADD }; +"addu" , RTYPE {txt="ADDU" ; op=MIPSROpADDU }; +"and" , RTYPE {txt="AND" ; op=MIPSROpAND }; +"dadd" , RTYPE {txt="DADD" ; op=MIPSROpDADD }; +"daddu" , RTYPE {txt="DADDU" ; op=MIPSROpDADDU }; +"dsub" , RTYPE {txt="DSUB" ; op=MIPSROpDSUB }; +"dsubu" , RTYPE {txt="DSUBU" ; op=MIPSROpDSUBU }; +"movn" , RTYPE {txt="MOVN" ; op=MIPSROpMOVN }; +"movz" , RTYPE {txt="MOVZ" ; op=MIPSROpMOVZ }; +"mul" , RTYPE {txt="MUL" ; op=MIPSROpMUL }; +"nor" , RTYPE {txt="NOR" ; op=MIPSROpNOR }; +"or" , RTYPE {txt="OR" ; op=MIPSROpOR }; +"slt" , RTYPE {txt="SLT" ; op=MIPSROpSLT }; +"sltu" , RTYPE {txt="SLTU" ; op=MIPSROpSLTU }; +"sub" , RTYPE {txt="SUB" ; op=MIPSROpSUB }; +"subu" , RTYPE {txt="SUBU" ; op=MIPSROpSUBU }; +"xor" , RTYPE {txt="XOR" ; op=MIPSROpXOR }; + +"addi" , ITYPE {txt="ADDI" ; op=MIPSIOpADDI }; +"addiu" , ITYPE {txt="ADDIU" ; op=MIPSIOpADDIU }; +"andi" , ITYPE {txt="ANDI" ; op=MIPSIOpANDI }; +"daddi" , ITYPE {txt="DADDI" ; op=MIPSIOpDADDI }; +"daddiu", ITYPE {txt="DADDIU"; op=MIPSIOpDADDIU }; +"ori" , ITYPE {txt="ORI" ; op=MIPSIOpORI }; +"slti" , ITYPE {txt="SLTI" ; op=MIPSIOpSLTI }; +"sltiu" , ITYPE {txt="SLTIU" ; op=MIPSIOpSLTIU }; +"xori" , ITYPE {txt="XORI" ; op=MIPSIOpXORI }; + +"dsll" , SHIFTI {txt="DSLL" ; op=MIPSDSLL }; +"dsll32" , SHIFTI {txt="DSLL32" ; op=MIPSDSLL32 }; +"dsra" , SHIFTI {txt="DSRA" ; op=MIPSDSRA }; +"dsra32" , SHIFTI {txt="DSRA32" ; op=MIPSDSRA32 }; +"dsrl" , SHIFTI {txt="DSRL" ; op=MIPSDSRL }; +"dsrl32" , SHIFTI {txt="DSRL32" ; op=MIPSDSRL32 }; +"sll" , SHIFTI {txt="SLL" ; op=MIPSSLL }; +"sra" , SHIFTI {txt="SRA" ; op=MIPSSRA }; +"srl" , SHIFTI {txt="SRL" ; op=MIPSSRL }; + +"dsllv", SHIFTV {txt="DSLLV" ; op=MIPSDSLLV }; +"dsrav", SHIFTV {txt="DSRAV" ; op=MIPSDSRAV }; +"dsrlv", SHIFTV {txt="DSRLV" ; op=MIPSDSRLV }; +"sllv" , SHIFTV {txt="SLLV" ; op=MIPSSLLV }; +"srav" , SHIFTV {txt="SRAV" ; op=MIPSSRAV }; +"srlv" , SHIFTV {txt="SRLV" ; op=MIPSSRLV }; + +"ddiv" , MULDIV {txt="DDIV" ; op=MIPSDDIV }; +"ddivu" , MULDIV {txt="DDIVU" ; op=MIPSDDIVU }; +"div" , MULDIV {txt="DIV" ; op=MIPSDIV }; +"divu" , MULDIV {txt="DIVU" ; op=MIPSDIVU }; +"dmult" , MULDIV {txt="DMULT" ; op=MIPSDMULT }; +"dmultu", MULDIV {txt="DMULTU"; op=MIPSDMULTU }; +"madd" , MULDIV {txt="MADD" ; op=MIPSMADD }; +"maddu" , MULDIV {txt="MADDU" ; op=MIPSMADDU }; +"msub" , MULDIV {txt="MSUB" ; op=MIPSMSUB }; +"msubu" , MULDIV {txt="MSUBU" ; op=MIPSMSUBU }; +"mult" , MULDIV {txt="MULT" ; op=MIPSMULT }; +"multu" , MULDIV {txt="MULTU" ; op=MIPSMULTU }; + +"mfhi" , MFHILO {txt="MFHI" ; op=MIPSMFHI }; +"mflo" , MFHILO {txt="MFLO" ; op=MIPSMFLO }; +"mthi" , MFHILO {txt="MTHI" ; op=MIPSMTHI }; +"mtlo" , MFHILO {txt="MTLO" ; op=MIPSMTLO }; + +"lui" , LUI {txt="LUI" }; + +"lb" , LOAD {txt="LB" ; width=MIPSByte ; signed=true; linked=false }; +"lbu" , LOAD {txt="LBU" ; width=MIPSByte ; signed=false; linked=false }; +"lh" , LOAD {txt="LH" ; width=MIPSHalf ; signed=true; linked=false }; +"lhu" , LOAD {txt="LHU" ; width=MIPSHalf ; signed=false; linked=false }; +"lw" , LOAD {txt="LW" ; width=MIPSWord ; signed=true; linked=false }; +"lwu" , LOAD {txt="LWU" ; width=MIPSWord ; signed=false; linked=false }; +"ld" , LOAD {txt="LD" ; width=MIPSDouble ; signed=false; linked=false }; +"ll" , LOAD {txt="LL" ; width=MIPSWord ; signed=true; linked=true }; +"lld" , LOAD {txt="LLD" ; width=MIPSDouble ; signed=false; linked=true }; + +"sb" , STORE {txt="SB" ; width=MIPSByte ; conditional=false }; +"sh" , STORE {txt="SH" ; width=MIPSHalf ; conditional=false }; +"sw" , STORE {txt="SW" ; width=MIPSWord ; conditional=false }; +"sd" , STORE {txt="SD" ; width=MIPSDouble ; conditional=false }; +"sc" , STORE {txt="SC" ; width=MIPSWord ; conditional=true }; +"scd" , STORE {txt="SCD" ; width=MIPSDouble ; conditional=true }; + +"lwl" , LSLR {txt="LWL" ; store=false; double=false; left=true }; +"lwr" , LSLR {txt="LWR" ; store=false; double=false; left=false}; +"ldl" , LSLR {txt="LDL" ; store=false; double=true ; left=true }; +"ldr" , LSLR {txt="LDR" ; store=false; double=true ; left=false}; +"swl" , LSLR {txt="SWL" ; store=true ; double=false; left=true }; +"swr" , LSLR {txt="SWR" ; store=true ; double=false; left=false}; +"sdl" , LSLR {txt="SDL" ; store=true ; double=true ; left=true }; +"sdr" , LSLR {txt="SDR" ; store=true ; double=true ; left=false}; +"sync", SYNC {txt="SYNC"}; + +"beq", BEQ {txt="BEQ"; ne=false; likely=false }; +"beql", BEQ {txt="BEQ"; ne=false; likely=true }; +"bne", BEQ {txt="BEQ"; ne=true ; likely=false }; +"bnel", BEQ {txt="BEQ"; ne=true ; likely=true }; + +"bltz", BCMPZ {txt="BCMPZ"; cmp=MIPS_LT; likely=false; link=false }; +"bltzal", BCMPZ {txt="BCMPZ"; cmp=MIPS_LT; likely=false; link=true }; +"bltzl", BCMPZ {txt="BCMPZ"; cmp=MIPS_LT; likely=true; link=false }; +"bltzall",BCMPZ {txt="BCMPZ"; cmp=MIPS_LT; likely=true; link=true }; + +"bgez", BCMPZ {txt="BCMPZ"; cmp=MIPS_GE; likely=false; link=false }; +"bgezal", BCMPZ {txt="BCMPZ"; cmp=MIPS_GE; likely=false; link=true }; +"bgezl", BCMPZ {txt="BCMPZ"; cmp=MIPS_GE; likely=true; link=false }; +"bgezall",BCMPZ {txt="BCMPZ"; cmp=MIPS_GE; likely=true; link=true }; + +"bgtz", BCMPZ {txt="BCMPZ"; cmp=MIPS_GT; likely=false; link=false }; +"bgtzl", BCMPZ {txt="BCMPZ"; cmp=MIPS_GT; likely=true; link=false }; + +"blez", BCMPZ {txt="BCMPZ"; cmp=MIPS_LE; likely=false; link=false }; +"blezl", BCMPZ {txt="BCMPZ"; cmp=MIPS_LE; likely=true; link=false }; +"j", J {txt="J"}; +"jal", JAL {txt="JAL"}; +"jr", JR {txt="JR"}; +"jalr", JALR {txt="JALR"}; diff --git a/mips/gen/map.hgen b/mips/gen/map.hgen new file mode 100644 index 00000000..f5116bae --- /dev/null +++ b/mips/gen/map.hgen @@ -0,0 +1,19 @@ +| `MIPSThreadStart -> `MIPSThreadStart +| `MIPSRType (op, rd, rs, rt) -> `MIPSRType (op, map_reg rd, map_reg rs, map_reg rt) +| `MIPSIType (op, rs, rt, imm) -> `MIPSIType (op, map_reg rs, map_reg rt, imm) +| `MIPSShiftI (op, rd, rt, imm) -> `MIPSShiftI (op, map_reg rd, map_reg rt, imm) +| `MIPSShiftV (op, rd, rt, rs) -> `MIPSShiftV (op, map_reg rd, map_reg rt, map_reg rs) +| `MIPSMulDiv (op, rs, rt) -> `MIPSMulDiv (op, map_reg rs, map_reg rt) +| `MIPSMFHiLo (op, rs) -> `MIPSMFHiLo (op, map_reg rs) +| `MIPSLUI (rt, imm) -> `MIPSLUI (map_reg rt, imm) +| `MIPSLoad (width, signed, linked, base, rt, offset) -> `MIPSLoad (width, signed, linked, map_reg base, map_reg rt, offset) +| `MIPSStore (width, conditional, base, rt, offset) -> `MIPSStore (width, conditional, map_reg base, map_reg rt, offset) +| `MIPSLSLR (store, double, left, base, rt, offset) -> `MIPSLSLR (store, double, left, map_reg base, map_reg rt, offset) +| `MIPSSYNC -> `MIPSSYNC +| `MIPSBEQ (rs, rt, offset, ne, likely) -> `MIPSBEQ (map_reg rs, map_reg rt, offset, ne, likely) +| `MIPSBCMPZ (rs, offset, cmp, link, likely) -> `MIPSBCMPZ (map_reg rs, offset, cmp, link, likely) +| `MIPSJ (offset) -> `MIPSJ (offset) +| `MIPSJAL (offset) -> `MIPSJAL (offset) (* implicit R31? *) +| `MIPSJR (rd) -> `MIPSJR (map_reg rd) +| `MIPSJALR (rd, rs) -> `MIPSJALR(map_reg rd, map_reg rs) + diff --git a/mips/gen/parser.hgen b/mips/gen/parser.hgen new file mode 100644 index 00000000..8f573aa5 --- /dev/null +++ b/mips/gen/parser.hgen @@ -0,0 +1,34 @@ +| RTYPE reg COMMA reg COMMA reg + { `MIPSRType ($1.op, $2, $4, $6) } +| ITYPE reg COMMA reg COMMA NUM + { `MIPSIType ($1.op, $2, $4, $6) } +| SHIFTI reg COMMA reg COMMA NUM + { `MIPSShiftI ($1.op, $2, $4, $6) } +| SHIFTV reg COMMA reg COMMA reg + { `MIPSShiftV ($1.op, $2, $4, $6) } +| MULDIV reg COMMA reg + { `MIPSMulDiv ($1.op, $2, $4) } +| MFHILO reg + { `MIPSMFHiLo ($1.op, $2) } +| LUI reg COMMA NUM + { `MIPSLUI ($2, $4) } +| LOAD reg COMMA NUM LPAR reg RPAR + { `MIPSLoad ($1.width, $1.signed, $1.linked, $6, $2, $4) } +| STORE reg COMMA NUM LPAR reg RPAR + { `MIPSStore ($1.width, $1.conditional, $6, $2, $4) } +| LSLR reg COMMA NUM LPAR reg RPAR + { `MIPSLSLR ($1.store, $1.double, $1.left, $6, $2, $4) } +| SYNC + { `MIPSSYNC } +| BEQ reg COMMA reg COMMA NUM + { `MIPSBEQ ( $2, $4, $6, $1.ne, $1.likely) } +| BCMPZ reg COMMA NUM + { `MIPSBCMPZ ( $2, $4, $1.cmp, $1.link, $1.likely) } +| J NUM + { `MIPSJ ($2) } +| JAL NUM + { `MIPSJAL ($2) } +| JR reg + { `MIPSJR ($2) } +| JALR reg COMMA reg + { `MIPSJALR ($2, $4) } diff --git a/mips/gen/pretty.hgen b/mips/gen/pretty.hgen new file mode 100644 index 00000000..98f56f2e --- /dev/null +++ b/mips/gen/pretty.hgen @@ -0,0 +1,36 @@ +| `MIPSThreadStart -> "syscall 0xfffff" (* thread start *) +| `MIPSStopFetching -> "STOP" (* TODO *) +| `MIPSRType (op, rd,rs,rt) -> + sprintf "%s %s,%s,%s" (pp_rtype_op op) (pp_reg rd) (pp_reg rs) (pp_reg rt) +| `MIPSIType (op,rd,rs,imm) -> + sprintf "%s %s,%s,%d" (pp_itype_op op) (pp_reg rd) (pp_reg rs) imm +| `MIPSShiftI (op, rs, rt, imm) -> + sprintf "%s %s,%s,%d" (pp_shifti_op op) (pp_reg rs) (pp_reg rt) imm +| `MIPSShiftV (op, rd,rs,rt) -> + sprintf "%s %s,%s,%s" (pp_shiftv_op op) (pp_reg rd) (pp_reg rs) (pp_reg rt) +| `MIPSMulDiv (op, rs, rt) -> + sprintf "%s %s,%s" (pp_muldiv_op op) (pp_reg rs) (pp_reg rt) +| `MIPSMFHiLo (op, rs) -> + sprintf "%s %s" (pp_mfhilo_op op) (pp_reg rs) +| `MIPSLUI (rt, imm) -> + sprintf "lui %s,%d" (pp_reg rt) imm +| `MIPSLoad (width, signed, linked, base, rt, offset) -> + sprintf "%s %s,%d(%s)" (pp_load_op width signed linked) (pp_reg rt) offset (pp_reg base) +| `MIPSStore (width, conditional, base, rt, offset) -> + sprintf "%s %s,%d(%s)" (pp_store_op width conditional) (pp_reg rt) offset (pp_reg base) +| `MIPSLSLR (store, double, left, base, rt, offset) -> + sprintf "%s %s,%d(%s)" (pp_lslr_op store double left) (pp_reg rt) offset (pp_reg base) +| `MIPSSYNC -> "sync" +| `MIPSBEQ (rs, rt, offset, ne, likely) -> + sprintf "%s %s,%s,.%+d" (pp_beq_op ne likely) (pp_reg rs) (pp_reg rt) offset +| `MIPSBCMPZ (rs, offset, cmp, link, likely) -> + sprintf "%s,%s,.%+d" (pp_bcmpz_op cmp link likely) (pp_reg rs) offset +| `MIPSJ (offset) -> + sprintf "j %d" offset +| `MIPSJAL (offset) -> + sprintf "jal %d" offset +| `MIPSJR(rd) -> + sprintf "jr %s" (pp_reg rd) +| `MIPSJALR(rd, rs) -> + sprintf "jalr %s,%s" (pp_reg rd) (pp_reg rs) + diff --git a/mips/gen/sail_trans_out.hgen b/mips/gen/sail_trans_out.hgen new file mode 100644 index 00000000..f2d006e8 --- /dev/null +++ b/mips/gen/sail_trans_out.hgen @@ -0,0 +1,98 @@ +| ("SYSCALL_THREAD_START", []) -> `MIPSThreadStart +| ("ADD" , [rs; rt; rd]) -> `MIPSRType (MIPSROpADD , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("ADDU" , [rs; rt; rd]) -> `MIPSRType (MIPSROpADDU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("AND" , [rs; rt; rd]) -> `MIPSRType (MIPSROpAND , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("DADD" , [rs; rt; rd]) -> `MIPSRType (MIPSROpDADD , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("DADDU" , [rs; rt; rd]) -> `MIPSRType (MIPSROpDADDU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("DSUB" , [rs; rt; rd]) -> `MIPSRType (MIPSROpDSUB , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("DSUBU" , [rs; rt; rd]) -> `MIPSRType (MIPSROpDSUBU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("MOVN" , [rs; rt; rd]) -> `MIPSRType (MIPSROpMOVN , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("MOVZ" , [rs; rt; rd]) -> `MIPSRType (MIPSROpMOVZ , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("MUL" , [rs; rt; rd]) -> `MIPSRType (MIPSROpMUL , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("NOR" , [rs; rt; rd]) -> `MIPSRType (MIPSROpNOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("OR" , [rs; rt; rd]) -> `MIPSRType (MIPSROpOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("SLT" , [rs; rt; rd]) -> `MIPSRType (MIPSROpSLT , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("SLTU" , [rs; rt; rd]) -> `MIPSRType (MIPSROpSLTU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("SUB" , [rs; rt; rd]) -> `MIPSRType (MIPSROpSUB , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("SUBU" , [rs; rt; rd]) -> `MIPSRType (MIPSROpSUBU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| ("XOR" , [rs; rt; rd]) -> `MIPSRType (MIPSROpXOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) + +| ("ADDI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpADDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| ("ADDIU" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpADDIU ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| ("ANDI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpANDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) +| ("DADDI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpDADDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| ("DADDIU", [rs; rt; imm]) -> `MIPSIType (MIPSIOpDADDIU,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| ("ORI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpORI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) +| ("SLTI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpSLTI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| ("SLTIU" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpSLTIU ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| ("XORI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpXORI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) + +| ("DSLL" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSLL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| ("DSLL32" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSLL32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| ("DSRA" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSRA , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| ("DSRA32" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSRA32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| ("DSRL" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSRL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| ("DSRL32" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSRL32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| ("SLL" , [rt; rd; sa]) -> `MIPSShiftI (MIPSSLL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| ("SRA" , [rt; rd; sa]) -> `MIPSShiftI (MIPSSRA , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| ("SRL" , [rt; rd; sa]) -> `MIPSShiftI (MIPSSRL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) + +| "DSLLV" , [rs; rt; rd] -> `MIPSShiftV (MIPSDSLLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) +| "DSRAV" , [rs; rt; rd] -> `MIPSShiftV (MIPSDSRAV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) +| "DSRLV" , [rs; rt; rd] -> `MIPSShiftV (MIPSDSRLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) +| "SLLV" , [rs; rt; rd] -> `MIPSShiftV (MIPSSLLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) +| "SRAV" , [rs; rt; rd] -> `MIPSShiftV (MIPSSRAV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) +| "SRLV" , [rs; rt; rd] -> `MIPSShiftV (MIPSSRLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) + +| "DDIV" , [rs; rt] -> `MIPSMulDiv (MIPSDDIV , (translate_out_ireg rs), (translate_out_ireg rt)) +| "DDIVU" , [rs; rt] -> `MIPSMulDiv (MIPSDDIVU , (translate_out_ireg rs), (translate_out_ireg rt)) +| "DIV" , [rs; rt] -> `MIPSMulDiv (MIPSDIV , (translate_out_ireg rs), (translate_out_ireg rt)) +| "DIVU" , [rs; rt] -> `MIPSMulDiv (MIPSDIVU , (translate_out_ireg rs), (translate_out_ireg rt)) +| "DMULT" , [rs; rt] -> `MIPSMulDiv (MIPSDMULT , (translate_out_ireg rs), (translate_out_ireg rt)) +| "DMULTU", [rs; rt] -> `MIPSMulDiv (MIPSDMULTU , (translate_out_ireg rs), (translate_out_ireg rt)) +| "MADD" , [rs; rt] -> `MIPSMulDiv (MIPSMADD , (translate_out_ireg rs), (translate_out_ireg rt)) +| "MADDU" , [rs; rt] -> `MIPSMulDiv (MIPSMADDU , (translate_out_ireg rs), (translate_out_ireg rt)) +| "MSUB" , [rs; rt] -> `MIPSMulDiv (MIPSMSUB , (translate_out_ireg rs), (translate_out_ireg rt)) +| "MSUBU" , [rs; rt] -> `MIPSMulDiv (MIPSMSUBU , (translate_out_ireg rs), (translate_out_ireg rt)) +| "MULT" , [rs; rt] -> `MIPSMulDiv (MIPSMULT , (translate_out_ireg rs), (translate_out_ireg rt)) +| "MULTU" , [rs; rt] -> `MIPSMulDiv (MIPSMULTU , (translate_out_ireg rs), (translate_out_ireg rt)) + +| "MFHI" , [rs] -> `MIPSMFHiLo (MIPSMFHI, (translate_out_ireg rs)) +| "MFLO" , [rs] -> `MIPSMFHiLo (MIPSMFLO, (translate_out_ireg rs)) +| "MTHI" , [rs] -> `MIPSMFHiLo (MIPSMTHI, (translate_out_ireg rs)) +| "MTLO" , [rs] -> `MIPSMFHiLo (MIPSMTLO, (translate_out_ireg rs)) + +| "LUI" , [rt; imm] -> `MIPSLUI ((translate_out_ireg rt), (translate_out_imm16 imm)) +| "Load", [width; signed; linked; base; rt; offset] -> + `MIPSLoad ( + (translate_out_wordWidth width), + (translate_out_bool signed), + (translate_out_bool linked), + (translate_out_ireg base), + (translate_out_ireg rt), + (translate_out_simm16 offset) + ) +| "Store", [width; conditional; base; rt; offset] -> + `MIPSStore ( + (translate_out_wordWidth width), + (translate_out_bool conditional), + (translate_out_ireg base), + (translate_out_ireg rt), + (translate_out_simm16 offset) + ) +| "LWL", [base; rt; offset] -> `MIPSLSLR (false, false, true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| "LWR", [base; rt; offset] -> `MIPSLSLR (false, false, false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| "LDL", [base; rt; offset] -> `MIPSLSLR (false, true , true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| "LDR", [base; rt; offset] -> `MIPSLSLR (false, true , false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| "SWL", [base; rt; offset] -> `MIPSLSLR (true , false, true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| "SWR", [base; rt; offset] -> `MIPSLSLR (true , false, false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| "SDL", [base; rt; offset] -> `MIPSLSLR (true , true , true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| "SDR", [base; rt; offset] -> `MIPSLSLR (true , true , false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| "SYNC", [] -> `MIPSSYNC +| "BEQ", [rs; rt; offset; ne; likely] -> `MIPSBEQ ((translate_out_ireg rs), (translate_out_ireg rt), (translate_out_simm16 offset), (translate_out_bool ne), (translate_out_bool likely)) +| "BCMPZ", [rs; offset; cmp; link; likely] -> `MIPSBCMPZ ((translate_out_ireg rs), (translate_out_simm16 offset), (translate_out_cmp cmp), (translate_out_bool link), (translate_out_bool likely)) +| "J", [offset] -> `MIPSJ (translate_out_imm26 offset) +| "JAL", [offset] -> `MIPSJAL (translate_out_imm26 offset) +| "JR", [rd] -> `MIPSJR (translate_out_ireg rd) +| "JALR", [rd; rs] -> `MIPSJALR (translate_out_ireg rd, translate_out_ireg rs) + diff --git a/mips/gen/shallow_ast_to_herdtools_ast.hgen b/mips/gen/shallow_ast_to_herdtools_ast.hgen new file mode 100644 index 00000000..efe2c77e --- /dev/null +++ b/mips/gen/shallow_ast_to_herdtools_ast.hgen @@ -0,0 +1,98 @@ +| SYSCALL_THREAD_START -> `MIPSThreadStart +| (ADD (rs, rt, rd)) -> `MIPSRType (MIPSROpADD , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (ADDU (rs, rt, rd)) -> `MIPSRType (MIPSROpADDU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (AND (rs, rt, rd)) -> `MIPSRType (MIPSROpAND , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (DADD (rs, rt, rd)) -> `MIPSRType (MIPSROpDADD , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (DADDU (rs, rt, rd)) -> `MIPSRType (MIPSROpDADDU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (DSUB (rs, rt, rd)) -> `MIPSRType (MIPSROpDSUB , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (DSUBU (rs, rt, rd)) -> `MIPSRType (MIPSROpDSUBU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (MOVN (rs, rt, rd)) -> `MIPSRType (MIPSROpMOVN , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (MOVZ (rs, rt, rd)) -> `MIPSRType (MIPSROpMOVZ , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (MUL (rs, rt, rd)) -> `MIPSRType (MIPSROpMUL , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (NOR (rs, rt, rd)) -> `MIPSRType (MIPSROpNOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (OR (rs, rt, rd)) -> `MIPSRType (MIPSROpOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (SLT (rs, rt, rd)) -> `MIPSRType (MIPSROpSLT , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (SLTU (rs, rt, rd)) -> `MIPSRType (MIPSROpSLTU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (SUB (rs, rt, rd)) -> `MIPSRType (MIPSROpSUB , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (SUBU (rs, rt, rd)) -> `MIPSRType (MIPSROpSUBU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) +| (XOR (rs, rt, rd)) -> `MIPSRType (MIPSROpXOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) + +| (ADDI (rs, rt, imm)) -> `MIPSIType (MIPSIOpADDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| (ADDIU (rs, rt, imm)) -> `MIPSIType (MIPSIOpADDIU ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| (ANDI (rs, rt, imm)) -> `MIPSIType (MIPSIOpANDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) +| (DADDI (rs, rt, imm)) -> `MIPSIType (MIPSIOpDADDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| (DADDIU (rs, rt, imm)) -> `MIPSIType (MIPSIOpDADDIU,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| (ORI (rs, rt, imm)) -> `MIPSIType (MIPSIOpORI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) +| (SLTI (rs, rt, imm)) -> `MIPSIType (MIPSIOpSLTI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| (SLTIU (rs, rt, imm)) -> `MIPSIType (MIPSIOpSLTIU ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) +| (XORI (rs, rt, imm)) -> `MIPSIType (MIPSIOpXORI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) + +| (DSLL (rt, rd, sa)) -> `MIPSShiftI (MIPSDSLL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| (DSLL32 (rt, rd, sa)) -> `MIPSShiftI (MIPSDSLL32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| (DSRA (rt, rd, sa)) -> `MIPSShiftI (MIPSDSRA , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| (DSRA32 (rt, rd, sa)) -> `MIPSShiftI (MIPSDSRA32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| (DSRL (rt, rd, sa)) -> `MIPSShiftI (MIPSDSRL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| (DSRL32 (rt, rd, sa)) -> `MIPSShiftI (MIPSDSRL32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| (SLL (rt, rd, sa)) -> `MIPSShiftI (MIPSSLL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| (SRA (rt, rd, sa)) -> `MIPSShiftI (MIPSSRA , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) +| (SRL (rt, rd, sa)) -> `MIPSShiftI (MIPSSRL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) + +| DSLLV (rs, rt, rd) -> `MIPSShiftV (MIPSDSLLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) +| DSRAV (rs, rt, rd) -> `MIPSShiftV (MIPSDSRAV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) +| DSRLV (rs, rt, rd) -> `MIPSShiftV (MIPSDSRLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) +| SLLV (rs, rt, rd) -> `MIPSShiftV (MIPSSLLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) +| SRAV (rs, rt, rd) -> `MIPSShiftV (MIPSSRAV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) +| SRLV (rs, rt, rd) -> `MIPSShiftV (MIPSSRLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) + +| DDIV (rs, rt) -> `MIPSMulDiv (MIPSDDIV , (translate_out_ireg rs), (translate_out_ireg rt)) +| DDIVU (rs, rt) -> `MIPSMulDiv (MIPSDDIVU , (translate_out_ireg rs), (translate_out_ireg rt)) +| DIV (rs, rt) -> `MIPSMulDiv (MIPSDIV , (translate_out_ireg rs), (translate_out_ireg rt)) +| DIVU (rs, rt) -> `MIPSMulDiv (MIPSDIVU , (translate_out_ireg rs), (translate_out_ireg rt)) +| DMULT (rs, rt) -> `MIPSMulDiv (MIPSDMULT , (translate_out_ireg rs), (translate_out_ireg rt)) +| DMULTU (rs, rt) -> `MIPSMulDiv (MIPSDMULTU , (translate_out_ireg rs), (translate_out_ireg rt)) +| MADD (rs, rt) -> `MIPSMulDiv (MIPSMADD , (translate_out_ireg rs), (translate_out_ireg rt)) +| MADDU (rs, rt) -> `MIPSMulDiv (MIPSMADDU , (translate_out_ireg rs), (translate_out_ireg rt)) +| MSUB (rs, rt) -> `MIPSMulDiv (MIPSMSUB , (translate_out_ireg rs), (translate_out_ireg rt)) +| MSUBU (rs, rt) -> `MIPSMulDiv (MIPSMSUBU , (translate_out_ireg rs), (translate_out_ireg rt)) +| MULT (rs, rt) -> `MIPSMulDiv (MIPSMULT , (translate_out_ireg rs), (translate_out_ireg rt)) +| MULTU (rs, rt) -> `MIPSMulDiv (MIPSMULTU , (translate_out_ireg rs), (translate_out_ireg rt)) + +| MFHI (rs) -> `MIPSMFHiLo (MIPSMFHI, (translate_out_ireg rs)) +| MFLO (rs) -> `MIPSMFHiLo (MIPSMFLO, (translate_out_ireg rs)) +| MTHI (rs) -> `MIPSMFHiLo (MIPSMTHI, (translate_out_ireg rs)) +| MTLO (rs) -> `MIPSMFHiLo (MIPSMTLO, (translate_out_ireg rs)) + +| LUI (rt, imm) -> `MIPSLUI ((translate_out_ireg rt), (translate_out_imm16 imm)) +| Load (width, signed, linked, base, rt, offset) -> + `MIPSLoad ( + (translate_out_wordWidth width), + (translate_out_bool signed), + (translate_out_bool linked), + (translate_out_ireg base), + (translate_out_ireg rt), + (translate_out_simm16 offset) + ) +| Store (width, conditional, base, rt, offset) -> + `MIPSStore ( + (translate_out_wordWidth width), + (translate_out_bool conditional), + (translate_out_ireg base), + (translate_out_ireg rt), + (translate_out_simm16 offset) + ) +| LWL (base, rt, offset) -> `MIPSLSLR (false, false, true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| LWR (base, rt, offset) -> `MIPSLSLR (false, false, false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| LDL (base, rt, offset) -> `MIPSLSLR (false, true , true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| LDR (base, rt, offset) -> `MIPSLSLR (false, true , false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| SWL (base, rt, offset) -> `MIPSLSLR (true , false, true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| SWR (base, rt, offset) -> `MIPSLSLR (true , false, false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| SDL (base, rt, offset) -> `MIPSLSLR (true , true , true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| SDR (base, rt, offset) -> `MIPSLSLR (true , true , false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) +| SYNC -> `MIPSSYNC +| BEQ (rs, rt, offset, ne, likely) -> `MIPSBEQ ((translate_out_ireg rs), (translate_out_ireg rt), (translate_out_simm16 offset), (translate_out_bool ne), (translate_out_bool likely)) +| BCMPZ (rs, offset, cmp, link, likely) -> `MIPSBCMPZ ((translate_out_ireg rs), (translate_out_simm16 offset), (translate_out_cmp cmp), (translate_out_bool link), (translate_out_bool likely)) +| J (offset) -> `MIPSJ (translate_out_imm26 offset) +| JAL (offset) -> `MIPSJAL (translate_out_imm26 offset) +| JR (rd) -> `MIPSJR (translate_out_ireg rd) +| JALR (rd, rs) -> `MIPSJALR (translate_out_ireg rd, translate_out_ireg rs) + diff --git a/mips/gen/shallow_types_to_herdtools_types.hgen b/mips/gen/shallow_types_to_herdtools_types.hgen new file mode 100644 index 00000000..a02d83b7 --- /dev/null +++ b/mips/gen/shallow_types_to_herdtools_types.hgen @@ -0,0 +1,39 @@ +let translate_out_big_bit = Sail_values.unsigned + +let translate_out_int inst = (Nat_big_num.to_int (translate_out_big_bit inst)) +let translate_out_signed_int inst bits = + let i = (Nat_big_num.to_int (translate_out_big_bit inst)) in + if (i >= (1 lsl (bits - 1))) then + (i - (1 lsl bits)) else + i + +let translate_out_ireg ireg = IReg (int_to_ireg (translate_out_int ireg)) + +let translate_out_imm26 imm = translate_out_int imm + +let translate_out_imm16 imm = translate_out_int imm +let translate_out_simm16 imm = translate_out_signed_int imm 16 + +let translate_out_imm5 imm = translate_out_int imm + +let translate_out_bool = function + | Sail_values.B1 -> true + | Sail_values.B0 -> false + | _ -> failwith "translate_out_bool Undef" + + +let translate_out_wordWidth = function + | Mips_embed_types.B2 -> MIPSByte + | Mips_embed_types.H -> MIPSHalf + | Mips_embed_types.W -> MIPSWord + | Mips_embed_types.D -> MIPSDouble + +let translate_out_cmp = function + | Mips_embed_types.EQ' -> MIPS_EQ (* equal *) + | Mips_embed_types.NE -> MIPS_NE (* not equal *) + | Mips_embed_types.GE -> MIPS_GE (* signed greater than or equal *) + | Mips_embed_types.GEU -> MIPS_GEU (* unsigned greater than or equal *) + | Mips_embed_types.GT' -> MIPS_GT (* signed strictly greater than *) + | Mips_embed_types.LE -> MIPS_LE (* signed less than or equal *) + | Mips_embed_types.LT' -> MIPS_LT (* signed strictly less than *) + | Mips_embed_types.LTU -> MIPS_LTU (* unsigned less than or qual *) diff --git a/mips/gen/token_types.hgen b/mips/gen/token_types.hgen new file mode 100644 index 00000000..170b42d3 --- /dev/null +++ b/mips/gen/token_types.hgen @@ -0,0 +1,39 @@ +type token_RTYPE = {txt : string; op : mipsRTypeOp } +type token_ITYPE = {txt : string; op : mipsITypeOp } +type token_ShiftI = {txt : string; op : mipsShiftIOp } +type token_ShiftV = {txt : string; op : mipsShiftVOp } +type token_MulDiv = {txt : string; op : mipsMulDivOp } +type token_MFHiLo = {txt : string; op : mipsMFHiLoOp } +type token_LUI = {txt : string } +type token_Load = {txt : string; width: mipsWordWidth; signed : bool; linked : bool} +type token_Store = {txt : string; width: mipsWordWidth; conditional : bool} +type token_LSLR = {txt : string; store : bool; double : bool; left: bool } (* Load/Store Left/Right *) +type token_SYNC = {txt : string} +type token_BEQ = {txt : string; ne : bool; likely : bool } +type token_BCMPZ = {txt : string; cmp : mipsCmp; likely : bool; link : bool } +type token_J = {txt : string} +type token_JAL = {txt : string} +type token_JR = {txt : string} +type token_JALR = {txt : string} +(* +(regno, imm16, Comparison) TRAPIMM + +(regno, regno) RDHWR +(regno, regno, Comparison) TRAPREG +(regno, regno, bit[3], bool) MFC0 +(regno, regno, bit[3], bool) MTC0 +(regno, regno, imm16, bool, bool) BEQ +TLBP +TLBR +TLBWI +TLBWR + +regregimm16 CACHE +regregimm16 PREF + +unit BREAK +unit ERET +unit HCF +unit SYSCALL +unit WAIT +*) \ No newline at end of file diff --git a/mips/gen/tokens.hgen b/mips/gen/tokens.hgen new file mode 100644 index 00000000..937c6354 --- /dev/null +++ b/mips/gen/tokens.hgen @@ -0,0 +1,17 @@ +%token RTYPE +%token ITYPE +%token SHIFTI +%token SHIFTV +%token MULDIV +%token MFHILO +%token LUI +%token LOAD +%token STORE +%token LSLR +%token SYNC +%token BEQ +%token BCMPZ +%token J +%token JAL +%token JR +%token JALR diff --git a/mips/gen/trans_sail.hgen b/mips/gen/trans_sail.hgen new file mode 100644 index 00000000..e42d1b19 --- /dev/null +++ b/mips/gen/trans_sail.hgen @@ -0,0 +1,122 @@ +| `MIPSThreadStart -> + ("SYSCALL_THREAD_START", [], []) +| `MIPSStopFetching -> + ("ImplementationDefinedStopFetching", + [], + []) + +(* Note different argument order, which reflects difference + between instruction encoding and asm format *) +| `MIPSRType (op, rd, rs, rt) -> + (translate_rtype_op op, + [ + translate_reg "rs" rs; + translate_reg "rt" rt; + translate_reg "rd" rd; + ], + []) + +(* Note different argument order similar to above *) +| `MIPSIType (op, rt, rs, imm) -> + (translate_itype_op op, + [ + translate_reg "rs" rs; + translate_reg "rt" rt; + translate_imm16 "imm" imm; + ], + []) + +| `MIPSShiftI (op, rd, rt, sa) -> + (translate_shifti_op op, + [ + translate_reg "rt" rt; + translate_reg "rd" rd; + translate_imm5 "sa" sa; + ], + []) + +| `MIPSShiftV (op, rd, rt, rs) -> + (translate_shiftv_op op, + [ + translate_reg "rs" rs; + translate_reg "rt" rt; + translate_reg "rd" rd; + ], + []) + +| `MIPSMulDiv (op, rs, rt) -> + (translate_muldiv_op op, + [ + translate_reg "rs" rs; + translate_reg "rt" rt; + ], + []) + +| `MIPSMFHiLo (op, rs) -> + (translate_mfhilo_op op, + [ + translate_reg "rs" rs; + ], + []) +| `MIPSLUI (rt, imm) -> + ("LUI", + [ + translate_reg "rt" rt; + translate_imm16 "imm" imm; + ], + []) +| `MIPSLoad (width, signed, linked, base, rt, offset) -> + ("Load", + [ + translate_wordsize "width" width; + translate_bool "signed" signed; + translate_bool "linked" linked; + translate_reg "base" base; + translate_reg "rt" rt; + translate_imm16 "offset" offset; + ], + []) +| `MIPSStore (width, conditional, base, rt, offset) -> + ("Store", + [ + translate_wordsize "width" width; + translate_bool "conditional" conditional; + translate_reg "base" base; + translate_reg "rt" rt; + translate_imm16 "offset" offset; + ], + []) +| `MIPSLSLR (store, double, left, base, rt, offset) -> + (translate_lslr_op store double left, + [ + translate_reg "base" base; + translate_reg "rt" rt; + translate_imm16 "offset" offset; + ], + []) +| `MIPSSYNC -> ("SYNC", [], []) +| `MIPSBEQ (rs, rt, offset, ne, likely) -> + ("BEQ", + [translate_reg "rs" rs; + translate_reg "rt" rt; + translate_imm16 "offset" offset; + translate_bool "ne" ne; + translate_bool "likely" likely; + ], []) + +| `MIPSBCMPZ (rs, offset, cmp, link, likely) -> + ("BCMPZ", + [translate_reg "rs" rs; + translate_imm16 "offset" offset; + translate_cmp "cmp" cmp; + translate_bool "link" link; + translate_bool "likely" likely; + ], []) +| `MIPSJ (offset) -> + ("J", [translate_imm26 "offset" offset;], []) +| `MIPSJAL (offset) -> + ("JAL", [translate_imm26 "offset" offset;], []) +| `MIPSJR(rd) -> + ("JR", [translate_reg "rd" rd;], []) +| `MIPSJALR(rd, rs) -> + ("JALR", [translate_reg "rd" rd; translate_reg "rs" rs;], []) diff --git a/mips/gen/types.hgen b/mips/gen/types.hgen new file mode 100644 index 00000000..a1c61f4b --- /dev/null +++ b/mips/gen/types.hgen @@ -0,0 +1,209 @@ +type mipsRTypeOp = +| MIPSROpADD +| MIPSROpADDU +| MIPSROpAND +| MIPSROpDADD +| MIPSROpDADDU +| MIPSROpDSUB +| MIPSROpDSUBU +| MIPSROpMOVN +| MIPSROpMOVZ +| MIPSROpMUL +| MIPSROpNOR +| MIPSROpOR +| MIPSROpSLT +| MIPSROpSLTU +| MIPSROpSUB +| MIPSROpSUBU +| MIPSROpXOR + +let pp_rtype_op = function +| MIPSROpADD -> "add" +| MIPSROpADDU -> "addu" +| MIPSROpAND -> "and" +| MIPSROpDADD -> "dadd" +| MIPSROpDADDU -> "daddu" +| MIPSROpDSUB -> "dsub" +| MIPSROpDSUBU -> "dsubu" +| MIPSROpMOVN -> "movn" +| MIPSROpMOVZ -> "movz" +| MIPSROpMUL -> "mul" +| MIPSROpNOR -> "nor" +| MIPSROpOR -> "or" +| MIPSROpSLT -> "slt" +| MIPSROpSLTU -> "sltu" +| MIPSROpSUB -> "sub" +| MIPSROpSUBU -> "subu" +| MIPSROpXOR -> "xor" + +type bit26 = int +type bit16 = int +type bit5 = int + +type mipsITypeOp = +| MIPSIOpADDI +| MIPSIOpADDIU +| MIPSIOpANDI +| MIPSIOpDADDI +| MIPSIOpDADDIU +| MIPSIOpORI +| MIPSIOpSLTI +| MIPSIOpSLTIU +| MIPSIOpXORI + +let pp_itype_op = function +| MIPSIOpADDI -> "addi" +| MIPSIOpADDIU -> "addiu" +| MIPSIOpANDI -> "andi" +| MIPSIOpDADDI -> "daddi" +| MIPSIOpDADDIU -> "daddiu" +| MIPSIOpORI -> "ori" +| MIPSIOpSLTI -> "slti" +| MIPSIOpSLTIU -> "sltiu" +| MIPSIOpXORI -> "xori" + +type mipsShiftIOp = +| MIPSDSLL +| MIPSDSLL32 +| MIPSDSRA +| MIPSDSRA32 +| MIPSDSRL +| MIPSDSRL32 +| MIPSSLL +| MIPSSRA +| MIPSSRL + +let pp_shifti_op = function +| MIPSDSLL -> "dsll" +| MIPSDSLL32 -> "dsll32" +| MIPSDSRA -> "dsra" +| MIPSDSRA32 -> "dsra32" +| MIPSDSRL -> "dsrl" +| MIPSDSRL32 -> "dsrl32" +| MIPSSLL -> "sll" +| MIPSSRA -> "sra" +| MIPSSRL -> "srl" + +type mipsShiftVOp = +| MIPSDSLLV +| MIPSDSRAV +| MIPSDSRLV +| MIPSSLLV +| MIPSSRAV +| MIPSSRLV + +let pp_shiftv_op = function +| MIPSDSLLV -> "dsllv" +| MIPSDSRAV -> "dsrav" +| MIPSDSRLV -> "dsrlv" +| MIPSSLLV -> "sllv" +| MIPSSRAV -> "srav" +| MIPSSRLV -> "srlv" + +type mipsMulDivOp = +| MIPSDDIV +| MIPSDDIVU +| MIPSDIV +| MIPSDIVU +| MIPSDMULT +| MIPSDMULTU +| MIPSMADD +| MIPSMADDU +| MIPSMSUB +| MIPSMSUBU +| MIPSMULT +| MIPSMULTU + +let pp_muldiv_op = function +| MIPSDDIV -> "ddiv" +| MIPSDDIVU -> "ddivu" +| MIPSDIV -> "div" +| MIPSDIVU -> "divu" +| MIPSDMULT -> "dmult" +| MIPSDMULTU -> "dmultu" +| MIPSMADD -> "madd" +| MIPSMADDU -> "maddu" +| MIPSMSUB -> "msub" +| MIPSMSUBU -> "msubu" +| MIPSMULT -> "mult" +| MIPSMULTU -> "multu" + +type mipsMFHiLoOp = +| MIPSMFHI +| MIPSMFLO +| MIPSMTHI +| MIPSMTLO + +let pp_mfhilo_op = function +| MIPSMFHI -> "mfhi" +| MIPSMFLO -> "mflo" +| MIPSMTHI -> "mthi" +| MIPSMTLO -> "mtlo" + +type mipsWordWidth = +| MIPSByte +| MIPSHalf +| MIPSWord +| MIPSDouble + +type mipsCmp = +| MIPS_EQ (* equal *) +| MIPS_NE (* not equal *) +| MIPS_GE (* signed greater than or equal *) +| MIPS_GEU (* unsigned greater than or equal *) +| MIPS_GT (* signed strictly greater than *) +| MIPS_LE (* signed less than or equal *) +| MIPS_LT (* signed strictly less than *) +| MIPS_LTU (* unsigned less than or qual *) + +let pp_load_op width signed linked = match (width, signed, linked) with + | (MIPSByte, true, false) -> "lb" + | (MIPSByte, false, false) -> "lbu" + | (MIPSHalf, true, false) -> "lh" + | (MIPSHalf, false, false) -> "lhu" + | (MIPSWord, true, false) -> "lw" + | (MIPSWord, false, false) -> "lwu" + | (MIPSDouble, false, false) -> "ld" + | (MIPSWord, true, true) -> "ll" + | (MIPSDouble, false, true) -> "lld" + | _ -> failwith "unexpected load op" + +let pp_store_op width conditional = match (width, conditional) with + | (MIPSByte, false) -> "sb" + | (MIPSHalf, false) -> "sh" + | (MIPSWord, false) -> "sw" + | (MIPSDouble, false) -> "sd" + | (MIPSWord, true) -> "sc" + | (MIPSDouble, true) -> "scd" + | _ -> failwith "unexpected store op" + +let pp_lslr_op store double left = match (store, double, left) with + | (false, false, true ) -> "lwl" + | (false, false, false) -> "lwr" + | (false, true , true ) -> "ldl" + | (false, true , false) -> "ldr" + | (true , false, true ) -> "swl" + | (true , false, false) -> "swr" + | (true , true , true ) -> "sdl" + | (true , true , false) -> "sdr" + +let pp_beq_op ne likely = match (ne, likely) with + | (false, false) -> "beq" + | (false, true) -> "beql" + | (true , false) -> "bne" + | (true , true) -> "bnel" + +let pp_bcmpz_op cmp link likely = match (cmp, likely, link) with +| (MIPS_LT, false , false ) -> "bltz" +| (MIPS_LT, false , true ) -> "bltzal" +| (MIPS_LT, true , false ) -> "bltzl" +| (MIPS_LT, true , true ) -> "bltzall" +| (MIPS_GE, false , false ) -> "bgez" +| (MIPS_GE, false , true ) -> "bgezal" +| (MIPS_GE, true , false ) -> "bgezl" +| (MIPS_GE, true , true ) -> "bgezall" +| (MIPS_GT, false , false ) -> "bgtz" +| (MIPS_GT, true , false ) -> "bgtzl" +| (MIPS_LE, false , false ) -> "blez" +| (MIPS_LE, true , false ) -> "blezl" +| _ -> failwith "unknown bcmpz instruction" diff --git a/mips/gen/types_sail_trans_out.hgen b/mips/gen/types_sail_trans_out.hgen new file mode 100644 index 00000000..ebd31fcb --- /dev/null +++ b/mips/gen/types_sail_trans_out.hgen @@ -0,0 +1,47 @@ +let translate_out_big_bit = function + | (name, Bvector _, bits) -> IInt.integer_of_bit_list bits + | _ -> assert false + +let translate_out_int inst = (Nat_big_num.to_int (translate_out_big_bit inst)) +let translate_out_signed_int inst bits = + let i = (Nat_big_num.to_int (translate_out_big_bit inst)) in + if (i >= (1 lsl (bits - 1))) then + (i - (1 lsl bits)) else + i + +let translate_out_ireg ireg = IReg (int_to_ireg (translate_out_int ireg)) + +let translate_out_imm26 imm = translate_out_int imm + +let translate_out_imm16 imm = translate_out_int imm +let translate_out_simm16 imm = translate_out_signed_int imm 16 + +let translate_out_imm5 imm = translate_out_int imm + +let translate_out_bool = function + | (name, Bit, [Bitc_one]) -> true + | (name, Bit, [Bitc_zero]) -> false + | _ -> assert false + +let translate_out_enum (name,_,bits) = + Nat_big_num.to_int (IInt.integer_of_bit_list bits) + +let translate_out_wordWidth inst = + match translate_out_enum inst with + | 0 -> MIPSByte + | 1 -> MIPSHalf + | 2 -> MIPSWord + | 3 -> MIPSDouble + | _ -> failwith "Unknown wordWidth in sail translate out" + +let translate_out_cmp inst = + match translate_out_enum inst with + | 0 -> MIPS_EQ (* equal *) + | 1 -> MIPS_NE (* not equal *) + | 2 -> MIPS_GE (* signed greater than or equal *) + | 3 -> MIPS_GEU (* unsigned greater than or equal *) + | 4 -> MIPS_GT (* signed strictly greater than *) + | 5 -> MIPS_LE (* signed less than or equal *) + | 6 -> MIPS_LT (* signed strictly less than *) + | 7 -> MIPS_LTU (* unsigned less than or qual *) + | _ -> failwith "Unknown mipsCmp in sail translate out" diff --git a/mips/gen/types_trans_sail.hgen b/mips/gen/types_trans_sail.hgen new file mode 100644 index 00000000..63880ae9 --- /dev/null +++ b/mips/gen/types_trans_sail.hgen @@ -0,0 +1,44 @@ +let translate_rtype_op op = uppercase (pp_rtype_op op) +let translate_itype_op op = uppercase (pp_itype_op op) +let translate_shifti_op op = uppercase (pp_shifti_op op) +let translate_shiftv_op op = uppercase (pp_shiftv_op op) +let translate_muldiv_op op = uppercase (pp_muldiv_op op) +let translate_mfhilo_op op = uppercase (pp_mfhilo_op op) +let translate_load_op width signed linked = uppercase (pp_load_op width signed linked) +let translate_store_op width conditional = uppercase (pp_store_op width conditional) +let translate_lslr_op store double left = uppercase (pp_lslr_op store double left) +let translate_beq_op ne likely = uppercase (pp_beq_op ne likely) +let translate_bcmpz_op cmp link likely = uppercase (pp_bcmpz_op cmp link likely) + +let translate_reg name value = + (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int (reg_to_int value))) +let translate_imm26 name value = + (name, Bvector (Some 26), bit_list_of_integer 26 (Nat_big_num.of_int value)) +let translate_imm16 name value = + (name, Bvector (Some 16), bit_list_of_integer 16 (Nat_big_num.of_int value)) +let translate_imm5 name value = + (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int value)) +let translate_bool name value = + (name, Bit, [if value then Bitc_one else Bitc_zero]) +let translate_enum enum_values name value = + let rec bit_count n = + if n = 0 then 0 + else 1 + (bit_count (n lsr 1)) in + let rec find_index element = function + | h::tail -> if h = element then 0 else 1 + (find_index element tail) + | _ -> failwith "translate_enum could not find value" + in + let size = bit_count (List.length enum_values) in + let index = find_index value enum_values in + (name, Range0 (Some size), IInt.bit_list_of_integer size (Nat_big_num.of_int index)) +let translate_wordsize = translate_enum [MIPSByte; MIPSHalf; MIPSWord; MIPSDouble] +let translate_cmp = translate_enum [ +MIPS_EQ ;(* equal *) +MIPS_NE ;(* not equal *) +MIPS_GE ;(* signed greater than or equal *) +MIPS_GEU ;(* unsigned greater than or equal *) +MIPS_GT ;(* signed strictly greater than *) +MIPS_LE ;(* signed less than or equal *) +MIPS_LT ;(* signed strictly less than *) +MIPS_LTU ;(* unsigned less than or qual *) +] \ No newline at end of file diff --git a/mips/hgen/ast.hgen b/mips/hgen/ast.hgen deleted file mode 100644 index a251adff..00000000 --- a/mips/hgen/ast.hgen +++ /dev/null @@ -1,18 +0,0 @@ -| `MIPSThreadStart -| `MIPSRType of mipsRTypeOp * reg * reg * reg -| `MIPSIType of mipsITypeOp * reg * reg * bit16 -| `MIPSShiftI of mipsShiftIOp * reg * reg * bit5 -| `MIPSShiftV of mipsShiftVOp * reg * reg * reg -| `MIPSMulDiv of mipsMulDivOp * reg * reg -| `MIPSMFHiLo of mipsMFHiLoOp * reg -| `MIPSLUI of reg * bit16 -| `MIPSLoad of mipsWordWidth * bool * bool * reg * reg * bit16 (* width, signed, linked, base, rt, offset *) -| `MIPSStore of mipsWordWidth * bool * reg * reg * bit16 (* width, conditional, base, rt, offset *) -| `MIPSLSLR of bool * bool * bool * reg * reg * bit16 (* store, double, left, base, rt, offset *) -| `MIPSSYNC -| `MIPSBEQ of reg * reg * bit16 * bool * bool (* rs, rt, offset, not equal, likely *) -| `MIPSBCMPZ of reg * bit16 * mipsCmp * bool * bool (* rs, offset, cmp, link, likely *) -| `MIPSJ of bit26 -| `MIPSJAL of bit26 -| `MIPSJR of reg -| `MIPSJALR of reg * reg (* rs, rd *) diff --git a/mips/hgen/fold.hgen b/mips/hgen/fold.hgen deleted file mode 100644 index 05b9c808..00000000 --- a/mips/hgen/fold.hgen +++ /dev/null @@ -1,19 +0,0 @@ -| `MIPSThreadStart -> (y_reg, y_sreg) -| `MIPSRType (op, rd, rs, rt) -> fold_reg rt (fold_reg rs (fold_reg rd (y_reg, y_sreg))) -| `MIPSIType (op, rs, rt, imm) -> fold_reg rs (fold_reg rt (y_reg, y_sreg)) -| `MIPSShiftI (op, rd, rt, imm) -> fold_reg rt (fold_reg rd (y_reg, y_sreg)) -| `MIPSShiftV (op, rd, rt, rs) -> fold_reg rs (fold_reg rt (fold_reg rd (y_reg, y_sreg))) -| `MIPSMulDiv (op, rs, rt) -> fold_reg rs (fold_reg rt (y_reg, y_sreg)) -| `MIPSMFHiLo (op, rs) -> fold_reg rs (y_reg, y_sreg) -| `MIPSLUI (rt, imm) -> fold_reg rt (y_reg, y_sreg) -| `MIPSLoad (width, signed, linked, base, rt, offset) -> fold_reg rt (fold_reg base (y_reg, y_sreg)) -| `MIPSStore (width, conditional, base, rt, offset) -> fold_reg rt (fold_reg base (y_reg, y_sreg)) -| `MIPSLSLR (store, double, left, base, rt, offset) -> fold_reg rt (fold_reg base (y_reg, y_sreg)) -| `MIPSSYNC -> (y_reg, y_sreg) -| `MIPSBEQ (rs, rt, offset, ne, likely) -> fold_reg rs (fold_reg rt (y_reg, y_sreg)) -| `MIPSBCMPZ (rs, offset, cmp, link, likely) -> fold_reg rs (y_reg, y_sreg) -| `MIPSJ (offset) -> (y_reg, y_sreg) -| `MIPSJAL (offset) -> fold_reg (IReg(R31)) (y_reg, y_sreg) -| `MIPSJR (rd) -> fold_reg rd (y_reg, y_sreg) -| `MIPSJALR (rd, rs) -> fold_reg rd (fold_reg rs (y_reg, y_sreg)) - diff --git a/mips/hgen/herdtools_ast_to_shallow_ast.hgen b/mips/hgen/herdtools_ast_to_shallow_ast.hgen deleted file mode 100644 index 7b1a58d9..00000000 --- a/mips/hgen/herdtools_ast_to_shallow_ast.hgen +++ /dev/null @@ -1,121 +0,0 @@ -| `MIPSThreadStart -> - SYSCALL_THREAD_START - -| `MIPSStopFetching -> - ImplementationDefinedStopFetching0 - -(* Note different argument order, which reflects difference - between instruction encoding and asm format *) -| `MIPSRType (op, rd, rs, rt) -> - (translate_rtype_op op) - ( - translate_reg "rs" rs, - translate_reg "rt" rt, - translate_reg "rd" rd - ) - - -(* Note different argument order similar to above *) -| `MIPSIType (op, rt, rs, imm) -> - (translate_itype_op op) - ( - translate_reg "rs" rs, - translate_reg "rt" rt, - translate_imm16 "imm" imm - ) - - -| `MIPSShiftI (op, rd, rt, sa) -> - (translate_shifti_op op) - ( - translate_reg "rt" rt, - translate_reg "rd" rd, - translate_imm5 "sa" sa - ) - - -| `MIPSShiftV (op, rd, rt, rs) -> - (translate_shiftv_op op) - ( - translate_reg "rs" rs, - translate_reg "rt" rt, - translate_reg "rd" rd - ) - - -| `MIPSMulDiv (op, rs, rt) -> - (translate_muldiv_op op) - ( - translate_reg "rs" rs, - translate_reg "rt" rt - ) - - -| `MIPSMFHiLo (op, rs) -> - (translate_mfhilo_op op) - ( - translate_reg "rs" rs - ) - -| `MIPSLUI (rt, imm) -> - LUI - ( - translate_reg "rt" rt, - translate_imm16 "imm" imm - ) - -| `MIPSLoad (width, signed, linked, base, rt, offset) -> - Load - ( - translate_wordsize "width" width, - translate_bool "signed" signed, - translate_bool "linked" linked, - translate_reg "base" base, - translate_reg "rt" rt, - translate_imm16 "offset" offset - ) - -| `MIPSStore (width, conditional, base, rt, offset) -> - Store - ( - translate_wordsize "width" width, - translate_bool "conditional" conditional, - translate_reg "base" base, - translate_reg "rt" rt, - translate_imm16 "offset" offset - ) - -| `MIPSLSLR (store, double, left, base, rt, offset) -> - (translate_lslr_op store double left) - ( - translate_reg "base" base, - translate_reg "rt" rt, - translate_imm16 "offset" offset - ) - -| `MIPSSYNC -> SYNC -| `MIPSBEQ (rs, rt, offset, ne, likely) -> - BEQ - (translate_reg "rs" rs, - translate_reg "rt" rt, - translate_imm16 "offset" offset, - translate_bool "ne" ne, - translate_bool "likely" likely - ) - -| `MIPSBCMPZ (rs, offset, cmp, link, likely) -> - BCMPZ - (translate_reg "rs" rs, - translate_imm16 "offset" offset, - translate_cmp "cmp" cmp, - translate_bool "link" link, - translate_bool "likely" likely - ) -| `MIPSJ (offset) -> - J (translate_imm26 "offset" offset) -| `MIPSJAL (offset) -> - JAL (translate_imm26 "offset" offset) -| `MIPSJR(rd) -> - JR (translate_reg "rd" rd) -| `MIPSJALR(rd, rs) -> - JALR (translate_reg "rd" rd, translate_reg "rs" rs) diff --git a/mips/hgen/herdtools_types_to_shallow_types.hgen b/mips/hgen/herdtools_types_to_shallow_types.hgen deleted file mode 100644 index 5a0e3bfc..00000000 --- a/mips/hgen/herdtools_types_to_shallow_types.hgen +++ /dev/null @@ -1,120 +0,0 @@ -let is_inc = false - -let translate_rtype_op op = uppercase (pp_rtype_op op) - -let translate_rtype_op op x = match op with - | MIPSROpADD -> ADD x - | MIPSROpADDU -> ADDU x - | MIPSROpAND -> AND x - | MIPSROpDADD -> DADD x - | MIPSROpDADDU -> DADDU x - | MIPSROpDSUB -> DSUB x - | MIPSROpDSUBU -> DSUBU x - | MIPSROpMOVN -> MOVN x - | MIPSROpMOVZ -> MOVZ x - | MIPSROpMUL -> MUL x - | MIPSROpNOR -> NOR x - | MIPSROpOR -> OR x - | MIPSROpSLT -> SLT x - | MIPSROpSLTU -> SLTU x - | MIPSROpSUB -> SUB x - | MIPSROpSUBU -> SUBU x - | MIPSROpXOR -> XOR x - -let translate_itype_op op x = match op with - | MIPSIOpADDI -> ADDI x - | MIPSIOpADDIU -> ADDIU x - | MIPSIOpANDI -> ANDI x - | MIPSIOpDADDI -> DADDI x - | MIPSIOpDADDIU -> DADDIU x - | MIPSIOpORI -> ORI x - | MIPSIOpSLTI -> SLTI x - | MIPSIOpSLTIU -> SLTIU x - | MIPSIOpXORI -> XORI x - -let translate_shifti_op op x = match op with - | MIPSDSLL -> DSLL x - | MIPSDSLL32 -> DSLL32 x - | MIPSDSRA -> DSRA x - | MIPSDSRA32 -> DSRA32 x - | MIPSDSRL -> DSRL x - | MIPSDSRL32 -> DSRL32 x - | MIPSSLL -> SLL x - | MIPSSRA -> SRA x - | MIPSSRL -> SRL x - -let translate_shiftv_op op x = match op with - | MIPSDSLLV -> DSLLV x - | MIPSDSRAV -> DSRAV x - | MIPSDSRLV -> DSRLV x - | MIPSSLLV -> SLLV x - | MIPSSRAV -> SRAV x - | MIPSSRLV -> SRLV x - -let translate_muldiv_op op x = match op with - | MIPSDDIV -> DDIV x - | MIPSDDIVU -> DDIVU x - | MIPSDIV -> DIV x - | MIPSDIVU -> DIVU x - | MIPSDMULT -> DMULT x - | MIPSDMULTU -> DMULTU x - | MIPSMADD -> MADD x - | MIPSMADDU -> MADDU x - | MIPSMSUB -> MSUB x - | MIPSMSUBU -> MSUBU x - | MIPSMULT -> MULT x - | MIPSMULTU -> MULTU x - -let translate_mfhilo_op op x = match op with - | MIPSMFHI -> MFHI x - | MIPSMFLO -> MFLO x - | MIPSMTHI -> MTHI x - | MIPSMTLO -> MTLO x - -let translate_load_op width signed linked = uppercase (pp_load_op width signed linked) - -let translate_store_op width conditional = uppercase (pp_store_op width conditional) - -let translate_lslr_op store double left x = match (store,double,left) with - | (false, false, true ) -> LWL x - | (false, false, false) -> LWR x - | (false, true , true ) -> LDL x - | (false, true , false) -> LDR x - | (true , false, true ) -> SWL x - | (true , false, false) -> SWR x - | (true , true , true ) -> SDL x - | (true , true , false) -> SDR x - -let translate_beq_op ne likely = uppercase (pp_beq_op ne likely) - -let translate_bcmpz_op cmp link likely = uppercase (pp_bcmpz_op cmp link likely) - - -let translate_reg name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 5,Nat_big_num.of_int (reg_to_int value)) - -let translate_imm26 name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 26,Nat_big_num.of_int value) -let translate_imm16 name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 16,Nat_big_num.of_int value) -let translate_imm5 name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 5,Nat_big_num.of_int value) -let translate_bool name = function - | true -> Sail_values.B1 - | false -> Sail_values.B0 - -let translate_wordsize _ = function - | MIPSByte -> Mips_embed_types.B2 - | MIPSHalf -> Mips_embed_types.H - | MIPSWord -> Mips_embed_types.W - | MIPSDouble -> Mips_embed_types.D - -let translate_cmp _ = function - | MIPS_EQ -> EQ' - | MIPS_NE -> NE - | MIPS_GE -> GE - | MIPS_GEU -> GEU - | MIPS_GT -> GT' - | MIPS_LE -> LE - | MIPS_LT -> LT' - | MIPS_LTU -> LTU diff --git a/mips/hgen/lexer.hgen b/mips/hgen/lexer.hgen deleted file mode 100644 index c01b14cc..00000000 --- a/mips/hgen/lexer.hgen +++ /dev/null @@ -1,116 +0,0 @@ -"add" , RTYPE {txt="ADD" ; op=MIPSROpADD }; -"addu" , RTYPE {txt="ADDU" ; op=MIPSROpADDU }; -"and" , RTYPE {txt="AND" ; op=MIPSROpAND }; -"dadd" , RTYPE {txt="DADD" ; op=MIPSROpDADD }; -"daddu" , RTYPE {txt="DADDU" ; op=MIPSROpDADDU }; -"dsub" , RTYPE {txt="DSUB" ; op=MIPSROpDSUB }; -"dsubu" , RTYPE {txt="DSUBU" ; op=MIPSROpDSUBU }; -"movn" , RTYPE {txt="MOVN" ; op=MIPSROpMOVN }; -"movz" , RTYPE {txt="MOVZ" ; op=MIPSROpMOVZ }; -"mul" , RTYPE {txt="MUL" ; op=MIPSROpMUL }; -"nor" , RTYPE {txt="NOR" ; op=MIPSROpNOR }; -"or" , RTYPE {txt="OR" ; op=MIPSROpOR }; -"slt" , RTYPE {txt="SLT" ; op=MIPSROpSLT }; -"sltu" , RTYPE {txt="SLTU" ; op=MIPSROpSLTU }; -"sub" , RTYPE {txt="SUB" ; op=MIPSROpSUB }; -"subu" , RTYPE {txt="SUBU" ; op=MIPSROpSUBU }; -"xor" , RTYPE {txt="XOR" ; op=MIPSROpXOR }; - -"addi" , ITYPE {txt="ADDI" ; op=MIPSIOpADDI }; -"addiu" , ITYPE {txt="ADDIU" ; op=MIPSIOpADDIU }; -"andi" , ITYPE {txt="ANDI" ; op=MIPSIOpANDI }; -"daddi" , ITYPE {txt="DADDI" ; op=MIPSIOpDADDI }; -"daddiu", ITYPE {txt="DADDIU"; op=MIPSIOpDADDIU }; -"ori" , ITYPE {txt="ORI" ; op=MIPSIOpORI }; -"slti" , ITYPE {txt="SLTI" ; op=MIPSIOpSLTI }; -"sltiu" , ITYPE {txt="SLTIU" ; op=MIPSIOpSLTIU }; -"xori" , ITYPE {txt="XORI" ; op=MIPSIOpXORI }; - -"dsll" , SHIFTI {txt="DSLL" ; op=MIPSDSLL }; -"dsll32" , SHIFTI {txt="DSLL32" ; op=MIPSDSLL32 }; -"dsra" , SHIFTI {txt="DSRA" ; op=MIPSDSRA }; -"dsra32" , SHIFTI {txt="DSRA32" ; op=MIPSDSRA32 }; -"dsrl" , SHIFTI {txt="DSRL" ; op=MIPSDSRL }; -"dsrl32" , SHIFTI {txt="DSRL32" ; op=MIPSDSRL32 }; -"sll" , SHIFTI {txt="SLL" ; op=MIPSSLL }; -"sra" , SHIFTI {txt="SRA" ; op=MIPSSRA }; -"srl" , SHIFTI {txt="SRL" ; op=MIPSSRL }; - -"dsllv", SHIFTV {txt="DSLLV" ; op=MIPSDSLLV }; -"dsrav", SHIFTV {txt="DSRAV" ; op=MIPSDSRAV }; -"dsrlv", SHIFTV {txt="DSRLV" ; op=MIPSDSRLV }; -"sllv" , SHIFTV {txt="SLLV" ; op=MIPSSLLV }; -"srav" , SHIFTV {txt="SRAV" ; op=MIPSSRAV }; -"srlv" , SHIFTV {txt="SRLV" ; op=MIPSSRLV }; - -"ddiv" , MULDIV {txt="DDIV" ; op=MIPSDDIV }; -"ddivu" , MULDIV {txt="DDIVU" ; op=MIPSDDIVU }; -"div" , MULDIV {txt="DIV" ; op=MIPSDIV }; -"divu" , MULDIV {txt="DIVU" ; op=MIPSDIVU }; -"dmult" , MULDIV {txt="DMULT" ; op=MIPSDMULT }; -"dmultu", MULDIV {txt="DMULTU"; op=MIPSDMULTU }; -"madd" , MULDIV {txt="MADD" ; op=MIPSMADD }; -"maddu" , MULDIV {txt="MADDU" ; op=MIPSMADDU }; -"msub" , MULDIV {txt="MSUB" ; op=MIPSMSUB }; -"msubu" , MULDIV {txt="MSUBU" ; op=MIPSMSUBU }; -"mult" , MULDIV {txt="MULT" ; op=MIPSMULT }; -"multu" , MULDIV {txt="MULTU" ; op=MIPSMULTU }; - -"mfhi" , MFHILO {txt="MFHI" ; op=MIPSMFHI }; -"mflo" , MFHILO {txt="MFLO" ; op=MIPSMFLO }; -"mthi" , MFHILO {txt="MTHI" ; op=MIPSMTHI }; -"mtlo" , MFHILO {txt="MTLO" ; op=MIPSMTLO }; - -"lui" , LUI {txt="LUI" }; - -"lb" , LOAD {txt="LB" ; width=MIPSByte ; signed=true; linked=false }; -"lbu" , LOAD {txt="LBU" ; width=MIPSByte ; signed=false; linked=false }; -"lh" , LOAD {txt="LH" ; width=MIPSHalf ; signed=true; linked=false }; -"lhu" , LOAD {txt="LHU" ; width=MIPSHalf ; signed=false; linked=false }; -"lw" , LOAD {txt="LW" ; width=MIPSWord ; signed=true; linked=false }; -"lwu" , LOAD {txt="LWU" ; width=MIPSWord ; signed=false; linked=false }; -"ld" , LOAD {txt="LD" ; width=MIPSDouble ; signed=false; linked=false }; -"ll" , LOAD {txt="LL" ; width=MIPSWord ; signed=true; linked=true }; -"lld" , LOAD {txt="LLD" ; width=MIPSDouble ; signed=false; linked=true }; - -"sb" , STORE {txt="SB" ; width=MIPSByte ; conditional=false }; -"sh" , STORE {txt="SH" ; width=MIPSHalf ; conditional=false }; -"sw" , STORE {txt="SW" ; width=MIPSWord ; conditional=false }; -"sd" , STORE {txt="SD" ; width=MIPSDouble ; conditional=false }; -"sc" , STORE {txt="SC" ; width=MIPSWord ; conditional=true }; -"scd" , STORE {txt="SCD" ; width=MIPSDouble ; conditional=true }; - -"lwl" , LSLR {txt="LWL" ; store=false; double=false; left=true }; -"lwr" , LSLR {txt="LWR" ; store=false; double=false; left=false}; -"ldl" , LSLR {txt="LDL" ; store=false; double=true ; left=true }; -"ldr" , LSLR {txt="LDR" ; store=false; double=true ; left=false}; -"swl" , LSLR {txt="SWL" ; store=true ; double=false; left=true }; -"swr" , LSLR {txt="SWR" ; store=true ; double=false; left=false}; -"sdl" , LSLR {txt="SDL" ; store=true ; double=true ; left=true }; -"sdr" , LSLR {txt="SDR" ; store=true ; double=true ; left=false}; -"sync", SYNC {txt="SYNC"}; - -"beq", BEQ {txt="BEQ"; ne=false; likely=false }; -"beql", BEQ {txt="BEQ"; ne=false; likely=true }; -"bne", BEQ {txt="BEQ"; ne=true ; likely=false }; -"bnel", BEQ {txt="BEQ"; ne=true ; likely=true }; - -"bltz", BCMPZ {txt="BCMPZ"; cmp=MIPS_LT; likely=false; link=false }; -"bltzal", BCMPZ {txt="BCMPZ"; cmp=MIPS_LT; likely=false; link=true }; -"bltzl", BCMPZ {txt="BCMPZ"; cmp=MIPS_LT; likely=true; link=false }; -"bltzall",BCMPZ {txt="BCMPZ"; cmp=MIPS_LT; likely=true; link=true }; - -"bgez", BCMPZ {txt="BCMPZ"; cmp=MIPS_GE; likely=false; link=false }; -"bgezal", BCMPZ {txt="BCMPZ"; cmp=MIPS_GE; likely=false; link=true }; -"bgezl", BCMPZ {txt="BCMPZ"; cmp=MIPS_GE; likely=true; link=false }; -"bgezall",BCMPZ {txt="BCMPZ"; cmp=MIPS_GE; likely=true; link=true }; - -"bgtz", BCMPZ {txt="BCMPZ"; cmp=MIPS_GT; likely=false; link=false }; -"bgtzl", BCMPZ {txt="BCMPZ"; cmp=MIPS_GT; likely=true; link=false }; - -"blez", BCMPZ {txt="BCMPZ"; cmp=MIPS_LE; likely=false; link=false }; -"blezl", BCMPZ {txt="BCMPZ"; cmp=MIPS_LE; likely=true; link=false }; -"j", J {txt="J"}; -"jal", JAL {txt="JAL"}; -"jr", JR {txt="JR"}; -"jalr", JALR {txt="JALR"}; diff --git a/mips/hgen/map.hgen b/mips/hgen/map.hgen deleted file mode 100644 index f5116bae..00000000 --- a/mips/hgen/map.hgen +++ /dev/null @@ -1,19 +0,0 @@ -| `MIPSThreadStart -> `MIPSThreadStart -| `MIPSRType (op, rd, rs, rt) -> `MIPSRType (op, map_reg rd, map_reg rs, map_reg rt) -| `MIPSIType (op, rs, rt, imm) -> `MIPSIType (op, map_reg rs, map_reg rt, imm) -| `MIPSShiftI (op, rd, rt, imm) -> `MIPSShiftI (op, map_reg rd, map_reg rt, imm) -| `MIPSShiftV (op, rd, rt, rs) -> `MIPSShiftV (op, map_reg rd, map_reg rt, map_reg rs) -| `MIPSMulDiv (op, rs, rt) -> `MIPSMulDiv (op, map_reg rs, map_reg rt) -| `MIPSMFHiLo (op, rs) -> `MIPSMFHiLo (op, map_reg rs) -| `MIPSLUI (rt, imm) -> `MIPSLUI (map_reg rt, imm) -| `MIPSLoad (width, signed, linked, base, rt, offset) -> `MIPSLoad (width, signed, linked, map_reg base, map_reg rt, offset) -| `MIPSStore (width, conditional, base, rt, offset) -> `MIPSStore (width, conditional, map_reg base, map_reg rt, offset) -| `MIPSLSLR (store, double, left, base, rt, offset) -> `MIPSLSLR (store, double, left, map_reg base, map_reg rt, offset) -| `MIPSSYNC -> `MIPSSYNC -| `MIPSBEQ (rs, rt, offset, ne, likely) -> `MIPSBEQ (map_reg rs, map_reg rt, offset, ne, likely) -| `MIPSBCMPZ (rs, offset, cmp, link, likely) -> `MIPSBCMPZ (map_reg rs, offset, cmp, link, likely) -| `MIPSJ (offset) -> `MIPSJ (offset) -| `MIPSJAL (offset) -> `MIPSJAL (offset) (* implicit R31? *) -| `MIPSJR (rd) -> `MIPSJR (map_reg rd) -| `MIPSJALR (rd, rs) -> `MIPSJALR(map_reg rd, map_reg rs) - diff --git a/mips/hgen/parser.hgen b/mips/hgen/parser.hgen deleted file mode 100644 index 8f573aa5..00000000 --- a/mips/hgen/parser.hgen +++ /dev/null @@ -1,34 +0,0 @@ -| RTYPE reg COMMA reg COMMA reg - { `MIPSRType ($1.op, $2, $4, $6) } -| ITYPE reg COMMA reg COMMA NUM - { `MIPSIType ($1.op, $2, $4, $6) } -| SHIFTI reg COMMA reg COMMA NUM - { `MIPSShiftI ($1.op, $2, $4, $6) } -| SHIFTV reg COMMA reg COMMA reg - { `MIPSShiftV ($1.op, $2, $4, $6) } -| MULDIV reg COMMA reg - { `MIPSMulDiv ($1.op, $2, $4) } -| MFHILO reg - { `MIPSMFHiLo ($1.op, $2) } -| LUI reg COMMA NUM - { `MIPSLUI ($2, $4) } -| LOAD reg COMMA NUM LPAR reg RPAR - { `MIPSLoad ($1.width, $1.signed, $1.linked, $6, $2, $4) } -| STORE reg COMMA NUM LPAR reg RPAR - { `MIPSStore ($1.width, $1.conditional, $6, $2, $4) } -| LSLR reg COMMA NUM LPAR reg RPAR - { `MIPSLSLR ($1.store, $1.double, $1.left, $6, $2, $4) } -| SYNC - { `MIPSSYNC } -| BEQ reg COMMA reg COMMA NUM - { `MIPSBEQ ( $2, $4, $6, $1.ne, $1.likely) } -| BCMPZ reg COMMA NUM - { `MIPSBCMPZ ( $2, $4, $1.cmp, $1.link, $1.likely) } -| J NUM - { `MIPSJ ($2) } -| JAL NUM - { `MIPSJAL ($2) } -| JR reg - { `MIPSJR ($2) } -| JALR reg COMMA reg - { `MIPSJALR ($2, $4) } diff --git a/mips/hgen/pretty.hgen b/mips/hgen/pretty.hgen deleted file mode 100644 index 98f56f2e..00000000 --- a/mips/hgen/pretty.hgen +++ /dev/null @@ -1,36 +0,0 @@ -| `MIPSThreadStart -> "syscall 0xfffff" (* thread start *) -| `MIPSStopFetching -> "STOP" (* TODO *) -| `MIPSRType (op, rd,rs,rt) -> - sprintf "%s %s,%s,%s" (pp_rtype_op op) (pp_reg rd) (pp_reg rs) (pp_reg rt) -| `MIPSIType (op,rd,rs,imm) -> - sprintf "%s %s,%s,%d" (pp_itype_op op) (pp_reg rd) (pp_reg rs) imm -| `MIPSShiftI (op, rs, rt, imm) -> - sprintf "%s %s,%s,%d" (pp_shifti_op op) (pp_reg rs) (pp_reg rt) imm -| `MIPSShiftV (op, rd,rs,rt) -> - sprintf "%s %s,%s,%s" (pp_shiftv_op op) (pp_reg rd) (pp_reg rs) (pp_reg rt) -| `MIPSMulDiv (op, rs, rt) -> - sprintf "%s %s,%s" (pp_muldiv_op op) (pp_reg rs) (pp_reg rt) -| `MIPSMFHiLo (op, rs) -> - sprintf "%s %s" (pp_mfhilo_op op) (pp_reg rs) -| `MIPSLUI (rt, imm) -> - sprintf "lui %s,%d" (pp_reg rt) imm -| `MIPSLoad (width, signed, linked, base, rt, offset) -> - sprintf "%s %s,%d(%s)" (pp_load_op width signed linked) (pp_reg rt) offset (pp_reg base) -| `MIPSStore (width, conditional, base, rt, offset) -> - sprintf "%s %s,%d(%s)" (pp_store_op width conditional) (pp_reg rt) offset (pp_reg base) -| `MIPSLSLR (store, double, left, base, rt, offset) -> - sprintf "%s %s,%d(%s)" (pp_lslr_op store double left) (pp_reg rt) offset (pp_reg base) -| `MIPSSYNC -> "sync" -| `MIPSBEQ (rs, rt, offset, ne, likely) -> - sprintf "%s %s,%s,.%+d" (pp_beq_op ne likely) (pp_reg rs) (pp_reg rt) offset -| `MIPSBCMPZ (rs, offset, cmp, link, likely) -> - sprintf "%s,%s,.%+d" (pp_bcmpz_op cmp link likely) (pp_reg rs) offset -| `MIPSJ (offset) -> - sprintf "j %d" offset -| `MIPSJAL (offset) -> - sprintf "jal %d" offset -| `MIPSJR(rd) -> - sprintf "jr %s" (pp_reg rd) -| `MIPSJALR(rd, rs) -> - sprintf "jalr %s,%s" (pp_reg rd) (pp_reg rs) - diff --git a/mips/hgen/sail_trans_out.hgen b/mips/hgen/sail_trans_out.hgen deleted file mode 100644 index f2d006e8..00000000 --- a/mips/hgen/sail_trans_out.hgen +++ /dev/null @@ -1,98 +0,0 @@ -| ("SYSCALL_THREAD_START", []) -> `MIPSThreadStart -| ("ADD" , [rs; rt; rd]) -> `MIPSRType (MIPSROpADD , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("ADDU" , [rs; rt; rd]) -> `MIPSRType (MIPSROpADDU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("AND" , [rs; rt; rd]) -> `MIPSRType (MIPSROpAND , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("DADD" , [rs; rt; rd]) -> `MIPSRType (MIPSROpDADD , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("DADDU" , [rs; rt; rd]) -> `MIPSRType (MIPSROpDADDU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("DSUB" , [rs; rt; rd]) -> `MIPSRType (MIPSROpDSUB , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("DSUBU" , [rs; rt; rd]) -> `MIPSRType (MIPSROpDSUBU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("MOVN" , [rs; rt; rd]) -> `MIPSRType (MIPSROpMOVN , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("MOVZ" , [rs; rt; rd]) -> `MIPSRType (MIPSROpMOVZ , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("MUL" , [rs; rt; rd]) -> `MIPSRType (MIPSROpMUL , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("NOR" , [rs; rt; rd]) -> `MIPSRType (MIPSROpNOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("OR" , [rs; rt; rd]) -> `MIPSRType (MIPSROpOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("SLT" , [rs; rt; rd]) -> `MIPSRType (MIPSROpSLT , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("SLTU" , [rs; rt; rd]) -> `MIPSRType (MIPSROpSLTU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("SUB" , [rs; rt; rd]) -> `MIPSRType (MIPSROpSUB , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("SUBU" , [rs; rt; rd]) -> `MIPSRType (MIPSROpSUBU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| ("XOR" , [rs; rt; rd]) -> `MIPSRType (MIPSROpXOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) - -| ("ADDI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpADDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| ("ADDIU" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpADDIU ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| ("ANDI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpANDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) -| ("DADDI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpDADDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| ("DADDIU", [rs; rt; imm]) -> `MIPSIType (MIPSIOpDADDIU,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| ("ORI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpORI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) -| ("SLTI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpSLTI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| ("SLTIU" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpSLTIU ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| ("XORI" , [rs; rt; imm]) -> `MIPSIType (MIPSIOpXORI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) - -| ("DSLL" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSLL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| ("DSLL32" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSLL32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| ("DSRA" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSRA , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| ("DSRA32" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSRA32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| ("DSRL" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSRL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| ("DSRL32" , [rt; rd; sa]) -> `MIPSShiftI (MIPSDSRL32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| ("SLL" , [rt; rd; sa]) -> `MIPSShiftI (MIPSSLL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| ("SRA" , [rt; rd; sa]) -> `MIPSShiftI (MIPSSRA , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| ("SRL" , [rt; rd; sa]) -> `MIPSShiftI (MIPSSRL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) - -| "DSLLV" , [rs; rt; rd] -> `MIPSShiftV (MIPSDSLLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) -| "DSRAV" , [rs; rt; rd] -> `MIPSShiftV (MIPSDSRAV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) -| "DSRLV" , [rs; rt; rd] -> `MIPSShiftV (MIPSDSRLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) -| "SLLV" , [rs; rt; rd] -> `MIPSShiftV (MIPSSLLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) -| "SRAV" , [rs; rt; rd] -> `MIPSShiftV (MIPSSRAV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) -| "SRLV" , [rs; rt; rd] -> `MIPSShiftV (MIPSSRLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) - -| "DDIV" , [rs; rt] -> `MIPSMulDiv (MIPSDDIV , (translate_out_ireg rs), (translate_out_ireg rt)) -| "DDIVU" , [rs; rt] -> `MIPSMulDiv (MIPSDDIVU , (translate_out_ireg rs), (translate_out_ireg rt)) -| "DIV" , [rs; rt] -> `MIPSMulDiv (MIPSDIV , (translate_out_ireg rs), (translate_out_ireg rt)) -| "DIVU" , [rs; rt] -> `MIPSMulDiv (MIPSDIVU , (translate_out_ireg rs), (translate_out_ireg rt)) -| "DMULT" , [rs; rt] -> `MIPSMulDiv (MIPSDMULT , (translate_out_ireg rs), (translate_out_ireg rt)) -| "DMULTU", [rs; rt] -> `MIPSMulDiv (MIPSDMULTU , (translate_out_ireg rs), (translate_out_ireg rt)) -| "MADD" , [rs; rt] -> `MIPSMulDiv (MIPSMADD , (translate_out_ireg rs), (translate_out_ireg rt)) -| "MADDU" , [rs; rt] -> `MIPSMulDiv (MIPSMADDU , (translate_out_ireg rs), (translate_out_ireg rt)) -| "MSUB" , [rs; rt] -> `MIPSMulDiv (MIPSMSUB , (translate_out_ireg rs), (translate_out_ireg rt)) -| "MSUBU" , [rs; rt] -> `MIPSMulDiv (MIPSMSUBU , (translate_out_ireg rs), (translate_out_ireg rt)) -| "MULT" , [rs; rt] -> `MIPSMulDiv (MIPSMULT , (translate_out_ireg rs), (translate_out_ireg rt)) -| "MULTU" , [rs; rt] -> `MIPSMulDiv (MIPSMULTU , (translate_out_ireg rs), (translate_out_ireg rt)) - -| "MFHI" , [rs] -> `MIPSMFHiLo (MIPSMFHI, (translate_out_ireg rs)) -| "MFLO" , [rs] -> `MIPSMFHiLo (MIPSMFLO, (translate_out_ireg rs)) -| "MTHI" , [rs] -> `MIPSMFHiLo (MIPSMTHI, (translate_out_ireg rs)) -| "MTLO" , [rs] -> `MIPSMFHiLo (MIPSMTLO, (translate_out_ireg rs)) - -| "LUI" , [rt; imm] -> `MIPSLUI ((translate_out_ireg rt), (translate_out_imm16 imm)) -| "Load", [width; signed; linked; base; rt; offset] -> - `MIPSLoad ( - (translate_out_wordWidth width), - (translate_out_bool signed), - (translate_out_bool linked), - (translate_out_ireg base), - (translate_out_ireg rt), - (translate_out_simm16 offset) - ) -| "Store", [width; conditional; base; rt; offset] -> - `MIPSStore ( - (translate_out_wordWidth width), - (translate_out_bool conditional), - (translate_out_ireg base), - (translate_out_ireg rt), - (translate_out_simm16 offset) - ) -| "LWL", [base; rt; offset] -> `MIPSLSLR (false, false, true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| "LWR", [base; rt; offset] -> `MIPSLSLR (false, false, false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| "LDL", [base; rt; offset] -> `MIPSLSLR (false, true , true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| "LDR", [base; rt; offset] -> `MIPSLSLR (false, true , false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| "SWL", [base; rt; offset] -> `MIPSLSLR (true , false, true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| "SWR", [base; rt; offset] -> `MIPSLSLR (true , false, false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| "SDL", [base; rt; offset] -> `MIPSLSLR (true , true , true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| "SDR", [base; rt; offset] -> `MIPSLSLR (true , true , false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| "SYNC", [] -> `MIPSSYNC -| "BEQ", [rs; rt; offset; ne; likely] -> `MIPSBEQ ((translate_out_ireg rs), (translate_out_ireg rt), (translate_out_simm16 offset), (translate_out_bool ne), (translate_out_bool likely)) -| "BCMPZ", [rs; offset; cmp; link; likely] -> `MIPSBCMPZ ((translate_out_ireg rs), (translate_out_simm16 offset), (translate_out_cmp cmp), (translate_out_bool link), (translate_out_bool likely)) -| "J", [offset] -> `MIPSJ (translate_out_imm26 offset) -| "JAL", [offset] -> `MIPSJAL (translate_out_imm26 offset) -| "JR", [rd] -> `MIPSJR (translate_out_ireg rd) -| "JALR", [rd; rs] -> `MIPSJALR (translate_out_ireg rd, translate_out_ireg rs) - diff --git a/mips/hgen/shallow_ast_to_herdtools_ast.hgen b/mips/hgen/shallow_ast_to_herdtools_ast.hgen deleted file mode 100644 index efe2c77e..00000000 --- a/mips/hgen/shallow_ast_to_herdtools_ast.hgen +++ /dev/null @@ -1,98 +0,0 @@ -| SYSCALL_THREAD_START -> `MIPSThreadStart -| (ADD (rs, rt, rd)) -> `MIPSRType (MIPSROpADD , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (ADDU (rs, rt, rd)) -> `MIPSRType (MIPSROpADDU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (AND (rs, rt, rd)) -> `MIPSRType (MIPSROpAND , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (DADD (rs, rt, rd)) -> `MIPSRType (MIPSROpDADD , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (DADDU (rs, rt, rd)) -> `MIPSRType (MIPSROpDADDU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (DSUB (rs, rt, rd)) -> `MIPSRType (MIPSROpDSUB , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (DSUBU (rs, rt, rd)) -> `MIPSRType (MIPSROpDSUBU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (MOVN (rs, rt, rd)) -> `MIPSRType (MIPSROpMOVN , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (MOVZ (rs, rt, rd)) -> `MIPSRType (MIPSROpMOVZ , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (MUL (rs, rt, rd)) -> `MIPSRType (MIPSROpMUL , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (NOR (rs, rt, rd)) -> `MIPSRType (MIPSROpNOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (OR (rs, rt, rd)) -> `MIPSRType (MIPSROpOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (SLT (rs, rt, rd)) -> `MIPSRType (MIPSROpSLT , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (SLTU (rs, rt, rd)) -> `MIPSRType (MIPSROpSLTU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (SUB (rs, rt, rd)) -> `MIPSRType (MIPSROpSUB , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (SUBU (rs, rt, rd)) -> `MIPSRType (MIPSROpSUBU , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) -| (XOR (rs, rt, rd)) -> `MIPSRType (MIPSROpXOR , (translate_out_ireg rd), (translate_out_ireg rs), (translate_out_ireg rt)) - -| (ADDI (rs, rt, imm)) -> `MIPSIType (MIPSIOpADDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| (ADDIU (rs, rt, imm)) -> `MIPSIType (MIPSIOpADDIU ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| (ANDI (rs, rt, imm)) -> `MIPSIType (MIPSIOpANDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) -| (DADDI (rs, rt, imm)) -> `MIPSIType (MIPSIOpDADDI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| (DADDIU (rs, rt, imm)) -> `MIPSIType (MIPSIOpDADDIU,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| (ORI (rs, rt, imm)) -> `MIPSIType (MIPSIOpORI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) -| (SLTI (rs, rt, imm)) -> `MIPSIType (MIPSIOpSLTI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| (SLTIU (rs, rt, imm)) -> `MIPSIType (MIPSIOpSLTIU ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_simm16 imm)) -| (XORI (rs, rt, imm)) -> `MIPSIType (MIPSIOpXORI ,(translate_out_ireg rt), (translate_out_ireg rs), (translate_out_imm16 imm)) - -| (DSLL (rt, rd, sa)) -> `MIPSShiftI (MIPSDSLL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| (DSLL32 (rt, rd, sa)) -> `MIPSShiftI (MIPSDSLL32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| (DSRA (rt, rd, sa)) -> `MIPSShiftI (MIPSDSRA , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| (DSRA32 (rt, rd, sa)) -> `MIPSShiftI (MIPSDSRA32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| (DSRL (rt, rd, sa)) -> `MIPSShiftI (MIPSDSRL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| (DSRL32 (rt, rd, sa)) -> `MIPSShiftI (MIPSDSRL32 , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| (SLL (rt, rd, sa)) -> `MIPSShiftI (MIPSSLL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| (SRA (rt, rd, sa)) -> `MIPSShiftI (MIPSSRA , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) -| (SRL (rt, rd, sa)) -> `MIPSShiftI (MIPSSRL , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_imm5 sa)) - -| DSLLV (rs, rt, rd) -> `MIPSShiftV (MIPSDSLLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) -| DSRAV (rs, rt, rd) -> `MIPSShiftV (MIPSDSRAV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) -| DSRLV (rs, rt, rd) -> `MIPSShiftV (MIPSDSRLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) -| SLLV (rs, rt, rd) -> `MIPSShiftV (MIPSSLLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) -| SRAV (rs, rt, rd) -> `MIPSShiftV (MIPSSRAV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) -| SRLV (rs, rt, rd) -> `MIPSShiftV (MIPSSRLV , (translate_out_ireg rd), (translate_out_ireg rt), (translate_out_ireg rs)) - -| DDIV (rs, rt) -> `MIPSMulDiv (MIPSDDIV , (translate_out_ireg rs), (translate_out_ireg rt)) -| DDIVU (rs, rt) -> `MIPSMulDiv (MIPSDDIVU , (translate_out_ireg rs), (translate_out_ireg rt)) -| DIV (rs, rt) -> `MIPSMulDiv (MIPSDIV , (translate_out_ireg rs), (translate_out_ireg rt)) -| DIVU (rs, rt) -> `MIPSMulDiv (MIPSDIVU , (translate_out_ireg rs), (translate_out_ireg rt)) -| DMULT (rs, rt) -> `MIPSMulDiv (MIPSDMULT , (translate_out_ireg rs), (translate_out_ireg rt)) -| DMULTU (rs, rt) -> `MIPSMulDiv (MIPSDMULTU , (translate_out_ireg rs), (translate_out_ireg rt)) -| MADD (rs, rt) -> `MIPSMulDiv (MIPSMADD , (translate_out_ireg rs), (translate_out_ireg rt)) -| MADDU (rs, rt) -> `MIPSMulDiv (MIPSMADDU , (translate_out_ireg rs), (translate_out_ireg rt)) -| MSUB (rs, rt) -> `MIPSMulDiv (MIPSMSUB , (translate_out_ireg rs), (translate_out_ireg rt)) -| MSUBU (rs, rt) -> `MIPSMulDiv (MIPSMSUBU , (translate_out_ireg rs), (translate_out_ireg rt)) -| MULT (rs, rt) -> `MIPSMulDiv (MIPSMULT , (translate_out_ireg rs), (translate_out_ireg rt)) -| MULTU (rs, rt) -> `MIPSMulDiv (MIPSMULTU , (translate_out_ireg rs), (translate_out_ireg rt)) - -| MFHI (rs) -> `MIPSMFHiLo (MIPSMFHI, (translate_out_ireg rs)) -| MFLO (rs) -> `MIPSMFHiLo (MIPSMFLO, (translate_out_ireg rs)) -| MTHI (rs) -> `MIPSMFHiLo (MIPSMTHI, (translate_out_ireg rs)) -| MTLO (rs) -> `MIPSMFHiLo (MIPSMTLO, (translate_out_ireg rs)) - -| LUI (rt, imm) -> `MIPSLUI ((translate_out_ireg rt), (translate_out_imm16 imm)) -| Load (width, signed, linked, base, rt, offset) -> - `MIPSLoad ( - (translate_out_wordWidth width), - (translate_out_bool signed), - (translate_out_bool linked), - (translate_out_ireg base), - (translate_out_ireg rt), - (translate_out_simm16 offset) - ) -| Store (width, conditional, base, rt, offset) -> - `MIPSStore ( - (translate_out_wordWidth width), - (translate_out_bool conditional), - (translate_out_ireg base), - (translate_out_ireg rt), - (translate_out_simm16 offset) - ) -| LWL (base, rt, offset) -> `MIPSLSLR (false, false, true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| LWR (base, rt, offset) -> `MIPSLSLR (false, false, false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| LDL (base, rt, offset) -> `MIPSLSLR (false, true , true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| LDR (base, rt, offset) -> `MIPSLSLR (false, true , false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| SWL (base, rt, offset) -> `MIPSLSLR (true , false, true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| SWR (base, rt, offset) -> `MIPSLSLR (true , false, false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| SDL (base, rt, offset) -> `MIPSLSLR (true , true , true , (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| SDR (base, rt, offset) -> `MIPSLSLR (true , true , false, (translate_out_ireg base), (translate_out_ireg rt), (translate_out_simm16 offset)) -| SYNC -> `MIPSSYNC -| BEQ (rs, rt, offset, ne, likely) -> `MIPSBEQ ((translate_out_ireg rs), (translate_out_ireg rt), (translate_out_simm16 offset), (translate_out_bool ne), (translate_out_bool likely)) -| BCMPZ (rs, offset, cmp, link, likely) -> `MIPSBCMPZ ((translate_out_ireg rs), (translate_out_simm16 offset), (translate_out_cmp cmp), (translate_out_bool link), (translate_out_bool likely)) -| J (offset) -> `MIPSJ (translate_out_imm26 offset) -| JAL (offset) -> `MIPSJAL (translate_out_imm26 offset) -| JR (rd) -> `MIPSJR (translate_out_ireg rd) -| JALR (rd, rs) -> `MIPSJALR (translate_out_ireg rd, translate_out_ireg rs) - diff --git a/mips/hgen/shallow_types_to_herdtools_types.hgen b/mips/hgen/shallow_types_to_herdtools_types.hgen deleted file mode 100644 index a02d83b7..00000000 --- a/mips/hgen/shallow_types_to_herdtools_types.hgen +++ /dev/null @@ -1,39 +0,0 @@ -let translate_out_big_bit = Sail_values.unsigned - -let translate_out_int inst = (Nat_big_num.to_int (translate_out_big_bit inst)) -let translate_out_signed_int inst bits = - let i = (Nat_big_num.to_int (translate_out_big_bit inst)) in - if (i >= (1 lsl (bits - 1))) then - (i - (1 lsl bits)) else - i - -let translate_out_ireg ireg = IReg (int_to_ireg (translate_out_int ireg)) - -let translate_out_imm26 imm = translate_out_int imm - -let translate_out_imm16 imm = translate_out_int imm -let translate_out_simm16 imm = translate_out_signed_int imm 16 - -let translate_out_imm5 imm = translate_out_int imm - -let translate_out_bool = function - | Sail_values.B1 -> true - | Sail_values.B0 -> false - | _ -> failwith "translate_out_bool Undef" - - -let translate_out_wordWidth = function - | Mips_embed_types.B2 -> MIPSByte - | Mips_embed_types.H -> MIPSHalf - | Mips_embed_types.W -> MIPSWord - | Mips_embed_types.D -> MIPSDouble - -let translate_out_cmp = function - | Mips_embed_types.EQ' -> MIPS_EQ (* equal *) - | Mips_embed_types.NE -> MIPS_NE (* not equal *) - | Mips_embed_types.GE -> MIPS_GE (* signed greater than or equal *) - | Mips_embed_types.GEU -> MIPS_GEU (* unsigned greater than or equal *) - | Mips_embed_types.GT' -> MIPS_GT (* signed strictly greater than *) - | Mips_embed_types.LE -> MIPS_LE (* signed less than or equal *) - | Mips_embed_types.LT' -> MIPS_LT (* signed strictly less than *) - | Mips_embed_types.LTU -> MIPS_LTU (* unsigned less than or qual *) diff --git a/mips/hgen/token_types.hgen b/mips/hgen/token_types.hgen deleted file mode 100644 index 170b42d3..00000000 --- a/mips/hgen/token_types.hgen +++ /dev/null @@ -1,39 +0,0 @@ -type token_RTYPE = {txt : string; op : mipsRTypeOp } -type token_ITYPE = {txt : string; op : mipsITypeOp } -type token_ShiftI = {txt : string; op : mipsShiftIOp } -type token_ShiftV = {txt : string; op : mipsShiftVOp } -type token_MulDiv = {txt : string; op : mipsMulDivOp } -type token_MFHiLo = {txt : string; op : mipsMFHiLoOp } -type token_LUI = {txt : string } -type token_Load = {txt : string; width: mipsWordWidth; signed : bool; linked : bool} -type token_Store = {txt : string; width: mipsWordWidth; conditional : bool} -type token_LSLR = {txt : string; store : bool; double : bool; left: bool } (* Load/Store Left/Right *) -type token_SYNC = {txt : string} -type token_BEQ = {txt : string; ne : bool; likely : bool } -type token_BCMPZ = {txt : string; cmp : mipsCmp; likely : bool; link : bool } -type token_J = {txt : string} -type token_JAL = {txt : string} -type token_JR = {txt : string} -type token_JALR = {txt : string} -(* -(regno, imm16, Comparison) TRAPIMM - -(regno, regno) RDHWR -(regno, regno, Comparison) TRAPREG -(regno, regno, bit[3], bool) MFC0 -(regno, regno, bit[3], bool) MTC0 -(regno, regno, imm16, bool, bool) BEQ -TLBP -TLBR -TLBWI -TLBWR - -regregimm16 CACHE -regregimm16 PREF - -unit BREAK -unit ERET -unit HCF -unit SYSCALL -unit WAIT -*) \ No newline at end of file diff --git a/mips/hgen/tokens.hgen b/mips/hgen/tokens.hgen deleted file mode 100644 index 937c6354..00000000 --- a/mips/hgen/tokens.hgen +++ /dev/null @@ -1,17 +0,0 @@ -%token RTYPE -%token ITYPE -%token SHIFTI -%token SHIFTV -%token MULDIV -%token MFHILO -%token LUI -%token LOAD -%token STORE -%token LSLR -%token SYNC -%token BEQ -%token BCMPZ -%token J -%token JAL -%token JR -%token JALR diff --git a/mips/hgen/trans_sail.hgen b/mips/hgen/trans_sail.hgen deleted file mode 100644 index e42d1b19..00000000 --- a/mips/hgen/trans_sail.hgen +++ /dev/null @@ -1,122 +0,0 @@ -| `MIPSThreadStart -> - ("SYSCALL_THREAD_START", [], []) -| `MIPSStopFetching -> - ("ImplementationDefinedStopFetching", - [], - []) - -(* Note different argument order, which reflects difference - between instruction encoding and asm format *) -| `MIPSRType (op, rd, rs, rt) -> - (translate_rtype_op op, - [ - translate_reg "rs" rs; - translate_reg "rt" rt; - translate_reg "rd" rd; - ], - []) - -(* Note different argument order similar to above *) -| `MIPSIType (op, rt, rs, imm) -> - (translate_itype_op op, - [ - translate_reg "rs" rs; - translate_reg "rt" rt; - translate_imm16 "imm" imm; - ], - []) - -| `MIPSShiftI (op, rd, rt, sa) -> - (translate_shifti_op op, - [ - translate_reg "rt" rt; - translate_reg "rd" rd; - translate_imm5 "sa" sa; - ], - []) - -| `MIPSShiftV (op, rd, rt, rs) -> - (translate_shiftv_op op, - [ - translate_reg "rs" rs; - translate_reg "rt" rt; - translate_reg "rd" rd; - ], - []) - -| `MIPSMulDiv (op, rs, rt) -> - (translate_muldiv_op op, - [ - translate_reg "rs" rs; - translate_reg "rt" rt; - ], - []) - -| `MIPSMFHiLo (op, rs) -> - (translate_mfhilo_op op, - [ - translate_reg "rs" rs; - ], - []) -| `MIPSLUI (rt, imm) -> - ("LUI", - [ - translate_reg "rt" rt; - translate_imm16 "imm" imm; - ], - []) -| `MIPSLoad (width, signed, linked, base, rt, offset) -> - ("Load", - [ - translate_wordsize "width" width; - translate_bool "signed" signed; - translate_bool "linked" linked; - translate_reg "base" base; - translate_reg "rt" rt; - translate_imm16 "offset" offset; - ], - []) -| `MIPSStore (width, conditional, base, rt, offset) -> - ("Store", - [ - translate_wordsize "width" width; - translate_bool "conditional" conditional; - translate_reg "base" base; - translate_reg "rt" rt; - translate_imm16 "offset" offset; - ], - []) -| `MIPSLSLR (store, double, left, base, rt, offset) -> - (translate_lslr_op store double left, - [ - translate_reg "base" base; - translate_reg "rt" rt; - translate_imm16 "offset" offset; - ], - []) -| `MIPSSYNC -> ("SYNC", [], []) -| `MIPSBEQ (rs, rt, offset, ne, likely) -> - ("BEQ", - [translate_reg "rs" rs; - translate_reg "rt" rt; - translate_imm16 "offset" offset; - translate_bool "ne" ne; - translate_bool "likely" likely; - ], []) - -| `MIPSBCMPZ (rs, offset, cmp, link, likely) -> - ("BCMPZ", - [translate_reg "rs" rs; - translate_imm16 "offset" offset; - translate_cmp "cmp" cmp; - translate_bool "link" link; - translate_bool "likely" likely; - ], []) -| `MIPSJ (offset) -> - ("J", [translate_imm26 "offset" offset;], []) -| `MIPSJAL (offset) -> - ("JAL", [translate_imm26 "offset" offset;], []) -| `MIPSJR(rd) -> - ("JR", [translate_reg "rd" rd;], []) -| `MIPSJALR(rd, rs) -> - ("JALR", [translate_reg "rd" rd; translate_reg "rs" rs;], []) diff --git a/mips/hgen/types.hgen b/mips/hgen/types.hgen deleted file mode 100644 index a1c61f4b..00000000 --- a/mips/hgen/types.hgen +++ /dev/null @@ -1,209 +0,0 @@ -type mipsRTypeOp = -| MIPSROpADD -| MIPSROpADDU -| MIPSROpAND -| MIPSROpDADD -| MIPSROpDADDU -| MIPSROpDSUB -| MIPSROpDSUBU -| MIPSROpMOVN -| MIPSROpMOVZ -| MIPSROpMUL -| MIPSROpNOR -| MIPSROpOR -| MIPSROpSLT -| MIPSROpSLTU -| MIPSROpSUB -| MIPSROpSUBU -| MIPSROpXOR - -let pp_rtype_op = function -| MIPSROpADD -> "add" -| MIPSROpADDU -> "addu" -| MIPSROpAND -> "and" -| MIPSROpDADD -> "dadd" -| MIPSROpDADDU -> "daddu" -| MIPSROpDSUB -> "dsub" -| MIPSROpDSUBU -> "dsubu" -| MIPSROpMOVN -> "movn" -| MIPSROpMOVZ -> "movz" -| MIPSROpMUL -> "mul" -| MIPSROpNOR -> "nor" -| MIPSROpOR -> "or" -| MIPSROpSLT -> "slt" -| MIPSROpSLTU -> "sltu" -| MIPSROpSUB -> "sub" -| MIPSROpSUBU -> "subu" -| MIPSROpXOR -> "xor" - -type bit26 = int -type bit16 = int -type bit5 = int - -type mipsITypeOp = -| MIPSIOpADDI -| MIPSIOpADDIU -| MIPSIOpANDI -| MIPSIOpDADDI -| MIPSIOpDADDIU -| MIPSIOpORI -| MIPSIOpSLTI -| MIPSIOpSLTIU -| MIPSIOpXORI - -let pp_itype_op = function -| MIPSIOpADDI -> "addi" -| MIPSIOpADDIU -> "addiu" -| MIPSIOpANDI -> "andi" -| MIPSIOpDADDI -> "daddi" -| MIPSIOpDADDIU -> "daddiu" -| MIPSIOpORI -> "ori" -| MIPSIOpSLTI -> "slti" -| MIPSIOpSLTIU -> "sltiu" -| MIPSIOpXORI -> "xori" - -type mipsShiftIOp = -| MIPSDSLL -| MIPSDSLL32 -| MIPSDSRA -| MIPSDSRA32 -| MIPSDSRL -| MIPSDSRL32 -| MIPSSLL -| MIPSSRA -| MIPSSRL - -let pp_shifti_op = function -| MIPSDSLL -> "dsll" -| MIPSDSLL32 -> "dsll32" -| MIPSDSRA -> "dsra" -| MIPSDSRA32 -> "dsra32" -| MIPSDSRL -> "dsrl" -| MIPSDSRL32 -> "dsrl32" -| MIPSSLL -> "sll" -| MIPSSRA -> "sra" -| MIPSSRL -> "srl" - -type mipsShiftVOp = -| MIPSDSLLV -| MIPSDSRAV -| MIPSDSRLV -| MIPSSLLV -| MIPSSRAV -| MIPSSRLV - -let pp_shiftv_op = function -| MIPSDSLLV -> "dsllv" -| MIPSDSRAV -> "dsrav" -| MIPSDSRLV -> "dsrlv" -| MIPSSLLV -> "sllv" -| MIPSSRAV -> "srav" -| MIPSSRLV -> "srlv" - -type mipsMulDivOp = -| MIPSDDIV -| MIPSDDIVU -| MIPSDIV -| MIPSDIVU -| MIPSDMULT -| MIPSDMULTU -| MIPSMADD -| MIPSMADDU -| MIPSMSUB -| MIPSMSUBU -| MIPSMULT -| MIPSMULTU - -let pp_muldiv_op = function -| MIPSDDIV -> "ddiv" -| MIPSDDIVU -> "ddivu" -| MIPSDIV -> "div" -| MIPSDIVU -> "divu" -| MIPSDMULT -> "dmult" -| MIPSDMULTU -> "dmultu" -| MIPSMADD -> "madd" -| MIPSMADDU -> "maddu" -| MIPSMSUB -> "msub" -| MIPSMSUBU -> "msubu" -| MIPSMULT -> "mult" -| MIPSMULTU -> "multu" - -type mipsMFHiLoOp = -| MIPSMFHI -| MIPSMFLO -| MIPSMTHI -| MIPSMTLO - -let pp_mfhilo_op = function -| MIPSMFHI -> "mfhi" -| MIPSMFLO -> "mflo" -| MIPSMTHI -> "mthi" -| MIPSMTLO -> "mtlo" - -type mipsWordWidth = -| MIPSByte -| MIPSHalf -| MIPSWord -| MIPSDouble - -type mipsCmp = -| MIPS_EQ (* equal *) -| MIPS_NE (* not equal *) -| MIPS_GE (* signed greater than or equal *) -| MIPS_GEU (* unsigned greater than or equal *) -| MIPS_GT (* signed strictly greater than *) -| MIPS_LE (* signed less than or equal *) -| MIPS_LT (* signed strictly less than *) -| MIPS_LTU (* unsigned less than or qual *) - -let pp_load_op width signed linked = match (width, signed, linked) with - | (MIPSByte, true, false) -> "lb" - | (MIPSByte, false, false) -> "lbu" - | (MIPSHalf, true, false) -> "lh" - | (MIPSHalf, false, false) -> "lhu" - | (MIPSWord, true, false) -> "lw" - | (MIPSWord, false, false) -> "lwu" - | (MIPSDouble, false, false) -> "ld" - | (MIPSWord, true, true) -> "ll" - | (MIPSDouble, false, true) -> "lld" - | _ -> failwith "unexpected load op" - -let pp_store_op width conditional = match (width, conditional) with - | (MIPSByte, false) -> "sb" - | (MIPSHalf, false) -> "sh" - | (MIPSWord, false) -> "sw" - | (MIPSDouble, false) -> "sd" - | (MIPSWord, true) -> "sc" - | (MIPSDouble, true) -> "scd" - | _ -> failwith "unexpected store op" - -let pp_lslr_op store double left = match (store, double, left) with - | (false, false, true ) -> "lwl" - | (false, false, false) -> "lwr" - | (false, true , true ) -> "ldl" - | (false, true , false) -> "ldr" - | (true , false, true ) -> "swl" - | (true , false, false) -> "swr" - | (true , true , true ) -> "sdl" - | (true , true , false) -> "sdr" - -let pp_beq_op ne likely = match (ne, likely) with - | (false, false) -> "beq" - | (false, true) -> "beql" - | (true , false) -> "bne" - | (true , true) -> "bnel" - -let pp_bcmpz_op cmp link likely = match (cmp, likely, link) with -| (MIPS_LT, false , false ) -> "bltz" -| (MIPS_LT, false , true ) -> "bltzal" -| (MIPS_LT, true , false ) -> "bltzl" -| (MIPS_LT, true , true ) -> "bltzall" -| (MIPS_GE, false , false ) -> "bgez" -| (MIPS_GE, false , true ) -> "bgezal" -| (MIPS_GE, true , false ) -> "bgezl" -| (MIPS_GE, true , true ) -> "bgezall" -| (MIPS_GT, false , false ) -> "bgtz" -| (MIPS_GT, true , false ) -> "bgtzl" -| (MIPS_LE, false , false ) -> "blez" -| (MIPS_LE, true , false ) -> "blezl" -| _ -> failwith "unknown bcmpz instruction" diff --git a/mips/hgen/types_sail_trans_out.hgen b/mips/hgen/types_sail_trans_out.hgen deleted file mode 100644 index ebd31fcb..00000000 --- a/mips/hgen/types_sail_trans_out.hgen +++ /dev/null @@ -1,47 +0,0 @@ -let translate_out_big_bit = function - | (name, Bvector _, bits) -> IInt.integer_of_bit_list bits - | _ -> assert false - -let translate_out_int inst = (Nat_big_num.to_int (translate_out_big_bit inst)) -let translate_out_signed_int inst bits = - let i = (Nat_big_num.to_int (translate_out_big_bit inst)) in - if (i >= (1 lsl (bits - 1))) then - (i - (1 lsl bits)) else - i - -let translate_out_ireg ireg = IReg (int_to_ireg (translate_out_int ireg)) - -let translate_out_imm26 imm = translate_out_int imm - -let translate_out_imm16 imm = translate_out_int imm -let translate_out_simm16 imm = translate_out_signed_int imm 16 - -let translate_out_imm5 imm = translate_out_int imm - -let translate_out_bool = function - | (name, Bit, [Bitc_one]) -> true - | (name, Bit, [Bitc_zero]) -> false - | _ -> assert false - -let translate_out_enum (name,_,bits) = - Nat_big_num.to_int (IInt.integer_of_bit_list bits) - -let translate_out_wordWidth inst = - match translate_out_enum inst with - | 0 -> MIPSByte - | 1 -> MIPSHalf - | 2 -> MIPSWord - | 3 -> MIPSDouble - | _ -> failwith "Unknown wordWidth in sail translate out" - -let translate_out_cmp inst = - match translate_out_enum inst with - | 0 -> MIPS_EQ (* equal *) - | 1 -> MIPS_NE (* not equal *) - | 2 -> MIPS_GE (* signed greater than or equal *) - | 3 -> MIPS_GEU (* unsigned greater than or equal *) - | 4 -> MIPS_GT (* signed strictly greater than *) - | 5 -> MIPS_LE (* signed less than or equal *) - | 6 -> MIPS_LT (* signed strictly less than *) - | 7 -> MIPS_LTU (* unsigned less than or qual *) - | _ -> failwith "Unknown mipsCmp in sail translate out" diff --git a/mips/hgen/types_trans_sail.hgen b/mips/hgen/types_trans_sail.hgen deleted file mode 100644 index 63880ae9..00000000 --- a/mips/hgen/types_trans_sail.hgen +++ /dev/null @@ -1,44 +0,0 @@ -let translate_rtype_op op = uppercase (pp_rtype_op op) -let translate_itype_op op = uppercase (pp_itype_op op) -let translate_shifti_op op = uppercase (pp_shifti_op op) -let translate_shiftv_op op = uppercase (pp_shiftv_op op) -let translate_muldiv_op op = uppercase (pp_muldiv_op op) -let translate_mfhilo_op op = uppercase (pp_mfhilo_op op) -let translate_load_op width signed linked = uppercase (pp_load_op width signed linked) -let translate_store_op width conditional = uppercase (pp_store_op width conditional) -let translate_lslr_op store double left = uppercase (pp_lslr_op store double left) -let translate_beq_op ne likely = uppercase (pp_beq_op ne likely) -let translate_bcmpz_op cmp link likely = uppercase (pp_bcmpz_op cmp link likely) - -let translate_reg name value = - (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int (reg_to_int value))) -let translate_imm26 name value = - (name, Bvector (Some 26), bit_list_of_integer 26 (Nat_big_num.of_int value)) -let translate_imm16 name value = - (name, Bvector (Some 16), bit_list_of_integer 16 (Nat_big_num.of_int value)) -let translate_imm5 name value = - (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int value)) -let translate_bool name value = - (name, Bit, [if value then Bitc_one else Bitc_zero]) -let translate_enum enum_values name value = - let rec bit_count n = - if n = 0 then 0 - else 1 + (bit_count (n lsr 1)) in - let rec find_index element = function - | h::tail -> if h = element then 0 else 1 + (find_index element tail) - | _ -> failwith "translate_enum could not find value" - in - let size = bit_count (List.length enum_values) in - let index = find_index value enum_values in - (name, Range0 (Some size), IInt.bit_list_of_integer size (Nat_big_num.of_int index)) -let translate_wordsize = translate_enum [MIPSByte; MIPSHalf; MIPSWord; MIPSDouble] -let translate_cmp = translate_enum [ -MIPS_EQ ;(* equal *) -MIPS_NE ;(* not equal *) -MIPS_GE ;(* signed greater than or equal *) -MIPS_GEU ;(* unsigned greater than or equal *) -MIPS_GT ;(* signed strictly greater than *) -MIPS_LE ;(* signed less than or equal *) -MIPS_LT ;(* signed strictly less than *) -MIPS_LTU ;(* unsigned less than or qual *) -] \ No newline at end of file diff --git a/risc-v/gen/ast.hgen b/risc-v/gen/ast.hgen new file mode 100644 index 00000000..b1968173 --- /dev/null +++ b/risc-v/gen/ast.hgen @@ -0,0 +1,17 @@ +| `RISCVUTYPE of bit20 * reg * riscvUop +| `RISCVJAL of bit20 * reg +| `RISCVJALR of bit12 * reg * reg +| `RISCVBType of bit12 * reg * reg * riscvBop +| `RISCVIType of bit12 * reg * reg * riscvIop +| `RISCVShiftIop of bit6 * reg * reg * riscvSop +| `RISCVRType of reg * reg * reg * riscvRop +| `RISCVLoad of bit12 * reg * reg * bool * wordWidth * bool * bool +| `RISCVStore of bit12 * reg * reg * wordWidth * bool * bool +| `RISCVADDIW of bit12 * reg * reg +| `RISCVSHIFTW of bit5 * reg * reg * riscvSop +| `RISCVRTYPEW of reg * reg * reg * riscvRopw +| `RISCVFENCE of bit4 * bit4 +| `RISCVFENCEI +| `RISCVLoadRes of bool * bool * reg * wordWidth * reg +| `RISCVStoreCon of bool * bool * reg * reg * wordWidth * reg +| `RISCVAMO of riscvAmoop * bool * bool * reg * reg * wordWidth * reg diff --git a/risc-v/gen/fold.hgen b/risc-v/gen/fold.hgen new file mode 100644 index 00000000..4c51e114 --- /dev/null +++ b/risc-v/gen/fold.hgen @@ -0,0 +1,16 @@ +| `RISCVThreadStart -> (y_reg, y_sreg) +| `RISCVUTYPE (_, r0, _) -> fold_reg r0 (y_reg, y_sreg) +| `RISCVJAL (_, r0) -> fold_reg r0 (y_reg, y_sreg) +| `RISCVJALR (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVBType (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVIType (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVShiftIop (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVRType (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) +| `RISCVLoad (_, r0, r1, _, _, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVStore (_, r0, r1, _, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVADDIW (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVSHIFTW (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) +| `RISCVRTYPEW (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) +| `RISCVLoadRes (_, _, rs1, _, rd) -> fold_reg rs1 (fold_reg rd (y_reg, y_sreg)) +| `RISCVStoreCon (_, _, rs2, rs1, _, rd) -> fold_reg rs2 (fold_reg rs1 (fold_reg rd (y_reg, y_sreg))) +| `RISCVAMO (_, _, _, rs2, rs1, _, rd) -> fold_reg rs2 (fold_reg rs1 (fold_reg rd (y_reg, y_sreg))) diff --git a/risc-v/gen/herdtools_ast_to_shallow_ast.hgen b/risc-v/gen/herdtools_ast_to_shallow_ast.hgen new file mode 100644 index 00000000..07c1d082 --- /dev/null +++ b/risc-v/gen/herdtools_ast_to_shallow_ast.hgen @@ -0,0 +1,86 @@ +| `RISCVStopFetching -> EBREAK +| `RISCVUTYPE(imm, rd, op) -> UTYPE( + translate_imm20 "imm" imm, + translate_reg "rd" rd, + translate_uop op) +| `RISCVJAL(imm, rd) -> RISCV_JAL( + translate_imm21 "imm" imm, + translate_reg "rd" rd) +| `RISCVJALR(imm, rs, rd) -> RISCV_JALR( + translate_imm12 "imm" imm, + translate_reg "rs" rd, + translate_reg "rd" rd) +| `RISCVBType(imm, rs2, rs1, op) -> BTYPE( + translate_imm13 "imm" imm, + translate_reg "rs2" rs2, + translate_reg "rs1" rs1, + translate_bop op) +| `RISCVIType(imm, rs1, rd, op) -> ITYPE( + translate_imm12 "imm" imm, + translate_reg "rs1" rs1, + translate_reg "rd" rd, + translate_iop op) +| `RISCVShiftIop(imm, rs, rd, op) -> SHIFTIOP( + translate_imm6 "imm" imm, + translate_reg "rs" rs, + translate_reg "rd" rd, + translate_sop op) +| `RISCVRType (rs2, rs1, rd, op) -> RTYPE ( + translate_reg "rs2" rs2, + translate_reg "rs1" rs1, + translate_reg "rd" rd, + translate_rop op) +| `RISCVLoad(imm, rs, rd, unsigned, width, aq, rl) -> LOAD( + translate_imm12 "imm" imm, + translate_reg "rs" rs, + translate_reg "rd" rd, + translate_bool "unsigned" unsigned, + translate_wordWidth width, + translate_bool "aq" aq, + translate_bool "rl" rl) +| `RISCVStore(imm, rs, rd, width, aq, rl) -> STORE ( + translate_imm12 "imm" imm, + translate_reg "rs" rs, + translate_reg "rd" rd, + translate_wordWidth width, + translate_bool "aq" aq, + translate_bool "rl" rl) +| `RISCVADDIW(imm, rs, rd) -> ADDIW( + translate_imm12 "imm" imm, + translate_reg "rs" rs, + translate_reg "rd" rd) +| `RISCVSHIFTW(imm, rs, rd, op) -> SHIFTW( + translate_imm5 "imm" imm, + translate_reg "rs" rs, + translate_reg "rd" rd, + translate_sop op) +| `RISCVRTYPEW(rs2, rs1, rd, op) -> RTYPEW( + translate_reg "rs2" rs2, + translate_reg "rs1" rs1, + translate_reg "rd" rd, + translate_ropw op) +| `RISCVFENCE(pred, succ) -> FENCE( + translate_imm4 "pred" pred, + translate_imm4 "succ" succ) +| `RISCVFENCEI -> FENCEI +| `RISCVLoadRes(aq, rl, rs1, width, rd) -> LOADRES( + translate_bool "aq" aq, + translate_bool "rl" rl, + translate_reg "rs1" rs1, + translate_wordWidth width, + translate_reg "rd" rd) +| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> STORECON( + translate_bool "aq" aq, + translate_bool "rl" rl, + translate_reg "rs2" rs2, + translate_reg "rs1" rs1, + translate_wordWidth width, + translate_reg "rd" rd) +| `RISCVAMO (op, aq, rl, rs2, rs1, width, rd) -> AMO( + translate_amoop op, + translate_bool "aq" aq, + translate_bool "rl" rl, + translate_reg "rs2" rs2, + translate_reg "rs1" rs1, + translate_wordWidth width, + translate_reg "rd" rd) diff --git a/risc-v/gen/herdtools_types_to_shallow_types.hgen b/risc-v/gen/herdtools_types_to_shallow_types.hgen new file mode 100644 index 00000000..e6edd24d --- /dev/null +++ b/risc-v/gen/herdtools_types_to_shallow_types.hgen @@ -0,0 +1,90 @@ +let is_inc = false + +let translate_reg name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 5,Nat_big_num.of_int (reg_to_int value)) + +let translate_uop op = match op with + | RISCVLUI -> RISCV_LUI + | RISCVAUIPC -> RISCV_AUIPC + +let translate_bop op = match op with + | RISCVBEQ -> RISCV_BEQ + | RISCVBNE -> RISCV_BNE + | RISCVBLT -> RISCV_BLT + | RISCVBGE -> RISCV_BGE + | RISCVBLTU -> RISCV_BLTU + | RISCVBGEU -> RISCV_BGEU + +let translate_iop op = match op with + | RISCVADDI -> RISCV_ADDI + | RISCVSLTI -> RISCV_SLTI + | RISCVSLTIU -> RISCV_SLTIU + | RISCVXORI -> RISCV_XORI + | RISCVORI -> RISCV_ORI + | RISCVANDI -> RISCV_ANDI + +let translate_sop op = match op with + | RISCVSLLI -> RISCV_SLLI + | RISCVSRLI -> RISCV_SRLI + | RISCVSRAI -> RISCV_SRAI + +let translate_rop op = match op with + | RISCVADD -> RISCV_ADD + | RISCVSUB -> RISCV_SUB + | RISCVSLL -> RISCV_SLL + | RISCVSLT -> RISCV_SLT + | RISCVSLTU -> RISCV_SLTU + | RISCVXOR -> RISCV_XOR + | RISCVSRL -> RISCV_SRL + | RISCVSRA -> RISCV_SRA + | RISCVOR -> RISCV_OR + | RISCVAND -> RISCV_AND + +let translate_ropw op = match op with + | RISCVADDW -> RISCV_ADDW + | RISCVSUBW -> RISCV_SUBW + | RISCVSLLW -> RISCV_SLLW + | RISCVSRLW -> RISCV_SRLW + | RISCVSRAW -> RISCV_SRAW + +let translate_amoop op = match op with + | RISCVAMOSWAP -> AMOSWAP + | RISCVAMOADD -> AMOADD + | RISCVAMOXOR -> AMOXOR + | RISCVAMOAND -> AMOAND + | RISCVAMOOR -> AMOOR + | RISCVAMOMIN -> AMOMIN + | RISCVAMOMAX -> AMOMAX + | RISCVAMOMINU -> AMOMINU + | RISCVAMOMAXU -> AMOMAXU + +let translate_wordWidth op = match op with + | RISCVBYTE -> BYTE + | RISCVHALF -> HALF + | RISCVWORD -> WORD + | RISCVDOUBLE -> DOUBLE + +let translate_bool name = function + | true -> Sail_values.B1 + | false -> Sail_values.B0 + +let translate_imm21 name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 21,Nat_big_num.of_int value) + +let translate_imm20 name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 20,Nat_big_num.of_int value) + +let translate_imm13 name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 13,Nat_big_num.of_int value) + +let translate_imm12 name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 12,Nat_big_num.of_int value) + +let translate_imm6 name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 6,Nat_big_num.of_int value) + +let translate_imm5 name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 5,Nat_big_num.of_int value) + +let translate_imm4 name value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int 4,Nat_big_num.of_int value) diff --git a/risc-v/gen/lexer.hgen b/risc-v/gen/lexer.hgen new file mode 100644 index 00000000..e42b8a62 --- /dev/null +++ b/risc-v/gen/lexer.hgen @@ -0,0 +1,190 @@ +"lui" , UTYPE { op=RISCVLUI }; +"auipc" , UTYPE { op=RISCVAUIPC }; + +"jal", JAL (); +"jalr", JALR (); + +"beq", BTYPE {op=RISCVBEQ}; +"bne", BTYPE {op=RISCVBNE}; +"blt", BTYPE {op=RISCVBLT}; +"bge", BTYPE {op=RISCVBGE}; +"bltu", BTYPE {op=RISCVBLTU}; +"bgeu", BTYPE {op=RISCVBGEU}; + +"addi", ITYPE {op=RISCVADDI}; +"stli", ITYPE {op=RISCVSLTI}; +"sltiu", ITYPE {op=RISCVSLTIU}; +"xori", ITYPE {op=RISCVXORI}; +"ori", ITYPE {op=RISCVORI}; +"andi", ITYPE {op=RISCVANDI}; + +"slli", SHIFTIOP{op=RISCVSLLI}; +"srli", SHIFTIOP{op=RISCVSRLI}; +"srai", SHIFTIOP{op=RISCVSRAI}; + +"add", RTYPE{op=RISCVADD}; +"sub", RTYPE{op=RISCVSUB}; +"sll", RTYPE{op=RISCVSLL}; +"slt", RTYPE{op=RISCVSLT}; +"sltu", RTYPE{op=RISCVSLT}; +"xor", RTYPE{op=RISCVXOR}; +"srl", RTYPE{op=RISCVSRL}; +"sra", RTYPE{op=RISCVSRA}; +"or", RTYPE{op=RISCVOR}; +"and", RTYPE{op=RISCVAND}; + +"lb", LOAD{unsigned=false; width=RISCVBYTE; aq=false; rl=false}; +"lbu", LOAD{unsigned=true; width=RISCVBYTE; aq=false; rl=false}; +"lh", LOAD{unsigned=false; width=RISCVHALF; aq=false; rl=false}; +"lhu", LOAD{unsigned=true; width=RISCVHALF; aq=false; rl=false}; +"lw", LOAD{unsigned=false; width=RISCVWORD; aq=false; rl=false}; +"lwu", LOAD{unsigned=true; width=RISCVWORD; aq=false; rl=false}; +"ld", LOAD{unsigned=false; width=RISCVDOUBLE; aq=false; rl=false}; + +"lb.aq", LOAD{unsigned=false; width=RISCVBYTE; aq=true; rl=false}; +"lbu.aq", LOAD{unsigned=true; width=RISCVBYTE; aq=true; rl=false}; +"lh.aq", LOAD{unsigned=false; width=RISCVHALF; aq=true; rl=false}; +"lhu.aq", LOAD{unsigned=true; width=RISCVHALF; aq=true; rl=false}; +"lw.aq", LOAD{unsigned=false; width=RISCVWORD; aq=true; rl=false}; +"lwu.aq", LOAD{unsigned=true; width=RISCVWORD; aq=true; rl=false}; +"ld.aq", LOAD{unsigned=false; width=RISCVDOUBLE; aq=true; rl=false}; + +"lb.aq.rl", LOAD{unsigned=false; width=RISCVBYTE; aq=true; rl=true}; +"lbu.aq.rl", LOAD{unsigned=true; width=RISCVBYTE; aq=true; rl=true}; +"lh.aq.rl", LOAD{unsigned=false; width=RISCVHALF; aq=true; rl=true}; +"lhu.aq.rl", LOAD{unsigned=true; width=RISCVHALF; aq=true; rl=true}; +"lw.aq.rl", LOAD{unsigned=false; width=RISCVWORD; aq=true; rl=true}; +"lwu.aq.rl", LOAD{unsigned=true; width=RISCVWORD; aq=true; rl=true}; +"ld.aq.rl", LOAD{unsigned=false; width=RISCVDOUBLE; aq=true; rl=true}; + +"sb", STORE{width=RISCVBYTE; aq=false; rl=false}; +"sh", STORE{width=RISCVHALF; aq=false; rl=false}; +"sw", STORE{width=RISCVWORD; aq=false; rl=false}; +"sd", STORE{width=RISCVDOUBLE; aq=false; rl=false}; + +"sb.rl", STORE{width=RISCVBYTE; aq=false; rl=true}; +"sh.rl", STORE{width=RISCVHALF; aq=false; rl=true}; +"sw.rl", STORE{width=RISCVWORD; aq=false; rl=true}; +"sd.rl", STORE{width=RISCVDOUBLE; aq=false; rl=true}; + +"sb.aq.rl", STORE{width=RISCVBYTE; aq=true; rl=true}; +"sh.aq.rl", STORE{width=RISCVHALF; aq=true; rl=true}; +"sw.aq.rl", STORE{width=RISCVWORD; aq=true; rl=true}; +"sd.aq.rl", STORE{width=RISCVDOUBLE; aq=true; rl=true}; + +"addiw", ADDIW (); + +"slliw", SHIFTW{op=RISCVSLLI}; +"srliw", SHIFTW{op=RISCVSRLI}; +"sraiw", SHIFTW{op=RISCVSRAI}; + +"addw", RTYPEW{op=RISCVADDW}; +"subw", RTYPEW{op=RISCVSUBW}; +"sslw", RTYPEW{op=RISCVSLLW}; +"srlw", RTYPEW{op=RISCVSRLW}; +"sraw", RTYPEW{op=RISCVSRAW}; + +"fence", FENCE (); +"r", FENCEOPTION Fence_R; +"w", FENCEOPTION Fence_W; +"rw", FENCEOPTION Fence_RW; + +"fence.i", FENCEI (); + +"lr.w", LOADRES {width=RISCVWORD; aq=false; rl=false}; +"lr.w.aq", LOADRES {width=RISCVWORD; aq=true; rl=false}; +"lr.w.aq.rl", LOADRES {width=RISCVWORD; aq=true; rl=true}; +"lr.d", LOADRES {width=RISCVDOUBLE; aq=false; rl=false}; +"lr.d.aq", LOADRES {width=RISCVDOUBLE; aq=true; rl=false}; +"lr.d.aq.rl", LOADRES {width=RISCVDOUBLE; aq=true; rl=true}; + +"sc.w", STORECON {width=RISCVWORD; aq=false; rl=false}; +"sc.w.rl", STORECON {width=RISCVWORD; aq=false; rl=true}; +"sc.w.aq.rl", STORECON {width=RISCVWORD; aq=true; rl=true}; +"sc.d", STORECON {width=RISCVDOUBLE; aq=false; rl=false}; +"sc.d.rl", STORECON {width=RISCVDOUBLE; aq=false; rl=true}; +"sc.d.aq.rl", STORECON {width=RISCVDOUBLE; aq=true; rl=true}; + +"amoswap.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOSWAP}; +"amoadd.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOADD}; +"amoand.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOAND}; +"amoor.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOOR}; +"amoxor.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOXOR}; +"amomax.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMAX}; +"amomin.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMIN}; +"amomaxu.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMAXU}; +"amominu.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMINU}; + +"amoswap.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOSWAP}; +"amoadd.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOADD}; +"amoand.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOAND}; +"amoor.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOOR}; +"amoxor.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOXOR}; +"amomax.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMAX}; +"amomin.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMIN}; +"amomaxu.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMAXU}; +"amominu.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMINU}; + +"amoswap.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOSWAP}; +"amoadd.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOADD}; +"amoand.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOAND}; +"amoor.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOOR}; +"amoxor.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOXOR}; +"amomax.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMAX}; +"amomin.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMIN}; +"amomaxu.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMAXU}; +"amominu.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMINU}; + +"amoswap.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOSWAP}; +"amoadd.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOADD}; +"amoand.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOAND}; +"amoor.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOOR}; +"amoxor.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOXOR}; +"amomax.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMAX}; +"amomin.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMIN}; +"amomaxu.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMAXU}; +"amominu.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMINU}; + +"amoswap.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOSWAP}; +"amoadd.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOADD}; +"amoand.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOAND}; +"amoor.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOOR}; +"amoxor.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOXOR}; +"amomax.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMAX}; +"amomin.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMIN}; +"amomaxu.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMAXU}; +"amominu.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMINU}; + +"amoswap.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOSWAP}; +"amoadd.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOADD}; +"amoand.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOAND}; +"amoor.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOOR}; +"amoxor.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOXOR}; +"amomax.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMAX}; +"amomin.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMIN}; +"amomaxu.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMAXU}; +"amominu.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMINU}; + +"amoswap.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOSWAP}; +"amoadd.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOADD}; +"amoand.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOAND}; +"amoor.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOOR}; +"amoxor.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOXOR}; +"amomax.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMAX}; +"amomin.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMIN}; +"amomaxu.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMAXU}; +"amominu.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMINU}; + +"amoswap.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOSWAP}; +"amoadd.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOADD}; +"amoand.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOAND}; +"amoor.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOOR}; +"amoxor.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOXOR}; +"amomax.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMAX}; +"amomin.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMIN}; +"amomaxu.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMAXU}; +"amominu.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMINU}; + +(** pseudo instructions *********************************************) + +"li", LI () diff --git a/risc-v/gen/map.hgen b/risc-v/gen/map.hgen new file mode 100644 index 00000000..bab5ced8 --- /dev/null +++ b/risc-v/gen/map.hgen @@ -0,0 +1,15 @@ +| `RISCVUTYPE (x, r0, y) -> `RISCVUTYPE (x, map_reg r0, y) +| `RISCVJAL (x, r0) -> `RISCVJAL (x, map_reg r0) +| `RISCVJALR (x, r0, r1) -> `RISCVJALR (x, map_reg r0, map_reg r1) +| `RISCVBType (x, r0, r1, y) -> `RISCVBType (x, map_reg r0, map_reg r1, y) +| `RISCVIType (x, r0, r1, y) -> `RISCVIType (x, map_reg r0, map_reg r1, y) +| `RISCVShiftIop (x, r0, r1, y) -> `RISCVShiftIop (x, map_reg r0, map_reg r1, y) +| `RISCVRType (r0, r1, r2, y) -> `RISCVRType (r0, map_reg r1, map_reg r2, y) +| `RISCVLoad (x, r0, r1, y, z, a, b) -> `RISCVLoad (x, map_reg r0, map_reg r1, y, z, a, b) +| `RISCVStore (x, r0, r1, y, z, a) -> `RISCVStore (x, map_reg r0, map_reg r1, y, z, a) +| `RISCVADDIW (x, r0, r1) -> `RISCVADDIW (x, map_reg r0, map_reg r1) +| `RISCVSHIFTW (x, r0, r1, y) -> `RISCVSHIFTW (x, map_reg r0, map_reg r1, y) +| `RISCVRTYPEW (r0, r1, r2, x) -> `RISCVRTYPEW (r0, map_reg r1, map_reg r2, x) +| `RISCVLoadRes (aq, rl, rs1, w, rd) -> `RISCVLoadRes (aq, rl, map_reg rs1, w, map_reg rd) +| `RISCVStoreCon (aq, rl, rs2, rs1, w, rd) -> `RISCVStoreCon (aq, rl, map_reg rs2, map_reg rs1, w, map_reg rd) +| `RISCVAMO (op, aq, rl, rs2, rs1, w, rd) -> `RISCVAMO (op, aq, rl, map_reg rs2, map_reg rs1, w, map_reg rd) diff --git a/risc-v/gen/parser.hgen b/risc-v/gen/parser.hgen new file mode 100644 index 00000000..210e38fb --- /dev/null +++ b/risc-v/gen/parser.hgen @@ -0,0 +1,74 @@ +| UTYPE reg COMMA NUM + { (* it's not clear if NUM here should be before or after filling the + lowest 12 bits with zeros, or if it should be signed or unsigned; + currently assuming: NUM does not include the 12 zeros, and is unsigned *) + if not (iskbituimm 20 $4) then failwith "immediate is not 20bit" + else `RISCVUTYPE ($4, $2, $1.op) } +| JAL reg COMMA NUM + { if not ($4 mod 2 = 0) then failwith "odd offset" + else if not (iskbitsimm 21 $4) then failwith "offset is not 21bit" + else `RISCVJAL ($4, $2) } +| JALR reg COMMA reg COMMA NUM + { if not (iskbitsimm 12 $6) then failwith "offset is not 12bit" + else `RISCVJALR ($6, $4, $2) } +| BTYPE reg COMMA reg COMMA NUM + { if not ($6 mod 2 = 0) then failwith "odd offset" + else if not (iskbitsimm 13 $6) then failwith "offset is not 13bit" + else `RISCVBType ($6, $4, $2, $1.op) } +| ITYPE reg COMMA reg COMMA NUM + { if $1.op <> RISCVSLTIU && not (iskbitsimm 12 $6) then failwith "immediate is not 12bit" + else if $1.op = RISCVSLTIU && not (iskbituimm 12 $6) then failwith "unsigned immediate is not 12bit" + else `RISCVIType ($6, $4, $2, $1.op) } +| ADDIW reg COMMA reg COMMA NUM + { if not (iskbitsimm 12 $6) then failwith "immediate is not 12bit" + else `RISCVADDIW ($6, $4, $2) } +| SHIFTIOP reg COMMA reg COMMA NUM + { if not (iskbituimm 6 $6) then failwith "unsigned immediate is not 6bit" + else `RISCVShiftIop ($6, $4, $2, $1.op) } +| SHIFTW reg COMMA reg COMMA NUM + { if not (iskbituimm 5 $6) then failwith "unsigned immediate is not 5bit" + else `RISCVSHIFTW ($6, $4, $2, $1.op) } +| RTYPE reg COMMA reg COMMA reg + { `RISCVRType ($6, $4, $2, $1.op) } +| LOAD reg COMMA NUM LPAR reg RPAR + { if not (iskbitsimm 12 $4) then failwith "offset is not 12bit" + else `RISCVLoad ($4, $6, $2, $1.unsigned, $1.width, $1.aq, $1.rl) } +| STORE reg COMMA NUM LPAR reg RPAR + { if not (iskbitsimm 12 $4) then failwith "offset is not 12bit" + else `RISCVStore ($4, $2, $6, $1.width, $1.aq, $1.rl) } +| RTYPEW reg COMMA reg COMMA reg + { `RISCVRTYPEW ($6, $4, $2, $1.op) } +| FENCE FENCEOPTION COMMA FENCEOPTION + { match ($2, $4) with + | (Fence_RW, Fence_RW) -> `RISCVFENCE (0b0011, 0b0011) + | (Fence_R, Fence_RW) -> `RISCVFENCE (0b0010, 0b0011) + | (Fence_R, Fence_R) -> `RISCVFENCE (0b0010, 0b0010) + | (Fence_RW, Fence_W) -> `RISCVFENCE (0b0011, 0b0001) + | (Fence_W, Fence_W) -> `RISCVFENCE (0b0001, 0b0001) + | (Fence_RW, Fence_R) -> failwith "'fence rw,r' is not supported" + | (Fence_R, Fence_W) -> failwith "'fence r,w' is not supported" + | (Fence_W, Fence_RW) -> failwith "'fence w,rw' is not supported" + | (Fence_W, Fence_R) -> failwith "'fence w,r' is not supported" + } +| FENCEI + { `RISCVFENCEI } +| LOADRES reg COMMA LPAR reg RPAR + { `RISCVLoadRes ($1.aq, $1.rl, $5, $1.width, $2) } +| LOADRES reg COMMA NUM LPAR reg RPAR + { if $4 <> 0 then failwith "'lr' offset must be 0" else + `RISCVLoadRes ($1.aq, $1.rl, $6, $1.width, $2) } +| STORECON reg COMMA reg COMMA LPAR reg RPAR + { `RISCVStoreCon ($1.aq, $1.rl, $4, $7, $1.width, $2) } +| STORECON reg COMMA reg COMMA NUM LPAR reg RPAR + { if $6 <> 0 then failwith "'sc' offset must be 0" else + `RISCVStoreCon ($1.aq, $1.rl, $4, $8, $1.width, $2) } +| AMO reg COMMA reg COMMA LPAR reg RPAR + { `RISCVAMO ($1.op, $1.aq, $1.rl, $4, $7, $1.width, $2) } +| AMO reg COMMA reg COMMA NUM LPAR reg RPAR + { if $6 <> 0 then failwith "'amo' offset must be 0" else + `RISCVAMO ($1.op, $1.aq, $1.rl, $4, $8, $1.width, $2) } + +/* pseudo-ops */ +| LI reg COMMA NUM + { if not (iskbitsimm 12 $4) then failwith "immediate is not 12bit (li is currently implemented only with small immediate)" + else `RISCVIType ($4, IReg R0, $2, RISCVORI) } diff --git a/risc-v/gen/pretty.hgen b/risc-v/gen/pretty.hgen new file mode 100644 index 00000000..fc1c0000 --- /dev/null +++ b/risc-v/gen/pretty.hgen @@ -0,0 +1,30 @@ +| `RISCVThreadStart -> "start" +| `RISCVStopFetching -> "stop" +| `RISCVUTYPE(imm, rd, op) -> sprintf "%s %s, %d" (pp_riscv_uop op) (pp_reg rd) imm +| `RISCVJAL(imm, rd) -> sprintf "jal %s, %d" (pp_reg rd) imm +| `RISCVJALR(imm, rs, rd) -> sprintf "jalr %s, %s, %d" (pp_reg rd) (pp_reg rs) imm +| `RISCVBType(imm, rs2, rs1, op) -> sprintf "%s %s, %s, %d" (pp_riscv_bop op) (pp_reg rs1) (pp_reg rs2) imm +| `RISCVIType(imm, rs2, rs1, op) -> sprintf "%s %s, %s, %d" (pp_riscv_iop op) (pp_reg rs1) (pp_reg rs2) imm +| `RISCVShiftIop(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm +| `RISCVRType (rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_rop op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) + +| `RISCVLoad(imm, rs, rd, unsigned, width, aq, rl) -> + sprintf "%s %s, %d(%s)" (pp_riscv_load_op (unsigned, width, aq, rl)) (pp_reg rd) imm (pp_reg rs) + +| `RISCVStore(imm, rs2, rs1, width, aq, rl) -> + sprintf "%s %s, %d(%s)" (pp_riscv_store_op (width, aq, rl)) (pp_reg rs2) imm (pp_reg rs1) + +| `RISCVADDIW(imm, rs, rd) -> sprintf "addiw %s, %s, %d" (pp_reg rd) (pp_reg rs) imm +| `RISCVSHIFTW(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm +| `RISCVRTYPEW(rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_ropw op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) +| `RISCVFENCE(pred, succ) -> sprintf "fence %s, %s" (pp_riscv_fence_option pred) (pp_riscv_fence_option succ) +| `RISCVFENCEI -> sprintf "fence.i" + +| `RISCVLoadRes(aq, rl, rs1, width, rd) -> + sprintf "%s %s, (%s)" (pp_riscv_load_reserved_op (aq, rl, width)) (pp_reg rd) (pp_reg rs1) + +| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> + sprintf "%s %s, %s, (%s)" (pp_riscv_store_conditional_op (aq, rl, width)) (pp_reg rd) (pp_reg rs2) (pp_reg rs1) + +| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) -> + sprintf "%s %s, %s, (%s)" (pp_riscv_amo_op (op, aq, rl, width)) (pp_reg rd) (pp_reg rs2) (pp_reg rs1) diff --git a/risc-v/gen/pretty_xml.hgen b/risc-v/gen/pretty_xml.hgen new file mode 100644 index 00000000..b0306161 --- /dev/null +++ b/risc-v/gen/pretty_xml.hgen @@ -0,0 +1,137 @@ +| `RISCVThreadStart -> ("op_thread_start", []) + +| `RISCVStopFetching -> ("op_stop_fetching", []) + +| `RISCVUTYPE(imm, rd, op) -> + ("op_U_type", + [ ("op", pp_riscv_uop op); + ("uimm", sprintf "%d" imm); + ("dest", pp_reg rd); + ]) + +| `RISCVJAL(imm, rd) -> + ("op_jal", + [ ("offset", sprintf "%d" imm); + ("dest", pp_reg rd); + ]) + +| `RISCVJALR(imm, rs1, rd) -> + ("op_jalr", + [ ("offset", sprintf "%d" imm); + ("base", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVBType(imm, rs2, rs1, op) -> + ("op_branch", + [ ("op", pp_riscv_bop op); + ("offset", sprintf "%d" imm); + ("src2", pp_reg rs2); + ("src1", pp_reg rs1); + ]) + +| `RISCVIType(imm, rs1, rd, op) -> + ("op_I_type", + [ ("op", pp_riscv_iop op); + ("iimm", sprintf "%d" imm); + ("src", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVShiftIop(imm, rs1, rd, op) -> + ("op_IS_type", + [ ("op", pp_riscv_sop op); + ("shamt", sprintf "%d" imm); + ("src", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVSHIFTW(imm, rs1, rd, op) -> + ("op_ISW_type", + [ ("op", pp_riscv_sop op); + ("shamt", sprintf "%d" imm); + ("src", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVRType (rs2, rs1, rd, op) -> + ("op_R_type", + [ ("op", pp_riscv_rop op); + ("src2", pp_reg rs2); + ("src1", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVLoad(imm, rs1, rd, unsigned, width, aq, rl) -> + ("op_load", + [ ("aq", if aq then "true" else "false"); + ("rl", if rl then "true" else "false"); + ("width", pp_word_width width); + ("unsigned", if unsigned then "true" else "false"); + ("base", pp_reg rs1); + ("offset", sprintf "%d" imm); + ("dest", pp_reg rd); + ]) + +| `RISCVStore(imm, rs2, rs1, width, aq, rl) -> + ("op_store", + [ ("aq", if aq then "true" else "false"); + ("rl", if rl then "true" else "false"); + ("width", pp_word_width width); + ("src", pp_reg rs2); + ("base", pp_reg rs1); + ("offset", sprintf "%d" imm); + ]) + +| `RISCVADDIW(imm, rs1, rd) -> + ("op_addiw", + [ ("iimm", sprintf "%d" imm); + ("src", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVRTYPEW(rs2, rs1, rd, op) -> + ("op_RW_type", + [ ("op", pp_riscv_ropw op); + ("src2", pp_reg rs2); + ("src1", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVFENCE(pred, succ) -> + ("op_fence", + [ ("pred", pp_riscv_fence_option pred); + ("succ", pp_riscv_fence_option succ); + ]) + +| `RISCVFENCEI -> ("op_fence_i", []) + +| `RISCVLoadRes(aq, rl, rs1, width, rd) -> + ("op_lr", + [ ("aq", if aq then "true" else "false"); + ("rl", if rl then "true" else "false"); + ("width", pp_word_width width); + ("addr", pp_reg rs1); + ("dest", pp_reg rd); + ]) + +| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> + ("op_sc", + [ ("aq", if aq then "true" else "false"); + ("rl", if rl then "true" else "false"); + ("width", pp_word_width width); + ("addr", pp_reg rs1); + ("src", pp_reg rs2); + ("dest", pp_reg rd); + ]) + +| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) -> + ("op_amo", + [ ("op", pp_riscv_amo_op_part op); + ("aq", if aq then "true" else "false"); + ("rl", if rl then "true" else "false"); + ("width", pp_word_width width); + ("src", pp_reg rs2); + ("addr", pp_reg rs1); + ("dest", pp_reg rd); + ]) diff --git a/risc-v/gen/sail_trans_out.hgen b/risc-v/gen/sail_trans_out.hgen new file mode 100644 index 00000000..2f9a80f1 --- /dev/null +++ b/risc-v/gen/sail_trans_out.hgen @@ -0,0 +1,23 @@ +| ("EBREAK", []) -> `RISCVStopFetching +| ("UTYPE", [imm; rd; op]) -> `RISCVUTYPE(translate_out_simm20 imm, translate_out_ireg rd, translate_out_uop op) +| ("JAL", [imm; rd]) -> `RISCVJAL(translate_out_simm21 imm, translate_out_ireg rd) +| ("JALR", [imm; rs; rd]) -> `RISCVJALR(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) +| ("BTYPE", [imm; rs2; rs1; op]) -> `RISCVBType(translate_out_simm13 imm, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_bop op) +| ("ITYPE", [imm; rs1; rd; op]) -> `RISCVIType(translate_out_simm12 imm, translate_out_ireg rs1, translate_out_ireg rd, translate_out_iop op) +| ("SHIFTIOP", [imm; rs; rd; op]) -> `RISCVShiftIop(translate_out_imm6 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) +| ("RTYPE", [rs2; rs1; rd; op]) -> `RISCVRType (translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_rop op) +| ("LOAD", [imm; rs; rd; unsigned; width; aq; rl]) + -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) +| ("STORE", [imm; rs; rd; width; aq; rl]) + -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) +| ("ADDIW", [imm; rs; rd]) -> `RISCVADDIW(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) +| ("SHIFTW", [imm; rs; rd; op]) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) +| ("RTYPEW", [rs2; rs1; rd; op]) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) +| ("FENCE", [pred; succ]) -> `RISCVFENCE(translate_out_imm4 pred, translate_out_imm4 succ) +| ("FENCEI", []) -> `RISCVFENCEI +| ("LOADRES", [aq; rl; rs1; width; rd]) + -> `RISCVLoadRes(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) +| ("STORECON", [aq; rl; rs2; rs1; width; rd]) + -> `RISCVStoreCon(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) +| ("AMO", [op; aq; rl; rs2; rs1; width; rd]) + -> `RISCVAMO(translate_out_amoop op, translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) diff --git a/risc-v/gen/shallow_ast_to_herdtools_ast.hgen b/risc-v/gen/shallow_ast_to_herdtools_ast.hgen new file mode 100644 index 00000000..3025992e --- /dev/null +++ b/risc-v/gen/shallow_ast_to_herdtools_ast.hgen @@ -0,0 +1,23 @@ +| EBREAK -> `RISCVStopFetching +| UTYPE( imm, rd, op) -> `RISCVUTYPE(translate_out_simm20 imm, translate_out_ireg rd, translate_out_uop op) +| RISCV_JAL( imm, rd) -> `RISCVJAL(translate_out_simm21 imm, translate_out_ireg rd) +| RISCV_JALR( imm, rs, rd) -> `RISCVJALR(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) +| BTYPE( imm, rs2, rs1, op) -> `RISCVBType(translate_out_simm13 imm, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_bop op) +| ITYPE( imm, rs1, rd, op) -> `RISCVIType(translate_out_simm12 imm, translate_out_ireg rs1, translate_out_ireg rd, translate_out_iop op) +| SHIFTIOP( imm, rs, rd, op) -> `RISCVShiftIop(translate_out_imm6 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) +| RTYPE( rs2, rs1, rd, op) -> `RISCVRType (translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_rop op) +| LOAD( imm, rs, rd, unsigned, width, aq, rl) + -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) +| STORE( imm, rs, rd, width, aq, rl) + -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) +| ADDIW( imm, rs, rd) -> `RISCVADDIW(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) +| SHIFTW( imm, rs, rd, op) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) +| RTYPEW( rs2, rs1, rd, op) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) +| FENCE( pred, succ) -> `RISCVFENCE(translate_out_imm4 pred, translate_out_imm4 succ) +| FENCEI -> `RISCVFENCEI +| LOADRES( aq, rl, rs1, width, rd) + -> `RISCVLoadRes(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) +| STORECON( aq, rl, rs2, rs1, width, rd) + -> `RISCVStoreCon(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) +| AMO( op, aq, rl, rs2, rs1, width, rd) + -> `RISCVAMO(translate_out_amoop op, translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) diff --git a/risc-v/gen/shallow_types_to_herdtools_types.hgen b/risc-v/gen/shallow_types_to_herdtools_types.hgen new file mode 100644 index 00000000..6b3b7f51 --- /dev/null +++ b/risc-v/gen/shallow_types_to_herdtools_types.hgen @@ -0,0 +1,84 @@ +let translate_out_big_bit = Sail_values.unsigned + +let translate_out_int inst = (Nat_big_num.to_int (translate_out_big_bit inst)) +let translate_out_signed_int inst bits = + let i = (Nat_big_num.to_int (translate_out_big_bit inst)) in + if (i >= (1 lsl (bits - 1))) then + (i - (1 lsl bits)) else + i + +let translate_out_ireg ireg = IReg (int_to_ireg (translate_out_int ireg)) + +let translate_out_uop op = match op with + | RISCV_LUI -> RISCVLUI + | RISCV_AUIPC -> RISCVAUIPC + +let translate_out_bop op = match op with + | RISCV_BEQ -> RISCVBEQ + | RISCV_BNE -> RISCVBNE + | RISCV_BLT -> RISCVBLT + | RISCV_BGE -> RISCVBGE + | RISCV_BLTU -> RISCVBLTU + | RISCV_BGEU -> RISCVBGEU + +let translate_out_iop op = match op with + | RISCV_ADDI -> RISCVADDI + | RISCV_SLTI -> RISCVSLTI + | RISCV_SLTIU -> RISCVSLTIU + | RISCV_XORI -> RISCVXORI + | RISCV_ORI -> RISCVORI + | RISCV_ANDI -> RISCVANDI + +let translate_out_sop op = match op with + | RISCV_SLLI -> RISCVSLLI + | RISCV_SRLI -> RISCVSRLI + | RISCV_SRAI -> RISCVSRAI + +let translate_out_rop op = match op with + | RISCV_ADD -> RISCVADD + | RISCV_SUB -> RISCVSUB + | RISCV_SLL -> RISCVSLL + | RISCV_SLT -> RISCVSLT + | RISCV_SLTU -> RISCVSLTU + | RISCV_XOR -> RISCVXOR + | RISCV_SRL -> RISCVSRL + | RISCV_SRA -> RISCVSRA + | RISCV_OR -> RISCVOR + | RISCV_AND -> RISCVAND + +let translate_out_ropw op = match op with + | RISCV_ADDW -> RISCVADDW + | RISCV_SUBW -> RISCVSUBW + | RISCV_SLLW -> RISCVSLLW + | RISCV_SRLW -> RISCVSRLW + | RISCV_SRAW -> RISCVSRAW + +let translate_out_amoop op = match op with + | AMOSWAP -> RISCVAMOSWAP + | AMOADD -> RISCVAMOADD + | AMOXOR -> RISCVAMOXOR + | AMOAND -> RISCVAMOAND + | AMOOR -> RISCVAMOOR + | AMOMIN -> RISCVAMOMIN + | AMOMAX -> RISCVAMOMAX + | AMOMINU -> RISCVAMOMINU + | AMOMAXU -> RISCVAMOMAXU + +let translate_out_wordWidth op = match op with + | BYTE -> RISCVBYTE + | HALF -> RISCVHALF + | WORD -> RISCVWORD + | DOUBLE -> RISCVDOUBLE + +let translate_out_bool = function + | Sail_values.B1 -> true + | Sail_values.B0 -> false + | _ -> failwith "translate_out_bool Undef" + +let translate_out_simm21 imm = translate_out_signed_int imm 21 +let translate_out_simm20 imm = translate_out_signed_int imm 20 +let translate_out_simm13 imm = translate_out_signed_int imm 13 +let translate_out_simm12 imm = translate_out_signed_int imm 12 +let translate_out_imm6 imm = translate_out_int imm +let translate_out_imm5 imm = translate_out_int imm +let translate_out_imm4 imm = translate_out_int imm diff --git a/risc-v/gen/token_types.hgen b/risc-v/gen/token_types.hgen new file mode 100644 index 00000000..f29e318d --- /dev/null +++ b/risc-v/gen/token_types.hgen @@ -0,0 +1,23 @@ +type token_UTYPE = {op : riscvUop } +type token_JAL = unit +type token_JALR = unit +type token_BType = {op : riscvBop } +type token_IType = {op : riscvIop } +type token_ShiftIop = {op : riscvSop } +type token_RTYPE = {op : riscvRop } +type token_Load = {unsigned: bool; width : wordWidth; aq: bool; rl: bool } +type token_Store = {width : wordWidth; aq: bool; rl: bool } +type token_ADDIW = unit +type token_SHIFTW = {op : riscvSop } +type token_RTYPEW = {op : riscvRopw } +type token_FENCE = unit +type token_FENCEI = unit +type token_LoadRes = {width : wordWidth; aq: bool; rl: bool } +type token_StoreCon = {width : wordWidth; aq: bool; rl: bool } +type token_AMO = {width : wordWidth; aq: bool; rl: bool; op: riscvAmoop } + +type token_FENCEOPTION = Fence_R | Fence_W | Fence_RW + +(* pseudo-ops *) + +type token_LI = unit diff --git a/risc-v/gen/tokens.hgen b/risc-v/gen/tokens.hgen new file mode 100644 index 00000000..f812adbd --- /dev/null +++ b/risc-v/gen/tokens.hgen @@ -0,0 +1,19 @@ +%token UTYPE +%token JAL +%token JALR +%token BTYPE +%token ITYPE +%token SHIFTIOP +%token RTYPE +%token LOAD +%token STORE +%token ADDIW +%token SHIFTW +%token RTYPEW +%token FENCE +%token FENCEOPTION +%token FENCEI +%token LOADRES +%token STORECON +%token AMO +%token LI diff --git a/risc-v/gen/trans_sail.hgen b/risc-v/gen/trans_sail.hgen new file mode 100644 index 00000000..8b7cbe11 --- /dev/null +++ b/risc-v/gen/trans_sail.hgen @@ -0,0 +1,153 @@ +| `RISCVStopFetching -> ("EBREAK", [], []) +| `RISCVUTYPE(imm, rd, op) -> + ("UTYPE", + [ + translate_imm20 "imm" imm; + translate_reg "rd" rd; + translate_uop "op" op; + ], + []) +| `RISCVJAL(imm, rd) -> + ("JAL", + [ + translate_imm21 "imm" imm; + translate_reg "rd" rd; + ], + []) +| `RISCVJALR(imm, rs, rd) -> + ("JALR", + [ + translate_imm12 "imm" imm; + translate_reg "rs" rd; + translate_reg "rd" rd; + ], + []) +| `RISCVBType(imm, rs2, rs1, op) -> + ("BTYPE", + [ + translate_imm13 "imm" imm; + translate_reg "rs2" rs2; + translate_reg "rs1" rs1; + translate_bop "op" op; + ], + []) +| `RISCVIType(imm, rs1, rd, op) -> + ("ITYPE", + [ + translate_imm12 "imm" imm; + translate_reg "rs1" rs1; + translate_reg "rd" rd; + translate_iop "op" op; + ], + []) +| `RISCVShiftIop(imm, rs, rd, op) -> + ("SHIFTIOP", + [ + translate_imm6 "imm" imm; + translate_reg "rs" rs; + translate_reg "rd" rd; + translate_sop "op" op; + ], + []) +| `RISCVRType (rs2, rs1, rd, op) -> + ("RTYPE", + [ + translate_reg "rs2" rs2; + translate_reg "rs1" rs1; + translate_reg "rd" rd; + translate_rop "op" op; + ], + []) +| `RISCVLoad(imm, rs, rd, unsigned, width, aq, rl) -> + ("LOAD", + [ + translate_imm12 "imm" imm; + translate_reg "rs" rs; + translate_reg "rd" rd; + translate_bool "unsigned" unsigned; + translate_width "width" width; + translate_bool "aq" aq; + translate_bool "rl" rl; + ], + []) +| `RISCVStore(imm, rs2, rs1, width, aq, rl) -> + ("STORE", + [ + translate_imm12 "imm" imm; + translate_reg "rs2" rs2; + translate_reg "rs1" rs1; + translate_width "width" width; + translate_bool "aq" aq; + translate_bool "rl" rl; + ], + []) +| `RISCVADDIW(imm, rs, rd) -> + ("ADDIW", + [ + translate_imm12 "imm" imm; + translate_reg "rs" rs; + translate_reg "rd" rd; + ], + []) +| `RISCVSHIFTW(imm, rs, rd, op) -> + ("SHIFTW", + [ + translate_imm5 "imm" imm; + translate_reg "rs" rs; + translate_reg "rd" rd; + translate_sop "op" op; + ], + []) +| `RISCVRTYPEW(rs2, rs1, rd, op) -> + ("RTYPEW", + [ + translate_reg "rs2" rs2; + translate_reg "rs1" rs1; + translate_reg "rd" rd; + translate_ropw "op" op; + ], + []) +| `RISCVFENCE(pred, succ) -> + ("FENCE", + [ + translate_imm4 "pred" pred; + translate_imm4 "succ" succ; + ], + []) +| `RISCVFENCEI -> + ("FENCEI", + [], + []) +| `RISCVLoadRes(aq, rl, rs1, width, rd) -> + ("LOADRES", + [ + translate_bool "aq" aq; + translate_bool "rl" rl; + translate_reg "rs1" rs1; + translate_width "width" width; + translate_reg "rd" rd; + ], + []) +| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> + ("STORECON", + [ + translate_bool "aq" aq; + translate_bool "rl" rl; + translate_reg "rs2" rs2; + translate_reg "rs1" rs1; + translate_width "width" width; + translate_reg "rd" rd; + ], + []) +| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) -> + ("AMO", + [ + translate_amoop "op" op; + translate_bool "aq" aq; + translate_bool "rl" rl; + translate_reg "rs2" rs2; + translate_reg "rs1" rs1; + translate_width "width" width; + translate_reg "rd" rd; + ], + []) diff --git a/risc-v/gen/types.hgen b/risc-v/gen/types.hgen new file mode 100644 index 00000000..a0b75606 --- /dev/null +++ b/risc-v/gen/types.hgen @@ -0,0 +1,172 @@ +type bit20 = int +type bit12 = int +type bit6 = int +type bit5 = int +type bit4 = int + +type riscvUop = (* upper immediate ops *) +| RISCVLUI +| RISCVAUIPC + +let pp_riscv_uop = function +| RISCVLUI -> "lui" +| RISCVAUIPC -> "auipc" + + +type riscvBop = (* branch ops *) +| RISCVBEQ +| RISCVBNE +| RISCVBLT +| RISCVBGE +| RISCVBLTU +| RISCVBGEU + +let pp_riscv_bop = function +| RISCVBEQ -> "beq" +| RISCVBNE -> "bne" +| RISCVBLT -> "blt" +| RISCVBGE -> "bge" +| RISCVBLTU -> "bltu" +| RISCVBGEU -> "bgeu" + +type riscvIop = (* immediate ops *) +| RISCVADDI +| RISCVSLTI +| RISCVSLTIU +| RISCVXORI +| RISCVORI +| RISCVANDI + +let pp_riscv_iop = function +| RISCVADDI -> "addi" +| RISCVSLTI -> "slti" +| RISCVSLTIU -> "sltiu" +| RISCVXORI -> "xori" +| RISCVORI -> "ori" +| RISCVANDI -> "andi" + +type riscvSop = (* shift ops *) +| RISCVSLLI +| RISCVSRLI +| RISCVSRAI + +let pp_riscv_sop = function +| RISCVSLLI -> "slli" +| RISCVSRLI -> "srli" +| RISCVSRAI -> "srai" + +type riscvRop = (* reg-reg ops *) +| RISCVADD +| RISCVSUB +| RISCVSLL +| RISCVSLT +| RISCVSLTU +| RISCVXOR +| RISCVSRL +| RISCVSRA +| RISCVOR +| RISCVAND + +let pp_riscv_rop = function +| RISCVADD -> "add" +| RISCVSUB -> "sub" +| RISCVSLL -> "sll" +| RISCVSLT -> "slt" +| RISCVSLTU -> "sltu" +| RISCVXOR -> "xor" +| RISCVSRL -> "srl" +| RISCVSRA -> "sra" +| RISCVOR -> "or" +| RISCVAND -> "and" + +type riscvRopw = (* reg-reg 32-bit ops *) +| RISCVADDW +| RISCVSUBW +| RISCVSLLW +| RISCVSRLW +| RISCVSRAW + +let pp_riscv_ropw = function +| RISCVADDW -> "addw" +| RISCVSUBW -> "subw" +| RISCVSLLW -> "sllw" +| RISCVSRLW -> "srlw" +| RISCVSRAW -> "sraw" + +type wordWidth = + | RISCVBYTE + | RISCVHALF + | RISCVWORD + | RISCVDOUBLE + +let pp_word_width width : string = + begin match width with + | RISCVBYTE -> "b" + | RISCVHALF -> "h" + | RISCVWORD -> "w" + | RISCVDOUBLE -> "d" + end + +let pp_riscv_load_op (unsigned, width, aq, rl) = + "l" ^ + (pp_word_width width) ^ + (if unsigned then "u" else "") ^ + (if aq then ".aq" else "") ^ + (if rl then ".rl" else "") + +let pp_riscv_store_op (width, aq, rl) = + "s" ^ + (pp_word_width width) ^ + (if aq then ".aq" else "") ^ + (if rl then ".rl" else "") + +let pp_riscv_load_reserved_op (aq, rl, width) = + "lr." ^ + (pp_word_width width) ^ + (if aq then ".aq" else "") ^ + (if rl then ".rl" else "") + +let pp_riscv_store_conditional_op (aq, rl, width) = + "sc." ^ + (pp_word_width width) ^ + (if aq then ".aq" else "") ^ + (if rl then ".rl" else "") + +type riscvAmoop = + | RISCVAMOSWAP + | RISCVAMOADD + | RISCVAMOXOR + | RISCVAMOAND + | RISCVAMOOR + | RISCVAMOMIN + | RISCVAMOMAX + | RISCVAMOMINU + | RISCVAMOMAXU + +let pp_riscv_amo_op_part = function + | RISCVAMOSWAP -> "swap" + | RISCVAMOADD -> "add" + | RISCVAMOXOR -> "xor" + | RISCVAMOAND -> "and" + | RISCVAMOOR -> "or" + | RISCVAMOMIN -> "min" + | RISCVAMOMAX -> "max" + | RISCVAMOMINU -> "minu" + | RISCVAMOMAXU -> "maxu" + +let pp_riscv_amo_op (op, aq, rl, width) = + "amo" ^ + pp_riscv_amo_op_part op ^ + begin match width with + | RISCVWORD -> ".w" + | RISCVDOUBLE -> ".d" + | _ -> assert false + end ^ + (if aq then ".aq" else "") ^ + (if rl then ".rl" else "") + +let pp_riscv_fence_option = function + | 0b0011 -> "rw" + | 0b0010 -> "r" + | 0b0001 -> "w" + | _ -> failwith "unexpected fence option" diff --git a/risc-v/gen/types_sail_trans_out.hgen b/risc-v/gen/types_sail_trans_out.hgen new file mode 100644 index 00000000..66a2020c --- /dev/null +++ b/risc-v/gen/types_sail_trans_out.hgen @@ -0,0 +1,98 @@ +let translate_out_big_bit = function + | (name, Bvector _, bits) -> IInt.integer_of_bit_list bits + | _ -> assert false + +let translate_out_int inst = (Nat_big_num.to_int (translate_out_big_bit inst)) +let translate_out_signed_int inst bits = + let i = (Nat_big_num.to_int (translate_out_big_bit inst)) in + if (i >= (1 lsl (bits - 1))) then + (i - (1 lsl bits)) else + i + +let translate_out_ireg ireg = IReg (int_to_ireg (translate_out_int ireg)) + +let translate_out_simm21 imm = translate_out_signed_int imm 21 +let translate_out_simm20 imm = translate_out_signed_int imm 20 +let translate_out_simm13 imm = translate_out_signed_int imm 13 +let translate_out_simm12 imm = translate_out_signed_int imm 12 +let translate_out_imm6 imm = translate_out_int imm +let translate_out_imm5 imm = translate_out_int imm +let translate_out_imm4 imm = translate_out_int imm + +let translate_out_bool = function + | (name, Bit, [Bitc_one]) -> true + | (name, Bit, [Bitc_zero]) -> false + | _ -> assert false + +let translate_out_enum (name,_,bits) = + Nat_big_num.to_int (IInt.integer_of_bit_list bits) + +let translate_out_wordWidth w = + match translate_out_enum w with + | 0 -> RISCVBYTE + | 1 -> RISCVHALF + | 2 -> RISCVWORD + | 3 -> RISCVDOUBLE + | _ -> failwith "Unknown wordWidth in sail translate out" + +let translate_out_uop op = match translate_out_enum op with + | 0 -> RISCVLUI + | 1 -> RISCVAUIPC + | _ -> failwith "Unknown uop in sail translate out" + +let translate_out_bop op = match translate_out_enum op with +| 0 -> RISCVBEQ +| 1 -> RISCVBNE +| 2 -> RISCVBLT +| 3 -> RISCVBGE +| 4 -> RISCVBLTU +| 5 -> RISCVBGEU +| _ -> failwith "Unknown bop in sail translate out" + +let translate_out_iop op = match translate_out_enum op with +| 0 -> RISCVADDI +| 1 -> RISCVSLTI +| 2 -> RISCVSLTIU +| 3 -> RISCVXORI +| 4 -> RISCVORI +| 5 -> RISCVANDI +| _ -> failwith "Unknown iop in sail translate out" + +let translate_out_sop op = match translate_out_enum op with +| 0 -> RISCVSLLI +| 1 -> RISCVSRLI +| 2 -> RISCVSRAI +| _ -> failwith "Unknown sop in sail translate out" + +let translate_out_rop op = match translate_out_enum op with +| 0 -> RISCVADD +| 1 -> RISCVSUB +| 2 -> RISCVSLL +| 3 -> RISCVSLT +| 4 -> RISCVSLTU +| 5 -> RISCVXOR +| 6 -> RISCVSRL +| 7 -> RISCVSRA +| 8 -> RISCVOR +| 9 -> RISCVAND +| _ -> failwith "Unknown rop in sail translate out" + +let translate_out_ropw op = match translate_out_enum op with +| 0 -> RISCVADDW +| 1 -> RISCVSUBW +| 2 -> RISCVSLLW +| 3 -> RISCVSRLW +| 4 -> RISCVSRAW +| _ -> failwith "Unknown ropw in sail translate out" + +let translate_out_amoop op = match translate_out_enum op with +| 0 -> RISCVAMOSWAP +| 1 -> RISCVAMOADD +| 2 -> RISCVAMOXOR +| 3 -> RISCVAMOAND +| 4 -> RISCVAMOOR +| 5 -> RISCVAMOMIN +| 6 -> RISCVAMOMAX +| 7 -> RISCVAMOMINU +| 8 -> RISCVAMOMAXU +| _ -> failwith "Unknown amoop in sail translate out" diff --git a/risc-v/gen/types_trans_sail.hgen b/risc-v/gen/types_trans_sail.hgen new file mode 100644 index 00000000..238c7e5b --- /dev/null +++ b/risc-v/gen/types_trans_sail.hgen @@ -0,0 +1,57 @@ +let translate_enum enum_values name value = + let rec bit_count n = + if n = 0 then 0 + else 1 + (bit_count (n lsr 1)) in + let rec find_index element = function + | h::tail -> if h = element then 0 else 1 + (find_index element tail) + | _ -> failwith "translate_enum could not find value" + in + let size = bit_count (List.length enum_values) in + let index = find_index value enum_values in + (name, Range0 (Some size), IInt.bit_list_of_integer size (Nat_big_num.of_int index)) + +let translate_uop = translate_enum [RISCVLUI; RISCVAUIPC] + +let translate_bop = translate_enum [RISCVBEQ; RISCVBNE; RISCVBLT; RISCVBGE; RISCVBLTU; RISCVBGEU] (* branch ops *) + +let translate_iop = translate_enum [RISCVADDI; RISCVSLTI; RISCVSLTIU; RISCVXORI; RISCVORI; RISCVANDI] (* immediate ops *) + +let translate_sop = translate_enum [RISCVSLLI; RISCVSRLI; RISCVSRAI] (* shift ops *) + +let translate_rop = translate_enum [RISCVADD; RISCVSUB; RISCVSLL; RISCVSLT; RISCVSLTU; RISCVXOR; RISCVSRL; RISCVSRA; RISCVOR; RISCVAND] (* reg-reg ops *) + +let translate_ropw = translate_enum [RISCVADDW; RISCVSUBW; RISCVSLLW; RISCVSRLW; RISCVSRAW] (* reg-reg 32-bit ops *) + +let translate_amoop = translate_enum [RISCVAMOSWAP; RISCVAMOADD; RISCVAMOXOR; RISCVAMOAND; RISCVAMOOR; RISCVAMOMIN; RISCVAMOMAX; RISCVAMOMINU; RISCVAMOMAXU] + +let translate_width = translate_enum [RISCVBYTE; RISCVHALF; RISCVWORD; RISCVDOUBLE] + +let translate_reg name value = + (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int (reg_to_int value))) + +let translate_imm21 name value = + (name, Bvector (Some 21), bit_list_of_integer 21 (Nat_big_num.of_int value)) + +let translate_imm20 name value = + (name, Bvector (Some 20), bit_list_of_integer 20 (Nat_big_num.of_int value)) + +let translate_imm16 name value = + (name, Bvector (Some 16), bit_list_of_integer 16 (Nat_big_num.of_int value)) + +let translate_imm13 name value = + (name, Bvector (Some 13), bit_list_of_integer 13 (Nat_big_num.of_int value)) + +let translate_imm12 name value = + (name, Bvector (Some 12), bit_list_of_integer 12 (Nat_big_num.of_int value)) + +let translate_imm6 name value = + (name, Bvector (Some 6), bit_list_of_integer 6 (Nat_big_num.of_int value)) + +let translate_imm5 name value = + (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int value)) + +let translate_imm4 name value = + (name, Bvector (Some 4), bit_list_of_integer 4 (Nat_big_num.of_int value)) + +let translate_bool name value = + (name, Bit, [if value then Bitc_one else Bitc_zero]) diff --git a/risc-v/hgen/ast.hgen b/risc-v/hgen/ast.hgen deleted file mode 100644 index b1968173..00000000 --- a/risc-v/hgen/ast.hgen +++ /dev/null @@ -1,17 +0,0 @@ -| `RISCVUTYPE of bit20 * reg * riscvUop -| `RISCVJAL of bit20 * reg -| `RISCVJALR of bit12 * reg * reg -| `RISCVBType of bit12 * reg * reg * riscvBop -| `RISCVIType of bit12 * reg * reg * riscvIop -| `RISCVShiftIop of bit6 * reg * reg * riscvSop -| `RISCVRType of reg * reg * reg * riscvRop -| `RISCVLoad of bit12 * reg * reg * bool * wordWidth * bool * bool -| `RISCVStore of bit12 * reg * reg * wordWidth * bool * bool -| `RISCVADDIW of bit12 * reg * reg -| `RISCVSHIFTW of bit5 * reg * reg * riscvSop -| `RISCVRTYPEW of reg * reg * reg * riscvRopw -| `RISCVFENCE of bit4 * bit4 -| `RISCVFENCEI -| `RISCVLoadRes of bool * bool * reg * wordWidth * reg -| `RISCVStoreCon of bool * bool * reg * reg * wordWidth * reg -| `RISCVAMO of riscvAmoop * bool * bool * reg * reg * wordWidth * reg diff --git a/risc-v/hgen/fold.hgen b/risc-v/hgen/fold.hgen deleted file mode 100644 index 4c51e114..00000000 --- a/risc-v/hgen/fold.hgen +++ /dev/null @@ -1,16 +0,0 @@ -| `RISCVThreadStart -> (y_reg, y_sreg) -| `RISCVUTYPE (_, r0, _) -> fold_reg r0 (y_reg, y_sreg) -| `RISCVJAL (_, r0) -> fold_reg r0 (y_reg, y_sreg) -| `RISCVJALR (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVBType (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVIType (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVShiftIop (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVRType (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) -| `RISCVLoad (_, r0, r1, _, _, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVStore (_, r0, r1, _, _, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVADDIW (_, r0, r1) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVSHIFTW (_, r0, r1, _) -> fold_reg r0 (fold_reg r1 (y_reg, y_sreg)) -| `RISCVRTYPEW (r0, r1, r2, _) -> fold_reg r0 (fold_reg r1 (fold_reg r2 (y_reg, y_sreg))) -| `RISCVLoadRes (_, _, rs1, _, rd) -> fold_reg rs1 (fold_reg rd (y_reg, y_sreg)) -| `RISCVStoreCon (_, _, rs2, rs1, _, rd) -> fold_reg rs2 (fold_reg rs1 (fold_reg rd (y_reg, y_sreg))) -| `RISCVAMO (_, _, _, rs2, rs1, _, rd) -> fold_reg rs2 (fold_reg rs1 (fold_reg rd (y_reg, y_sreg))) diff --git a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen b/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen deleted file mode 100644 index 07c1d082..00000000 --- a/risc-v/hgen/herdtools_ast_to_shallow_ast.hgen +++ /dev/null @@ -1,86 +0,0 @@ -| `RISCVStopFetching -> EBREAK -| `RISCVUTYPE(imm, rd, op) -> UTYPE( - translate_imm20 "imm" imm, - translate_reg "rd" rd, - translate_uop op) -| `RISCVJAL(imm, rd) -> RISCV_JAL( - translate_imm21 "imm" imm, - translate_reg "rd" rd) -| `RISCVJALR(imm, rs, rd) -> RISCV_JALR( - translate_imm12 "imm" imm, - translate_reg "rs" rd, - translate_reg "rd" rd) -| `RISCVBType(imm, rs2, rs1, op) -> BTYPE( - translate_imm13 "imm" imm, - translate_reg "rs2" rs2, - translate_reg "rs1" rs1, - translate_bop op) -| `RISCVIType(imm, rs1, rd, op) -> ITYPE( - translate_imm12 "imm" imm, - translate_reg "rs1" rs1, - translate_reg "rd" rd, - translate_iop op) -| `RISCVShiftIop(imm, rs, rd, op) -> SHIFTIOP( - translate_imm6 "imm" imm, - translate_reg "rs" rs, - translate_reg "rd" rd, - translate_sop op) -| `RISCVRType (rs2, rs1, rd, op) -> RTYPE ( - translate_reg "rs2" rs2, - translate_reg "rs1" rs1, - translate_reg "rd" rd, - translate_rop op) -| `RISCVLoad(imm, rs, rd, unsigned, width, aq, rl) -> LOAD( - translate_imm12 "imm" imm, - translate_reg "rs" rs, - translate_reg "rd" rd, - translate_bool "unsigned" unsigned, - translate_wordWidth width, - translate_bool "aq" aq, - translate_bool "rl" rl) -| `RISCVStore(imm, rs, rd, width, aq, rl) -> STORE ( - translate_imm12 "imm" imm, - translate_reg "rs" rs, - translate_reg "rd" rd, - translate_wordWidth width, - translate_bool "aq" aq, - translate_bool "rl" rl) -| `RISCVADDIW(imm, rs, rd) -> ADDIW( - translate_imm12 "imm" imm, - translate_reg "rs" rs, - translate_reg "rd" rd) -| `RISCVSHIFTW(imm, rs, rd, op) -> SHIFTW( - translate_imm5 "imm" imm, - translate_reg "rs" rs, - translate_reg "rd" rd, - translate_sop op) -| `RISCVRTYPEW(rs2, rs1, rd, op) -> RTYPEW( - translate_reg "rs2" rs2, - translate_reg "rs1" rs1, - translate_reg "rd" rd, - translate_ropw op) -| `RISCVFENCE(pred, succ) -> FENCE( - translate_imm4 "pred" pred, - translate_imm4 "succ" succ) -| `RISCVFENCEI -> FENCEI -| `RISCVLoadRes(aq, rl, rs1, width, rd) -> LOADRES( - translate_bool "aq" aq, - translate_bool "rl" rl, - translate_reg "rs1" rs1, - translate_wordWidth width, - translate_reg "rd" rd) -| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> STORECON( - translate_bool "aq" aq, - translate_bool "rl" rl, - translate_reg "rs2" rs2, - translate_reg "rs1" rs1, - translate_wordWidth width, - translate_reg "rd" rd) -| `RISCVAMO (op, aq, rl, rs2, rs1, width, rd) -> AMO( - translate_amoop op, - translate_bool "aq" aq, - translate_bool "rl" rl, - translate_reg "rs2" rs2, - translate_reg "rs1" rs1, - translate_wordWidth width, - translate_reg "rd" rd) diff --git a/risc-v/hgen/herdtools_types_to_shallow_types.hgen b/risc-v/hgen/herdtools_types_to_shallow_types.hgen deleted file mode 100644 index e6edd24d..00000000 --- a/risc-v/hgen/herdtools_types_to_shallow_types.hgen +++ /dev/null @@ -1,90 +0,0 @@ -let is_inc = false - -let translate_reg name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 5,Nat_big_num.of_int (reg_to_int value)) - -let translate_uop op = match op with - | RISCVLUI -> RISCV_LUI - | RISCVAUIPC -> RISCV_AUIPC - -let translate_bop op = match op with - | RISCVBEQ -> RISCV_BEQ - | RISCVBNE -> RISCV_BNE - | RISCVBLT -> RISCV_BLT - | RISCVBGE -> RISCV_BGE - | RISCVBLTU -> RISCV_BLTU - | RISCVBGEU -> RISCV_BGEU - -let translate_iop op = match op with - | RISCVADDI -> RISCV_ADDI - | RISCVSLTI -> RISCV_SLTI - | RISCVSLTIU -> RISCV_SLTIU - | RISCVXORI -> RISCV_XORI - | RISCVORI -> RISCV_ORI - | RISCVANDI -> RISCV_ANDI - -let translate_sop op = match op with - | RISCVSLLI -> RISCV_SLLI - | RISCVSRLI -> RISCV_SRLI - | RISCVSRAI -> RISCV_SRAI - -let translate_rop op = match op with - | RISCVADD -> RISCV_ADD - | RISCVSUB -> RISCV_SUB - | RISCVSLL -> RISCV_SLL - | RISCVSLT -> RISCV_SLT - | RISCVSLTU -> RISCV_SLTU - | RISCVXOR -> RISCV_XOR - | RISCVSRL -> RISCV_SRL - | RISCVSRA -> RISCV_SRA - | RISCVOR -> RISCV_OR - | RISCVAND -> RISCV_AND - -let translate_ropw op = match op with - | RISCVADDW -> RISCV_ADDW - | RISCVSUBW -> RISCV_SUBW - | RISCVSLLW -> RISCV_SLLW - | RISCVSRLW -> RISCV_SRLW - | RISCVSRAW -> RISCV_SRAW - -let translate_amoop op = match op with - | RISCVAMOSWAP -> AMOSWAP - | RISCVAMOADD -> AMOADD - | RISCVAMOXOR -> AMOXOR - | RISCVAMOAND -> AMOAND - | RISCVAMOOR -> AMOOR - | RISCVAMOMIN -> AMOMIN - | RISCVAMOMAX -> AMOMAX - | RISCVAMOMINU -> AMOMINU - | RISCVAMOMAXU -> AMOMAXU - -let translate_wordWidth op = match op with - | RISCVBYTE -> BYTE - | RISCVHALF -> HALF - | RISCVWORD -> WORD - | RISCVDOUBLE -> DOUBLE - -let translate_bool name = function - | true -> Sail_values.B1 - | false -> Sail_values.B0 - -let translate_imm21 name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 21,Nat_big_num.of_int value) - -let translate_imm20 name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 20,Nat_big_num.of_int value) - -let translate_imm13 name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 13,Nat_big_num.of_int value) - -let translate_imm12 name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 12,Nat_big_num.of_int value) - -let translate_imm6 name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 6,Nat_big_num.of_int value) - -let translate_imm5 name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 5,Nat_big_num.of_int value) - -let translate_imm4 name value = - Sail_values.to_vec0 is_inc (Nat_big_num.of_int 4,Nat_big_num.of_int value) diff --git a/risc-v/hgen/lexer.hgen b/risc-v/hgen/lexer.hgen deleted file mode 100644 index e42b8a62..00000000 --- a/risc-v/hgen/lexer.hgen +++ /dev/null @@ -1,190 +0,0 @@ -"lui" , UTYPE { op=RISCVLUI }; -"auipc" , UTYPE { op=RISCVAUIPC }; - -"jal", JAL (); -"jalr", JALR (); - -"beq", BTYPE {op=RISCVBEQ}; -"bne", BTYPE {op=RISCVBNE}; -"blt", BTYPE {op=RISCVBLT}; -"bge", BTYPE {op=RISCVBGE}; -"bltu", BTYPE {op=RISCVBLTU}; -"bgeu", BTYPE {op=RISCVBGEU}; - -"addi", ITYPE {op=RISCVADDI}; -"stli", ITYPE {op=RISCVSLTI}; -"sltiu", ITYPE {op=RISCVSLTIU}; -"xori", ITYPE {op=RISCVXORI}; -"ori", ITYPE {op=RISCVORI}; -"andi", ITYPE {op=RISCVANDI}; - -"slli", SHIFTIOP{op=RISCVSLLI}; -"srli", SHIFTIOP{op=RISCVSRLI}; -"srai", SHIFTIOP{op=RISCVSRAI}; - -"add", RTYPE{op=RISCVADD}; -"sub", RTYPE{op=RISCVSUB}; -"sll", RTYPE{op=RISCVSLL}; -"slt", RTYPE{op=RISCVSLT}; -"sltu", RTYPE{op=RISCVSLT}; -"xor", RTYPE{op=RISCVXOR}; -"srl", RTYPE{op=RISCVSRL}; -"sra", RTYPE{op=RISCVSRA}; -"or", RTYPE{op=RISCVOR}; -"and", RTYPE{op=RISCVAND}; - -"lb", LOAD{unsigned=false; width=RISCVBYTE; aq=false; rl=false}; -"lbu", LOAD{unsigned=true; width=RISCVBYTE; aq=false; rl=false}; -"lh", LOAD{unsigned=false; width=RISCVHALF; aq=false; rl=false}; -"lhu", LOAD{unsigned=true; width=RISCVHALF; aq=false; rl=false}; -"lw", LOAD{unsigned=false; width=RISCVWORD; aq=false; rl=false}; -"lwu", LOAD{unsigned=true; width=RISCVWORD; aq=false; rl=false}; -"ld", LOAD{unsigned=false; width=RISCVDOUBLE; aq=false; rl=false}; - -"lb.aq", LOAD{unsigned=false; width=RISCVBYTE; aq=true; rl=false}; -"lbu.aq", LOAD{unsigned=true; width=RISCVBYTE; aq=true; rl=false}; -"lh.aq", LOAD{unsigned=false; width=RISCVHALF; aq=true; rl=false}; -"lhu.aq", LOAD{unsigned=true; width=RISCVHALF; aq=true; rl=false}; -"lw.aq", LOAD{unsigned=false; width=RISCVWORD; aq=true; rl=false}; -"lwu.aq", LOAD{unsigned=true; width=RISCVWORD; aq=true; rl=false}; -"ld.aq", LOAD{unsigned=false; width=RISCVDOUBLE; aq=true; rl=false}; - -"lb.aq.rl", LOAD{unsigned=false; width=RISCVBYTE; aq=true; rl=true}; -"lbu.aq.rl", LOAD{unsigned=true; width=RISCVBYTE; aq=true; rl=true}; -"lh.aq.rl", LOAD{unsigned=false; width=RISCVHALF; aq=true; rl=true}; -"lhu.aq.rl", LOAD{unsigned=true; width=RISCVHALF; aq=true; rl=true}; -"lw.aq.rl", LOAD{unsigned=false; width=RISCVWORD; aq=true; rl=true}; -"lwu.aq.rl", LOAD{unsigned=true; width=RISCVWORD; aq=true; rl=true}; -"ld.aq.rl", LOAD{unsigned=false; width=RISCVDOUBLE; aq=true; rl=true}; - -"sb", STORE{width=RISCVBYTE; aq=false; rl=false}; -"sh", STORE{width=RISCVHALF; aq=false; rl=false}; -"sw", STORE{width=RISCVWORD; aq=false; rl=false}; -"sd", STORE{width=RISCVDOUBLE; aq=false; rl=false}; - -"sb.rl", STORE{width=RISCVBYTE; aq=false; rl=true}; -"sh.rl", STORE{width=RISCVHALF; aq=false; rl=true}; -"sw.rl", STORE{width=RISCVWORD; aq=false; rl=true}; -"sd.rl", STORE{width=RISCVDOUBLE; aq=false; rl=true}; - -"sb.aq.rl", STORE{width=RISCVBYTE; aq=true; rl=true}; -"sh.aq.rl", STORE{width=RISCVHALF; aq=true; rl=true}; -"sw.aq.rl", STORE{width=RISCVWORD; aq=true; rl=true}; -"sd.aq.rl", STORE{width=RISCVDOUBLE; aq=true; rl=true}; - -"addiw", ADDIW (); - -"slliw", SHIFTW{op=RISCVSLLI}; -"srliw", SHIFTW{op=RISCVSRLI}; -"sraiw", SHIFTW{op=RISCVSRAI}; - -"addw", RTYPEW{op=RISCVADDW}; -"subw", RTYPEW{op=RISCVSUBW}; -"sslw", RTYPEW{op=RISCVSLLW}; -"srlw", RTYPEW{op=RISCVSRLW}; -"sraw", RTYPEW{op=RISCVSRAW}; - -"fence", FENCE (); -"r", FENCEOPTION Fence_R; -"w", FENCEOPTION Fence_W; -"rw", FENCEOPTION Fence_RW; - -"fence.i", FENCEI (); - -"lr.w", LOADRES {width=RISCVWORD; aq=false; rl=false}; -"lr.w.aq", LOADRES {width=RISCVWORD; aq=true; rl=false}; -"lr.w.aq.rl", LOADRES {width=RISCVWORD; aq=true; rl=true}; -"lr.d", LOADRES {width=RISCVDOUBLE; aq=false; rl=false}; -"lr.d.aq", LOADRES {width=RISCVDOUBLE; aq=true; rl=false}; -"lr.d.aq.rl", LOADRES {width=RISCVDOUBLE; aq=true; rl=true}; - -"sc.w", STORECON {width=RISCVWORD; aq=false; rl=false}; -"sc.w.rl", STORECON {width=RISCVWORD; aq=false; rl=true}; -"sc.w.aq.rl", STORECON {width=RISCVWORD; aq=true; rl=true}; -"sc.d", STORECON {width=RISCVDOUBLE; aq=false; rl=false}; -"sc.d.rl", STORECON {width=RISCVDOUBLE; aq=false; rl=true}; -"sc.d.aq.rl", STORECON {width=RISCVDOUBLE; aq=true; rl=true}; - -"amoswap.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOSWAP}; -"amoadd.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOADD}; -"amoand.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOAND}; -"amoor.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOOR}; -"amoxor.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOXOR}; -"amomax.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMAX}; -"amomin.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMIN}; -"amomaxu.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMAXU}; -"amominu.w", AMO {width=RISCVWORD; aq=false; rl=false; op=RISCVAMOMINU}; - -"amoswap.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOSWAP}; -"amoadd.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOADD}; -"amoand.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOAND}; -"amoor.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOOR}; -"amoxor.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOXOR}; -"amomax.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMAX}; -"amomin.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMIN}; -"amomaxu.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMAXU}; -"amominu.d", AMO {width=RISCVDOUBLE; aq=false; rl=false; op=RISCVAMOMINU}; - -"amoswap.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOSWAP}; -"amoadd.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOADD}; -"amoand.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOAND}; -"amoor.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOOR}; -"amoxor.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOXOR}; -"amomax.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMAX}; -"amomin.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMIN}; -"amomaxu.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMAXU}; -"amominu.w.aq", AMO {width=RISCVWORD; aq=true; rl=false; op=RISCVAMOMINU}; - -"amoswap.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOSWAP}; -"amoadd.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOADD}; -"amoand.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOAND}; -"amoor.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOOR}; -"amoxor.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOXOR}; -"amomax.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMAX}; -"amomin.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMIN}; -"amomaxu.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMAXU}; -"amominu.d.aq", AMO {width=RISCVDOUBLE; aq=true; rl=false; op=RISCVAMOMINU}; - -"amoswap.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOSWAP}; -"amoadd.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOADD}; -"amoand.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOAND}; -"amoor.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOOR}; -"amoxor.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOXOR}; -"amomax.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMAX}; -"amomin.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMIN}; -"amomaxu.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMAXU}; -"amominu.w.rl", AMO {width=RISCVWORD; aq=false; rl=true; op=RISCVAMOMINU}; - -"amoswap.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOSWAP}; -"amoadd.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOADD}; -"amoand.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOAND}; -"amoor.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOOR}; -"amoxor.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOXOR}; -"amomax.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMAX}; -"amomin.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMIN}; -"amomaxu.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMAXU}; -"amominu.d.rl", AMO {width=RISCVDOUBLE; aq=false; rl=true; op=RISCVAMOMINU}; - -"amoswap.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOSWAP}; -"amoadd.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOADD}; -"amoand.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOAND}; -"amoor.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOOR}; -"amoxor.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOXOR}; -"amomax.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMAX}; -"amomin.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMIN}; -"amomaxu.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMAXU}; -"amominu.w.aq.rl", AMO {width=RISCVWORD; aq=true; rl=true; op=RISCVAMOMINU}; - -"amoswap.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOSWAP}; -"amoadd.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOADD}; -"amoand.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOAND}; -"amoor.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOOR}; -"amoxor.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOXOR}; -"amomax.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMAX}; -"amomin.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMIN}; -"amomaxu.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMAXU}; -"amominu.d.aq.rl", AMO {width=RISCVDOUBLE; aq=true; rl=true; op=RISCVAMOMINU}; - -(** pseudo instructions *********************************************) - -"li", LI () diff --git a/risc-v/hgen/map.hgen b/risc-v/hgen/map.hgen deleted file mode 100644 index bab5ced8..00000000 --- a/risc-v/hgen/map.hgen +++ /dev/null @@ -1,15 +0,0 @@ -| `RISCVUTYPE (x, r0, y) -> `RISCVUTYPE (x, map_reg r0, y) -| `RISCVJAL (x, r0) -> `RISCVJAL (x, map_reg r0) -| `RISCVJALR (x, r0, r1) -> `RISCVJALR (x, map_reg r0, map_reg r1) -| `RISCVBType (x, r0, r1, y) -> `RISCVBType (x, map_reg r0, map_reg r1, y) -| `RISCVIType (x, r0, r1, y) -> `RISCVIType (x, map_reg r0, map_reg r1, y) -| `RISCVShiftIop (x, r0, r1, y) -> `RISCVShiftIop (x, map_reg r0, map_reg r1, y) -| `RISCVRType (r0, r1, r2, y) -> `RISCVRType (r0, map_reg r1, map_reg r2, y) -| `RISCVLoad (x, r0, r1, y, z, a, b) -> `RISCVLoad (x, map_reg r0, map_reg r1, y, z, a, b) -| `RISCVStore (x, r0, r1, y, z, a) -> `RISCVStore (x, map_reg r0, map_reg r1, y, z, a) -| `RISCVADDIW (x, r0, r1) -> `RISCVADDIW (x, map_reg r0, map_reg r1) -| `RISCVSHIFTW (x, r0, r1, y) -> `RISCVSHIFTW (x, map_reg r0, map_reg r1, y) -| `RISCVRTYPEW (r0, r1, r2, x) -> `RISCVRTYPEW (r0, map_reg r1, map_reg r2, x) -| `RISCVLoadRes (aq, rl, rs1, w, rd) -> `RISCVLoadRes (aq, rl, map_reg rs1, w, map_reg rd) -| `RISCVStoreCon (aq, rl, rs2, rs1, w, rd) -> `RISCVStoreCon (aq, rl, map_reg rs2, map_reg rs1, w, map_reg rd) -| `RISCVAMO (op, aq, rl, rs2, rs1, w, rd) -> `RISCVAMO (op, aq, rl, map_reg rs2, map_reg rs1, w, map_reg rd) diff --git a/risc-v/hgen/parser.hgen b/risc-v/hgen/parser.hgen deleted file mode 100644 index 210e38fb..00000000 --- a/risc-v/hgen/parser.hgen +++ /dev/null @@ -1,74 +0,0 @@ -| UTYPE reg COMMA NUM - { (* it's not clear if NUM here should be before or after filling the - lowest 12 bits with zeros, or if it should be signed or unsigned; - currently assuming: NUM does not include the 12 zeros, and is unsigned *) - if not (iskbituimm 20 $4) then failwith "immediate is not 20bit" - else `RISCVUTYPE ($4, $2, $1.op) } -| JAL reg COMMA NUM - { if not ($4 mod 2 = 0) then failwith "odd offset" - else if not (iskbitsimm 21 $4) then failwith "offset is not 21bit" - else `RISCVJAL ($4, $2) } -| JALR reg COMMA reg COMMA NUM - { if not (iskbitsimm 12 $6) then failwith "offset is not 12bit" - else `RISCVJALR ($6, $4, $2) } -| BTYPE reg COMMA reg COMMA NUM - { if not ($6 mod 2 = 0) then failwith "odd offset" - else if not (iskbitsimm 13 $6) then failwith "offset is not 13bit" - else `RISCVBType ($6, $4, $2, $1.op) } -| ITYPE reg COMMA reg COMMA NUM - { if $1.op <> RISCVSLTIU && not (iskbitsimm 12 $6) then failwith "immediate is not 12bit" - else if $1.op = RISCVSLTIU && not (iskbituimm 12 $6) then failwith "unsigned immediate is not 12bit" - else `RISCVIType ($6, $4, $2, $1.op) } -| ADDIW reg COMMA reg COMMA NUM - { if not (iskbitsimm 12 $6) then failwith "immediate is not 12bit" - else `RISCVADDIW ($6, $4, $2) } -| SHIFTIOP reg COMMA reg COMMA NUM - { if not (iskbituimm 6 $6) then failwith "unsigned immediate is not 6bit" - else `RISCVShiftIop ($6, $4, $2, $1.op) } -| SHIFTW reg COMMA reg COMMA NUM - { if not (iskbituimm 5 $6) then failwith "unsigned immediate is not 5bit" - else `RISCVSHIFTW ($6, $4, $2, $1.op) } -| RTYPE reg COMMA reg COMMA reg - { `RISCVRType ($6, $4, $2, $1.op) } -| LOAD reg COMMA NUM LPAR reg RPAR - { if not (iskbitsimm 12 $4) then failwith "offset is not 12bit" - else `RISCVLoad ($4, $6, $2, $1.unsigned, $1.width, $1.aq, $1.rl) } -| STORE reg COMMA NUM LPAR reg RPAR - { if not (iskbitsimm 12 $4) then failwith "offset is not 12bit" - else `RISCVStore ($4, $2, $6, $1.width, $1.aq, $1.rl) } -| RTYPEW reg COMMA reg COMMA reg - { `RISCVRTYPEW ($6, $4, $2, $1.op) } -| FENCE FENCEOPTION COMMA FENCEOPTION - { match ($2, $4) with - | (Fence_RW, Fence_RW) -> `RISCVFENCE (0b0011, 0b0011) - | (Fence_R, Fence_RW) -> `RISCVFENCE (0b0010, 0b0011) - | (Fence_R, Fence_R) -> `RISCVFENCE (0b0010, 0b0010) - | (Fence_RW, Fence_W) -> `RISCVFENCE (0b0011, 0b0001) - | (Fence_W, Fence_W) -> `RISCVFENCE (0b0001, 0b0001) - | (Fence_RW, Fence_R) -> failwith "'fence rw,r' is not supported" - | (Fence_R, Fence_W) -> failwith "'fence r,w' is not supported" - | (Fence_W, Fence_RW) -> failwith "'fence w,rw' is not supported" - | (Fence_W, Fence_R) -> failwith "'fence w,r' is not supported" - } -| FENCEI - { `RISCVFENCEI } -| LOADRES reg COMMA LPAR reg RPAR - { `RISCVLoadRes ($1.aq, $1.rl, $5, $1.width, $2) } -| LOADRES reg COMMA NUM LPAR reg RPAR - { if $4 <> 0 then failwith "'lr' offset must be 0" else - `RISCVLoadRes ($1.aq, $1.rl, $6, $1.width, $2) } -| STORECON reg COMMA reg COMMA LPAR reg RPAR - { `RISCVStoreCon ($1.aq, $1.rl, $4, $7, $1.width, $2) } -| STORECON reg COMMA reg COMMA NUM LPAR reg RPAR - { if $6 <> 0 then failwith "'sc' offset must be 0" else - `RISCVStoreCon ($1.aq, $1.rl, $4, $8, $1.width, $2) } -| AMO reg COMMA reg COMMA LPAR reg RPAR - { `RISCVAMO ($1.op, $1.aq, $1.rl, $4, $7, $1.width, $2) } -| AMO reg COMMA reg COMMA NUM LPAR reg RPAR - { if $6 <> 0 then failwith "'amo' offset must be 0" else - `RISCVAMO ($1.op, $1.aq, $1.rl, $4, $8, $1.width, $2) } - -/* pseudo-ops */ -| LI reg COMMA NUM - { if not (iskbitsimm 12 $4) then failwith "immediate is not 12bit (li is currently implemented only with small immediate)" - else `RISCVIType ($4, IReg R0, $2, RISCVORI) } diff --git a/risc-v/hgen/pretty.hgen b/risc-v/hgen/pretty.hgen deleted file mode 100644 index fc1c0000..00000000 --- a/risc-v/hgen/pretty.hgen +++ /dev/null @@ -1,30 +0,0 @@ -| `RISCVThreadStart -> "start" -| `RISCVStopFetching -> "stop" -| `RISCVUTYPE(imm, rd, op) -> sprintf "%s %s, %d" (pp_riscv_uop op) (pp_reg rd) imm -| `RISCVJAL(imm, rd) -> sprintf "jal %s, %d" (pp_reg rd) imm -| `RISCVJALR(imm, rs, rd) -> sprintf "jalr %s, %s, %d" (pp_reg rd) (pp_reg rs) imm -| `RISCVBType(imm, rs2, rs1, op) -> sprintf "%s %s, %s, %d" (pp_riscv_bop op) (pp_reg rs1) (pp_reg rs2) imm -| `RISCVIType(imm, rs2, rs1, op) -> sprintf "%s %s, %s, %d" (pp_riscv_iop op) (pp_reg rs1) (pp_reg rs2) imm -| `RISCVShiftIop(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm -| `RISCVRType (rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_rop op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) - -| `RISCVLoad(imm, rs, rd, unsigned, width, aq, rl) -> - sprintf "%s %s, %d(%s)" (pp_riscv_load_op (unsigned, width, aq, rl)) (pp_reg rd) imm (pp_reg rs) - -| `RISCVStore(imm, rs2, rs1, width, aq, rl) -> - sprintf "%s %s, %d(%s)" (pp_riscv_store_op (width, aq, rl)) (pp_reg rs2) imm (pp_reg rs1) - -| `RISCVADDIW(imm, rs, rd) -> sprintf "addiw %s, %s, %d" (pp_reg rd) (pp_reg rs) imm -| `RISCVSHIFTW(imm, rs, rd, op) -> sprintf "%s %s, %s, %d" (pp_riscv_sop op) (pp_reg rd) (pp_reg rs) imm -| `RISCVRTYPEW(rs2, rs1, rd, op) -> sprintf "%s %s, %s, %s" (pp_riscv_ropw op) (pp_reg rd) (pp_reg rs1) (pp_reg rs2) -| `RISCVFENCE(pred, succ) -> sprintf "fence %s, %s" (pp_riscv_fence_option pred) (pp_riscv_fence_option succ) -| `RISCVFENCEI -> sprintf "fence.i" - -| `RISCVLoadRes(aq, rl, rs1, width, rd) -> - sprintf "%s %s, (%s)" (pp_riscv_load_reserved_op (aq, rl, width)) (pp_reg rd) (pp_reg rs1) - -| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> - sprintf "%s %s, %s, (%s)" (pp_riscv_store_conditional_op (aq, rl, width)) (pp_reg rd) (pp_reg rs2) (pp_reg rs1) - -| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) -> - sprintf "%s %s, %s, (%s)" (pp_riscv_amo_op (op, aq, rl, width)) (pp_reg rd) (pp_reg rs2) (pp_reg rs1) diff --git a/risc-v/hgen/pretty_xml.hgen b/risc-v/hgen/pretty_xml.hgen deleted file mode 100644 index b0306161..00000000 --- a/risc-v/hgen/pretty_xml.hgen +++ /dev/null @@ -1,137 +0,0 @@ -| `RISCVThreadStart -> ("op_thread_start", []) - -| `RISCVStopFetching -> ("op_stop_fetching", []) - -| `RISCVUTYPE(imm, rd, op) -> - ("op_U_type", - [ ("op", pp_riscv_uop op); - ("uimm", sprintf "%d" imm); - ("dest", pp_reg rd); - ]) - -| `RISCVJAL(imm, rd) -> - ("op_jal", - [ ("offset", sprintf "%d" imm); - ("dest", pp_reg rd); - ]) - -| `RISCVJALR(imm, rs1, rd) -> - ("op_jalr", - [ ("offset", sprintf "%d" imm); - ("base", pp_reg rs1); - ("dest", pp_reg rd); - ]) - -| `RISCVBType(imm, rs2, rs1, op) -> - ("op_branch", - [ ("op", pp_riscv_bop op); - ("offset", sprintf "%d" imm); - ("src2", pp_reg rs2); - ("src1", pp_reg rs1); - ]) - -| `RISCVIType(imm, rs1, rd, op) -> - ("op_I_type", - [ ("op", pp_riscv_iop op); - ("iimm", sprintf "%d" imm); - ("src", pp_reg rs1); - ("dest", pp_reg rd); - ]) - -| `RISCVShiftIop(imm, rs1, rd, op) -> - ("op_IS_type", - [ ("op", pp_riscv_sop op); - ("shamt", sprintf "%d" imm); - ("src", pp_reg rs1); - ("dest", pp_reg rd); - ]) - -| `RISCVSHIFTW(imm, rs1, rd, op) -> - ("op_ISW_type", - [ ("op", pp_riscv_sop op); - ("shamt", sprintf "%d" imm); - ("src", pp_reg rs1); - ("dest", pp_reg rd); - ]) - -| `RISCVRType (rs2, rs1, rd, op) -> - ("op_R_type", - [ ("op", pp_riscv_rop op); - ("src2", pp_reg rs2); - ("src1", pp_reg rs1); - ("dest", pp_reg rd); - ]) - -| `RISCVLoad(imm, rs1, rd, unsigned, width, aq, rl) -> - ("op_load", - [ ("aq", if aq then "true" else "false"); - ("rl", if rl then "true" else "false"); - ("width", pp_word_width width); - ("unsigned", if unsigned then "true" else "false"); - ("base", pp_reg rs1); - ("offset", sprintf "%d" imm); - ("dest", pp_reg rd); - ]) - -| `RISCVStore(imm, rs2, rs1, width, aq, rl) -> - ("op_store", - [ ("aq", if aq then "true" else "false"); - ("rl", if rl then "true" else "false"); - ("width", pp_word_width width); - ("src", pp_reg rs2); - ("base", pp_reg rs1); - ("offset", sprintf "%d" imm); - ]) - -| `RISCVADDIW(imm, rs1, rd) -> - ("op_addiw", - [ ("iimm", sprintf "%d" imm); - ("src", pp_reg rs1); - ("dest", pp_reg rd); - ]) - -| `RISCVRTYPEW(rs2, rs1, rd, op) -> - ("op_RW_type", - [ ("op", pp_riscv_ropw op); - ("src2", pp_reg rs2); - ("src1", pp_reg rs1); - ("dest", pp_reg rd); - ]) - -| `RISCVFENCE(pred, succ) -> - ("op_fence", - [ ("pred", pp_riscv_fence_option pred); - ("succ", pp_riscv_fence_option succ); - ]) - -| `RISCVFENCEI -> ("op_fence_i", []) - -| `RISCVLoadRes(aq, rl, rs1, width, rd) -> - ("op_lr", - [ ("aq", if aq then "true" else "false"); - ("rl", if rl then "true" else "false"); - ("width", pp_word_width width); - ("addr", pp_reg rs1); - ("dest", pp_reg rd); - ]) - -| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> - ("op_sc", - [ ("aq", if aq then "true" else "false"); - ("rl", if rl then "true" else "false"); - ("width", pp_word_width width); - ("addr", pp_reg rs1); - ("src", pp_reg rs2); - ("dest", pp_reg rd); - ]) - -| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) -> - ("op_amo", - [ ("op", pp_riscv_amo_op_part op); - ("aq", if aq then "true" else "false"); - ("rl", if rl then "true" else "false"); - ("width", pp_word_width width); - ("src", pp_reg rs2); - ("addr", pp_reg rs1); - ("dest", pp_reg rd); - ]) diff --git a/risc-v/hgen/sail_trans_out.hgen b/risc-v/hgen/sail_trans_out.hgen deleted file mode 100644 index 2f9a80f1..00000000 --- a/risc-v/hgen/sail_trans_out.hgen +++ /dev/null @@ -1,23 +0,0 @@ -| ("EBREAK", []) -> `RISCVStopFetching -| ("UTYPE", [imm; rd; op]) -> `RISCVUTYPE(translate_out_simm20 imm, translate_out_ireg rd, translate_out_uop op) -| ("JAL", [imm; rd]) -> `RISCVJAL(translate_out_simm21 imm, translate_out_ireg rd) -| ("JALR", [imm; rs; rd]) -> `RISCVJALR(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) -| ("BTYPE", [imm; rs2; rs1; op]) -> `RISCVBType(translate_out_simm13 imm, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_bop op) -| ("ITYPE", [imm; rs1; rd; op]) -> `RISCVIType(translate_out_simm12 imm, translate_out_ireg rs1, translate_out_ireg rd, translate_out_iop op) -| ("SHIFTIOP", [imm; rs; rd; op]) -> `RISCVShiftIop(translate_out_imm6 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) -| ("RTYPE", [rs2; rs1; rd; op]) -> `RISCVRType (translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_rop op) -| ("LOAD", [imm; rs; rd; unsigned; width; aq; rl]) - -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) -| ("STORE", [imm; rs; rd; width; aq; rl]) - -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) -| ("ADDIW", [imm; rs; rd]) -> `RISCVADDIW(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) -| ("SHIFTW", [imm; rs; rd; op]) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) -| ("RTYPEW", [rs2; rs1; rd; op]) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) -| ("FENCE", [pred; succ]) -> `RISCVFENCE(translate_out_imm4 pred, translate_out_imm4 succ) -| ("FENCEI", []) -> `RISCVFENCEI -| ("LOADRES", [aq; rl; rs1; width; rd]) - -> `RISCVLoadRes(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) -| ("STORECON", [aq; rl; rs2; rs1; width; rd]) - -> `RISCVStoreCon(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) -| ("AMO", [op; aq; rl; rs2; rs1; width; rd]) - -> `RISCVAMO(translate_out_amoop op, translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) diff --git a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen b/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen deleted file mode 100644 index 3025992e..00000000 --- a/risc-v/hgen/shallow_ast_to_herdtools_ast.hgen +++ /dev/null @@ -1,23 +0,0 @@ -| EBREAK -> `RISCVStopFetching -| UTYPE( imm, rd, op) -> `RISCVUTYPE(translate_out_simm20 imm, translate_out_ireg rd, translate_out_uop op) -| RISCV_JAL( imm, rd) -> `RISCVJAL(translate_out_simm21 imm, translate_out_ireg rd) -| RISCV_JALR( imm, rs, rd) -> `RISCVJALR(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) -| BTYPE( imm, rs2, rs1, op) -> `RISCVBType(translate_out_simm13 imm, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_bop op) -| ITYPE( imm, rs1, rd, op) -> `RISCVIType(translate_out_simm12 imm, translate_out_ireg rs1, translate_out_ireg rd, translate_out_iop op) -| SHIFTIOP( imm, rs, rd, op) -> `RISCVShiftIop(translate_out_imm6 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) -| RTYPE( rs2, rs1, rd, op) -> `RISCVRType (translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_rop op) -| LOAD( imm, rs, rd, unsigned, width, aq, rl) - -> `RISCVLoad(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_bool unsigned, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) -| STORE( imm, rs, rd, width, aq, rl) - -> `RISCVStore(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_wordWidth width, translate_out_bool aq, translate_out_bool rl) -| ADDIW( imm, rs, rd) -> `RISCVADDIW(translate_out_simm12 imm, translate_out_ireg rs, translate_out_ireg rd) -| SHIFTW( imm, rs, rd, op) -> `RISCVSHIFTW(translate_out_imm5 imm, translate_out_ireg rs, translate_out_ireg rd, translate_out_sop op) -| RTYPEW( rs2, rs1, rd, op) -> `RISCVRTYPEW(translate_out_ireg rs2, translate_out_ireg rs1, translate_out_ireg rd, translate_out_ropw op) -| FENCE( pred, succ) -> `RISCVFENCE(translate_out_imm4 pred, translate_out_imm4 succ) -| FENCEI -> `RISCVFENCEI -| LOADRES( aq, rl, rs1, width, rd) - -> `RISCVLoadRes(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) -| STORECON( aq, rl, rs2, rs1, width, rd) - -> `RISCVStoreCon(translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) -| AMO( op, aq, rl, rs2, rs1, width, rd) - -> `RISCVAMO(translate_out_amoop op, translate_out_bool aq, translate_out_bool rl, translate_out_ireg rs2, translate_out_ireg rs1, translate_out_wordWidth width, translate_out_ireg rd) diff --git a/risc-v/hgen/shallow_types_to_herdtools_types.hgen b/risc-v/hgen/shallow_types_to_herdtools_types.hgen deleted file mode 100644 index 6b3b7f51..00000000 --- a/risc-v/hgen/shallow_types_to_herdtools_types.hgen +++ /dev/null @@ -1,84 +0,0 @@ -let translate_out_big_bit = Sail_values.unsigned - -let translate_out_int inst = (Nat_big_num.to_int (translate_out_big_bit inst)) -let translate_out_signed_int inst bits = - let i = (Nat_big_num.to_int (translate_out_big_bit inst)) in - if (i >= (1 lsl (bits - 1))) then - (i - (1 lsl bits)) else - i - -let translate_out_ireg ireg = IReg (int_to_ireg (translate_out_int ireg)) - -let translate_out_uop op = match op with - | RISCV_LUI -> RISCVLUI - | RISCV_AUIPC -> RISCVAUIPC - -let translate_out_bop op = match op with - | RISCV_BEQ -> RISCVBEQ - | RISCV_BNE -> RISCVBNE - | RISCV_BLT -> RISCVBLT - | RISCV_BGE -> RISCVBGE - | RISCV_BLTU -> RISCVBLTU - | RISCV_BGEU -> RISCVBGEU - -let translate_out_iop op = match op with - | RISCV_ADDI -> RISCVADDI - | RISCV_SLTI -> RISCVSLTI - | RISCV_SLTIU -> RISCVSLTIU - | RISCV_XORI -> RISCVXORI - | RISCV_ORI -> RISCVORI - | RISCV_ANDI -> RISCVANDI - -let translate_out_sop op = match op with - | RISCV_SLLI -> RISCVSLLI - | RISCV_SRLI -> RISCVSRLI - | RISCV_SRAI -> RISCVSRAI - -let translate_out_rop op = match op with - | RISCV_ADD -> RISCVADD - | RISCV_SUB -> RISCVSUB - | RISCV_SLL -> RISCVSLL - | RISCV_SLT -> RISCVSLT - | RISCV_SLTU -> RISCVSLTU - | RISCV_XOR -> RISCVXOR - | RISCV_SRL -> RISCVSRL - | RISCV_SRA -> RISCVSRA - | RISCV_OR -> RISCVOR - | RISCV_AND -> RISCVAND - -let translate_out_ropw op = match op with - | RISCV_ADDW -> RISCVADDW - | RISCV_SUBW -> RISCVSUBW - | RISCV_SLLW -> RISCVSLLW - | RISCV_SRLW -> RISCVSRLW - | RISCV_SRAW -> RISCVSRAW - -let translate_out_amoop op = match op with - | AMOSWAP -> RISCVAMOSWAP - | AMOADD -> RISCVAMOADD - | AMOXOR -> RISCVAMOXOR - | AMOAND -> RISCVAMOAND - | AMOOR -> RISCVAMOOR - | AMOMIN -> RISCVAMOMIN - | AMOMAX -> RISCVAMOMAX - | AMOMINU -> RISCVAMOMINU - | AMOMAXU -> RISCVAMOMAXU - -let translate_out_wordWidth op = match op with - | BYTE -> RISCVBYTE - | HALF -> RISCVHALF - | WORD -> RISCVWORD - | DOUBLE -> RISCVDOUBLE - -let translate_out_bool = function - | Sail_values.B1 -> true - | Sail_values.B0 -> false - | _ -> failwith "translate_out_bool Undef" - -let translate_out_simm21 imm = translate_out_signed_int imm 21 -let translate_out_simm20 imm = translate_out_signed_int imm 20 -let translate_out_simm13 imm = translate_out_signed_int imm 13 -let translate_out_simm12 imm = translate_out_signed_int imm 12 -let translate_out_imm6 imm = translate_out_int imm -let translate_out_imm5 imm = translate_out_int imm -let translate_out_imm4 imm = translate_out_int imm diff --git a/risc-v/hgen/token_types.hgen b/risc-v/hgen/token_types.hgen deleted file mode 100644 index f29e318d..00000000 --- a/risc-v/hgen/token_types.hgen +++ /dev/null @@ -1,23 +0,0 @@ -type token_UTYPE = {op : riscvUop } -type token_JAL = unit -type token_JALR = unit -type token_BType = {op : riscvBop } -type token_IType = {op : riscvIop } -type token_ShiftIop = {op : riscvSop } -type token_RTYPE = {op : riscvRop } -type token_Load = {unsigned: bool; width : wordWidth; aq: bool; rl: bool } -type token_Store = {width : wordWidth; aq: bool; rl: bool } -type token_ADDIW = unit -type token_SHIFTW = {op : riscvSop } -type token_RTYPEW = {op : riscvRopw } -type token_FENCE = unit -type token_FENCEI = unit -type token_LoadRes = {width : wordWidth; aq: bool; rl: bool } -type token_StoreCon = {width : wordWidth; aq: bool; rl: bool } -type token_AMO = {width : wordWidth; aq: bool; rl: bool; op: riscvAmoop } - -type token_FENCEOPTION = Fence_R | Fence_W | Fence_RW - -(* pseudo-ops *) - -type token_LI = unit diff --git a/risc-v/hgen/tokens.hgen b/risc-v/hgen/tokens.hgen deleted file mode 100644 index f812adbd..00000000 --- a/risc-v/hgen/tokens.hgen +++ /dev/null @@ -1,19 +0,0 @@ -%token UTYPE -%token JAL -%token JALR -%token BTYPE -%token ITYPE -%token SHIFTIOP -%token RTYPE -%token LOAD -%token STORE -%token ADDIW -%token SHIFTW -%token RTYPEW -%token FENCE -%token FENCEOPTION -%token FENCEI -%token LOADRES -%token STORECON -%token AMO -%token LI diff --git a/risc-v/hgen/trans_sail.hgen b/risc-v/hgen/trans_sail.hgen deleted file mode 100644 index 8b7cbe11..00000000 --- a/risc-v/hgen/trans_sail.hgen +++ /dev/null @@ -1,153 +0,0 @@ -| `RISCVStopFetching -> ("EBREAK", [], []) -| `RISCVUTYPE(imm, rd, op) -> - ("UTYPE", - [ - translate_imm20 "imm" imm; - translate_reg "rd" rd; - translate_uop "op" op; - ], - []) -| `RISCVJAL(imm, rd) -> - ("JAL", - [ - translate_imm21 "imm" imm; - translate_reg "rd" rd; - ], - []) -| `RISCVJALR(imm, rs, rd) -> - ("JALR", - [ - translate_imm12 "imm" imm; - translate_reg "rs" rd; - translate_reg "rd" rd; - ], - []) -| `RISCVBType(imm, rs2, rs1, op) -> - ("BTYPE", - [ - translate_imm13 "imm" imm; - translate_reg "rs2" rs2; - translate_reg "rs1" rs1; - translate_bop "op" op; - ], - []) -| `RISCVIType(imm, rs1, rd, op) -> - ("ITYPE", - [ - translate_imm12 "imm" imm; - translate_reg "rs1" rs1; - translate_reg "rd" rd; - translate_iop "op" op; - ], - []) -| `RISCVShiftIop(imm, rs, rd, op) -> - ("SHIFTIOP", - [ - translate_imm6 "imm" imm; - translate_reg "rs" rs; - translate_reg "rd" rd; - translate_sop "op" op; - ], - []) -| `RISCVRType (rs2, rs1, rd, op) -> - ("RTYPE", - [ - translate_reg "rs2" rs2; - translate_reg "rs1" rs1; - translate_reg "rd" rd; - translate_rop "op" op; - ], - []) -| `RISCVLoad(imm, rs, rd, unsigned, width, aq, rl) -> - ("LOAD", - [ - translate_imm12 "imm" imm; - translate_reg "rs" rs; - translate_reg "rd" rd; - translate_bool "unsigned" unsigned; - translate_width "width" width; - translate_bool "aq" aq; - translate_bool "rl" rl; - ], - []) -| `RISCVStore(imm, rs2, rs1, width, aq, rl) -> - ("STORE", - [ - translate_imm12 "imm" imm; - translate_reg "rs2" rs2; - translate_reg "rs1" rs1; - translate_width "width" width; - translate_bool "aq" aq; - translate_bool "rl" rl; - ], - []) -| `RISCVADDIW(imm, rs, rd) -> - ("ADDIW", - [ - translate_imm12 "imm" imm; - translate_reg "rs" rs; - translate_reg "rd" rd; - ], - []) -| `RISCVSHIFTW(imm, rs, rd, op) -> - ("SHIFTW", - [ - translate_imm5 "imm" imm; - translate_reg "rs" rs; - translate_reg "rd" rd; - translate_sop "op" op; - ], - []) -| `RISCVRTYPEW(rs2, rs1, rd, op) -> - ("RTYPEW", - [ - translate_reg "rs2" rs2; - translate_reg "rs1" rs1; - translate_reg "rd" rd; - translate_ropw "op" op; - ], - []) -| `RISCVFENCE(pred, succ) -> - ("FENCE", - [ - translate_imm4 "pred" pred; - translate_imm4 "succ" succ; - ], - []) -| `RISCVFENCEI -> - ("FENCEI", - [], - []) -| `RISCVLoadRes(aq, rl, rs1, width, rd) -> - ("LOADRES", - [ - translate_bool "aq" aq; - translate_bool "rl" rl; - translate_reg "rs1" rs1; - translate_width "width" width; - translate_reg "rd" rd; - ], - []) -| `RISCVStoreCon(aq, rl, rs2, rs1, width, rd) -> - ("STORECON", - [ - translate_bool "aq" aq; - translate_bool "rl" rl; - translate_reg "rs2" rs2; - translate_reg "rs1" rs1; - translate_width "width" width; - translate_reg "rd" rd; - ], - []) -| `RISCVAMO(op, aq, rl, rs2, rs1, width, rd) -> - ("AMO", - [ - translate_amoop "op" op; - translate_bool "aq" aq; - translate_bool "rl" rl; - translate_reg "rs2" rs2; - translate_reg "rs1" rs1; - translate_width "width" width; - translate_reg "rd" rd; - ], - []) diff --git a/risc-v/hgen/types.hgen b/risc-v/hgen/types.hgen deleted file mode 100644 index a0b75606..00000000 --- a/risc-v/hgen/types.hgen +++ /dev/null @@ -1,172 +0,0 @@ -type bit20 = int -type bit12 = int -type bit6 = int -type bit5 = int -type bit4 = int - -type riscvUop = (* upper immediate ops *) -| RISCVLUI -| RISCVAUIPC - -let pp_riscv_uop = function -| RISCVLUI -> "lui" -| RISCVAUIPC -> "auipc" - - -type riscvBop = (* branch ops *) -| RISCVBEQ -| RISCVBNE -| RISCVBLT -| RISCVBGE -| RISCVBLTU -| RISCVBGEU - -let pp_riscv_bop = function -| RISCVBEQ -> "beq" -| RISCVBNE -> "bne" -| RISCVBLT -> "blt" -| RISCVBGE -> "bge" -| RISCVBLTU -> "bltu" -| RISCVBGEU -> "bgeu" - -type riscvIop = (* immediate ops *) -| RISCVADDI -| RISCVSLTI -| RISCVSLTIU -| RISCVXORI -| RISCVORI -| RISCVANDI - -let pp_riscv_iop = function -| RISCVADDI -> "addi" -| RISCVSLTI -> "slti" -| RISCVSLTIU -> "sltiu" -| RISCVXORI -> "xori" -| RISCVORI -> "ori" -| RISCVANDI -> "andi" - -type riscvSop = (* shift ops *) -| RISCVSLLI -| RISCVSRLI -| RISCVSRAI - -let pp_riscv_sop = function -| RISCVSLLI -> "slli" -| RISCVSRLI -> "srli" -| RISCVSRAI -> "srai" - -type riscvRop = (* reg-reg ops *) -| RISCVADD -| RISCVSUB -| RISCVSLL -| RISCVSLT -| RISCVSLTU -| RISCVXOR -| RISCVSRL -| RISCVSRA -| RISCVOR -| RISCVAND - -let pp_riscv_rop = function -| RISCVADD -> "add" -| RISCVSUB -> "sub" -| RISCVSLL -> "sll" -| RISCVSLT -> "slt" -| RISCVSLTU -> "sltu" -| RISCVXOR -> "xor" -| RISCVSRL -> "srl" -| RISCVSRA -> "sra" -| RISCVOR -> "or" -| RISCVAND -> "and" - -type riscvRopw = (* reg-reg 32-bit ops *) -| RISCVADDW -| RISCVSUBW -| RISCVSLLW -| RISCVSRLW -| RISCVSRAW - -let pp_riscv_ropw = function -| RISCVADDW -> "addw" -| RISCVSUBW -> "subw" -| RISCVSLLW -> "sllw" -| RISCVSRLW -> "srlw" -| RISCVSRAW -> "sraw" - -type wordWidth = - | RISCVBYTE - | RISCVHALF - | RISCVWORD - | RISCVDOUBLE - -let pp_word_width width : string = - begin match width with - | RISCVBYTE -> "b" - | RISCVHALF -> "h" - | RISCVWORD -> "w" - | RISCVDOUBLE -> "d" - end - -let pp_riscv_load_op (unsigned, width, aq, rl) = - "l" ^ - (pp_word_width width) ^ - (if unsigned then "u" else "") ^ - (if aq then ".aq" else "") ^ - (if rl then ".rl" else "") - -let pp_riscv_store_op (width, aq, rl) = - "s" ^ - (pp_word_width width) ^ - (if aq then ".aq" else "") ^ - (if rl then ".rl" else "") - -let pp_riscv_load_reserved_op (aq, rl, width) = - "lr." ^ - (pp_word_width width) ^ - (if aq then ".aq" else "") ^ - (if rl then ".rl" else "") - -let pp_riscv_store_conditional_op (aq, rl, width) = - "sc." ^ - (pp_word_width width) ^ - (if aq then ".aq" else "") ^ - (if rl then ".rl" else "") - -type riscvAmoop = - | RISCVAMOSWAP - | RISCVAMOADD - | RISCVAMOXOR - | RISCVAMOAND - | RISCVAMOOR - | RISCVAMOMIN - | RISCVAMOMAX - | RISCVAMOMINU - | RISCVAMOMAXU - -let pp_riscv_amo_op_part = function - | RISCVAMOSWAP -> "swap" - | RISCVAMOADD -> "add" - | RISCVAMOXOR -> "xor" - | RISCVAMOAND -> "and" - | RISCVAMOOR -> "or" - | RISCVAMOMIN -> "min" - | RISCVAMOMAX -> "max" - | RISCVAMOMINU -> "minu" - | RISCVAMOMAXU -> "maxu" - -let pp_riscv_amo_op (op, aq, rl, width) = - "amo" ^ - pp_riscv_amo_op_part op ^ - begin match width with - | RISCVWORD -> ".w" - | RISCVDOUBLE -> ".d" - | _ -> assert false - end ^ - (if aq then ".aq" else "") ^ - (if rl then ".rl" else "") - -let pp_riscv_fence_option = function - | 0b0011 -> "rw" - | 0b0010 -> "r" - | 0b0001 -> "w" - | _ -> failwith "unexpected fence option" diff --git a/risc-v/hgen/types_sail_trans_out.hgen b/risc-v/hgen/types_sail_trans_out.hgen deleted file mode 100644 index 66a2020c..00000000 --- a/risc-v/hgen/types_sail_trans_out.hgen +++ /dev/null @@ -1,98 +0,0 @@ -let translate_out_big_bit = function - | (name, Bvector _, bits) -> IInt.integer_of_bit_list bits - | _ -> assert false - -let translate_out_int inst = (Nat_big_num.to_int (translate_out_big_bit inst)) -let translate_out_signed_int inst bits = - let i = (Nat_big_num.to_int (translate_out_big_bit inst)) in - if (i >= (1 lsl (bits - 1))) then - (i - (1 lsl bits)) else - i - -let translate_out_ireg ireg = IReg (int_to_ireg (translate_out_int ireg)) - -let translate_out_simm21 imm = translate_out_signed_int imm 21 -let translate_out_simm20 imm = translate_out_signed_int imm 20 -let translate_out_simm13 imm = translate_out_signed_int imm 13 -let translate_out_simm12 imm = translate_out_signed_int imm 12 -let translate_out_imm6 imm = translate_out_int imm -let translate_out_imm5 imm = translate_out_int imm -let translate_out_imm4 imm = translate_out_int imm - -let translate_out_bool = function - | (name, Bit, [Bitc_one]) -> true - | (name, Bit, [Bitc_zero]) -> false - | _ -> assert false - -let translate_out_enum (name,_,bits) = - Nat_big_num.to_int (IInt.integer_of_bit_list bits) - -let translate_out_wordWidth w = - match translate_out_enum w with - | 0 -> RISCVBYTE - | 1 -> RISCVHALF - | 2 -> RISCVWORD - | 3 -> RISCVDOUBLE - | _ -> failwith "Unknown wordWidth in sail translate out" - -let translate_out_uop op = match translate_out_enum op with - | 0 -> RISCVLUI - | 1 -> RISCVAUIPC - | _ -> failwith "Unknown uop in sail translate out" - -let translate_out_bop op = match translate_out_enum op with -| 0 -> RISCVBEQ -| 1 -> RISCVBNE -| 2 -> RISCVBLT -| 3 -> RISCVBGE -| 4 -> RISCVBLTU -| 5 -> RISCVBGEU -| _ -> failwith "Unknown bop in sail translate out" - -let translate_out_iop op = match translate_out_enum op with -| 0 -> RISCVADDI -| 1 -> RISCVSLTI -| 2 -> RISCVSLTIU -| 3 -> RISCVXORI -| 4 -> RISCVORI -| 5 -> RISCVANDI -| _ -> failwith "Unknown iop in sail translate out" - -let translate_out_sop op = match translate_out_enum op with -| 0 -> RISCVSLLI -| 1 -> RISCVSRLI -| 2 -> RISCVSRAI -| _ -> failwith "Unknown sop in sail translate out" - -let translate_out_rop op = match translate_out_enum op with -| 0 -> RISCVADD -| 1 -> RISCVSUB -| 2 -> RISCVSLL -| 3 -> RISCVSLT -| 4 -> RISCVSLTU -| 5 -> RISCVXOR -| 6 -> RISCVSRL -| 7 -> RISCVSRA -| 8 -> RISCVOR -| 9 -> RISCVAND -| _ -> failwith "Unknown rop in sail translate out" - -let translate_out_ropw op = match translate_out_enum op with -| 0 -> RISCVADDW -| 1 -> RISCVSUBW -| 2 -> RISCVSLLW -| 3 -> RISCVSRLW -| 4 -> RISCVSRAW -| _ -> failwith "Unknown ropw in sail translate out" - -let translate_out_amoop op = match translate_out_enum op with -| 0 -> RISCVAMOSWAP -| 1 -> RISCVAMOADD -| 2 -> RISCVAMOXOR -| 3 -> RISCVAMOAND -| 4 -> RISCVAMOOR -| 5 -> RISCVAMOMIN -| 6 -> RISCVAMOMAX -| 7 -> RISCVAMOMINU -| 8 -> RISCVAMOMAXU -| _ -> failwith "Unknown amoop in sail translate out" diff --git a/risc-v/hgen/types_trans_sail.hgen b/risc-v/hgen/types_trans_sail.hgen deleted file mode 100644 index 238c7e5b..00000000 --- a/risc-v/hgen/types_trans_sail.hgen +++ /dev/null @@ -1,57 +0,0 @@ -let translate_enum enum_values name value = - let rec bit_count n = - if n = 0 then 0 - else 1 + (bit_count (n lsr 1)) in - let rec find_index element = function - | h::tail -> if h = element then 0 else 1 + (find_index element tail) - | _ -> failwith "translate_enum could not find value" - in - let size = bit_count (List.length enum_values) in - let index = find_index value enum_values in - (name, Range0 (Some size), IInt.bit_list_of_integer size (Nat_big_num.of_int index)) - -let translate_uop = translate_enum [RISCVLUI; RISCVAUIPC] - -let translate_bop = translate_enum [RISCVBEQ; RISCVBNE; RISCVBLT; RISCVBGE; RISCVBLTU; RISCVBGEU] (* branch ops *) - -let translate_iop = translate_enum [RISCVADDI; RISCVSLTI; RISCVSLTIU; RISCVXORI; RISCVORI; RISCVANDI] (* immediate ops *) - -let translate_sop = translate_enum [RISCVSLLI; RISCVSRLI; RISCVSRAI] (* shift ops *) - -let translate_rop = translate_enum [RISCVADD; RISCVSUB; RISCVSLL; RISCVSLT; RISCVSLTU; RISCVXOR; RISCVSRL; RISCVSRA; RISCVOR; RISCVAND] (* reg-reg ops *) - -let translate_ropw = translate_enum [RISCVADDW; RISCVSUBW; RISCVSLLW; RISCVSRLW; RISCVSRAW] (* reg-reg 32-bit ops *) - -let translate_amoop = translate_enum [RISCVAMOSWAP; RISCVAMOADD; RISCVAMOXOR; RISCVAMOAND; RISCVAMOOR; RISCVAMOMIN; RISCVAMOMAX; RISCVAMOMINU; RISCVAMOMAXU] - -let translate_width = translate_enum [RISCVBYTE; RISCVHALF; RISCVWORD; RISCVDOUBLE] - -let translate_reg name value = - (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int (reg_to_int value))) - -let translate_imm21 name value = - (name, Bvector (Some 21), bit_list_of_integer 21 (Nat_big_num.of_int value)) - -let translate_imm20 name value = - (name, Bvector (Some 20), bit_list_of_integer 20 (Nat_big_num.of_int value)) - -let translate_imm16 name value = - (name, Bvector (Some 16), bit_list_of_integer 16 (Nat_big_num.of_int value)) - -let translate_imm13 name value = - (name, Bvector (Some 13), bit_list_of_integer 13 (Nat_big_num.of_int value)) - -let translate_imm12 name value = - (name, Bvector (Some 12), bit_list_of_integer 12 (Nat_big_num.of_int value)) - -let translate_imm6 name value = - (name, Bvector (Some 6), bit_list_of_integer 6 (Nat_big_num.of_int value)) - -let translate_imm5 name value = - (name, Bvector (Some 5), bit_list_of_integer 5 (Nat_big_num.of_int value)) - -let translate_imm4 name value = - (name, Bvector (Some 4), bit_list_of_integer 4 (Nat_big_num.of_int value)) - -let translate_bool name value = - (name, Bit, [if value then Bitc_one else Bitc_zero]) -- cgit v1.2.3 From 5fa993caef3c48da36f641bf3608a9515ecc40cf Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Mon, 4 Dec 2017 14:54:54 +0000 Subject: match what rmem expects from sail/arm --- arm/Makefile | 59 +- arm/aarch64_regfp.sail | 598 +++++++++++ arm/armV8.h.sail | 24 + arm/armV8.sail | 157 ++- arm/armV8_A64_lib.sail | 18 +- arm/armV8_A64_sys_regs.sail | 200 +--- arm/armV8_common_lib.sail | 10 +- arm/armV8_extras.lem | 77 ++ arm/armV8_extras_embed.lem | 59 ++ arm/armV8_extras_embed_sequential.lem | 59 ++ arm/armV8_lib.h.sail | 5 +- arm/gen/ast.hgen | 44 + arm/gen/fold.hgen | 44 + arm/gen/herdtools_ast_to_shallow_ast.hgen | 335 ++++++ arm/gen/herdtools_types_to_shallow_types.hgen | 153 +++ arm/gen/lexer.hgen | 309 ++++++ arm/gen/map.hgen | 44 + arm/gen/parser.hgen | 1396 +++++++++++++++++++++++++ arm/gen/pretty.hgen | 393 +++++++ arm/gen/regs_out_in.hgen | 155 +++ arm/gen/sail_trans_out.hgen | 326 ++++++ arm/gen/shallow_ast_to_herdtools_ast.hgen | 326 ++++++ arm/gen/shallow_types_to_herdtools_types.hgen | 154 +++ arm/gen/token_types.hgen | 85 ++ arm/gen/tokens.hgen | 78 ++ arm/gen/trans_sail.hgen | 379 +++++++ arm/gen/types.hgen | 90 ++ arm/gen/types_sail_trans_out.hgen | 189 ++++ arm/gen/types_trans_sail.hgen | 119 +++ 29 files changed, 5623 insertions(+), 262 deletions(-) create mode 100644 arm/aarch64_regfp.sail create mode 100644 arm/armV8_extras.lem create mode 100644 arm/armV8_extras_embed.lem create mode 100644 arm/armV8_extras_embed_sequential.lem create mode 100644 arm/gen/ast.hgen create mode 100644 arm/gen/fold.hgen create mode 100644 arm/gen/herdtools_ast_to_shallow_ast.hgen create mode 100644 arm/gen/herdtools_types_to_shallow_types.hgen create mode 100644 arm/gen/lexer.hgen create mode 100644 arm/gen/map.hgen create mode 100644 arm/gen/parser.hgen create mode 100644 arm/gen/pretty.hgen create mode 100644 arm/gen/regs_out_in.hgen create mode 100644 arm/gen/sail_trans_out.hgen create mode 100644 arm/gen/shallow_ast_to_herdtools_ast.hgen create mode 100644 arm/gen/shallow_types_to_herdtools_types.hgen create mode 100644 arm/gen/token_types.hgen create mode 100644 arm/gen/tokens.hgen create mode 100644 arm/gen/trans_sail.hgen create mode 100644 arm/gen/types.hgen create mode 100644 arm/gen/types_sail_trans_out.hgen create mode 100644 arm/gen/types_trans_sail.hgen diff --git a/arm/Makefile b/arm/Makefile index 18eba393..d7124df6 100644 --- a/arm/Makefile +++ b/arm/Makefile @@ -1,16 +1,5 @@ -BUILDDIR=./build - -SAIL=../sail -ifeq ("$(wildcard $(SAIL))","") - $(warning can not find Sail) -endif - -LEM=../../lem/lem -ifeq ("$(wildcard $(LEM))","") - $(warning can not find Lem) -endif - -LEMINTERPDIR=../src/lem_interp/ +SAIL:=../src/sail.native +LEM:=../../lem/lem # the order of the files is important SOURCES=armV8.h.sail\ @@ -23,39 +12,28 @@ SOURCES=armV8.h.sail\ armV8_A64_lib.sail\ armV8.sail -all: $(BUILDDIR)/armv8.ml - -clean: - rm -rf $(BUILDDIR) - -ocaml: $(BUILDDIR)/armv8_embed.ml +all: armV8.lem armV8.ml armV8_embed.lem -.PHONY: all clean ocaml +armV8.lem: $(SOURCES) + $(SAIL) -lem_ast -o armV8 $(SOURCES) -$(BUILDDIR): - mkdir -p $@ +armV8.ml: armV8.lem ../src/lem_interp/interp_ast.lem + $(LEM) -ocaml -lib ../src/lem_interp/ $< -$(BUILDDIR)/armv8.lem: $(SOURCES) | $(BUILDDIR) - $(SAIL) -lem_ast $(SOURCES) -o $(basename $@) -# sail generates the .lem file in pwd - mv $(notdir $@) $@ -$(BUILDDIR)/armv8.ml: $(BUILDDIR)/armv8.lem - $(LEM) -ocaml -lib $(LEMINTERPDIR) $< - -$(BUILDDIR)/armv8_embed.ml: $(SOURCES) | $(BUILDDIR) - $(SAIL) -ocaml $(SOURCES) -o $(basename $@) -# sail generates the .lem file in pwd - mv $(notdir $@) $@ +armV8_embed.lem: $(SOURCES) ../etc/regfp.sail aarch64_regfp.sail +# also generates armV8_embed_sequential.lem, armV8_embed_types.lem, armV8_toFromInterp.lem + $(SAIL) -lem -lem_lib ArmV8_extras_embed -o armV8 $^ +clean: + rm -f armV8.lem armV8.ml + rm -f armV8_embed*.lem armV8_toFromInterp.lem ###################################################################### ETCDIR=../etc apply_header: - -chmod u+w *.sail headache -c $(ETCDIR)/headache_config -h $(ETCDIR)/arm_header *.sail - chmod a-w *.sail .PHONY: apply_header @@ -63,10 +41,13 @@ apply_header: IDLARM=../../../rsem/idlarm pull_from_idlarm: - svn up $(IDLARM) - $(MAKE) -C $(IDLARM) - -chmod u+w *.sail + $(MAKE) -C $(IDLARM) clean + $(MAKE) -C $(IDLARM) san_sail rm -f *.sail cp -a $(IDLARM)/build/*.sail ./ - chmod a-w *.sail + cp -a $(IDLARM)/armV8_extras_embed.lem ./ + cp -a $(IDLARM)/armV8_extras_embed_sequential.lem ./ + cp -a $(IDLARM)/armV8_extras.lem ./ + mkdir -p gen + cp -a $(IDLARM)/*.hgen gen/ $(MAKE) apply_header diff --git a/arm/aarch64_regfp.sail b/arm/aarch64_regfp.sail new file mode 100644 index 00000000..148f9646 --- /dev/null +++ b/arm/aarch64_regfp.sail @@ -0,0 +1,598 @@ +(*========================================================================*) +(* *) +(* Copyright (c) 2015-2017 Shaked Flur *) +(* Copyright (c) 2015-2017 Kathyrn Gray *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(*========================================================================*) + +function instruction_kind rmem_kind ((AccType) acctype, (bool) exclusive) = + if exclusive then + switch acctype { + case AccType_ATOMIC -> IK_mem_read(Read_exclusive) + case AccType_ORDERED -> IK_mem_read(Read_exclusive_acquire) + case _ -> { not_implemented("unimplemented memory access"); + IK_mem_read(Read_exclusive); } + } + else + switch acctype { + case AccType_NORMAL -> IK_mem_read(Read_plain) + case AccType_ATOMIC -> IK_mem_read(Read_plain) + case AccType_STREAM -> IK_mem_read(Read_stream) + case AccType_UNPRIV -> IK_mem_read(Read_plain) + case AccType_ORDERED -> IK_mem_read(Read_acquire) + } + + +function instruction_kind wmem_kind ((AccType) acctype, (bool) exclusive) = + if exclusive then { + switch acctype { + case AccType_ATOMIC -> IK_mem_write(Write_exclusive) + case AccType_ORDERED -> IK_mem_write(Write_exclusive_release) + case _ -> { not_implemented("unimplemented memory access"); + IK_mem_write(Write_exclusive); } + } + } else { + switch acctype { + case AccType_NORMAL -> IK_mem_write(Write_plain) + case AccType_STREAM -> IK_mem_write(Write_plain) + case AccType_UNPRIV -> IK_mem_write(Write_plain) + case AccType_ORDERED -> IK_mem_write(Write_release) + case _ -> { not_implemented("unimplemented memory access"); + IK_mem_write(Write_plain) } + }; + } + + +let (vector<30,31,dec,string>) _Rs = + ["R30","R29","R28","R27","R26","R25","R24","R23","R22","R21", + "R20","R19","R18","R17","R16","R15","R14","R13","R12","R11", + "R10","R9" ,"R8" ,"R7" ,"R6" ,"R5" ,"R4" ,"R3" ,"R2" ,"R1" , + "R0"] + +let TxNestingLevelfp = RFull("TxNestingLevel") +let TXIDR_EL0_DEPTHfp = RField("TXIDR_EL0","DEPTH") + +let PSTATE_Nfp = RField("NZCV","N") +let PSTATE_Zfp = RField("NZCV","Z") +let PSTATE_Cfp = RField("NZCV","C") +let PSTATE_Vfp = RField("NZCV","V") +let PSTATE_Dfp = RField("DAIF","D") +let PSTATE_Afp = RField("DAIF","A") +let PSTATE_Ifp = RField("DAIF","I") +let PSTATE_Ffp = RField("DAIF","F") +let PSTATE_ELfp = RFull("CurrentEL") +let PSTATE_SPfp = RField("SPSel","SP") +let _PCfp = RFull("_PC") + +let NZCVfp = [|| PSTATE_Nfp, PSTATE_Zfp, PSTATE_Cfp, PSTATE_Vfp ||] + +function regfps xFP((reg_index) n) = + if n != 31 then [||RFull(_Rs[n])||] else [|| ||] + + +(* check if this is still what we want *) +function forall Nat 'N, 'N IN {32,64}. (regfps,regfps) BranchToFP (iR,oR) = + (if UsingAArch32() then iR else PSTATE_ELfp :: iR, _PCfp :: oR) + +function regfps ConditionHoldsIFP((bit[4]) _cond) = + switch _cond[3..1] { + case 0b000 -> [|| PSTATE_Zfp ||] + case 0b001 -> [|| PSTATE_Cfp ||] + case 0b010 -> [|| PSTATE_Nfp ||] + case 0b011 -> [|| PSTATE_Vfp ||] + case 0b100 -> [|| PSTATE_Cfp, PSTATE_Zfp ||] + case 0b101 -> [|| PSTATE_Nfp, PSTATE_Vfp ||] + case 0b110 -> [|| PSTATE_Nfp, PSTATE_Vfp, PSTATE_Zfp ||] + case 0b111 -> [|| ||] + } + +(* for iR if rSPFP, for oR if wSPFP *) +let rSPIFP = + (* TODO: actually this depends on runtime data: PSTATE_SP and PSTATE_EL *) + [|| PSTATE_SPfp, RFull("SP_EL0") ||] + +let wSPFP = + (* TODO: actually this depends on runtime data: PSTATE_SP and PSTATE_EL *) + ([|| PSTATE_SPfp ||], + [|| RFull("SP_EL0") ||]) + + +let CheckSPAlignmentIFP = PSTATE_ELfp :: rSPIFP + +let BigEndianIFP = + if UsingAArch32() then [|| RFull("PSTATE_E") ||] else [|| PSTATE_ELfp ||] + +let wMem'IFP = BigEndianIFP +let wMemIFP = wMem'IFP + +function (regfps,regfps,regfps,niafps,diafp,instruction_kind) effect pure initial_analysis (instr) = { + iR := [|| ||]; + oR := [|| ||]; + aR := [|| ||]; + Nias := [|| NIAFP_successor ||]; + Dia := DIAFP_none; + ik := IK_simple; + + switch instr { + case (TMStart(t)) -> { + iR := TxNestingLevelfp :: TXIDR_EL0_DEPTHfp :: iR; + (* TODO: whether the following applies depends on runtime data: + ~(TxNestingLevel >= TXIDR_EL0.DEPTH) *) + oR := TxNestingLevelfp :: append(oR,xFP(t)); + ik := IK_trans(Transaction_start); + } + case (TMCommit) -> { + iR := TxNestingLevelfp :: iR; + oR := TxNestingLevelfp :: oR; + ik := IK_trans(Transaction_commit); + } + case (TMAbort(retry,reason)) -> { + iR := TxNestingLevelfp :: iR; + ik := IK_trans(Transaction_abort); + } + case (TMTest) -> { + iR := TxNestingLevelfp :: iR; + oR := RFull("NZCV") :: oR; + } + case (CompareAndBranch(t,datasize,iszero,offset)) -> { + iR := append(iR,xFP(t)); + (* TODO: whether the following applies depends on runtime data: + IsZero(operand1) *) + let (i,o) = BranchToFP(iR,oR) in {iR := i; oR := o}; + (bit[64]) nia' := rPC() + offset; + Nias := [|| NIAFP_successor, NIAFP_concrete_address(nia') ||]; + ik := IK_cond_branch; + } + case (BranchConditional(offset,condition)) -> { + iR := append(iR,ConditionHoldsIFP(condition)); + (* TODO: whether the following applies depends on runtime data: + ConditionHolds(condition) *) + let (i,o) = BranchToFP(iR,oR) in {iR := i; oR := o}; + Nias := [|| NIAFP_successor, NIAFP_concrete_address(rPC() + offset) ||]; + ik := IK_cond_branch; + } + case (GenerateExceptionEL1(imm)) -> not_implemented("GenerateExceptionEL1") + case (GenerateExceptionEL2(imm)) -> not_implemented("GenerateExceptionEL2") + case (GenerateExceptionEL3(imm)) -> not_implemented("GenerateExceptionEL3") + case (DebugBreakpoint(comment)) -> not_implemented("DebugBreakpoint") + case (ExternalDebugBreakpoint) -> not_implemented("ExternalDebugBreakpoint") + case (DebugSwitchToExceptionLevel(target_level)) -> not_implemented("DebugSwitchToExceptionLevel") + case (MoveSystemImmediate(operand,field)) -> + switch field { + case PSTATEField_SP -> oR := PSTATE_SPfp :: oR + case PSTATEField_DAIFSet -> { + iR := append(iR, [|| PSTATE_Dfp, PSTATE_Afp, PSTATE_Ifp, PSTATE_Ffp ||]); + oR := append(oR, [|| PSTATE_Dfp, PSTATE_Afp, PSTATE_Ifp, PSTATE_Ffp ||]); + } + case PSTATEField_DAIFClr -> { + iR := append(iR, [|| PSTATE_Dfp, PSTATE_Afp, PSTATE_Ifp, PSTATE_Ffp ||]); + oR := append(oR, [|| PSTATE_Dfp, PSTATE_Afp, PSTATE_Ifp, PSTATE_Ffp ||]); + } + } + case (Hint(op)) -> + switch op { + case SystemHintOp_YIELD -> () + case SystemHintOp_WFE -> { + if EventRegistered() then () (* ClearEventRegister *) + else { + (* the execute code for this case always fails because of + WaitForEvent, declared as extern but not defined *) + not_implemented("Hint(SystemHintOp_WFE);") + } + } + case SystemHintOp_WFI -> { + (* the execute code for this case always fails because of + InterruptPending, declared as extern but not defined *) + not_implemented("Hint(SystemHintOp_WFI);") + } + case SystemHintOp_SEV -> () (*SendEvent*) + case SystemHintOp_SEVL -> + (* the execute code for this case always fails because of + EventRegisterSet, declared as extern but not defined *) + not_implemented("Hint(SystemHintOp_SEVL);") + case _ -> () (* do nothing *) + } + case (ClearExclusiveMonitor(imm)) -> () (*ClearExclusiveLocal*) + case (Barrier(op,domain,types)) -> { + ik := switch op { + case MemBarrierOp_DSB -> + switch types { + case MBReqTypes_Reads -> IK_barrier(Barrier_DSB_LD) + case MBReqTypes_Writes -> IK_barrier(Barrier_DSB_ST) + case MBReqTypes_All -> IK_barrier(Barrier_DSB) + } + case MemBarrierOp_DMB -> + switch types { + case MBReqTypes_Reads -> IK_barrier(Barrier_DMB_LD) + case MBReqTypes_Writes -> IK_barrier(Barrier_DMB_ST) + case MBReqTypes_All -> IK_barrier(Barrier_DMB) + } + case MemBarrierOp_ISB -> + IK_barrier(Barrier_ISB) + }; + } + case (System(t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,has_result)) -> { + oR := append(oR,xFP(t)); + not_implemented("System"); (* because SysOp_R and SysOp_W *) + } + case (MoveSystemRegister(t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,read)) -> { + if read then { + oR := append(oR,xFP(t)); + switch (sys_op0,sys_op1,sys_crn,sys_crm,sys_op2) { (* System_Get *) + case (3,3,4,2,0) -> iR := RFull("NZCV") :: iR + case (3,3,4,2,1) -> iR := RFull("DAIF") :: iR + case (3, 3, 13, 0, 2) -> iR := RFull("TPIDR_EL0") :: iR + (* TODO FIXME: higher EL TPIDRs *) + } + } + else { + iR := append(iR,xFP(t)); + switch (sys_op0,sys_op1,sys_crn,sys_crm,sys_op2) { (* System_Put *) + case (3,3,4,2,0) -> oR := RFull("NZCV") :: oR + case (3,3,4,2,1) -> oR := RFull("DAIF") :: oR + case (3, 3, 13, 0, 2) -> oR := RFull("TPIDR_EL0") :: oR + (* TODO FIXME: higher EL TPIDRs *) + } + } + } + case (ImplementationDefinedTestBeginEnd(isEnd)) -> () + case (ImplementationDefinedStopFetching) -> () + case (ImplementationDefinedThreadStart) -> () + case (TestBitAndBranch(t,datasize,bit_pos,bit_val,offset)) -> { + iR := append(xFP(t),iR); + (* TODO: whether the following applies depends on runtime data: + operand[bit_pos] == bit_val *) + let (i,o) = BranchToFP(iR,oR) in {iR := i; oR := o}; + Nias := [|| NIAFP_successor, NIAFP_concrete_address(rPC() + offset) ||]; + ik := IK_cond_branch; + } + case (BranchImmediate(branch_type,offset)) -> { + if branch_type == BranchType_CALL + then {iR := _PCfp :: iR; oR := append(xFP(30),oR)}; + let (i,o) = BranchToFP(iR,oR) in {iR := i; oR := o}; + Nias := [|| NIAFP_concrete_address(rPC() + offset) ||]; + ik := IK_simple (* IK_uncond_branch *) + } + case (BranchRegister(n,branch_type)) -> { + iR := append(iR,xFP(n)); + if branch_type == BranchType_CALL + then {iR := _PCfp :: iR; oR := append(xFP(30),oR)}; + let (i,o) = BranchToFP(iR,oR) in {iR := i; oR := o}; + Nias := if n ==31 + then [|| NIAFP_concrete_address(0) ||] + else [|| NIAFP_register(RFull(_Rs[n]))||]; + ik := IK_simple (* IK_uncond_branch *) + } + case (ExceptionReturn) -> not_implemented("ExceptionReturn") + case (DebugRestorePState) -> not_implemented("DebugRestorePState") + case (LoadLiteral(t,memop,_signed,size,offset,datasize)) -> { + (* assuming rMem doesn't touch other registers *) + iR := _PCfp :: iR; + oR := append(xFP(t),oR); + aR := _PCfp :: aR; + switch memop { + case MemOp_LOAD -> ik := IK_mem_read(Read_plain) + case MemOp_PREFETCH -> {ik := IK_simple; aR := [|| ||]} + } + } + case (LoadStoreAcqExc(n,t,t2,s,acctype,excl,pair,memop,elsize,regsize,datasize)) -> { + (boolean) rt_unknown := false; + (boolean) rn_unknown := false; + if n==31 then { + iR := append(CheckSPAlignmentIFP,iR); + iR := append(rSPIFP,iR); + aR := append(rSPIFP,aR); + } + else if rn_unknown then () + else { + iR := append(xFP(n),iR); + aR := append(xFP(n),aR); + }; + switch memop { + case MemOp_STORE -> { + if rt_unknown then () + else if pair then iR := append(xFP(t),append(xFP(t2),iR)) + else iR := append(xFP(t),iR); + if excl then { + (* TODO: the command below depends on runtime data: + AArch64_ExclusiveMonitorsPass(address, dbytes) *) + iR := append(iR,wMemIFP); + oR := append(xFP(s),oR); + ik := wmem_kind(acctype,true); + } + else { + iR := append(iR,wMemIFP); + ik := wmem_kind(acctype,false); + } + } + case MemOp_LOAD -> { + if pair then { + if rt_unknown then + oR := append(xFP(t),oR) + else if elsize == 32 then { + iR := append(iR,BigEndianIFP); + oR := append(xFP(t),append(xFP(t2),oR)); + } + else { + oR := append(xFP(t),append(xFP(t2),oR)) + }; + ik := rmem_kind(acctype,true); + } + else { + oR := append(xFP(t),oR); + ik := rmem_kind(acctype,excl); + } + + } + case MemOp_PREFETCH -> aR := [|| ||] + } + } + case (LoadStorePairNonTemp(wback,postindex,n,t,t2,acctype,memop,scale,datasize,offset)) -> { + (boolean) rt_unknown := false; + if n == 31 then { + iR := append(CheckSPAlignmentIFP,iR); + iR := append(rSPIFP,iR); + aR := append(rSPIFP,aR); + } + else { + iR := append(xFP(n),iR); + aR := append(xFP(n),aR); + }; + if wback then { + if n == 31 then + let (i,o) = wSPFP in { + iR := append(i,iR); + oR := append(o,oR); + } + else + oR := append(xFP(n),oR); + }; + switch memop { + case MemOp_STORE -> { + if rt_unknown & t == n then () + else iR := append(xFP(t),iR); + if rt_unknown & t2 == n then () + else iR := append(xFP(t2),iR); + iR := append(wMemIFP,iR); + ik := wmem_kind(acctype,false); + } + case MemOp_LOAD -> { + oR := append(xFP(t),append(xFP(t2),oR)); + ik := rmem_kind(acctype,false); + } + } + } + case (LoadImmediate(n,t,acctype,memop,_signed,wback,postindex,offset,regsize,datasize)) -> { + (boolean) wb_unknown := false; + (boolean) rt_unknown := false; + if n == 31 then { + iR := append(CheckSPAlignmentIFP,iR); + iR := append(rSPIFP,iR); + aR := append(rSPIFP,aR); + } + else { + iR := append(xFP(n),iR); + aR := append(xFP(n),aR); + }; + if wback then { + if n == 31 then + let (i,o) = wSPFP in {iR := append(i,iR); oR := append(o,oR)} + else oR := append(xFP(n),oR); + }; + switch memop { + case MemOp_STORE -> { + if rt_unknown then () + else iR := append(xFP(t),iR); + iR := append(wMemIFP,iR); + ik := wmem_kind(acctype,false); + } + case MemOp_LOAD -> { + oR := append(xFP(t),oR); + ik := rmem_kind(acctype,false); + } + case MemOp_PREFETCH -> aR := [|| ||] + } + } + case (LoadRegister(n,t,m,acctype,memop,_signed,wback,postindex,extend_type,shift,regsize,datasize)) -> { + iR := append(xFP(m),iR); + aR := append(xFP(m),aR); + (boolean) wb_unknown := false; + (boolean) rt_unknown := false; + if n == 31 then { + iR := append(CheckSPAlignmentIFP,iR); + iR := append(rSPIFP,iR); + aR := append(rSPIFP,aR); + } + else { + iR := append(xFP(n),iR); + aR := append(xFP(n),aR); + }; + if wback then { + if n == 31 then let (i,o) = wSPFP in {iR := append(i,iR); oR := append(o,oR)} + else oR := append(xFP(n),oR); + }; + switch memop { + case MemOp_STORE -> { + if rt_unknown then () + else iR := append(xFP(t),iR); + iR := append(wMemIFP,iR); + ik := wmem_kind(acctype,false); + } + case MemOp_LOAD -> { + oR := append(xFP(t),oR); + ik := rmem_kind(acctype,false); + } + case MemOp_PREFETCH -> aR := [|| ||] + } + } + case (LoadStorePair(wback,postindex,n,t,t2,acctype,memop,_signed,datasize,offset)) -> { + (boolean) rt_unknown := false; + (boolean) wb_unknown := false; + if n == 31 then { + iR := append(CheckSPAlignmentIFP,iR); + iR := append(rSPIFP,iR); + aR := append(rSPIFP,aR); + } + else { + iR := append(xFP(n),iR); + aR := append(xFP(n),aR); + }; + if wback then { + if n == 31 then let (i,o) = wSPFP in {iR := append(i,iR); oR := append(o,oR)} + else oR := append(xFP(n),oR); + }; + switch memop { + case MemOp_STORE -> { + if rt_unknown & t == n then () + else iR := append(xFP(t),iR); + if rt_unknown & t2 == n then () + else iR := append(xFP(t2),iR); + iR := append(wMemIFP,iR); + ik := wmem_kind(acctype,false); + } + case MemOp_LOAD -> { + oR := append(xFP(t),oR); + oR := append(xFP(t2),oR); + ik := rmem_kind(acctype,false); + } + } + } + case (AddSubImmediate(d,n,datasize,sub_op,setflags,imm)) -> { + iR := append(if n == 31 then rSPIFP else xFP(n),iR); + if setflags then oR := append(NZCVfp,oR); + if d ==31 & ~(setflags) then + let (i,o) = wSPFP in + { iR := append(i,iR); + oR := append(o,oR) } + else oR := append(xFP(d),oR) + } + case (BitfieldMove(d,n,datasize,inzero,extend,R,S,wmask,tmask)) -> { + if inzero then () else iR:= append(xFP(d),iR); + iR := append(xFP(n),iR); + oR := append(xFP(d),oR); + } + case (ExtractRegister(d,n,m,datasize,lsb)) -> { + iR := append(xFP(n),append(xFP(m),iR)); + oR := append(xFP(d),oR); + } + case (LogicalImmediate(d,n,datasize,setflags,op,imm)) -> { + iR := append(xFP(n),iR); + if setflags then oR := append(NZCVfp,oR); + if d ==31 & ~(setflags) then let (i,o) = wSPFP in + { iR := append(i,iR); oR := append(o,oR) } + else oR := append(xFP(d),oR) + } + case (MoveWide(d,datasize,imm,pos,opcode)) -> { + if opcode == MoveWideOp_K then iR := append(xFP(d),iR); + oR := append(xFP(d),oR); + } + case (Address(d,page,imm)) -> { + iR := _PCfp :: iR; + oR := append(xFP(d),oR); + } + case (AddSubExtendRegister(d,n,m,datasize,sub_op,setflags,extend_type,shift)) -> { + iR := append(if n == 31 then rSPIFP else xFP(n),iR); + iR := append(xFP(m),iR); + if setflags then oR := append(NZCVfp,oR); + if d ==31 & ~(setflags) then let (i,o) = wSPFP in + { iR := append(i,iR); oR := append(o,oR) } + else oR := append(xFP(d),oR) + } + case (AddSubShiftedRegister(d,n,m,datasize,sub_op,setflags,shift_type,shift_amount)) -> { + iR := append(xFP(n),append(xFP(m),iR)); + if setflags then oR := append(NZCVfp,oR); + oR := append(xFP(d),oR); + } + case (AddSubCarry(d,n,m,datasize,sub_op,setflags)) -> { + iR := append(xFP(n),append(xFP(m),iR)); + iR := PSTATE_Cfp :: iR; + if setflags then oR := append(NZCVfp,oR); + oR := append(xFP(d),oR); + } + case (ConditionalCompareImmediate(n,datasize,sub_op,condition,flags,imm)) -> { + iR := append(xFP(n),iR); + iR := append(ConditionHoldsIFP(condition),iR); + oR := append(NZCVfp,oR); + } + case (ConditionalCompareRegister(n,m,datasize,sub_op,condition,flags)) -> { + iR := append(xFP(n),append(xFP(m),iR)); + iR := append(ConditionHoldsIFP(condition),iR); + oR := append(NZCVfp,oR); + } + case (ConditionalSelect(d,n,m,datasize,condition,else_inv,else_inc)) -> { + iR := append(xFP(n),append(xFP(m),iR)); + iR := append(ConditionHoldsIFP(condition),iR); + oR := append(xFP(d),oR); + } + case (Reverse(d,n,datasize,op)) -> { + iR := append(xFP(n),iR); + oR := append(xFP(d),oR); + } + case (CountLeading(d,n,datasize,opcode)) -> { + iR := append(xFP(n),iR); + oR := append(xFP(d),oR); + } + case (Division(d,n,m,datasize,_unsigned)) -> { + iR := append(xFP(n),append(xFP(m),iR)); + oR := append(xFP(d),oR); + } + case (Shift(d,n,m,datasize,shift_type)) -> { + iR := append(xFP(m),iR); + iR := append(xFP(n),iR); + oR := append(xFP(d),oR); + } + case (CRC(d,n,m,size,crc32c)) -> { + iR := append(xFP(n),append(xFP(m),iR)); + oR := append(xFP(d),oR); + } + case (MultiplyAddSub(d,n,m,a,destsize,datasize,sub_op)) -> { + iR := append(xFP(n),iR); + iR := append(xFP(m),iR); + iR := append(xFP(a),iR); + oR := append(xFP(d),oR); + } + case (MultiplyAddSubLong(d,n,m,a,destsize,datasize,sub_op,_unsigned)) -> { + iR := append(xFP(n),iR); + iR := append(xFP(m),iR); + iR := append(xFP(a),iR); + oR := append(xFP(d),oR); + } + case (MultiplyHigh(d,n,m,a,destsize,datasize,_unsigned)) -> { + iR := append(xFP(n),append(xFP(m),iR)); + oR := append(xFP(d),oR); + } + case (LogicalShiftedRegister(d,n,m,datasize,setflags,op,shift_type,shift_amount,invert)) -> { + iR := append(xFP(n),append(xFP(m),iR)); + if setflags then oR := append(NZCVfp,oR); + oR := append(xFP(d),oR); + } + }; + (iR,oR,aR,Nias,Dia,ik) +} diff --git a/arm/armV8.h.sail b/arm/armV8.h.sail index c788855a..9105f964 100644 --- a/arm/armV8.h.sail +++ b/arm/armV8.h.sail @@ -43,6 +43,27 @@ typedef SIMD_index = [|32|] register (bit[64]) _PC +(* transactional memory registers *) +register (bit[8]) TxNestingLevel (* same size as TXIDR_EL0.DEPTH *) + +typedef TMSTATUS_type = register bits [63:0] +{ + (*63..17 : RES0;*) + 16 : IMP; + 15 : DBG; + 14 : MEM; + 13 : ERR; + 12 : INV; + 11 : SIZE; + 10 : NEST; + 9 : ABRT; + 8 : RTRY; + (*7..5 : RES0*) + 4..0 : REASON; +} +register (TMSTATUS_type) TMAbortEffect (* we abuse the register write to pass out the status value *) +register (TMSTATUS_type) TMStartEffect (* we abuse the register read to pass in the status value *) + (* General purpose registers *) register (bit[64]) R30 @@ -170,3 +191,6 @@ let IMPLEMENTATION_DEFINED = (* FIXME: ask Kathy what should we do with this *) let UNKNOWN = 0 + + +val extern unit -> bool effect {exmem} speculate_exclusive_success diff --git a/arm/armV8.sail b/arm/armV8.sail index 10c57d1e..2614c7a5 100644 --- a/arm/armV8.sail +++ b/arm/armV8.sail @@ -40,6 +40,12 @@ typedef ast = const union forall Nat 'R, 'R IN {32, 64}, (* register size *) ImplementationDefinedStopFetching; ImplementationDefinedThreadStart; + (* transactional memory, from the pre-alpha document *) + (reg_index) TMStart; + TMCommit; + (boolean,bit[5]) TMAbort; + TMTest; + (reg_index,[:'R:],boolean,bit[64]) CompareAndBranch; (bit[64],bit[4]) BranchConditional; (bit[16]) GenerateExceptionEL1; (* TODO: add to .hgen *) @@ -64,7 +70,7 @@ typedef ast = const union forall Nat 'R, 'R IN {32, 64}, (* register size *) (boolean,boolean,reg_index,reg_index,reg_index,AccType,MemOp,uinteger,[:'D:],bit[64]) LoadStorePairNonTemp; (reg_index,reg_index,AccType,MemOp,boolean,boolean,boolean,bit[64],[:'R:],[:'D:]) LoadImmediate; (reg_index,reg_index,reg_index,AccType,MemOp,boolean,boolean,boolean,ExtendType,uinteger,[:'R:],[:'D:]) LoadRegister; - (boolean,boolean,reg_index,reg_index,reg_index,AccType,MemOp,boolean,uinteger,[:'D:],bit[64]) LoadStorePair; + (boolean,boolean,reg_index,reg_index,reg_index,AccType,MemOp,boolean,[:'D:],bit[64]) LoadStorePair; (reg_index,reg_index,[:'R:],boolean,boolean,bit['R]) AddSubImmediate; (reg_index,reg_index,[:'R:],boolean,boolean,uinteger,uinteger,bit['R],bit['R]) BitfieldMove; (reg_index,reg_index,reg_index,[:'R:],uinteger) ExtractRegister; @@ -86,12 +92,91 @@ typedef ast = const union forall Nat 'R, 'R IN {32, 64}, (* register size *) (reg_index,reg_index,reg_index,reg_index,[:'R:],[:'D:],boolean,boolean) MultiplyAddSubLong; (reg_index,reg_index,reg_index,reg_index,[:'R:],[:'D:],boolean) MultiplyHigh; (reg_index,reg_index,reg_index,[:'R:],boolean,LogicalOp,ShiftType,[|63|],boolean) LogicalShiftedRegister; - } -val forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. ast<'R,'D> -> unit effect {rreg,wreg,rmem,barr,eamem,wmv,escape} execute +val forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. ast<'R,'D> -> unit effect {rreg,wreg,rmem,barr,eamem,wmv,exmem,escape} execute scattered function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. unit execute +(* TSTART - dummy decoding *) +function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. + option<(ast<'R,'D>)> effect pure decodeTMStart ((bit[5]) Rt) = +{ + (reg_index) t := UInt_reg(Rt); + + Some(TMStart(t)); +} + +(* transactional memory, from the pre-alpha document *) +function clause execute (TMStart(t)) = { + (bit[8]) nesting := TxNestingLevel; + + if nesting <_u TXIDR_EL0.DEPTH then { + TxNestingLevel := nesting + 1; + (bit[64]) status := 0; + if nesting == 0 then + status := TMStartEffect; (* fake effect *) + wX(t) := status; + } else { + (bit[64]) status := 0; + status[10] := 1; (* set the NEST bit *) + TMAbortEffect := status; (* fake effect *) + } +} + +val extern unit -> unit effect {barr} TMCommitEffect + +(* TCOMMIT - dummy decoding *) +function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. + option<(ast<'R,'D>)> effect pure decodeTMCommit () = +{ + Some(TMCommit); +} + +(* transactional memory, from the pre-alpha document *) +function clause execute (TMCommit) = { + (bit[8]) nesting := TxNestingLevel; + + if nesting == 1 then + TMCommitEffect() (* fake effect *) + else if nesting == 0 then + AArch64_UndefinedFault(); + + TxNestingLevel := nesting - 1; +} + +(* TTEST - dummy decoding *) +function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. + option<(ast<'R,'D>)> effect pure decodeTMTest () = +{ + Some(TMTest); +} + +(* transactional memory, from the pre-alpha document *) +function clause execute (TMTest) = { + if TxNestingLevel > 0 then + wPSTATE_NZCV() := 0b0000 + else + wPSTATE_NZCV() := 0b0100 +} + +(* TABORT - dummy decoding *) +function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. + option<(ast<'R,'D>)> effect pure decodeTMAbort ([R]:(bit[5]) imm5) = +{ + Some(TMAbort(R,imm5)); +} + +(* transactional memory, from the pre-alpha document *) +function clause execute (TMAbort(retry,reason)) = { + if TxNestingLevel > 0 then { + (bit[64]) status := 0; + status[4..0] := reason; (* REASON *) + status[8] := retry; (* RTRY *) + status[9] := 1; (* ABRT *) + TMAbortEffect := status; (* fake effect *) + }; +} + (* CBNZ *) (* CBZ *) function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. @@ -517,16 +602,16 @@ function clause execute ( TestBitAndBranch(t,datasize,bit_pos,bit_val,offset) ) (* BL *) function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. option<(ast<'R,'D>)> effect {escape} decodeUnconditionalBranchImmediate ([op]:0b00101:(bit[26]) imm26) = { - (BranchType) _branch_type := if op == 1 then BranchType_CALL else BranchType_JMP; + (BranchType) branch_type := if op == 1 then BranchType_CALL else BranchType_JMP; (bit[64]) offset := SignExtend(imm26:0b00); - Some(BranchImmediate(_branch_type,offset)); + Some(BranchImmediate(branch_type,offset)); } -function clause execute (BranchImmediate(_branch_type,offset)) = { - if _branch_type == BranchType_CALL then wX(30) := rPC() + 4; +function clause execute (BranchImmediate(branch_type,offset)) = { + if branch_type == BranchType_CALL then wX(30) := rPC() + 4; - BranchTo(rPC() + offset, _branch_type); + BranchTo(rPC() + offset, branch_type); } @@ -540,24 +625,24 @@ scattered function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. (* RET *) function clause decodeUnconditionalBranchRegister (0b1101011:0b00:op:0b11111:0b000000:Rn:0b00000) = { (reg_index) n := UInt_reg(Rn); - (BranchType) _branch_type := 0; (* ARM: uninitialized *) + (BranchType) branch_type := 0; (* ARM: uninitialized *) switch op { - case 0b00 -> _branch_type := BranchType_JMP - case 0b01 -> _branch_type := BranchType_CALL - case 0b10 -> _branch_type := BranchType_RET + case 0b00 -> branch_type := BranchType_JMP + case 0b01 -> branch_type := BranchType_CALL + case 0b10 -> branch_type := BranchType_RET case _ -> UnallocatedEncoding() }; - Some(BranchRegister(n,_branch_type)); + Some(BranchRegister(n,branch_type)); } -function clause execute (BranchRegister(n,_branch_type)) = +function clause execute (BranchRegister(n,branch_type)) = { (bit[64]) target := rX(n); - if _branch_type == BranchType_CALL then wX(30) := rPC() + 4; - BranchTo(target, _branch_type); + if branch_type == BranchType_CALL then wX(30) := rPC() + 4; + BranchTo(target, branch_type); } (* ERET *) @@ -717,7 +802,7 @@ function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. Some(LoadStoreAcqExc(n,t,t2,s,acctype,excl,pair,memop,elsize,regsize,datasize)); } -function clause execute ( LoadStoreAcqExc(n,t,t2,s,acctype,excl,pair,memop,elsize,regsize,datasize) ) = { +function clause execute ( LoadStoreAcqExc(n,t,t2,s,acctype,excl,pair,memop,elsize,regsize,([:'D:]) datasize) ) = { (bit[64]) address := 0; (* ARM: uninitialized *) (bit['D]) data := 0; (* ARM: uninitialized *) (*constant*) (uinteger) dbytes := datasize quot 8; @@ -760,6 +845,19 @@ function clause execute ( LoadStoreAcqExc(n,t,t2,s,acctype,excl,pair,memop,elsiz }; }; + (* this is a hack to allow the result of store-exclusive to be observed + before anything else *) + (bit) status := 0; + if memop == MemOp_STORE & excl then { + (*(bit)*) status := if speculate_exclusive_success() then 0 else 1; + wX(s) := (bit[32]) (ZeroExtend([status])); + + (* should be: + if status == 1 then return (); + *) + }; + if status == 1 then () else { + if n == 31 then { CheckSPAlignment(); address := rSP(); @@ -781,7 +879,7 @@ function clause execute ( LoadStoreAcqExc(n,t,t2,s,acctype,excl,pair,memop,elsiz (bit['R]) el2 := rX(t2); (* ARM: bit[datasize / 2] see lemma in the decoding *) data := if BigEndian() then el1:el2 else el2:el1; } else - data := rX(t); + (bit['D]) data := rX(t); if excl then { (* store {release} exclusive register|pair (atomic) *) @@ -798,7 +896,9 @@ function clause execute ( LoadStoreAcqExc(n,t,t2,s,acctype,excl,pair,memop,elsiz wMem_exclusive(empty_write_buffer, address, dbytes, acctype, data) ); }; + (* ARM: the following code was moved up, see note there wX(s) := (bit[32]) (ZeroExtend([status])); + *) } else { (* store release register (atomic) *) flush_write_buffer( @@ -860,6 +960,7 @@ function clause execute ( LoadStoreAcqExc(n,t,t2,s,acctype,excl,pair,memop,elsiz }; } }; + }; } (* LDNP *) @@ -885,7 +986,7 @@ function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. Some(LoadStorePairNonTemp(wback,postindex,n,t,t2,acctype,memop,scale,datasize,offset)); } -function clause execute ( LoadStorePairNonTemp(wback,postindex,n,t,t2,acctype,memop,scale,datasize,offset) ) = { +function clause execute ( LoadStorePairNonTemp(wback,postindex,n,t,t2,acctype,memop,scale,([:'D:]) datasize,offset) ) = { (bit[64]) address := 0; (* ARM: uninitialized *) (bit['D]) data1 := 0; (* ARM: uninitialized *) (bit['D]) data2 := 0; (* ARM: uninitialized *) @@ -930,11 +1031,11 @@ function clause execute ( LoadStorePairNonTemp(wback,postindex,n,t,t2,acctype,me switch memop { case MemOp_STORE -> { if rt_unknown & t == n then - date1 := (bit['D]) UNKNOWN + data1 := (bit['D]) UNKNOWN else data1 := rX(t); if rt_unknown & t2 == n then - date2 := (bit['D]) UNKNOWN + data2 := (bit['D]) UNKNOWN else data2 := rX(t2); @@ -951,7 +1052,7 @@ function clause execute ( LoadStorePairNonTemp(wback,postindex,n,t,t2,acctype,me data2 := read_data[((datasize * 2) - 1)..datasize]; if rt_unknown then { - date1 := (bit['D]) UNKNOWN; + data1 := (bit['D]) UNKNOWN; data2 := (bit['D]) UNKNOWN; }; wX(t) := data1; @@ -1028,7 +1129,7 @@ function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. sharedDecodeLoadImmediate(opc,size,Rn,Rt,wback,postindex,scale,offset,AccType_NORMAL,false); } -function clause execute ( LoadImmediate(n,t,acctype,memop,_signed,wback,postindex,offset,regsize,datasize) ) = { +function clause execute ( LoadImmediate(n,t,acctype,memop,_signed,wback,postindex,offset,regsize,([:'D:]) datasize) ) = { (bit[64]) address := 0; (* ARM: uninitialized *) (bit['D]) data := 0; (* ARM: uninitialized *) (boolean) wb_unknown := false; @@ -1191,7 +1292,7 @@ function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. sharedDecodeLoadRegister(Rn,Rt,Rm,opc,size,wback,postindex,scale,extend_type,shift); } -function clause execute ( LoadRegister(n,t,m,acctype,memop,_signed,wback,postindex,extend_type,shift,regsize,datasize) ) = { +function clause execute ( LoadRegister(n,t,m,acctype,memop,_signed,wback,postindex,extend_type,shift,regsize,([:'D:]) datasize) ) = { (bit[64]) offset := ExtendReg(m, extend_type, shift); (bit[64]) address := 0; (* ARM: uninitialized *) (bit['D]) data := 0; (* ARM: uninitialized *) @@ -1352,7 +1453,7 @@ function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. ([:'D:]) datasize := lsl(8, scale); (bit[64]) offset := LSL(SignExtend(imm7), scale); - Some(LoadStorePair(wback,postindex,n,t,t2,acctype,memop,_signed,scale,datasize,offset)); + Some(LoadStorePair(wback,postindex,n,t,t2,acctype,memop,_signed,datasize,offset)); } (* LDP signed offset *) @@ -1367,7 +1468,7 @@ function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. sharedDecodeLoadStorePair(L,opc,imm7,Rn,Rt,Rt2,wback,postindex); } -function clause execute ( LoadStorePair(wback,postindex,n,t,t2,acctype,memop,_signed,scale,datasize,offset) ) = { +function clause execute ( LoadStorePair(wback,postindex,n,t,t2,acctype,memop,_signed,([:'D:])datasize,offset) ) = { (bit[64]) address := 0; (* ARM: uninitialized *) (bit['D]) data1 := 0; (* ARM: uninitialized *) (bit['D]) data2 := 0; (* ARM: uninitialized *) @@ -1616,7 +1717,7 @@ function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. Some(ExtractRegister(d,n,m,datasize,lsb)); } -function clause execute ( ExtractRegister(d,n,m,datasize,lsb) ) = { +function clause execute ( ExtractRegister(d,n,m,([:'R:]) datasize,lsb) ) = { (bit['R]) result := 0; (* ARM: uninitialized *) (bit['R]) operand1 := rX(n); (bit['R]) operand2 := rX(m); @@ -1650,7 +1751,7 @@ function forall Nat 'R, 'R IN {32,64}, Nat 'D, 'D IN {8,16,32,64}. Some(LogicalImmediate(d,n,datasize,setflags,op,imm)); }} -function clause execute (LogicalImmediate(d,n,datasize,setflags,op,imm)) = { +function clause execute (LogicalImmediate(d,n,([:'R:]) datasize,setflags,op,imm)) = { (bit['R]) result := 0; (* ARM: uninitialized *) (bit['R]) operand1 := rX(n); (bit['R]) operand2 := imm; diff --git a/arm/armV8_A64_lib.sail b/arm/armV8_A64_lib.sail index 5a1b6ec3..2aa31d4f 100644 --- a/arm/armV8_A64_lib.sail +++ b/arm/armV8_A64_lib.sail @@ -730,6 +730,8 @@ function bit[64] System_Get((uinteger) op0, (uinteger) op1, (uinteger) crn, (uin switch (op0,op1,crn,crm,op2) { case (3,3,4,2,0) -> ZeroExtend(NZCV) case (3,3,4,2,1) -> ZeroExtend(DAIF) + case (3, 3, 13, 0, 2) -> TPIDR_EL0 + (* TODO FIXME: higher EL TPIDRs *) (* case (3,0,1,0,1) -> ZeroExtend(ACTLR_EL1) *) } @@ -741,6 +743,8 @@ function unit effect {wreg} System_Put((uinteger) op0, (uinteger) op1, (uinteger switch (op0,op1,crn,crm,op2) { case (3,3,4,2,0) -> NZCV := _val[31..0] case (3,3,4,2,1) -> DAIF := _val[31..0] + case (3, 3, 13, 0, 2) -> TPIDR_EL0 := _val[63..0] + (* TODO FIXME: higher EL TPIDRs *) (* case (3,0,1,0,1) -> ACTLR_EL1 := _val[31..0] *) } @@ -756,7 +760,19 @@ function unit AArch64_ExceptionReturn((bit[64]) new_pc, (bit[32]) spsr) = (** ENUMERATE:aarch64/instrs/countop/CountOp *) (** FUNCTION:ExtendType DecodeRegExtend(bits(3) op) *) -function ExtendType DecodeRegExtend ((bit[3]) op) = ([|8|]) op +function ExtendType DecodeRegExtend ((bit[3]) op) = +{ + switch op { + case 0b000 -> ExtendType_UXTB + case 0b001 -> ExtendType_UXTH + case 0b010 -> ExtendType_UXTW + case 0b011 -> ExtendType_UXTX + case 0b100 -> ExtendType_SXTB + case 0b101 -> ExtendType_SXTH + case 0b110 -> ExtendType_SXTW + case 0b111 -> ExtendType_SXTX + } +} (** FUNCTION:aarch64/instrs/extendreg/ExtendReg *) diff --git a/arm/armV8_A64_sys_regs.sail b/arm/armV8_A64_sys_regs.sail index 50c150c6..95b5c710 100644 --- a/arm/armV8_A64_sys_regs.sail +++ b/arm/armV8_A64_sys_regs.sail @@ -35,162 +35,6 @@ (*************************************************************************) (* General system control registers *) -register (bit[32]) ACTLR_EL1 (* Auxiliary Control Register (EL1) *) (* UNUSED *) -register (bit[32]) ACTLR_EL2 (* Auxiliary Control Register (EL2) *) (* UNUSED *) -register (bit[32]) ACTLR_EL3 (* Auxiliary Control Register (EL3) *) (* UNUSED *) -register (bit[32]) AFSR0_EL1 (* Auxiliary Fault Status Register 0 (EL1) *) (* UNUSED *) -register (bit[32]) AFSR0_EL2 (* Auxiliary Fault Status Register 0 (EL2) *) (* UNUSED *) -register (bit[32]) AFSR0_EL3 (* Auxiliary Fault Status Register 0 (EL3) *) (* UNUSED *) -register (bit[32]) AFSR1_EL1 (* Auxiliary Fault Status Register 1 (EL1) *) (* UNUSED *) -register (bit[32]) AFSR1_EL2 (* Auxiliary Fault Status Register 1 (EL2) *) (* UNUSED *) -register (bit[32]) AFSR1_EL3 (* Auxiliary Fault Status Register 1 (EL3) *) (* UNUSED *) -register (bit[32]) AIDR_EL1 (* Auxiliary ID Register *) (* UNUSED *) -register (bit[64]) AMAIR_EL1 (* Auxiliary Memory Attribute Indirection Register (EL1) *) (* UNUSED *) -register (bit[64]) AMAIR_EL2 (* Auxiliary Memory Attribute Indirection Register (EL2) *) (* UNUSED *) -register (bit[64]) AMAIR_EL3 (* Auxiliary Memory Attribute Indirection Register (EL3) *) (* UNUSED *) - -typedef CCSIDR_type = register bits [31:0] -{ - 31 : WT; - 30 : WB; - 29 : RA; - 28 : WA; - 27..13 : NumSets; - 12..3 : Associativity; - 2..0 : LineSize; -} -register (CCSIDR_type) CCSIDR_EL1 (* Current Cache Size ID Register *) (* UNUSED *) - -typedef CLIDR_type = register bits [63:0] -{ - (*63..33 : RES0*) - 32..30 : ICB; - 29..27 : LoUU; - 26..24 : LoC; - 23..21 : LoUIS; - 20..18 : Ctype7; - 17..15 : Ctype6; - 14..12 : Ctype5; - 11..9 : Ctype4; - 8..6 : Ctype3; - 5..3 : Ctype2; - 2..0 : Ctype1; -} -register (CLIDR_type) CLIDR_EL1 (* Cache Level ID Register *) (* UNUSED *) - -typedef CONTEXTIDR_type = register bits [31:0] { 31..0 : PROCID } -register (CONTEXTIDR_type) CONTEXTIDR_EL1 (* Context ID Register *) (* UNUSED *) - -typedef CPACR_type = register bits [31:0] -{ - (*31..29 : RES0;*) - 28 : TTA; - (*27..22 : RES0;*) - 21..20 : FPEN; - (*19..0 : RES0;*) -} -register (CPACR_type) CPACR_EL1 (* Architectural Feature Access Control Register *) (* UNUSED *) - -typedef CPTR_type = register bits [31:0] -{ - (* in EL3 all the RES are RES0 *) - 31 : TCPAC; - (*30..21 : RES0;*) - 20 : TTA; - (*19..14 : RES0;*) - (*13..12 : RES1;*) - (*11 : RES0;*) - 10 : TFP; - (*9..0 : RES1;*) -} -register (CPTR_type) CPTR_EL2 (* Architectural Feature Trap Register (EL2) *) (* UNUSED *) -register (CPTR_type) CPTR_EL3 (* Architectural Feature Trap Register (EL3) *) (* UNUSED *) - -typedef CSSELR_type = register bits [31:0] -{ - (*31..4 : RES0;*) - 3..1 : Level; - 0 : InD; -} -register (CSSELR_type) CSSELR_EL1 (* Cache Size Selection Register *) (* UNUSED *) - -typedef CTR_type = register bits [31:0] -{ - (*31 : RES1;*) - (*30..28 : RES0;*) - 27..24 : CWG; - 23..20 : ERG; - 19..16 : DminLine; - 15..14 : L1Ip; - (*13..4 : RES0;*) - 3..0 : IminLine; -} -register (CTR_type) CTR_EL0 (* Cache Type Register *) (* UNUSED *) - -typedef DACR32_type = register bits [31:0] -{ - 31..30 : D15; - 29..28 : D14; - 27..26 : D13; - 25..24 : D12; - 23..22 : D11; - 21..20 : D10; - 29..18 : D9; - 17..16 : D8; - 15..14 : D7; - 13..12 : D6; - 11..10 : D5; - 9..8 : D4; - 7..6 : D3; - 5..4 : D2; - 3..2 : D1; - 1..0 : D0; -} -register (DACR32_type) DACR32_EL2 (* Domain Access Control Register *) (* UNUSED *) - -typedef DCZID_type = register bits [31:0] -{ - (*31..5 : RES0;*) - 4 : DZP; - 3..0 : BS; -} -register (DCZID_type) DCZID_EL0 (* Data Cache Zero ID register *) (* UNUSED *) - -typedef ESR_type = register bits [31:0] -{ - 31..26 : EC; - 25 : IL; - 24..0 : ISS; -} -register (ESR_type) ESR_EL1 (* Exception Syndrome Register (EL1) *) (* UNUSED *) -register (ESR_type) ESR_EL2 (* Exception Syndrome Register (EL2) *) (* UNUSED *) -register (ESR_type) ESR_EL3 (* Exception Syndrome Register (EL3) *) (* UNUSED *) - -register (bit[64]) FAR_EL1 (* Fault Address Register (EL1) *) (* UNUSED *) -register (bit[64]) FAR_EL2 (* Fault Address Register (EL2) *) (* UNUSED *) -register (bit[64]) FAR_EL3 (* Fault Address Register (EL3) *) (* UNUSED *) - -typedef FPEXC32_type = register bits [31:0] -{ - 31 : EX; - 30 : EN; - 29 : DEX; - 28 : FP2V; - 27 : VV; - 26 : TFV; - (*25..21 : RES0;*) - (*20..11 : IMPLEMENTATION DEFINED*) - 10..8 : VECITR; - 7 : IDF; - (*6..5 : IMPLEMENTATION DEFINED*) - 4 : IXF; - 3 : UFF; - 2 : OFF; - 1 : DZF; - 0 : IOF; -} -register (FPEXC32_type) FPEXC32_EL2 (* Floating-point Exception Control register *) (* UNUSED *) -register (bit[32]) HACR_EL2 (* Hypervisor Auxiliary Control Register *) (* UNUSED *) typedef HCR_type = register bits [63:0] { @@ -231,35 +75,6 @@ typedef HCR_type = register bits [63:0] } register (HCR_type) HCR_EL2 (* Hypervisor Configuration Register *) -typedef HPFAR_type = register bits [63:0] -{ - (*63..40 : RES0;*) - 39..4 : FIPA; (* bits [47:12] of FIPA *) - (*3..0 : RES0;*) -} -register (HPFAR_type) HPFAR_EL2 (* Hypervisor IPA Fault Address Register *) (* UNUSED *) - -typedef HSTR_type = register bits [31:0] -{ - (*31..16 : RES0;*) - 15 : T15; - 14 : T14; - 13 : T13; - 12 : T12; - 11 : T11; - 10 : T10; - 9 : T9; - 8 : T8; - 7 : T7; - 6 : T6; - 5 : T5; - 4 : T4; - 3 : T3; - 2 : T2; - 1 : T1; - 0 : T0; -} -register (HSTR_type) HSTR_EL2 (* Hypervisor System Trap Register *) (* UNUSED *) typedef ID_AA64MMFR0_type = register bits [63:0] { @@ -402,6 +217,11 @@ typedef TCR_type = register bits [31:0] register (TCR_type) TCR_EL2 (* Translation Control Register (EL2) *) register (TCR_type) TCR_EL3 (* Translation Control Register (EL3) *) +register (bit[64]) TPIDR_EL0 (* EL0 Read/Write Software Thread ID Register *) +register (bit[64]) TPIDR_EL1 (* EL1 Read/Write Software Thread ID Register *) +register (bit[64]) TPIDR_EL2 (* EL2 Read/Write Software Thread ID Register *) +register (bit[64]) TPIDR_EL3 (* EL3 Read/Write Software Thread ID Register *) + (*************************************************************************) (* Debug registers *) @@ -458,9 +278,17 @@ typedef EDSCR_type = register bits [31:0] } register (EDSCR_type) EDSCR (* External Debug Status and Control Register *) +(* transactional memory, from the pre-alpha document *) +typedef TXIDR_EL0_type = register bits [63:0] +{ + (*63..8 : RES0;*) + 7..0 : DEPTH; +} +register (TXIDR_EL0_type) TXIDR_EL0 (* Transaction ID Register *) + + function unit effect pure AArch64_ResetControlRegisters((boolean) cold_reset) = { () } - diff --git a/arm/armV8_common_lib.sail b/arm/armV8_common_lib.sail index 3bae8070..9bea1cd1 100644 --- a/arm/armV8_common_lib.sail +++ b/arm/armV8_common_lib.sail @@ -513,8 +513,8 @@ val extern unit -> unit effect {barr} DataMemoryBarrier_All function unit effect {barr} DataMemoryBarrier((MBReqDomain) domain, (MBReqTypes) types) = { - if domain != MBReqDomain_FullSystem then - not_implemented("DataMemoryBarrier: not MBReqDomain_FullSystem"); + if domain != MBReqDomain_FullSystem & domain != MBReqDomain_InnerShareable then + not_implemented("DataMemoryBarrier: not MBReqDomain_FullSystem or _InnerShareable"); switch types { case MBReqTypes_Reads -> DataMemoryBarrier_Reads() @@ -725,10 +725,10 @@ function bool effect {wmv} flush_write_buffer_exclusive((write_buffer_type) writ (** FUNCTION:BranchTo(bits(N) target, BranchType branch_type) *) -function forall Nat 'N, 'N IN {32,64}. unit effect {rreg,wreg} BranchTo((bit['N]) target, (BranchType) _branch_type) = { +function forall Nat 'N, 'N IN {32,64}. unit effect {rreg,wreg} BranchTo((bit['N]) target, (BranchType) branch_type) = { (bit['N]) target' := target; (* Sail does not let you change parameter vector *) - Hint_Branch(_branch_type); + Hint_Branch(branch_type); if length(target) == 32 then { assert( UsingAArch32(), None ); _PC := ZeroExtend(target); @@ -831,7 +831,7 @@ function boolean effect {rreg} ConditionHolds((bit[4]) _cond) = case 0b111 -> result := true (* AL *) }; - (* Condition flag valuesin the set '111x' indicate always true *) + (* Condition flag values in the set '111x' indicate always true *) (* Otherwise, invert condition if necessary. *) if _cond[0] == 1 & _cond != 0b1111 then result := ~(result); diff --git a/arm/armV8_extras.lem b/arm/armV8_extras.lem new file mode 100644 index 00000000..9a187ecb --- /dev/null +++ b/arm/armV8_extras.lem @@ -0,0 +1,77 @@ +open import Pervasives +open import Interp_ast +open import Interp_interface +open import Sail_impl_base +open import Interp_inter_imp +import Set_extra + +let memory_parameter_transformer mode v = + match v with + | Interp_ast.V_tuple [location;length] -> + let (v,loc_regs) = extern_with_track mode extern_vector_value location in + + match length with + | Interp_ast.V_lit (L_aux (L_num len) _) -> + (v,(natFromInteger len),loc_regs) + + | Interp_ast.V_track (Interp_ast.V_lit (L_aux (L_num len) _)) size_regs -> + match loc_regs with + | Nothing -> (v,(natFromInteger len),Just (List.map (fun r -> extern_reg r Nothing) (Set_extra.toList size_regs))) + | Just loc_regs -> (v,(natFromInteger len),Just (loc_regs++(List.map (fun r -> extern_reg r Nothing) (Set_extra.toList size_regs)))) + end + + | _ -> Assert_extra.failwith "expected 'V_lit (L_aux (L_num _) _)' or 'V_track (V_lit (L_aux (L_num len) _)) _'" + end + | _ -> Assert_extra.failwith "expected 'V_tuple [_;_]'" + end + +let aArch64_read_memory_functions : memory_reads = + [ ("rMem_NORMAL", (MR Read_plain memory_parameter_transformer)); + ("rMem_STREAM", (MR Read_stream memory_parameter_transformer)); + ("rMem_ORDERED", (MR Read_acquire memory_parameter_transformer)); + ("rMem_ATOMIC", (MR Read_exclusive memory_parameter_transformer)); + ("rMem_ATOMIC_ORDERED", (MR Read_exclusive_acquire memory_parameter_transformer)); + ] + +let aArch64_memory_writes : memory_writes = [] + (* [ ("wMem_NORMAL", (MW Write_plain memory_parameter_transformer Nothing)); + ("wMem_ORDERED", (MW Write_release memory_parameter_transformer Nothing)); + ("wMem_ATOMIC", (MW Write_exclusive memory_parameter_transformer Nothing)); + ("wMem_ATOMIC_ORDERED", (MW Write_exclusive_release memory_parameter_transformer Nothing)); + ] *) + +let aArch64_memory_eas : memory_write_eas = + [ ("wMem_Addr_NORMAL", (MEA Write_plain memory_parameter_transformer)); + ("wMem_Addr_ORDERED", (MEA Write_release memory_parameter_transformer)); + ("wMem_Addr_ATOMIC", (MEA Write_exclusive memory_parameter_transformer)); + ("wMem_Addr_ATOMIC_ORDERED", (MEA Write_exclusive_release memory_parameter_transformer)); + ] + +let aArch64_memory_vals : memory_write_vals = + [ ("wMem_Val_NORMAL", (MV (fun mode v -> Nothing) Nothing)); + ("wMem_Val_ATOMIC", (MV (fun mode v -> Nothing) + (Just + (fun (IState interp context) b -> + (*ppcmem2 provides true for success and false for failure; but the status for ARM is reversed*) + let bit = Interp_ast.V_lit (L_aux (if b then L_zero else L_one) Interp_ast.Unknown)in + (IState (Interp.add_answer_to_stack interp bit) context))))); + ] + +let aArch64_excl_res : excl_res = + let f = fun (IState interp context) b -> + let bool_res = Interp_ast.V_lit (L_aux (if b then L_one else L_zero) Interp_ast.Unknown) in + IState (Interp.add_answer_to_stack interp bool_res) context + in + Just ("speculate_exclusive_success", (ER (Just f))) + +let aArch64_barrier_functions = + [ ("DataMemoryBarrier_Reads", Barrier_DMB_LD); + ("DataMemoryBarrier_Writes", Barrier_DMB_ST); + ("DataMemoryBarrier_All", Barrier_DMB); + ("DataSynchronizationBarrier_Reads", Barrier_DSB_LD); + ("DataSynchronizationBarrier_Writes", Barrier_DSB_ST); + ("DataSynchronizationBarrier_All", Barrier_DSB); + ("InstructionSynchronizationBarrier", Barrier_ISB); + + ("TMCommitEffect", Barrier_TM_COMMIT); + ] diff --git a/arm/armV8_extras_embed.lem b/arm/armV8_extras_embed.lem new file mode 100644 index 00000000..86570fc4 --- /dev/null +++ b/arm/armV8_extras_embed.lem @@ -0,0 +1,59 @@ +open import Pervasives +open import Sail_impl_base +open import Sail_values +open import Prompt + +val rMem_NORMAL : (vector bitU * integer) -> M (vector bitU) +val rMem_STREAM : (vector bitU * integer) -> M (vector bitU) +val rMem_ORDERED : (vector bitU * integer) -> M (vector bitU) +val rMem_ATOMICL : (vector bitU * integer) -> M (vector bitU) +val rMem_ATOMIC_ORDERED : (vector bitU * integer) -> M (vector bitU) + +let rMem_NORMAL (addr,size) = read_mem false Read_plain addr size +let rMem_STREAM (addr,size) = read_mem false Read_stream addr size +let rMem_ORDERED (addr,size) = read_mem false Read_acquire addr size +let rMem_ATOMIC (addr,size) = read_mem false Read_exclusive addr size +let rMem_ATOMIC_ORDERED (addr,size) = read_mem false Read_exclusive_acquire addr size + +val wMem_Addr_NORMAL : (vector bitU * integer) -> M unit +val wMem_Addr_ORDERED : (vector bitU * integer) -> M unit +val wMem_Addr_ATOMIC : (vector bitU * integer) -> M unit +val wMem_Addr_ATOMIC_ORDERED : (vector bitU * integer) -> M unit + +let wMem_Addr_NORMAL (addr,size) = write_mem_ea Write_plain addr size +let wMem_Addr_ORDERED (addr,size) = write_mem_ea Write_release addr size +let wMem_Addr_ATOMIC (addr,size) = write_mem_ea Write_exclusive addr size +let wMem_Addr_ATOMIC_ORDERED (addr,size) = write_mem_ea Write_exclusive_release addr size + + +val wMem_Val_NORMAL : (integer * vector bitU) -> M unit +val wMem_Val_ATOMIC : (integer * vector bitU) -> M bitU + +let wMem_Val_NORMAL (_,v) = write_mem_val v >>= fun _ -> return () +(* in ARM the status returned is inversed *) +let wMem_Val_ATOMIC (_,v) = write_mem_val v >>= fun b -> return (if b then B0 else B1) + +let speculate_exclusive_success () = excl_result () >>= fun b -> return (if b then B1 else B0) + +val DataMemoryBarrier_Reads : unit -> M unit +val DataMemoryBarrier_Writes : unit -> M unit +val DataMemoryBarrier_All : unit -> M unit +val DataSynchronizationBarrier_Reads : unit -> M unit +val DataSynchronizationBarrier_Writes : unit -> M unit +val DataSynchronizationBarrier_All : unit -> M unit +val InstructionSynchronizationBarrier : unit -> M unit + +let DataMemoryBarrier_Reads () = barrier Barrier_DMB_LD +let DataMemoryBarrier_Writes () = barrier Barrier_DMB_ST +let DataMemoryBarrier_All () = barrier Barrier_DMB +let DataSynchronizationBarrier_Reads () = barrier Barrier_DSB_LD +let DataSynchronizationBarrier_Writes () = barrier Barrier_DSB_ST +let DataSynchronizationBarrier_All () = barrier Barrier_DSB +let InstructionSynchronizationBarrier () = barrier Barrier_ISB + +val TMCommitEffect : unit -> M unit +let TMCommitEffect () = barrier Barrier_TM_COMMIT + +let duplicate_bits (Vector bits start direction,len) = + let bits' = repeat bits len in + Vector bits' start direction diff --git a/arm/armV8_extras_embed_sequential.lem b/arm/armV8_extras_embed_sequential.lem new file mode 100644 index 00000000..d2bb8330 --- /dev/null +++ b/arm/armV8_extras_embed_sequential.lem @@ -0,0 +1,59 @@ +open import Pervasives +open import Sail_impl_base +open import Sail_values +open import State + +val rMem_NORMAL : (vector bitU * integer) -> M (vector bitU) +val rMem_STREAM : (vector bitU * integer) -> M (vector bitU) +val rMem_ORDERED : (vector bitU * integer) -> M (vector bitU) +val rMem_ATOMICL : (vector bitU * integer) -> M (vector bitU) +val rMem_ATOMIC_ORDERED : (vector bitU * integer) -> M (vector bitU) + +let rMem_NORMAL (addr,size) = read_mem false Read_plain addr size +let rMem_STREAM (addr,size) = read_mem false Read_stream addr size +let rMem_ORDERED (addr,size) = read_mem false Read_acquire addr size +let rMem_ATOMIC (addr,size) = read_mem false Read_exclusive addr size +let rMem_ATOMIC_ORDERED (addr,size) = read_mem false Read_exclusive_acquire addr size + +val wMem_Addr_NORMAL : (vector bitU * integer) -> M unit +val wMem_Addr_ORDERED : (vector bitU * integer) -> M unit +val wMem_Addr_ATOMIC : (vector bitU * integer) -> M unit +val wMem_Addr_ATOMIC_ORDERED : (vector bitU * integer) -> M unit + +let wMem_Addr_NORMAL (addr,size) = write_mem_ea Write_plain addr size +let wMem_Addr_ORDERED (addr,size) = write_mem_ea Write_release addr size +let wMem_Addr_ATOMIC (addr,size) = write_mem_ea Write_exclusive addr size +let wMem_Addr_ATOMIC_ORDERED (addr,size) = write_mem_ea Write_exclusive_release addr size + + +val wMem_Val_NORMAL : (integer * vector bitU) -> M unit +val wMem_Val_ATOMIC : (integer * vector bitU) -> M bitU + +let wMem_Val_NORMAL (_,v) = write_mem_val v >>= fun _ -> return () +(* in ARM the status returned is inversed *) +let wMem_Val_ATOMIC (_,v) = write_mem_val v >>= fun b -> return (if b then B0 else B1) + +let speculate_exclusive_success () = excl_result () >>= fun b -> return (if b then B1 else B0) + +val DataMemoryBarrier_Reads : unit -> M unit +val DataMemoryBarrier_Writes : unit -> M unit +val DataMemoryBarrier_All : unit -> M unit +val DataSynchronizationBarrier_Reads : unit -> M unit +val DataSynchronizationBarrier_Writes : unit -> M unit +val DataSynchronizationBarrier_All : unit -> M unit +val InstructionSynchronizationBarrier : unit -> M unit + +let DataMemoryBarrier_Reads () = barrier Barrier_DMB_LD +let DataMemoryBarrier_Writes () = barrier Barrier_DMB_ST +let DataMemoryBarrier_All () = barrier Barrier_DMB +let DataSynchronizationBarrier_Reads () = barrier Barrier_DSB_LD +let DataSynchronizationBarrier_Writes () = barrier Barrier_DSB_ST +let DataSynchronizationBarrier_All () = barrier Barrier_DSB +let InstructionSynchronizationBarrier () = barrier Barrier_ISB + +val TMCommitEffect : unit -> M unit +let TMCommitEffect () = barrier Barrier_TM_COMMIT + +let duplicate_bits (Vector bits start direction,len) = + let bits' = repeat bits len in + Vector bits' start direction diff --git a/arm/armV8_lib.h.sail b/arm/armV8_lib.h.sail index 849472e1..d52cc5d5 100644 --- a/arm/armV8_lib.h.sail +++ b/arm/armV8_lib.h.sail @@ -187,9 +187,8 @@ typedef CountOp = enumerate {CountOp_CLZ; CountOp_CLS; CountOp_CNT} typedef ExtendType = - (* the oreder is important for decoding *) - enumerate { ExtendType_UXTB; ExtendType_UXTH; ExtendType_UXTW; ExtendType_UXTX; - ExtendType_SXTB; ExtendType_SXTH; ExtendType_SXTW; ExtendType_SXTX } + enumerate { ExtendType_SXTB; ExtendType_SXTH; ExtendType_SXTW; ExtendType_SXTX; + ExtendType_UXTB; ExtendType_UXTH; ExtendType_UXTW; ExtendType_UXTX } typedef RevOp = enumerate {RevOp_RBIT; RevOp_REV16; RevOp_REV32; RevOp_REV64} diff --git a/arm/gen/ast.hgen b/arm/gen/ast.hgen new file mode 100644 index 00000000..60f130d7 --- /dev/null +++ b/arm/gen/ast.hgen @@ -0,0 +1,44 @@ + | `AArch64TMStart of inst_reg (* t *) + | `AArch64TMCommit + | `AArch64TMAbort of boolean*bit5 (* retry,reason *) + | `AArch64TMTest + + | `AArch64ImplementationDefinedTestBeginEnd of boolean (* isEnd *) + | `AArch64ImplementationDefinedStopFetching + | `AArch64ImplementationDefinedThreadStart + | `AArch64AddSubCarry of inst_reg*inst_reg*inst_reg*reg_size*boolean*boolean (* d,n,m,datasize,sub_op,setflags *) + | `AArch64AddSubExtendRegister of inst_reg*inst_reg*inst_reg*reg_size*boolean*boolean*extendType*range0_7 (* d,n,m,datasize,sub_op,setflags,extend_type,shift *) + | `AArch64AddSubShiftedRegister of inst_reg*inst_reg*inst_reg*reg_size*boolean*boolean*shiftType*range0_63 (* d,n,m,datasize,sub_op,setflags,shift_type,shift_amount *) + | `AArch64AddSubImmediate of inst_reg*inst_reg*reg_size*boolean*boolean*reg_size_bits (* d,n,datasize,sub_op,setflags,imm *) + | `AArch64Address of inst_reg*boolean*bit64 (* d,page,imm *) + | `AArch64LogicalImmediate of inst_reg*inst_reg*reg_size*boolean*logicalOp*reg_size_bits (* d,n,datasize,setflags,op,imm *) + | `AArch64LogicalShiftedRegister of inst_reg*inst_reg*inst_reg*reg_size*boolean*logicalOp*shiftType*range0_63*boolean (* d,n,m,datasize,setflags,op,shift_type,shift_amount,invert *) + | `AArch64Shift of inst_reg*inst_reg*inst_reg*reg_size*shiftType (* d,n,m,datasize,shift_type *) + | `AArch64BranchConditional of bit64*bit4 (* offset,condition *) + | `AArch64BranchImmediate of branchType*bit64 (* branch_type,offset *) + | `AArch64BitfieldMove of inst_reg*inst_reg*reg_size*boolean*boolean*uinteger*uinteger*reg_size_bits*reg_size_bits (* d,n,datasize,inzero,extend,R,S,wmask,tmask *) + | `AArch64BranchRegister of inst_reg*branchType (* n,branch_type *) + | `AArch64CompareAndBranch of inst_reg*reg_size*boolean*bit64 (* t,datasize,iszero,offset *) + | `AArch64ConditionalCompareImmediate of inst_reg*reg_size*boolean*bit4*bit4*reg_size_bits (* n,datasize,sub_op,condition,flags,imm *) + | `AArch64ConditionalCompareRegister of inst_reg*inst_reg*reg_size*boolean*bit4*bit4 (* n,m,datasize,sub_op,condition,flags *) + | `AArch64ClearExclusiveMonitor of uinteger (* imm *) + | `AArch64CountLeading of inst_reg*inst_reg*reg_size*countOp (* d,n,datasize,opcode *) + | `AArch64CRC of inst_reg*inst_reg*inst_reg*data_size*boolean (* d,n,m,size,crc32c *) + | `AArch64ConditionalSelect of inst_reg*inst_reg*inst_reg*reg_size*bit4*boolean*boolean (* d,n,m,datasize,condition,else_inv,else_inc *) + | `AArch64Barrier of memBarrierOp*mBReqDomain*mBReqTypes (* op,domain,types *) + | `AArch64ExtractRegister of inst_reg*inst_reg*inst_reg*reg_size*uinteger (* d,n,m,datasize,lsb *) + | `AArch64Hint of systemHintOp (* op *) + | `AArch64LoadStoreAcqExc of inst_reg*inst_reg*inst_reg*inst_reg*accType*boolean*boolean*memOp*uinteger*reg_size*data_size (* n,t,t2,s,acctype,excl,pair,memop,elsize,regsize,datasize *) + | `AArch64LoadStorePair of boolean*boolean*inst_reg*inst_reg*inst_reg*accType*memOp*boolean*data_size*bit64 (* wback,postindex,n,t,t2,acctype,memop,signed,datasize,offset *) + | `AArch64LoadImmediate of inst_reg*inst_reg*accType*memOp*boolean*boolean*boolean*bit64*reg_size*data_size (* n,t,acctype,memop,signed,wback,postindex,offset,regsize,datasize *) + | `AArch64LoadLiteral of inst_reg*memOp*boolean*uinteger*bit64*data_size (* t,memop,signed,size,offset,datasize *) + | `AArch64LoadRegister of inst_reg*inst_reg*inst_reg*accType*memOp*boolean*boolean*boolean*extendType*uinteger*reg_size*data_size (* n,t,m,acctype,memop,signed,wback,postindex,extend_type,shift,regsize,datasize *) + | `AArch64MultiplyAddSub of inst_reg*inst_reg*inst_reg*inst_reg*reg_size*data_size*boolean (* d,n,m,a,destsize,datasize,sub_op *) + | `AArch64MoveWide of inst_reg*reg_size*bit16*uinteger*moveWideOp (* d,datasize,imm,pos,opcode *) + | `AArch64Reverse of inst_reg*inst_reg*reg_size*revOp (* d,n,datasize,op *) + | `AArch64Division of inst_reg*inst_reg*inst_reg*reg_size*boolean (* d,n,m,datasize,unsigned *) + | `AArch64MultiplyAddSubLong of inst_reg*inst_reg*inst_reg*inst_reg*reg_size*data_size*boolean*boolean (* d,n,m,a,destsize,datasize,sub_op,unsigned *) + | `AArch64MultiplyHigh of inst_reg*inst_reg*inst_reg*inst_reg*reg_size*data_size*boolean (* d,n,m,a,destsize,datasize,unsigned *) + | `AArch64TestBitAndBranch of inst_reg*reg_size*uinteger*bit*bit64 (* t,datasize,bit_pos,bit_val,offset *) + | `AArch64MoveSystemRegister of inst_reg*uinteger*uinteger*uinteger*uinteger*uinteger*boolean (* t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,read *) + | `AArch64MoveSystemImmediate of bit4*pSTATEField (* operand,field *) diff --git a/arm/gen/fold.hgen b/arm/gen/fold.hgen new file mode 100644 index 00000000..4062d8e6 --- /dev/null +++ b/arm/gen/fold.hgen @@ -0,0 +1,44 @@ +| `AArch64TMStart t -> fold_reg t (y_reg, y_sreg) +| `AArch64TMCommit -> (y_reg, y_sreg) +| `AArch64TMAbort (retry,reason) -> (y_reg, y_sreg) +| `AArch64TMTest -> (y_reg, y_sreg) + +| `AArch64ImplementationDefinedStopFetching -> (y_reg, y_sreg) +| `AArch64ImplementationDefinedThreadStart -> (y_reg, y_sreg) +| `AArch64ImplementationDefinedTestBeginEnd (isEnd) -> (y_reg, y_sreg) +| `AArch64AddSubCarry (d,n,m,datasize,sub_op,setflags) -> fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg))) +| `AArch64AddSubExtendRegister (d,n,m,datasize,sub_op,setflags,extend_type,shift) -> fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg))) +| `AArch64AddSubShiftedRegister (d,n,m,datasize,sub_op,setflags,shift_type,shift_amount) -> fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg))) +| `AArch64AddSubImmediate (d,n,datasize,sub_op,setflags,imm) -> fold_reg n (fold_reg d (y_reg, y_sreg)) +| `AArch64Address (d,page,imm) -> fold_reg d (y_reg, y_sreg) +| `AArch64LogicalImmediate (d,n,datasize,setflags,op,imm) -> fold_reg n (fold_reg d (y_reg, y_sreg)) +| `AArch64LogicalShiftedRegister (d,n,m,datasize,setflags,op,shift_type,shift_amount,invert) -> fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg))) +| `AArch64Shift (d,n,m,datasize,shift_type) -> fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg))) +| `AArch64BranchConditional (offset,condition) -> (y_reg, y_sreg) +| `AArch64BranchImmediate (branch_type,offset) -> (y_reg, y_sreg) +| `AArch64BitfieldMove (d,n,datasize,inzero,extend,_R,_S,wmask,tmask) -> fold_reg n (fold_reg d (y_reg, y_sreg)) +| `AArch64BranchRegister (n,branch_type) -> fold_reg n (y_reg, y_sreg) +| `AArch64CompareAndBranch (t,datasize,iszero,offset) -> fold_reg t (y_reg, y_sreg) +| `AArch64ConditionalCompareImmediate (n,datasize,sub_op,condition,flags,imm) -> fold_reg n (y_reg, y_sreg) +| `AArch64ConditionalCompareRegister (n,m,datasize,sub_op,condition,flags) -> fold_reg m (fold_reg n (y_reg, y_sreg)) +| `AArch64ClearExclusiveMonitor (imm) -> (y_reg, y_sreg) +| `AArch64CountLeading (d,n,datasize,opcode) -> fold_reg n (fold_reg d (y_reg, y_sreg)) +| `AArch64CRC (d,n,m,size,crc32c) -> fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg))) +| `AArch64ConditionalSelect (d,n,m,datasize,condition,else_inv,else_inc) -> fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg))) +| `AArch64Barrier (op,domain,types) -> (y_reg, y_sreg) +| `AArch64ExtractRegister (d,n,m,datasize,lsb) -> fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg))) +| `AArch64Hint (op) -> (y_reg, y_sreg) +| `AArch64LoadStoreAcqExc (n,t,t2,s,acctype,excl,pair,memop,elsize,regsize,datasize) -> fold_reg s (fold_reg t2 (fold_reg t (fold_reg n (y_reg, y_sreg)))) +| `AArch64LoadStorePair (wback,postindex,n,t,t2,acctype,memop,signed,datasize,offset) -> fold_reg t2 (fold_reg t (fold_reg n (y_reg, y_sreg))) +| `AArch64LoadImmediate (n,t,acctype,memop,signed,wback,postindex,offset,regsize,datasize) -> fold_reg t (fold_reg n (y_reg, y_sreg)) +| `AArch64LoadLiteral (t,memop,signed,size,offset,datasize) -> fold_reg t (y_reg, y_sreg) +| `AArch64LoadRegister (n,t,m,acctype,memop,signed,wback,postindex,extend_type,shift,regsize,datasize) -> fold_reg m (fold_reg t (fold_reg n (y_reg, y_sreg))) +| `AArch64MultiplyAddSub (d,n,m,a,destsize,datasize,sub_op) -> fold_reg a (fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg)))) +| `AArch64MoveWide (d,datasize,imm,pos,opcode) -> fold_reg d (y_reg, y_sreg) +| `AArch64Reverse (d,n,datasize,op) -> fold_reg n (fold_reg d (y_reg, y_sreg)) +| `AArch64Division (d,n,m,datasize,unsigned) -> fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg))) +| `AArch64MultiplyAddSubLong (d,n,m,a,destsize,datasize,sub_op,unsigned) -> fold_reg a (fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg)))) +| `AArch64MultiplyHigh (d,n,m,a,destsize,datasize,unsigned) -> fold_reg a (fold_reg m (fold_reg n (fold_reg d (y_reg, y_sreg)))) +| `AArch64TestBitAndBranch (t,datasize,bit_pos,bit_val,offset) -> fold_reg t (y_reg, y_sreg) +| `AArch64MoveSystemRegister (t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,read) -> fold_reg t (y_reg, y_sreg) +| `AArch64MoveSystemImmediate (operand,field) -> (y_reg, y_sreg) diff --git a/arm/gen/herdtools_ast_to_shallow_ast.hgen b/arm/gen/herdtools_ast_to_shallow_ast.hgen new file mode 100644 index 00000000..5a19e483 --- /dev/null +++ b/arm/gen/herdtools_ast_to_shallow_ast.hgen @@ -0,0 +1,335 @@ +| `AArch64TMStart t -> TMStart (translate_reg "t" t) + +| `AArch64TMCommit -> TMCommit + +| `AArch64TMAbort (retry,reason) -> + TMAbort + (translate_boolean "retry" retry, + translate_bit5 "reason" reason) + +| `AArch64TMTest -> TMTest + +| `AArch64ImplementationDefinedStopFetching -> + ImplementationDefinedStopFetching + +| `AArch64ImplementationDefinedThreadStart -> + ImplementationDefinedThreadStart + +| `AArch64ImplementationDefinedTestBeginEnd(isEnd) -> + ImplementationDefinedTestBeginEnd + (translate_boolean "isEnd" isEnd) + +| `AArch64AddSubCarry(d,n,m,datasize,sub_op,setflags) -> + AddSubCarry + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg_size "datasize" datasize, + translate_boolean "sub_op" sub_op, + translate_boolean "setflags" setflags) + +| `AArch64AddSubExtendRegister (d,n,m,datasize,sub_op,setflags,extend_type,shift) -> + AddSubExtendRegister + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg_size "datasize" datasize, + translate_boolean "sub_op" sub_op, + translate_boolean "setflags" setflags, + translate_extendType "extend_type" extend_type, + translate_range0_7 "shift" shift) + +| `AArch64AddSubShiftedRegister (d,n,m,datasize,sub_op,setflags,shift_type,shift_amount) -> + AddSubShiftedRegister + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg_size "datasize" datasize, + translate_boolean "sub_op" sub_op, + translate_boolean "setflags" setflags, + translate_shiftType "shift_type" shift_type, + translate_range0_63 "shift_amount" shift_amount) + +| `AArch64AddSubImmediate (d,n,datasize,sub_op,setflags,imm) -> + AddSubImmediate + (translate_reg "d" d, + translate_reg "n" n, + translate_reg_size "datasize" datasize, + translate_boolean "sub_op" sub_op, + translate_boolean "setflags" setflags, + translate_reg_size_bits "imm" imm) + +| `AArch64Address (d,page,imm) -> + Address0 + (translate_reg "d" d, + translate_boolean "page" page, + translate_bit64 "imm" imm) + +| `AArch64LogicalImmediate (d,n,datasize,setflags,op,imm) -> + LogicalImmediate + (translate_reg "d" d, + translate_reg "n" n, + translate_reg_size "datasize" datasize, + translate_boolean "setflags" setflags, + translate_logicalOp "op" op, + translate_reg_size_bits "imm" imm) + +| `AArch64LogicalShiftedRegister (d,n,m,datasize,setflags,op,shift_type,shift_amount,invert) -> + LogicalShiftedRegister + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg_size "datasize" datasize, + translate_boolean "setflags" setflags, + translate_logicalOp "op" op, + translate_shiftType "shift_type" shift_type, + translate_range0_63 "shift_amount" shift_amount, + translate_boolean "invert" invert) + +| `AArch64Shift (d,n,m,datasize,shift_type) -> + Shift + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg_size "datasize" datasize, + translate_shiftType "shift_type" shift_type) + +| `AArch64BranchConditional (offset,condition) -> + BranchConditional + (translate_bit64 "offset" offset, + translate_bit4 "condition" condition) + +| `AArch64BranchImmediate (branch_type,offset) -> + BranchImmediate + (translate_branchType "branch_type" branch_type, + translate_bit64 "offset" offset) + +| `AArch64BitfieldMove (d,n,datasize,inzero,extend,_R,_S,wmask,tmask) -> + BitfieldMove + (translate_reg "d" d, + translate_reg "n" n, + translate_reg_size "datasize" datasize, + translate_boolean "inzero" inzero, + translate_boolean "extend" extend, + translate_uinteger "_R" _R, + translate_uinteger "_S" _S, + translate_reg_size_bits "wmask" wmask, + translate_reg_size_bits "tmask" tmask) + +| `AArch64BranchRegister (n,branch_type) -> + BranchRegister + (translate_reg "n" n, + translate_branchType "branch_type" branch_type) + +| `AArch64CompareAndBranch (t,datasize,iszero,offset) -> + CompareAndBranch + (translate_reg "t" t, + translate_reg_size "datasize" datasize, + translate_boolean "iszero" iszero, + translate_bit64 "offset" offset) + +| `AArch64ConditionalCompareImmediate (n,datasize,sub_op,condition,flags,imm) -> + ConditionalCompareImmediate + (translate_reg "n" n, + translate_reg_size "datasize" datasize, + translate_boolean "sub_op" sub_op, + translate_bit4 "condition" condition, + translate_bit4 "flags" flags, + translate_reg_size_bits "imm" imm) + +| `AArch64ConditionalCompareRegister (n,m,datasize,sub_op,condition,flags) -> + ConditionalCompareRegister + (translate_reg "n" n, + translate_reg "m" m, + translate_reg_size "datasize" datasize, + translate_boolean "sub_op" sub_op, + translate_bit4 "condition" condition, + translate_bit4 "flags" flags) + +| `AArch64ClearExclusiveMonitor (imm) -> + ClearExclusiveMonitor + (translate_uinteger "imm" imm) + +| `AArch64CountLeading (d,n,datasize,opcode) -> + CountLeading + (translate_reg "d" d, + translate_reg "n" n, + translate_reg_size "datasize" datasize, + translate_countOp "opcode" opcode) + +| `AArch64CRC (d,n,m,size,crc32c) -> + CRC + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_data_size "size" size, + translate_boolean "crc32c" crc32c) + +| `AArch64ConditionalSelect (d,n,m,datasize,condition,else_inv,else_inc) -> + ConditionalSelect + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg_size "datasize" datasize, + translate_bit4 "condition" condition, + translate_boolean "else_inv" else_inv, + translate_boolean "else_inc" else_inc) + +| `AArch64Barrier (op,domain,types) -> + Barrier2 + (translate_memBarrierOp "op" op, + translate_mBReqDomain "domain" domain, + translate_mBReqTypes "types" types) + +| `AArch64ExtractRegister (d,n,m,datasize,lsb) -> + ExtractRegister + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg_size "datasize" datasize, + translate_uinteger "lsb" lsb) + +| `AArch64Hint (op) -> + Hint + (translate_systemHintOp "op" op) + +| `AArch64LoadStoreAcqExc (n,t,t2,s,acctype,excl,pair,memop,elsize,regsize,datasize) -> + LoadStoreAcqExc + (translate_reg "n" n, + translate_reg "t" t, + translate_reg "t2" t2, + translate_reg "s" s, + translate_accType "acctype" acctype, + translate_boolean "excl" excl, + translate_boolean "pair" pair, + translate_memOp "memop" memop, + translate_uinteger "elsize" elsize, + translate_reg_size "regsize" regsize, + translate_data_size "datasize" datasize) + +| `AArch64LoadStorePair (wback,postindex,n,t,t2,acctype,memop,signed,datasize,offset) -> + LoadStorePair + (translate_boolean "wback" wback, + translate_boolean "postindex" postindex, + translate_reg "n" n, + translate_reg "t" t, + translate_reg "t2" t2, + translate_accType "acctype" acctype, + translate_memOp "memop" memop, + translate_boolean "signed" signed, + translate_data_size "datasize" datasize, + translate_bit64 "offset" offset) + +| `AArch64LoadImmediate (n,t,acctype,memop,signed,wback,postindex,offset,regsize,datasize) -> + LoadImmediate + (translate_reg "n" n, + translate_reg "t" t, + translate_accType "acctype" acctype, + translate_memOp "memop" memop, + translate_boolean "signed" signed, + translate_boolean "wback" wback, + translate_boolean "postindex" postindex, + translate_bit64 "offset" offset, + translate_reg_size "regsize" regsize, + translate_data_size "datasize" datasize) + +| `AArch64LoadLiteral (t,memop,signed,size,offset,datasize) -> + LoadLiteral + (translate_reg "t" t, + translate_memOp "memop" memop, + translate_boolean "signed" signed, + translate_uinteger "size" size, + translate_bit64 "offset" offset, + translate_data_size "datasize" datasize) + +| `AArch64LoadRegister (n,t,m,acctype,memop,signed,wback,postindex,extend_type,shift,regsize,datasize) -> + LoadRegister + (translate_reg "n" n, + translate_reg "t" t, + translate_reg "m" m, + translate_accType "acctype" acctype, + translate_memOp "memop" memop, + translate_boolean "signed" signed, + translate_boolean "wback" wback, + translate_boolean "postindex" postindex, + translate_extendType "extend_type" extend_type, + translate_uinteger "shift" shift, + translate_reg_size "regsize" regsize, + translate_data_size "datasize" datasize) + +| `AArch64MultiplyAddSub (d,n,m,a,destsize,datasize,sub_op) -> + MultiplyAddSub + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg "a" a, + translate_reg_size "destsize" destsize, + translate_data_size "datasize" datasize, + translate_boolean "sub_op" sub_op) + +| `AArch64MoveWide (d,datasize,imm,pos,opcode) -> + MoveWide + (translate_reg "d" d, + translate_reg_size "datasize" datasize, + translate_bit16 "imm" imm, + translate_uinteger "pos" pos, + translate_moveWideOp "opcode" opcode) + +| `AArch64Reverse (d,n,datasize,op) -> + Reverse + (translate_reg "d" d, + translate_reg "n" n, + translate_reg_size "datasize" datasize, + translate_revOp "op" op) + +| `AArch64Division (d,n,m,datasize,unsigned) -> + Division + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg_size "datasize" datasize, + translate_boolean "unsigned" unsigned) + +| `AArch64MultiplyAddSubLong (d,n,m,a,destsize,datasize,sub_op,unsigned) -> + MultiplyAddSubLong + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg "a" a, + translate_reg_size "destsize" destsize, + translate_data_size "datasize" datasize, + translate_boolean "sub_op" sub_op, + translate_boolean "unsigned" unsigned) + +| `AArch64MultiplyHigh (d,n,m,a,destsize,datasize,unsigned) -> + MultiplyHigh + (translate_reg "d" d, + translate_reg "n" n, + translate_reg "m" m, + translate_reg "a" a, + translate_reg_size "destsize" destsize, + translate_data_size "datasize" datasize, + translate_boolean "unsigned" unsigned) + +| `AArch64TestBitAndBranch (t,datasize,bit_pos,bit_val,offset) -> + TestBitAndBranch + (translate_reg "t" t, + translate_reg_size "datasize" datasize, + translate_uinteger "bit_pos" bit_pos, + translate_bit "bit_val" bit_val, + translate_bit64 "offset" offset) + +| `AArch64MoveSystemRegister (t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,read) -> + MoveSystemRegister + (translate_reg "t" t, + translate_uinteger "sys_op0" sys_op0, + translate_uinteger "sys_op1" sys_op1, + translate_uinteger "sys_op2" sys_op2, + translate_uinteger "sys_crn" sys_crn, + translate_uinteger "sys_crm" sys_crm, + translate_boolean "read" read) + +| `AArch64MoveSystemImmediate (operand,field) -> + MoveSystemImmediate + (translate_bit4 "operand" operand, + translate_pSTATEField "field" field) diff --git a/arm/gen/herdtools_types_to_shallow_types.hgen b/arm/gen/herdtools_types_to_shallow_types.hgen new file mode 100644 index 00000000..e14a37e3 --- /dev/null +++ b/arm/gen/herdtools_types_to_shallow_types.hgen @@ -0,0 +1,153 @@ +open Sail_values + +let is_inc = false + +let translate_big_int bits (name : string) value = + (name, Range0 (Some bits), IInt.bit_list_of_integer bits value) + +let translate_big_bit bits (name:string) value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int bits,value) + +let translate_int (size : int) (name:string) value = (Nat_big_num.of_int value) + +let translate_bits bits (name:string) value = + Sail_values.to_vec0 is_inc (Nat_big_num.of_int bits,Nat_big_num.of_int value) + +let translate_bool _ = function + | true -> B1 + | false -> B0 + +let translate_reg_size name value = + match value with + | Set32 -> (Nat_big_num.of_int 32) + | Set64 -> (Nat_big_num.of_int 64) + +let translate_reg name value = + (Nat_big_num.of_int (inst_reg_to_int value)) + + +let translate_reg_size_bits name value = + match value with + | R32Bits value -> translate_bits 32 name value + | R64Bits value -> translate_big_bit 64 name value + +let translate_data_size name value = + match value with + | DataSize8 -> (Nat_big_num.of_int 8) + | DataSize16 -> (Nat_big_num.of_int 16) + | DataSize32 -> (Nat_big_num.of_int 32) + | DataSize64 -> (Nat_big_num.of_int 64) + +let translate_reg_index = translate_int 5 + +let translate_boolean = translate_bool + +let translate_range0_7 = translate_int 3 + +let translate_range0_63 = translate_int 6 + +let translate_bit64 = translate_big_bit 64 + +let translate_bit4 = translate_bits 4 +let translate_bit5 = translate_bits 5 +let translate_bit16 = translate_bits 16 + +let translate_bit = translate_bool + +let translate_range8_64 = translate_int 7 + +let translate_uinteger = translate_int 63 + +let translate_extendType _ = function + | ExtendType_UXTB -> ArmV8_embed_types.ExtendType_UXTB + | ExtendType_UXTH -> ArmV8_embed_types.ExtendType_UXTH + | ExtendType_UXTW -> ArmV8_embed_types.ExtendType_UXTW + | ExtendType_UXTX -> ArmV8_embed_types.ExtendType_UXTX + | ExtendType_SXTB -> ArmV8_embed_types.ExtendType_SXTB + | ExtendType_SXTH -> ArmV8_embed_types.ExtendType_SXTH + | ExtendType_SXTW -> ArmV8_embed_types.ExtendType_SXTW + | ExtendType_SXTX -> ArmV8_embed_types.ExtendType_SXTX + +let translate_shiftType _ = function + | ShiftType_LSL -> ArmV8_embed_types.ShiftType_LSL + | ShiftType_LSR -> ArmV8_embed_types.ShiftType_LSR + | ShiftType_ASR -> ArmV8_embed_types.ShiftType_ASR + | ShiftType_ROR -> ArmV8_embed_types.ShiftType_ROR + +let translate_logicalOp _ = function + | LogicalOp_AND -> ArmV8_embed_types.LogicalOp_AND + | LogicalOp_EOR -> ArmV8_embed_types.LogicalOp_EOR + | LogicalOp_ORR -> ArmV8_embed_types.LogicalOp_ORR + +let translate_branchType _ = function + | BranchType_CALL -> ArmV8_embed_types.BranchType_CALL + | BranchType_ERET -> ArmV8_embed_types.BranchType_ERET + | BranchType_DBGEXIT -> ArmV8_embed_types.BranchType_DBGEXIT + | BranchType_RET -> ArmV8_embed_types.BranchType_RET + | BranchType_JMP -> ArmV8_embed_types.BranchType_JMP + | BranchType_EXCEPTION -> ArmV8_embed_types.BranchType_EXCEPTION + | BranchType_UNKNOWN -> ArmV8_embed_types.BranchType_UNKNOWN + +let translate_countOp _ = function + | CountOp_CLZ -> ArmV8_embed_types.CountOp_CLZ + | CountOp_CLS -> ArmV8_embed_types.CountOp_CLS + | CountOp_CNT -> ArmV8_embed_types.CountOp_CNT + +let translate_memBarrierOp _ = function + | MemBarrierOp_DSB -> ArmV8_embed_types.MemBarrierOp_DSB + | MemBarrierOp_DMB -> ArmV8_embed_types.MemBarrierOp_DMB + | MemBarrierOp_ISB -> ArmV8_embed_types.MemBarrierOp_ISB + +let translate_mBReqDomain _ = function + | MBReqDomain_Nonshareable -> ArmV8_embed_types.MBReqDomain_Nonshareable + | MBReqDomain_InnerShareable -> ArmV8_embed_types.MBReqDomain_InnerShareable + | MBReqDomain_OuterShareable -> ArmV8_embed_types.MBReqDomain_OuterShareable + | MBReqDomain_FullSystem -> ArmV8_embed_types.MBReqDomain_FullSystem + +let translate_mBReqTypes _ = function + | MBReqTypes_Reads -> ArmV8_embed_types.MBReqTypes_Reads + | MBReqTypes_Writes -> ArmV8_embed_types.MBReqTypes_Writes + | MBReqTypes_All -> ArmV8_embed_types.MBReqTypes_All + +let translate_systemHintOp _ = function + | SystemHintOp_NOP -> ArmV8_embed_types.SystemHintOp_NOP + | SystemHintOp_YIELD -> ArmV8_embed_types.SystemHintOp_YIELD + | SystemHintOp_WFE -> ArmV8_embed_types.SystemHintOp_WFE + | SystemHintOp_WFI -> ArmV8_embed_types.SystemHintOp_WFI + | SystemHintOp_SEV -> ArmV8_embed_types.SystemHintOp_SEV + | SystemHintOp_SEVL -> ArmV8_embed_types.SystemHintOp_SEVL + +let translate_accType _ = function + | AccType_NORMAL -> ArmV8_embed_types.AccType_NORMAL + | AccType_VEC -> ArmV8_embed_types.AccType_VEC + | AccType_STREAM -> ArmV8_embed_types.AccType_STREAM + | AccType_VECSTREAM -> ArmV8_embed_types.AccType_VECSTREAM + | AccType_ATOMIC -> ArmV8_embed_types.AccType_ATOMIC + | AccType_ORDERED -> ArmV8_embed_types.AccType_ORDERED + | AccType_UNPRIV -> ArmV8_embed_types.AccType_UNPRIV + | AccType_IFETCH -> ArmV8_embed_types.AccType_IFETCH + | AccType_PTW -> ArmV8_embed_types.AccType_PTW + | AccType_DC -> ArmV8_embed_types.AccType_DC + | AccType_IC -> ArmV8_embed_types.AccType_IC + | AccType_AT -> ArmV8_embed_types.AccType_AT + +let translate_memOp _ = function + | MemOp_LOAD -> ArmV8_embed_types.MemOp_LOAD + | MemOp_STORE -> ArmV8_embed_types.MemOp_STORE + | MemOp_PREFETCH -> ArmV8_embed_types.MemOp_PREFETCH + +let translate_moveWideOp _ = function + | MoveWideOp_N -> ArmV8_embed_types.MoveWideOp_N + | MoveWideOp_Z -> ArmV8_embed_types.MoveWideOp_Z + | MoveWideOp_K -> ArmV8_embed_types.MoveWideOp_K + +let translate_revOp _ = function + | RevOp_RBIT -> ArmV8_embed_types.RevOp_RBIT + | RevOp_REV16 -> ArmV8_embed_types.RevOp_REV16 + | RevOp_REV32 -> ArmV8_embed_types.RevOp_REV32 + | RevOp_REV64 -> ArmV8_embed_types.RevOp_REV64 + +let translate_pSTATEField _ = function + | PSTATEField_DAIFSet -> ArmV8_embed_types.PSTATEField_DAIFSet + | PSTATEField_DAIFClr -> ArmV8_embed_types.PSTATEField_DAIFClr + | PSTATEField_SP -> ArmV8_embed_types.PSTATEField_SP diff --git a/arm/gen/lexer.hgen b/arm/gen/lexer.hgen new file mode 100644 index 00000000..6ff24317 --- /dev/null +++ b/arm/gen/lexer.hgen @@ -0,0 +1,309 @@ +(* instructions: *) + + "TSTART" , TSTART {txt="TSTART"} ; + "TCOMMIT", TCOMMIT {txt="TCOMMIT"} ; + "TABORT" , TABORT {txt="TABORT"} ; + "TTEST" , TTEST {txt="TTEST"} ; + + "ADC" , ADCSBC {txt="ADC"; sub_op = false; setflags = false} ; + "SBC" , ADCSBC {txt="SBC"; sub_op = true; setflags = false} ; + "ADCS" , ADCSBC {txt="ADCS"; sub_op = false; setflags = true} ; + "SBCS" , ADCSBC {txt="SBCS"; sub_op = true; setflags = true} ; + + "ADD" , ADDSUB {txt="ADD"; sub_op=false; setflags=false} ; + "SUB" , ADDSUB {txt="SUB"; sub_op=true; setflags=false} ; + "ADDS" , ADDSUB {txt="ADDS"; sub_op=false; setflags=true} ; + "SUBS" , ADDSUB {txt="SUBS"; sub_op=true; setflags=true} ; + + "ADR" , ADR {txt="ADR"; page=false} ; + "ADRP" , ADR {txt="ADRP"; page=true} ; + + "AND" , LOGOP {txt="AND"; op = LogicalOp_AND; setflags = false; invert = false} ; + "ANDS" , LOGOP {txt="ANDS"; op = LogicalOp_AND; setflags = true; invert = false} ; + "EOR" , LOGOP {txt="EOR"; op = LogicalOp_EOR; setflags = false; invert = false} ; + "ORR" , LOGOP {txt="ORR"; op = LogicalOp_ORR; setflags = false; invert = false} ; + "BIC" , LOGOP {txt="BIC"; op = LogicalOp_AND; setflags = false; invert = true} ; + "BICS" , LOGOP {txt="BICS"; op = LogicalOp_AND; setflags = true; invert = true} ; + "EON" , LOGOP {txt="EON"; op = LogicalOp_EOR; setflags = false; invert = true} ; + "ORN" , LOGOP {txt="ORN"; op = LogicalOp_ORR; setflags = false; invert = true} ; + + "ASRV" , SHIFTOP {txt="ASRV"; shift_type=ShiftType_ASR} ; + "LSLV" , SHIFTOP {txt="LSLV"; shift_type=ShiftType_LSL} ; + "LSRV" , SHIFTOP {txt="LSRV"; shift_type=ShiftType_LSR} ; + "RORV" , SHIFTOP {txt="RORV"; shift_type=ShiftType_ROR} ; + + "B.EQ" , BCOND {txt="B.EQ"; condition=0b0000} ; + "B.NE" , BCOND {txt="B.NE"; condition=0b0001} ; + "B.CS" , BCOND {txt="B.CS"; condition=0b0010} ; + "B.HS" , BCOND {txt="B.CS"; condition=0b0010} ; + "B.CC" , BCOND {txt="B.CC"; condition=0b0011} ; + "B.LO" , BCOND {txt="B.CC"; condition=0b0011} ; + "B.MI" , BCOND {txt="B.MI"; condition=0b0100} ; + "B.PL" , BCOND {txt="B.PL"; condition=0b0101} ; + "B.VS" , BCOND {txt="B.VS"; condition=0b0110} ; + "B.VC" , BCOND {txt="B.VC"; condition=0b0111} ; + "B.HI" , BCOND {txt="B.HI"; condition=0b1000} ; + "B.LS" , BCOND {txt="B.LS"; condition=0b1001} ; + "B.GE" , BCOND {txt="B.GE"; condition=0b1010} ; + "B.LT" , BCOND {txt="B.LT"; condition=0b1011} ; + "B.GT" , BCOND {txt="B.GT"; condition=0b1100} ; + "B.LE" , BCOND {txt="B.LE"; condition=0b1101} ; + "B.AL" , BCOND {txt="B.AL"; condition=0b1110} ; + "B.NV" , BCOND {txt="B.NV"; condition=0b1111} ; (* ARM: exists only to provide a valid disassembly + of the 0b1111 encoding, otherwise its + behavior is identical to AL *) + + "B" , B {txt="B"; branch_type=BranchType_JMP} ; + "BL" , B {txt="BL"; branch_type=BranchType_CALL} ; + + "BR" , BR {txt="BR"; branch_type=BranchType_JMP} ; + "BLR" , BR {txt="BLR"; branch_type=BranchType_CALL} ; + + "CBZ" , CBZ {txt="CBZ"; iszero=true} ; + "CBNZ" , CBZ {txt="CBNZ"; iszero=false} ; + + "BFM" , BFM {txt="BFM"; inzero=false; extend=false} ; + "SBFM" , BFM {txt="SBFM"; inzero=true; extend=true} ; + "UBFM" , BFM {txt="UBFM"; inzero=true; extend=false} ; + + "CCMN" , CCM {txt="CCMN"; sub_op=false} ; + "CCMP" , CCM {txt="CCMP"; sub_op=true} ; + + "CMN" , CM {txt="CMN"; sub_op=false} ; + "CMP" , CM {txt="CMP"; sub_op=true} ; + + "CLS" , CL {txt="CLS"; opcode=CountOp_CLS} ; + "CLZ" , CL {txt="CLZ"; opcode=CountOp_CLZ} ; + + "CRC32B" , CRC {txt="CRC32B"; size = DataSize8; crc32c = false} ; + "CRC32H" , CRC {txt="CRC32H"; size = DataSize16; crc32c = false} ; + "CRC32W" , CRC {txt="CRC32W"; size = DataSize32; crc32c = false} ; + "CRC32CB" , CRC {txt="CRC32CB"; size = DataSize8; crc32c = true} ; + "CRC32CH" , CRC {txt="CRC32CH"; size = DataSize16; crc32c = true} ; + "CRC32CW" , CRC {txt="CRC32CW"; size = DataSize32; crc32c = true} ; + + "CRC32X" , CRC32X {txt="CRC32X"; crc32c=false} ; + "CRC32CX" , CRC32X {txt="CRC32CX"; crc32c=true} ; + + "CSEL" , CSEL {txt="CSEL"; else_inv = false; else_inc = false} ; + "CSINC" , CSEL {txt="CSINC"; else_inv = false; else_inc = true} ; + "CSINV" , CSEL {txt="CSINV"; else_inv = true; else_inc = false} ; + "CSNEG" , CSEL {txt="CSNEG"; else_inv = true; else_inc = true} ; + + "CSET" , CSET {txt="CSET"; else_inv = false; else_inc = true} ; + "CSETM" , CSETM {txt="CSETM"; else_inv = true; else_inc = false} ; + + "CINC" , CON {txt="CINC"; else_inv = false; else_inc = true} ; + "CINV" , CON {txt="CINV"; else_inv = true; else_inc = false} ; + "CNEG" , CON {txt="CNEG"; else_inv = true; else_inc = true} ; + + "DMB" , MEMBARR {txt="DMB"; op=MemBarrierOp_DMB} ; + "DSB" , MEMBARR {txt="DSB"; op=MemBarrierOp_DSB} ; + + "LDAR" , LDAXR {txt="LDAR"; acctype=AccType_ORDERED; excl=false; memop=MemOp_LOAD; var32={elsize=32; datasize=DataSize32}; var64=true} ; + "LDARB" , LDAXR {txt="LDARB"; acctype=AccType_ORDERED; excl=false; memop=MemOp_LOAD; var32={elsize=8; datasize=DataSize8}; var64=false} ; + "LDARH" , LDAXR {txt="LDARH"; acctype=AccType_ORDERED; excl=false; memop=MemOp_LOAD; var32={elsize=16; datasize=DataSize16}; var64=false} ; + "LDAXR" , LDAXR {txt="LDAXR"; acctype=AccType_ORDERED; excl=true; memop=MemOp_LOAD; var32={elsize=32; datasize=DataSize32}; var64=true} ; + "LDAXRB" , LDAXR {txt="LDAXRB"; acctype=AccType_ORDERED; excl=true; memop=MemOp_LOAD; var32={elsize=8; datasize=DataSize8}; var64=false} ; + "LDAXRH" , LDAXR {txt="LDAXRH"; acctype=AccType_ORDERED; excl=true; memop=MemOp_LOAD; var32={elsize=16; datasize=DataSize16}; var64=false} ; + "LDXR" , LDAXR {txt="LDXR"; acctype=AccType_ATOMIC; excl=true; memop=MemOp_LOAD; var32={elsize=32; datasize=DataSize32}; var64=true} ; + "LDXRB" , LDAXR {txt="LDXRB"; acctype=AccType_ATOMIC; excl=true; memop=MemOp_LOAD; var32={elsize=8; datasize=DataSize8}; var64=false} ; + "LDXRH" , LDAXR {txt="LDXRH"; acctype=AccType_ATOMIC; excl=true; memop=MemOp_LOAD; var32={elsize=16; datasize=DataSize16}; var64=false} ; + "STLR" , LDAXR {txt="STLR"; acctype=AccType_ORDERED; excl=false; memop=MemOp_STORE; var32={elsize=32; datasize=DataSize32}; var64=true} ; + "STLRB" , LDAXR {txt="STLRB"; acctype=AccType_ORDERED; excl=false; memop=MemOp_STORE; var32={elsize=8; datasize=DataSize8}; var64=false} ; + "STLRH" , LDAXR {txt="STLRH"; acctype=AccType_ORDERED; excl=false; memop=MemOp_STORE; var32={elsize=16; datasize=DataSize16}; var64=false} ; + + "STLXR" , STLXR {txt="STLXR"; acctype=AccType_ORDERED; var32={elsize=32; datasize=DataSize32}; var64=true} ; + "STLXRB" , STLXR {txt="STLXRB"; acctype=AccType_ORDERED; var32={elsize=8; datasize=DataSize8}; var64=false} ; + "STLXRH" , STLXR {txt="STLXRH"; acctype=AccType_ORDERED; var32={elsize=16; datasize=DataSize16}; var64=false} ; + "STXR" , STLXR {txt="STXR"; acctype=AccType_ATOMIC; var32={elsize=32; datasize=DataSize32}; var64=true} ; + "STXRB" , STLXR {txt="STXRB"; acctype=AccType_ATOMIC; var32={elsize=8; datasize=DataSize8}; var64=false} ; + "STXRH" , STLXR {txt="STXRH"; acctype=AccType_ATOMIC; var32={elsize=16; datasize=DataSize16}; var64=false} ; + + + "LDAXP" , LDXP {txt="LDAXP"; acctype=AccType_ORDERED} ; + "LDXP" , LDXP {txt="LDXP"; acctype=AccType_ATOMIC} ; + + "STLXP" , STXP {txt="STLXP"; acctype=AccType_ORDERED} ; + "STXP" , STXP {txt="STXP"; acctype=AccType_ATOMIC} ; + + "LDR" , LDSTR {txt="LDR"; memop=MemOp_LOAD; signed=false; lit32=true; var32=Some {datasize=DataSize32}; var64=Some {datasize=DataSize64}; lit64=Some {datasize=DataSize64; size=8}} ; + "LDRB" , LDSTR {txt="LDRB"; memop=MemOp_LOAD; signed=false; lit32=false; var32=Some {datasize=DataSize8}; var64=None; lit64=None} ; + "LDRH" , LDSTR {txt="LDRH"; memop=MemOp_LOAD; signed=false; lit32=false; var32=Some {datasize=DataSize16}; var64=None; lit64=None} ; + "LDRSB" , LDSTR {txt="LDRSB"; memop=MemOp_LOAD; signed=true; lit32=false; var32=Some {datasize=DataSize8}; var64=Some {datasize=DataSize8}; lit64=None} ; + "LDRSH" , LDSTR {txt="LDRSH"; memop=MemOp_LOAD; signed=true; lit32=false; var32=Some {datasize=DataSize16}; var64=Some {datasize=DataSize16}; lit64=None} ; + "LDRSW" , LDSTR {txt="LDRSW"; memop=MemOp_LOAD; signed=true; lit32=false; var32=None; var64=Some {datasize=DataSize32}; lit64=Some {datasize=DataSize32; size=4}} ; + "STR" , LDSTR {txt="STR"; memop=MemOp_STORE; signed=false; lit32=false; var32=Some {datasize=DataSize32}; var64=Some {datasize=DataSize64}; lit64=None} ; + "STRB" , LDSTR {txt="STRB"; memop=MemOp_STORE; signed=false; lit32=false; var32=Some {datasize=DataSize8}; var64=None; lit64=None} ; + "STRH" , LDSTR {txt="STRH"; memop=MemOp_STORE; signed=false; lit32=false; var32=Some {datasize=DataSize16}; var64=None; lit64=None} ; + + "LDTR" , LDSTTUR {txt="LDTR"; memop=MemOp_LOAD; acctype=AccType_UNPRIV; signed=false; off32=Some {datasize=DataSize32}; off64=Some {datasize=DataSize64}} ; + "LDTRB" , LDSTTUR {txt="LDTRB"; memop=MemOp_LOAD; acctype=AccType_UNPRIV; signed=false; off32=Some {datasize=DataSize8}; off64=None} ; + "LDTRH" , LDSTTUR {txt="LDTRH"; memop=MemOp_LOAD; acctype=AccType_UNPRIV; signed=false; off32=Some {datasize=DataSize16}; off64=None} ; + "LDTRSB" , LDSTTUR {txt="LDTRSB"; memop=MemOp_LOAD; acctype=AccType_UNPRIV; signed=true; off32=Some {datasize=DataSize8}; off64=Some {datasize=DataSize8}} ; + "LDTRSH" , LDSTTUR {txt="LDTRSH"; memop=MemOp_LOAD; acctype=AccType_UNPRIV; signed=true; off32=Some {datasize=DataSize16}; off64=Some {datasize=DataSize16}} ; + "LDTRSW" , LDSTTUR {txt="LDTRSW"; memop=MemOp_LOAD; acctype=AccType_UNPRIV; signed=true; off32=None; off64=Some {datasize=DataSize32}} ; + "LDUR" , LDSTTUR {txt="LDUR"; memop=MemOp_LOAD; acctype=AccType_NORMAL; signed=false; off32=Some {datasize=DataSize32}; off64=Some {datasize=DataSize64}} ; + "LDURB" , LDSTTUR {txt="LDURB"; memop=MemOp_LOAD; acctype=AccType_NORMAL; signed=false; off32=Some {datasize=DataSize8}; off64=None} ; + "LDURH" , LDSTTUR {txt="LDURH"; memop=MemOp_LOAD; acctype=AccType_NORMAL; signed=false; off32=Some {datasize=DataSize16}; off64=None} ; + "LDURSB" , LDSTTUR {txt="LDURSB"; memop=MemOp_LOAD; acctype=AccType_NORMAL; signed=true; off32=Some {datasize=DataSize8}; off64=Some {datasize=DataSize8}} ; + "LDURSH" , LDSTTUR {txt="LDURSH"; memop=MemOp_LOAD; acctype=AccType_NORMAL; signed=true; off32=Some {datasize=DataSize16}; off64=Some {datasize=DataSize16}} ; + "LDURSW" , LDSTTUR {txt="LDURSW"; memop=MemOp_LOAD; acctype=AccType_NORMAL; signed=true; off32=None; off64=Some {datasize=DataSize32}} ; + "STTR" , LDSTTUR {txt="STTR"; memop=MemOp_STORE; acctype=AccType_UNPRIV; signed=false; off32=Some {datasize=DataSize32}; off64=Some {datasize=DataSize64}} ; + "STTRB" , LDSTTUR {txt="STTRB"; memop=MemOp_STORE; acctype=AccType_UNPRIV; signed=false; off32=Some {datasize=DataSize8}; off64=None} ; + "STTRH" , LDSTTUR {txt="STTRH"; memop=MemOp_STORE; acctype=AccType_UNPRIV; signed=false; off32=Some {datasize=DataSize16}; off64=None} ; + "STUR" , LDSTTUR {txt="STUR"; memop=MemOp_STORE; acctype=AccType_NORMAL; signed=false; off32=Some {datasize=DataSize32}; off64=Some {datasize=DataSize64}} ; + "STURB" , LDSTTUR {txt="STURB"; memop=MemOp_STORE; acctype=AccType_NORMAL; signed=false; off32=Some {datasize=DataSize8}; off64=None} ; + "STURH" , LDSTTUR {txt="STURH"; memop=MemOp_STORE; acctype=AccType_NORMAL; signed=false; off32=Some {datasize=DataSize16}; off64=None} ; + + "MADD" , MADDSUB {txt="MADD"; sub_op=false} ; + "MSUB" , MADDSUB {txt="MSUB"; sub_op=true} ; + + "MUL" , MUL {txt="MUL"; sub_op=false} ; + "MNEG" , MUL {txt="MNEG"; sub_op=true} ; + + "MOVK" , MOVWIDE {txt="MOVK"; opcode=MoveWideOp_K} ; + "MOVN" , MOVWIDE {txt="MOVN"; opcode=MoveWideOp_N} ; + "MOVZ" , MOVWIDE {txt="MOVZ"; opcode=MoveWideOp_Z} ; + + "NEG" , NEG {txt="NEG"; setflags=false} ; + "NEGS" , NEG {txt="NEGS"; setflags=true} ; + + "NGC" , NGC {txt="NGC"; setflags=false} ; + "NGCS" , NGC {txt="NGCS"; setflags=true} ; + + "RBIT" , REV {txt="RBIT"; op32=Some RevOp_RBIT; op64=RevOp_RBIT} ; + "REV" , REV {txt="REV"; op32=Some RevOp_REV32; op64=RevOp_REV64} ; + "REV16" , REV {txt="REV16"; op32=Some RevOp_REV16; op64=RevOp_REV16} ; + "REV32" , REV {txt="REV32"; op32=None; op64=RevOp_REV32} ; + + "SDIV" , DIV {txt="SDIV"; unsigned=false} ; + "UDIV" , DIV {txt="UDIV"; unsigned=true} ; + + "SMADDL" , MADDSUBL {txt="SMADDL"; sub_op=false; unsigned=false} ; + "SMSUBL" , MADDSUBL {txt="SMSUBL"; sub_op=true; unsigned=false} ; + "UMADDL" , MADDSUBL {txt="UMADDL"; sub_op=false; unsigned=true} ; + "UMSUBL" , MADDSUBL {txt="UMSUBL"; sub_op=true; unsigned=true} ; + + "SMULH" , MULH {txt="SMULH"; unsigned=false} ; + "UMULH" , MULH {txt="UMULH"; unsigned=true} ; + + "SMULL" , MULL {txt="SMULL"; unsigned=false} ; + "UMULL" , MULL {txt="UMULL"; unsigned=true} ; + + "LDP" , LDSTP {txt="LDP"; memop=MemOp_LOAD} ; + "STP" , LDSTP {txt="STP"; memop=MemOp_STORE} ; + + "TBZ" , TBZ {txt="TBZ"; bit_val=false} ; + "TBNZ" , TBZ {txt="TBNZ"; bit_val=true} ; + + "SBFIZ" , BFIZ {txt="SBFIZ"; extend=true} ; + "UBFIZ" , BFIZ {txt="UBFIZ"; extend=false} ; + + "SBFX" , BFX {txt="SBFX"; extend=true} ; + "UBFX" , BFX {txt="UBFX"; extend=false} ; + + "SMNEGL" , MNEGL {txt="SMNEGL"; unsigned=false} ; + "UMNEGL" , MNEGL {txt="UMNEGL"; unsigned=true} ; + + "BFI" , BFI {txt="BFI"} ; + "BFXIL" , BFXIL {txt="BFXIL"} ; + "CLREX" , CLREX {txt="CLREX"} ; + "EXTR" , EXTR {txt="EXTR"} ; + "HINT" , HINT {txt="HINT"} ; + "ISB" , ISB {txt="ISB"} ; + "LDPSW" , LDPSW {txt="LDPSW"} ; + "MOV" , MOV {txt="MOV"} ; + "MVN" , MVN {txt="MVN"} ; + "NOP" , NOP {txt="NOP"} ; + "PRFM" , PRFM {txt="PRFM"} ; + "PRFUM" , PRFUM {txt="PRFUM"} ; + "RET" , RET {txt="RET"} ; + "TST" , TST {txt="TST"} ; + "MRS" , MRS {txt="MRS"} ; + "MSR" , MSR {txt="MSR"} ; + + +(*** instructions/operands ***) + + "LSL" , SHIFT {txt="LSL"; shift_type=ShiftType_LSL} ; + "LSR" , SHIFT {txt="LSR"; shift_type=ShiftType_LSR} ; + "ASR" , SHIFT {txt="ASR"; shift_type=ShiftType_ASR} ; + "ROR" , SHIFT {txt="ROR"; shift_type=ShiftType_ROR} ; + + "UXTB" , EXTEND {txt="UXTB"; _type=ExtendType_UXTB; inst=Some {extend=false; imms=7}} ; + "UXTH" , EXTEND {txt="UXTH"; _type=ExtendType_UXTH; inst=Some {extend=false; imms=15}} ; + "UXTW" , EXTEND {txt="UXTW"; _type=ExtendType_UXTW; inst=None} ; + "UXTX" , EXTEND {txt="UXTX"; _type=ExtendType_UXTX; inst=None} ; + "SXTB" , EXTEND {txt="SXTB"; _type=ExtendType_SXTB; inst=Some {extend=true; imms=7}} ; + "SXTH" , EXTEND {txt="SXTH"; _type=ExtendType_SXTH; inst=Some {extend=true; imms=15}} ; + "SXTW" , EXTEND {txt="SXTW"; _type=ExtendType_SXTW; inst=Some {extend=true; imms=31}} ; + "SXTX" , EXTEND {txt="SXTX"; _type=ExtendType_SXTX; inst=None} ; + +(*** operands: ***) + + "EQ" , COND 0b0000 ; + "NE" , COND 0b0001 ; + "CS" , COND 0b0010 ; + "HS" , COND 0b0010 ; + "CC" , COND 0b0011 ; + "LO" , COND 0b0011 ; + "MI" , COND 0b0100 ; + "PL" , COND 0b0101 ; + "VS" , COND 0b0110 ; + "VC" , COND 0b0111 ; + "HI" , COND 0b1000 ; + "LS" , COND 0b1001 ; + "GE" , COND 0b1010 ; + "LT" , COND 0b1011 ; + "GT" , COND 0b1100 ; + "LE" , COND 0b1101 ; + "AL" , COND 0b1110 ; + "NV" , COND 0b1111 ; (* ARM: exists only to provide a valid disassembly + of the 0b1111 encoding, otherwise its + behavior is identical to AL *) + + "OSHLD" , BARROP {domain=MBReqDomain_OuterShareable; types=MBReqTypes_Reads} ; + "OSHST" , BARROP {domain=MBReqDomain_OuterShareable; types=MBReqTypes_Writes} ; + "OSH" , BARROP {domain=MBReqDomain_OuterShareable; types=MBReqTypes_All} ; + "NSHLD" , BARROP {domain=MBReqDomain_Nonshareable; types=MBReqTypes_Reads} ; + "NSHST" , BARROP {domain=MBReqDomain_Nonshareable; types=MBReqTypes_Writes} ; + "NSH" , BARROP {domain=MBReqDomain_Nonshareable; types=MBReqTypes_All} ; + "ISHLD" , BARROP {domain=MBReqDomain_InnerShareable; types=MBReqTypes_Reads} ; + "ISHST" , BARROP {domain=MBReqDomain_InnerShareable; types=MBReqTypes_Writes} ; + "ISH" , BARROP {domain=MBReqDomain_InnerShareable; types=MBReqTypes_All} ; + "LD" , BARROP {domain=MBReqDomain_FullSystem; types=MBReqTypes_Reads} ; + "ST" , BARROP {domain=MBReqDomain_FullSystem; types=MBReqTypes_Writes} ; + "SY" , BARROP {domain=MBReqDomain_FullSystem; types=MBReqTypes_All} ; + + "PLDL1KEEP" , PRFOP (X (Ireg R0)) ; + "PLDL1STRM" , PRFOP (X (Ireg R1)) ; + "PLDL2KEEP" , PRFOP (X (Ireg R2)) ; + "PLDL2STRM" , PRFOP (X (Ireg R3)) ; + "PLDL3KEEP" , PRFOP (X (Ireg R4)) ; + "PLDL3STRM" , PRFOP (X (Ireg R5)) ; + + "PLIL1KEEP" , PRFOP (X (Ireg R8)) ; + "PLIL1STRM" , PRFOP (X (Ireg R9)) ; + "PLIL2KEEP" , PRFOP (X (Ireg R10)) ; + "PLIL2STRM" , PRFOP (X (Ireg R11)) ; + "PLIL3KEEP" , PRFOP (X (Ireg R12)) ; + "PLIL3STRM" , PRFOP (X (Ireg R13)) ; + + "PSTL1KEEP" , PRFOP (X (Ireg R16)) ; + "PSTL1STRM" , PRFOP (X (Ireg R17)) ; + "PSTL2KEEP" , PRFOP (X (Ireg R18)) ; + "PSTL2STRM" , PRFOP (X (Ireg R19)) ; + "PSTL3KEEP" , PRFOP (X (Ireg R20)) ; + "PSTL3STRM" , PRFOP (X (Ireg R21)) ; + + "NZCV" , SYSREG {sys_op0=0b11; sys_op1=0b011; sys_op2=0b000; sys_crn=0b0100; sys_crm=0b0010} ; + "DAIF" , SYSREG {sys_op0=0b11; sys_op1=0b011; sys_op2=0b001; sys_crn=0b0100; sys_crm=0b0010} ; + "TPIDR_EL0" , SYSREG {sys_op0=0b11; sys_op1=0b011; sys_op2=0b010; sys_crn=0b1101; sys_crm=0b0000} ; + "TPIDR_EL1" , SYSREG {sys_op0=0b11; sys_op1=0b000; sys_op2=0b100; sys_crn=0b1101; sys_crm=0b0000} ; + "TPIDR_EL2" , SYSREG {sys_op0=0b11; sys_op1=0b100; sys_op2=0b010; sys_crn=0b1101; sys_crm=0b0000} ; + "TPIDR_EL3" , SYSREG {sys_op0=0b11; sys_op1=0b011; sys_op2=0b011; sys_crn=0b1101; sys_crm=0b0000} ; + + "SPSel" , PSTATEFIELD (PSTATEField_SP) ; + "DAIFSet" , PSTATEFIELD (PSTATEField_DAIFSet) ; + "DAIFClr" , PSTATEFIELD (PSTATEField_DAIFClr) ; diff --git a/arm/gen/map.hgen b/arm/gen/map.hgen new file mode 100644 index 00000000..62899c91 --- /dev/null +++ b/arm/gen/map.hgen @@ -0,0 +1,44 @@ +| `AArch64TMStart t -> `AArch64TMStart (map_reg t) +| `AArch64TMCommit -> `AArch64TMCommit +| `AArch64TMAbort (retry,reason) -> `AArch64TMAbort (retry,reason) +| `AArch64TMTest -> `AArch64TMTest + +| `AArch64ImplementationDefinedStopFetching -> `AArch64ImplementationDefinedStopFetching +| `AArch64ImplementationDefinedThreadStart -> `AArch64ImplementationDefinedThreadStart +| `AArch64ImplementationDefinedTestBeginEnd (isEnd) -> `AArch64ImplementationDefinedTestBeginEnd (isEnd) +| `AArch64AddSubCarry (d,n,m,datasize,sub_op,setflags) -> `AArch64AddSubCarry (map_reg d,map_reg n,map_reg m,datasize,sub_op,setflags) +| `AArch64AddSubExtendRegister (d,n,m,datasize,sub_op,setflags,extend_type,shift) -> `AArch64AddSubExtendRegister (map_reg d,map_reg n,map_reg m,datasize,sub_op,setflags,extend_type,shift) +| `AArch64AddSubShiftedRegister (d,n,m,datasize,sub_op,setflags,shift_type,shift_amount) -> `AArch64AddSubShiftedRegister (map_reg d,map_reg n,map_reg m,datasize,sub_op,setflags,shift_type,shift_amount) +| `AArch64AddSubImmediate (d,n,datasize,sub_op,setflags,imm) -> `AArch64AddSubImmediate (map_reg d,map_reg n,datasize,sub_op,setflags,imm) +| `AArch64Address (d,page,imm) -> `AArch64Address (map_reg d,page,imm) +| `AArch64LogicalImmediate (d,n,datasize,setflags,op,imm) -> `AArch64LogicalImmediate (map_reg d,map_reg n,datasize,setflags,op,imm) +| `AArch64LogicalShiftedRegister (d,n,m,datasize,setflags,op,shift_type,shift_amount,invert) -> `AArch64LogicalShiftedRegister (map_reg d,map_reg n,map_reg m,datasize,setflags,op,shift_type,shift_amount,invert) +| `AArch64Shift (d,n,m,datasize,shift_type) -> `AArch64Shift (map_reg d,map_reg n,map_reg m,datasize,shift_type) +| `AArch64BranchConditional (offset,condition) -> `AArch64BranchConditional (offset,condition) +| `AArch64BranchImmediate (branch_type,offset) -> `AArch64BranchImmediate (branch_type,offset) +| `AArch64BitfieldMove (d,n,datasize,inzero,extend,_R,_S,wmask,tmask) -> `AArch64BitfieldMove (map_reg d,map_reg n,datasize,inzero,extend,_R,_S,wmask,tmask) +| `AArch64BranchRegister (n,branch_type) -> `AArch64BranchRegister (map_reg n,branch_type) +| `AArch64CompareAndBranch (t,datasize,iszero,offset) -> `AArch64CompareAndBranch (map_reg t,datasize,iszero,offset) +| `AArch64ConditionalCompareImmediate (n,datasize,sub_op,condition,flags,imm) -> `AArch64ConditionalCompareImmediate (map_reg n,datasize,sub_op,condition,flags,imm) +| `AArch64ConditionalCompareRegister (n,m,datasize,sub_op,condition,flags) -> `AArch64ConditionalCompareRegister (map_reg n,map_reg m,datasize,sub_op,condition,flags) +| `AArch64ClearExclusiveMonitor (imm) -> `AArch64ClearExclusiveMonitor (imm) +| `AArch64CountLeading (d,n,datasize,opcode) -> `AArch64CountLeading (map_reg d,map_reg n,datasize,opcode) +| `AArch64CRC (d,n,m,size,crc32c) -> `AArch64CRC (map_reg d,map_reg n,map_reg m,size,crc32c) +| `AArch64ConditionalSelect (d,n,m,datasize,condition,else_inv,else_inc) -> `AArch64ConditionalSelect (map_reg d,map_reg n,map_reg m,datasize,condition,else_inv,else_inc) +| `AArch64Barrier (op,domain,types) -> `AArch64Barrier (op,domain,types) +| `AArch64ExtractRegister (d,n,m,datasize,lsb) -> `AArch64ExtractRegister (map_reg d,map_reg n,map_reg m,datasize,lsb) +| `AArch64Hint (op) -> `AArch64Hint (op) +| `AArch64LoadStoreAcqExc (n,t,t2,s,acctype,excl,pair,memop,elsize,regsize,datasize) -> `AArch64LoadStoreAcqExc (map_reg n,map_reg t,map_reg t2,map_reg s,acctype,excl,pair,memop,elsize,regsize,datasize) +| `AArch64LoadStorePair (wback,postindex,n,t,t2,acctype,memop,signed,datasize,offset) -> `AArch64LoadStorePair (wback,postindex,map_reg n,map_reg t,map_reg t2,acctype,memop,signed,datasize,offset) +| `AArch64LoadImmediate (n,t,acctype,memop,signed,wback,postindex,offset,regsize,datasize) -> `AArch64LoadImmediate (map_reg n,map_reg t,acctype,memop,signed,wback,postindex,offset,regsize,datasize) +| `AArch64LoadLiteral (t,memop,signed,size,offset,datasize) -> `AArch64LoadLiteral (map_reg t,memop,signed,size,offset,datasize) +| `AArch64LoadRegister (n,t,m,acctype,memop,signed,wback,postindex,extend_type,shift,regsize,datasize) -> `AArch64LoadRegister (map_reg n,map_reg t,map_reg m,acctype,memop,signed,wback,postindex,extend_type,shift,regsize,datasize) +| `AArch64MultiplyAddSub (d,n,m,a,destsize,datasize,sub_op) -> `AArch64MultiplyAddSub (map_reg d,map_reg n,map_reg m,map_reg a,destsize,datasize,sub_op) +| `AArch64MoveWide (d,datasize,imm,pos,opcode) -> `AArch64MoveWide (map_reg d,datasize,imm,pos,opcode) +| `AArch64Reverse (d,n,datasize,op) -> `AArch64Reverse (map_reg d,map_reg n,datasize,op) +| `AArch64Division (d,n,m,datasize,unsigned) -> `AArch64Division (map_reg d,map_reg n,map_reg m,datasize,unsigned) +| `AArch64MultiplyAddSubLong (d,n,m,a,destsize,datasize,sub_op,unsigned) -> `AArch64MultiplyAddSubLong (map_reg d,map_reg n,map_reg m,map_reg a,destsize,datasize,sub_op,unsigned) +| `AArch64MultiplyHigh (d,n,m,a,destsize,datasize,unsigned) -> `AArch64MultiplyHigh (map_reg d,map_reg n,map_reg m,map_reg a,destsize,datasize,unsigned) +| `AArch64TestBitAndBranch (t,datasize,bit_pos,bit_val,offset) -> `AArch64TestBitAndBranch (map_reg t,datasize,bit_pos,bit_val,offset) +| `AArch64MoveSystemRegister (t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,read) -> `AArch64MoveSystemRegister (map_reg t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,read) +| `AArch64MoveSystemImmediate (operand,field) -> `AArch64MoveSystemImmediate (operand,field) diff --git a/arm/gen/parser.hgen b/arm/gen/parser.hgen new file mode 100644 index 00000000..94ce6fcf --- /dev/null +++ b/arm/gen/parser.hgen @@ -0,0 +1,1396 @@ + /* TSTART */ + | TSTART xreg + { if not (isregzr $2) then error_registers ("expected " ^ $1.txt ^ " ") + else `AArch64TMStart $2 } + + /* TCOMMIT */ + | TCOMMIT + { `AArch64TMCommit } + + /* TABORT */ + | TABORT imm + { if not (iskbituimm 6 $2) then error_arg " must be in the range 0 to 63" + else `AArch64TMAbort (($2 lsr 5) <> 0, $2 mod 32) } + + /* TTEST */ + | TTEST + {`AArch64TMTest} + + | ADCSBC wreg COMMA wreg COMMA wreg + { if not (isregzr $2 && isregzr $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , ") + else `AArch64AddSubCarry ($2,$4,$6,Set32,$1.sub_op,$1.setflags) } + | ADCSBC xreg COMMA xreg COMMA xreg + { if not (isregzr $2 && isregzr $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , ") + else `AArch64AddSubCarry ($2,$4,$6,Set64,$1.sub_op,$1.setflags) } + + /* ADC/ADCS/SBC/SBCS */ + + | ADCSBC wreg COMMA wreg COMMA wreg + { if not (isregzr $2 && isregzr $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , ") + else `AArch64AddSubCarry ($2,$4,$6,Set32,$1.sub_op,$1.setflags) } + | ADCSBC xreg COMMA xreg COMMA xreg + { if not (isregzr $2 && isregzr $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , ") + else `AArch64AddSubCarry ($2,$4,$6,Set64,$1.sub_op,$1.setflags) } + + /* ADD/SUB/ADDS/SUBS (extended register), and when noted (shifted register) */ + + | ADDSUB wreg COMMA wreg COMMA wreg + { (* ambiguous with (shifted register) *) + if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then + error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then + error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else `AArch64AddSubExtendRegister ($2,$4,$6,Set32,$1.sub_op,$1.setflags,ExtendType_UXTW,0) } + | ADDSUB wreg COMMA wreg COMMA wreg COMMA EXTEND + { if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then + error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then + error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else `AArch64AddSubExtendRegister ($2,$4,$6,Set32,$1.sub_op,$1.setflags,$8._type,0) } + | ADDSUB wreg COMMA wreg COMMA wreg COMMA SHIFT + { if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if (not $1.setflags) && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not ($8.shift_type = ShiftType_LSL) then error_arg " must be one of UXTB,UXTH,UXTW,UXTX,SXTB,SXTH,SXTW,SXTX,LSL" + else `AArch64AddSubExtendRegister ($2,$4,$6,Set32,$1.sub_op,$1.setflags,ExtendType_UXTW,0) } + | ADDSUB wreg COMMA wreg COMMA wreg COMMA EXTEND imm + { if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not (0 <= $9 && $9 <= 4) then error_arg " must be in the range 0 to 4" + else `AArch64AddSubExtendRegister ($2,$4,$6,Set32,$1.sub_op,$1.setflags,$8._type,$9) } + | ADDSUB wreg COMMA wreg COMMA wreg COMMA SHIFT imm + { if (issp $2 || issp $4) then + begin + (* (extended register) *) + if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not ($8.shift_type = ShiftType_LSL) then error_arg " must be one of UXTB,UXTH,UXTW,UXTX,SXTB,SXTH,SXTW,SXTX,LSL" + else if not (0 <= $9 && $9 <= 4) then error_arg " must be in the range 0 to 4" + else `AArch64AddSubExtendRegister ($2,$4,$6,Set32,$1.sub_op,$1.setflags,ExtendType_UXTW,$9) + end + else + begin + (* (shifted register) *) + if not (isregzr $2 && isregzr $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, #}") + else if $8.shift_type = ShiftType_ROR then error_arg " must be one of LSL,LSR,ASR" + else if not (0 <= $9 && $9 <= 31) then error_arg " must be in the range 0 to 31" + else `AArch64AddSubShiftedRegister ($2,$4,$6,Set32,$1.sub_op,$1.setflags,$8.shift_type,$9) + end } + + | ADDSUB xreg COMMA xreg COMMA xreg + { (* ambiguous with (shifted register) *) + if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else `AArch64AddSubExtendRegister ($2,$4,$6,Set64,$1.sub_op,$1.setflags,ExtendType_UXTX,0) } + | ADDSUB xreg COMMA xreg COMMA wreg COMMA EXTEND + { if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if $8._type = ExtendType_UXTX || $8._type = ExtendType_SXTX then error_arg " doesn't match " + else `AArch64AddSubExtendRegister ($2,$4,$6,Set64,$1.sub_op,$1.setflags,$8._type,0) } + | ADDSUB xreg COMMA xreg COMMA wreg COMMA SHIFT + { if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not ($8.shift_type = ShiftType_LSL) then error_arg " must be one of UXTB,UXTH,UXTW,UXTX,SXTB,SXTH,SXTW,SXTX,LSL" + else `AArch64AddSubExtendRegister ($2,$4,$6,Set64,$1.sub_op,$1.setflags,ExtendType_UXTX,0) } + | ADDSUB xreg COMMA xreg COMMA wreg COMMA EXTEND imm + { if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not (0 <= $9 && $9 <= 4) then error_arg " must be in the range 0 to 4." + else if $8._type = ExtendType_UXTX || $8._type = ExtendType_SXTX then error_arg " doesn't match " + else `AArch64AddSubExtendRegister ($2,$4,$6,Set64,$1.sub_op,$1.setflags,$8._type,$9) } + | ADDSUB xreg COMMA xreg COMMA wreg COMMA SHIFT imm + { if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not ($8.shift_type = ShiftType_LSL) then error_arg " must be one of UXTB,UXTH,UXTW,UXTX,SXTB,SXTH,SXTW,SXTX,LSL" + else if not (0 <= $9 && $9 <= 4) then error_arg " must be in the range 0 to 4." + else `AArch64AddSubExtendRegister ($2,$4,$6,Set64,$1.sub_op,$1.setflags,ExtendType_UXTX,$9) } + | ADDSUB xreg COMMA xreg COMMA xreg COMMA EXTEND + { if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not ($8._type = ExtendType_UXTX || $8._type = ExtendType_SXTX) then error_arg " doesn't match " + else `AArch64AddSubExtendRegister ($2,$4,$6,Set64,$1.sub_op,$1.setflags,$8._type,0) } + | ADDSUB xreg COMMA xreg COMMA xreg COMMA SHIFT + { if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not ($8.shift_type = ShiftType_LSL) then error_arg " must be one of UXTB,UXTH,UXTW,UXTX,SXTB,SXTH,SXTW,SXTX,LSL" + else `AArch64AddSubExtendRegister ($2,$4,$6,Set64,$1.sub_op,$1.setflags,ExtendType_UXTX,0) } + | ADDSUB xreg COMMA xreg COMMA xreg COMMA EXTEND imm + { if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not (0 <= $9 && $9 <= 4) then error_arg " must be in the range 0 to 4." + else if not ($8._type = ExtendType_UXTX || $8._type = ExtendType_SXTX) then error_arg " doesn't match " + else `AArch64AddSubExtendRegister ($2,$4,$6,Set64,$1.sub_op,$1.setflags,$8._type,$9) } + | ADDSUB xreg COMMA xreg COMMA xreg COMMA SHIFT imm + { if (issp $2 || issp $4) then + begin + (* (extended register) *) + if $1.setflags && not (isregzr $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not $1.setflags && not (isregsp $2 && isregsp $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, {#}}") + else if not ($8.shift_type = ShiftType_LSL) then error_arg " must be one of UXTB,UXTH,UXTW,UXTX,SXTB,SXTH,SXTW,SXTX,LSL" + else if not (0 <= $9 && $9 <= 4) then error_arg " must be in the range 0 to 4." + else `AArch64AddSubExtendRegister ($2,$4,$6,Set64,$1.sub_op,$1.setflags,ExtendType_UXTX,$9) + end + else + begin + (* (shifted register) *) + if not (isregzr $2 && isregzr $4 && isregzr $6) then error_registers ("expected " ^ $1.txt ^ " , , {, #}") + else if $8.shift_type = ShiftType_ROR then error_arg " must be one of LSL,LSR,ASR" + else if not (0 <= $9 && $9 <= 63) then error_arg " must be in the range 0 to 63" + else `AArch64AddSubShiftedRegister ($2,$4,$6,Set64,$1.sub_op,$1.setflags,$8.shift_type,$9) + end } + + /* ADD/SUB/ADDS/SUBS (immediate) */ + + | ADDSUB wreg COMMA wreg COMMA imm + { if $1.setflags && not (isregzr $2 && isregsp $4) then error_registers ("expected " ^ $1.txt ^ " , , #{, }") + else if not $1.setflags && not (isregsp $2 && isregsp $4) then error_registers ("expected " ^ $1.txt ^ " , , #{, }") + else if not (0 <= $6 && $6 <= 4095) then error_arg " must be in the range 0 to 4095" + else `AArch64AddSubImmediate ($2,$4,Set32,$1.sub_op,$1.setflags,reg_size_bits_R32_of_int $6) } + | ADDSUB wreg COMMA wreg COMMA imm COMMA SHIFT imm + { if $1.setflags && not (isregzr $2 && isregsp $4) then error_registers ("expected " ^ $1.txt ^ " , , #{, }") + else if not $1.setflags && not (isregsp $2 && isregsp $4) then error_registers ("expected " ^ $1.txt ^ " , , #{, }") + else if not (0 <= $6 && $6 <= 4095) then error_arg " must be in the range 0 to 4095" + else if not ($8.shift_type = ShiftType_LSL && ($9 = 0 || $9 = 12)) then error_arg " must be 'LSL #0' or 'LSL #12'" + else `AArch64AddSubImmediate ($2,$4,Set32,$1.sub_op,$1.setflags,reg_size_bits_R32_of_int ($6 lsl $9)) } + | ADDSUB xreg COMMA xreg COMMA imm + { if $1.setflags && not (isregzr $2 && isregsp $4) then error_registers ("expected " ^ $1.txt ^ " , , #{, }") + else if not $1.setflags && not (isregsp $2 && isregsp $4) then error_registers ("expected " ^ $1.txt ^ " , , #{, }") + else if not (0 <= $6 && $6 <= 4095) then error_arg " must be in the range 0 to 4095" + else `AArch64AddSubImmediate ($2,$4,Set64,$1.sub_op,$1.setflags,reg_size_bits_R64_of_int $6) } + | ADDSUB xreg COMMA xreg COMMA imm COMMA SHIFT imm + { if $1.setflags && not (isregzr $2 && isregsp $4) then error_registers ("expected " ^ $1.txt ^ " , , #{, }") + else if not $1.setflags && not (isregsp $2 && isregsp $4) then error_registers ("expected " ^ $1.txt ^ " , , #{, }") + else if not (0 <= $6 && $6 <= 4095) then error_arg " must be in the range 0 to 4095" + else if not ($8.shift_type = ShiftType_LSL && ($9 = 0 || $9 = 12)) then error_arg " must be 'LSL #0' or 'LSL #12'" + else `AArch64AddSubImmediate ($2,$4,Set64,$1.sub_op,$1.setflags,reg_size_bits_R64_of_int ($6 lsl $9)) } + + /* ADR/ADRP */ +/* + | ADR xreg COMMA NAME + { if not (isregzr $2) then error_registers ("expected " ^ $1.txt ^ " ,