diff options
92 files changed, 4756 insertions, 20912 deletions
@@ -1,11 +1,15 @@ .PHONY: all sail language clean archs isabelle-lib apply_header -all: sail interpreter +all: sail sail: - $(MAKE) -C src + $(MAKE) -C src sail ln -f -s src/sail.native sail +isail: + $(MAKE) -C src isail + ln -f -s src/isail.native sail + language: $(MAKE) -C language diff --git a/editors/sail2-mode.el b/editors/sail2-mode.el index 8dde96df..e17b1a4f 100644 --- a/editors/sail2-mode.el +++ b/editors/sail2-mode.el @@ -4,11 +4,11 @@ (add-to-list 'auto-mode-alist '("\\.sail\\'" . sail-mode)) (defconst sail2-keywords - '("val" "function" "type" "struct" "union" "enum" "let" "if" "then" - "else" "match" "in" "return" "register" "forall" "operator" "effect" - "overload" "cast" "sizeof" "constraint" "default" "assert" + '("val" "function" "type" "struct" "union" "enum" "let" "var" "if" "then" + "else" "match" "in" "return" "register" "ref" "forall" "operator" "effect" + "overload" "cast" "sizeof" "constraint" "default" "assert" "newtype" "pure" "infixl" "infixr" "infix" "scattered" "end" "try" "catch" "and" - "throw" "clause" "as" "repeat" "until" "while" "do" "foreach")) + "throw" "clause" "as" "repeat" "until" "while" "do" "foreach" "bitfield")) (defconst sail2-kinds '("Int" "Type" "Order" "inc" "dec" @@ -31,16 +31,12 @@ (defconst sail2-mode-syntax-table (let ((st (make-syntax-table))) + (modify-syntax-entry ?> "." st) (modify-syntax-entry ?_ "w" st) (modify-syntax-entry ?' "w" st) - (modify-syntax-entry ?* ". 23" st) - (condition-case nil - (progn - (modify-syntax-entry ?\( "()1n" st) - (modify-syntax-entry ?\) ")(4n" st)) - (error ; XEmacs signals an error instead of ignoring `n'. - (modify-syntax-entry ?\( "()1" st) - (modify-syntax-entry ?\) ")(4" st))) + (modify-syntax-entry ?* ". 23" st) + (modify-syntax-entry ?/ ". 124b" st) + (modify-syntax-entry ?\n "> b" st) st) "Syntax table for Sail2 mode") diff --git a/language/l2.ott b/language/l2.ott index 02823237..69073421 100644 --- a/language/l2.ott +++ b/language/l2.ott @@ -26,7 +26,7 @@ metavar hex ::= {{ ocaml string }} {{ lem string }} {{ com Bit vector literal, specified by C-style hex number }} - + metavar bin ::= {{ phantom }} {{ lex numeric }} @@ -55,10 +55,16 @@ metavar real ::= {{ hol string }} {{ com Real number literal }} +metavar value ::= + {{ phantom }} + {{ ocaml value }} + {{ lem value }} + embed {{ ocaml open Big_int +open Value type text = string @@ -72,28 +78,15 @@ type loop = While | Until embed {{ lem -open import Pervasives -open import Pervasives_extra -open import Map -open import Maybe -open import Set_extra - -type l = - | Unknown - | Int of string * maybe l (*internal types, functions*) - | Range of string * nat * nat * nat * nat - | Generated of l (*location for a generated node, where l is the location of the closest original source*) - -type annot 'a = l * 'a -val duplicates : forall 'a. list 'a -> list 'a +type l = | Unknown -val set_from_list : forall 'a. list 'a -> set 'a - -val subst : forall 'a. list 'a -> list 'a -> bool +type value = | Val type loop = While | Until +type annot 'a = l * 'a + }} metavar x , y , z ::= @@ -113,8 +106,6 @@ metavar ix ::= {{ ocamlvar "[[ix]]" }} {{ lemvar "[[ix]]" }} - - grammar l :: '' ::= {{ phantom }} @@ -139,7 +130,7 @@ id :: '' ::= | x :: :: id | ( deinfix x ) :: D :: deIid {{ com remove infix status }} | bool :: M :: bool {{ com built in type identifiers }} {{ ichlo (Id "bool") }} - | bit :: M :: bit {{ ichlo (Id "bit") }} + | bit :: M :: bit {{ ichlo (Id "bit") }} | unit :: M :: unit {{ ichlo (Id "unit") }} | nat :: M :: nat {{ ichlo (Id "nat") }} | int :: M :: int {{ ichlo (Id "int") }} @@ -246,23 +237,12 @@ base_effect :: 'BE_' ::= effect :: 'Effect_' ::= {{ com effect set, of kind $[[Effect]]$ }} {{ aux _ l }} - | kid :: :: var | { base_effect1 , .. , base_effectn } :: :: set {{ com effect set }} | pure :: M :: pure {{ com sugar for empty effect set }} {{ lem (Effect_set []) }} {{icho [[{}]] }} | effect1 u+ .. u+ effectn :: M :: union {{ com union of sets of effects }} {{ icho [] }} {{ lem (List.foldr effect_union (Effect_aux (Effect_set []) Unknown) [[effect1..effectn]]) }} -embed -{{ lem -let effect_union e1 e2 = - match (e1,e2) with - | ((Effect_aux (Effect_set els) _),(Effect_aux (Effect_set els2) l)) -> Effect_aux (Effect_set (els++els2)) l - end -}} - -grammar - % TODO: are we going to need any effect polymorphism? Conceivably for built-in maps and folds. Yes. But we think we don't need any interesting effect-set expressions, eg effectset-variable union {rreg}. typ :: 'Typ_' ::= @@ -446,8 +426,11 @@ type_def_aux :: 'TD_' ::= | typedef id name_scm_opt = enumerate { id1 ; ... ; idn semi_opt } :: :: enum {{ com enumeration type definition}} {{ texlong }} - | typedef id = register bits [ nexp : nexp' ] { index_range1 : id1 ; ... ; index_rangen : idn } -:: :: register {{ com register mutable bitfield type definition }} {{ texlong }} + | bitfield id : typ = { id1 : index_range1 , ... , idn : index_rangen } :: :: bitfield + {{ com register mutable bitfield type definition }} {{ texlong }} + +% | typedef id = register bits [ nexp : nexp' ] { index_range1 : id1 ; ... ; index_rangen : idn } +% :: :: register {{ com register mutable bitfield type definition }} {{ texlong }} % the D(eprecated) forms here should be removed; they add complexity for no purpose. The nexp abbreviation form should have better syntax. @@ -575,7 +558,7 @@ pat :: 'P_' ::= % cf ntoes for this | pat1 : .... : patn :: :: vector_concat - {{ com concatenated vector pattern }} + {{ com concatenated vector pattern }} | ( pat1 , .... , patn ) :: :: tup {{ com tuple pattern }} @@ -596,114 +579,85 @@ parsing P_app <= P_app P_app <= P_as -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% Machinery for typing rules % -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -embed -{{ lem - -let rec remove_one i l = - match l with - | [] -> [] - | i2::l2 -> if i2 = i then l2 else i2::(remove_one i l2) -end - -let rec remove_from l l2 = - match l2 with - | [] -> l - | i::l2' -> remove_from (remove_one i l) l2' -end - -let disjoint s1 s2 = Set.null (s1 inter s2) - -let rec disjoint_all sets = - match sets with - | [] -> true - | s1::[] -> true - | s1::s2::sets -> (disjoint s1 s2) && (disjoint_all (s2::sets)) -end -}} - grammar -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% Interpreter specific things % -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -optx :: '' ::= {{ phantom }} {{ lem maybe string }} {{ ocaml string option }} - | x :: :: optx_x - {{ lem (Just [[x]]) }} {{ ocaml (Some [[x]]) }} - | :: :: optx_none - {{ lem Nothing }} {{ ocaml None }} - -tag :: 'Tag_' ::= -{{ com Data indicating where the identifier arises and thus information necessary in compilation }} - | None :: :: empty - | Intro :: :: intro {{ com Denotes an assignment and lexp that introduces a binding }} - | Set :: :: set {{ com Denotes an expression that mutates a local variable }} - | Tuple :: :: tuple_assign {{ com Denotes an assignment with a tuple lexp }} - | Global :: :: global {{ com Globally let-bound or enumeration based value/variable }} - | Ctor :: :: ctor {{ com Data constructor from a type union }} - | Extern optx :: :: extern {{ com External function, specied only with a val statement }} - | Default :: :: default {{ com Type has come from default declaration, identifier may not be bound locally }} - | Spec :: :: spec - | Enum num :: :: enum - | Alias :: :: alias - | Unknown_path optx :: :: unknown {{ com Tag to distinguish an unknown path from a non-analysis non deterministic path}} - -embed -{{ lem - -type tannot = maybe (typ * tag * list unit * effect * effect) - -}} - -embed -{{ ocaml - -(* Interpreter specific things are just set to unit here *) -type tannot = unit - -type reg_form_set = unit - -}} - -grammar -tannot :: '' ::= - {{ phantom }} - {{ ocaml unit }} - {{ lem tannot }} - -i_direction :: 'I' ::= - | IInc :: :: Inc - | IDec :: :: Dec - -ctor_kind :: 'C_' ::= - | C_Enum nat :: :: Enum - | C_Union :: :: Union - -reg_form :: 'Form_' ::= - | Reg id tannot i_direction :: :: Reg - | SubReg id reg_form index_range :: :: SubReg - -reg_form_set :: '' ::= {{ phantom }} {{ lem set reg_form }} - -alias_spec_tannot :: '' ::= {{ phantom }} {{ lem alias_spec tannot }} {{ ocaml tannot alias_spec }} - -value :: 'V_' ::= {{ com interpreter evaluated value }} - | Boxref nat typ :: :: boxref - | Lit lit :: :: lit - | Tuple ( value1 , ... , valuen ) :: :: tuple - | List ( value1 , ... , valuen ) :: :: list - | Vector nat i_direction ( value1 , ... , valuen ) :: :: vector - | Vector_sparse nat' nat'' i_direction ( nat1 value1 , ... , natn valuen ) value' :: :: vector_sparse - | Record typ ( id1 value1 , ... , idn valuen ) :: :: record - | V_ctor id typ ctor_kind value1 :: :: ctor - | Unknown :: :: unknown - | Register reg_form :: :: register - | Register_alias alias_spec_tannot tannot :: :: register_alias - | Track value reg_form_set :: :: track +% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% % Interpreter specific things % +% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% optx :: '' ::= {{ phantom }} {{ lem maybe string }} {{ ocaml string option }} +% | x :: :: optx_x +% {{ lem (Just [[x]]) }} {{ ocaml (Some [[x]]) }} +% | :: :: optx_none +% {{ lem Nothing }} {{ ocaml None }} + +% tag :: 'Tag_' ::= +% {{ com Data indicating where the identifier arises and thus information necessary in compilation }} +% | None :: :: empty +% | Intro :: :: intro {{ com Denotes an assignment and lexp that introduces a binding }} +% | Set :: :: set {{ com Denotes an expression that mutates a local variable }} +% | Tuple :: :: tuple_assign {{ com Denotes an assignment with a tuple lexp }} +% | Global :: :: global {{ com Globally let-bound or enumeration based value/variable }} +% | Ctor :: :: ctor {{ com Data constructor from a type union }} +% | Extern optx :: :: extern {{ com External function, specied only with a val statement }} +% | Default :: :: default {{ com Type has come from default declaration, identifier may not be bound locally }} +% | Spec :: :: spec +% | Enum num :: :: enum +% | Alias :: :: alias +% | Unknown_path optx :: :: unknown {{ com Tag to distinguish an unknown path from a non-analysis non deterministic path}} + +% embed +% {{ lem + +% type tannot = maybe (typ * tag * list unit * effect * effect) + +% }} + +% embed +% {{ ocaml + +% (* Interpreter specific things are just set to unit here *) +% type tannot = unit + +% type reg_form_set = unit + +% }} + +% grammar +% tannot :: '' ::= +% {{ phantom }} +% {{ ocaml unit }} +% {{ lem tannot }} + +% i_direction :: 'I' ::= +% | IInc :: :: Inc +% | IDec :: :: Dec + +% ctor_kind :: 'C_' ::= +% | C_Enum nat :: :: Enum +% | C_Union :: :: Union + +% reg_form :: 'Form_' ::= +% | Reg id tannot i_direction :: :: Reg +% | SubReg id reg_form index_range :: :: SubReg + +% reg_form_set :: '' ::= {{ phantom }} {{ lem set reg_form }} + +% alias_spec_tannot :: '' ::= {{ phantom }} {{ lem alias_spec tannot }} {{ ocaml tannot alias_spec }} + +% value :: 'V_' ::= {{ com interpreter evaluated value }} +% | Boxref nat typ :: :: boxref +% | Lit lit :: :: lit +% | Tuple ( value1 , ... , valuen ) :: :: tuple +% | List ( value1 , ... , valuen ) :: :: list +% | Vector nat i_direction ( value1 , ... , valuen ) :: :: vector +% | Vector_sparse nat' nat'' i_direction ( nat1 value1 , ... , natn valuen ) value' :: :: vector_sparse +% | Record typ ( id1 value1 , ... , idn valuen ) :: :: record +% | V_ctor id typ ctor_kind value1 :: :: ctor +% | Unknown :: :: unknown +% | Register reg_form :: :: register +% | Register_alias alias_spec_tannot tannot :: :: register_alias +% | Track value reg_form_set :: :: track %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Expressions % @@ -835,6 +789,7 @@ exp :: 'E_' ::= % this can be used to break out of for loops | exit exp :: :: exit {{ com halt all current execution }} + | ref id :: :: ref | throw exp :: :: throw | try exp catch pexp1 .. pexpn :: :: try %, potentially calling a system, trap, or interrupt handler with exp @@ -848,7 +803,7 @@ exp :: 'E_' ::= | annot , annot' :: I :: internal_exp_user {{ com This is like the above but the user has specified an implicit parameter for the current function }} | comment string :: I :: comment {{ com For generated unstructured comments }} | comment exp :: I :: comment_struc {{ com For generated structured comments }} - | let lexp = exp in exp' :: I :: internal_let {{ com This is an internal node for compilation that demonstrates the scope of a local mutable variable }} + | var lexp = exp in exp' :: I :: var {{ com This is an internal node for compilation that demonstrates the scope of a local mutable variable }} | let pat = exp in exp' :: I :: internal_plet {{ com This is an internal node, used to distinguised some introduced lets during processing from original ones }} | return_int ( exp ) :: :: internal_return {{ com For internal use to embed into monad definition }} | value :: I :: internal_value {{ com For internal use in interpreter to wrap pre-evaluated values when returning an action }} @@ -874,6 +829,8 @@ exp :: 'E_' ::= lexp :: 'LEXP_' ::= {{ com lvalue expression }} {{ aux _ annot }} {{ auxparam 'a }} | id :: :: id +% | ref id :: :: ref + | deref exp :: :: deref {{ com identifier }} | id ( exp1 , .. , expn ) :: :: memory {{ com memory or register write via function call }} | id exp :: S :: mem_tup {{ ichlo [[id (exp)]] }} @@ -1040,7 +997,7 @@ val_spec {{ ocaml 'a val_spec }} {{ lem val_spec 'a }} :: 'VS_' ::= val_spec_aux :: 'VS_' ::= {{ com value type specification }} {{ ocaml VS_val_spec of typschm * id * (string -> string option) * bool }} - {{ lem VS_val_spec of typschm * id * maybe string * bool }} + {{ lem VS_val_spec of typschm * id * (string -> maybe string) * bool }} | val typschm id :: S :: val_spec {{ com specify the type of an upcoming definition }} {{ ocaml (VS_val_spec [[typschm]] [[id]] None false) }} {{ lem }} diff --git a/lib/ocaml_rts/Makefile b/lib/ocaml_rts/Makefile index 3d837e25..52b8841b 100644 --- a/lib/ocaml_rts/Makefile +++ b/lib/ocaml_rts/Makefile @@ -50,7 +50,6 @@ all: main import: rsync -rv --include "*/" --include="*.ml" --include="*.mli" --exclude="*" $(BITBUCKET_ROOT)/linksem/src/ linksem - rsync -rv --include "*/" --include="*.ml" --include="*.mli" --exclude="*" $(BITBUCKET_ROOT)/lem/ocaml-lib/ lem main: import ocamlbuild -pkg uint -pkg zarith main.native -use-ocamlfind diff --git a/lib/ocaml_rts/_tags b/lib/ocaml_rts/_tags index 5f2586c5..db11bf77 100644 --- a/lib/ocaml_rts/_tags +++ b/lib/ocaml_rts/_tags @@ -1,6 +1,5 @@ +true: use_lem, debug <main.{byte,native}>: use_nums, use_str, use_unix, debug <linksem>: include <linksem/adaptors>: include -<lem>: include -<lem/dependencies/zarith>: -traverse <linksem/src_lem_library>: -traverse diff --git a/lib/ocaml_rts/sail_lib.ml b/lib/ocaml_rts/sail_lib.ml index dfdd1db9..b24e2fec 100644 --- a/lib/ocaml_rts/sail_lib.ml +++ b/lib/ocaml_rts/sail_lib.ml @@ -87,10 +87,10 @@ let undefined_bit () = let undefined_bool () = if !random then Random.bool () else false -let rec undefined_vector (start_index, len, item) = +let rec undefined_vector (len, item) = if eq_big_int len zero_big_int then [] - else item :: undefined_vector (start_index, sub_big_int len unit_big_int, item) + else item :: undefined_vector (sub_big_int len unit_big_int, item) let undefined_string () = "" diff --git a/power/Makefile b/power/Makefile index 9559646c..f7c49e00 100644 --- a/power/Makefile +++ b/power/Makefile @@ -16,10 +16,6 @@ power.ml: power.lem ../src/lem_interp/interp_ast.lem power_embed.lem: $(SOURCES) # also generates power_embed_sequential.lem, power_embed_types.lem, power_toFromInterp.lem $(SAIL) -lem -lem_lib Power_extras_embed -o power $(SOURCES) - # patch: - rm -f power_embed.lem power_embed_sequential.lem - cp power_embed.lem.fixed power_embed.lem - cp power_embed_sequential.lem.fixed power_embed_sequential.lem clean: rm -f power.lem power.ml diff --git a/power/power.sail b/power/power.sail index 026502b1..6f55a803 100644 --- a/power/power.sail +++ b/power/power.sail @@ -109,7 +109,7 @@ val forall Nat 'n, Nat 'm, 0 <= 'n, 'n <= 'm, 'm <= 63 . function (bit[64]) MASK(start, stop) = { (bit[64]) mask_temp := 0; if(start > stop) then { - mask_temp[start .. 63] := bitone ^^ (64 - start); + mask_temp[start .. 63] := bitone ^^ sub(64, start); mask_temp[0 .. stop] := bitone ^^ (stop + 1); } else { mask_temp[start .. stop ] := bitone ^^ (stop - start + 1); @@ -213,8 +213,12 @@ let (vector <0, 1024, inc, (register<(bit[64])>) >) SPR = vector definition. *) register (vector <0, 64, inc, bit>) DCR0 register (vector <0, 64, inc, bit>) DCR1 -let (vector <0, 1024, inc, (register<(vector<0, 64, inc, bit>)>) >) DCR = - [ 0=DCR0, 1=DCR1 ; default=undefined] +let (vector <0, 1024, inc, (register<(vector<0, 64, inc, bit>)>) >) DCR = { + v = undefined; + v[0] = DCR0; + v[1] = DCR1; + v +} (* Floating-point registers *) @@ -362,7 +366,7 @@ function bit[32] SINGLE ((bit[64]) frs) = { (bit[11]) exp := frs[1..11] - 1023; (bit[53]) frac := 0b1 : frs[12..63]; foreach (i from 0 to 53) { - if exp < (0 - 126) + if exp < sub(0, 126) then { frac[0..52] := 0b0 : frac[0..51]; exp := exp + 1; } else ()}; @@ -1701,7 +1705,7 @@ function clause execute (Lmw (RT, RA, D)) = (bit[64]) EA := 0; if RA == 0 then b := 0 else b := GPR[RA]; EA := b + EXTS(D); - size := ([|32|]) (32 - RT) * 4; + size := ([|32|])(sub(32, RT)) * 4; buffer := MEMr(EA,size); i := 0; foreach (r from RT to 31 by 1 in inc) @@ -1725,9 +1729,9 @@ function clause execute (Stmw (RS, RA, D)) = (bit[64]) EA := 0; if RA == 0 then b := 0 else b := GPR[RA]; EA := b + EXTS(D); - size := ([|32|]) (32 - RS) * 4; + size := ([|32|]) (sub(32, RS)) * 4; MEMw_EA(EA,size); - (bit[994]) buffer := [0 = 0,993 = 0; default=0]; + (bit[994]) buffer := zeros(994); i := 0; foreach (r from RS to 31 by 1 in inc) { @@ -1838,7 +1842,7 @@ function clause execute (Stswi (RS, RA, NB)) = r := RS - 1; ([|32|]) size := if NB == 0 then 32 else NB; MEMw_EA(EA,size); - (bit[256]) membuffer := [0 = 0,255 = 0; default=0]; + (bit[256]) membuffer := zeros(255); j := 0; i := 32; foreach (n from (if NB == 0 then 32 else NB) to 1 by 1 in dec) @@ -1874,7 +1878,7 @@ function clause execute (Stswx (RS, RA, RB)) = ([|128|]) n_top := XER[57 .. 63]; recalculate_dependency(()); MEMw_EA(EA,n_top); - (bit[512]) membuffer := [0 = 0,511 = 0; default=0]; + (bit[512]) membuffer := zeros(512); j := 0; foreach (n from n_top to 1 by 1 in dec) { diff --git a/power/power_embed.lem.fixed b/power/power_embed.lem.fixed deleted file mode 100644 index 52e25bdf..00000000 --- a/power/power_embed.lem.fixed +++ /dev/null @@ -1,6743 +0,0 @@ -(*Generated by Sail from generated/power.sail.*) -open import Pervasives_extra -open import Sail_impl_base -open import Prompt -open import Sail_values -open import Power_embed_types -open import Power_extras_embed -let DEC_TO_BCD (Vector [p;q;r;s;t;u;v;w;x;y] _ _) = - let a = ((~s) &. (v &. w)) |. ((t &. (v &. (w &. s))) |. (v &. (w &. (~x)))) in - let b = (p &. (s &. (x &. (~t)))) |. ((p &. (~w)) |. (p &. (~v))) in - let c = (q &. (s &. (x &. (~t)))) |. ((q &. (~w)) |. (q &. (~v))) in - let d = r in - let e = (v &. ((~w) &. x)) |. ((s &. (v &. (w &. x))) |. ((~t) &. (v &. (x &. w)))) in - let f = (p &. (t &. (v &. (w &. (x &. (~s)))))) |. ((s &. ((~x) &. v)) |. (s &. (~v))) in - let g = (q &. (t &. (w &. (v &. (x &. (~s)))))) |. ((t &. ((~x) &. v)) |. (t &. (~v))) in - let h = u in - let i = (t &. (v &. (w &. x))) |. ((s &. (v &. (w &. x))) |. (v &. ((~w) &. (~x)))) in - let j = - (p &. ((~s) &. ((~t) &. (w &. v)))) |. - ((s &. (v &. ((~w) &. x))) |. ((p &. (w &. ((~x) &. v))) |. (w &. (~v)))) in - let k = - (q &. ((~s) &. ((~t) &. (v &. w)))) |. - ((t &. (v &. ((~w) &. x))) |. ((q &. (v &. (w &. (~x)))) |. (x &. (~v)))) in - let m = y in - Vector [a;b;c;d;e;f;g;h;i;j;k;m] 0 true - -let BCD_TO_DEC (Vector [a;b;c;d;e;f;g;h;i;j;k;m] _ _) = - let p = (f &. (a &. (i &. (~e)))) |. ((j &. (a &. (~i))) |. (b &. (~a))) in - let q = (g &. (a &. (i &. (~e)))) |. ((k &. (a &. (~i))) |. (c &. (~a))) in - let r = d in - let s = - (j &. ((~a) &. (e &. (~i)))) |. ((f &. ((~i) &. (~e))) |. ((f &. ((~a) &. (~e))) |. (e &. i))) in - let t = - (k &. ((~a) &. (e &. (~i)))) |. ((g &. ((~i) &. (~e))) |. ((g &. ((~a) &. (~e))) |. (a &. i))) in - let u = h in - let v = a |. (e |. i) in - let w = ((~e) &. (j &. (~i))) |. ((e &. i) |. a) in - let x = ((~a) &. (k &. (~i))) |. ((a &. i) |. e) in - let y = m in - Vector [p;q;r;s;t;u;v;w;x;y] 0 true - -let carry_out (_, carry) = carry - -let real_addr x = x - -let mark_as_not_likely_to_be_needed_again_anytime_soon x = () - -let EXTS_EXPLICIT (v, m) = (duplicate (access v (0:ii), m - (length (reset_vector_start v)))) ^^ v - -let MASK (start, stop) = - let mask_temp = to_vec_inc ((64:ii),(0:ii)) in - if bitU_to_bool (gt (start, stop)) - then - let mask_temp = update mask_temp start (63:ii) (duplicate (B1, (64:ii) - start)) in - update mask_temp (0:ii) stop (duplicate (B1, stop + (1:ii))) - else update mask_temp start stop (duplicate (B1, (stop - start) + (1:ii))) - -let ROTL (v, n) = (slice v n (63:ii)) ^^ (slice v (0:ii) (n - (1:ii))) - -let DOUBLE word = - let temp = to_vec_inc ((64:ii),(0:ii)) in - if bitU_to_bool - ((gt_vec_range (slice word (1:ii) (8:ii), (0:ii))) &. - (lt_vec_range (slice word (1:ii) (8:ii), (255:ii)))) - then - let temp = update temp (0:ii) (1:ii) (slice word (0:ii) (1:ii)) in - let temp = update_pos temp (2:ii) (~(access word (1:ii))) in - let temp = update_pos temp (3:ii) (~(access word (1:ii))) in - let temp = update_pos temp (4:ii) (~(access word (1:ii))) in - update - temp (5:ii) (63:ii) - (set_vector_start 5 - ((slice word (2:ii) (31:ii)) ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0] 0 true))) - else - if bitU_to_bool - ((eq_vec_range (slice word (1:ii) (8:ii), (0:ii))) &. - (neq_vec_range (slice word (9:ii) (31:ii), (0:ii)))) - then - let sign = access word (0:ii) in - let exp = (0:ii) - (126:ii) in - let frac = - (Vector [B0] 0 true) ^^ - ((slice word (9:ii) (31:ii)) ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0] 0 true)) in - let (exp, frac) = - (foreach_inc ((0:ii),(52:ii),(1:ii)) (exp,frac) - (fun i (exp,frac) -> - let (frac, exp) = - if bitU_to_bool - (eq (match (access frac (0:ii)) with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - let frac = - update frac (0:ii) (52:ii) ((slice frac (1:ii) (52:ii)) ^^ (Vector [B0] 0 true)) in - let exp = exp - (1:ii) in - (frac,exp) - else (frac,exp) in - (exp,frac))) in - let temp = update_pos temp (0:ii) sign in - let temp = - update - temp (1:ii) (11:ii) - (add_VIV (reset_vector_start (to_vec_inc ((11:ii),exp))) (1023:ii)) in - update temp (12:ii) (63:ii) (set_vector_start 12 (slice frac (1:ii) (52:ii))) - else - let temp = update temp (0:ii) (1:ii) (slice word (0:ii) (1:ii)) in - let temp = update_pos temp (2:ii) (access word (1:ii)) in - let temp = update_pos temp (3:ii) (access word (1:ii)) in - let temp = update_pos temp (4:ii) (access word (1:ii)) in - update - temp (5:ii) (63:ii) - (set_vector_start 5 - ((slice word (2:ii) (31:ii)) ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0] 0 true))) - -let SINGLE frs = - let word = to_vec_inc ((32:ii),(0:ii)) in - if bitU_to_bool - ((gt_vec_range (slice frs (1:ii) (11:ii), (896:ii))) |. - (eq_vec_range (slice frs (1:ii) (63:ii), (0:ii)))) - then - let word = update word (0:ii) (1:ii) (slice frs (0:ii) (1:ii)) in - update word (2:ii) (31:ii) (set_vector_start 2 (slice frs (5:ii) (34:ii))) - else - if bitU_to_bool - ((lteq_range_vec ((874:ii), slice frs (1:ii) (11:ii))) &. - (lteq_vec_range (slice frs (1:ii) (11:ii), (896:ii)))) - then - let sign = access frs (0:ii) in - let exp = - set_vector_start 0 (minus_VIV (reset_vector_start (slice frs (1:ii) (11:ii))) (1023:ii)) in - let frac = (Vector [B1] 0 true) ^^ (slice frs (12:ii) (63:ii)) in - let (exp, frac) = - (foreach_inc ((0:ii),(53:ii),(1:ii)) (exp,frac) - (fun i (exp,frac) -> - let (frac, exp) = - if bitU_to_bool (lt_vec_range (exp, (0:ii) - (126:ii))) - then - let frac = - update frac (0:ii) (52:ii) ((Vector [B0] 0 true) ^^ (slice frac (0:ii) (51:ii))) in - let exp = set_vector_start 0 (add_VIV (reset_vector_start exp) (1:ii)) in - (frac,exp) - else (frac,exp) in - (exp,frac))) in - word - else to_vec_inc_undef (32:ii) - -let Chop (x, y) = slice x (0:ii) y - -let byte_reverse (m', input) = - let output = to_vec_inc (length input,(0:ii)) in - let j = length (reset_vector_start input) in - let (j, output) = - (foreach_inc ((0:ii),length (reset_vector_start input),(8:ii)) (j,output) - (fun i (j,output) -> - let output = update output i (i + (7:ii)) (slice input (j - (7:ii)) j) in - let j = j - (8:ii) in - (j,output))) in - output - -let rec reverse_endianness value = - let width = length (reset_vector_start value) in - let half = quot width (2:ii) in - if bitU_to_bool (eq_range (width, (8:ii))) - then value - else - (reverse_endianness - (reset_vector_start (set_vector_start 0 (slice value half (width - (1:ii)))))) ^^ - (reverse_endianness (reset_vector_start (slice value (0:ii) (half - (1:ii))))) - -let zero_or_undef x = - let out = to_vec_inc (length x,(0:ii)) in - (foreach_inc ((0:ii),(length (reset_vector_start x)) - (1:ii),(1:ii)) out - (fun i out -> update_pos out i (if bitU_to_bool (access x i) then BU else B0))) - -let GPRs = - Vector ["GPR0";"GPR1";"GPR2";"GPR3";"GPR4";"GPR5";"GPR6";"GPR7";"GPR8";"GPR9";"GPR10";"GPR11";"GPR12";"GPR13";"GPR14";"GPR15";"GPR16";"GPR17";"GPR18";"GPR19";"GPR20"; - "GPR21";"GPR22";"GPR23";"GPR24";"GPR25";"GPR26";"GPR27";"GPR28";"GPR29";"GPR30";"GPR31"] 0 true - -let SPRs = - make_indexed_vector - [(1,"XER");(8,"LR");(9,"CTR");(259,"SPRG3");(260,"SPRG4");(261,"SPRG5"); - (262,"SPRG6");(263,"SPRG7")] - "" 0 1024 true - -let DCRs = make_indexed_vector [(0,"DCR0");(1,"DCR1")] "" 0 1024 true - -let length_spr i = - match toNatural i with - | (1:nn) -> (64:ii) - | (8:nn) -> (64:ii) - | (9:nn) -> (64:ii) - | (259:nn) -> (64:ii) - | (260:nn) -> (64:ii) - | (261:nn) -> (64:ii) - | (262:nn) -> (64:ii) - | (263:nn) -> (64:ii) - end - -let DCR = make_indexed_vector [(0,DCR0);(1,DCR1)] (UndefinedRegister 64) 0 1024 true - -let Clamp (k', x, y, z) = - let result = (0:ii) in - (if bitU_to_bool (lt (x, y)) - then - let result = y in - write_reg_bitfield VSCR "SAT" B1 >> - return result - else - if bitU_to_bool (gt (x, z)) - then - let result = z in - write_reg_bitfield VSCR "SAT" B1 >> - return result - else return x) >>= fun result -> - return (to_vec_inc (k',result)) - -let MEMw (ea, size, value) = - read_reg bigendianmode >>= fun w__0 -> - if bitU_to_bool (most_significant w__0) - then - MEMw' - (reset_vector_start ea, - size, - reset_vector_start (reverse_endianness (reset_vector_start value))) - else MEMw' (reset_vector_start ea,size,reset_vector_start value) - -let MEMr (ea, size) = - read_reg bigendianmode >>= fun w__0 -> - if bitU_to_bool (most_significant w__0) - then - MEMr' (reset_vector_start ea,size) >>= fun w__1 -> - return (reverse_endianness (reset_vector_start w__1)) - else MEMr' (reset_vector_start ea,size) - -let MEMr_reserve (ea, size) = - read_reg bigendianmode >>= fun w__0 -> - if bitU_to_bool (most_significant w__0) - then - MEMr_reserve' (reset_vector_start ea,size) >>= fun w__1 -> - return (reverse_endianness (reset_vector_start w__1)) - else MEMr_reserve' (reset_vector_start ea,size) - -let MEMw_conditional (ea, size, value) = - read_reg bigendianmode >>= fun w__0 -> - if bitU_to_bool (most_significant w__0) - then - MEMw_conditional' - (reset_vector_start ea, - size, - reset_vector_start (reverse_endianness (reset_vector_start value))) - else MEMw_conditional' (reset_vector_start ea,size,reset_vector_start value) - -let set_SO_OV overflow = - write_reg_bitfield XER "OV" overflow >> - read_reg_bitfield XER "SO" >>= fun w__0 -> - write_reg_bitfield XER "SO" (w__0 |. overflow) - -let supported_instructions instr = - match instr with - | Sync ((Vector [B1;B0] _ _)) -> Nothing - | Sync ((Vector [B1;B1] _ _)) -> Nothing - | _ -> Just instr - end - -let CIA_fp = RFull "CIA" - -let NIA_fp = RFull "NIA" - -let mode64bit_fp = RFull "mode64bit" - -let bigendianmode_fp = RFull "bigendianmode" - -let set_overflow_cr0 (target_register, new_xer_so) = - let m = (0:ii) in - let c = to_vec_inc ((3:ii),(0:ii)) in - let zero = to_vec_inc ((64:ii),(0:ii)) in - read_reg mode64bit >>= fun w__0 -> - let m = if bitU_to_bool (most_significant w__0) then (0:ii) else (32:ii) in - let c = - if bitU_to_bool (lt_vec_signed (slice target_register m (63:ii), slice zero m (63:ii))) - then Vector [B1;B0;B0] 0 true - else - if bitU_to_bool (gt_vec_signed (slice target_register m (63:ii), slice zero m (63:ii))) - then Vector [B0;B1;B0] 0 true - else Vector [B0;B0;B1] 0 true in - write_reg_field CR "CR0" (set_vector_start 32 (c ^^ (Vector [new_xer_so] 0 true))) - -let SPR = - make_indexed_vector - [(1,XER);(8,LR);(9,CTR);(259,SPRG3);(260,SPRG4);(261,SPRG5); - (262,SPRG6);(263,SPRG7)] - (UndefinedRegister 64) 0 1024 true - -let FPRp = - make_indexed_vector - [(0,RegisterPair FPR0 FPR1);(2,RegisterPair FPR2 FPR3);(4,RegisterPair FPR4 FPR5);(6,RegisterPair FPR6 FPR7);(8,RegisterPair FPR8 FPR9);(10,RegisterPair FPR10 FPR11); - (12,RegisterPair FPR12 FPR13);(14,RegisterPair FPR14 FPR15);(16,RegisterPair FPR16 FPR17);(18,RegisterPair FPR18 FPR19);(20,RegisterPair FPR20 FPR21);(22,RegisterPair FPR22 FPR23); - (24,RegisterPair FPR24 FPR25);(26,RegisterPair FPR26 FPR27);(28,RegisterPair FPR28 FPR29);(30,RegisterPair FPR30 FPR31)] - (UndefinedRegister 128) 0 32 true - -let illegal_instructions_pred instr = - match instr with - | Bcctr (BO,BI,BH,LK) -> ~(access BO (2:ii)) - | Lbzu (RT,RA,D) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lbzux (RT,RA,_) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lhzu (RT,RA,D) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lhzux (RT,RA,RB) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lhau (RT,RA,D) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lhaux (RT,RA,RB) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lwzu (RA,RT,D) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lwzux (RT,RA,RB) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lwaux (RA,RT,RB) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Ldu (RT,RA,DS) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Ldux (RT,RA,RB) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Stbu (RS,RA,D) -> eq_vec_range (RA, (0:ii)) - | Stbux (RS,RA,RB) -> eq_vec_range (RA, (0:ii)) - | Sthu (RS,RA,RB) -> eq_vec_range (RA, (0:ii)) - | Sthux (RS,RA,RB) -> eq_vec_range (RA, (0:ii)) - | Stwu (RS,RA,D) -> eq_vec_range (RA, (0:ii)) - | Stwux (RS,RA,RB) -> eq_vec_range (RA, (0:ii)) - | Stdu (RS,RA,DS) -> eq_vec_range (RA, (0:ii)) - | Stdux (RS,RA,RB) -> eq_vec_range (RA, (0:ii)) - | Lmw (RT,RA,D) -> - (eq_vec_range (RA, (0:ii))) |. ((lteq_vec (RT, RA)) &. (lteq_vec_range (RA, (31:ii)))) - | Lswi (RT,RA,NB) -> - let n = - if bitU_to_bool (~(eq_vec_range (NB, (0:ii)))) - then unsigned (reset_vector_start NB) - else (32:ii) in - let ceil = - if bitU_to_bool (eq_range (modulo n (4:ii), (0:ii))) - then quot n (4:ii) - else (quot n (4:ii)) + (1:ii) in - (lteq_vec (RT, RA)) &. - (lteq_vec - (RA, - minus_VIV - (reset_vector_start (set_vector_start 0 (add_VIV (reset_vector_start RT) ceil))) - (1:ii))) - | Lq (RTp,RA,DQ,Pt) -> - (eq_vec_range (minus_VIV (reset_vector_start RTp) (2:ii), (1:ii))) |. (eq_vec (RTp, RA)) - | Stq (RSp,RA,RS) -> eq_vec_range (minus_VIV (reset_vector_start RSp) (2:ii), (1:ii)) - | Mtspr (RS,spr) -> - ~((eq_vec_range (spr, (1:ii))) |. - ((eq_vec_range (spr, (8:ii))) |. - ((eq_vec_range (spr, (9:ii))) |. - ((eq_vec_range (spr, (256:ii))) |. - ((eq_vec_range (spr, (512:ii))) |. - ((eq_vec_range (spr, (896:ii))) |. (eq_vec_range (spr, (898:ii))))))))) - | _ -> B0 - end - -let GPR = - Vector [GPR0;GPR1;GPR2;GPR3;GPR4;GPR5;GPR6;GPR7;GPR8;GPR9;GPR10;GPR11;GPR12;GPR13;GPR14;GPR15;GPR16;GPR17;GPR18;GPR19;GPR20; - GPR21;GPR22;GPR23;GPR24;GPR25;GPR26;GPR27;GPR28;GPR29;GPR30;GPR31] 0 true - -let FPR = - Vector [FPR0;FPR1;FPR2;FPR3;FPR4;FPR5;FPR6;FPR7;FPR8;FPR9;FPR10;FPR11;FPR12;FPR13;FPR14;FPR15;FPR16;FPR17;FPR18;FPR19;FPR20; - FPR21;FPR22;FPR23;FPR24;FPR25;FPR26;FPR27;FPR28;FPR29;FPR30;FPR31] 0 true - -let VR = - Vector [VR0;VR1;VR2;VR3;VR4;VR5;VR6;VR7;VR8;VR9;VR10;VR11;VR12;VR13;VR14;VR15;VR16;VR17;VR18;VR19;VR20; - VR21;VR22;VR23;VR24;VR25;VR26;VR27;VR28;VR29;VR30;VR31] 0 true - -let decode = function - | ((Vector [B0;B1;B0;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;AA;LK] _ _) as instr) -> - let LI = slice_raw instr (6:ii) (29:ii) in - Just (B (reset_vector_start LI,AA,LK)) - | ((Vector [B0;B1;B0;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;AA;LK] _ _) as instr) -> - let BO = slice_raw instr (6:ii) (10:ii) in - let BI = slice_raw instr (11:ii) (15:ii) in - let BD = slice_raw instr (16:ii) (29:ii) in - Just (Bc (reset_vector_start BO,reset_vector_start BI,reset_vector_start BD,AA,LK)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B0;B0;B0;LK] _ _) as instr) -> - let BO = slice_raw instr (6:ii) (10:ii) in - let BI = slice_raw instr (11:ii) (15:ii) in - let BH = slice_raw instr (19:ii) (20:ii) in - Just (Bclr (reset_vector_start BO,reset_vector_start BI,reset_vector_start BH,LK)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B0;B0;B0;B0;LK] _ _) as instr) -> - let BO = slice_raw instr (6:ii) (10:ii) in - let BI = slice_raw instr (11:ii) (15:ii) in - let BH = slice_raw instr (19:ii) (20:ii) in - Just (Bcctr (reset_vector_start BO,reset_vector_start BI,reset_vector_start BH,LK)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B0;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crand (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B1;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crnand (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B0;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Cror (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B0;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crxor (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crnor (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B1;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Creqv (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crandc (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B1;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crorc (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - let BFA = slice_raw instr (11:ii) (13:ii) in - Just (Mcrf (reset_vector_start BF,reset_vector_start BFA)) - | ((Vector [B0;B1;B0;B0;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;_] _ _) as instr) -> - let LEV = slice_raw instr (20:ii) (26:ii) in - Just (Sc (reset_vector_start LEV)) - | ((Vector [B0;B1;B0;B0;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1] _ _) as instr) -> - let LEV = slice_raw instr (20:ii) (26:ii) in - Just (Scv (reset_vector_start LEV)) - | ((Vector [B1;B0;B0;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lbz (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lbzx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lbzu (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lbzux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lhz (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lhzx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B0;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lhzu (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lhzux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lha (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lhax (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lhau (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lhaux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lwz (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwzx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B0;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lwzu (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwzux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Lwa (reset_vector_start RT,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwax (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B1;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwaux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Ld (reset_vector_start RT,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Ldx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Ldu (reset_vector_start RT,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Ldux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Stb (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stbx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Stbu (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stbux (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Sth (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sthx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B1;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Sthu (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sthux (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Stw (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stwx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B1;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Stwu (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stwux (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Std (reset_vector_start RS,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stdx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Stdu (reset_vector_start RS,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B1;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stdux (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RTp = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DQ = slice_raw instr (16:ii) (27:ii) in - let PT = slice_raw instr (28:ii) (31:ii) in - Just (Lq (reset_vector_start RTp,reset_vector_start RA,reset_vector_start DQ,reset_vector_start PT)) - | ((Vector [B1;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0] _ _) as instr) -> - let RSp = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Stq (reset_vector_start RSp,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lhbrx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sthbrx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwbrx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stwbrx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B0;B1;B0;B0;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Ldbrx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B0;B0;B1;B0;B1;B0;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stdbrx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lmw (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B1;B0;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Stmw (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B1;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let NB = slice_raw instr (16:ii) (20:ii) in - Just (Lswi (reset_vector_start RT,reset_vector_start RA,reset_vector_start NB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lswx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B1;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let NB = slice_raw instr (16:ii) (20:ii) in - Just (Stswi (reset_vector_start RS,reset_vector_start RA,reset_vector_start NB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B0;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stswx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B0;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Addi (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B0;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Addis (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B0;B0;B0;B0;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Add (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Subf (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B1;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Addic (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B0;B1;B1;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (AddicDot (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B0;B1;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Subfic (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B0;B0;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Addc (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Subfc (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B0;B0;B0;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Adde (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B0;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Subfe (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Addme (reset_vector_start RT,reset_vector_start RA,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Subfme (reset_vector_start RT,reset_vector_start RA,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B0;B0;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Addze (reset_vector_start RT,reset_vector_start RA,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Subfze (reset_vector_start RT,reset_vector_start RA,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B1;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Neg (reset_vector_start RT,reset_vector_start RA,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Mulli (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mullw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B1;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B0;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B1;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divwe (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B0;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divweu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulld (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhd (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhdu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B1;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divd (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B0;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divdu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B1;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divde (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B0;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divdeu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B1;B0;B1;B1;_;_;_;_;L;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Cmpi (reset_vector_start BF,L,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;L;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Cmp (reset_vector_start BF,L,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B0;B1;B0;B1;B0;_;_;_;_;L;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Cmpli (reset_vector_start BF,L,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;L;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B0;B0;B0;B0;B0;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Cmpl (reset_vector_start BF,L,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - let BC = slice_raw instr (21:ii) (25:ii) in - Just (Isel (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,reset_vector_start BC)) - | ((Vector [B0;B1;B1;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Andi (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B1;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Andis (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Ori (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B0;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Oris (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Xori (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Xoris (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (And (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B1;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Xor (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B0;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nand (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B1;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Or (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B1;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nor (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B0;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Eqv (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Andc (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B0;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Orc (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B0;B1;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Extsb (reset_vector_start RS,reset_vector_start RA,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B0;B0;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Extsh (reset_vector_start RS,reset_vector_start RA,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Cntlzw (reset_vector_start RS,reset_vector_start RA,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B1;B1;B1;B1;B0;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Cmpb (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B1;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Popcntb (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B1;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Popcntw (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B1;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Prtyd (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Prtyw (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B1;B0;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Extsw (reset_vector_start RS,reset_vector_start RA,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Cntlzd (reset_vector_start RS,reset_vector_start RA,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B1;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Popcntd (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B1;B1;B1;B1;B0;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Bpermd (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B0;B1;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SH = slice_raw instr (16:ii) (20:ii) in - let MB = slice_raw instr (21:ii) (25:ii) in - let ME = slice_raw instr (26:ii) (30:ii) in - Just (Rlwinm (reset_vector_start RS,reset_vector_start RA,reset_vector_start SH,reset_vector_start MB,reset_vector_start ME,Rc)) - | ((Vector [B0;B1;B0;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - let MB = slice_raw instr (21:ii) (25:ii) in - let ME = slice_raw instr (26:ii) (30:ii) in - Just (Rlwnm (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,reset_vector_start MB,reset_vector_start ME,Rc)) - | ((Vector [B0;B1;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SH = slice_raw instr (16:ii) (20:ii) in - let MB = slice_raw instr (21:ii) (25:ii) in - let ME = slice_raw instr (26:ii) (30:ii) in - Just (Rlwimi (reset_vector_start RS,reset_vector_start RA,reset_vector_start SH,reset_vector_start MB,reset_vector_start ME,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let mb = slice_raw instr (21:ii) (26:ii) in - Just (Rldicl (reset_vector_start RS,reset_vector_start RA,reset_vector_start ((slice instr - (16:ii) - (20:ii)) ^^ - (slice instr - (30:ii) - (30:ii))),reset_vector_start mb,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let me = slice_raw instr (21:ii) (26:ii) in - Just (Rldicr (reset_vector_start RS,reset_vector_start RA,reset_vector_start ((slice instr - (16:ii) - (20:ii)) ^^ - (slice instr - (30:ii) - (30:ii))),reset_vector_start me,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let mb = slice_raw instr (21:ii) (26:ii) in - Just (Rldic (reset_vector_start RS,reset_vector_start RA,reset_vector_start ((slice instr - (16:ii) (20:ii)) ^^ - (slice instr - (30:ii) (30:ii))),reset_vector_start mb,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - let mb = slice_raw instr (21:ii) (26:ii) in - Just (Rldcl (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,reset_vector_start mb,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - let me = slice_raw instr (21:ii) (26:ii) in - Just (Rldcr (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,reset_vector_start me,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let mb = slice_raw instr (21:ii) (26:ii) in - Just (Rldimi (reset_vector_start RS,reset_vector_start RA,reset_vector_start ((slice instr - (16:ii) - (20:ii)) ^^ - (slice instr - (30:ii) - (30:ii))),reset_vector_start mb,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Slw (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Srw (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B0;B1;B1;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SH = slice_raw instr (16:ii) (20:ii) in - Just (Srawi (reset_vector_start RS,reset_vector_start RA,reset_vector_start SH,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B0;B0;B1;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sraw (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sld (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Srd (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B0;B1;B1;B1;B0;B1;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Sradi (reset_vector_start RS,reset_vector_start RA,reset_vector_start ((slice instr - (16:ii) (20:ii)) ^^ - (slice instr - (30:ii) (30:ii))),Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B0;B0;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Srad (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B0;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Cdtbcd (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B1;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Cbcdtd (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B0;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Addg6s (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B0;B1;B0;B0;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let spr = slice_raw instr (11:ii) (20:ii) in - Just (Mtspr (reset_vector_start RS,reset_vector_start spr)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B0;B1;B0;B0;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let spr = slice_raw instr (11:ii) (20:ii) in - Just (Mfspr (reset_vector_start RT,reset_vector_start spr)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;B0;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B0;B0;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let FXM = slice_raw instr (12:ii) (19:ii) in - Just (Mtcrf (reset_vector_start RS,reset_vector_start FXM)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;B0;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B0;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - Just (Mfcr (reset_vector_start RT)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;B1;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B0;B0;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let FXM = slice_raw instr (12:ii) (19:ii) in - Just (Mtocrf (reset_vector_start RS,reset_vector_start FXM)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;B1;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B0;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let FXM = slice_raw instr (12:ii) (19:ii) in - Just (Mfocrf (reset_vector_start RT,reset_vector_start FXM)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B0;B0;B0;B0;B0;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - Just (Mcrxr (reset_vector_start BF)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B0;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dlmzb (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B0;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Macchw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Macchws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B0;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Macchwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Macchwsu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Machhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B1;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Machhws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Machhwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B1;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Machhwsu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Maclhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Maclhws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Maclhwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Maclhwsu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulchw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulchwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhhwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mullhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mullhwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B0;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmacchw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmacchws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmachhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B1;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmachhws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmaclhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmaclhws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B1;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Icbi (reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let CT = slice_raw instr (7:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Icbt (reset_vector_start CT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B1;B1;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcba (reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let TH = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcbt (reset_vector_start TH,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B1;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let TH = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcbtst (reset_vector_start TH,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B1;B1;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcbz (reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcbst (reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let L = slice_raw instr (9:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcbf (reset_vector_start L,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - Just (Isync) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B0;B1;B0;B0;EH] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lbarx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,EH)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B1;B1;B0;B1;B0;B0;EH] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lharx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,EH)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B1;B0;B0;EH] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwarx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,EH)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B0;B1;B1;B0;B1;B1;B0;B1] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stbcx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B1;B0;B1;B0;B1;B1;B0;B1] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sthcx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B1;B0;B1] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stwcx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B0;B1;B0;B1;B0;B0;EH] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Ldarx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,EH)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B0;B1;B0;B1;B1;B0;B1] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stdcx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B1;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let L = slice_raw instr (9:ii) (10:ii) in - Just (Sync (reset_vector_start L)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B1;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - Just (Eieio) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B1;B1;B1;B0;_] _ _) as instr) -> - let WC = slice_raw instr (9:ii) (10:ii) in - Just (Wait (reset_vector_start WC)) - | _ -> Nothing - end - -let illegal_instructions instr = - if bitU_to_bool (illegal_instructions_pred instr) - then Nothing - else Just instr - -let recalculate_lswx_reg_footprint instr = - let iR = [] in - let oR = [] in - let Nias = [NIAFP_successor] in - let Dia = DIAFP_none in - let ik = IK_mem_read Read_plain in - let (RT, RA, RB) = match instr with | Lswx (RT,RA,RB) -> (RT,RA,RB) end in - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let r = (0:ii) in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: - (RSlice ("XER",(57:ii),(63:ii))) :: iR in - let aR = iR in - let r = minus_VII (reset_vector_start RT) (1:ii) in - let i = (32:ii) in - read_reg_range XER (57:ii) (63:ii) >>= fun w__0 -> - let n_top = unsigned (reset_vector_start w__0) in - let (r, oR) = - if bitU_to_bool (eq_range (n_top, (0:ii))) - then - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - (r,oR) - else - let j = (0:ii) in - let n_r = quot n_top (4:ii) in - let n_mod = modulo n_top (4:ii) in - let n_r = if bitU_to_bool (eq_range (n_mod, (0:ii))) then n_r else n_r + (1:ii) in - let (oR, j, r) = - (foreach_dec (n_r,(1:ii),(1:ii)) (oR,j,r) - (fun n (oR,j,r) -> - let r = modulo (r + (1:ii)) (32:ii) in - let j = j + (32:ii) in - let oR = (RFull (access GPRs r)) :: oR in - (oR,j,r))) in - (r,oR) in - return (iR,oR,aR,Nias,Dia,ik) - -let recalculate_stswx_reg_footprint instr = - let iR = [] in - let oR = [] in - let Nias = [NIAFP_successor] in - let Dia = DIAFP_none in - let ik = IK_mem_write Write_plain in - let (RS, RA, RB) = match instr with | Stswx (RS,RA,RB) -> (RS,RA,RB) end in - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let r = (0:ii) in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: - (RSlice ("XER",(57:ii),(63:ii))) :: iR in - let aR = iR in - let r = minus_VII (reset_vector_start RS) (1:ii) in - let i = (32:ii) in - read_reg_range XER (57:ii) (63:ii) >>= fun w__0 -> - let n_top = unsigned (reset_vector_start w__0) in - let j = (0:ii) in - let (j, i, iR, r) = - (foreach_dec (n_top,(1:ii),(1:ii)) (j,i,iR,r) - (fun n (j,i,iR,r) -> - let r = if bitU_to_bool (eq_range (i, (32:ii))) then modulo (r + (1:ii)) (32:ii) else r in - let iR = (RSlice (access GPRs r,i,i + (7:ii))) :: iR in - let i = i + (8:ii) in - let j = j + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - (j,i,iR,r))) in - let ik = IK_mem_write Write_plain in - return (iR,oR,aR,Nias,Dia,ik) - - - -let execute_B (LI, AA, LK) = - (if bitU_to_bool AA - then - write_reg - NIA - (set_vector_start 0 (exts ((64:ii),reset_vector_start (LI ^^ (Vector [B0;B0] 0 true))))) - else - read_reg CIA >>= fun w__0 -> - write_reg - NIA - (set_vector_start 0 - (add_VVV - w__0 - (reset_vector_start (exts ((64:ii),reset_vector_start (LI ^^ (Vector [B0;B0] 0 true)))))))) >> - if bitU_to_bool LK - then - read_reg CIA >>= fun w__1 -> - write_reg LR (set_vector_start 0 (add_VIV w__1 (4:ii))) - else return () - -let execute_Bc (BO, BI, BD, AA, LK) = - let M = (0:ii) in - read_reg mode64bit >>= fun w__0 -> - let M = if bitU_to_bool (most_significant w__0) then (0:ii) else (32:ii) in - read_reg CTR >>= fun ctr_temp -> - (if bitU_to_bool (~(access BO (2:ii))) - then - let ctr_temp = set_vector_start 0 (minus_VIV (reset_vector_start ctr_temp) (1:ii)) in - write_reg CTR ctr_temp >> - return ctr_temp - else return ctr_temp) >>= fun ctr_temp -> - let ctr_ok = - (access BO (2:ii)) |. - ((~(eq_vec_range (slice ctr_temp M (63:ii), (0:ii)))) +. (access BO (3:ii))) in - read_reg_bit CR (add_VII (reset_vector_start BI) (32:ii)) >>= fun w__1 -> - let cond_ok = (access BO (0:ii)) |. (w__1 +. (~(access BO (1:ii)))) in - (if bitU_to_bool (ctr_ok &. cond_ok) - then - if bitU_to_bool AA - then - write_reg - NIA - (set_vector_start 0 (exts ((64:ii),reset_vector_start (BD ^^ (Vector [B0;B0] 0 true))))) - else - read_reg CIA >>= fun w__2 -> - write_reg - NIA - (set_vector_start 0 - (add_VVV - w__2 - (reset_vector_start (exts ((64:ii),reset_vector_start (BD ^^ (Vector [B0;B0] 0 true))))))) - else return ()) >> - if bitU_to_bool LK - then - read_reg CIA >>= fun w__3 -> - write_reg LR (set_vector_start 0 (add_VIV w__3 (4:ii))) - else return () - -let execute_Bclr (BO, BI, BH, LK) = - let M = (0:ii) in - read_reg mode64bit >>= fun w__0 -> - let M = if bitU_to_bool (most_significant w__0) then (0:ii) else (32:ii) in - read_reg CTR >>= fun ctr_temp -> - (if bitU_to_bool (~(access BO (2:ii))) - then - let ctr_temp = set_vector_start 0 (minus_VIV (reset_vector_start ctr_temp) (1:ii)) in - write_reg CTR ctr_temp >> - return ctr_temp - else return ctr_temp) >>= fun ctr_temp -> - let ctr_ok = - (access BO (2:ii)) |. - ((~(eq_vec_range (slice ctr_temp M (63:ii), (0:ii)))) +. (access BO (3:ii))) in - read_reg_bit CR (add_VII (reset_vector_start BI) (32:ii)) >>= fun w__1 -> - let cond_ok = (access BO (0:ii)) |. (w__1 +. (~(access BO (1:ii)))) in - (if bitU_to_bool (ctr_ok &. cond_ok) - then - read_reg_range LR (0:ii) (61:ii) >>= fun w__2 -> - write_reg NIA (w__2 ^^ (Vector [B0;B0] 0 true)) - else return ()) >> - if bitU_to_bool LK - then - read_reg CIA >>= fun w__3 -> - write_reg LR (set_vector_start 0 (add_VIV w__3 (4:ii))) - else return () - -let execute_Bcctr (BO, BI, BH, LK) = - read_reg_bit CR (add_VII (reset_vector_start BI) (32:ii)) >>= fun w__0 -> - let cond_ok = (access BO (0:ii)) |. (w__0 +. (~(access BO (1:ii)))) in - (if bitU_to_bool cond_ok - then - read_reg_range CTR (0:ii) (61:ii) >>= fun w__1 -> - write_reg NIA (w__1 ^^ (Vector [B0;B0] 0 true)) - else return ()) >> - if bitU_to_bool LK - then - read_reg CIA >>= fun w__2 -> - write_reg LR (set_vector_start 0 (add_VIV w__2 (4:ii))) - else return () - -let execute_Crand (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 &. w__1) - -let execute_Crnand (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (~(w__0 &. w__1)) - -let execute_Cror (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 |. w__1) - -let execute_Crxor (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 +. w__1) - -let execute_Crnor (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (~(w__0 |. w__1)) - -let execute_Creqv (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 +. (~w__1)) - -let execute_Crandc (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 &. (~w__1)) - -let execute_Crorc (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 |. (~w__1)) - -let execute_Mcrf (BF, BFA) = - read_reg_range CR - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BFA))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BFA))) (35:ii)) >>= fun w__0 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - w__0 - -let execute_Sc LEV = return () - -let execute_Scv LEV = return () - -let execute_Lbz (RT, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMr (reset_vector_start EA,(1:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lbzx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(1:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lbzu (RT, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(1:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lbzux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(1:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lhz (RT, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lhzx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lhzu (RT, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lhzux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lha (RT, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__1))) - -let execute_Lhax (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__2))) - -let execute_Lhau (RT, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__1))) - -let execute_Lhaux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__2))) - -let execute_Lwz (RT, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lwzx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lwzu (RT, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lwzux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lwa (RT, RA, DS) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV - (reset_vector_start b) - (reset_vector_start (exts ((64:ii),reset_vector_start (DS ^^ (Vector [B0;B0] 0 true)))))) in - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__1))) - -let execute_Lwax (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__2))) - -let execute_Lwaux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__2))) - -let execute_Ld (RT, RA, DS) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV - (reset_vector_start b) - (reset_vector_start (exts ((64:ii),reset_vector_start (DS ^^ (Vector [B0;B0] 0 true)))))) in - MEMr (reset_vector_start EA,(8:ii)) >>= fun w__1 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__1 - -let execute_Ldx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(8:ii)) >>= fun w__2 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__2 - -let execute_Ldu (RT, RA, DS) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start (DS ^^ (Vector [B0;B0] 0 true)))))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(8:ii)) >>= fun w__1 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__1 - -let execute_Ldux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(8:ii)) >>= fun w__2 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__2 - -let execute_Stb (RS, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(1:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(1:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Stbx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(1:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(1:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Stbu (RS, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(1:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(1:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Stbux (RS, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(1:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(1:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Sth (RS, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(2:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(2:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Sthx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(2:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(2:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Sthu (RS, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(2:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(2:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Sthux (RS, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(2:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(2:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Stw (RS, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(4:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(4:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Stwx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(4:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(4:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Stwu (RS, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(4:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(4:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Stwux (RS, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(4:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(4:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Std (RS, RA, DS) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV - (reset_vector_start b) - (reset_vector_start (exts ((64:ii),reset_vector_start (DS ^^ (Vector [B0;B0] 0 true)))))) in - MEMw_EA (reset_vector_start EA,(8:ii)) >> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__1 -> - MEMw (reset_vector_start EA,(8:ii),reset_vector_start w__1) - -let execute_Stdx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(8:ii)) >> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__2 -> - MEMw (reset_vector_start EA,(8:ii),reset_vector_start w__2) - -let execute_Stdu (RS, RA, DS) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start (DS ^^ (Vector [B0;B0] 0 true)))))) in - MEMw_EA (reset_vector_start EA,(8:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__1 -> - MEMw (reset_vector_start EA,(8:ii),reset_vector_start w__1) - -let execute_Stdux (RS, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(8:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__2 -> - MEMw (reset_vector_start EA,(8:ii),reset_vector_start w__2) - -let execute_Lhbrx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(2:ii)) >>= fun load_data -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - ((slice load_data (8:ii) (15:ii)) ^^ (slice load_data (0:ii) (7:ii)))) - -let execute_Sthbrx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(2:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (55:ii) >>= fun w__3 -> - MEMw (reset_vector_start EA,(2:ii),reset_vector_start (w__2 ^^ w__3)) - -let execute_Lwbrx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(4:ii)) >>= fun load_data -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - ((slice load_data (24:ii) (31:ii)) ^^ - ((slice load_data (16:ii) (23:ii)) ^^ - ((slice load_data (8:ii) (15:ii)) ^^ (slice load_data (0:ii) (7:ii)))))) - -let execute_Stwbrx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(4:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (55:ii) >>= fun w__3 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (40:ii) (47:ii) >>= fun w__4 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (39:ii) >>= fun w__5 -> - MEMw (reset_vector_start EA,(4:ii),reset_vector_start (w__2 ^^ (w__3 ^^ (w__4 ^^ w__5)))) - -let execute_Ldbrx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(8:ii)) >>= fun load_data -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((slice load_data (56:ii) (63:ii)) ^^ - ((slice load_data (48:ii) (55:ii)) ^^ - ((slice load_data (40:ii) (47:ii)) ^^ - ((slice load_data (32:ii) (39:ii)) ^^ - ((slice load_data (24:ii) (31:ii)) ^^ - ((slice load_data (16:ii) (23:ii)) ^^ - ((slice load_data (8:ii) (15:ii)) ^^ (slice load_data (0:ii) (7:ii))))))))) - -let execute_Stdbrx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(8:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (55:ii) >>= fun w__3 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (40:ii) (47:ii) >>= fun w__4 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (39:ii) >>= fun w__5 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (24:ii) (31:ii) >>= fun w__6 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (16:ii) (23:ii) >>= fun w__7 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (8:ii) (15:ii) >>= fun w__8 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (0:ii) (7:ii) >>= fun w__9 -> - MEMw - (reset_vector_start EA, - (8:ii), - reset_vector_start (w__2 ^^ (w__3 ^^ (w__4 ^^ (w__5 ^^ (w__6 ^^ (w__7 ^^ (w__8 ^^ w__9)))))))) - -let execute_Lmw (RT, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - let size = (minus_IVI (32:ii) (reset_vector_start RT)) * (4:ii) in - MEMr (reset_vector_start EA,size) >>= fun buffer -> - let i = (0:ii) in - (foreachM_inc (unsigned (reset_vector_start RT),(31:ii),(1:ii)) i - (fun r i -> - write_reg - (access GPR r) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (slice buffer i (i + (31:ii)))) >> - let i = i + (32:ii) in - return i)) >>= fun i -> - return () - -let execute_Stmw (RS, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - let size = (minus_IVI (32:ii) (reset_vector_start RS)) * (4:ii) in - MEMw_EA (reset_vector_start EA,size) >> - let buffer = make_indexed_vector [(0,B0);(993,B0)] B0 0 994 true in - let i = (0:ii) in - (foreachM_inc (unsigned (reset_vector_start RS),(31:ii),(1:ii)) (i,buffer) - (fun r (i,buffer) -> - read_reg_range (access GPR r) (32:ii) (63:ii) >>= fun w__1 -> - let buffer = update buffer i (i + (31:ii)) w__1 in - let i = i + (32:ii) in - return (i,buffer))) >>= fun (i, buffer) -> - MEMw - (reset_vector_start EA, - size, - reset_vector_start (slice buffer (0:ii) ((size * (8:ii)) - (1:ii)))) - -let execute_Lswi (RT, RA, NB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let EA = to_vec_inc ((64:ii),(0:ii)) in - return EA - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun EA -> - let r = (0:ii) in - let r = minus_VII (reset_vector_start RT) (1:ii) in - let size = - if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB) in - MEMr (reset_vector_start EA,size) >>= fun membuffer -> - let j = (0:ii) in - let i = (32:ii) in - (foreachM_dec (if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB),(1:ii),(1:ii)) (EA,i,j,r) - (fun n (EA,i,j,r) -> - (if bitU_to_bool (eq_range (i, (32:ii))) - then - let r = modulo (r + (1:ii)) (32:ii) in - write_reg (access GPR r) (to_vec_inc ((64:ii),(0:ii))) >> - return r - else return r) >>= fun r -> - write_reg_range (access GPR r) i (i + (7:ii)) (slice membuffer j (j + (7:ii))) >> - let j = j + (8:ii) in - let i = i + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - let EA = set_vector_start 0 (add_VIV (reset_vector_start EA) (1:ii)) in - return (EA,i,j,r))) >>= fun (EA, i, j, r) -> - return () - -let execute_Lswx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let r = (0:ii) in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - let r = minus_VII (reset_vector_start RT) (1:ii) in - let i = (32:ii) in - read_reg_range XER (57:ii) (63:ii) >>= fun w__2 -> - let n_top = unsigned (reset_vector_start w__2) in - recalculate_dependency () >> - (if bitU_to_bool (eq_range (n_top, (0:ii))) - then - write_reg (access GPR (unsigned (reset_vector_start RT))) (to_vec_inc_undef (64:ii)) >> - return r - else - MEMr (reset_vector_start EA,n_top) >>= fun membuffer -> - let j = (0:ii) in - let n_r = quot n_top (4:ii) in - let n_mod = modulo n_top (4:ii) in - let n_r = if bitU_to_bool (eq_range (n_mod, (0:ii))) then n_r else n_r + (1:ii) in - (foreachM_dec (n_r,(1:ii),(1:ii)) (j,r) - (fun n (j,r) -> - let r = modulo (r + (1:ii)) (32:ii) in - let temp = to_vec_inc ((64:ii),(0:ii)) in - let temp = - if bitU_to_bool (eq_range (n, (1:ii))) - then - match toNatural n_mod with - | (0:nn) -> - update temp (32:ii) (63:ii) (set_vector_start 32 (slice membuffer j (j + (31:ii)))) - | (1:nn) -> - update temp (32:ii) (39:ii) (set_vector_start 32 (slice membuffer j (j + (7:ii)))) - | (2:nn) -> - update temp (32:ii) (47:ii) (set_vector_start 32 (slice membuffer j (j + (15:ii)))) - | (3:nn) -> - update temp (32:ii) (55:ii) (set_vector_start 32 (slice membuffer j (j + (23:ii)))) - end - else update temp (32:ii) (63:ii) (set_vector_start 32 (slice membuffer j (j + (31:ii)))) in - let j = j + (32:ii) in - write_reg (access GPR r) temp >> - return (j,r))) >>= fun (j, r) -> - return r) >>= fun r -> - return () - -let execute_Stswi (RS, RA, NB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let EA = to_vec_inc ((64:ii),(0:ii)) in - return EA - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun EA -> - let r = (0:ii) in - let r = minus_VII (reset_vector_start RS) (1:ii) in - let size = - if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB) in - MEMw_EA (reset_vector_start EA,size) >> - let membuffer = make_indexed_vector [(0,B0);(255,B0)] B0 0 256 true in - let j = (0:ii) in - let i = (32:ii) in - (foreachM_dec (if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB),(1:ii),(1:ii)) (i,j,membuffer,r) - (fun n (i,j,membuffer,r) -> - let r = if bitU_to_bool (eq_range (i, (32:ii))) then modulo (r + (1:ii)) (32:ii) else r in - read_reg_range (access GPR r) i (i + (7:ii)) >>= fun w__1 -> - let membuffer = update membuffer j (j + (7:ii)) w__1 in - let j = j + (8:ii) in - let i = i + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - return (i,j,membuffer,r))) >>= fun (i, j, membuffer, r) -> - MEMw - (reset_vector_start EA, - size, - reset_vector_start (slice membuffer (0:ii) ((size * (8:ii)) - (1:ii)))) - -let execute_Stswx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let r = (0:ii) in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - let r = minus_VII (reset_vector_start RS) (1:ii) in - let i = (32:ii) in - read_reg_range XER (57:ii) (63:ii) >>= fun w__2 -> - let n_top = unsigned (reset_vector_start w__2) in - recalculate_dependency () >> - MEMw_EA (reset_vector_start EA,n_top) >> - let membuffer = make_indexed_vector [(0,B0);(511,B0)] B0 0 512 true in - let j = (0:ii) in - (foreachM_dec (n_top,(1:ii),(1:ii)) (j,i,membuffer,r) - (fun n (j,i,membuffer,r) -> - let r = if bitU_to_bool (eq_range (i, (32:ii))) then modulo (r + (1:ii)) (32:ii) else r in - read_reg_range (access GPR r) i (i + (7:ii)) >>= fun w__3 -> - let membuffer = update membuffer j (j + (7:ii)) w__3 in - let i = i + (8:ii) in - let j = j + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - return (j,i,membuffer,r))) >>= fun (j, i, membuffer, r) -> - if bitU_to_bool (~(eq_range (n_top, (0:ii)))) - then - MEMw - (reset_vector_start EA, - n_top, - reset_vector_start (slice membuffer (0:ii) ((n_top * (8:ii)) - (1:ii)))) - else return () - -let execute_Addi (RT, RA, SI) = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start SI))) - else - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 - (add_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start SI))))) - -let execute_Addis (RT, RA, SI) = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 - (exts - ((64:ii), - reset_vector_start (SI ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true))))) - else - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 - (add_VVV - (reset_vector_start w__0) - (reset_vector_start (exts - ((64:ii), - reset_vector_start (SI ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true))))))) - -let execute_Add (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (temp, overflow, _) = - match (addSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v0v', v1v', v2v') -> (v0v',v1v',v2v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Subf (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (t1, o1, _) = - match (addSO_VVV - (reset_vector_start (bitwise_not (reset_vector_start w__0))) - (reset_vector_start w__1)) with - | (v3v', v4v', v5v') -> (v3v',v4v',v5v') - end in - let (t2, o2, _) = - match (addSO_VBV (reset_vector_start t1) B1) with | (v6v', v7v', v8v') -> (v6v',v7v',v8v') end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Addic (RT, RA, SI) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let (temp, _, carry) = - match (addSO_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start SI)))) with - | (v9v', v10v', v11v') -> (v9v',v10v',v11v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - write_reg_bitfield XER "CA" carry - -let execute_AddicDot (RT, RA, SI) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let (temp, overflow, carry) = - match (addSO_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start SI)))) with - | (v12v', v13v', v14v') -> (v12v',v13v',v14v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - write_reg_bitfield XER "CA" carry >> - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),overflow |. w__1) - -let execute_Subfic (RT, RA, SI) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let (t1, o1, c1) = - match (addSO_VVV - (reset_vector_start (bitwise_not (reset_vector_start w__0))) - (reset_vector_start (exts ((64:ii),reset_vector_start SI)))) with - | (v15v', v16v', v17v') -> (v15v',v16v',v17v') - end in - let (t2, o2, c2) = - match (addSO_VBV (reset_vector_start t1) B1) with - | (v18v', v19v', v20v') -> (v18v',v19v',v20v') - end in - let temp = set_vector_start 0 t2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - write_reg_bitfield XER "CA" (c1 |. c2) - -let execute_Addc (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (temp, overflow, carry) = - match (addSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v21v', v22v', v23v') -> (v21v',v22v',v23v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Subfc (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (t1, o1, c1) = - match (addSO_VVV - (reset_vector_start (bitwise_not (reset_vector_start w__0))) - (reset_vector_start w__1)) with - | (v24v', v25v', v26v') -> (v24v',v25v',v26v') - end in - let (t2, o2, c2) = - match (addSO_VBV (reset_vector_start t1) B1) with - | (v27v', v28v', v29v') -> (v27v',v28v',v29v') - end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - let carry = c1 |. c2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Adde (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (t1, o1, c1) = - match (addSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v30v', v31v', v32v') -> (v30v',v31v',v32v') - end in - read_reg_bitfield XER "CA" >>= fun w__2 -> - let (t2, o2, c2) = - match (addSO_VBV (reset_vector_start t1) w__2) with - | (v33v', v34v', v35v') -> (v33v',v34v',v35v') - end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - let carry = c1 |. c2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Subfe (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (t1, o1, c1) = - match (addSO_VVV - (reset_vector_start (bitwise_not (reset_vector_start w__0))) - (reset_vector_start w__1)) with - | (v36v', v37v', v38v') -> (v36v',v37v',v38v') - end in - read_reg_bitfield XER "CA" >>= fun w__2 -> - let (t2, o2, c2) = - match (addSO_VBV (reset_vector_start t1) w__2) with - | (v39v', v40v', v41v') -> (v39v',v40v',v41v') - end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - let carry = c1 |. c2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Addme (RT, RA, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg_bitfield XER "CA" >>= fun w__1 -> - let (t1, o1, c1) = - match (addSO_VBV (reset_vector_start w__0) w__1) with - | (v42v', v43v', v44v') -> (v42v',v43v',v44v') - end in - let (t2, o2, c2) = - match (addSO_VVV - (reset_vector_start t1) - (reset_vector_start (Vector [B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1] 0 true))) with - | (v45v', v46v', v47v') -> (v45v',v46v',v47v') - end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - let carry = c1 |. c2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Subfme (RT, RA, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg_bitfield XER "CA" >>= fun w__1 -> - let (t1, o1, c1) = - match (addSO_VBV (reset_vector_start (bitwise_not (reset_vector_start w__0))) w__1) with - | (v48v', v49v', v50v') -> (v48v',v49v',v50v') - end in - let (t2, o2, c2) = - match (addSO_VVV - (reset_vector_start t1) - (reset_vector_start (Vector [B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1] 0 true))) with - | (v51v', v52v', v53v') -> (v51v',v52v',v53v') - end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - let carry = c1 |. c2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Addze (RT, RA, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg_bitfield XER "CA" >>= fun w__1 -> - let (temp, overflow, carry) = - match (addSO_VBV (reset_vector_start w__0) w__1) with - | (v54v', v55v', v56v') -> (v54v',v55v',v56v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Subfze (RT, RA, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg_bitfield XER "CA" >>= fun w__1 -> - let (temp, overflow, carry) = - match (addSO_VBV (reset_vector_start (bitwise_not (reset_vector_start w__0))) w__1) with - | (v57v', v58v', v59v') -> (v57v',v58v',v59v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Neg (RT, RA, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let (temp, overflow, _) = - match (addSO_VBV (reset_vector_start (bitwise_not (reset_vector_start w__0))) B1) with - | (v60v', v61v', v62v') -> (v60v',v61v',v62v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),w__1) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Mulli (RT, RA, SI) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let prod = - set_vector_start 0 - (multS_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start SI)))) in - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (slice prod (64:ii) (127:ii))) - -let execute_Mullw (RT, RA, RB, OE, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let (prod, overflow, _) = - match (multSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v63v', v64v', v65v') -> (v63v',v64v',v65v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 prod) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 prod),xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Mulhw (RT, RA, RB, Rc) = - let prod = to_vec_inc ((64:ii),(0:ii)) in - let overflow = B0 in - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let (p, o, _) = - match (multSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v66v', v67v', v68v') -> (v66v',v67v',v68v') - end in - let prod = set_vector_start 0 p in - let overflow = o in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (set_vector_start 32 (slice prod (0:ii) (31:ii))) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool (most_significant w__2) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start prod,xer_so) - else return () - -let execute_Mulhwu (RT, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let prod = set_vector_start 0 (mult_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (set_vector_start 32 (slice prod (0:ii) (31:ii))) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool (most_significant w__2) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start prod,xer_so) - else return () - -let execute_Divw (RT, RA, RB, OE, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let dividend = set_vector_start 0 w__0 in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let divisor = set_vector_start 0 w__1 in - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotSO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v69v', v70v', v71v') -> (v69v',v70v',v71v') - end in - let divided = update divided (32:ii) (63:ii) (set_vector_start 32 d) in - let overflow = o in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (slice divided (32:ii) (63:ii)) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool ((most_significant w__2) |. overflow) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start divided,xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Divwu (RT, RA, RB, OE, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let dividend = set_vector_start 0 w__0 in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let divisor = set_vector_start 0 w__1 in - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v72v', v73v', v74v') -> (v72v',v73v',v74v') - end in - let divided = update divided (32:ii) (63:ii) (set_vector_start 32 d) in - let overflow = o in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (slice divided (32:ii) (63:ii)) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool ((most_significant w__2) |. overflow) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start divided,xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Divwe (RT, RA, RB, OE, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let dividend = - w__0 ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let divisor = set_vector_start 0 w__1 in - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotSO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v75v', v76v', v77v') -> (v75v',v76v',v77v') - end in - let divided = update divided (32:ii) (63:ii) (slice d (32:ii) (63:ii)) in - let overflow = o in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (slice divided (32:ii) (63:ii)) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool ((most_significant w__2) |. overflow) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start divided,xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Divweu (RT, RA, RB, OE, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let dividend = - w__0 ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let divisor = set_vector_start 0 w__1 in - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v78v', v79v', v80v') -> (v78v',v79v',v80v') - end in - let divided = update divided (32:ii) (63:ii) (slice d (32:ii) (63:ii)) in - let overflow = o in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (slice divided (32:ii) (63:ii)) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool ((most_significant w__2) |. overflow) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start divided,xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Mulld (RT, RA, RB, OE, Rc) = - let prod = to_vec_inc ((128:ii),(0:ii)) in - let overflow = B0 in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (p, o, _) = - match (multSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v81v', v82v', v83v') -> (v81v',v82v',v83v') - end in - let prod = set_vector_start 0 p in - let overflow = o in - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (slice prod (64:ii) (127:ii))) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 (slice prod (64:ii) (127:ii))),xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Mulhd (RT, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let prod = set_vector_start 0 (multS_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RT))) (slice prod (0:ii) (63:ii)) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start (slice prod (0:ii) (63:ii)),w__2) - else return () - -let execute_Mulhdu (RT, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let prod = set_vector_start 0 (mult_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RT))) (slice prod (0:ii) (63:ii)) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start (slice prod (0:ii) (63:ii)),w__2) - else return () - -let execute_Divd (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun dividend -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun divisor -> - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotSO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v84v', v85v', v86v') -> (v84v',v85v',v86v') - end in - let divided = set_vector_start 0 d in - let overflow = o in - write_reg (access GPR (unsigned (reset_vector_start RT))) divided >> - (if bitU_to_bool OE - then set_SO_OV overflow - else return ()) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__0 -> - set_overflow_cr0 (reset_vector_start divided,overflow |. w__0) - else return () - -let execute_Divdu (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun dividend -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun divisor -> - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v87v', v88v', v89v') -> (v87v',v88v',v89v') - end in - let divided = set_vector_start 0 d in - let overflow = o in - write_reg (access GPR (unsigned (reset_vector_start RT))) divided >> - (if bitU_to_bool OE - then set_SO_OV overflow - else return ()) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__0 -> - set_overflow_cr0 (reset_vector_start divided,overflow |. w__0) - else return () - -let execute_Divde (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let dividend = - w__0 ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true) in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun divisor -> - let divided = to_vec_inc ((128:ii),(0:ii)) in - let overflow = B0 in - let (d, o, _) = - match (quotSO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v90v', v91v', v92v') -> (v90v',v91v',v92v') - end in - let divided = set_vector_start 0 d in - let overflow = o in - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (slice divided (64:ii) (127:ii))) >> - (if bitU_to_bool OE - then set_SO_OV overflow - else return ()) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - if bitU_to_bool overflow - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else - set_overflow_cr0 - (reset_vector_start (set_vector_start 0 (slice divided (64:ii) (127:ii))), - xer_so) - else return () - -let execute_Divdeu (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let dividend = - w__0 ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true) in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun divisor -> - let divided = to_vec_inc ((128:ii),(0:ii)) in - let overflow = B0 in - let (d, o, _) = - match (quotO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v93v', v94v', v95v') -> (v93v',v94v',v95v') - end in - let divided = set_vector_start 0 d in - let overflow = o in - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (slice divided (64:ii) (127:ii))) >> - (if bitU_to_bool OE - then set_SO_OV overflow - else return ()) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - if bitU_to_bool overflow - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else - set_overflow_cr0 - (reset_vector_start (set_vector_start 0 (slice divided (64:ii) (127:ii))), - xer_so) - else return () - -let execute_Cmpi (BF, L, RA, SI) = - let a = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let a = set_vector_start 0 (exts ((64:ii),reset_vector_start w__0)) in - return a - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun a -> - let c = make_indexed_vector [] B0 0 3 true in - let c = - if bitU_to_bool (lt_vec (a, exts ((64:ii),reset_vector_start SI))) - then Vector [B1;B0;B0] 0 true - else - if bitU_to_bool (gt_vec (a, exts ((64:ii),reset_vector_start SI))) - then Vector [B0;B1;B0] 0 true - else Vector [B0;B0;B1] 0 true in - read_reg_bitfield XER "SO" >>= fun w__2 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - (c ^^ (Vector [w__2] 0 true)) - -let execute_Cmp (BF, L, RA, RB) = - let a = to_vec_inc ((64:ii),(0:ii)) in - let b = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let a = set_vector_start 0 (exts ((64:ii),reset_vector_start w__0)) in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let b = set_vector_start 0 (exts ((64:ii),reset_vector_start w__1)) in - return (a,b) - else - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__2 -> - let a = w__2 in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__3 -> - let b = w__3 in - return (a,b)) >>= fun (a, b) -> - let c = make_indexed_vector [] B0 0 3 true in - let c = - if bitU_to_bool (lt_vec (a, b)) - then Vector [B1;B0;B0] 0 true - else if bitU_to_bool (gt_vec (a, b)) then Vector [B0;B1;B0] 0 true else Vector [B0;B0;B1] 0 true in - read_reg_bitfield XER "SO" >>= fun w__4 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - (c ^^ (Vector [w__4] 0 true)) - -let execute_Cmpli (BF, L, RA, UI) = - let a = to_vec_inc ((64:ii),(0:ii)) in - let c = to_vec_inc ((3:ii),(0:ii)) in - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let a = - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__0 in - return a - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun a -> - let c = - if bitU_to_bool - (lt_vec_unsigned - (a, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - UI)) - then Vector [B1;B0;B0] 0 true - else - if bitU_to_bool - (gt_vec_unsigned - (a, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - UI)) - then Vector [B0;B1;B0] 0 true - else Vector [B0;B0;B1] 0 true in - read_reg_bitfield XER "SO" >>= fun w__2 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - (c ^^ (Vector [w__2] 0 true)) - -let execute_Cmpl (BF, L, RA, RB) = - let a = to_vec_inc ((64:ii),(0:ii)) in - let b = to_vec_inc ((64:ii),(0:ii)) in - let c = to_vec_inc ((3:ii),(0:ii)) in - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let a = - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__0 in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let b = - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1 in - return (a,b) - else - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__2 -> - let a = w__2 in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__3 -> - let b = w__3 in - return (a,b)) >>= fun (a, b) -> - let c = - if bitU_to_bool (lt_vec_unsigned (a, b)) - then Vector [B1;B0;B0] 0 true - else - if bitU_to_bool (gt_vec_unsigned (a, b)) - then Vector [B0;B1;B0] 0 true - else Vector [B0;B0;B1] 0 true in - read_reg_bitfield XER "SO" >>= fun w__4 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - (c ^^ (Vector [w__4] 0 true)) - -let execute_Isel (RT, RA, RB, BC) = - let a = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let a = to_vec_inc ((64:ii),(0:ii)) in - return a - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun a -> - read_reg_bit CR (add_VII (reset_vector_start BC) (32:ii)) >>= fun w__1 -> - if bitU_to_bool (eq (match w__1 with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then - write_reg (access GPR (unsigned (reset_vector_start RT))) a >> - let discard = access GPR (unsigned (reset_vector_start RB)) in - return () - else - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__2 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__2 - -let execute_Andi (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let temp = - set_vector_start 0 - (bitwise_and - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - UI)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - -let execute_Andis (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let temp = - set_vector_start 0 - (bitwise_and - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (UI ^^ (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - -let execute_Ori (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - (set_vector_start 0 - (bitwise_or - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - UI))) - -let execute_Oris (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - (set_vector_start 0 - (bitwise_or - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (UI ^^ (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true))))) - -let execute_Xori (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - (set_vector_start 0 - (bitwise_xor - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - UI))) - -let execute_Xoris (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - (set_vector_start 0 - (bitwise_xor - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (UI ^^ (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true))))) - -let execute_And (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_and (w__0, w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Xor (RS, RA, RB, Rc) = - let temp = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec (RS, RB)) - then - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let temp = w__0 in - let temp = to_vec_inc ((64:ii),(0:ii)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) (to_vec_inc ((64:ii),(0:ii))) >> - return temp - else - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__1 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__2 -> - let temp = set_vector_start 0 (bitwise_xor (w__1, w__2)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - return temp) >>= fun temp -> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__3 -> - set_overflow_cr0 (reset_vector_start temp,w__3) - else return () - -let execute_Nand (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_not (reset_vector_start (bitwise_and (w__0, w__1)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Or (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_or (w__0, w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Nor (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_not (reset_vector_start (bitwise_or (w__0, w__1)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Eqv (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_xor (w__0, bitwise_not (reset_vector_start w__1))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Andc (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_and (w__0, bitwise_not (reset_vector_start w__1))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Orc (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_or (w__0, bitwise_not (reset_vector_start w__1))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Extsb (RS, RA, Rc) = - let temp = to_vec_inc ((64:ii),(0:ii)) in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (56:ii) >>= fun s -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__0 -> - let temp = update temp (56:ii) (63:ii) w__0 in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (56:ii) - (63:ii) - (slice temp (56:ii) (63:ii)) >> - let temp = update temp (0:ii) (55:ii) (duplicate (s, (56:ii))) in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (0:ii) - (55:ii) - (slice temp (0:ii) (55:ii)) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Extsh (RS, RA, Rc) = - let temp = to_vec_inc ((64:ii),(0:ii)) in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (48:ii) >>= fun s -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__0 -> - let temp = update temp (48:ii) (63:ii) w__0 in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (48:ii) - (63:ii) - (slice temp (48:ii) (63:ii)) >> - let temp = update temp (0:ii) (47:ii) (duplicate (s, (48:ii))) in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (0:ii) - (47:ii) - (slice temp (0:ii) (47:ii)) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Cntlzw (RS, RA, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let temp = to_vec_inc ((64:ii),countLeadingZeroes (reset_vector_start w__0,(32:ii))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Cmpb (RS, RA, RB) = - (foreachM_inc ((0:ii),(7:ii),(1:ii)) () - (fun n _ -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) - ((8:ii) * n) (((8:ii) * n) + (7:ii)) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RB))) - ((8:ii) * n) (((8:ii) * n) + (7:ii)) >>= fun w__1 -> - if bitU_to_bool (eq_vec (w__0, w__1)) - then - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) ((8:ii) * n) - (((8:ii) * n) + (7:ii)) - (Vector [B1;B1;B1;B1;B1;B1;B1;B1] 0 true) - else - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) ((8:ii) * n) - (((8:ii) * n) + (7:ii)) - (to_vec_inc ((8:ii),(0:ii))))) - -let execute_Popcntb (RS, RA) = - (foreachM_inc ((0:ii),(7:ii),(1:ii)) () - (fun i _ -> - let n = (0:ii) in - (foreachM_inc ((0:ii),(7:ii),(1:ii)) n - (fun j n -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) ((i * (8:ii)) + j) >>= fun w__0 -> - let n = - if bitU_to_bool (eq (match w__0 with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then n + (1:ii) - else n in - return n)) >>= fun n -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (i * (8:ii)) - ((i * (8:ii)) + (7:ii)) - (to_vec_inc ((8:ii),n)))) - -let execute_Popcntw (RS, RA) = - (foreachM_inc ((0:ii),(1:ii),(1:ii)) () - (fun i _ -> - let n = (0:ii) in - (foreachM_inc ((0:ii),(31:ii),(1:ii)) n - (fun j n -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) ((i * (32:ii)) + j) >>= fun w__0 -> - let n = - if bitU_to_bool (eq (match w__0 with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then n + (1:ii) - else n in - return n)) >>= fun n -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (i * (32:ii)) - ((i * (32:ii)) + (31:ii)) - (to_vec_inc ((32:ii),n)))) - -let execute_Prtyd (RS, RA) = - let s = (0:ii) in - (foreachM_inc ((0:ii),(7:ii),(1:ii)) s - (fun i s -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) ((i * (8:ii)) + (7:ii)) >>= fun w__0 -> - let s = - match ((if bitU_to_bool (is_one s) - then B1 - else B0) +. w__0) with - | B0 -> (0:ii) - | B1 -> (1:ii) - end in - return s)) >>= fun s -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (Vector [if bitU_to_bool (is_one s) then B1 else B0] 0 true)) - -let execute_Prtyw (RS, RA) = - let s = (0:ii) in - let t = (0:ii) in - (foreachM_inc ((0:ii),(3:ii),(1:ii)) s - (fun i s -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) ((i * (8:ii)) + (7:ii)) >>= fun w__0 -> - let s = - match ((if bitU_to_bool (is_one s) - then B1 - else B0) +. w__0) with - | B0 -> (0:ii) - | B1 -> (1:ii) - end in - return s)) >>= fun s -> - (foreachM_inc ((4:ii),(7:ii),(1:ii)) t - (fun i t -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) ((i * (8:ii)) + (7:ii)) >>= fun w__1 -> - let t = - match ((if bitU_to_bool (is_one t) - then B1 - else B0) +. w__1) with - | B0 -> (0:ii) - | B1 -> (1:ii) - end in - return t)) >>= fun t -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (0:ii) - (31:ii) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (Vector [if bitU_to_bool (is_one s) then B1 else B0] 0 true)) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (32:ii) - (63:ii) - (set_vector_start 32 - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (Vector [if bitU_to_bool (is_one t) then B1 else B0] 0 true))) - -let execute_Extsw (RS, RA, Rc) = - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (32:ii) >>= fun s -> - let temp = to_vec_inc ((64:ii),(0:ii)) in - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - let temp = update temp (32:ii) (63:ii) w__0 in - let temp = update temp (0:ii) (31:ii) (duplicate (s, (32:ii))) in - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return ()) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) temp - -let execute_Cntlzd (RS, RA, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let temp = to_vec_inc ((64:ii),countLeadingZeroes (reset_vector_start w__0,(0:ii))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Popcntd (RS, RA) = - let n = (0:ii) in - (foreachM_inc ((0:ii),(63:ii),(1:ii)) n - (fun i n -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) i >>= fun w__0 -> - let n = - if bitU_to_bool (eq (match w__0 with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then n + (1:ii) - else n in - return n)) >>= fun n -> - write_reg (access GPR (unsigned (reset_vector_start RA))) (to_vec_inc ((64:ii),n)) - -let execute_Bpermd (RS, RA, RB) = - let perm = to_vec_inc ((8:ii),(0:ii)) in - (foreachM_inc ((0:ii),(7:ii),(1:ii)) perm - (fun i perm -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) - ((8:ii) * i) (((8:ii) * i) + (7:ii)) >>= fun index -> - if bitU_to_bool (lt_vec_unsigned (index, to_vec_inc ((8:ii),(64:ii)))) - then - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (unsigned - (reset_vector_start index)) >>= fun w__0 -> - let perm = update_pos perm i w__0 in - return perm - else - let perm = update_pos perm i B0 in - let discard = access GPR (unsigned (reset_vector_start RB)) in - return perm)) >>= fun perm -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (slice perm (0:ii) (7:ii))) - -let execute_Rlwinm (RS, RA, SH, MB, ME, Rc) = - let n = SH in - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),unsigned (reset_vector_start n)) in - let m = MASK (add_VII (reset_vector_start MB) (32:ii),add_VII (reset_vector_start ME) (32:ii)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Rlwnm (RS, RA, RB, MB, ME, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (59:ii) (63:ii) >>= fun n -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),unsigned (reset_vector_start n)) in - let m = MASK (add_VII (reset_vector_start MB) (32:ii),add_VII (reset_vector_start ME) (32:ii)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Rlwimi (RS, RA, SH, MB, ME, Rc) = - let n = SH in - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),unsigned (reset_vector_start n)) in - let m = MASK (add_VII (reset_vector_start MB) (32:ii),add_VII (reset_vector_start ME) (32:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__2 -> - let temp = - set_vector_start 0 - (bitwise_or (bitwise_and (r, m), bitwise_and (w__2, bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__3 -> - set_overflow_cr0 (reset_vector_start temp,w__3) - else return () - -let execute_Rldicl (RS, RA, sh, mb, Rc) = - let n = (Vector [access sh (5:ii)] 0 true) ^^ (slice sh (0:ii) (4:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let b = (Vector [access mb (5:ii)] 0 true) ^^ (slice mb (0:ii) (4:ii)) in - let m = MASK (unsigned (reset_vector_start b),(63:ii)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Rldicr (RS, RA, sh, me, Rc) = - let n = (Vector [access sh (5:ii)] 0 true) ^^ (slice sh (0:ii) (4:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let e = (Vector [access me (5:ii)] 0 true) ^^ (slice me (0:ii) (4:ii)) in - let m = MASK ((0:ii),unsigned (reset_vector_start e)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Rldic (RS, RA, sh, mb, Rc) = - let n = (Vector [access sh (5:ii)] 0 true) ^^ (slice sh (0:ii) (4:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let b = (Vector [access mb (5:ii)] 0 true) ^^ (slice mb (0:ii) (4:ii)) in - let m = - MASK - (unsigned (reset_vector_start b), - unsigned (reset_vector_start (bitwise_not (reset_vector_start n)))) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Rldcl (RS, RA, RB, mb, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (58:ii) (63:ii) >>= fun n -> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let b = (Vector [access mb (5:ii)] 0 true) ^^ (slice mb (0:ii) (4:ii)) in - let m = MASK (unsigned (reset_vector_start b),(63:ii)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Rldcr (RS, RA, RB, me, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (58:ii) (63:ii) >>= fun n -> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let e = (Vector [access me (5:ii)] 0 true) ^^ (slice me (0:ii) (4:ii)) in - let m = MASK ((0:ii),unsigned (reset_vector_start e)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Rldimi (RS, RA, sh, mb, Rc) = - let n = (Vector [access sh (5:ii)] 0 true) ^^ (slice sh (0:ii) (4:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let b = (Vector [access mb (5:ii)] 0 true) ^^ (slice mb (0:ii) (4:ii)) in - let m = - MASK - (unsigned (reset_vector_start b), - unsigned (reset_vector_start (bitwise_not (reset_vector_start n)))) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__1 -> - let temp = - set_vector_start 0 - (bitwise_or (bitwise_and (r, m), bitwise_and (w__1, bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Slw (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (59:ii) (63:ii) >>= fun n -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),unsigned (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (58:ii) >>= fun w__2 -> - let m = - if bitU_to_bool (eq (match w__2 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK ((32:ii),minus_IVI (63:ii) (reset_vector_start n)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__3 -> - set_overflow_cr0 (reset_vector_start temp,w__3) - else return () - -let execute_Srw (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (59:ii) (63:ii) >>= fun n -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),minus_IVI (64:ii) (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (58:ii) >>= fun w__2 -> - let m = - if bitU_to_bool (eq (match w__2 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK (add_VII (reset_vector_start n) (32:ii),(63:ii)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__3 -> - set_overflow_cr0 (reset_vector_start temp,w__3) - else return () - -let execute_Srawi (RS, RA, SH, Rc) = - let n = SH in - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),minus_IVI (64:ii) (reset_vector_start n)) in - let m = MASK (add_VII (reset_vector_start n) (32:ii),(63:ii)) in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (32:ii) >>= fun s -> - let temp = - set_vector_start 0 - (bitwise_or - (bitwise_and (r, m), - bitwise_and (duplicate (s, (64:ii)), bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return ()) >> - write_reg_bitfield - XER "CA" - (if bitU_to_bool (gt_vec_unsigned (n, to_vec_inc ((5:ii),(0:ii)))) - then s &. (~(eq_vec_range (bitwise_and (r, bitwise_not (reset_vector_start m)), (0:ii)))) - else B0) - -let execute_Sraw (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (59:ii) (63:ii) >>= fun n -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),minus_IVI (64:ii) (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (58:ii) >>= fun w__2 -> - let m = - if bitU_to_bool (eq (match w__2 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK (add_VII (reset_vector_start n) (32:ii),(63:ii)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (32:ii) >>= fun s -> - let temp = - set_vector_start 0 - (bitwise_or - (bitwise_and (r, m), - bitwise_and (duplicate (s, (64:ii)), bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__3 -> - set_overflow_cr0 (reset_vector_start temp,w__3) - else return ()) >> - write_reg_bitfield - XER "CA" - (if bitU_to_bool (gt_vec_unsigned (n, to_vec_inc ((5:ii),(0:ii)))) - then s &. (~(eq_vec_range (bitwise_and (r, bitwise_not (reset_vector_start m)), (0:ii)))) - else B0) - -let execute_Sld (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (58:ii) (63:ii) >>= fun n -> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (57:ii) >>= fun w__1 -> - let m = - if bitU_to_bool (eq (match w__1 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK ((0:ii),minus_IVI (63:ii) (reset_vector_start n)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Srd (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (58:ii) (63:ii) >>= fun n -> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,minus_IVI (64:ii) (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (57:ii) >>= fun w__1 -> - let m = - if bitU_to_bool (eq (match w__1 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK (unsigned (reset_vector_start n),(63:ii)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Sradi (RS, RA, sh, Rc) = - let n = (Vector [access sh (5:ii)] 0 true) ^^ (slice sh (0:ii) (4:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,minus_IVI (64:ii) (reset_vector_start n)) in - let m = MASK (unsigned (reset_vector_start n),(63:ii)) in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (0:ii) >>= fun s -> - let temp = - set_vector_start 0 - (bitwise_or - (bitwise_and (r, m), - bitwise_and (duplicate (s, (64:ii)), bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return ()) >> - write_reg_bitfield - XER "CA" - (if bitU_to_bool (gt_vec_unsigned (n, to_vec_inc ((6:ii),(0:ii)))) - then s &. (~(eq_vec_range (bitwise_and (r, bitwise_not (reset_vector_start m)), (0:ii)))) - else B0) - -let execute_Srad (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (58:ii) (63:ii) >>= fun n -> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,minus_IVI (64:ii) (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (57:ii) >>= fun w__1 -> - let m = - if bitU_to_bool (eq (match w__1 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK (unsigned (reset_vector_start n),(63:ii)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (0:ii) >>= fun s -> - let temp = - set_vector_start 0 - (bitwise_or - (bitwise_and (r, m), - bitwise_and (duplicate (s, (64:ii)), bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return ()) >> - write_reg_bitfield - XER "CA" - (if bitU_to_bool (gt_vec_unsigned (n, to_vec_inc ((6:ii),(0:ii)))) - then s &. (~(eq_vec_range (bitwise_and (r, bitwise_not (reset_vector_start m)), (0:ii)))) - else B0) - -let execute_Cdtbcd (RS, RA) = - (foreachM_inc ((0:ii),(1:ii),(1:ii)) () - (fun i _ -> - let n = i * (32:ii) in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (0:ii)) - (n + (7:ii)) - (to_vec_inc ((8:ii),(0:ii))) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (n + (12:ii)) (n + (21:ii)) >>= fun w__0 -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (8:ii)) - (n + (19:ii)) - (DEC_TO_BCD (reset_vector_start (set_vector_start 0 w__0))) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (n + (22:ii)) (n + (31:ii)) >>= fun w__1 -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (20:ii)) - (n + (31:ii)) - (DEC_TO_BCD (reset_vector_start (set_vector_start 0 w__1))))) - -let execute_Cbcdtd (RS, RA) = - (foreachM_inc ((0:ii),(1:ii),(1:ii)) () - (fun i _ -> - let n = i * (32:ii) in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (0:ii)) - (n + (11:ii)) - (to_vec_inc ((12:ii),(0:ii))) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (n + (8:ii)) (n + (19:ii)) >>= fun w__0 -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (12:ii)) - (n + (21:ii)) - (BCD_TO_DEC (reset_vector_start (set_vector_start 0 w__0))) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (n + (20:ii)) (n + (31:ii)) >>= fun w__1 -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (22:ii)) - (n + (31:ii)) - (BCD_TO_DEC (reset_vector_start (set_vector_start 0 w__1))))) - -let execute_Addg6s (RT, RA, RB) = - let dc = to_vec_inc ((16:ii),(0:ii)) in - (foreachM_inc ((0:ii),(15:ii),(1:ii)) dc - (fun i dc -> - read_reg_range (access GPR (unsigned (reset_vector_start RA))) ((4:ii) * i) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RB))) ((4:ii) * i) (63:ii) >>= fun w__1 -> - let (v, _, co) = - match (addO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v96v', v97v', v98v') -> (v96v',v97v',v98v') - end in - let dc = update_pos dc i (carry_out (reset_vector_start (set_vector_start 0 v),co)) in - return dc)) >>= fun dc -> - let c = - (duplicate (access dc (0:ii), (4:ii))) ^^ - ((duplicate (access dc (1:ii), (4:ii))) ^^ - ((duplicate (access dc (2:ii), (4:ii))) ^^ - ((duplicate (access dc (3:ii), (4:ii))) ^^ - ((duplicate (access dc (4:ii), (4:ii))) ^^ - ((duplicate (access dc (5:ii), (4:ii))) ^^ - ((duplicate (access dc (6:ii), (4:ii))) ^^ - ((duplicate (access dc (7:ii), (4:ii))) ^^ - ((duplicate (access dc (8:ii), (4:ii))) ^^ - ((duplicate (access dc (9:ii), (4:ii))) ^^ - ((duplicate (access dc (10:ii), (4:ii))) ^^ - ((duplicate (access dc (11:ii), (4:ii))) ^^ - ((duplicate (access dc (12:ii), (4:ii))) ^^ - ((duplicate (access dc (13:ii), (4:ii))) ^^ - ((duplicate (access dc (14:ii), (4:ii))) ^^ (duplicate (access dc (15:ii), (4:ii))))))))))))))))) in - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 - (bitwise_and - (bitwise_not (reset_vector_start c), - Vector [B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0; - B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1; - B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1; - B0] 0 true))) - -let execute_Mtspr (RS, spr) = - let n = (slice spr (5:ii) (9:ii)) ^^ (slice spr (0:ii) (4:ii)) in - if bitU_to_bool (eq_vec_range (n, (13:ii))) - then trap () - else - if bitU_to_bool (eq_vec_range (n, (1:ii))) - then - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun reg -> - let front = zero_or_undef (reset_vector_start (slice reg (0:ii) (31:ii))) in - let xer_so = access reg (32:ii) in - let xer_ov = access reg (33:ii) in - let xer_ca = access reg (34:ii) in - let mid = zero_or_undef (reset_vector_start (set_vector_start 0 (slice reg (35:ii) (56:ii)))) in - let bot = set_vector_start 0 (slice reg (57:ii) (63:ii)) in - write_reg - XER - (front ^^ - ((Vector [xer_so] 0 true) ^^ - ((Vector [xer_ov] 0 true) ^^ ((Vector [xer_ca] 0 true) ^^ (mid ^^ bot))))) - else - read_reg (access SPR (unsigned (reset_vector_start n))) >>= fun w__0 -> - if bitU_to_bool (eq_range (length (reset_vector_start w__0), (64:ii))) - then - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__1 -> - write_reg (access SPR (unsigned (reset_vector_start n))) w__1 - else - if bitU_to_bool (eq_vec_range (n, (152:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun CTRL -> - return () - else return () - -let execute_Mfspr (RT, spr) = - let n = (slice spr (5:ii) (9:ii)) ^^ (slice spr (0:ii) (4:ii)) in - read_reg (access SPR (unsigned (reset_vector_start n))) >>= fun w__0 -> - if bitU_to_bool (eq_range (length (reset_vector_start w__0), (64:ii))) - then - read_reg (access SPR (unsigned (reset_vector_start n))) >>= fun w__1 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__1 - else - read_reg (access SPR (unsigned (reset_vector_start n))) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Mtcrf (RS, FXM) = - let mask = - (duplicate (access FXM (0:ii), (4:ii))) ^^ - ((duplicate (access FXM (1:ii), (4:ii))) ^^ - ((duplicate (access FXM (2:ii), (4:ii))) ^^ - ((duplicate (access FXM (3:ii), (4:ii))) ^^ - ((duplicate (access FXM (4:ii), (4:ii))) ^^ - ((duplicate (access FXM (5:ii), (4:ii))) ^^ - ((duplicate (access FXM (6:ii), (4:ii))) ^^ (duplicate (access FXM (7:ii), (4:ii))))))))) in - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg CR >>= fun w__1 -> - write_reg - CR - (set_vector_start 32 - (bitwise_or - (set_vector_start 0 (bitwise_and (w__0, mask)), - set_vector_start 0 (bitwise_and (w__1, bitwise_not (reset_vector_start mask)))))) - -let execute_Mfcr RT = - read_reg CR >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__0) - -let execute_Mtocrf (RS, FXM) = - let n = (0:ii) in - let count = (0:ii) in - let (count, n) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (count,n) - (fun i (count,n) -> - let (n, count) = - if bitU_to_bool (eq (match (access FXM i) with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then - let n = i in - let count = count + (1:ii) in - (n,count) - else (n,count) in - (count,n))) in - if bitU_to_bool (eq_range (count, (1:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RS))) - (((4:ii) * n) + (32:ii)) (((4:ii) * n) + (35:ii)) >>= fun w__0 -> - write_reg_range CR (((4:ii) * n) + (32:ii)) (((4:ii) * n) + (35:ii)) w__0 - else write_reg CR (to_vec_inc_undef (32:ii)) - -let execute_Mfocrf (RT, FXM) = - let n = (0:ii) in - let count = (0:ii) in - let (count, n) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (count,n) - (fun i (count,n) -> - let (n, count) = - if bitU_to_bool (eq (match (access FXM i) with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then - let n = i in - let count = count + (1:ii) in - (n,count) - else (n,count) in - (count,n))) in - if bitU_to_bool (eq_range (count, (1:ii))) - then - let temp = to_vec_inc_undef (64:ii) in - read_reg_range CR (((4:ii) * n) + (32:ii)) (((4:ii) * n) + (35:ii)) >>= fun w__0 -> - let temp = update temp (((4:ii) * n) + (32:ii)) (((4:ii) * n) + (35:ii)) w__0 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp - else write_reg (access GPR (unsigned (reset_vector_start RT))) (to_vec_inc_undef (64:ii)) - -let execute_Mcrxr BF = - read_reg_range XER (32:ii) (35:ii) >>= fun w__0 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - w__0 >> - write_reg_range XER (32:ii) (35:ii) (set_vector_start 32 (Vector [B0;B0;B0;B0] 0 true)) - -let execute_Dlmzb (RS, RA, RB, Rc) = return () - -let execute_Macchw (RT, RA, RB, OE, Rc) = return () - -let execute_Macchws (RT, RA, RB, OE, Rc) = return () - -let execute_Macchwu (RT, RA, RB, OE, Rc) = return () - -let execute_Macchwsu (RT, RA, RB, OE, Rc) = return () - -let execute_Machhw (RT, RA, RB, OE, Rc) = return () - -let execute_Machhws (RT, RA, RB, OE, Rc) = return () - -let execute_Machhwu (RT, RA, RB, OE, Rc) = return () - -let execute_Machhwsu (RT, RA, RB, OE, Rc) = return () - -let execute_Maclhw (RT, RA, RB, OE, Rc) = return () - -let execute_Maclhws (RT, RA, RB, OE, Rc) = return () - -let execute_Maclhwu (RT, RA, RB, OE, Rc) = return () - -let execute_Maclhwsu (RT, RA, RB, OE, Rc) = return () - -let execute_Mulchw (RT, RA, RB, Rc) = return () - -let execute_Mulchwu (RT, RA, RB, Rc) = return () - -let execute_Mulhhw (RT, RA, RB, Rc) = return () - -let execute_Mulhhwu (RT, RA, RB, Rc) = return () - -let execute_Mullhw (RT, RA, RB, Rc) = return () - -let execute_Mullhwu (RT, RA, RB, Rc) = return () - -let execute_Nmacchw (RT, RA, RB, OE, Rc) = return () - -let execute_Nmacchws (RT, RA, RB, OE, Rc) = return () - -let execute_Nmachhw (RT, RA, RB, OE, Rc) = return () - -let execute_Nmachhws (RT, RA, RB, OE, Rc) = return () - -let execute_Nmaclhw (RT, RA, RB, OE, Rc) = return () - -let execute_Nmaclhws (RT, RA, RB, OE, Rc) = return () - -let execute_Icbi (RA, RB) = return () - -let execute_Icbt (CT, RA, RB) = return () - -let execute_Dcba (RA, RB) = return () - -let execute_Dcbt (TH, RA, RB) = return () - -let execute_Dcbtst (TH, RA, RB) = return () - -let execute_Dcbz (RA, RB) = return () - -let execute_Dcbst (RA, RB) = return () - -let execute_Dcbf (L, RA, RB) = return () - -let execute_Isync () = I_Sync () - -let execute_Lbarx (RT, RA, RB, EH) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr_reserve (reset_vector_start EA,(1:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lharx (RT, RA, RB, EH) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr_reserve (reset_vector_start EA,(2:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lwarx (RT, RA, RB, EH) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr_reserve (reset_vector_start EA,(4:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Stbcx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA_cond (reset_vector_start EA,(1:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - MEMw_conditional (reset_vector_start EA,(1:ii),reset_vector_start (set_vector_start 0 w__2)) >>= fun status -> - read_reg_bitfield XER "SO" >>= fun w__3 -> - let CR0 = (Vector [B0;B0] 0 true) ^^ ((Vector [status] 0 true) ^^ (Vector [w__3] 0 true)) in - return () - -let execute_Sthcx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA_cond (reset_vector_start EA,(2:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__2 -> - MEMw_conditional (reset_vector_start EA,(2:ii),reset_vector_start (set_vector_start 0 w__2)) >>= fun status -> - read_reg_bitfield XER "SO" >>= fun w__3 -> - let CR0 = (Vector [B0;B0] 0 true) ^^ ((Vector [status] 0 true) ^^ (Vector [w__3] 0 true)) in - return () - -let execute_Stwcx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA_cond (reset_vector_start EA,(4:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__2 -> - MEMw_conditional (reset_vector_start EA,(4:ii),reset_vector_start (set_vector_start 0 w__2)) >>= fun status -> - read_reg_bitfield XER "SO" >>= fun w__3 -> - let CR0 = (Vector [B0;B0] 0 true) ^^ ((Vector [status] 0 true) ^^ (Vector [w__3] 0 true)) in - return () - -let execute_Ldarx (RT, RA, RB, EH) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr_reserve (reset_vector_start EA,(8:ii)) >>= fun w__2 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__2 - -let execute_Stdcx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA_cond (reset_vector_start EA,(8:ii)) >> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__2 -> - MEMw_conditional (reset_vector_start EA,(8:ii),reset_vector_start w__2) >>= fun status -> - read_reg_bitfield XER "SO" >>= fun w__3 -> - let CR0 = (Vector [B0;B0] 0 true) ^^ ((Vector [status] 0 true) ^^ (Vector [w__3] 0 true)) in - return () - -let execute_Sync L = - match L with | Vector [B0;B0] _ _ -> H_Sync () | Vector [B0;B1] _ _ -> LW_Sync () end - -let execute_Eieio () = EIEIO_Sync () - -let execute_Wait WC = return () - -let execute = function - - | B (LI,AA,LK) -> execute_B (LI,AA,LK) - | Bc (BO,BI,BD,AA,LK) -> execute_Bc (BO,BI,BD,AA,LK) - | Bclr (BO,BI,BH,LK) -> execute_Bclr (BO,BI,BH,LK) - | Bcctr (BO,BI,BH,LK) -> execute_Bcctr (BO,BI,BH,LK) - | Crand (BT,BA,BB) -> execute_Crand (BT,BA,BB) - | Crnand (BT,BA,BB) -> execute_Crnand (BT,BA,BB) - | Cror (BT,BA,BB) -> execute_Cror (BT,BA,BB) - | Crxor (BT,BA,BB) -> execute_Crxor (BT,BA,BB) - | Crnor (BT,BA,BB) -> execute_Crnor (BT,BA,BB) - | Creqv (BT,BA,BB) -> execute_Creqv (BT,BA,BB) - | Crandc (BT,BA,BB) -> execute_Crandc (BT,BA,BB) - | Crorc (BT,BA,BB) -> execute_Crorc (BT,BA,BB) - | Mcrf (BF,BFA) -> execute_Mcrf (BF,BFA) - | Sc (LEV) -> execute_Sc (LEV) - | Scv (LEV) -> execute_Scv (LEV) - | Lbz (RT,RA,D) -> execute_Lbz (RT,RA,D) - | Lbzx (RT,RA,RB) -> execute_Lbzx (RT,RA,RB) - | Lbzu (RT,RA,D) -> execute_Lbzu (RT,RA,D) - | Lbzux (RT,RA,RB) -> execute_Lbzux (RT,RA,RB) - | Lhz (RT,RA,D) -> execute_Lhz (RT,RA,D) - | Lhzx (RT,RA,RB) -> execute_Lhzx (RT,RA,RB) - | Lhzu (RT,RA,D) -> execute_Lhzu (RT,RA,D) - | Lhzux (RT,RA,RB) -> execute_Lhzux (RT,RA,RB) - | Lha (RT,RA,D) -> execute_Lha (RT,RA,D) - | Lhax (RT,RA,RB) -> execute_Lhax (RT,RA,RB) - | Lhau (RT,RA,D) -> execute_Lhau (RT,RA,D) - | Lhaux (RT,RA,RB) -> execute_Lhaux (RT,RA,RB) - | Lwz (RT,RA,D) -> execute_Lwz (RT,RA,D) - | Lwzx (RT,RA,RB) -> execute_Lwzx (RT,RA,RB) - | Lwzu (RT,RA,D) -> execute_Lwzu (RT,RA,D) - | Lwzux (RT,RA,RB) -> execute_Lwzux (RT,RA,RB) - | Lwa (RT,RA,DS) -> execute_Lwa (RT,RA,DS) - | Lwax (RT,RA,RB) -> execute_Lwax (RT,RA,RB) - | Lwaux (RT,RA,RB) -> execute_Lwaux (RT,RA,RB) - | Ld (RT,RA,DS) -> execute_Ld (RT,RA,DS) - | Ldx (RT,RA,RB) -> execute_Ldx (RT,RA,RB) - | Ldu (RT,RA,DS) -> execute_Ldu (RT,RA,DS) - | Ldux (RT,RA,RB) -> execute_Ldux (RT,RA,RB) - | Stb (RS,RA,D) -> execute_Stb (RS,RA,D) - | Stbx (RS,RA,RB) -> execute_Stbx (RS,RA,RB) - | Stbu (RS,RA,D) -> execute_Stbu (RS,RA,D) - | Stbux (RS,RA,RB) -> execute_Stbux (RS,RA,RB) - | Sth (RS,RA,D) -> execute_Sth (RS,RA,D) - | Sthx (RS,RA,RB) -> execute_Sthx (RS,RA,RB) - | Sthu (RS,RA,D) -> execute_Sthu (RS,RA,D) - | Sthux (RS,RA,RB) -> execute_Sthux (RS,RA,RB) - | Stw (RS,RA,D) -> execute_Stw (RS,RA,D) - | Stwx (RS,RA,RB) -> execute_Stwx (RS,RA,RB) - | Stwu (RS,RA,D) -> execute_Stwu (RS,RA,D) - | Stwux (RS,RA,RB) -> execute_Stwux (RS,RA,RB) - | Std (RS,RA,DS) -> execute_Std (RS,RA,DS) - | Stdx (RS,RA,RB) -> execute_Stdx (RS,RA,RB) - | Stdu (RS,RA,DS) -> execute_Stdu (RS,RA,DS) - | Stdux (RS,RA,RB) -> execute_Stdux (RS,RA,RB) - | Lhbrx (RT,RA,RB) -> execute_Lhbrx (RT,RA,RB) - | Sthbrx (RS,RA,RB) -> execute_Sthbrx (RS,RA,RB) - | Lwbrx (RT,RA,RB) -> execute_Lwbrx (RT,RA,RB) - | Stwbrx (RS,RA,RB) -> execute_Stwbrx (RS,RA,RB) - | Ldbrx (RT,RA,RB) -> execute_Ldbrx (RT,RA,RB) - | Stdbrx (RS,RA,RB) -> execute_Stdbrx (RS,RA,RB) - | Lmw (RT,RA,D) -> execute_Lmw (RT,RA,D) - | Stmw (RS,RA,D) -> execute_Stmw (RS,RA,D) - | Lswi (RT,RA,NB) -> execute_Lswi (RT,RA,NB) - | Lswx (RT,RA,RB) -> execute_Lswx (RT,RA,RB) - | Stswi (RS,RA,NB) -> execute_Stswi (RS,RA,NB) - | Stswx (RS,RA,RB) -> execute_Stswx (RS,RA,RB) - | Addi (RT,RA,SI) -> execute_Addi (RT,RA,SI) - | Addis (RT,RA,SI) -> execute_Addis (RT,RA,SI) - | Add (RT,RA,RB,OE,Rc) -> execute_Add (RT,RA,RB,OE,Rc) - | Subf (RT,RA,RB,OE,Rc) -> execute_Subf (RT,RA,RB,OE,Rc) - | Addic (RT,RA,SI) -> execute_Addic (RT,RA,SI) - | AddicDot (RT,RA,SI) -> execute_AddicDot (RT,RA,SI) - | Subfic (RT,RA,SI) -> execute_Subfic (RT,RA,SI) - | Addc (RT,RA,RB,OE,Rc) -> execute_Addc (RT,RA,RB,OE,Rc) - | Subfc (RT,RA,RB,OE,Rc) -> execute_Subfc (RT,RA,RB,OE,Rc) - | Adde (RT,RA,RB,OE,Rc) -> execute_Adde (RT,RA,RB,OE,Rc) - | Subfe (RT,RA,RB,OE,Rc) -> execute_Subfe (RT,RA,RB,OE,Rc) - | Addme (RT,RA,OE,Rc) -> execute_Addme (RT,RA,OE,Rc) - | Subfme (RT,RA,OE,Rc) -> execute_Subfme (RT,RA,OE,Rc) - | Addze (RT,RA,OE,Rc) -> execute_Addze (RT,RA,OE,Rc) - | Subfze (RT,RA,OE,Rc) -> execute_Subfze (RT,RA,OE,Rc) - | Neg (RT,RA,OE,Rc) -> execute_Neg (RT,RA,OE,Rc) - | Mulli (RT,RA,SI) -> execute_Mulli (RT,RA,SI) - | Mullw (RT,RA,RB,OE,Rc) -> execute_Mullw (RT,RA,RB,OE,Rc) - | Mulhw (RT,RA,RB,Rc) -> execute_Mulhw (RT,RA,RB,Rc) - | Mulhwu (RT,RA,RB,Rc) -> execute_Mulhwu (RT,RA,RB,Rc) - | Divw (RT,RA,RB,OE,Rc) -> execute_Divw (RT,RA,RB,OE,Rc) - | Divwu (RT,RA,RB,OE,Rc) -> execute_Divwu (RT,RA,RB,OE,Rc) - | Divwe (RT,RA,RB,OE,Rc) -> execute_Divwe (RT,RA,RB,OE,Rc) - | Divweu (RT,RA,RB,OE,Rc) -> execute_Divweu (RT,RA,RB,OE,Rc) - | Mulld (RT,RA,RB,OE,Rc) -> execute_Mulld (RT,RA,RB,OE,Rc) - | Mulhd (RT,RA,RB,Rc) -> execute_Mulhd (RT,RA,RB,Rc) - | Mulhdu (RT,RA,RB,Rc) -> execute_Mulhdu (RT,RA,RB,Rc) - | Divd (RT,RA,RB,OE,Rc) -> execute_Divd (RT,RA,RB,OE,Rc) - | Divdu (RT,RA,RB,OE,Rc) -> execute_Divdu (RT,RA,RB,OE,Rc) - | Divde (RT,RA,RB,OE,Rc) -> execute_Divde (RT,RA,RB,OE,Rc) - | Divdeu (RT,RA,RB,OE,Rc) -> execute_Divdeu (RT,RA,RB,OE,Rc) - | Cmpi (BF,L,RA,SI) -> execute_Cmpi (BF,L,RA,SI) - | Cmp (BF,L,RA,RB) -> execute_Cmp (BF,L,RA,RB) - | Cmpli (BF,L,RA,UI) -> execute_Cmpli (BF,L,RA,UI) - | Cmpl (BF,L,RA,RB) -> execute_Cmpl (BF,L,RA,RB) - | Isel (RT,RA,RB,BC) -> execute_Isel (RT,RA,RB,BC) - | Andi (RS,RA,UI) -> execute_Andi (RS,RA,UI) - | Andis (RS,RA,UI) -> execute_Andis (RS,RA,UI) - | Ori (RS,RA,UI) -> execute_Ori (RS,RA,UI) - | Oris (RS,RA,UI) -> execute_Oris (RS,RA,UI) - | Xori (RS,RA,UI) -> execute_Xori (RS,RA,UI) - | Xoris (RS,RA,UI) -> execute_Xoris (RS,RA,UI) - | And (RS,RA,RB,Rc) -> execute_And (RS,RA,RB,Rc) - | Xor (RS,RA,RB,Rc) -> execute_Xor (RS,RA,RB,Rc) - | Nand (RS,RA,RB,Rc) -> execute_Nand (RS,RA,RB,Rc) - | Or (RS,RA,RB,Rc) -> execute_Or (RS,RA,RB,Rc) - | Nor (RS,RA,RB,Rc) -> execute_Nor (RS,RA,RB,Rc) - | Eqv (RS,RA,RB,Rc) -> execute_Eqv (RS,RA,RB,Rc) - | Andc (RS,RA,RB,Rc) -> execute_Andc (RS,RA,RB,Rc) - | Orc (RS,RA,RB,Rc) -> execute_Orc (RS,RA,RB,Rc) - | Extsb (RS,RA,Rc) -> execute_Extsb (RS,RA,Rc) - | Extsh (RS,RA,Rc) -> execute_Extsh (RS,RA,Rc) - | Cntlzw (RS,RA,Rc) -> execute_Cntlzw (RS,RA,Rc) - | Cmpb (RS,RA,RB) -> execute_Cmpb (RS,RA,RB) - | Popcntb (RS,RA) -> execute_Popcntb (RS,RA) - | Popcntw (RS,RA) -> execute_Popcntw (RS,RA) - | Prtyd (RS,RA) -> execute_Prtyd (RS,RA) - | Prtyw (RS,RA) -> execute_Prtyw (RS,RA) - | Extsw (RS,RA,Rc) -> execute_Extsw (RS,RA,Rc) - | Cntlzd (RS,RA,Rc) -> execute_Cntlzd (RS,RA,Rc) - | Popcntd (RS,RA) -> execute_Popcntd (RS,RA) - | Bpermd (RS,RA,RB) -> execute_Bpermd (RS,RA,RB) - | Rlwinm (RS,RA,SH,MB,ME,Rc) -> execute_Rlwinm (RS,RA,SH,MB,ME,Rc) - | Rlwnm (RS,RA,RB,MB,ME,Rc) -> execute_Rlwnm (RS,RA,RB,MB,ME,Rc) - | Rlwimi (RS,RA,SH,MB,ME,Rc) -> execute_Rlwimi (RS,RA,SH,MB,ME,Rc) - | Rldicl (RS,RA,sh,mb,Rc) -> execute_Rldicl (RS,RA,sh,mb,Rc) - | Rldicr (RS,RA,sh,me,Rc) -> execute_Rldicr (RS,RA,sh,me,Rc) - | Rldic (RS,RA,sh,mb,Rc) -> execute_Rldic (RS,RA,sh,mb,Rc) - | Rldcl (RS,RA,RB,mb,Rc) -> execute_Rldcl (RS,RA,RB,mb,Rc) - | Rldcr (RS,RA,RB,me,Rc) -> execute_Rldcr (RS,RA,RB,me,Rc) - | Rldimi (RS,RA,sh,mb,Rc) -> execute_Rldimi (RS,RA,sh,mb,Rc) - | Slw (RS,RA,RB,Rc) -> execute_Slw (RS,RA,RB,Rc) - | Srw (RS,RA,RB,Rc) -> execute_Srw (RS,RA,RB,Rc) - | Srawi (RS,RA,SH,Rc) -> execute_Srawi (RS,RA,SH,Rc) - | Sraw (RS,RA,RB,Rc) -> execute_Sraw (RS,RA,RB,Rc) - | Sld (RS,RA,RB,Rc) -> execute_Sld (RS,RA,RB,Rc) - | Srd (RS,RA,RB,Rc) -> execute_Srd (RS,RA,RB,Rc) - | Sradi (RS,RA,sh,Rc) -> execute_Sradi (RS,RA,sh,Rc) - | Srad (RS,RA,RB,Rc) -> execute_Srad (RS,RA,RB,Rc) - | Cdtbcd (RS,RA) -> execute_Cdtbcd (RS,RA) - | Cbcdtd (RS,RA) -> execute_Cbcdtd (RS,RA) - | Addg6s (RT,RA,RB) -> execute_Addg6s (RT,RA,RB) - | Mtspr (RS,spr) -> execute_Mtspr (RS,spr) - | Mfspr (RT,spr) -> execute_Mfspr (RT,spr) - | Mtcrf (RS,FXM) -> execute_Mtcrf (RS,FXM) - | Mfcr (RT) -> execute_Mfcr (RT) - | Mtocrf (RS,FXM) -> execute_Mtocrf (RS,FXM) - | Mfocrf (RT,FXM) -> execute_Mfocrf (RT,FXM) - | Mcrxr (BF) -> execute_Mcrxr (BF) - | Dlmzb (RS,RA,RB,Rc) -> execute_Dlmzb (RS,RA,RB,Rc) - | Macchw (RT,RA,RB,OE,Rc) -> execute_Macchw (RT,RA,RB,OE,Rc) - | Macchws (RT,RA,RB,OE,Rc) -> execute_Macchws (RT,RA,RB,OE,Rc) - | Macchwu (RT,RA,RB,OE,Rc) -> execute_Macchwu (RT,RA,RB,OE,Rc) - | Macchwsu (RT,RA,RB,OE,Rc) -> execute_Macchwsu (RT,RA,RB,OE,Rc) - | Machhw (RT,RA,RB,OE,Rc) -> execute_Machhw (RT,RA,RB,OE,Rc) - | Machhws (RT,RA,RB,OE,Rc) -> execute_Machhws (RT,RA,RB,OE,Rc) - | Machhwu (RT,RA,RB,OE,Rc) -> execute_Machhwu (RT,RA,RB,OE,Rc) - | Machhwsu (RT,RA,RB,OE,Rc) -> execute_Machhwsu (RT,RA,RB,OE,Rc) - | Maclhw (RT,RA,RB,OE,Rc) -> execute_Maclhw (RT,RA,RB,OE,Rc) - | Maclhws (RT,RA,RB,OE,Rc) -> execute_Maclhws (RT,RA,RB,OE,Rc) - | Maclhwu (RT,RA,RB,OE,Rc) -> execute_Maclhwu (RT,RA,RB,OE,Rc) - | Maclhwsu (RT,RA,RB,OE,Rc) -> execute_Maclhwsu (RT,RA,RB,OE,Rc) - | Mulchw (RT,RA,RB,Rc) -> execute_Mulchw (RT,RA,RB,Rc) - | Mulchwu (RT,RA,RB,Rc) -> execute_Mulchwu (RT,RA,RB,Rc) - | Mulhhw (RT,RA,RB,Rc) -> execute_Mulhhw (RT,RA,RB,Rc) - | Mulhhwu (RT,RA,RB,Rc) -> execute_Mulhhwu (RT,RA,RB,Rc) - | Mullhw (RT,RA,RB,Rc) -> execute_Mullhw (RT,RA,RB,Rc) - | Mullhwu (RT,RA,RB,Rc) -> execute_Mullhwu (RT,RA,RB,Rc) - | Nmacchw (RT,RA,RB,OE,Rc) -> execute_Nmacchw (RT,RA,RB,OE,Rc) - | Nmacchws (RT,RA,RB,OE,Rc) -> execute_Nmacchws (RT,RA,RB,OE,Rc) - | Nmachhw (RT,RA,RB,OE,Rc) -> execute_Nmachhw (RT,RA,RB,OE,Rc) - | Nmachhws (RT,RA,RB,OE,Rc) -> execute_Nmachhws (RT,RA,RB,OE,Rc) - | Nmaclhw (RT,RA,RB,OE,Rc) -> execute_Nmaclhw (RT,RA,RB,OE,Rc) - | Nmaclhws (RT,RA,RB,OE,Rc) -> execute_Nmaclhws (RT,RA,RB,OE,Rc) - | Icbi (RA,RB) -> execute_Icbi (RA,RB) - | Icbt (CT,RA,RB) -> execute_Icbt (CT,RA,RB) - | Dcba (RA,RB) -> execute_Dcba (RA,RB) - | Dcbt (TH,RA,RB) -> execute_Dcbt (TH,RA,RB) - | Dcbtst (TH,RA,RB) -> execute_Dcbtst (TH,RA,RB) - | Dcbz (RA,RB) -> execute_Dcbz (RA,RB) - | Dcbst (RA,RB) -> execute_Dcbst (RA,RB) - | Dcbf (L,RA,RB) -> execute_Dcbf (L,RA,RB) - | Isync -> execute_Isync () - | Lbarx (RT,RA,RB,EH) -> execute_Lbarx (RT,RA,RB,EH) - | Lharx (RT,RA,RB,EH) -> execute_Lharx (RT,RA,RB,EH) - | Lwarx (RT,RA,RB,EH) -> execute_Lwarx (RT,RA,RB,EH) - | Stbcx (RS,RA,RB) -> execute_Stbcx (RS,RA,RB) - | Sthcx (RS,RA,RB) -> execute_Sthcx (RS,RA,RB) - | Stwcx (RS,RA,RB) -> execute_Stwcx (RS,RA,RB) - | Ldarx (RT,RA,RB,EH) -> execute_Ldarx (RT,RA,RB,EH) - | Stdcx (RS,RA,RB) -> execute_Stdcx (RS,RA,RB) - | Sync (L) -> execute_Sync (L) - | Eieio -> execute_Eieio () - | Wait (WC) -> execute_Wait (WC) - end - -let initial_analysis instr = - let iR = [] in - let oR = [] in - let aR = [] in - let ik = IK_simple in - let Nias = [NIAFP_successor] in - let Dia = DIAFP_none in - match instr with - | B (LI,AA,LK) -> - let oR = NIA_fp :: oR in - let iR = if bitU_to_bool AA then CIA_fp :: iR else iR in - let oR = if bitU_to_bool LK then (RFull "LR") :: oR else oR in - (if bitU_to_bool AA - then - return (set_vector_start 0 - (exts ((64:ii),reset_vector_start (LI ^^ (Vector [B0;B0] 0 true))))) - else - read_reg CIA >>= fun w__0 -> - return (set_vector_start 0 - (add_VVV - w__0 - (reset_vector_start (exts ((64:ii),reset_vector_start (LI ^^ (Vector [B0;B0] 0 true)))))))) >>= fun nia' -> - let Nias = [NIAFP_concrete_address (reset_vector_start nia')] in - let ik = IK_simple in - return (aR,oR,iR,Nias,ik) - | Bc (BO,BI,BD,AA,LK) -> - let iR = mode64bit_fp :: iR in - let iR = (RFull "CTR") :: iR in - let oR = if bitU_to_bool (~(access BO (2:ii))) then (RFull "CTR") :: oR else oR in - let iR = (RSliceBit ("CR",add_VII (reset_vector_start BI) (32:ii))) :: iR in - let oR = NIA_fp :: oR in - let iR = if bitU_to_bool AA then CIA_fp :: iR else iR in - (if bitU_to_bool AA - then - return (set_vector_start 0 - (exts ((64:ii),reset_vector_start (BD ^^ (Vector [B0;B0] 0 true))))) - else - read_reg CIA >>= fun w__1 -> - return (set_vector_start 0 - (add_VVV - w__1 - (reset_vector_start (exts ((64:ii),reset_vector_start (BD ^^ (Vector [B0;B0] 0 true)))))))) >>= fun w__2 -> - let Nias = [NIAFP_concrete_address (reset_vector_start w__2);NIAFP_successor] in - let (oR, iR) = - if bitU_to_bool LK - then - let oR = (RFull "LR") :: oR in - let iR = CIA_fp :: iR in - (oR,iR) - else (oR,iR) in - let ik = IK_cond_branch in - return (aR,oR,iR,Nias,ik) - | Bclr (BO,BI,BH,LK) -> - let iR = mode64bit_fp :: iR in - let iR = (RFull "CTR") :: iR in - let oR = if bitU_to_bool (~(access BO (2:ii))) then (RFull "CTR") :: oR else oR in - let iR = (RSliceBit ("CR",add_VII (reset_vector_start BI) (32:ii))) :: iR in - let iR = (RSlice ("LR",(0:ii),(61:ii))) :: iR in - let oR = NIA_fp :: oR in - let Nias = [NIAFP_LR;NIAFP_successor] in - let (oR, iR) = - if bitU_to_bool LK - then - let oR = (RFull "LR") :: oR in - let iR = CIA_fp :: iR in - (oR,iR) - else (oR,iR) in - let ik = IK_cond_branch in - return (aR,oR,iR,Nias,ik) - | Bcctr (BO,BI,BH,LK) -> - let iR = (RSliceBit ("CR",add_VII (reset_vector_start BI) (32:ii))) :: iR in - let iR = (RSlice ("CTR",(0:ii),(61:ii))) :: iR in - let oR = NIA_fp :: oR in - let Nias = [NIAFP_CTR;NIAFP_successor] in - let (oR, iR) = - if bitU_to_bool LK - then - let oR = (RFull "LR") :: oR in - let iR = CIA_fp :: iR in - (oR,iR) - else (oR,iR) in - let ik = IK_cond_branch in - return (aR,oR,iR,Nias,ik) - | Crand (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Crnand (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Cror (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Crxor (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Crnor (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Creqv (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Crandc (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Crorc (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Mcrf (BF,BFA) -> - let iR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BFA))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BFA))) - (35:ii))) :: - iR in - let oR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - oR in - return (aR,oR,iR,Nias,ik) - | Sc (LEV) -> - let Nias = if bitU_to_bool (eq_vec_range (LEV, (63:ii))) then [] else [NIAFP_successor] in - return (aR,oR,iR,Nias,ik) - | Scv (LEV) -> return (aR,oR,iR,Nias,ik) - | Lbz (RT,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lbzx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lbzu (RT,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lbzux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhz (RT,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhzx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhzu (RT,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhzux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lha (RT,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhax (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhau (RT,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhaux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwz (RT,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwzx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwzu (RT,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwzux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwa (RT,RA,DS) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwax (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwaux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Ld (RT,RA,DS) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Ldx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Ldu (RT,RA,DS) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Ldux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stb (RS,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stbx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stbu (RS,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stbux (RS,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Sth (RS,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Sthx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Sthu (RS,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Sthux (RS,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stw (RS,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stwx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stwu (RS,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stwux (RS,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Std (RS,RA,DS) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stdx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stdu (RS,RA,DS) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stdux (RS,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Lq (RTp,RA,DQ,PT) -> - let iR = bigendianmode_fp :: iR in - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RTp)))) :: - (RFull (access GPRs (add_VII (reset_vector_start RTp) (1:ii)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stq (RSp,RA,DS) -> - let iR = bigendianmode_fp :: iR in - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RSp)))) :: - (RFull (access GPRs (add_VII (reset_vector_start RSp) (1:ii)))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Lhbrx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Sthbrx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(55:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Lwbrx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stwbrx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(55:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(40:ii),(47:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(39:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Ldbrx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stdbrx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(55:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(40:ii),(47:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(39:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(24:ii),(31:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(16:ii),(23:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(8:ii),(15:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(0:ii),(7:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Lmw (RT,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let i = (0:ii) in - let aR = iR in - let (i, oR) = - (foreach_inc (unsigned (reset_vector_start RT),(31:ii),(1:ii)) (i,oR) - (fun r (i,oR) -> - let oR = (RFull (access GPRs r)) :: oR in - let i = i + (32:ii) in - (i,oR))) in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stmw (RS,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let i = (0:ii) in - let (i, iR) = - (foreach_inc (unsigned (reset_vector_start RS),(31:ii),(1:ii)) (i,iR) - (fun r (i,iR) -> - let iR = (RSlice (access GPRs r,(32:ii),(63:ii))) :: iR in - let i = i + (32:ii) in - (i,iR))) in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Lswi (RT,RA,NB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let r = (0:ii) in - let r = minus_VII (reset_vector_start RT) (1:ii) in - let j = (0:ii) in - let i = (32:ii) in - let (i, j, oR, r) = - (foreach_dec (if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB),(1:ii),(1:ii)) (i,j,oR,r) - (fun n (i,j,oR,r) -> - let (r, oR) = - if bitU_to_bool (eq_range (i, (32:ii))) - then - let r = modulo (r + (1:ii)) (32:ii) in - let oR = (RFull (access GPRs r)) :: oR in - (r,oR) - else (r,oR) in - let oR = (RSlice (access GPRs r,i,i + (7:ii))) :: oR in - let j = j + (8:ii) in - let i = i + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - (i,j,oR,r))) in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lswx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: - (RSlice ("XER",(57:ii),(63:ii))) :: iR in - let aR = iR in - let oR = (foreach_inc ((0:ii),(31:ii),(1:ii)) oR (fun r oR -> (RFull (access GPRs r)) :: oR)) in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stswi (RS,RA,NB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let r = (0:ii) in - let r = minus_VII (reset_vector_start RS) (1:ii) in - let j = (0:ii) in - let i = (32:ii) in - let (i, j, iR, r) = - (foreach_dec (if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB),(1:ii),(1:ii)) (i,j,iR,r) - (fun n (i,j,iR,r) -> - let r = if bitU_to_bool (eq_range (i, (32:ii))) then modulo (r + (1:ii)) (32:ii) else r in - let iR = (RSlice (access GPRs r,i,i + (7:ii))) :: iR in - let j = j + (8:ii) in - let i = i + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - (i,j,iR,r))) in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stswx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let r = (0:ii) in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: - (RSlice ("XER",(57:ii),(63:ii))) :: iR in - let aR = iR in - let r = minus_VII (reset_vector_start RS) (1:ii) in - let i = (32:ii) in - let n_top = unsigned (reset_vector_start (Vector [B1;B1;B1;B1;B1;B1;B1] 0 true)) in - let j = (0:ii) in - let (j, i, iR, r) = - (foreach_dec (n_top,(1:ii),(1:ii)) (j,i,iR,r) - (fun n (j,i,iR,r) -> - let r = if bitU_to_bool (eq_range (i, (32:ii))) then modulo (r + (1:ii)) (32:ii) else r in - let iR = (RSlice (access GPRs r,i,i + (7:ii))) :: iR in - let i = i + (8:ii) in - let j = j + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - (j,i,iR,r))) in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Addi (RT,RA,SI) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Addis (RT,RA,SI) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Add (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Subf (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Addic (RT,RA,SI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | AddicDot (RT,RA,SI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: (RField ("XER","CA")) :: oR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - return (aR,oR,iR,Nias,ik) - | Subfic (RT,RA,SI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | Addc (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Subfc (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Adde (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let iR = (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Subfe (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let iR = (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Addme (RT,RA,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Subfme (RT,RA,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Addze (RT,RA,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Subfze (RT,RA,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Neg (RT,RA,OE,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulli (RT,RA,SI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Mullw (RT,RA,RB,OE,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulhw (RT,RA,RB,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulhwu (RT,RA,RB,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divw (RT,RA,RB,OE,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divwu (RT,RA,RB,OE,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divwe (RT,RA,RB,OE,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divweu (RT,RA,RB,OE,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulld (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulhd (RT,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulhdu (RT,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divd (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divdu (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divde (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divdeu (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Cmpi (BF,L,RA,SI) -> - let iR = - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii)) - else RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - oR in - return (aR,oR,iR,Nias,ik) - | Cmp (BF,L,RA,RB) -> - let iR = - if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR - else - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = - (RSlice ("CR",unsigned (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - oR in - return (aR,oR,iR,Nias,ik) - | Cmpli (BF,L,RA,UI) -> - let iR = - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii)) - else RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - oR in - return (aR,oR,iR,Nias,ik) - | Cmpl (BF,L,RA,RB) -> - let iR = - if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR - else - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - oR in - return (aR,oR,iR,Nias,ik) - | Isel (RT,RA,RB,BC) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RSliceBit ("CR",add_VII (reset_vector_start BC) (32:ii))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Andi (RS,RA,UI) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: (RField ("XER","SO")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let oR = (RField ("CR","CR0")) :: oR in - return (aR,oR,iR,Nias,ik) - | Andis (RS,RA,UI) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: (RField ("XER","SO")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let oR = (RField ("CR","CR0")) :: oR in - return (aR,oR,iR,Nias,ik) - | Ori (RS,RA,UI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Oris (RS,RA,UI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Xori (RS,RA,UI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Xoris (RS,RA,UI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | And (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Xor (RS,RA,RB,Rc) -> - let (iR, oR) = - if bitU_to_bool (eq_vec (RS, RB)) - then - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - (iR,oR) - else - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - (iR,oR) in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Nand (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Or (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Nor (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Eqv (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Andc (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Orc (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Extsb (RS,RA,Rc) -> - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(56:ii))) :: iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: iR in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(56:ii),(63:ii))) :: oR in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(0:ii),(55:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Extsh (RS,RA,Rc) -> - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(48:ii))) :: iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(63:ii))) :: iR in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(48:ii),(63:ii))) :: oR in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(0:ii),(47:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Cntlzw (RS,RA,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Cmpb (RS,RA,RB) -> - let (oR, iR) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (oR,iR) - (fun n (oR,iR) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(8:ii) * n,((8:ii) * n) + (7:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(8:ii) * n,((8:ii) * n) + - (7:ii))) :: - iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(8:ii) * n,((8:ii) * n) + (7:ii))) :: - oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Popcntb (RS,RA) -> - let (oR, iR) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (oR,iR) - (fun i (oR,iR) -> - let iR = - (foreach_inc ((0:ii),(7:ii),(1:ii)) iR - (fun j iR -> - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(i * (8:ii)) + j)) :: iR)) in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),i * (8:ii),(i * (8:ii)) + (7:ii))) :: - oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Popcntw (RS,RA) -> - let (oR, iR) = - (foreach_inc ((0:ii),(1:ii),(1:ii)) (oR,iR) - (fun i (oR,iR) -> - let iR = - (foreach_inc ((0:ii),(31:ii),(1:ii)) iR - (fun j iR -> - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(i * (32:ii)) + j)) :: iR)) in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),i * (32:ii),(i * (32:ii)) + - (31:ii))) :: - oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Prtyd (RS,RA) -> - let iR = - (foreach_inc ((0:ii),(7:ii),(1:ii)) iR - (fun i iR -> - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(i * (8:ii)) + (7:ii))) :: iR)) in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Prtyw (RS,RA) -> - let iR = - (foreach_inc ((0:ii),(3:ii),(1:ii)) iR - (fun i iR -> - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(i * (8:ii)) + (7:ii))) :: iR)) in - let iR = - (foreach_inc ((4:ii),(7:ii),(1:ii)) iR - (fun i iR -> - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(i * (8:ii)) + (7:ii))) :: iR)) in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(0:ii),(31:ii))) :: oR in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Extsw (RS,RA,Rc) -> - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(32:ii))) :: iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Cntlzd (RS,RA,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Popcntd (RS,RA) -> - let iR = - (foreach_inc ((0:ii),(63:ii),(1:ii)) iR - (fun i iR -> (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),i)) :: iR)) in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Bpermd (RS,RA,RB) -> - let (oR, iR) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (oR,iR) - (fun i (oR,iR) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(8:ii) * i,((8:ii) * i) + (7:ii))) :: - iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Rlwinm (RS,RA,SH,MB,ME,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rlwnm (RS,RA,RB,MB,ME,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(59:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rlwimi (RS,RA,SH,MB,ME,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldicl (RS,RA,sh,mb,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldicr (RS,RA,sh,me,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldic (RS,RA,sh,mb,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldcl (RS,RA,RB,mb,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RB)),(58:ii),(63:ii))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldcr (RS,RA,RB,me,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RB)),(58:ii),(63:ii))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldimi (RS,RA,sh,mb,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Slw (RS,RA,RB,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RB)),(59:ii),(63:ii))) :: iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(58:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Srw (RS,RA,RB,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RB)),(59:ii),(63:ii))) :: iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(58:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Srawi (RS,RA,SH,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(32:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | Sraw (RS,RA,RB,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RB)),(59:ii),(63:ii))) :: iR in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: - (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(58:ii))) :: - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(32:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | Sld (RS,RA,RB,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(58:ii),(63:ii))) :: - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(57:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Srd (RS,RA,RB,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(58:ii),(63:ii))) :: - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(57:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Sradi (RS,RA,sh,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(0:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | Srad (RS,RA,RB,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(58:ii),(63:ii))) :: - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(57:ii))) :: - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(0:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | Cdtbcd (RS,RA) -> - let (oR, iR) = - (foreach_inc ((0:ii),(1:ii),(1:ii)) (oR,iR) - (fun i (oR,iR) -> - let n = i * (32:ii) in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),n + (12:ii),n + (31:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),n + (0:ii),n + (31:ii))) :: oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Cbcdtd (RS,RA) -> - let (oR, iR) = - (foreach_inc ((0:ii),(1:ii),(1:ii)) (oR,iR) - (fun i (oR,iR) -> - let n = i * (32:ii) in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),n + (8:ii),n + (31:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),n + (0:ii),n + (31:ii))) :: oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Addg6s (RT,RA,RB) -> - let iR = - (foreach_inc ((0:ii),(15:ii),(1:ii)) iR - (fun i iR -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(4:ii) * i,(63:ii))) :: iR in - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(4:ii) * i,(63:ii))) :: iR)) in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Mtspr (RS,spr) -> - let n = (slice spr (5:ii) (9:ii)) ^^ (slice spr (0:ii) (4:ii)) in - let (iR, oR) = - if bitU_to_bool (eq_vec_range (n, (1:ii))) - then - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull "XER") :: oR in - (iR,oR) - else - let iR = (RFull (access SPRs (unsigned (reset_vector_start n)))) :: iR in - let (iR, oR) = - if bitU_to_bool (eq_range (length_spr (unsigned (reset_vector_start n)), (64:ii))) - then - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access SPRs (unsigned (reset_vector_start n)))) :: oR in - (iR,oR) - else - let (iR, oR) = - if bitU_to_bool (eq_vec_range (n, (152:ii))) - then - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let oR = (RFull "CTRL") :: oR in - (iR,oR) - else (iR,oR) in - (iR,oR) in - (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mfspr (RT,spr) -> - let n = (slice spr (5:ii) (9:ii)) ^^ (slice spr (0:ii) (4:ii)) in - let iR = (RFull (access SPRs (unsigned (reset_vector_start n)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Mtcrf (RS,FXM) -> - let iR = - (RFull "CR") :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let oR = (RFull "CR") :: oR in - return (aR,oR,iR,Nias,ik) - | Mfcr (RT) -> - let iR = (RFull "CR") :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Mtocrf (RS,FXM) -> - let n = (0:ii) in - let count = (0:ii) in - let (count, n) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (count,n) - (fun i (count,n) -> - let (n, count) = - if bitU_to_bool - (eq (match (access FXM i) with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then - let n = i in - let count = count + (1:ii) in - (n,count) - else (n,count) in - (count,n))) in - let (oR, iR) = - if bitU_to_bool (eq_range (count, (1:ii))) - then - let oR = (RSlice ("CR",((4:ii) * n) + (32:ii),((4:ii) * n) + (35:ii))) :: oR in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),((4:ii) * n) + (32:ii),((4:ii) * - n) + - (35:ii))) :: - iR in - (oR,iR) - else - let oR = (RFull "CR") :: oR in - (oR,iR) in - return (aR,oR,iR,Nias,ik) - | Mfocrf (RT,FXM) -> - let n = (0:ii) in - let count = (0:ii) in - let (count, n) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (count,n) - (fun i (count,n) -> - let (n, count) = - if bitU_to_bool - (eq (match (access FXM i) with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then - let n = i in - let count = count + (1:ii) in - (n,count) - else (n,count) in - (count,n))) in - let (iR, oR) = - if bitU_to_bool (eq_range (count, (1:ii))) - then - let iR = (RSlice ("CR",((4:ii) * n) + (32:ii),((4:ii) * n) + (35:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - (iR,oR) - else - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mcrxr (BF) -> - let iR = (RSlice ("XER",(32:ii),(35:ii))) :: iR in - let oR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - (RSlice ("XER",(32:ii),(35:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Dlmzb (RS,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Macchws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Macchwu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Macchwsu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Machhws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Machhwu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Machhwsu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Maclhw (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Maclhws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Maclhwu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Maclhwsu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Mulchw (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Mulchwu (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Mulhhw (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Mulhhwu (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Mullhw (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Mullhwu (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmacchw (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmacchws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmachhw (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmachhws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmaclhw (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmaclhws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Icbi (RA,RB) -> return (aR,oR,iR,Nias,ik) - | Icbt (CT,RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcba (RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcbt (TH,RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcbtst (TH,RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcbz (RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcbst (RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcbf (L,RA,RB) -> return (aR,oR,iR,Nias,ik) - | Isync -> - let ik = IK_barrier Barrier_Isync in - return (aR,oR,iR,Nias,ik) - | Lbarx (RT,RA,RB,EH) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_reserve in - return (aR,oR,iR,Nias,ik) - | Lharx (RT,RA,RB,EH) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_reserve in - return (aR,oR,iR,Nias,ik) - | Lwarx (RT,RA,RB,EH) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_reserve in - return (aR,oR,iR,Nias,ik) - | Stbcx (RS,RA,RB) -> - let ik = IK_mem_write Write_conditional in - return (aR,oR,iR,Nias,ik) - | Sthcx (RS,RA,RB) -> - let ik = IK_mem_write Write_conditional in - return (aR,oR,iR,Nias,ik) - | Stwcx (RS,RA,RB) -> - let ik = IK_mem_write Write_conditional in - return (aR,oR,iR,Nias,ik) - | Ldarx (RT,RA,RB,EH) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_reserve in - return (aR,oR,iR,Nias,ik) - | Stdcx (RS,RA,RB) -> - let ik = IK_mem_write Write_conditional in - return (aR,oR,iR,Nias,ik) - | Sync (L) -> - let ik = - match L with - | Vector [B0;B0] _ _ -> IK_barrier Barrier_Sync - | Vector [B0;B1] _ _ -> IK_barrier Barrier_LwSync - end in - return (aR,oR,iR,Nias,ik) - | Eieio -> - let ik = IK_barrier Barrier_Eieio in - return (aR,oR,iR,Nias,ik) - | Wait (WC) -> return (aR,oR,iR,Nias,ik) - end >>= fun (aR, oR, iR, Nias, ik) -> - return (iR,oR,aR,Nias,Dia,ik) - diff --git a/power/power_embed_sequential.lem.fixed b/power/power_embed_sequential.lem.fixed deleted file mode 100644 index 7560b0a0..00000000 --- a/power/power_embed_sequential.lem.fixed +++ /dev/null @@ -1,6743 +0,0 @@ -(*Generated by Sail from generated/power.sail.*) -open import Pervasives_extra -open import Sail_impl_base -open import State -open import Sail_values -open import Power_embed_types -open import Power_extras_embed_sequential -let DEC_TO_BCD (Vector [p;q;r;s;t;u;v;w;x;y] _ _) = - let a = ((~s) &. (v &. w)) |. ((t &. (v &. (w &. s))) |. (v &. (w &. (~x)))) in - let b = (p &. (s &. (x &. (~t)))) |. ((p &. (~w)) |. (p &. (~v))) in - let c = (q &. (s &. (x &. (~t)))) |. ((q &. (~w)) |. (q &. (~v))) in - let d = r in - let e = (v &. ((~w) &. x)) |. ((s &. (v &. (w &. x))) |. ((~t) &. (v &. (x &. w)))) in - let f = (p &. (t &. (v &. (w &. (x &. (~s)))))) |. ((s &. ((~x) &. v)) |. (s &. (~v))) in - let g = (q &. (t &. (w &. (v &. (x &. (~s)))))) |. ((t &. ((~x) &. v)) |. (t &. (~v))) in - let h = u in - let i = (t &. (v &. (w &. x))) |. ((s &. (v &. (w &. x))) |. (v &. ((~w) &. (~x)))) in - let j = - (p &. ((~s) &. ((~t) &. (w &. v)))) |. - ((s &. (v &. ((~w) &. x))) |. ((p &. (w &. ((~x) &. v))) |. (w &. (~v)))) in - let k = - (q &. ((~s) &. ((~t) &. (v &. w)))) |. - ((t &. (v &. ((~w) &. x))) |. ((q &. (v &. (w &. (~x)))) |. (x &. (~v)))) in - let m = y in - Vector [a;b;c;d;e;f;g;h;i;j;k;m] 0 true - -let BCD_TO_DEC (Vector [a;b;c;d;e;f;g;h;i;j;k;m] _ _) = - let p = (f &. (a &. (i &. (~e)))) |. ((j &. (a &. (~i))) |. (b &. (~a))) in - let q = (g &. (a &. (i &. (~e)))) |. ((k &. (a &. (~i))) |. (c &. (~a))) in - let r = d in - let s = - (j &. ((~a) &. (e &. (~i)))) |. ((f &. ((~i) &. (~e))) |. ((f &. ((~a) &. (~e))) |. (e &. i))) in - let t = - (k &. ((~a) &. (e &. (~i)))) |. ((g &. ((~i) &. (~e))) |. ((g &. ((~a) &. (~e))) |. (a &. i))) in - let u = h in - let v = a |. (e |. i) in - let w = ((~e) &. (j &. (~i))) |. ((e &. i) |. a) in - let x = ((~a) &. (k &. (~i))) |. ((a &. i) |. e) in - let y = m in - Vector [p;q;r;s;t;u;v;w;x;y] 0 true - -let carry_out (_, carry) = carry - -let real_addr x = x - -let mark_as_not_likely_to_be_needed_again_anytime_soon x = () - -let EXTS_EXPLICIT (v, m) = (duplicate (access v (0:ii), m - (length (reset_vector_start v)))) ^^ v - -let MASK (start, stop) = - let mask_temp = to_vec_inc ((64:ii),(0:ii)) in - if bitU_to_bool (gt (start, stop)) - then - let mask_temp = update mask_temp start (63:ii) (duplicate (B1, (64:ii) - start)) in - update mask_temp (0:ii) stop (duplicate (B1, stop + (1:ii))) - else update mask_temp start stop (duplicate (B1, (stop - start) + (1:ii))) - -let ROTL (v, n) = (slice v n (63:ii)) ^^ (slice v (0:ii) (n - (1:ii))) - -let DOUBLE word = - let temp = to_vec_inc ((64:ii),(0:ii)) in - if bitU_to_bool - ((gt_vec_range (slice word (1:ii) (8:ii), (0:ii))) &. - (lt_vec_range (slice word (1:ii) (8:ii), (255:ii)))) - then - let temp = update temp (0:ii) (1:ii) (slice word (0:ii) (1:ii)) in - let temp = update_pos temp (2:ii) (~(access word (1:ii))) in - let temp = update_pos temp (3:ii) (~(access word (1:ii))) in - let temp = update_pos temp (4:ii) (~(access word (1:ii))) in - update - temp (5:ii) (63:ii) - (set_vector_start 5 - ((slice word (2:ii) (31:ii)) ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0] 0 true))) - else - if bitU_to_bool - ((eq_vec_range (slice word (1:ii) (8:ii), (0:ii))) &. - (neq_vec_range (slice word (9:ii) (31:ii), (0:ii)))) - then - let sign = access word (0:ii) in - let exp = (0:ii) - (126:ii) in - let frac = - (Vector [B0] 0 true) ^^ - ((slice word (9:ii) (31:ii)) ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0] 0 true)) in - let (exp, frac) = - (foreach_inc ((0:ii),(52:ii),(1:ii)) (exp,frac) - (fun i (exp,frac) -> - let (frac, exp) = - if bitU_to_bool - (eq (match (access frac (0:ii)) with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - let frac = - update frac (0:ii) (52:ii) ((slice frac (1:ii) (52:ii)) ^^ (Vector [B0] 0 true)) in - let exp = exp - (1:ii) in - (frac,exp) - else (frac,exp) in - (exp,frac))) in - let temp = update_pos temp (0:ii) sign in - let temp = - update - temp (1:ii) (11:ii) - (add_VIV (reset_vector_start (to_vec_inc ((11:ii),exp))) (1023:ii)) in - update temp (12:ii) (63:ii) (set_vector_start 12 (slice frac (1:ii) (52:ii))) - else - let temp = update temp (0:ii) (1:ii) (slice word (0:ii) (1:ii)) in - let temp = update_pos temp (2:ii) (access word (1:ii)) in - let temp = update_pos temp (3:ii) (access word (1:ii)) in - let temp = update_pos temp (4:ii) (access word (1:ii)) in - update - temp (5:ii) (63:ii) - (set_vector_start 5 - ((slice word (2:ii) (31:ii)) ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0] 0 true))) - -let SINGLE frs = - let word = to_vec_inc ((32:ii),(0:ii)) in - if bitU_to_bool - ((gt_vec_range (slice frs (1:ii) (11:ii), (896:ii))) |. - (eq_vec_range (slice frs (1:ii) (63:ii), (0:ii)))) - then - let word = update word (0:ii) (1:ii) (slice frs (0:ii) (1:ii)) in - update word (2:ii) (31:ii) (set_vector_start 2 (slice frs (5:ii) (34:ii))) - else - if bitU_to_bool - ((lteq_range_vec ((874:ii), slice frs (1:ii) (11:ii))) &. - (lteq_vec_range (slice frs (1:ii) (11:ii), (896:ii)))) - then - let sign = access frs (0:ii) in - let exp = - set_vector_start 0 (minus_VIV (reset_vector_start (slice frs (1:ii) (11:ii))) (1023:ii)) in - let frac = (Vector [B1] 0 true) ^^ (slice frs (12:ii) (63:ii)) in - let (exp, frac) = - (foreach_inc ((0:ii),(53:ii),(1:ii)) (exp,frac) - (fun i (exp,frac) -> - let (frac, exp) = - if bitU_to_bool (lt_vec_range (exp, (0:ii) - (126:ii))) - then - let frac = - update frac (0:ii) (52:ii) ((Vector [B0] 0 true) ^^ (slice frac (0:ii) (51:ii))) in - let exp = set_vector_start 0 (add_VIV (reset_vector_start exp) (1:ii)) in - (frac,exp) - else (frac,exp) in - (exp,frac))) in - word - else to_vec_inc_undef (32:ii) - -let Chop (x, y) = slice x (0:ii) y - -let byte_reverse (m', input) = - let output = to_vec_inc (length input,(0:ii)) in - let j = length (reset_vector_start input) in - let (j, output) = - (foreach_inc ((0:ii),length (reset_vector_start input),(8:ii)) (j,output) - (fun i (j,output) -> - let output = update output i (i + (7:ii)) (slice input (j - (7:ii)) j) in - let j = j - (8:ii) in - (j,output))) in - output - -let rec reverse_endianness value = - let width = length (reset_vector_start value) in - let half = quot width (2:ii) in - if bitU_to_bool (eq_range (width, (8:ii))) - then value - else - (reverse_endianness - (reset_vector_start (set_vector_start 0 (slice value half (width - (1:ii)))))) ^^ - (reverse_endianness (reset_vector_start (slice value (0:ii) (half - (1:ii))))) - -let zero_or_undef x = - let out = to_vec_inc (length x,(0:ii)) in - (foreach_inc ((0:ii),(length (reset_vector_start x)) - (1:ii),(1:ii)) out - (fun i out -> update_pos out i (if bitU_to_bool (access x i) then BU else B0))) - -let GPRs = - Vector ["GPR0";"GPR1";"GPR2";"GPR3";"GPR4";"GPR5";"GPR6";"GPR7";"GPR8";"GPR9";"GPR10";"GPR11";"GPR12";"GPR13";"GPR14";"GPR15";"GPR16";"GPR17";"GPR18";"GPR19";"GPR20"; - "GPR21";"GPR22";"GPR23";"GPR24";"GPR25";"GPR26";"GPR27";"GPR28";"GPR29";"GPR30";"GPR31"] 0 true - -let SPRs = - make_indexed_vector - [(1,"XER");(8,"LR");(9,"CTR");(259,"SPRG3");(260,"SPRG4");(261,"SPRG5"); - (262,"SPRG6");(263,"SPRG7")] - "" 0 1024 true - -let DCRs = make_indexed_vector [(0,"DCR0");(1,"DCR1")] "" 0 1024 true - -let length_spr i = - match toNatural i with - | (1:nn) -> (64:ii) - | (8:nn) -> (64:ii) - | (9:nn) -> (64:ii) - | (259:nn) -> (64:ii) - | (260:nn) -> (64:ii) - | (261:nn) -> (64:ii) - | (262:nn) -> (64:ii) - | (263:nn) -> (64:ii) - end - -let DCR = make_indexed_vector [(0,DCR0);(1,DCR1)] (UndefinedRegister 64) 0 1024 true - -let Clamp (k', x, y, z) = - let result = (0:ii) in - (if bitU_to_bool (lt (x, y)) - then - let result = y in - write_reg_bitfield VSCR "SAT" B1 >> - return result - else - if bitU_to_bool (gt (x, z)) - then - let result = z in - write_reg_bitfield VSCR "SAT" B1 >> - return result - else return x) >>= fun result -> - return (to_vec_inc (k',result)) - -let MEMw (ea, size, value) = - read_reg bigendianmode >>= fun w__0 -> - if bitU_to_bool (most_significant w__0) - then - MEMw' - (reset_vector_start ea, - size, - reset_vector_start (reverse_endianness (reset_vector_start value))) - else MEMw' (reset_vector_start ea,size,reset_vector_start value) - -let MEMr (ea, size) = - read_reg bigendianmode >>= fun w__0 -> - if bitU_to_bool (most_significant w__0) - then - MEMr' (reset_vector_start ea,size) >>= fun w__1 -> - return (reverse_endianness (reset_vector_start w__1)) - else MEMr' (reset_vector_start ea,size) - -let MEMr_reserve (ea, size) = - read_reg bigendianmode >>= fun w__0 -> - if bitU_to_bool (most_significant w__0) - then - MEMr_reserve' (reset_vector_start ea,size) >>= fun w__1 -> - return (reverse_endianness (reset_vector_start w__1)) - else MEMr_reserve' (reset_vector_start ea,size) - -let MEMw_conditional (ea, size, value) = - read_reg bigendianmode >>= fun w__0 -> - if bitU_to_bool (most_significant w__0) - then - MEMw_conditional' - (reset_vector_start ea, - size, - reset_vector_start (reverse_endianness (reset_vector_start value))) - else MEMw_conditional' (reset_vector_start ea,size,reset_vector_start value) - -let set_SO_OV overflow = - write_reg_bitfield XER "OV" overflow >> - read_reg_bitfield XER "SO" >>= fun w__0 -> - write_reg_bitfield XER "SO" (w__0 |. overflow) - -let supported_instructions instr = - match instr with - | Sync ((Vector [B1;B0] _ _)) -> Nothing - | Sync ((Vector [B1;B1] _ _)) -> Nothing - | _ -> Just instr - end - -let CIA_fp = RFull "CIA" - -let NIA_fp = RFull "NIA" - -let mode64bit_fp = RFull "mode64bit" - -let bigendianmode_fp = RFull "bigendianmode" - -let set_overflow_cr0 (target_register, new_xer_so) = - let m = (0:ii) in - let c = to_vec_inc ((3:ii),(0:ii)) in - let zero = to_vec_inc ((64:ii),(0:ii)) in - read_reg mode64bit >>= fun w__0 -> - let m = if bitU_to_bool (most_significant w__0) then (0:ii) else (32:ii) in - let c = - if bitU_to_bool (lt_vec_signed (slice target_register m (63:ii), slice zero m (63:ii))) - then Vector [B1;B0;B0] 0 true - else - if bitU_to_bool (gt_vec_signed (slice target_register m (63:ii), slice zero m (63:ii))) - then Vector [B0;B1;B0] 0 true - else Vector [B0;B0;B1] 0 true in - write_reg_field CR "CR0" (set_vector_start 32 (c ^^ (Vector [new_xer_so] 0 true))) - -let SPR = - make_indexed_vector - [(1,XER);(8,LR);(9,CTR);(259,SPRG3);(260,SPRG4);(261,SPRG5); - (262,SPRG6);(263,SPRG7)] - (UndefinedRegister 64) 0 1024 true - -let FPRp = - make_indexed_vector - [(0,RegisterPair FPR0 FPR1);(2,RegisterPair FPR2 FPR3);(4,RegisterPair FPR4 FPR5);(6,RegisterPair FPR6 FPR7);(8,RegisterPair FPR8 FPR9);(10,RegisterPair FPR10 FPR11); - (12,RegisterPair FPR12 FPR13);(14,RegisterPair FPR14 FPR15);(16,RegisterPair FPR16 FPR17);(18,RegisterPair FPR18 FPR19);(20,RegisterPair FPR20 FPR21);(22,RegisterPair FPR22 FPR23); - (24,RegisterPair FPR24 FPR25);(26,RegisterPair FPR26 FPR27);(28,RegisterPair FPR28 FPR29);(30,RegisterPair FPR30 FPR31)] - (UndefinedRegister 128) 0 32 true - -let illegal_instructions_pred instr = - match instr with - | Bcctr (BO,BI,BH,LK) -> ~(access BO (2:ii)) - | Lbzu (RT,RA,D) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lbzux (RT,RA,_) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lhzu (RT,RA,D) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lhzux (RT,RA,RB) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lhau (RT,RA,D) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lhaux (RT,RA,RB) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lwzu (RA,RT,D) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lwzux (RT,RA,RB) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Lwaux (RA,RT,RB) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Ldu (RT,RA,DS) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Ldux (RT,RA,RB) -> (eq_vec_range (RA, (0:ii))) |. (eq_vec (RA, RT)) - | Stbu (RS,RA,D) -> eq_vec_range (RA, (0:ii)) - | Stbux (RS,RA,RB) -> eq_vec_range (RA, (0:ii)) - | Sthu (RS,RA,RB) -> eq_vec_range (RA, (0:ii)) - | Sthux (RS,RA,RB) -> eq_vec_range (RA, (0:ii)) - | Stwu (RS,RA,D) -> eq_vec_range (RA, (0:ii)) - | Stwux (RS,RA,RB) -> eq_vec_range (RA, (0:ii)) - | Stdu (RS,RA,DS) -> eq_vec_range (RA, (0:ii)) - | Stdux (RS,RA,RB) -> eq_vec_range (RA, (0:ii)) - | Lmw (RT,RA,D) -> - (eq_vec_range (RA, (0:ii))) |. ((lteq_vec (RT, RA)) &. (lteq_vec_range (RA, (31:ii)))) - | Lswi (RT,RA,NB) -> - let n = - if bitU_to_bool (~(eq_vec_range (NB, (0:ii)))) - then unsigned (reset_vector_start NB) - else (32:ii) in - let ceil = - if bitU_to_bool (eq_range (modulo n (4:ii), (0:ii))) - then quot n (4:ii) - else (quot n (4:ii)) + (1:ii) in - (lteq_vec (RT, RA)) &. - (lteq_vec - (RA, - minus_VIV - (reset_vector_start (set_vector_start 0 (add_VIV (reset_vector_start RT) ceil))) - (1:ii))) - | Lq (RTp,RA,DQ,Pt) -> - (eq_vec_range (minus_VIV (reset_vector_start RTp) (2:ii), (1:ii))) |. (eq_vec (RTp, RA)) - | Stq (RSp,RA,RS) -> eq_vec_range (minus_VIV (reset_vector_start RSp) (2:ii), (1:ii)) - | Mtspr (RS,spr) -> - ~((eq_vec_range (spr, (1:ii))) |. - ((eq_vec_range (spr, (8:ii))) |. - ((eq_vec_range (spr, (9:ii))) |. - ((eq_vec_range (spr, (256:ii))) |. - ((eq_vec_range (spr, (512:ii))) |. - ((eq_vec_range (spr, (896:ii))) |. (eq_vec_range (spr, (898:ii))))))))) - | _ -> B0 - end - -let GPR = - Vector [GPR0;GPR1;GPR2;GPR3;GPR4;GPR5;GPR6;GPR7;GPR8;GPR9;GPR10;GPR11;GPR12;GPR13;GPR14;GPR15;GPR16;GPR17;GPR18;GPR19;GPR20; - GPR21;GPR22;GPR23;GPR24;GPR25;GPR26;GPR27;GPR28;GPR29;GPR30;GPR31] 0 true - -let FPR = - Vector [FPR0;FPR1;FPR2;FPR3;FPR4;FPR5;FPR6;FPR7;FPR8;FPR9;FPR10;FPR11;FPR12;FPR13;FPR14;FPR15;FPR16;FPR17;FPR18;FPR19;FPR20; - FPR21;FPR22;FPR23;FPR24;FPR25;FPR26;FPR27;FPR28;FPR29;FPR30;FPR31] 0 true - -let VR = - Vector [VR0;VR1;VR2;VR3;VR4;VR5;VR6;VR7;VR8;VR9;VR10;VR11;VR12;VR13;VR14;VR15;VR16;VR17;VR18;VR19;VR20; - VR21;VR22;VR23;VR24;VR25;VR26;VR27;VR28;VR29;VR30;VR31] 0 true - -let decode = function - | ((Vector [B0;B1;B0;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;AA;LK] _ _) as instr) -> - let LI = slice_raw instr (6:ii) (29:ii) in - Just (B (reset_vector_start LI,AA,LK)) - | ((Vector [B0;B1;B0;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;AA;LK] _ _) as instr) -> - let BO = slice_raw instr (6:ii) (10:ii) in - let BI = slice_raw instr (11:ii) (15:ii) in - let BD = slice_raw instr (16:ii) (29:ii) in - Just (Bc (reset_vector_start BO,reset_vector_start BI,reset_vector_start BD,AA,LK)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B0;B0;B0;LK] _ _) as instr) -> - let BO = slice_raw instr (6:ii) (10:ii) in - let BI = slice_raw instr (11:ii) (15:ii) in - let BH = slice_raw instr (19:ii) (20:ii) in - Just (Bclr (reset_vector_start BO,reset_vector_start BI,reset_vector_start BH,LK)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B0;B0;B0;B0;LK] _ _) as instr) -> - let BO = slice_raw instr (6:ii) (10:ii) in - let BI = slice_raw instr (11:ii) (15:ii) in - let BH = slice_raw instr (19:ii) (20:ii) in - Just (Bcctr (reset_vector_start BO,reset_vector_start BI,reset_vector_start BH,LK)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B0;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crand (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B1;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crnand (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B0;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Cror (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B0;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crxor (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crnor (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B1;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Creqv (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crandc (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B1;B0;B0;B0;B0;B1;_] _ _) as instr) -> - let BT = slice_raw instr (6:ii) (10:ii) in - let BA = slice_raw instr (11:ii) (15:ii) in - let BB = slice_raw instr (16:ii) (20:ii) in - Just (Crorc (reset_vector_start BT,reset_vector_start BA,reset_vector_start BB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - let BFA = slice_raw instr (11:ii) (13:ii) in - Just (Mcrf (reset_vector_start BF,reset_vector_start BFA)) - | ((Vector [B0;B1;B0;B0;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;_] _ _) as instr) -> - let LEV = slice_raw instr (20:ii) (26:ii) in - Just (Sc (reset_vector_start LEV)) - | ((Vector [B0;B1;B0;B0;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1] _ _) as instr) -> - let LEV = slice_raw instr (20:ii) (26:ii) in - Just (Scv (reset_vector_start LEV)) - | ((Vector [B1;B0;B0;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lbz (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lbzx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lbzu (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lbzux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lhz (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lhzx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B0;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lhzu (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lhzux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lha (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lhax (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lhau (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lhaux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lwz (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwzx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B0;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lwzu (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwzux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Lwa (reset_vector_start RT,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwax (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B1;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwaux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Ld (reset_vector_start RT,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Ldx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Ldu (reset_vector_start RT,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Ldux (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Stb (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stbx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Stbu (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stbux (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Sth (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sthx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B1;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Sthu (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sthux (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Stw (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stwx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B0;B1;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Stwu (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B1;B1;B0;B1;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stwux (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Std (reset_vector_start RS,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stdx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Stdu (reset_vector_start RS,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B1;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stdux (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B1;B1;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RTp = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DQ = slice_raw instr (16:ii) (27:ii) in - let PT = slice_raw instr (28:ii) (31:ii) in - Just (Lq (reset_vector_start RTp,reset_vector_start RA,reset_vector_start DQ,reset_vector_start PT)) - | ((Vector [B1;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0] _ _) as instr) -> - let RSp = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let DS = slice_raw instr (16:ii) (29:ii) in - Just (Stq (reset_vector_start RSp,reset_vector_start RA,reset_vector_start DS)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lhbrx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sthbrx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwbrx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stwbrx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B0;B1;B0;B0;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Ldbrx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B0;B0;B1;B0;B1;B0;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stdbrx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B1;B0;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Lmw (reset_vector_start RT,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B1;B0;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let D = slice_raw instr (16:ii) (31:ii) in - Just (Stmw (reset_vector_start RS,reset_vector_start RA,reset_vector_start D)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B1;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let NB = slice_raw instr (16:ii) (20:ii) in - Just (Lswi (reset_vector_start RT,reset_vector_start RA,reset_vector_start NB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lswx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B1;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let NB = slice_raw instr (16:ii) (20:ii) in - Just (Stswi (reset_vector_start RS,reset_vector_start RA,reset_vector_start NB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B0;B0;B1;B0;B1;B0;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stswx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B0;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Addi (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B0;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Addis (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B0;B0;B0;B0;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Add (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Subf (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B1;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Addic (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B0;B1;B1;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (AddicDot (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B0;B1;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Subfic (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B0;B0;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Addc (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Subfc (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B0;B0;B0;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Adde (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B0;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Subfe (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Addme (reset_vector_start RT,reset_vector_start RA,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Subfme (reset_vector_start RT,reset_vector_start RA,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B0;B0;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Addze (reset_vector_start RT,reset_vector_start RA,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Subfze (reset_vector_start RT,reset_vector_start RA,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B1;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Neg (reset_vector_start RT,reset_vector_start RA,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Mulli (reset_vector_start RT,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mullw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B1;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B0;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B1;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divwe (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B0;B0;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divweu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulld (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhd (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhdu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B1;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divd (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B0;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divdu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B1;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divde (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B0;B0;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Divdeu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B1;B0;B1;B1;_;_;_;_;L;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SI = slice_raw instr (16:ii) (31:ii) in - Just (Cmpi (reset_vector_start BF,L,reset_vector_start RA,reset_vector_start SI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;L;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Cmp (reset_vector_start BF,L,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B0;B1;B0;B1;B0;_;_;_;_;L;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Cmpli (reset_vector_start BF,L,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;L;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B0;B0;B0;B0;B0;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Cmpl (reset_vector_start BF,L,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - let BC = slice_raw instr (21:ii) (25:ii) in - Just (Isel (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,reset_vector_start BC)) - | ((Vector [B0;B1;B1;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Andi (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B1;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Andis (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B0;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Ori (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B0;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Oris (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B0;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Xori (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let UI = slice_raw instr (16:ii) (31:ii) in - Just (Xoris (reset_vector_start RS,reset_vector_start RA,reset_vector_start UI)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (And (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B1;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Xor (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B0;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nand (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B1;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Or (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B1;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nor (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B0;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Eqv (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Andc (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B0;B1;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Orc (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B0;B1;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Extsb (reset_vector_start RS,reset_vector_start RA,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B0;B0;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Extsh (reset_vector_start RS,reset_vector_start RA,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Cntlzw (reset_vector_start RS,reset_vector_start RA,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B1;B1;B1;B1;B0;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Cmpb (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B1;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Popcntb (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B1;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Popcntw (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B1;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Prtyd (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Prtyw (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B1;B0;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Extsw (reset_vector_start RS,reset_vector_start RA,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Cntlzd (reset_vector_start RS,reset_vector_start RA,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B1;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Popcntd (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B1;B1;B1;B1;B0;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Bpermd (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B0;B1;B0;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SH = slice_raw instr (16:ii) (20:ii) in - let MB = slice_raw instr (21:ii) (25:ii) in - let ME = slice_raw instr (26:ii) (30:ii) in - Just (Rlwinm (reset_vector_start RS,reset_vector_start RA,reset_vector_start SH,reset_vector_start MB,reset_vector_start ME,Rc)) - | ((Vector [B0;B1;B0;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - let MB = slice_raw instr (21:ii) (25:ii) in - let ME = slice_raw instr (26:ii) (30:ii) in - Just (Rlwnm (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,reset_vector_start MB,reset_vector_start ME,Rc)) - | ((Vector [B0;B1;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SH = slice_raw instr (16:ii) (20:ii) in - let MB = slice_raw instr (21:ii) (25:ii) in - let ME = slice_raw instr (26:ii) (30:ii) in - Just (Rlwimi (reset_vector_start RS,reset_vector_start RA,reset_vector_start SH,reset_vector_start MB,reset_vector_start ME,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let mb = slice_raw instr (21:ii) (26:ii) in - Just (Rldicl (reset_vector_start RS,reset_vector_start RA,reset_vector_start ((slice instr - (16:ii) - (20:ii)) ^^ - (slice instr - (30:ii) - (30:ii))),reset_vector_start mb,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let me = slice_raw instr (21:ii) (26:ii) in - Just (Rldicr (reset_vector_start RS,reset_vector_start RA,reset_vector_start ((slice instr - (16:ii) - (20:ii)) ^^ - (slice instr - (30:ii) - (30:ii))),reset_vector_start me,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let mb = slice_raw instr (21:ii) (26:ii) in - Just (Rldic (reset_vector_start RS,reset_vector_start RA,reset_vector_start ((slice instr - (16:ii) (20:ii)) ^^ - (slice instr - (30:ii) (30:ii))),reset_vector_start mb,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - let mb = slice_raw instr (21:ii) (26:ii) in - Just (Rldcl (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,reset_vector_start mb,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B1;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - let me = slice_raw instr (21:ii) (26:ii) in - Just (Rldcr (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,reset_vector_start me,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let mb = slice_raw instr (21:ii) (26:ii) in - Just (Rldimi (reset_vector_start RS,reset_vector_start RA,reset_vector_start ((slice instr - (16:ii) - (20:ii)) ^^ - (slice instr - (30:ii) - (30:ii))),reset_vector_start mb,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Slw (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Srw (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B0;B1;B1;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let SH = slice_raw instr (16:ii) (20:ii) in - Just (Srawi (reset_vector_start RS,reset_vector_start RA,reset_vector_start SH,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B0;B0;B1;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sraw (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sld (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B1;B1;B0;B1;B1;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Srd (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B0;B1;B1;B1;B0;B1;_;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Sradi (reset_vector_start RS,reset_vector_start RA,reset_vector_start ((slice instr - (16:ii) (20:ii)) ^^ - (slice instr - (30:ii) (30:ii))),Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B0;B0;B1;B1;B0;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Srad (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B0;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Cdtbcd (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B1;B1;B1;B0;B1;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - Just (Cbcdtd (reset_vector_start RS,reset_vector_start RA)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B0;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Addg6s (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B1;B0;B1;B0;B0;B1;B1;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let spr = slice_raw instr (11:ii) (20:ii) in - Just (Mtspr (reset_vector_start RS,reset_vector_start spr)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B1;B0;B1;B0;B0;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let spr = slice_raw instr (11:ii) (20:ii) in - Just (Mfspr (reset_vector_start RT,reset_vector_start spr)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;B0;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B0;B0;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let FXM = slice_raw instr (12:ii) (19:ii) in - Just (Mtcrf (reset_vector_start RS,reset_vector_start FXM)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;B0;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B0;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - Just (Mfcr (reset_vector_start RT)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;B1;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B0;B0;B0;_] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let FXM = slice_raw instr (12:ii) (19:ii) in - Just (Mtocrf (reset_vector_start RS,reset_vector_start FXM)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;B1;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B0;B1;B1;_] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let FXM = slice_raw instr (12:ii) (19:ii) in - Just (Mfocrf (reset_vector_start RT,reset_vector_start FXM)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B0;B0;B0;B0;B0;B0;B0;_] _ _) as instr) -> - let BF = slice_raw instr (6:ii) (8:ii) in - Just (Mcrxr (reset_vector_start BF)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B0;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dlmzb (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B0;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Macchw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Macchws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B0;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Macchwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Macchwsu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Machhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B1;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Machhws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Machhwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B1;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Machhwsu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Maclhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B1;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Maclhws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Maclhwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B0;B0;B1;B1;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Maclhwsu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulchw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulchwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mulhhwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B1;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mullhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B1;B0;B0;B0;B1;B0;B0;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Mullhwu (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B0;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmacchw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B1;B1;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmacchws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B0;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmachhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B0;B0;B1;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmachhws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B0;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmaclhw (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B0;B0;B1;B0;B0;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;OE;B1;B1;B1;B1;B0;B1;B1;B1;B0;Rc] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Nmaclhws (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,OE,Rc)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B1;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Icbi (reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let CT = slice_raw instr (7:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Icbt (reset_vector_start CT,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B1;B1;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcba (reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B1;B0;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let TH = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcbt (reset_vector_start TH,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B1;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let TH = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcbtst (reset_vector_start TH,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B1;B1;B1;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcbz (reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcbst (reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let L = slice_raw instr (9:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Dcbf (reset_vector_start L,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B0;B0;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - Just (Isync) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B0;B1;B0;B0;EH] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lbarx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,EH)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B1;B1;B0;B1;B0;B0;EH] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lharx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,EH)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B0;B1;B0;B1;B0;B0;EH] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Lwarx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,EH)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B0;B1;B1;B0;B1;B1;B0;B1] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stbcx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B1;B1;B0;B1;B0;B1;B1;B0;B1] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Sthcx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B0;B0;B1;B0;B1;B1;B0;B1] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stwcx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B1;B0;B1;B0;B1;B0;B0;EH] _ _) as instr) -> - let RT = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Ldarx (reset_vector_start RT,reset_vector_start RA,reset_vector_start RB,EH)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B1;B1;B0;B1;B0;B1;B1;B0;B1] _ _) as instr) -> - let RS = slice_raw instr (6:ii) (10:ii) in - let RA = slice_raw instr (11:ii) (15:ii) in - let RB = slice_raw instr (16:ii) (20:ii) in - Just (Stdcx (reset_vector_start RS,reset_vector_start RA,reset_vector_start RB)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B0;B0;B1;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - let L = slice_raw instr (9:ii) (10:ii) in - Just (Sync (reset_vector_start L)) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B1;B1;B0;B1;B0;B1;B0;B1;B1;B0;_] _ _) as instr) -> - Just (Eieio) - | ((Vector [B0;B1;B1;B1;B1;B1;_;_;_;_;_;_;_;_;_;_;_;_;_;_;_;B0;B0;B0;B0;B1;B1;B1;B1;B1;B0;_] _ _) as instr) -> - let WC = slice_raw instr (9:ii) (10:ii) in - Just (Wait (reset_vector_start WC)) - | _ -> Nothing - end - -let illegal_instructions instr = - if bitU_to_bool (illegal_instructions_pred instr) - then Nothing - else Just instr - -let recalculate_lswx_reg_footprint instr = - let iR = [] in - let oR = [] in - let Nias = [NIAFP_successor] in - let Dia = DIAFP_none in - let ik = IK_mem_read Read_plain in - let (RT, RA, RB) = match instr with | Lswx (RT,RA,RB) -> (RT,RA,RB) end in - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let r = (0:ii) in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: - (RSlice ("XER",(57:ii),(63:ii))) :: iR in - let aR = iR in - let r = minus_VII (reset_vector_start RT) (1:ii) in - let i = (32:ii) in - read_reg_range XER (57:ii) (63:ii) >>= fun w__0 -> - let n_top = unsigned (reset_vector_start w__0) in - let (r, oR) = - if bitU_to_bool (eq_range (n_top, (0:ii))) - then - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - (r,oR) - else - let j = (0:ii) in - let n_r = quot n_top (4:ii) in - let n_mod = modulo n_top (4:ii) in - let n_r = if bitU_to_bool (eq_range (n_mod, (0:ii))) then n_r else n_r + (1:ii) in - let (oR, j, r) = - (foreach_dec (n_r,(1:ii),(1:ii)) (oR,j,r) - (fun n (oR,j,r) -> - let r = modulo (r + (1:ii)) (32:ii) in - let j = j + (32:ii) in - let oR = (RFull (access GPRs r)) :: oR in - (oR,j,r))) in - (r,oR) in - return (iR,oR,aR,Nias,Dia,ik) - -let recalculate_stswx_reg_footprint instr = - let iR = [] in - let oR = [] in - let Nias = [NIAFP_successor] in - let Dia = DIAFP_none in - let ik = IK_mem_write Write_plain in - let (RS, RA, RB) = match instr with | Stswx (RS,RA,RB) -> (RS,RA,RB) end in - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let r = (0:ii) in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: - (RSlice ("XER",(57:ii),(63:ii))) :: iR in - let aR = iR in - let r = minus_VII (reset_vector_start RS) (1:ii) in - let i = (32:ii) in - read_reg_range XER (57:ii) (63:ii) >>= fun w__0 -> - let n_top = unsigned (reset_vector_start w__0) in - let j = (0:ii) in - let (j, i, iR, r) = - (foreach_dec (n_top,(1:ii),(1:ii)) (j,i,iR,r) - (fun n (j,i,iR,r) -> - let r = if bitU_to_bool (eq_range (i, (32:ii))) then modulo (r + (1:ii)) (32:ii) else r in - let iR = (RSlice (access GPRs r,i,i + (7:ii))) :: iR in - let i = i + (8:ii) in - let j = j + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - (j,i,iR,r))) in - let ik = IK_mem_write Write_plain in - return (iR,oR,aR,Nias,Dia,ik) - - - -let execute_B (LI, AA, LK) = - (if bitU_to_bool AA - then - write_reg - NIA - (set_vector_start 0 (exts ((64:ii),reset_vector_start (LI ^^ (Vector [B0;B0] 0 true))))) - else - read_reg CIA >>= fun w__0 -> - write_reg - NIA - (set_vector_start 0 - (add_VVV - w__0 - (reset_vector_start (exts ((64:ii),reset_vector_start (LI ^^ (Vector [B0;B0] 0 true)))))))) >> - if bitU_to_bool LK - then - read_reg CIA >>= fun w__1 -> - write_reg LR (set_vector_start 0 (add_VIV w__1 (4:ii))) - else return () - -let execute_Bc (BO, BI, BD, AA, LK) = - let M = (0:ii) in - read_reg mode64bit >>= fun w__0 -> - let M = if bitU_to_bool (most_significant w__0) then (0:ii) else (32:ii) in - read_reg CTR >>= fun ctr_temp -> - (if bitU_to_bool (~(access BO (2:ii))) - then - let ctr_temp = set_vector_start 0 (minus_VIV (reset_vector_start ctr_temp) (1:ii)) in - write_reg CTR ctr_temp >> - return ctr_temp - else return ctr_temp) >>= fun ctr_temp -> - let ctr_ok = - (access BO (2:ii)) |. - ((~(eq_vec_range (slice ctr_temp M (63:ii), (0:ii)))) +. (access BO (3:ii))) in - read_reg_bit CR (add_VII (reset_vector_start BI) (32:ii)) >>= fun w__1 -> - let cond_ok = (access BO (0:ii)) |. (w__1 +. (~(access BO (1:ii)))) in - (if bitU_to_bool (ctr_ok &. cond_ok) - then - if bitU_to_bool AA - then - write_reg - NIA - (set_vector_start 0 (exts ((64:ii),reset_vector_start (BD ^^ (Vector [B0;B0] 0 true))))) - else - read_reg CIA >>= fun w__2 -> - write_reg - NIA - (set_vector_start 0 - (add_VVV - w__2 - (reset_vector_start (exts ((64:ii),reset_vector_start (BD ^^ (Vector [B0;B0] 0 true))))))) - else return ()) >> - if bitU_to_bool LK - then - read_reg CIA >>= fun w__3 -> - write_reg LR (set_vector_start 0 (add_VIV w__3 (4:ii))) - else return () - -let execute_Bclr (BO, BI, BH, LK) = - let M = (0:ii) in - read_reg mode64bit >>= fun w__0 -> - let M = if bitU_to_bool (most_significant w__0) then (0:ii) else (32:ii) in - read_reg CTR >>= fun ctr_temp -> - (if bitU_to_bool (~(access BO (2:ii))) - then - let ctr_temp = set_vector_start 0 (minus_VIV (reset_vector_start ctr_temp) (1:ii)) in - write_reg CTR ctr_temp >> - return ctr_temp - else return ctr_temp) >>= fun ctr_temp -> - let ctr_ok = - (access BO (2:ii)) |. - ((~(eq_vec_range (slice ctr_temp M (63:ii), (0:ii)))) +. (access BO (3:ii))) in - read_reg_bit CR (add_VII (reset_vector_start BI) (32:ii)) >>= fun w__1 -> - let cond_ok = (access BO (0:ii)) |. (w__1 +. (~(access BO (1:ii)))) in - (if bitU_to_bool (ctr_ok &. cond_ok) - then - read_reg_range LR (0:ii) (61:ii) >>= fun w__2 -> - write_reg NIA (w__2 ^^ (Vector [B0;B0] 0 true)) - else return ()) >> - if bitU_to_bool LK - then - read_reg CIA >>= fun w__3 -> - write_reg LR (set_vector_start 0 (add_VIV w__3 (4:ii))) - else return () - -let execute_Bcctr (BO, BI, BH, LK) = - read_reg_bit CR (add_VII (reset_vector_start BI) (32:ii)) >>= fun w__0 -> - let cond_ok = (access BO (0:ii)) |. (w__0 +. (~(access BO (1:ii)))) in - (if bitU_to_bool cond_ok - then - read_reg_range CTR (0:ii) (61:ii) >>= fun w__1 -> - write_reg NIA (w__1 ^^ (Vector [B0;B0] 0 true)) - else return ()) >> - if bitU_to_bool LK - then - read_reg CIA >>= fun w__2 -> - write_reg LR (set_vector_start 0 (add_VIV w__2 (4:ii))) - else return () - -let execute_Crand (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 &. w__1) - -let execute_Crnand (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (~(w__0 &. w__1)) - -let execute_Cror (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 |. w__1) - -let execute_Crxor (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 +. w__1) - -let execute_Crnor (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (~(w__0 |. w__1)) - -let execute_Creqv (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 +. (~w__1)) - -let execute_Crandc (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 &. (~w__1)) - -let execute_Crorc (BT, BA, BB) = - read_reg_bit CR (add_VII (reset_vector_start BA) (32:ii)) >>= fun w__0 -> - read_reg_bit CR (add_VII (reset_vector_start BB) (32:ii)) >>= fun w__1 -> - write_reg_bit CR (add_VII (reset_vector_start BT) (32:ii)) (w__0 |. (~w__1)) - -let execute_Mcrf (BF, BFA) = - read_reg_range CR - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BFA))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BFA))) (35:ii)) >>= fun w__0 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - w__0 - -let execute_Sc LEV = return () - -let execute_Scv LEV = return () - -let execute_Lbz (RT, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMr (reset_vector_start EA,(1:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lbzx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(1:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lbzu (RT, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(1:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lbzux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(1:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lhz (RT, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lhzx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lhzu (RT, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lhzux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lha (RT, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__1))) - -let execute_Lhax (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__2))) - -let execute_Lhau (RT, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__1))) - -let execute_Lhaux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(2:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__2))) - -let execute_Lwz (RT, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lwzx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lwzu (RT, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1) - -let execute_Lwzux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lwa (RT, RA, DS) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV - (reset_vector_start b) - (reset_vector_start (exts ((64:ii),reset_vector_start (DS ^^ (Vector [B0;B0] 0 true)))))) in - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__1 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__1))) - -let execute_Lwax (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__2))) - -let execute_Lwaux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(4:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start w__2))) - -let execute_Ld (RT, RA, DS) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV - (reset_vector_start b) - (reset_vector_start (exts ((64:ii),reset_vector_start (DS ^^ (Vector [B0;B0] 0 true)))))) in - MEMr (reset_vector_start EA,(8:ii)) >>= fun w__1 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__1 - -let execute_Ldx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(8:ii)) >>= fun w__2 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__2 - -let execute_Ldu (RT, RA, DS) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start (DS ^^ (Vector [B0;B0] 0 true)))))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(8:ii)) >>= fun w__1 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__1 - -let execute_Ldux (RT, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - MEMr (reset_vector_start EA,(8:ii)) >>= fun w__2 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__2 - -let execute_Stb (RS, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(1:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(1:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Stbx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(1:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(1:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Stbu (RS, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(1:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(1:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Stbux (RS, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(1:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(1:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Sth (RS, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(2:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(2:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Sthx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(2:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(2:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Sthu (RS, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(2:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(2:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Sthux (RS, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(2:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(2:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Stw (RS, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(4:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(4:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Stwx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(4:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(4:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Stwu (RS, RA, D) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start w__0) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - MEMw_EA (reset_vector_start EA,(4:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - MEMw (reset_vector_start EA,(4:ii),reset_vector_start (set_vector_start 0 w__1)) - -let execute_Stwux (RS, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(4:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__2 -> - MEMw (reset_vector_start EA,(4:ii),reset_vector_start (set_vector_start 0 w__2)) - -let execute_Std (RS, RA, DS) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV - (reset_vector_start b) - (reset_vector_start (exts ((64:ii),reset_vector_start (DS ^^ (Vector [B0;B0] 0 true)))))) in - MEMw_EA (reset_vector_start EA,(8:ii)) >> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__1 -> - MEMw (reset_vector_start EA,(8:ii),reset_vector_start w__1) - -let execute_Stdx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(8:ii)) >> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__2 -> - MEMw (reset_vector_start EA,(8:ii),reset_vector_start w__2) - -let execute_Stdu (RS, RA, DS) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let EA = - set_vector_start 0 - (add_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start (DS ^^ (Vector [B0;B0] 0 true)))))) in - MEMw_EA (reset_vector_start EA,(8:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__1 -> - MEMw (reset_vector_start EA,(8:ii),reset_vector_start w__1) - -let execute_Stdux (RS, RA, RB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(8:ii)) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) EA >> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__2 -> - MEMw (reset_vector_start EA,(8:ii),reset_vector_start w__2) - -let execute_Lhbrx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(2:ii)) >>= fun load_data -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - ((slice load_data (8:ii) (15:ii)) ^^ (slice load_data (0:ii) (7:ii)))) - -let execute_Sthbrx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(2:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (55:ii) >>= fun w__3 -> - MEMw (reset_vector_start EA,(2:ii),reset_vector_start (w__2 ^^ w__3)) - -let execute_Lwbrx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(4:ii)) >>= fun load_data -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - ((slice load_data (24:ii) (31:ii)) ^^ - ((slice load_data (16:ii) (23:ii)) ^^ - ((slice load_data (8:ii) (15:ii)) ^^ (slice load_data (0:ii) (7:ii)))))) - -let execute_Stwbrx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(4:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (55:ii) >>= fun w__3 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (40:ii) (47:ii) >>= fun w__4 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (39:ii) >>= fun w__5 -> - MEMw (reset_vector_start EA,(4:ii),reset_vector_start (w__2 ^^ (w__3 ^^ (w__4 ^^ w__5)))) - -let execute_Ldbrx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr (reset_vector_start EA,(8:ii)) >>= fun load_data -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((slice load_data (56:ii) (63:ii)) ^^ - ((slice load_data (48:ii) (55:ii)) ^^ - ((slice load_data (40:ii) (47:ii)) ^^ - ((slice load_data (32:ii) (39:ii)) ^^ - ((slice load_data (24:ii) (31:ii)) ^^ - ((slice load_data (16:ii) (23:ii)) ^^ - ((slice load_data (8:ii) (15:ii)) ^^ (slice load_data (0:ii) (7:ii))))))))) - -let execute_Stdbrx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA (reset_vector_start EA,(8:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (55:ii) >>= fun w__3 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (40:ii) (47:ii) >>= fun w__4 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (39:ii) >>= fun w__5 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (24:ii) (31:ii) >>= fun w__6 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (16:ii) (23:ii) >>= fun w__7 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (8:ii) (15:ii) >>= fun w__8 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (0:ii) (7:ii) >>= fun w__9 -> - MEMw - (reset_vector_start EA, - (8:ii), - reset_vector_start (w__2 ^^ (w__3 ^^ (w__4 ^^ (w__5 ^^ (w__6 ^^ (w__7 ^^ (w__8 ^^ w__9)))))))) - -let execute_Lmw (RT, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - let size = (minus_IVI (32:ii) (reset_vector_start RT)) * (4:ii) in - MEMr (reset_vector_start EA,size) >>= fun buffer -> - let i = (0:ii) in - (foreachM_inc (unsigned (reset_vector_start RT),(31:ii),(1:ii)) i - (fun r i -> - write_reg - (access GPR r) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (slice buffer i (i + (31:ii)))) >> - let i = i + (32:ii) in - return i)) >>= fun i -> - return () - -let execute_Stmw (RS, RA, D) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let EA = - set_vector_start 0 - (add_VVV (reset_vector_start b) (reset_vector_start (exts ((64:ii),reset_vector_start D)))) in - let size = (minus_IVI (32:ii) (reset_vector_start RS)) * (4:ii) in - MEMw_EA (reset_vector_start EA,size) >> - let buffer = make_indexed_vector [(0,B0);(993,B0)] B0 0 994 true in - let i = (0:ii) in - (foreachM_inc (unsigned (reset_vector_start RS),(31:ii),(1:ii)) (i,buffer) - (fun r (i,buffer) -> - read_reg_range (access GPR r) (32:ii) (63:ii) >>= fun w__1 -> - let buffer = update buffer i (i + (31:ii)) w__1 in - let i = i + (32:ii) in - return (i,buffer))) >>= fun (i, buffer) -> - MEMw - (reset_vector_start EA, - size, - reset_vector_start (slice buffer (0:ii) ((size * (8:ii)) - (1:ii)))) - -let execute_Lswi (RT, RA, NB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let EA = to_vec_inc ((64:ii),(0:ii)) in - return EA - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun EA -> - let r = (0:ii) in - let r = minus_VII (reset_vector_start RT) (1:ii) in - let size = - if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB) in - MEMr (reset_vector_start EA,size) >>= fun membuffer -> - let j = (0:ii) in - let i = (32:ii) in - (foreachM_dec (if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB),(1:ii),(1:ii)) (EA,i,j,r) - (fun n (EA,i,j,r) -> - (if bitU_to_bool (eq_range (i, (32:ii))) - then - let r = modulo (r + (1:ii)) (32:ii) in - write_reg (access GPR r) (to_vec_inc ((64:ii),(0:ii))) >> - return r - else return r) >>= fun r -> - write_reg_range (access GPR r) i (i + (7:ii)) (slice membuffer j (j + (7:ii))) >> - let j = j + (8:ii) in - let i = i + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - let EA = set_vector_start 0 (add_VIV (reset_vector_start EA) (1:ii)) in - return (EA,i,j,r))) >>= fun (EA, i, j, r) -> - return () - -let execute_Lswx (RT, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let r = (0:ii) in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - let r = minus_VII (reset_vector_start RT) (1:ii) in - let i = (32:ii) in - read_reg_range XER (57:ii) (63:ii) >>= fun w__2 -> - let n_top = unsigned (reset_vector_start w__2) in - recalculate_dependency () >> - (if bitU_to_bool (eq_range (n_top, (0:ii))) - then - write_reg (access GPR (unsigned (reset_vector_start RT))) (to_vec_inc_undef (64:ii)) >> - return r - else - MEMr (reset_vector_start EA,n_top) >>= fun membuffer -> - let j = (0:ii) in - let n_r = quot n_top (4:ii) in - let n_mod = modulo n_top (4:ii) in - let n_r = if bitU_to_bool (eq_range (n_mod, (0:ii))) then n_r else n_r + (1:ii) in - (foreachM_dec (n_r,(1:ii),(1:ii)) (j,r) - (fun n (j,r) -> - let r = modulo (r + (1:ii)) (32:ii) in - let temp = to_vec_inc ((64:ii),(0:ii)) in - let temp = - if bitU_to_bool (eq_range (n, (1:ii))) - then - match toNatural n_mod with - | (0:nn) -> - update temp (32:ii) (63:ii) (set_vector_start 32 (slice membuffer j (j + (31:ii)))) - | (1:nn) -> - update temp (32:ii) (39:ii) (set_vector_start 32 (slice membuffer j (j + (7:ii)))) - | (2:nn) -> - update temp (32:ii) (47:ii) (set_vector_start 32 (slice membuffer j (j + (15:ii)))) - | (3:nn) -> - update temp (32:ii) (55:ii) (set_vector_start 32 (slice membuffer j (j + (23:ii)))) - end - else update temp (32:ii) (63:ii) (set_vector_start 32 (slice membuffer j (j + (31:ii)))) in - let j = j + (32:ii) in - write_reg (access GPR r) temp >> - return (j,r))) >>= fun (j, r) -> - return r) >>= fun r -> - return () - -let execute_Stswi (RS, RA, NB) = - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let EA = to_vec_inc ((64:ii),(0:ii)) in - return EA - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun EA -> - let r = (0:ii) in - let r = minus_VII (reset_vector_start RS) (1:ii) in - let size = - if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB) in - MEMw_EA (reset_vector_start EA,size) >> - let membuffer = make_indexed_vector [(0,B0);(255,B0)] B0 0 256 true in - let j = (0:ii) in - let i = (32:ii) in - (foreachM_dec (if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB),(1:ii),(1:ii)) (i,j,membuffer,r) - (fun n (i,j,membuffer,r) -> - let r = if bitU_to_bool (eq_range (i, (32:ii))) then modulo (r + (1:ii)) (32:ii) else r in - read_reg_range (access GPR r) i (i + (7:ii)) >>= fun w__1 -> - let membuffer = update membuffer j (j + (7:ii)) w__1 in - let j = j + (8:ii) in - let i = i + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - return (i,j,membuffer,r))) >>= fun (i, j, membuffer, r) -> - MEMw - (reset_vector_start EA, - size, - reset_vector_start (slice membuffer (0:ii) ((size * (8:ii)) - (1:ii)))) - -let execute_Stswx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - let r = (0:ii) in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - let r = minus_VII (reset_vector_start RS) (1:ii) in - let i = (32:ii) in - read_reg_range XER (57:ii) (63:ii) >>= fun w__2 -> - let n_top = unsigned (reset_vector_start w__2) in - recalculate_dependency () >> - MEMw_EA (reset_vector_start EA,n_top) >> - let membuffer = make_indexed_vector [(0,B0);(511,B0)] B0 0 512 true in - let j = (0:ii) in - (foreachM_dec (n_top,(1:ii),(1:ii)) (j,i,membuffer,r) - (fun n (j,i,membuffer,r) -> - let r = if bitU_to_bool (eq_range (i, (32:ii))) then modulo (r + (1:ii)) (32:ii) else r in - read_reg_range (access GPR r) i (i + (7:ii)) >>= fun w__3 -> - let membuffer = update membuffer j (j + (7:ii)) w__3 in - let i = i + (8:ii) in - let j = j + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - return (j,i,membuffer,r))) >>= fun (j, i, membuffer, r) -> - if bitU_to_bool (~(eq_range (n_top, (0:ii)))) - then - MEMw - (reset_vector_start EA, - n_top, - reset_vector_start (slice membuffer (0:ii) ((n_top * (8:ii)) - (1:ii)))) - else return () - -let execute_Addi (RT, RA, SI) = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (exts ((64:ii),reset_vector_start SI))) - else - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 - (add_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start SI))))) - -let execute_Addis (RT, RA, SI) = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 - (exts - ((64:ii), - reset_vector_start (SI ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true))))) - else - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 - (add_VVV - (reset_vector_start w__0) - (reset_vector_start (exts - ((64:ii), - reset_vector_start (SI ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true))))))) - -let execute_Add (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (temp, overflow, _) = - match (addSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v0v', v1v', v2v') -> (v0v',v1v',v2v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Subf (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (t1, o1, _) = - match (addSO_VVV - (reset_vector_start (bitwise_not (reset_vector_start w__0))) - (reset_vector_start w__1)) with - | (v3v', v4v', v5v') -> (v3v',v4v',v5v') - end in - let (t2, o2, _) = - match (addSO_VBV (reset_vector_start t1) B1) with | (v6v', v7v', v8v') -> (v6v',v7v',v8v') end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Addic (RT, RA, SI) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let (temp, _, carry) = - match (addSO_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start SI)))) with - | (v9v', v10v', v11v') -> (v9v',v10v',v11v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - write_reg_bitfield XER "CA" carry - -let execute_AddicDot (RT, RA, SI) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let (temp, overflow, carry) = - match (addSO_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start SI)))) with - | (v12v', v13v', v14v') -> (v12v',v13v',v14v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - write_reg_bitfield XER "CA" carry >> - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),overflow |. w__1) - -let execute_Subfic (RT, RA, SI) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let (t1, o1, c1) = - match (addSO_VVV - (reset_vector_start (bitwise_not (reset_vector_start w__0))) - (reset_vector_start (exts ((64:ii),reset_vector_start SI)))) with - | (v15v', v16v', v17v') -> (v15v',v16v',v17v') - end in - let (t2, o2, c2) = - match (addSO_VBV (reset_vector_start t1) B1) with - | (v18v', v19v', v20v') -> (v18v',v19v',v20v') - end in - let temp = set_vector_start 0 t2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - write_reg_bitfield XER "CA" (c1 |. c2) - -let execute_Addc (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (temp, overflow, carry) = - match (addSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v21v', v22v', v23v') -> (v21v',v22v',v23v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Subfc (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (t1, o1, c1) = - match (addSO_VVV - (reset_vector_start (bitwise_not (reset_vector_start w__0))) - (reset_vector_start w__1)) with - | (v24v', v25v', v26v') -> (v24v',v25v',v26v') - end in - let (t2, o2, c2) = - match (addSO_VBV (reset_vector_start t1) B1) with - | (v27v', v28v', v29v') -> (v27v',v28v',v29v') - end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - let carry = c1 |. c2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Adde (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (t1, o1, c1) = - match (addSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v30v', v31v', v32v') -> (v30v',v31v',v32v') - end in - read_reg_bitfield XER "CA" >>= fun w__2 -> - let (t2, o2, c2) = - match (addSO_VBV (reset_vector_start t1) w__2) with - | (v33v', v34v', v35v') -> (v33v',v34v',v35v') - end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - let carry = c1 |. c2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Subfe (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (t1, o1, c1) = - match (addSO_VVV - (reset_vector_start (bitwise_not (reset_vector_start w__0))) - (reset_vector_start w__1)) with - | (v36v', v37v', v38v') -> (v36v',v37v',v38v') - end in - read_reg_bitfield XER "CA" >>= fun w__2 -> - let (t2, o2, c2) = - match (addSO_VBV (reset_vector_start t1) w__2) with - | (v39v', v40v', v41v') -> (v39v',v40v',v41v') - end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - let carry = c1 |. c2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Addme (RT, RA, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg_bitfield XER "CA" >>= fun w__1 -> - let (t1, o1, c1) = - match (addSO_VBV (reset_vector_start w__0) w__1) with - | (v42v', v43v', v44v') -> (v42v',v43v',v44v') - end in - let (t2, o2, c2) = - match (addSO_VVV - (reset_vector_start t1) - (reset_vector_start (Vector [B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1] 0 true))) with - | (v45v', v46v', v47v') -> (v45v',v46v',v47v') - end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - let carry = c1 |. c2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Subfme (RT, RA, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg_bitfield XER "CA" >>= fun w__1 -> - let (t1, o1, c1) = - match (addSO_VBV (reset_vector_start (bitwise_not (reset_vector_start w__0))) w__1) with - | (v48v', v49v', v50v') -> (v48v',v49v',v50v') - end in - let (t2, o2, c2) = - match (addSO_VVV - (reset_vector_start t1) - (reset_vector_start (Vector [B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1;B1; - B1] 0 true))) with - | (v51v', v52v', v53v') -> (v51v',v52v',v53v') - end in - let temp = set_vector_start 0 t2 in - let overflow = o1 |. o2 in - let carry = c1 |. c2 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start temp,xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Addze (RT, RA, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg_bitfield XER "CA" >>= fun w__1 -> - let (temp, overflow, carry) = - match (addSO_VBV (reset_vector_start w__0) w__1) with - | (v54v', v55v', v56v') -> (v54v',v55v',v56v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Subfze (RT, RA, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg_bitfield XER "CA" >>= fun w__1 -> - let (temp, overflow, carry) = - match (addSO_VBV (reset_vector_start (bitwise_not (reset_vector_start w__0))) w__1) with - | (v57v', v58v', v59v') -> (v57v',v58v',v59v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),xer_so) - else return ()) >> - write_reg_bitfield XER "CA" carry >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Neg (RT, RA, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let (temp, overflow, _) = - match (addSO_VBV (reset_vector_start (bitwise_not (reset_vector_start w__0))) B1) with - | (v60v', v61v', v62v') -> (v60v',v61v',v62v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 temp) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start (set_vector_start 0 temp),w__1) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Mulli (RT, RA, SI) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let prod = - set_vector_start 0 - (multS_VVV - (reset_vector_start w__0) - (reset_vector_start (exts ((64:ii),reset_vector_start SI)))) in - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (slice prod (64:ii) (127:ii))) - -let execute_Mullw (RT, RA, RB, OE, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let (prod, overflow, _) = - match (multSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v63v', v64v', v65v') -> (v63v',v64v',v65v') - end in - write_reg (access GPR (unsigned (reset_vector_start RT))) (set_vector_start 0 prod) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 prod),xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Mulhw (RT, RA, RB, Rc) = - let prod = to_vec_inc ((64:ii),(0:ii)) in - let overflow = B0 in - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let (p, o, _) = - match (multSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v66v', v67v', v68v') -> (v66v',v67v',v68v') - end in - let prod = set_vector_start 0 p in - let overflow = o in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (set_vector_start 32 (slice prod (0:ii) (31:ii))) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool (most_significant w__2) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start prod,xer_so) - else return () - -let execute_Mulhwu (RT, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let prod = set_vector_start 0 (mult_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (set_vector_start 32 (slice prod (0:ii) (31:ii))) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool (most_significant w__2) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start prod,xer_so) - else return () - -let execute_Divw (RT, RA, RB, OE, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let dividend = set_vector_start 0 w__0 in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let divisor = set_vector_start 0 w__1 in - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotSO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v69v', v70v', v71v') -> (v69v',v70v',v71v') - end in - let divided = update divided (32:ii) (63:ii) (set_vector_start 32 d) in - let overflow = o in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (slice divided (32:ii) (63:ii)) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool ((most_significant w__2) |. overflow) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start divided,xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Divwu (RT, RA, RB, OE, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let dividend = set_vector_start 0 w__0 in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let divisor = set_vector_start 0 w__1 in - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v72v', v73v', v74v') -> (v72v',v73v',v74v') - end in - let divided = update divided (32:ii) (63:ii) (set_vector_start 32 d) in - let overflow = o in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (slice divided (32:ii) (63:ii)) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool ((most_significant w__2) |. overflow) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start divided,xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Divwe (RT, RA, RB, OE, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let dividend = - w__0 ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let divisor = set_vector_start 0 w__1 in - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotSO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v75v', v76v', v77v') -> (v75v',v76v',v77v') - end in - let divided = update divided (32:ii) (63:ii) (slice d (32:ii) (63:ii)) in - let overflow = o in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (slice divided (32:ii) (63:ii)) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool ((most_significant w__2) |. overflow) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start divided,xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Divweu (RT, RA, RB, OE, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let dividend = - w__0 ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let divisor = set_vector_start 0 w__1 in - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v78v', v79v', v80v') -> (v78v',v79v',v80v') - end in - let divided = update divided (32:ii) (63:ii) (slice d (32:ii) (63:ii)) in - let overflow = o in - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (32:ii) - (63:ii) - (slice divided (32:ii) (63:ii)) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RT))) (0:ii) - (31:ii) - (to_vec_inc_undef (((31:ii) - (0:ii)) + (1:ii))) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - read_reg mode64bit >>= fun w__2 -> - if bitU_to_bool ((most_significant w__2) |. overflow) - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else set_overflow_cr0 (reset_vector_start divided,xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Mulld (RT, RA, RB, OE, Rc) = - let prod = to_vec_inc ((128:ii),(0:ii)) in - let overflow = B0 in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let (p, o, _) = - match (multSO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v81v', v82v', v83v') -> (v81v',v82v',v83v') - end in - let prod = set_vector_start 0 p in - let overflow = o in - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (slice prod (64:ii) (127:ii))) >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - set_overflow_cr0 (reset_vector_start (set_vector_start 0 (slice prod (64:ii) (127:ii))),xer_so) - else return ()) >> - if bitU_to_bool OE - then set_SO_OV overflow - else return () - -let execute_Mulhd (RT, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let prod = set_vector_start 0 (multS_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RT))) (slice prod (0:ii) (63:ii)) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start (slice prod (0:ii) (63:ii)),w__2) - else return () - -let execute_Mulhdu (RT, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let prod = set_vector_start 0 (mult_VVV (reset_vector_start w__0) (reset_vector_start w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RT))) (slice prod (0:ii) (63:ii)) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start (slice prod (0:ii) (63:ii)),w__2) - else return () - -let execute_Divd (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun dividend -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun divisor -> - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotSO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v84v', v85v', v86v') -> (v84v',v85v',v86v') - end in - let divided = set_vector_start 0 d in - let overflow = o in - write_reg (access GPR (unsigned (reset_vector_start RT))) divided >> - (if bitU_to_bool OE - then set_SO_OV overflow - else return ()) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__0 -> - set_overflow_cr0 (reset_vector_start divided,overflow |. w__0) - else return () - -let execute_Divdu (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun dividend -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun divisor -> - let divided = - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let overflow = B0 in - let (d, o, _) = - match (quotO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v87v', v88v', v89v') -> (v87v',v88v',v89v') - end in - let divided = set_vector_start 0 d in - let overflow = o in - write_reg (access GPR (unsigned (reset_vector_start RT))) divided >> - (if bitU_to_bool OE - then set_SO_OV overflow - else return ()) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__0 -> - set_overflow_cr0 (reset_vector_start divided,overflow |. w__0) - else return () - -let execute_Divde (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let dividend = - w__0 ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true) in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun divisor -> - let divided = to_vec_inc ((128:ii),(0:ii)) in - let overflow = B0 in - let (d, o, _) = - match (quotSO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v90v', v91v', v92v') -> (v90v',v91v',v92v') - end in - let divided = set_vector_start 0 d in - let overflow = o in - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (slice divided (64:ii) (127:ii))) >> - (if bitU_to_bool OE - then set_SO_OV overflow - else return ()) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - if bitU_to_bool overflow - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else - set_overflow_cr0 - (reset_vector_start (set_vector_start 0 (slice divided (64:ii) (127:ii))), - xer_so) - else return () - -let execute_Divdeu (RT, RA, RB, OE, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__0 -> - let dividend = - w__0 ^^ - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true) in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun divisor -> - let divided = to_vec_inc ((128:ii),(0:ii)) in - let overflow = B0 in - let (d, o, _) = - match (quotO_VVV (reset_vector_start dividend) (reset_vector_start divisor)) with - | (v93v', v94v', v95v') -> (v93v',v94v',v95v') - end in - let divided = set_vector_start 0 d in - let overflow = o in - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 (slice divided (64:ii) (127:ii))) >> - (if bitU_to_bool OE - then set_SO_OV overflow - else return ()) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun xer_so -> - let xer_so = if bitU_to_bool (OE &. overflow) then overflow else xer_so in - if bitU_to_bool overflow - then write_reg_field CR "CR0" (set_vector_start 32 (Vector [BU;BU;BU;xer_so] 0 true)) - else - set_overflow_cr0 - (reset_vector_start (set_vector_start 0 (slice divided (64:ii) (127:ii))), - xer_so) - else return () - -let execute_Cmpi (BF, L, RA, SI) = - let a = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let a = set_vector_start 0 (exts ((64:ii),reset_vector_start w__0)) in - return a - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun a -> - let c = make_indexed_vector [] B0 0 3 true in - let c = - if bitU_to_bool (lt_vec (a, exts ((64:ii),reset_vector_start SI))) - then Vector [B1;B0;B0] 0 true - else - if bitU_to_bool (gt_vec (a, exts ((64:ii),reset_vector_start SI))) - then Vector [B0;B1;B0] 0 true - else Vector [B0;B0;B1] 0 true in - read_reg_bitfield XER "SO" >>= fun w__2 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - (c ^^ (Vector [w__2] 0 true)) - -let execute_Cmp (BF, L, RA, RB) = - let a = to_vec_inc ((64:ii),(0:ii)) in - let b = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let a = set_vector_start 0 (exts ((64:ii),reset_vector_start w__0)) in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let b = set_vector_start 0 (exts ((64:ii),reset_vector_start w__1)) in - return (a,b) - else - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__2 -> - let a = w__2 in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__3 -> - let b = w__3 in - return (a,b)) >>= fun (a, b) -> - let c = make_indexed_vector [] B0 0 3 true in - let c = - if bitU_to_bool (lt_vec (a, b)) - then Vector [B1;B0;B0] 0 true - else if bitU_to_bool (gt_vec (a, b)) then Vector [B0;B1;B0] 0 true else Vector [B0;B0;B1] 0 true in - read_reg_bitfield XER "SO" >>= fun w__4 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - (c ^^ (Vector [w__4] 0 true)) - -let execute_Cmpli (BF, L, RA, UI) = - let a = to_vec_inc ((64:ii),(0:ii)) in - let c = to_vec_inc ((3:ii),(0:ii)) in - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let a = - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__0 in - return a - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun a -> - let c = - if bitU_to_bool - (lt_vec_unsigned - (a, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - UI)) - then Vector [B1;B0;B0] 0 true - else - if bitU_to_bool - (gt_vec_unsigned - (a, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - UI)) - then Vector [B0;B1;B0] 0 true - else Vector [B0;B0;B1] 0 true in - read_reg_bitfield XER "SO" >>= fun w__2 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - (c ^^ (Vector [w__2] 0 true)) - -let execute_Cmpl (BF, L, RA, RB) = - let a = to_vec_inc ((64:ii),(0:ii)) in - let b = to_vec_inc ((64:ii),(0:ii)) in - let c = to_vec_inc ((3:ii),(0:ii)) in - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RA))) (32:ii) (63:ii) >>= fun w__0 -> - let a = - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__0 in - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (32:ii) (63:ii) >>= fun w__1 -> - let b = - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__1 in - return (a,b) - else - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__2 -> - let a = w__2 in - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__3 -> - let b = w__3 in - return (a,b)) >>= fun (a, b) -> - let c = - if bitU_to_bool (lt_vec_unsigned (a, b)) - then Vector [B1;B0;B0] 0 true - else - if bitU_to_bool (gt_vec_unsigned (a, b)) - then Vector [B0;B1;B0] 0 true - else Vector [B0;B0;B1] 0 true in - read_reg_bitfield XER "SO" >>= fun w__4 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - (c ^^ (Vector [w__4] 0 true)) - -let execute_Isel (RT, RA, RB, BC) = - let a = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let a = to_vec_inc ((64:ii),(0:ii)) in - return a - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun a -> - read_reg_bit CR (add_VII (reset_vector_start BC) (32:ii)) >>= fun w__1 -> - if bitU_to_bool (eq (match w__1 with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then - write_reg (access GPR (unsigned (reset_vector_start RT))) a >> - let discard = access GPR (unsigned (reset_vector_start RB)) in - return () - else - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__2 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__2 - -let execute_Andi (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let temp = - set_vector_start 0 - (bitwise_and - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - UI)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - -let execute_Andis (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let temp = - set_vector_start 0 - (bitwise_and - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (UI ^^ (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - -let execute_Ori (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - (set_vector_start 0 - (bitwise_or - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - UI))) - -let execute_Oris (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - (set_vector_start 0 - (bitwise_or - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (UI ^^ (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true))))) - -let execute_Xori (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - (set_vector_start 0 - (bitwise_xor - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - UI))) - -let execute_Xoris (RS, RA, UI) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - (set_vector_start 0 - (bitwise_xor - (w__0, - (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (UI ^^ (Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true))))) - -let execute_And (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_and (w__0, w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Xor (RS, RA, RB, Rc) = - let temp = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec (RS, RB)) - then - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let temp = w__0 in - let temp = to_vec_inc ((64:ii),(0:ii)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) (to_vec_inc ((64:ii),(0:ii))) >> - return temp - else - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__1 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__2 -> - let temp = set_vector_start 0 (bitwise_xor (w__1, w__2)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - return temp) >>= fun temp -> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__3 -> - set_overflow_cr0 (reset_vector_start temp,w__3) - else return () - -let execute_Nand (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_not (reset_vector_start (bitwise_and (w__0, w__1)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Or (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_or (w__0, w__1)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Nor (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_not (reset_vector_start (bitwise_or (w__0, w__1)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Eqv (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_xor (w__0, bitwise_not (reset_vector_start w__1))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Andc (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_and (w__0, bitwise_not (reset_vector_start w__1))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Orc (RS, RA, RB, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let temp = set_vector_start 0 (bitwise_or (w__0, bitwise_not (reset_vector_start w__1))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Extsb (RS, RA, Rc) = - let temp = to_vec_inc ((64:ii),(0:ii)) in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (56:ii) >>= fun s -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__0 -> - let temp = update temp (56:ii) (63:ii) w__0 in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (56:ii) - (63:ii) - (slice temp (56:ii) (63:ii)) >> - let temp = update temp (0:ii) (55:ii) (duplicate (s, (56:ii))) in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (0:ii) - (55:ii) - (slice temp (0:ii) (55:ii)) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Extsh (RS, RA, Rc) = - let temp = to_vec_inc ((64:ii),(0:ii)) in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (48:ii) >>= fun s -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__0 -> - let temp = update temp (48:ii) (63:ii) w__0 in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (48:ii) - (63:ii) - (slice temp (48:ii) (63:ii)) >> - let temp = update temp (0:ii) (47:ii) (duplicate (s, (48:ii))) in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (0:ii) - (47:ii) - (slice temp (0:ii) (47:ii)) >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Cntlzw (RS, RA, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let temp = to_vec_inc ((64:ii),countLeadingZeroes (reset_vector_start w__0,(32:ii))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Cmpb (RS, RA, RB) = - (foreachM_inc ((0:ii),(7:ii),(1:ii)) () - (fun n _ -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) - ((8:ii) * n) (((8:ii) * n) + (7:ii)) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RB))) - ((8:ii) * n) (((8:ii) * n) + (7:ii)) >>= fun w__1 -> - if bitU_to_bool (eq_vec (w__0, w__1)) - then - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) ((8:ii) * n) - (((8:ii) * n) + (7:ii)) - (Vector [B1;B1;B1;B1;B1;B1;B1;B1] 0 true) - else - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) ((8:ii) * n) - (((8:ii) * n) + (7:ii)) - (to_vec_inc ((8:ii),(0:ii))))) - -let execute_Popcntb (RS, RA) = - (foreachM_inc ((0:ii),(7:ii),(1:ii)) () - (fun i _ -> - let n = (0:ii) in - (foreachM_inc ((0:ii),(7:ii),(1:ii)) n - (fun j n -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) ((i * (8:ii)) + j) >>= fun w__0 -> - let n = - if bitU_to_bool (eq (match w__0 with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then n + (1:ii) - else n in - return n)) >>= fun n -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (i * (8:ii)) - ((i * (8:ii)) + (7:ii)) - (to_vec_inc ((8:ii),n)))) - -let execute_Popcntw (RS, RA) = - (foreachM_inc ((0:ii),(1:ii),(1:ii)) () - (fun i _ -> - let n = (0:ii) in - (foreachM_inc ((0:ii),(31:ii),(1:ii)) n - (fun j n -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) ((i * (32:ii)) + j) >>= fun w__0 -> - let n = - if bitU_to_bool (eq (match w__0 with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then n + (1:ii) - else n in - return n)) >>= fun n -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (i * (32:ii)) - ((i * (32:ii)) + (31:ii)) - (to_vec_inc ((32:ii),n)))) - -let execute_Prtyd (RS, RA) = - let s = (0:ii) in - (foreachM_inc ((0:ii),(7:ii),(1:ii)) s - (fun i s -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) ((i * (8:ii)) + (7:ii)) >>= fun w__0 -> - let s = - match ((if bitU_to_bool (is_one s) - then B1 - else B0) +. w__0) with - | B0 -> (0:ii) - | B1 -> (1:ii) - end in - return s)) >>= fun s -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (Vector [if bitU_to_bool (is_one s) then B1 else B0] 0 true)) - -let execute_Prtyw (RS, RA) = - let s = (0:ii) in - let t = (0:ii) in - (foreachM_inc ((0:ii),(3:ii),(1:ii)) s - (fun i s -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) ((i * (8:ii)) + (7:ii)) >>= fun w__0 -> - let s = - match ((if bitU_to_bool (is_one s) - then B1 - else B0) +. w__0) with - | B0 -> (0:ii) - | B1 -> (1:ii) - end in - return s)) >>= fun s -> - (foreachM_inc ((4:ii),(7:ii),(1:ii)) t - (fun i t -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) ((i * (8:ii)) + (7:ii)) >>= fun w__1 -> - let t = - match ((if bitU_to_bool (is_one t) - then B1 - else B0) +. w__1) with - | B0 -> (0:ii) - | B1 -> (1:ii) - end in - return t)) >>= fun t -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (0:ii) - (31:ii) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (Vector [if bitU_to_bool (is_one s) then B1 else B0] 0 true)) >> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (32:ii) - (63:ii) - (set_vector_start 32 - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (Vector [if bitU_to_bool (is_one t) then B1 else B0] 0 true))) - -let execute_Extsw (RS, RA, Rc) = - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (32:ii) >>= fun s -> - let temp = to_vec_inc ((64:ii),(0:ii)) in - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - let temp = update temp (32:ii) (63:ii) w__0 in - let temp = update temp (0:ii) (31:ii) (duplicate (s, (32:ii))) in - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return ()) >> - write_reg (access GPR (unsigned (reset_vector_start RA))) temp - -let execute_Cntlzd (RS, RA, Rc) = - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let temp = to_vec_inc ((64:ii),countLeadingZeroes (reset_vector_start w__0,(0:ii))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Popcntd (RS, RA) = - let n = (0:ii) in - (foreachM_inc ((0:ii),(63:ii),(1:ii)) n - (fun i n -> - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) i >>= fun w__0 -> - let n = - if bitU_to_bool (eq (match w__0 with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then n + (1:ii) - else n in - return n)) >>= fun n -> - write_reg (access GPR (unsigned (reset_vector_start RA))) (to_vec_inc ((64:ii),n)) - -let execute_Bpermd (RS, RA, RB) = - let perm = to_vec_inc ((8:ii),(0:ii)) in - (foreachM_inc ((0:ii),(7:ii),(1:ii)) perm - (fun i perm -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) - ((8:ii) * i) (((8:ii) * i) + (7:ii)) >>= fun index -> - if bitU_to_bool (lt_vec_unsigned (index, to_vec_inc ((8:ii),(64:ii)))) - then - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (unsigned - (reset_vector_start index)) >>= fun w__0 -> - let perm = update_pos perm i w__0 in - return perm - else - let perm = update_pos perm i B0 in - let discard = access GPR (unsigned (reset_vector_start RB)) in - return perm)) >>= fun perm -> - write_reg - (access GPR (unsigned (reset_vector_start RA))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - (slice perm (0:ii) (7:ii))) - -let execute_Rlwinm (RS, RA, SH, MB, ME, Rc) = - let n = SH in - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),unsigned (reset_vector_start n)) in - let m = MASK (add_VII (reset_vector_start MB) (32:ii),add_VII (reset_vector_start ME) (32:ii)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Rlwnm (RS, RA, RB, MB, ME, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (59:ii) (63:ii) >>= fun n -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),unsigned (reset_vector_start n)) in - let m = MASK (add_VII (reset_vector_start MB) (32:ii),add_VII (reset_vector_start ME) (32:ii)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Rlwimi (RS, RA, SH, MB, ME, Rc) = - let n = SH in - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),unsigned (reset_vector_start n)) in - let m = MASK (add_VII (reset_vector_start MB) (32:ii),add_VII (reset_vector_start ME) (32:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__2 -> - let temp = - set_vector_start 0 - (bitwise_or (bitwise_and (r, m), bitwise_and (w__2, bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__3 -> - set_overflow_cr0 (reset_vector_start temp,w__3) - else return () - -let execute_Rldicl (RS, RA, sh, mb, Rc) = - let n = (Vector [access sh (5:ii)] 0 true) ^^ (slice sh (0:ii) (4:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let b = (Vector [access mb (5:ii)] 0 true) ^^ (slice mb (0:ii) (4:ii)) in - let m = MASK (unsigned (reset_vector_start b),(63:ii)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Rldicr (RS, RA, sh, me, Rc) = - let n = (Vector [access sh (5:ii)] 0 true) ^^ (slice sh (0:ii) (4:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let e = (Vector [access me (5:ii)] 0 true) ^^ (slice me (0:ii) (4:ii)) in - let m = MASK ((0:ii),unsigned (reset_vector_start e)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Rldic (RS, RA, sh, mb, Rc) = - let n = (Vector [access sh (5:ii)] 0 true) ^^ (slice sh (0:ii) (4:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let b = (Vector [access mb (5:ii)] 0 true) ^^ (slice mb (0:ii) (4:ii)) in - let m = - MASK - (unsigned (reset_vector_start b), - unsigned (reset_vector_start (bitwise_not (reset_vector_start n)))) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Rldcl (RS, RA, RB, mb, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (58:ii) (63:ii) >>= fun n -> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let b = (Vector [access mb (5:ii)] 0 true) ^^ (slice mb (0:ii) (4:ii)) in - let m = MASK (unsigned (reset_vector_start b),(63:ii)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Rldcr (RS, RA, RB, me, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (58:ii) (63:ii) >>= fun n -> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let e = (Vector [access me (5:ii)] 0 true) ^^ (slice me (0:ii) (4:ii)) in - let m = MASK ((0:ii),unsigned (reset_vector_start e)) in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return () - -let execute_Rldimi (RS, RA, sh, mb, Rc) = - let n = (Vector [access sh (5:ii)] 0 true) ^^ (slice sh (0:ii) (4:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let b = (Vector [access mb (5:ii)] 0 true) ^^ (slice mb (0:ii) (4:ii)) in - let m = - MASK - (unsigned (reset_vector_start b), - unsigned (reset_vector_start (bitwise_not (reset_vector_start n)))) in - read_reg (access GPR (unsigned (reset_vector_start RA))) >>= fun w__1 -> - let temp = - set_vector_start 0 - (bitwise_or (bitwise_and (r, m), bitwise_and (w__1, bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Slw (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (59:ii) (63:ii) >>= fun n -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),unsigned (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (58:ii) >>= fun w__2 -> - let m = - if bitU_to_bool (eq (match w__2 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK ((32:ii),minus_IVI (63:ii) (reset_vector_start n)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__3 -> - set_overflow_cr0 (reset_vector_start temp,w__3) - else return () - -let execute_Srw (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (59:ii) (63:ii) >>= fun n -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),minus_IVI (64:ii) (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (58:ii) >>= fun w__2 -> - let m = - if bitU_to_bool (eq (match w__2 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK (add_VII (reset_vector_start n) (32:ii),(63:ii)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__3 -> - set_overflow_cr0 (reset_vector_start temp,w__3) - else return () - -let execute_Srawi (RS, RA, SH, Rc) = - let n = SH in - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),minus_IVI (64:ii) (reset_vector_start n)) in - let m = MASK (add_VII (reset_vector_start n) (32:ii),(63:ii)) in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (32:ii) >>= fun s -> - let temp = - set_vector_start 0 - (bitwise_or - (bitwise_and (r, m), - bitwise_and (duplicate (s, (64:ii)), bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return ()) >> - write_reg_bitfield - XER "CA" - (if bitU_to_bool (gt_vec_unsigned (n, to_vec_inc ((5:ii),(0:ii)))) - then s &. (~(eq_vec_range (bitwise_and (r, bitwise_not (reset_vector_start m)), (0:ii)))) - else B0) - -let execute_Sraw (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (59:ii) (63:ii) >>= fun n -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__1 -> - let r = ROTL (reset_vector_start (w__0 ^^ w__1),minus_IVI (64:ii) (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (58:ii) >>= fun w__2 -> - let m = - if bitU_to_bool (eq (match w__2 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK (add_VII (reset_vector_start n) (32:ii),(63:ii)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (32:ii) >>= fun s -> - let temp = - set_vector_start 0 - (bitwise_or - (bitwise_and (r, m), - bitwise_and (duplicate (s, (64:ii)), bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__3 -> - set_overflow_cr0 (reset_vector_start temp,w__3) - else return ()) >> - write_reg_bitfield - XER "CA" - (if bitU_to_bool (gt_vec_unsigned (n, to_vec_inc ((5:ii),(0:ii)))) - then s &. (~(eq_vec_range (bitwise_and (r, bitwise_not (reset_vector_start m)), (0:ii)))) - else B0) - -let execute_Sld (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (58:ii) (63:ii) >>= fun n -> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,unsigned (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (57:ii) >>= fun w__1 -> - let m = - if bitU_to_bool (eq (match w__1 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK ((0:ii),minus_IVI (63:ii) (reset_vector_start n)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Srd (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (58:ii) (63:ii) >>= fun n -> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,minus_IVI (64:ii) (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (57:ii) >>= fun w__1 -> - let m = - if bitU_to_bool (eq (match w__1 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK (unsigned (reset_vector_start n),(63:ii)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - let temp = set_vector_start 0 (bitwise_and (r, m)) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return () - -let execute_Sradi (RS, RA, sh, Rc) = - let n = (Vector [access sh (5:ii)] 0 true) ^^ (slice sh (0:ii) (4:ii)) in - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,minus_IVI (64:ii) (reset_vector_start n)) in - let m = MASK (unsigned (reset_vector_start n),(63:ii)) in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (0:ii) >>= fun s -> - let temp = - set_vector_start 0 - (bitwise_or - (bitwise_and (r, m), - bitwise_and (duplicate (s, (64:ii)), bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__1 -> - set_overflow_cr0 (reset_vector_start temp,w__1) - else return ()) >> - write_reg_bitfield - XER "CA" - (if bitU_to_bool (gt_vec_unsigned (n, to_vec_inc ((6:ii),(0:ii)))) - then s &. (~(eq_vec_range (bitwise_and (r, bitwise_not (reset_vector_start m)), (0:ii)))) - else B0) - -let execute_Srad (RS, RA, RB, Rc) = - read_reg_range (access GPR (unsigned (reset_vector_start RB))) (58:ii) (63:ii) >>= fun n -> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__0 -> - let r = ROTL (reset_vector_start w__0,minus_IVI (64:ii) (reset_vector_start n)) in - let m = make_indexed_vector [] B0 0 64 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RB))) (57:ii) >>= fun w__1 -> - let m = - if bitU_to_bool (eq (match w__1 with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then MASK (unsigned (reset_vector_start n),(63:ii)) - else - Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0] 0 true in - read_reg_bit (access GPR (unsigned (reset_vector_start RS))) (0:ii) >>= fun s -> - let temp = - set_vector_start 0 - (bitwise_or - (bitwise_and (r, m), - bitwise_and (duplicate (s, (64:ii)), bitwise_not (reset_vector_start m)))) in - write_reg (access GPR (unsigned (reset_vector_start RA))) temp >> - (if bitU_to_bool Rc - then - read_reg_bitfield XER "SO" >>= fun w__2 -> - set_overflow_cr0 (reset_vector_start temp,w__2) - else return ()) >> - write_reg_bitfield - XER "CA" - (if bitU_to_bool (gt_vec_unsigned (n, to_vec_inc ((6:ii),(0:ii)))) - then s &. (~(eq_vec_range (bitwise_and (r, bitwise_not (reset_vector_start m)), (0:ii)))) - else B0) - -let execute_Cdtbcd (RS, RA) = - (foreachM_inc ((0:ii),(1:ii),(1:ii)) () - (fun i _ -> - let n = i * (32:ii) in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (0:ii)) - (n + (7:ii)) - (to_vec_inc ((8:ii),(0:ii))) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (n + (12:ii)) (n + (21:ii)) >>= fun w__0 -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (8:ii)) - (n + (19:ii)) - (DEC_TO_BCD (reset_vector_start (set_vector_start 0 w__0))) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (n + (22:ii)) (n + (31:ii)) >>= fun w__1 -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (20:ii)) - (n + (31:ii)) - (DEC_TO_BCD (reset_vector_start (set_vector_start 0 w__1))))) - -let execute_Cbcdtd (RS, RA) = - (foreachM_inc ((0:ii),(1:ii),(1:ii)) () - (fun i _ -> - let n = i * (32:ii) in - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (0:ii)) - (n + (11:ii)) - (to_vec_inc ((12:ii),(0:ii))) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (n + (8:ii)) (n + (19:ii)) >>= fun w__0 -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (12:ii)) - (n + (21:ii)) - (BCD_TO_DEC (reset_vector_start (set_vector_start 0 w__0))) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (n + (20:ii)) (n + (31:ii)) >>= fun w__1 -> - write_reg_range - (access GPR (unsigned (reset_vector_start RA))) (n + (22:ii)) - (n + (31:ii)) - (BCD_TO_DEC (reset_vector_start (set_vector_start 0 w__1))))) - -let execute_Addg6s (RT, RA, RB) = - let dc = to_vec_inc ((16:ii),(0:ii)) in - (foreachM_inc ((0:ii),(15:ii),(1:ii)) dc - (fun i dc -> - read_reg_range (access GPR (unsigned (reset_vector_start RA))) ((4:ii) * i) (63:ii) >>= fun w__0 -> - read_reg_range (access GPR (unsigned (reset_vector_start RB))) ((4:ii) * i) (63:ii) >>= fun w__1 -> - let (v, _, co) = - match (addO_VVV (reset_vector_start w__0) (reset_vector_start w__1)) with - | (v96v', v97v', v98v') -> (v96v',v97v',v98v') - end in - let dc = update_pos dc i (carry_out (reset_vector_start (set_vector_start 0 v),co)) in - return dc)) >>= fun dc -> - let c = - (duplicate (access dc (0:ii), (4:ii))) ^^ - ((duplicate (access dc (1:ii), (4:ii))) ^^ - ((duplicate (access dc (2:ii), (4:ii))) ^^ - ((duplicate (access dc (3:ii), (4:ii))) ^^ - ((duplicate (access dc (4:ii), (4:ii))) ^^ - ((duplicate (access dc (5:ii), (4:ii))) ^^ - ((duplicate (access dc (6:ii), (4:ii))) ^^ - ((duplicate (access dc (7:ii), (4:ii))) ^^ - ((duplicate (access dc (8:ii), (4:ii))) ^^ - ((duplicate (access dc (9:ii), (4:ii))) ^^ - ((duplicate (access dc (10:ii), (4:ii))) ^^ - ((duplicate (access dc (11:ii), (4:ii))) ^^ - ((duplicate (access dc (12:ii), (4:ii))) ^^ - ((duplicate (access dc (13:ii), (4:ii))) ^^ - ((duplicate (access dc (14:ii), (4:ii))) ^^ (duplicate (access dc (15:ii), (4:ii))))))))))))))))) in - write_reg - (access GPR (unsigned (reset_vector_start RT))) - (set_vector_start 0 - (bitwise_and - (bitwise_not (reset_vector_start c), - Vector [B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0; - B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1; - B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1;B0;B0;B1;B1; - B0] 0 true))) - -let execute_Mtspr (RS, spr) = - let n = (slice spr (5:ii) (9:ii)) ^^ (slice spr (0:ii) (4:ii)) in - if bitU_to_bool (eq_vec_range (n, (13:ii))) - then trap () - else - if bitU_to_bool (eq_vec_range (n, (1:ii))) - then - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun reg -> - let front = zero_or_undef (reset_vector_start (slice reg (0:ii) (31:ii))) in - let xer_so = access reg (32:ii) in - let xer_ov = access reg (33:ii) in - let xer_ca = access reg (34:ii) in - let mid = zero_or_undef (reset_vector_start (set_vector_start 0 (slice reg (35:ii) (56:ii)))) in - let bot = set_vector_start 0 (slice reg (57:ii) (63:ii)) in - write_reg - XER - (front ^^ - ((Vector [xer_so] 0 true) ^^ - ((Vector [xer_ov] 0 true) ^^ ((Vector [xer_ca] 0 true) ^^ (mid ^^ bot))))) - else - read_reg (access SPR (unsigned (reset_vector_start n))) >>= fun w__0 -> - if bitU_to_bool (eq_range (length (reset_vector_start w__0), (64:ii))) - then - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__1 -> - write_reg (access SPR (unsigned (reset_vector_start n))) w__1 - else - if bitU_to_bool (eq_vec_range (n, (152:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun CTRL -> - return () - else return () - -let execute_Mfspr (RT, spr) = - let n = (slice spr (5:ii) (9:ii)) ^^ (slice spr (0:ii) (4:ii)) in - read_reg (access SPR (unsigned (reset_vector_start n))) >>= fun w__0 -> - if bitU_to_bool (eq_range (length (reset_vector_start w__0), (64:ii))) - then - read_reg (access SPR (unsigned (reset_vector_start n))) >>= fun w__1 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__1 - else - read_reg (access SPR (unsigned (reset_vector_start n))) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Mtcrf (RS, FXM) = - let mask = - (duplicate (access FXM (0:ii), (4:ii))) ^^ - ((duplicate (access FXM (1:ii), (4:ii))) ^^ - ((duplicate (access FXM (2:ii), (4:ii))) ^^ - ((duplicate (access FXM (3:ii), (4:ii))) ^^ - ((duplicate (access FXM (4:ii), (4:ii))) ^^ - ((duplicate (access FXM (5:ii), (4:ii))) ^^ - ((duplicate (access FXM (6:ii), (4:ii))) ^^ (duplicate (access FXM (7:ii), (4:ii))))))))) in - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__0 -> - read_reg CR >>= fun w__1 -> - write_reg - CR - (set_vector_start 32 - (bitwise_or - (set_vector_start 0 (bitwise_and (w__0, mask)), - set_vector_start 0 (bitwise_and (w__1, bitwise_not (reset_vector_start mask)))))) - -let execute_Mfcr RT = - read_reg CR >>= fun w__0 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__0) - -let execute_Mtocrf (RS, FXM) = - let n = (0:ii) in - let count = (0:ii) in - let (count, n) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (count,n) - (fun i (count,n) -> - let (n, count) = - if bitU_to_bool (eq (match (access FXM i) with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then - let n = i in - let count = count + (1:ii) in - (n,count) - else (n,count) in - (count,n))) in - if bitU_to_bool (eq_range (count, (1:ii))) - then - read_reg_range (access GPR (unsigned (reset_vector_start RS))) - (((4:ii) * n) + (32:ii)) (((4:ii) * n) + (35:ii)) >>= fun w__0 -> - write_reg_range CR (((4:ii) * n) + (32:ii)) (((4:ii) * n) + (35:ii)) w__0 - else write_reg CR (to_vec_inc_undef (32:ii)) - -let execute_Mfocrf (RT, FXM) = - let n = (0:ii) in - let count = (0:ii) in - let (count, n) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (count,n) - (fun i (count,n) -> - let (n, count) = - if bitU_to_bool (eq (match (access FXM i) with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then - let n = i in - let count = count + (1:ii) in - (n,count) - else (n,count) in - (count,n))) in - if bitU_to_bool (eq_range (count, (1:ii))) - then - let temp = to_vec_inc_undef (64:ii) in - read_reg_range CR (((4:ii) * n) + (32:ii)) (((4:ii) * n) + (35:ii)) >>= fun w__0 -> - let temp = update temp (((4:ii) * n) + (32:ii)) (((4:ii) * n) + (35:ii)) w__0 in - write_reg (access GPR (unsigned (reset_vector_start RT))) temp - else write_reg (access GPR (unsigned (reset_vector_start RT))) (to_vec_inc_undef (64:ii)) - -let execute_Mcrxr BF = - read_reg_range XER (32:ii) (35:ii) >>= fun w__0 -> - write_reg_range - CR (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii)) - (add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (35:ii)) - w__0 >> - write_reg_range XER (32:ii) (35:ii) (set_vector_start 32 (Vector [B0;B0;B0;B0] 0 true)) - -let execute_Dlmzb (RS, RA, RB, Rc) = return () - -let execute_Macchw (RT, RA, RB, OE, Rc) = return () - -let execute_Macchws (RT, RA, RB, OE, Rc) = return () - -let execute_Macchwu (RT, RA, RB, OE, Rc) = return () - -let execute_Macchwsu (RT, RA, RB, OE, Rc) = return () - -let execute_Machhw (RT, RA, RB, OE, Rc) = return () - -let execute_Machhws (RT, RA, RB, OE, Rc) = return () - -let execute_Machhwu (RT, RA, RB, OE, Rc) = return () - -let execute_Machhwsu (RT, RA, RB, OE, Rc) = return () - -let execute_Maclhw (RT, RA, RB, OE, Rc) = return () - -let execute_Maclhws (RT, RA, RB, OE, Rc) = return () - -let execute_Maclhwu (RT, RA, RB, OE, Rc) = return () - -let execute_Maclhwsu (RT, RA, RB, OE, Rc) = return () - -let execute_Mulchw (RT, RA, RB, Rc) = return () - -let execute_Mulchwu (RT, RA, RB, Rc) = return () - -let execute_Mulhhw (RT, RA, RB, Rc) = return () - -let execute_Mulhhwu (RT, RA, RB, Rc) = return () - -let execute_Mullhw (RT, RA, RB, Rc) = return () - -let execute_Mullhwu (RT, RA, RB, Rc) = return () - -let execute_Nmacchw (RT, RA, RB, OE, Rc) = return () - -let execute_Nmacchws (RT, RA, RB, OE, Rc) = return () - -let execute_Nmachhw (RT, RA, RB, OE, Rc) = return () - -let execute_Nmachhws (RT, RA, RB, OE, Rc) = return () - -let execute_Nmaclhw (RT, RA, RB, OE, Rc) = return () - -let execute_Nmaclhws (RT, RA, RB, OE, Rc) = return () - -let execute_Icbi (RA, RB) = return () - -let execute_Icbt (CT, RA, RB) = return () - -let execute_Dcba (RA, RB) = return () - -let execute_Dcbt (TH, RA, RB) = return () - -let execute_Dcbtst (TH, RA, RB) = return () - -let execute_Dcbz (RA, RB) = return () - -let execute_Dcbst (RA, RB) = return () - -let execute_Dcbf (L, RA, RB) = return () - -let execute_Isync () = I_Sync () - -let execute_Lbarx (RT, RA, RB, EH) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr_reserve (reset_vector_start EA,(1:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lharx (RT, RA, RB, EH) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr_reserve (reset_vector_start EA,(2:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Lwarx (RT, RA, RB, EH) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr_reserve (reset_vector_start EA,(4:ii)) >>= fun w__2 -> - write_reg - (access GPR (unsigned (reset_vector_start RT))) - ((Vector [B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0; - B0;B0;B0;B0;B0;B0;B0;B0;B0;B0;B0] 0 true) ^^ - w__2) - -let execute_Stbcx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA_cond (reset_vector_start EA,(1:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (56:ii) (63:ii) >>= fun w__2 -> - MEMw_conditional (reset_vector_start EA,(1:ii),reset_vector_start (set_vector_start 0 w__2)) >>= fun status -> - read_reg_bitfield XER "SO" >>= fun w__3 -> - let CR0 = (Vector [B0;B0] 0 true) ^^ ((Vector [status] 0 true) ^^ (Vector [w__3] 0 true)) in - return () - -let execute_Sthcx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA_cond (reset_vector_start EA,(2:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (48:ii) (63:ii) >>= fun w__2 -> - MEMw_conditional (reset_vector_start EA,(2:ii),reset_vector_start (set_vector_start 0 w__2)) >>= fun status -> - read_reg_bitfield XER "SO" >>= fun w__3 -> - let CR0 = (Vector [B0;B0] 0 true) ^^ ((Vector [status] 0 true) ^^ (Vector [w__3] 0 true)) in - return () - -let execute_Stwcx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA_cond (reset_vector_start EA,(4:ii)) >> - read_reg_range (access GPR (unsigned (reset_vector_start RS))) (32:ii) (63:ii) >>= fun w__2 -> - MEMw_conditional (reset_vector_start EA,(4:ii),reset_vector_start (set_vector_start 0 w__2)) >>= fun status -> - read_reg_bitfield XER "SO" >>= fun w__3 -> - let CR0 = (Vector [B0;B0] 0 true) ^^ ((Vector [status] 0 true) ^^ (Vector [w__3] 0 true)) in - return () - -let execute_Ldarx (RT, RA, RB, EH) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMr_reserve (reset_vector_start EA,(8:ii)) >>= fun w__2 -> - write_reg (access GPR (unsigned (reset_vector_start RT))) w__2 - -let execute_Stdcx (RS, RA, RB) = - let b = to_vec_inc ((64:ii),(0:ii)) in - let EA = to_vec_inc ((64:ii),(0:ii)) in - (if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then - let b = to_vec_inc ((64:ii),(0:ii)) in - return b - else read_reg (access GPR (unsigned (reset_vector_start RA)))) >>= fun b -> - read_reg (access GPR (unsigned (reset_vector_start RB))) >>= fun w__1 -> - let EA = set_vector_start 0 (add_VVV (reset_vector_start b) (reset_vector_start w__1)) in - MEMw_EA_cond (reset_vector_start EA,(8:ii)) >> - read_reg (access GPR (unsigned (reset_vector_start RS))) >>= fun w__2 -> - MEMw_conditional (reset_vector_start EA,(8:ii),reset_vector_start w__2) >>= fun status -> - read_reg_bitfield XER "SO" >>= fun w__3 -> - let CR0 = (Vector [B0;B0] 0 true) ^^ ((Vector [status] 0 true) ^^ (Vector [w__3] 0 true)) in - return () - -let execute_Sync L = - match L with | Vector [B0;B0] _ _ -> H_Sync () | Vector [B0;B1] _ _ -> LW_Sync () end - -let execute_Eieio () = EIEIO_Sync () - -let execute_Wait WC = return () - -let execute = function - - | B (LI,AA,LK) -> execute_B (LI,AA,LK) - | Bc (BO,BI,BD,AA,LK) -> execute_Bc (BO,BI,BD,AA,LK) - | Bclr (BO,BI,BH,LK) -> execute_Bclr (BO,BI,BH,LK) - | Bcctr (BO,BI,BH,LK) -> execute_Bcctr (BO,BI,BH,LK) - | Crand (BT,BA,BB) -> execute_Crand (BT,BA,BB) - | Crnand (BT,BA,BB) -> execute_Crnand (BT,BA,BB) - | Cror (BT,BA,BB) -> execute_Cror (BT,BA,BB) - | Crxor (BT,BA,BB) -> execute_Crxor (BT,BA,BB) - | Crnor (BT,BA,BB) -> execute_Crnor (BT,BA,BB) - | Creqv (BT,BA,BB) -> execute_Creqv (BT,BA,BB) - | Crandc (BT,BA,BB) -> execute_Crandc (BT,BA,BB) - | Crorc (BT,BA,BB) -> execute_Crorc (BT,BA,BB) - | Mcrf (BF,BFA) -> execute_Mcrf (BF,BFA) - | Sc (LEV) -> execute_Sc (LEV) - | Scv (LEV) -> execute_Scv (LEV) - | Lbz (RT,RA,D) -> execute_Lbz (RT,RA,D) - | Lbzx (RT,RA,RB) -> execute_Lbzx (RT,RA,RB) - | Lbzu (RT,RA,D) -> execute_Lbzu (RT,RA,D) - | Lbzux (RT,RA,RB) -> execute_Lbzux (RT,RA,RB) - | Lhz (RT,RA,D) -> execute_Lhz (RT,RA,D) - | Lhzx (RT,RA,RB) -> execute_Lhzx (RT,RA,RB) - | Lhzu (RT,RA,D) -> execute_Lhzu (RT,RA,D) - | Lhzux (RT,RA,RB) -> execute_Lhzux (RT,RA,RB) - | Lha (RT,RA,D) -> execute_Lha (RT,RA,D) - | Lhax (RT,RA,RB) -> execute_Lhax (RT,RA,RB) - | Lhau (RT,RA,D) -> execute_Lhau (RT,RA,D) - | Lhaux (RT,RA,RB) -> execute_Lhaux (RT,RA,RB) - | Lwz (RT,RA,D) -> execute_Lwz (RT,RA,D) - | Lwzx (RT,RA,RB) -> execute_Lwzx (RT,RA,RB) - | Lwzu (RT,RA,D) -> execute_Lwzu (RT,RA,D) - | Lwzux (RT,RA,RB) -> execute_Lwzux (RT,RA,RB) - | Lwa (RT,RA,DS) -> execute_Lwa (RT,RA,DS) - | Lwax (RT,RA,RB) -> execute_Lwax (RT,RA,RB) - | Lwaux (RT,RA,RB) -> execute_Lwaux (RT,RA,RB) - | Ld (RT,RA,DS) -> execute_Ld (RT,RA,DS) - | Ldx (RT,RA,RB) -> execute_Ldx (RT,RA,RB) - | Ldu (RT,RA,DS) -> execute_Ldu (RT,RA,DS) - | Ldux (RT,RA,RB) -> execute_Ldux (RT,RA,RB) - | Stb (RS,RA,D) -> execute_Stb (RS,RA,D) - | Stbx (RS,RA,RB) -> execute_Stbx (RS,RA,RB) - | Stbu (RS,RA,D) -> execute_Stbu (RS,RA,D) - | Stbux (RS,RA,RB) -> execute_Stbux (RS,RA,RB) - | Sth (RS,RA,D) -> execute_Sth (RS,RA,D) - | Sthx (RS,RA,RB) -> execute_Sthx (RS,RA,RB) - | Sthu (RS,RA,D) -> execute_Sthu (RS,RA,D) - | Sthux (RS,RA,RB) -> execute_Sthux (RS,RA,RB) - | Stw (RS,RA,D) -> execute_Stw (RS,RA,D) - | Stwx (RS,RA,RB) -> execute_Stwx (RS,RA,RB) - | Stwu (RS,RA,D) -> execute_Stwu (RS,RA,D) - | Stwux (RS,RA,RB) -> execute_Stwux (RS,RA,RB) - | Std (RS,RA,DS) -> execute_Std (RS,RA,DS) - | Stdx (RS,RA,RB) -> execute_Stdx (RS,RA,RB) - | Stdu (RS,RA,DS) -> execute_Stdu (RS,RA,DS) - | Stdux (RS,RA,RB) -> execute_Stdux (RS,RA,RB) - | Lhbrx (RT,RA,RB) -> execute_Lhbrx (RT,RA,RB) - | Sthbrx (RS,RA,RB) -> execute_Sthbrx (RS,RA,RB) - | Lwbrx (RT,RA,RB) -> execute_Lwbrx (RT,RA,RB) - | Stwbrx (RS,RA,RB) -> execute_Stwbrx (RS,RA,RB) - | Ldbrx (RT,RA,RB) -> execute_Ldbrx (RT,RA,RB) - | Stdbrx (RS,RA,RB) -> execute_Stdbrx (RS,RA,RB) - | Lmw (RT,RA,D) -> execute_Lmw (RT,RA,D) - | Stmw (RS,RA,D) -> execute_Stmw (RS,RA,D) - | Lswi (RT,RA,NB) -> execute_Lswi (RT,RA,NB) - | Lswx (RT,RA,RB) -> execute_Lswx (RT,RA,RB) - | Stswi (RS,RA,NB) -> execute_Stswi (RS,RA,NB) - | Stswx (RS,RA,RB) -> execute_Stswx (RS,RA,RB) - | Addi (RT,RA,SI) -> execute_Addi (RT,RA,SI) - | Addis (RT,RA,SI) -> execute_Addis (RT,RA,SI) - | Add (RT,RA,RB,OE,Rc) -> execute_Add (RT,RA,RB,OE,Rc) - | Subf (RT,RA,RB,OE,Rc) -> execute_Subf (RT,RA,RB,OE,Rc) - | Addic (RT,RA,SI) -> execute_Addic (RT,RA,SI) - | AddicDot (RT,RA,SI) -> execute_AddicDot (RT,RA,SI) - | Subfic (RT,RA,SI) -> execute_Subfic (RT,RA,SI) - | Addc (RT,RA,RB,OE,Rc) -> execute_Addc (RT,RA,RB,OE,Rc) - | Subfc (RT,RA,RB,OE,Rc) -> execute_Subfc (RT,RA,RB,OE,Rc) - | Adde (RT,RA,RB,OE,Rc) -> execute_Adde (RT,RA,RB,OE,Rc) - | Subfe (RT,RA,RB,OE,Rc) -> execute_Subfe (RT,RA,RB,OE,Rc) - | Addme (RT,RA,OE,Rc) -> execute_Addme (RT,RA,OE,Rc) - | Subfme (RT,RA,OE,Rc) -> execute_Subfme (RT,RA,OE,Rc) - | Addze (RT,RA,OE,Rc) -> execute_Addze (RT,RA,OE,Rc) - | Subfze (RT,RA,OE,Rc) -> execute_Subfze (RT,RA,OE,Rc) - | Neg (RT,RA,OE,Rc) -> execute_Neg (RT,RA,OE,Rc) - | Mulli (RT,RA,SI) -> execute_Mulli (RT,RA,SI) - | Mullw (RT,RA,RB,OE,Rc) -> execute_Mullw (RT,RA,RB,OE,Rc) - | Mulhw (RT,RA,RB,Rc) -> execute_Mulhw (RT,RA,RB,Rc) - | Mulhwu (RT,RA,RB,Rc) -> execute_Mulhwu (RT,RA,RB,Rc) - | Divw (RT,RA,RB,OE,Rc) -> execute_Divw (RT,RA,RB,OE,Rc) - | Divwu (RT,RA,RB,OE,Rc) -> execute_Divwu (RT,RA,RB,OE,Rc) - | Divwe (RT,RA,RB,OE,Rc) -> execute_Divwe (RT,RA,RB,OE,Rc) - | Divweu (RT,RA,RB,OE,Rc) -> execute_Divweu (RT,RA,RB,OE,Rc) - | Mulld (RT,RA,RB,OE,Rc) -> execute_Mulld (RT,RA,RB,OE,Rc) - | Mulhd (RT,RA,RB,Rc) -> execute_Mulhd (RT,RA,RB,Rc) - | Mulhdu (RT,RA,RB,Rc) -> execute_Mulhdu (RT,RA,RB,Rc) - | Divd (RT,RA,RB,OE,Rc) -> execute_Divd (RT,RA,RB,OE,Rc) - | Divdu (RT,RA,RB,OE,Rc) -> execute_Divdu (RT,RA,RB,OE,Rc) - | Divde (RT,RA,RB,OE,Rc) -> execute_Divde (RT,RA,RB,OE,Rc) - | Divdeu (RT,RA,RB,OE,Rc) -> execute_Divdeu (RT,RA,RB,OE,Rc) - | Cmpi (BF,L,RA,SI) -> execute_Cmpi (BF,L,RA,SI) - | Cmp (BF,L,RA,RB) -> execute_Cmp (BF,L,RA,RB) - | Cmpli (BF,L,RA,UI) -> execute_Cmpli (BF,L,RA,UI) - | Cmpl (BF,L,RA,RB) -> execute_Cmpl (BF,L,RA,RB) - | Isel (RT,RA,RB,BC) -> execute_Isel (RT,RA,RB,BC) - | Andi (RS,RA,UI) -> execute_Andi (RS,RA,UI) - | Andis (RS,RA,UI) -> execute_Andis (RS,RA,UI) - | Ori (RS,RA,UI) -> execute_Ori (RS,RA,UI) - | Oris (RS,RA,UI) -> execute_Oris (RS,RA,UI) - | Xori (RS,RA,UI) -> execute_Xori (RS,RA,UI) - | Xoris (RS,RA,UI) -> execute_Xoris (RS,RA,UI) - | And (RS,RA,RB,Rc) -> execute_And (RS,RA,RB,Rc) - | Xor (RS,RA,RB,Rc) -> execute_Xor (RS,RA,RB,Rc) - | Nand (RS,RA,RB,Rc) -> execute_Nand (RS,RA,RB,Rc) - | Or (RS,RA,RB,Rc) -> execute_Or (RS,RA,RB,Rc) - | Nor (RS,RA,RB,Rc) -> execute_Nor (RS,RA,RB,Rc) - | Eqv (RS,RA,RB,Rc) -> execute_Eqv (RS,RA,RB,Rc) - | Andc (RS,RA,RB,Rc) -> execute_Andc (RS,RA,RB,Rc) - | Orc (RS,RA,RB,Rc) -> execute_Orc (RS,RA,RB,Rc) - | Extsb (RS,RA,Rc) -> execute_Extsb (RS,RA,Rc) - | Extsh (RS,RA,Rc) -> execute_Extsh (RS,RA,Rc) - | Cntlzw (RS,RA,Rc) -> execute_Cntlzw (RS,RA,Rc) - | Cmpb (RS,RA,RB) -> execute_Cmpb (RS,RA,RB) - | Popcntb (RS,RA) -> execute_Popcntb (RS,RA) - | Popcntw (RS,RA) -> execute_Popcntw (RS,RA) - | Prtyd (RS,RA) -> execute_Prtyd (RS,RA) - | Prtyw (RS,RA) -> execute_Prtyw (RS,RA) - | Extsw (RS,RA,Rc) -> execute_Extsw (RS,RA,Rc) - | Cntlzd (RS,RA,Rc) -> execute_Cntlzd (RS,RA,Rc) - | Popcntd (RS,RA) -> execute_Popcntd (RS,RA) - | Bpermd (RS,RA,RB) -> execute_Bpermd (RS,RA,RB) - | Rlwinm (RS,RA,SH,MB,ME,Rc) -> execute_Rlwinm (RS,RA,SH,MB,ME,Rc) - | Rlwnm (RS,RA,RB,MB,ME,Rc) -> execute_Rlwnm (RS,RA,RB,MB,ME,Rc) - | Rlwimi (RS,RA,SH,MB,ME,Rc) -> execute_Rlwimi (RS,RA,SH,MB,ME,Rc) - | Rldicl (RS,RA,sh,mb,Rc) -> execute_Rldicl (RS,RA,sh,mb,Rc) - | Rldicr (RS,RA,sh,me,Rc) -> execute_Rldicr (RS,RA,sh,me,Rc) - | Rldic (RS,RA,sh,mb,Rc) -> execute_Rldic (RS,RA,sh,mb,Rc) - | Rldcl (RS,RA,RB,mb,Rc) -> execute_Rldcl (RS,RA,RB,mb,Rc) - | Rldcr (RS,RA,RB,me,Rc) -> execute_Rldcr (RS,RA,RB,me,Rc) - | Rldimi (RS,RA,sh,mb,Rc) -> execute_Rldimi (RS,RA,sh,mb,Rc) - | Slw (RS,RA,RB,Rc) -> execute_Slw (RS,RA,RB,Rc) - | Srw (RS,RA,RB,Rc) -> execute_Srw (RS,RA,RB,Rc) - | Srawi (RS,RA,SH,Rc) -> execute_Srawi (RS,RA,SH,Rc) - | Sraw (RS,RA,RB,Rc) -> execute_Sraw (RS,RA,RB,Rc) - | Sld (RS,RA,RB,Rc) -> execute_Sld (RS,RA,RB,Rc) - | Srd (RS,RA,RB,Rc) -> execute_Srd (RS,RA,RB,Rc) - | Sradi (RS,RA,sh,Rc) -> execute_Sradi (RS,RA,sh,Rc) - | Srad (RS,RA,RB,Rc) -> execute_Srad (RS,RA,RB,Rc) - | Cdtbcd (RS,RA) -> execute_Cdtbcd (RS,RA) - | Cbcdtd (RS,RA) -> execute_Cbcdtd (RS,RA) - | Addg6s (RT,RA,RB) -> execute_Addg6s (RT,RA,RB) - | Mtspr (RS,spr) -> execute_Mtspr (RS,spr) - | Mfspr (RT,spr) -> execute_Mfspr (RT,spr) - | Mtcrf (RS,FXM) -> execute_Mtcrf (RS,FXM) - | Mfcr (RT) -> execute_Mfcr (RT) - | Mtocrf (RS,FXM) -> execute_Mtocrf (RS,FXM) - | Mfocrf (RT,FXM) -> execute_Mfocrf (RT,FXM) - | Mcrxr (BF) -> execute_Mcrxr (BF) - | Dlmzb (RS,RA,RB,Rc) -> execute_Dlmzb (RS,RA,RB,Rc) - | Macchw (RT,RA,RB,OE,Rc) -> execute_Macchw (RT,RA,RB,OE,Rc) - | Macchws (RT,RA,RB,OE,Rc) -> execute_Macchws (RT,RA,RB,OE,Rc) - | Macchwu (RT,RA,RB,OE,Rc) -> execute_Macchwu (RT,RA,RB,OE,Rc) - | Macchwsu (RT,RA,RB,OE,Rc) -> execute_Macchwsu (RT,RA,RB,OE,Rc) - | Machhw (RT,RA,RB,OE,Rc) -> execute_Machhw (RT,RA,RB,OE,Rc) - | Machhws (RT,RA,RB,OE,Rc) -> execute_Machhws (RT,RA,RB,OE,Rc) - | Machhwu (RT,RA,RB,OE,Rc) -> execute_Machhwu (RT,RA,RB,OE,Rc) - | Machhwsu (RT,RA,RB,OE,Rc) -> execute_Machhwsu (RT,RA,RB,OE,Rc) - | Maclhw (RT,RA,RB,OE,Rc) -> execute_Maclhw (RT,RA,RB,OE,Rc) - | Maclhws (RT,RA,RB,OE,Rc) -> execute_Maclhws (RT,RA,RB,OE,Rc) - | Maclhwu (RT,RA,RB,OE,Rc) -> execute_Maclhwu (RT,RA,RB,OE,Rc) - | Maclhwsu (RT,RA,RB,OE,Rc) -> execute_Maclhwsu (RT,RA,RB,OE,Rc) - | Mulchw (RT,RA,RB,Rc) -> execute_Mulchw (RT,RA,RB,Rc) - | Mulchwu (RT,RA,RB,Rc) -> execute_Mulchwu (RT,RA,RB,Rc) - | Mulhhw (RT,RA,RB,Rc) -> execute_Mulhhw (RT,RA,RB,Rc) - | Mulhhwu (RT,RA,RB,Rc) -> execute_Mulhhwu (RT,RA,RB,Rc) - | Mullhw (RT,RA,RB,Rc) -> execute_Mullhw (RT,RA,RB,Rc) - | Mullhwu (RT,RA,RB,Rc) -> execute_Mullhwu (RT,RA,RB,Rc) - | Nmacchw (RT,RA,RB,OE,Rc) -> execute_Nmacchw (RT,RA,RB,OE,Rc) - | Nmacchws (RT,RA,RB,OE,Rc) -> execute_Nmacchws (RT,RA,RB,OE,Rc) - | Nmachhw (RT,RA,RB,OE,Rc) -> execute_Nmachhw (RT,RA,RB,OE,Rc) - | Nmachhws (RT,RA,RB,OE,Rc) -> execute_Nmachhws (RT,RA,RB,OE,Rc) - | Nmaclhw (RT,RA,RB,OE,Rc) -> execute_Nmaclhw (RT,RA,RB,OE,Rc) - | Nmaclhws (RT,RA,RB,OE,Rc) -> execute_Nmaclhws (RT,RA,RB,OE,Rc) - | Icbi (RA,RB) -> execute_Icbi (RA,RB) - | Icbt (CT,RA,RB) -> execute_Icbt (CT,RA,RB) - | Dcba (RA,RB) -> execute_Dcba (RA,RB) - | Dcbt (TH,RA,RB) -> execute_Dcbt (TH,RA,RB) - | Dcbtst (TH,RA,RB) -> execute_Dcbtst (TH,RA,RB) - | Dcbz (RA,RB) -> execute_Dcbz (RA,RB) - | Dcbst (RA,RB) -> execute_Dcbst (RA,RB) - | Dcbf (L,RA,RB) -> execute_Dcbf (L,RA,RB) - | Isync -> execute_Isync () - | Lbarx (RT,RA,RB,EH) -> execute_Lbarx (RT,RA,RB,EH) - | Lharx (RT,RA,RB,EH) -> execute_Lharx (RT,RA,RB,EH) - | Lwarx (RT,RA,RB,EH) -> execute_Lwarx (RT,RA,RB,EH) - | Stbcx (RS,RA,RB) -> execute_Stbcx (RS,RA,RB) - | Sthcx (RS,RA,RB) -> execute_Sthcx (RS,RA,RB) - | Stwcx (RS,RA,RB) -> execute_Stwcx (RS,RA,RB) - | Ldarx (RT,RA,RB,EH) -> execute_Ldarx (RT,RA,RB,EH) - | Stdcx (RS,RA,RB) -> execute_Stdcx (RS,RA,RB) - | Sync (L) -> execute_Sync (L) - | Eieio -> execute_Eieio () - | Wait (WC) -> execute_Wait (WC) - end - -let initial_analysis instr = - let iR = [] in - let oR = [] in - let aR = [] in - let ik = IK_simple in - let Nias = [NIAFP_successor] in - let Dia = DIAFP_none in - match instr with - | B (LI,AA,LK) -> - let oR = NIA_fp :: oR in - let iR = if bitU_to_bool AA then CIA_fp :: iR else iR in - let oR = if bitU_to_bool LK then (RFull "LR") :: oR else oR in - (if bitU_to_bool AA - then - return (set_vector_start 0 - (exts ((64:ii),reset_vector_start (LI ^^ (Vector [B0;B0] 0 true))))) - else - read_reg CIA >>= fun w__0 -> - return (set_vector_start 0 - (add_VVV - w__0 - (reset_vector_start (exts ((64:ii),reset_vector_start (LI ^^ (Vector [B0;B0] 0 true)))))))) >>= fun nia' -> - let Nias = [NIAFP_concrete_address (reset_vector_start nia')] in - let ik = IK_simple in - return (aR,oR,iR,Nias,ik) - | Bc (BO,BI,BD,AA,LK) -> - let iR = mode64bit_fp :: iR in - let iR = (RFull "CTR") :: iR in - let oR = if bitU_to_bool (~(access BO (2:ii))) then (RFull "CTR") :: oR else oR in - let iR = (RSliceBit ("CR",add_VII (reset_vector_start BI) (32:ii))) :: iR in - let oR = NIA_fp :: oR in - let iR = if bitU_to_bool AA then CIA_fp :: iR else iR in - (if bitU_to_bool AA - then - return (set_vector_start 0 - (exts ((64:ii),reset_vector_start (BD ^^ (Vector [B0;B0] 0 true))))) - else - read_reg CIA >>= fun w__1 -> - return (set_vector_start 0 - (add_VVV - w__1 - (reset_vector_start (exts ((64:ii),reset_vector_start (BD ^^ (Vector [B0;B0] 0 true)))))))) >>= fun w__2 -> - let Nias = [NIAFP_concrete_address (reset_vector_start w__2);NIAFP_successor] in - let (oR, iR) = - if bitU_to_bool LK - then - let oR = (RFull "LR") :: oR in - let iR = CIA_fp :: iR in - (oR,iR) - else (oR,iR) in - let ik = IK_cond_branch in - return (aR,oR,iR,Nias,ik) - | Bclr (BO,BI,BH,LK) -> - let iR = mode64bit_fp :: iR in - let iR = (RFull "CTR") :: iR in - let oR = if bitU_to_bool (~(access BO (2:ii))) then (RFull "CTR") :: oR else oR in - let iR = (RSliceBit ("CR",add_VII (reset_vector_start BI) (32:ii))) :: iR in - let iR = (RSlice ("LR",(0:ii),(61:ii))) :: iR in - let oR = NIA_fp :: oR in - let Nias = [NIAFP_LR;NIAFP_successor] in - let (oR, iR) = - if bitU_to_bool LK - then - let oR = (RFull "LR") :: oR in - let iR = CIA_fp :: iR in - (oR,iR) - else (oR,iR) in - let ik = IK_cond_branch in - return (aR,oR,iR,Nias,ik) - | Bcctr (BO,BI,BH,LK) -> - let iR = (RSliceBit ("CR",add_VII (reset_vector_start BI) (32:ii))) :: iR in - let iR = (RSlice ("CTR",(0:ii),(61:ii))) :: iR in - let oR = NIA_fp :: oR in - let Nias = [NIAFP_CTR;NIAFP_successor] in - let (oR, iR) = - if bitU_to_bool LK - then - let oR = (RFull "LR") :: oR in - let iR = CIA_fp :: iR in - (oR,iR) - else (oR,iR) in - let ik = IK_cond_branch in - return (aR,oR,iR,Nias,ik) - | Crand (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Crnand (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Cror (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Crxor (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Crnor (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Creqv (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Crandc (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Crorc (BT,BA,BB) -> - let iR = - (RSliceBit ("CR",add_VII (reset_vector_start BA) (32:ii))) :: - (RSliceBit ("CR",add_VII (reset_vector_start BB) (32:ii))) :: iR in - let oR = (RSliceBit ("CR",add_VII (reset_vector_start BT) (32:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Mcrf (BF,BFA) -> - let iR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BFA))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BFA))) - (35:ii))) :: - iR in - let oR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - oR in - return (aR,oR,iR,Nias,ik) - | Sc (LEV) -> - let Nias = if bitU_to_bool (eq_vec_range (LEV, (63:ii))) then [] else [NIAFP_successor] in - return (aR,oR,iR,Nias,ik) - | Scv (LEV) -> return (aR,oR,iR,Nias,ik) - | Lbz (RT,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lbzx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lbzu (RT,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lbzux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhz (RT,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhzx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhzu (RT,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhzux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lha (RT,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhax (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhau (RT,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lhaux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwz (RT,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwzx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwzu (RT,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwzux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwa (RT,RA,DS) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwax (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lwaux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Ld (RT,RA,DS) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Ldx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Ldu (RT,RA,DS) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Ldux (RT,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stb (RS,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stbx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stbu (RS,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stbux (RS,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Sth (RS,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Sthx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Sthu (RS,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Sthux (RS,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stw (RS,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stwx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stwu (RS,RA,D) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stwux (RS,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Std (RS,RA,DS) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stdx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stdu (RS,RA,DS) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stdux (RS,RA,RB) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let aR = iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Lq (RTp,RA,DQ,PT) -> - let iR = bigendianmode_fp :: iR in - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RTp)))) :: - (RFull (access GPRs (add_VII (reset_vector_start RTp) (1:ii)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stq (RSp,RA,DS) -> - let iR = bigendianmode_fp :: iR in - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RSp)))) :: - (RFull (access GPRs (add_VII (reset_vector_start RSp) (1:ii)))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Lhbrx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Sthbrx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(55:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Lwbrx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stwbrx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(55:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(40:ii),(47:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(39:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Ldbrx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stdbrx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(55:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(40:ii),(47:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(39:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(24:ii),(31:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(16:ii),(23:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(8:ii),(15:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(0:ii),(7:ii))) :: iR in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Lmw (RT,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let i = (0:ii) in - let aR = iR in - let (i, oR) = - (foreach_inc (unsigned (reset_vector_start RT),(31:ii),(1:ii)) (i,oR) - (fun r (i,oR) -> - let oR = (RFull (access GPRs r)) :: oR in - let i = i + (32:ii) in - (i,oR))) in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stmw (RS,RA,D) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let i = (0:ii) in - let (i, iR) = - (foreach_inc (unsigned (reset_vector_start RS),(31:ii),(1:ii)) (i,iR) - (fun r (i,iR) -> - let iR = (RSlice (access GPRs r,(32:ii),(63:ii))) :: iR in - let i = i + (32:ii) in - (i,iR))) in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Lswi (RT,RA,NB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let r = (0:ii) in - let r = minus_VII (reset_vector_start RT) (1:ii) in - let j = (0:ii) in - let i = (32:ii) in - let (i, j, oR, r) = - (foreach_dec (if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB),(1:ii),(1:ii)) (i,j,oR,r) - (fun n (i,j,oR,r) -> - let (r, oR) = - if bitU_to_bool (eq_range (i, (32:ii))) - then - let r = modulo (r + (1:ii)) (32:ii) in - let oR = (RFull (access GPRs r)) :: oR in - (r,oR) - else (r,oR) in - let oR = (RSlice (access GPRs r,i,i + (7:ii))) :: oR in - let j = j + (8:ii) in - let i = i + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - (i,j,oR,r))) in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Lswx (RT,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: - (RSlice ("XER",(57:ii),(63:ii))) :: iR in - let aR = iR in - let oR = (foreach_inc ((0:ii),(31:ii),(1:ii)) oR (fun r oR -> (RFull (access GPRs r)) :: oR)) in - let ik = IK_mem_read Read_plain in - return (aR,oR,iR,Nias,ik) - | Stswi (RS,RA,NB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let aR = iR in - let r = (0:ii) in - let r = minus_VII (reset_vector_start RS) (1:ii) in - let j = (0:ii) in - let i = (32:ii) in - let (i, j, iR, r) = - (foreach_dec (if bitU_to_bool (eq_vec_range (NB, (0:ii))) - then (32:ii) - else unsigned (reset_vector_start NB),(1:ii),(1:ii)) (i,j,iR,r) - (fun n (i,j,iR,r) -> - let r = if bitU_to_bool (eq_range (i, (32:ii))) then modulo (r + (1:ii)) (32:ii) else r in - let iR = (RSlice (access GPRs r,i,i + (7:ii))) :: iR in - let j = j + (8:ii) in - let i = i + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - (i,j,iR,r))) in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Stswx (RS,RA,RB) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let r = (0:ii) in - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: - (RSlice ("XER",(57:ii),(63:ii))) :: iR in - let aR = iR in - let r = minus_VII (reset_vector_start RS) (1:ii) in - let i = (32:ii) in - let n_top = unsigned (reset_vector_start (Vector [B1;B1;B1;B1;B1;B1;B1] 0 true)) in - let j = (0:ii) in - let (j, i, iR, r) = - (foreach_dec (n_top,(1:ii),(1:ii)) (j,i,iR,r) - (fun n (j,i,iR,r) -> - let r = if bitU_to_bool (eq_range (i, (32:ii))) then modulo (r + (1:ii)) (32:ii) else r in - let iR = (RSlice (access GPRs r,i,i + (7:ii))) :: iR in - let i = i + (8:ii) in - let j = j + (8:ii) in - let i = if bitU_to_bool (eq_range (i, (64:ii))) then (32:ii) else i in - (j,i,iR,r))) in - let ik = IK_mem_write Write_plain in - return (aR,oR,iR,Nias,ik) - | Addi (RT,RA,SI) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Addis (RT,RA,SI) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Add (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Subf (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Addic (RT,RA,SI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | AddicDot (RT,RA,SI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: (RField ("XER","CA")) :: oR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - return (aR,oR,iR,Nias,ik) - | Subfic (RT,RA,SI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = - (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | Addc (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Subfc (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Adde (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let iR = (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Subfe (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let iR = (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Addme (RT,RA,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Subfme (RT,RA,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Addze (RT,RA,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Subfze (RT,RA,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: (RField ("XER","CA")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Neg (RT,RA,OE,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulli (RT,RA,SI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Mullw (RT,RA,RB,OE,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulhw (RT,RA,RB,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulhwu (RT,RA,RB,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divw (RT,RA,RB,OE,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divwu (RT,RA,RB,OE,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divwe (RT,RA,RB,OE,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divweu (RT,RA,RB,OE,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RT)),(0:ii),(31:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = mode64bit_fp :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulld (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulhd (RT,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mulhdu (RT,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divd (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divdu (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divde (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Divdeu (RT,RA,RB,OE,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let (iR, oR) = - if bitU_to_bool OE - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("XER","OV")) :: (RField ("XER","SO")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Cmpi (BF,L,RA,SI) -> - let iR = - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii)) - else RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - oR in - return (aR,oR,iR,Nias,ik) - | Cmp (BF,L,RA,RB) -> - let iR = - if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR - else - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = - (RSlice ("CR",unsigned (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - oR in - return (aR,oR,iR,Nias,ik) - | Cmpli (BF,L,RA,UI) -> - let iR = - (if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii)) - else RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - oR in - return (aR,oR,iR,Nias,ik) - | Cmpl (BF,L,RA,RB) -> - let iR = - if bitU_to_bool (eq (match L with | B0 -> (0:ii) | B1 -> (1:ii) end, (0:ii))) - then - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(32:ii),(63:ii))) :: iR - else - (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let iR = (RField ("XER","SO")) :: iR in - let oR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - oR in - return (aR,oR,iR,Nias,ik) - | Isel (RT,RA,RB,BC) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RSliceBit ("CR",add_VII (reset_vector_start BC) (32:ii))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Andi (RS,RA,UI) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: (RField ("XER","SO")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let oR = (RField ("CR","CR0")) :: oR in - return (aR,oR,iR,Nias,ik) - | Andis (RS,RA,UI) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: (RField ("XER","SO")) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let oR = (RField ("CR","CR0")) :: oR in - return (aR,oR,iR,Nias,ik) - | Ori (RS,RA,UI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Oris (RS,RA,UI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Xori (RS,RA,UI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Xoris (RS,RA,UI) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | And (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Xor (RS,RA,RB,Rc) -> - let (iR, oR) = - if bitU_to_bool (eq_vec (RS, RB)) - then - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - (iR,oR) - else - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - (iR,oR) in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Nand (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Or (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Nor (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Eqv (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Andc (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Orc (RS,RA,RB,Rc) -> - let iR = - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Extsb (RS,RA,Rc) -> - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(56:ii))) :: iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(56:ii),(63:ii))) :: iR in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(56:ii),(63:ii))) :: oR in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(0:ii),(55:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Extsh (RS,RA,Rc) -> - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(48:ii))) :: iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(48:ii),(63:ii))) :: iR in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(48:ii),(63:ii))) :: oR in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(0:ii),(47:ii))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Cntlzw (RS,RA,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Cmpb (RS,RA,RB) -> - let (oR, iR) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (oR,iR) - (fun n (oR,iR) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(8:ii) * n,((8:ii) * n) + (7:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(8:ii) * n,((8:ii) * n) + - (7:ii))) :: - iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(8:ii) * n,((8:ii) * n) + (7:ii))) :: - oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Popcntb (RS,RA) -> - let (oR, iR) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (oR,iR) - (fun i (oR,iR) -> - let iR = - (foreach_inc ((0:ii),(7:ii),(1:ii)) iR - (fun j iR -> - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(i * (8:ii)) + j)) :: iR)) in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),i * (8:ii),(i * (8:ii)) + (7:ii))) :: - oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Popcntw (RS,RA) -> - let (oR, iR) = - (foreach_inc ((0:ii),(1:ii),(1:ii)) (oR,iR) - (fun i (oR,iR) -> - let iR = - (foreach_inc ((0:ii),(31:ii),(1:ii)) iR - (fun j iR -> - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(i * (32:ii)) + j)) :: iR)) in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),i * (32:ii),(i * (32:ii)) + - (31:ii))) :: - oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Prtyd (RS,RA) -> - let iR = - (foreach_inc ((0:ii),(7:ii),(1:ii)) iR - (fun i iR -> - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(i * (8:ii)) + (7:ii))) :: iR)) in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Prtyw (RS,RA) -> - let iR = - (foreach_inc ((0:ii),(3:ii),(1:ii)) iR - (fun i iR -> - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(i * (8:ii)) + (7:ii))) :: iR)) in - let iR = - (foreach_inc ((4:ii),(7:ii),(1:ii)) iR - (fun i iR -> - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(i * (8:ii)) + (7:ii))) :: iR)) in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(0:ii),(31:ii))) :: oR in - let oR = (RSlice (access GPRs (unsigned (reset_vector_start RA)),(32:ii),(63:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Extsw (RS,RA,Rc) -> - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(32:ii))) :: iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Cntlzd (RS,RA,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Popcntd (RS,RA) -> - let iR = - (foreach_inc ((0:ii),(63:ii),(1:ii)) iR - (fun i iR -> (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),i)) :: iR)) in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Bpermd (RS,RA,RB) -> - let (oR, iR) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (oR,iR) - (fun i (oR,iR) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(8:ii) * i,((8:ii) * i) + (7:ii))) :: - iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Rlwinm (RS,RA,SH,MB,ME,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rlwnm (RS,RA,RB,MB,ME,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(59:ii),(63:ii))) :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rlwimi (RS,RA,SH,MB,ME,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldicl (RS,RA,sh,mb,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldicr (RS,RA,sh,me,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldic (RS,RA,sh,mb,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldcl (RS,RA,RB,mb,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RB)),(58:ii),(63:ii))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldcr (RS,RA,RB,me,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RB)),(58:ii),(63:ii))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Rldimi (RS,RA,sh,mb,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Slw (RS,RA,RB,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RB)),(59:ii),(63:ii))) :: iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(58:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Srw (RS,RA,RB,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RB)),(59:ii),(63:ii))) :: iR in - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(58:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Srawi (RS,RA,SH,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(32:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | Sraw (RS,RA,RB,Rc) -> - let iR = (RSlice (access GPRs (unsigned (reset_vector_start RB)),(59:ii),(63:ii))) :: iR in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: - (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(58:ii))) :: - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(32:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | Sld (RS,RA,RB,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(58:ii),(63:ii))) :: - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(57:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Srd (RS,RA,RB,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(58:ii),(63:ii))) :: - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(57:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Sradi (RS,RA,sh,Rc) -> - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let iR = (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(0:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | Srad (RS,RA,RB,Rc) -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(58:ii),(63:ii))) :: - (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: - (RSliceBit (access GPRs (unsigned (reset_vector_start RB)),(57:ii))) :: - (RSliceBit (access GPRs (unsigned (reset_vector_start RS)),(0:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: oR in - let (iR, oR) = - if bitU_to_bool Rc - then - let iR = (RField ("XER","SO")) :: iR in - let oR = (RField ("CR","CR0")) :: oR in - (iR,oR) - else (iR,oR) in - let oR = (RField ("XER","CA")) :: oR in - return (aR,oR,iR,Nias,ik) - | Cdtbcd (RS,RA) -> - let (oR, iR) = - (foreach_inc ((0:ii),(1:ii),(1:ii)) (oR,iR) - (fun i (oR,iR) -> - let n = i * (32:ii) in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),n + (12:ii),n + (31:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),n + (0:ii),n + (31:ii))) :: oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Cbcdtd (RS,RA) -> - let (oR, iR) = - (foreach_inc ((0:ii),(1:ii),(1:ii)) (oR,iR) - (fun i (oR,iR) -> - let n = i * (32:ii) in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),n + (8:ii),n + (31:ii))) :: iR in - let oR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),n + (0:ii),n + (31:ii))) :: oR in - (oR,iR))) in - return (aR,oR,iR,Nias,ik) - | Addg6s (RT,RA,RB) -> - let iR = - (foreach_inc ((0:ii),(15:ii),(1:ii)) iR - (fun i iR -> - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RA)),(4:ii) * i,(63:ii))) :: iR in - (RSlice (access GPRs (unsigned (reset_vector_start RB)),(4:ii) * i,(63:ii))) :: iR)) in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Mtspr (RS,spr) -> - let n = (slice spr (5:ii) (9:ii)) ^^ (slice spr (0:ii) (4:ii)) in - let (iR, oR) = - if bitU_to_bool (eq_vec_range (n, (1:ii))) - then - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull "XER") :: oR in - (iR,oR) - else - let iR = (RFull (access SPRs (unsigned (reset_vector_start n)))) :: iR in - let (iR, oR) = - if bitU_to_bool (eq_range (length_spr (unsigned (reset_vector_start n)), (64:ii))) - then - let iR = (RFull (access GPRs (unsigned (reset_vector_start RS)))) :: iR in - let oR = (RFull (access SPRs (unsigned (reset_vector_start n)))) :: oR in - (iR,oR) - else - let (iR, oR) = - if bitU_to_bool (eq_vec_range (n, (152:ii))) - then - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let oR = (RFull "CTRL") :: oR in - (iR,oR) - else (iR,oR) in - (iR,oR) in - (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mfspr (RT,spr) -> - let n = (slice spr (5:ii) (9:ii)) ^^ (slice spr (0:ii) (4:ii)) in - let iR = (RFull (access SPRs (unsigned (reset_vector_start n)))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Mtcrf (RS,FXM) -> - let iR = - (RFull "CR") :: - (RSlice (access GPRs (unsigned (reset_vector_start RS)),(32:ii),(63:ii))) :: iR in - let oR = (RFull "CR") :: oR in - return (aR,oR,iR,Nias,ik) - | Mfcr (RT) -> - let iR = (RFull "CR") :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - return (aR,oR,iR,Nias,ik) - | Mtocrf (RS,FXM) -> - let n = (0:ii) in - let count = (0:ii) in - let (count, n) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (count,n) - (fun i (count,n) -> - let (n, count) = - if bitU_to_bool - (eq (match (access FXM i) with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then - let n = i in - let count = count + (1:ii) in - (n,count) - else (n,count) in - (count,n))) in - let (oR, iR) = - if bitU_to_bool (eq_range (count, (1:ii))) - then - let oR = (RSlice ("CR",((4:ii) * n) + (32:ii),((4:ii) * n) + (35:ii))) :: oR in - let iR = - (RSlice (access GPRs (unsigned (reset_vector_start RS)),((4:ii) * n) + (32:ii),((4:ii) * - n) + - (35:ii))) :: - iR in - (oR,iR) - else - let oR = (RFull "CR") :: oR in - (oR,iR) in - return (aR,oR,iR,Nias,ik) - | Mfocrf (RT,FXM) -> - let n = (0:ii) in - let count = (0:ii) in - let (count, n) = - (foreach_inc ((0:ii),(7:ii),(1:ii)) (count,n) - (fun i (count,n) -> - let (n, count) = - if bitU_to_bool - (eq (match (access FXM i) with | B0 -> (0:ii) | B1 -> (1:ii) end, (1:ii))) - then - let n = i in - let count = count + (1:ii) in - (n,count) - else (n,count) in - (count,n))) in - let (iR, oR) = - if bitU_to_bool (eq_range (count, (1:ii))) - then - let iR = (RSlice ("CR",((4:ii) * n) + (32:ii),((4:ii) * n) + (35:ii))) :: iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - (iR,oR) - else - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - (iR,oR) in - return (aR,oR,iR,Nias,ik) - | Mcrxr (BF) -> - let iR = (RSlice ("XER",(32:ii),(35:ii))) :: iR in - let oR = - (RSlice ("CR",add_VII (reset_vector_start (mult_IVV (4:ii) (reset_vector_start BF))) (32:ii),add_VII - (reset_vector_start (mult_IVV - (4:ii) - (reset_vector_start BF))) - (35:ii))) :: - (RSlice ("XER",(32:ii),(35:ii))) :: oR in - return (aR,oR,iR,Nias,ik) - | Dlmzb (RS,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Macchws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Macchwu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Macchwsu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Machhws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Machhwu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Machhwsu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Maclhw (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Maclhws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Maclhwu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Maclhwsu (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Mulchw (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Mulchwu (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Mulhhw (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Mulhhwu (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Mullhw (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Mullhwu (RT,RA,RB,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmacchw (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmacchws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmachhw (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmachhws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmaclhw (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Nmaclhws (RT,RA,RB,OE,Rc) -> return (aR,oR,iR,Nias,ik) - | Icbi (RA,RB) -> return (aR,oR,iR,Nias,ik) - | Icbt (CT,RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcba (RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcbt (TH,RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcbtst (TH,RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcbz (RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcbst (RA,RB) -> return (aR,oR,iR,Nias,ik) - | Dcbf (L,RA,RB) -> return (aR,oR,iR,Nias,ik) - | Isync -> - let ik = IK_barrier Barrier_Isync in - return (aR,oR,iR,Nias,ik) - | Lbarx (RT,RA,RB,EH) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_reserve in - return (aR,oR,iR,Nias,ik) - | Lharx (RT,RA,RB,EH) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_reserve in - return (aR,oR,iR,Nias,ik) - | Lwarx (RT,RA,RB,EH) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_reserve in - return (aR,oR,iR,Nias,ik) - | Stbcx (RS,RA,RB) -> - let ik = IK_mem_write Write_conditional in - return (aR,oR,iR,Nias,ik) - | Sthcx (RS,RA,RB) -> - let ik = IK_mem_write Write_conditional in - return (aR,oR,iR,Nias,ik) - | Stwcx (RS,RA,RB) -> - let ik = IK_mem_write Write_conditional in - return (aR,oR,iR,Nias,ik) - | Ldarx (RT,RA,RB,EH) -> - let iR = - if bitU_to_bool (eq_vec_range (RA, (0:ii))) - then iR - else (RFull (access GPRs (unsigned (reset_vector_start RA)))) :: iR in - let iR = (RFull (access GPRs (unsigned (reset_vector_start RB)))) :: iR in - let aR = iR in - let oR = (RFull (access GPRs (unsigned (reset_vector_start RT)))) :: oR in - let ik = IK_mem_read Read_reserve in - return (aR,oR,iR,Nias,ik) - | Stdcx (RS,RA,RB) -> - let ik = IK_mem_write Write_conditional in - return (aR,oR,iR,Nias,ik) - | Sync (L) -> - let ik = - match L with - | Vector [B0;B0] _ _ -> IK_barrier Barrier_Sync - | Vector [B0;B1] _ _ -> IK_barrier Barrier_LwSync - end in - return (aR,oR,iR,Nias,ik) - | Eieio -> - let ik = IK_barrier Barrier_Eieio in - return (aR,oR,iR,Nias,ik) - | Wait (WC) -> return (aR,oR,iR,Nias,ik) - end >>= fun (aR, oR, iR, Nias, ik) -> - return (iR,oR,aR,Nias,Dia,ik) - diff --git a/risc-v/Makefile b/risc-v/Makefile deleted file mode 100644 index bc46e4c2..00000000 --- a/risc-v/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -SAIL:=../src/sail.native -LEM:=../../lem/lem - -SOURCES:=riscv_types.sail riscv.sail ../etc/regfp.sail riscv_regfp.sail - - -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.ml - rm -f riscv_embed*.lem riscv_toFromInterp.lem diff --git a/risc-v/gen/ast.hgen b/risc-v/gen/ast.hgen deleted file mode 100644 index b1968173..00000000 --- a/risc-v/gen/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/gen/fold.hgen b/risc-v/gen/fold.hgen deleted file mode 100644 index 4c51e114..00000000 --- a/risc-v/gen/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/gen/herdtools_ast_to_shallow_ast.hgen b/risc-v/gen/herdtools_ast_to_shallow_ast.hgen deleted file mode 100644 index 07c1d082..00000000 --- a/risc-v/gen/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/gen/herdtools_types_to_shallow_types.hgen b/risc-v/gen/herdtools_types_to_shallow_types.hgen deleted file mode 100644 index e6edd24d..00000000 --- a/risc-v/gen/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/gen/lexer.hgen b/risc-v/gen/lexer.hgen deleted file mode 100644 index e42b8a62..00000000 --- a/risc-v/gen/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/gen/map.hgen b/risc-v/gen/map.hgen deleted file mode 100644 index bab5ced8..00000000 --- a/risc-v/gen/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/gen/parser.hgen b/risc-v/gen/parser.hgen deleted file mode 100644 index 210e38fb..00000000 --- a/risc-v/gen/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<op>' 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 deleted file mode 100644 index fc1c0000..00000000 --- a/risc-v/gen/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/gen/pretty_xml.hgen b/risc-v/gen/pretty_xml.hgen deleted file mode 100644 index b0306161..00000000 --- a/risc-v/gen/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/gen/sail_trans_out.hgen b/risc-v/gen/sail_trans_out.hgen deleted file mode 100644 index 2f9a80f1..00000000 --- a/risc-v/gen/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/gen/shallow_ast_to_herdtools_ast.hgen b/risc-v/gen/shallow_ast_to_herdtools_ast.hgen deleted file mode 100644 index 3025992e..00000000 --- a/risc-v/gen/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/gen/shallow_types_to_herdtools_types.hgen b/risc-v/gen/shallow_types_to_herdtools_types.hgen deleted file mode 100644 index 6b3b7f51..00000000 --- a/risc-v/gen/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/gen/token_types.hgen b/risc-v/gen/token_types.hgen deleted file mode 100644 index f29e318d..00000000 --- a/risc-v/gen/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/gen/tokens.hgen b/risc-v/gen/tokens.hgen deleted file mode 100644 index f812adbd..00000000 --- a/risc-v/gen/tokens.hgen +++ /dev/null @@ -1,19 +0,0 @@ -%token <RISCVHGenBase.token_UTYPE> UTYPE -%token <RISCVHGenBase.token_JAL> JAL -%token <RISCVHGenBase.token_JALR> JALR -%token <RISCVHGenBase.token_BType> BTYPE -%token <RISCVHGenBase.token_IType> ITYPE -%token <RISCVHGenBase.token_ShiftIop> SHIFTIOP -%token <RISCVHGenBase.token_RTYPE> RTYPE -%token <RISCVHGenBase.token_Load> LOAD -%token <RISCVHGenBase.token_Store> STORE -%token <RISCVHGenBase.token_ADDIW> ADDIW -%token <RISCVHGenBase.token_SHIFTW> SHIFTW -%token <RISCVHGenBase.token_RTYPEW> RTYPEW -%token <RISCVHGenBase.token_FENCE> FENCE -%token <RISCVHGenBase.token_FENCEOPTION> FENCEOPTION -%token <RISCVHGenBase.token_FENCEI> FENCEI -%token <RISCVHGenBase.token_LoadRes> LOADRES -%token <RISCVHGenBase.token_StoreCon> STORECON -%token <RISCVHGenBase.token_AMO> AMO -%token <RISCVHGenBase.token_LI> LI diff --git a/risc-v/gen/trans_sail.hgen b/risc-v/gen/trans_sail.hgen deleted file mode 100644 index 8b7cbe11..00000000 --- a/risc-v/gen/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/gen/types.hgen b/risc-v/gen/types.hgen deleted file mode 100644 index a0b75606..00000000 --- a/risc-v/gen/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/gen/types_sail_trans_out.hgen b/risc-v/gen/types_sail_trans_out.hgen deleted file mode 100644 index 66a2020c..00000000 --- a/risc-v/gen/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/gen/types_trans_sail.hgen b/risc-v/gen/types_trans_sail.hgen deleted file mode 100644 index 238c7e5b..00000000 --- a/risc-v/gen/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]) diff --git a/risc-v/riscv.sail b/risc-v/riscv.sail deleted file mode 100644 index 3d52d111..00000000 --- a/risc-v/riscv.sail +++ /dev/null @@ -1,407 +0,0 @@ -scattered typedef ast = const union - -val bit[32] -> option<ast> effect pure decode -scattered function option<ast> 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, 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 RISCV_LUI -> off - case RISCV_AUIPC -> PC + off - } in - wGPR(rd, ret) - -(********************************************************************) -union ast member ((bit[21]), regno) RISCV_JAL - -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 (RISCV_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) RISCV_JALR - -function clause decode ((bit[12]) imm : (regno) rs1 : 0b000 : (regno) rd : 0b1100111) = - Some(RISCV_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); - nextPC := newPC[63..1] : 0b0; -} - -(********************************************************************) -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, 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, 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, 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, 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, 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, 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 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) - -(********************************************************************) -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, 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 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, 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 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, 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 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) - -(********************************************************************) -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, 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, 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, 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, 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], 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) - } - } - -(********************************************************************) -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 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, 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 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, 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 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)) - -(********************************************************************) -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() - 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") - } -} - -(********************************************************************) -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)) = - 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)) = { - (*(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, 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], aq, rl, true) - case DOUBLE -> mem_write_value(addr, 8, rs2_val, aq, 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, 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, aq & rl, true)) - case DOUBLE -> mem_read(addr, 8, aq, aq & rl, 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], aq & rl, rl, true) - case DOUBLE -> mem_write_value(addr, 8, result, aq & rl, rl, true) - }; -} - -(********************************************************************) - -function clause decode _ = None - -end ast -end decode -end execute diff --git a/risc-v/riscv_extras.lem b/risc-v/riscv_extras.lem deleted file mode 100644 index 4ca5f9b7..00000000 --- a/risc-v/riscv_extras.lem +++ /dev/null @@ -1,83 +0,0 @@ -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 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)); - ("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 riscv_memory_writes : memory_writes = - [] - -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)); - ("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 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)); - ("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 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 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); - ("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 deleted file mode 100644 index 32110079..00000000 --- a/risc-v/riscv_extras_embed.lem +++ /dev/null @@ -1,71 +0,0 @@ -open import Pervasives -open import Pervasives_extra -open import Sail_impl_base -open import Sail_values -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_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) - -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 - -let duplicate (bit,len) = - let bits = repeat [bit] len in - let start = len - 1 in - Vector bits start false diff --git a/risc-v/riscv_extras_embed_sequential.lem b/risc-v/riscv_extras_embed_sequential.lem deleted file mode 100644 index 3c922268..00000000 --- a/risc-v/riscv_extras_embed_sequential.lem +++ /dev/null @@ -1,71 +0,0 @@ -open import Pervasives -open import Pervasives_extra -open import Sail_impl_base -open import Sail_values -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_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) - -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 - -let duplicate (bit,len) = - let bits = repeat [bit] len in - let start = len - 1 in - Vector bits start false diff --git a/risc-v/riscv_regfp.sail b/risc-v/riscv_regfp.sail deleted file mode 100644 index dee9cc8e..00000000 --- a/risc-v/riscv_regfp.sail +++ /dev/null @@ -1,145 +0,0 @@ -let (vector <0, 32, inc, string >) GPRstr = - [ "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" - ] - -let CIA_fp = RFull("CIA") -let NIA_fp = RFull("NIA") - -function (regfps,regfps,regfps,niafps,diafp,instruction_kind) initial_analysis (instr) = { - iR := [|| ||]; - oR := [|| ||]; - aR := [|| ||]; - ik := IK_simple; - Nias := [|| NIAFP_successor ||]; - Dia := DIAFP_none; - - switch instr { - case (EBREAK) -> () - case (UTYPE ( imm, rd, op)) -> { - if (rd == 0) then () else oR := RFull(GPRstr[rd]) :: oR; - } - 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 (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 - Nias := [|| NIAFP_register (RFull(GPRstr[rs])) ||]; - } - 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, 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 := - 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, 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 := - 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; - 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 (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" - }; - } - 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; - 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 (false, true) -> exit "not implemented" - case (true, true) -> IK_mem_read (Read_RISCV_reserved_strong_acquire) - }; - } - 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; - 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_strong_acquire, - Write_RISCV_conditional_strong_release) - }; - } - }; - (iR,oR,aR,Nias,Dia,ik) -} diff --git a/risc-v/riscv_types.sail b/risc-v/riscv_types.sail deleted file mode 100644 index b584ae9b..00000000 --- a/risc-v/riscv_types.sail +++ /dev/null @@ -1,166 +0,0 @@ -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_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 - -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 *) - -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] diff --git a/src/LICENCE b/src/LICENCE index 6b6dcc4f..c777e037 100644 --- a/src/LICENCE +++ b/src/LICENCE @@ -20,8 +20,9 @@ Copyright (c) 2013-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. +Laboratory and the University of Edinburgh 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 diff --git a/src/Makefile b/src/Makefile index abf03c4f..a39067b6 100644 --- a/src/Makefile +++ b/src/Makefile @@ -57,14 +57,21 @@ all: sail lib doc full: sail lib power doc test -ast.ml: ../language/l2.ott - ott -sort false -generate_aux_rules true -o ast.ml -picky_multiple_parses true ../language/l2.ott +ast.lem: ../language/l2.ott + ott -sort false -generate_aux_rules true -o ast.lem -picky_multiple_parses true ../language/l2.ott + +ast.ml: ast.lem + lem -ocaml ast.lem + sed -i -f ast.sed ast.ml lem_interp/interp_ast.lem: ../language/l2.ott ott -sort false -generate_aux_rules true -o lem_interp/interp_ast.lem -picky_multiple_parses true ../language/l2.ott sail: ast.ml - ocamlbuild sail.native + ocamlbuild -use-ocamlfind sail.native + +isail: ast.ml + ocamlbuild -use-ocamlfind isail.native sail.native: sail @@ -84,7 +91,7 @@ SAIL_DIR:=$(realpath $(dir $(THIS_MAKEFILE))..) BITBUCKET_ROOT=$(realpath $(dir $(THIS_MAKEFILE))../..) LEM = $(BITBUCKET_ROOT)/lem/lem -LEMLIBOCAML = $(BITBUCKET_ROOT)/lem/ocaml-lib +LEMLIBOCAML = $(BITBUCKET_ROOT)/lem/ocaml-lib/_build_zarith ELFDIR= $(BITBUCKET_ROOT)/linksem ZARITH_DIR=$(LEMLIBOCAML)/dependencies/zarith ZARITH_LIB=$(ZARITH_DIR)/zarith.cma @@ -257,6 +264,7 @@ clean: -rm -rf lem lib -rm -rf sail.docdir -rm -f ast.ml + -rm -f ast.lem doc: ocamlbuild sail.docdir/index.html @@ -1,12 +1,16 @@ true: -traverse, debug, use_menhir <**/*.ml>: bin_annot, annot -<lem_interp> or <test>: include -<sail.{byte,native}>: use_pprint, use_nums, use_unix, use_str +# <lem_interp> or <test>: include +<sail.{byte,native}>: package(zarith), package(linksem), package(lem), use_pprint +<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), use_pprint +<isail.ml>: package(linenoise) +<elf_loader.ml>: package(linksem) <pprint> or <pprint/src>: include +<*.m{l,li}>: package(lem) # see http://caml.inria.fr/mantis/view.php?id=4943 -<lem_interp/*> and not <lem_interp/*.cmxa>: use_nums, use_lem -<test/*> and not <test/*.cmxa>: use_nums, use_lem, use_str +<lem_interp/*> and not <lem_interp/*.cmxa>: use_nums, package(lem) +<test/*> and not <test/*.cmxa>: use_nums, package(lem), use_str # disable partial match and unused variable warnings <**/*.ml>: warn_y diff --git a/src/ast.sed b/src/ast.sed new file mode 100644 index 00000000..39c58a50 --- /dev/null +++ b/src/ast.sed @@ -0,0 +1,2 @@ +s/type l = | Unknown/type l = Parse_ast.l/ +s/type value = | Val/open Value/ diff --git a/src/ast_util.ml b/src/ast_util.ml index 4ceb3e7f..206515c5 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -50,7 +50,7 @@ open Ast open Util -open Big_int +module Big_int = Nat_big_num let no_annot = (Parse_ast.Unknown, ()) @@ -141,7 +141,16 @@ module Nexp = struct match nexp1, nexp2 with | Nexp_id v1, Nexp_id v2 -> Id.compare v1 v2 | Nexp_var kid1, Nexp_var kid2 -> Kid.compare kid1 kid2 - | Nexp_constant c1, Nexp_constant c2 -> compare_big_int c1 c2 + | Nexp_constant c1, Nexp_constant c2 -> Big_int.compare c1 c2 + | Nexp_app (op1, args1), Nexp_app (op2, args2) -> + let lex1 = Id.compare op1 op2 in + let lex2 = List.length args1 - List.length args2 in + let lex3 = + if lex2 = 0 then + List.fold_left2 (fun l n1 n2 -> if compare n1 n2 = 0 then 0 else compare n1 n2) 0 args1 args2 + else 0 + in + lex_ord (lex1, lex_ord (lex2, lex3)) | Nexp_times (n1a, n1b), Nexp_times (n2a, n2b) | Nexp_sum (n1a, n1b), Nexp_sum (n2a, n2b) | Nexp_minus (n1a, n1b), Nexp_minus (n2a, n2b) -> @@ -172,6 +181,7 @@ let rec is_nexp_constant (Nexp_aux (nexp, _)) = match nexp with | Nexp_times (n1, n2) | Nexp_sum (n1, n2) | Nexp_minus (n1, n2) -> is_nexp_constant n1 && is_nexp_constant n2 | Nexp_exp n | Nexp_neg n -> is_nexp_constant n + | Nexp_app (_, nexps) -> List.for_all is_nexp_constant nexps let rec nexp_simp (Nexp_aux (nexp, l)) = Nexp_aux (nexp_simp_aux nexp, l) and nexp_simp_aux = function @@ -186,7 +196,7 @@ and nexp_simp_aux = function let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in match n1_simp, n2_simp with - | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (add_big_int c1 c2) + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (Big_int.add c1 c2) | _, Nexp_neg n2 -> Nexp_minus (n1, n2) | _, _ -> Nexp_sum (n1, n2) end @@ -195,9 +205,9 @@ and nexp_simp_aux = function let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in match n1_simp, n2_simp with - | Nexp_constant c, _ when eq_big_int c unit_big_int -> n2_simp - | _, Nexp_constant c when eq_big_int c unit_big_int -> n1_simp - | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (mult_big_int c1 c2) + | Nexp_constant c, _ when Big_int.equal c (Big_int.of_int 1) -> n2_simp + | _, Nexp_constant c when Big_int.equal c (Big_int.of_int 1) -> n1_simp + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (Big_int.mul c1 c2) | _, _ -> Nexp_times (n1, n2) end | Nexp_minus (n1, n2) -> @@ -205,10 +215,10 @@ and nexp_simp_aux = function let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in match n1_simp, n2_simp with - | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (sub_big_int c1 c2) + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (Big_int.sub c1 c2) (* A vector range x['n-1 .. 0] can result in the size "('n-1) - -1" *) | Nexp_minus (Nexp_aux (n,_), Nexp_aux (Nexp_constant c1,_)), Nexp_constant c2 - when eq_big_int c1 (minus_big_int c2) -> n + when Big_int.equal c1 (Big_int.negate c2) -> n | _, _ -> Nexp_minus (n1, n2) end | nexp -> nexp @@ -228,6 +238,8 @@ let unit_typ = mk_id_typ (mk_id "unit") let bit_typ = mk_id_typ (mk_id "bit") let real_typ = mk_id_typ (mk_id "real") let app_typ id args = mk_typ (Typ_app (id, args)) +let ref_typ typ = mk_typ (Typ_app (mk_id "ref", [mk_typ_arg (Typ_arg_typ typ)])) +let register_typ typ = mk_typ (Typ_app (mk_id "register", [mk_typ_arg (Typ_arg_typ typ)])) let atom_typ nexp = mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (Typ_arg_nexp (nexp_simp nexp))])) let range_typ nexp1 nexp2 = @@ -239,17 +251,16 @@ let list_typ typ = mk_typ (Typ_app (mk_id "list", [mk_typ_arg (Typ_arg_typ typ)] let tuple_typ typs = mk_typ (Typ_tup typs) let function_typ typ1 typ2 eff = mk_typ (Typ_fn (typ1, typ2, eff)) -let vector_typ n m ord typ = +let vector_typ n ord typ = mk_typ (Typ_app (mk_id "vector", [mk_typ_arg (Typ_arg_nexp (nexp_simp n)); - mk_typ_arg (Typ_arg_nexp (nexp_simp m)); mk_typ_arg (Typ_arg_order ord); mk_typ_arg (Typ_arg_typ typ)])) let exc_typ = mk_id_typ (mk_id "exception") let nconstant c = Nexp_aux (Nexp_constant c, Parse_ast.Unknown) -let nint i = nconstant (big_int_of_int i) +let nint i = nconstant (Big_int.of_int i) let nminus n1 n2 = Nexp_aux (Nexp_minus (n1, n2), Parse_ast.Unknown) let nsum n1 n2 = Nexp_aux (Nexp_sum (n1, n2), Parse_ast.Unknown) let ntimes n1 n2 = Nexp_aux (Nexp_times (n1, n2), Parse_ast.Unknown) @@ -258,7 +269,7 @@ 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 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_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) @@ -329,6 +340,7 @@ and map_exp_annot_aux f = function | E_block xs -> E_block (List.map (map_exp_annot f) xs) | E_nondet xs -> E_nondet (List.map (map_exp_annot f) xs) | E_id id -> E_id id + | E_ref id -> E_ref id | E_lit lit -> E_lit lit | E_cast (typ, exp) -> E_cast (typ, map_exp_annot f exp) | E_app (id, xs) -> E_app (id, List.map (map_exp_annot f) xs) @@ -365,7 +377,8 @@ and map_exp_annot_aux f = function | E_internal_exp_user (annot1, annot2) -> E_internal_exp_user (f annot1, f annot2) | E_comment str -> E_comment str | E_comment_struc exp -> E_comment_struc (map_exp_annot f exp) - | E_internal_let (lexp, exp1, exp2) -> E_internal_let (map_lexp_annot f lexp, map_exp_annot f exp1, map_exp_annot f exp2) + | E_internal_value v -> E_internal_value v + | E_var (lexp, exp1, exp2) -> E_var (map_lexp_annot f lexp, map_exp_annot f exp1, map_exp_annot f exp2) | E_internal_plet (pat, exp1, exp2) -> E_internal_plet (map_pat_annot f pat, map_exp_annot f exp1, map_exp_annot f exp2) | E_internal_return exp -> E_internal_return (map_exp_annot f exp) and map_opt_default_annot f (Def_val_aux (df, annot)) = Def_val_aux (map_opt_default_annot_aux f df, f annot) @@ -400,6 +413,7 @@ and map_letbind_annot_aux f = function and map_lexp_annot f (LEXP_aux (lexp, annot)) = LEXP_aux (map_lexp_annot_aux f lexp, f annot) and map_lexp_annot_aux f = function | LEXP_id id -> LEXP_id id + | LEXP_deref exp -> LEXP_deref (map_exp_annot f exp) | LEXP_memory (id, exps) -> LEXP_memory (id, List.map (map_exp_annot f) exps) | LEXP_cast (typ, id) -> LEXP_cast (typ, id) | LEXP_tup lexps -> LEXP_tup (List.map (map_lexp_annot f) lexps) @@ -479,8 +493,6 @@ let string_of_base_effect = function | BE_aux (beff, _) -> string_of_base_effect_aux beff let string_of_effect = function - | Effect_aux (Effect_var kid, _) -> - string_of_kid kid | Effect_aux (Effect_set [], _) -> "pure" | Effect_aux (Effect_set beffs, _) -> "{" ^ string_of_list ", " string_of_base_effect beffs ^ "}" @@ -495,7 +507,7 @@ let rec string_of_nexp = function and string_of_nexp_aux = function | Nexp_id id -> string_of_id id | Nexp_var kid -> string_of_kid kid - | Nexp_constant c -> string_of_big_int c + | Nexp_constant c -> Big_int.to_string c | Nexp_times (n1, n2) -> "(" ^ string_of_nexp n1 ^ " * " ^ string_of_nexp n2 ^ ")" | Nexp_sum (n1, n2) -> "(" ^ string_of_nexp n1 ^ " + " ^ string_of_nexp n2 ^ ")" | Nexp_minus (n1, n2) -> "(" ^ string_of_nexp n1 ^ " - " ^ string_of_nexp n2 ^ ")" @@ -530,7 +542,7 @@ and string_of_n_constraint = function | NC_aux (NC_and (nc1, nc2), _) -> "(" ^ string_of_n_constraint nc1 ^ " & " ^ string_of_n_constraint nc2 ^ ")" | NC_aux (NC_set (kid, ns), _) -> - string_of_kid kid ^ " IN {" ^ string_of_list ", " string_of_big_int ns ^ "}" + string_of_kid kid ^ " IN {" ^ string_of_list ", " Big_int.to_string ns ^ "}" | NC_aux (NC_true, _) -> "true" | NC_aux (NC_false, _) -> "false" @@ -563,7 +575,7 @@ let string_of_lit (L_aux (lit, _)) = | L_one -> "bitone" | L_true -> "true" | L_false -> "false" - | L_num n -> string_of_big_int n + | L_num n -> Big_int.to_string n | L_hex n -> "0x" ^ n | L_bin n -> "0b" ^ n | L_undef -> "undefined" @@ -574,6 +586,7 @@ let rec string_of_exp (E_aux (exp, _)) = match exp with | E_block exps -> "{ " ^ string_of_list "; " string_of_exp exps ^ " }" | E_id v -> string_of_id v + | E_ref id -> "ref " ^ string_of_id id | E_sizeof nexp -> "sizeof " ^ string_of_nexp nexp | E_constraint nc -> "constraint(" ^ string_of_n_constraint nc ^ ")" | E_lit lit -> string_of_lit lit @@ -620,7 +633,7 @@ let rec string_of_exp (E_aux (exp, _)) = | E_internal_exp_user _ -> "INTERNAL EXP USER" | E_comment _ -> "INTERNAL COMMENT" | E_comment_struc _ -> "INTERNAL COMMENT STRUC" - | E_internal_let _ -> "INTERNAL LET" + | E_var _ -> "INTERNAL LET" | E_internal_return exp -> "internal_return (" ^ string_of_exp exp ^ ")" | E_internal_plet (pat, exp, body) -> "internal_plet " ^ string_of_pat pat ^ " = " ^ string_of_exp exp ^ " in " ^ string_of_exp body | _ -> "INTERNAL" @@ -648,6 +661,7 @@ and string_of_pat (P_aux (pat, l)) = and string_of_lexp (LEXP_aux (lexp, _)) = match lexp with | LEXP_id v -> string_of_id v + | LEXP_deref exp -> "*(" ^ string_of_exp exp ^ ")" | LEXP_cast (typ, v) -> "(" ^ string_of_typ typ ^ ") " ^ string_of_id v | LEXP_tup lexps -> "(" ^ string_of_list ", " string_of_lexp lexps ^ ")" | LEXP_vector (lexp, exp) -> string_of_lexp lexp ^ "[" ^ string_of_exp exp ^ "]" @@ -655,15 +669,14 @@ and string_of_lexp (LEXP_aux (lexp, _)) = string_of_lexp lexp ^ "[" ^ string_of_exp exp1 ^ ".." ^ string_of_exp exp2 ^ "]" | LEXP_field (lexp, id) -> string_of_lexp lexp ^ "." ^ string_of_id id | LEXP_memory (f, xs) -> string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")" - | _ -> "LEXP" and string_of_letbind (LB_aux (lb, l)) = match lb with | LB_val (pat, exp) -> string_of_pat pat ^ " = " ^ string_of_exp exp let rec string_of_index_range (BF_aux (ir, _)) = match ir with - | BF_single n -> string_of_big_int n - | BF_range (n, m) -> string_of_big_int n ^ " .. " ^ string_of_big_int m + | BF_single n -> Big_int.to_string n + | BF_range (n, m) -> Big_int.to_string n ^ " .. " ^ Big_int.to_string m | BF_concat (ir1, ir2) -> "(" ^ string_of_index_range ir1 ^ ") : (" ^ string_of_index_range ir2 ^ ")" let id_of_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) = @@ -684,7 +697,7 @@ let id_of_type_def_aux = function | TD_record (id, _, _, _, _) | TD_variant (id, _, _, _, _) | TD_enum (id, _, _, _) - | TD_register (id, _, _, _) -> id + | TD_bitfield (id, _, _) -> id let id_of_type_def (TD_aux (td_aux, _)) = id_of_type_def_aux td_aux module BE = struct @@ -704,6 +717,7 @@ let rec nexp_frees (Nexp_aux (nexp, l)) = | Nexp_minus (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2) | Nexp_exp n -> nexp_frees n | Nexp_neg n -> nexp_frees n + | Nexp_app (_, nexps) -> List.fold_left KidSet.union KidSet.empty (List.map nexp_frees nexps) let rec lexp_to_exp (LEXP_aux (lexp_aux, annot) as le) = let rewrap e_aux = E_aux (e_aux, annot) in @@ -720,6 +734,7 @@ let rec lexp_to_exp (LEXP_aux (lexp_aux, annot) as le) = | LEXP_vector_range (lexp, e1, e2) -> rewrap (E_vector_subrange (lexp_to_exp lexp, e1, e2)) | LEXP_field (lexp, id) -> rewrap (E_field (lexp_to_exp lexp, id)) | LEXP_memory (id, exps) -> rewrap (E_app (id, exps)) + | LEXP_deref exp -> rewrap (E_app (mk_id "reg_deref", [exp])) let destruct_range (Typ_aux (typ_aux, _)) = match typ_aux with @@ -743,7 +758,7 @@ let is_reftyp (Typ_aux (typ_aux, _)) = match typ_aux with | _ -> false let rec is_vector_typ = function - | Typ_aux (Typ_app (Id_aux (Id "vector",_), [_;_;_;_]), _) -> true + | Typ_aux (Typ_app (Id_aux (Id "vector",_), [_;_;_]), _) -> true | Typ_aux (Typ_app (Id_aux (Id "register",_), [Typ_arg_aux (Typ_arg_typ rtyp,_)]), _) -> is_vector_typ rtyp | _ -> false @@ -756,8 +771,13 @@ let typ_app_args_of = function ("typ_app_args_of called on non-app type " ^ string_of_typ typ)) let rec vector_typ_args_of typ = match typ_app_args_of typ with - | ("vector", [Typ_arg_nexp start; Typ_arg_nexp len; Typ_arg_order ord; Typ_arg_typ etyp], _) -> - (nexp_simp start, nexp_simp len, ord, etyp) + | ("vector", [Typ_arg_nexp len; Typ_arg_order ord; Typ_arg_typ etyp], l) -> + begin + match ord with + | Ord_aux (Ord_inc, _) -> (nint 0, nexp_simp len, ord, etyp) + | Ord_aux (Ord_dec, _) -> (nexp_simp (nminus len (nint 1)), nexp_simp len, ord, etyp) (* FIXME to return 3 arguments *) + | _ -> raise (Reporting_basic.err_typ l "Can't calculate start index without order") + end | ("register", [Typ_arg_typ rtyp], _) -> vector_typ_args_of rtyp | (_, _, l) -> raise (Reporting_basic.err_typ l @@ -782,9 +802,6 @@ let is_bitvector_typ typ = let has_effect (Effect_aux (eff,_)) searched_for = match eff with | Effect_set effs -> List.exists (fun (BE_aux (be,_)) -> be = searched_for) effs - | Effect_var _ -> - raise (Reporting_basic.err_unreachable Parse_ast.Unknown - "has_effect called on effect variable") let effect_set (Effect_aux (eff,_)) = match eff with | Effect_set effs -> BESet.of_list effs @@ -796,13 +813,11 @@ let union_effects e1 e2 = | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) -> let base_effs3 = BESet.elements (BESet.of_list (base_effs1 @ base_effs2)) in Effect_aux (Effect_set base_effs3, Parse_ast.Unknown) - | _, _ -> assert false (* We don't do Effect variables *) let equal_effects e1 e2 = match e1, e2 with | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) -> BESet.compare (BESet.of_list base_effs1) (BESet.of_list base_effs2) = 0 - | _, _ -> assert false (* We don't do Effect variables *) let rec tyvars_of_nexp (Nexp_aux (nexp,_)) = match nexp with @@ -814,6 +829,7 @@ let rec tyvars_of_nexp (Nexp_aux (nexp,_)) = | Nexp_minus (n1,n2) -> KidSet.union (tyvars_of_nexp n1) (tyvars_of_nexp n2) | Nexp_exp n | Nexp_neg n -> tyvars_of_nexp n + | Nexp_app (_, nexps) -> List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_nexp nexps) let rec tyvars_of_typ (Typ_aux (t,_)) = match t with @@ -848,7 +864,9 @@ let rec undefined_of_typ mwords l annot (Typ_aux (typ_aux, _) as typ) = wrap (E_sizeof i) typ | Typ_app (id, args) -> wrap (E_app (prepend_id "undefined_" id, - List.concat (List.map (undefined_of_typ_args mwords l annot) args))) typ + List.concat (List.map (undefined_of_typ_args mwords l annot) args))) typ + | Typ_tup typs -> + wrap (E_tuple (List.map (undefined_of_typ mwords l annot) typs)) typ | Typ_var kid -> (* Undefined monomorphism restriction in the type checker should guarantee that the typ_(kid) parameter was always one created @@ -856,7 +874,7 @@ let rec undefined_of_typ mwords l annot (Typ_aux (typ_aux, _) as typ) = initial_check.ml. i.e. the rewriter should only encounter this case when re-writing those functions. *) wrap (E_id (prepend_id "typ_" (id_of_kid kid))) typ - | Typ_fn _ -> assert false + | Typ_fn _ | Typ_exist _ -> assert false (* Typ_exist should be re-written *) and undefined_of_typ_args mwords l annot (Typ_arg_aux (typ_arg_aux, _) as typ_arg) = match typ_arg_aux with | Typ_arg_nexp n -> [E_aux (E_sizeof n, (l, annot (atom_typ n)))] diff --git a/src/ast_util.mli b/src/ast_util.mli index 68955387..69bd5a52 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -49,7 +49,7 @@ (**************************************************************************) open Ast -open Big_int +module Big_int = Nat_big_num val no_annot : unit annot val gen_loc : Parse_ast.l -> Parse_ast.l @@ -103,10 +103,12 @@ val range_typ : nexp -> nexp -> typ val bit_typ : typ val bool_typ : typ val app_typ : id -> typ_arg list -> typ +val ref_typ : typ -> typ +val register_typ : typ -> typ val unit_typ : typ val string_typ : typ val real_typ : typ -val vector_typ : nexp -> nexp -> order -> typ -> typ +val vector_typ : nexp -> order -> typ -> typ val list_typ : typ -> typ val exc_typ : typ val tuple_typ : typ list -> typ @@ -118,7 +120,7 @@ val mk_effect : base_effect_aux list -> effect val nexp_simp : nexp -> nexp (* Utilities for building n-expressions *) -val nconstant : big_int -> nexp +val nconstant : Big_int.num -> nexp val nint : int -> nexp val nminus : nexp -> nexp -> nexp val nsum : nexp -> nexp -> nexp @@ -138,7 +140,7 @@ val nc_and : n_constraint -> n_constraint -> n_constraint 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_set : kid -> Big_int.num 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 diff --git a/src/bitfield.ml b/src/bitfield.ml new file mode 100644 index 00000000..db3411b1 --- /dev/null +++ b/src/bitfield.ml @@ -0,0 +1,130 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* 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. *) +(**************************************************************************) + +module Big_int = Nat_big_num + +open Initial_check +open Ast +open Ast_util + +let bitvec size order = + Printf.sprintf "vector(%i, %s, bit)" size (string_of_order order) + +let rec combine = function + | [] -> Defs [] + | (Defs defs) :: ast -> + let (Defs defs') = combine ast in + Defs (defs @ defs') + +let newtype name size order = + let nt = Printf.sprintf "newtype %s = Mk_%s : %s" name name (bitvec size order) in + ast_of_def_string order nt + +(* These functions define the getter and setter for all the bits in the field. *) +let full_getter name size order = + let fg_val = Printf.sprintf "val _get_%s : %s -> %s" name name (bitvec size order) in + let fg_function = Printf.sprintf "function _get_%s Mk_%s(v) = v" name name in + combine [ast_of_def_string order fg_val; ast_of_def_string order fg_function] + +let full_setter name size order = + let fs_val = Printf.sprintf "val _set_%s : (register(%s), %s) -> unit effect {wreg}" name name (bitvec size order) in + let fs_function = String.concat "\n" + [ Printf.sprintf "function _set_%s (r_ref, v) = {" name; + " r = _reg_deref(r_ref);"; + Printf.sprintf " r = Mk_%s(v);" name; + " (*r_ref) = r"; + "}" + ] + in + combine [ast_of_def_string order fs_val; ast_of_def_string order fs_function] + +let full_overload name order = + ast_of_def_string order (Printf.sprintf "overload _mod_bits = {_get_%s, _set_%s}" name name) + +let full_accessor name size order = + combine [full_getter name size order; full_setter name size order; full_overload name order] + +(* For every index range, create a getter and setter *) +let index_range_getter' name field order start stop = + let size = if start > stop then start - (stop - 1) else stop - (start - 1) in + let irg_val = Printf.sprintf "val _get_%s : %s -> %s" field name (bitvec size order) in + let irg_function = Printf.sprintf "function _get_%s Mk_%s(v) = v[%i .. %i]" field name start stop in + combine [ast_of_def_string order irg_val; ast_of_def_string order irg_function] + +let index_range_setter' name field order start stop = + let size = if start > stop then start - (stop - 1) else stop - (start - 1) in + let irs_val = Printf.sprintf "val _set_%s : (register(%s), %s) -> unit effect {wreg}" field name (bitvec size order) in + let irs_function = String.concat "\n" + [ Printf.sprintf "function _set_%s (r_ref, v) = {" field; + Printf.sprintf " r = _get_%s(_reg_deref(r_ref));" name; + Printf.sprintf " r[%i .. %i] = v;" start stop; + Printf.sprintf " (*r_ref) = Mk_%s(r)" name; + "}" + ] + in + combine [ast_of_def_string order irs_val; ast_of_def_string order irs_function] + +let index_range_overload field order = + ast_of_def_string order (Printf.sprintf "overload _mod_%s = {_get_%s, _set_%s}" field field field) + +let index_range_accessor name field order (BF_aux (bf_aux, l)) = + let getter n m = index_range_getter' name field order (Big_int.to_int n) (Big_int.to_int m) in + let setter n m = index_range_setter' name field order (Big_int.to_int n) (Big_int.to_int m) in + let overload = index_range_overload field order in + match bf_aux with + | BF_single n -> combine [getter n n; setter n n; overload] + | BF_range (n, m) -> combine [getter n m; setter n m; overload] + | BF_concat _ -> failwith "Unimplemented" + +let field_accessor name order (id, ir) = index_range_accessor name (string_of_id id) order ir + +let macro id size order ranges = + let name = string_of_id id in + combine ([newtype name size order; full_accessor name size order] @ List.map (field_accessor name order) ranges) diff --git a/src/constraint.ml b/src/constraint.ml index 3d5a3689..ae72d956 100644 --- a/src/constraint.ml +++ b/src/constraint.ml @@ -48,7 +48,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Big_int +module Big_int = Nat_big_num open Util (* ===== Integer Constraints ===== *) @@ -58,13 +58,13 @@ type nexp_op = string type nexp = | NFun of (nexp_op * nexp list) | N2n of nexp - | NConstant of big_int + | NConstant of Big_int.num | NVar of int -let big_int_op : nexp_op -> (big_int -> big_int -> big_int) option = function - | "+" -> Some add_big_int - | "-" -> Some sub_big_int - | "*" -> Some mult_big_int +let big_int_op : nexp_op -> (Big_int.num -> Big_int.num -> Big_int.num) option = function + | "+" -> Some Big_int.add + | "-" -> Some Big_int.sub + | "*" -> Some Big_int.mul | _ -> None let rec arith constr = @@ -80,7 +80,7 @@ let rec arith constr = | Some op -> NConstant (op x y) | None -> c end - | N2n (NConstant x) -> NConstant (power_int_positive_big_int 2 x) + | N2n (NConstant x) -> NConstant (Big_int.pow_int_positive 2 (Big_int.to_int x)) | c -> c (* ===== Boolean Constraints ===== *) @@ -157,7 +157,7 @@ let cop_sexpr op x y = let rec sexpr_of_nexp = function | NFun (op, xs) -> sfun op (List.map sexpr_of_nexp xs) | N2n x -> sfun "^" [Atom "2"; sexpr_of_nexp x] - | NConstant c -> Atom (string_of_big_int c) (* CHECK: do we do negative constants right? *) + | NConstant c -> Atom (Big_int.to_string c) (* CHECK: do we do negative constants right? *) | NVar var -> Atom ("v" ^ string_of_int var) let rec sexpr_of_constraint = function @@ -303,6 +303,6 @@ let mult x y : nexp = NFun ("*", [x; y]) let app f xs : nexp = NFun (f, xs) -let constant (x : big_int) : nexp = NConstant x +let constant (x : Big_int.num) : nexp = NConstant x let variable (v : int) : nexp = NVar v diff --git a/src/constraint.mli b/src/constraint.mli index 89f2c625..2111a4e3 100644 --- a/src/constraint.mli +++ b/src/constraint.mli @@ -48,6 +48,8 @@ (* SUCH DAMAGE. *) (**************************************************************************) +module Big_int = Nat_big_num + type nexp type t @@ -80,5 +82,5 @@ val sub : nexp -> nexp -> nexp val mult : nexp -> nexp -> nexp val app : string -> nexp list -> nexp -val constant : Big_int.big_int -> nexp +val constant : Big_int.num -> nexp val variable : int -> nexp diff --git a/src/gen_lib/prompt.lem b/src/gen_lib/prompt.lem index 77a39096..744b6f7f 100644 --- a/src/gen_lib/prompt.lem +++ b/src/gen_lib/prompt.lem @@ -25,7 +25,6 @@ let rec bind m f = match m with | Internal descr o_s -> Internal descr (let (o,opt) = o_s in (bind o f ,opt)) end - let inline (>>=) = bind val (>>) : forall 'b 'e. M unit 'e -> M 'b 'e -> M 'b 'e let inline (>>) m n = m >>= fun (_ : unit) -> n diff --git a/src/initial_check.ml b/src/initial_check.ml index 689df577..5f3930b6 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -51,7 +51,7 @@ open Ast open Util open Ast_util -open Big_int +module Big_int = Nat_big_num let opt_undefined_gen = ref false let opt_magic_hash = ref false @@ -131,7 +131,7 @@ let string_of_parse_id_aux = function | Parse_ast.DeIid v -> v let string_contains str char = - try (String.index str char; true) with + try (ignore (String.index str char); true) with | Not_found -> false let to_ast_id (Parse_ast.Id_aux(id, l)) = @@ -185,12 +185,12 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) let make_r bot top = match bot,top with | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant b,_),Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,l) -> - Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (add_big_int (sub_big_int t b) unit_big_int),l) + Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.add (Big_int.sub t b) (Big_int.of_int 1)),l) | bot,(Parse_ast.ATyp_aux(_,l) as top) -> Parse_ast.ATyp_aux((Parse_ast.ATyp_sum ((Parse_ast.ATyp_aux (Parse_ast.ATyp_sum (top, - Parse_ast.ATyp_aux(Parse_ast.ATyp_constant unit_big_int,Parse_ast.Unknown)), + Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.of_int 1),Parse_ast.Unknown)), Parse_ast.Unknown)), (Parse_ast.ATyp_aux ((Parse_ast.ATyp_neg bot),Parse_ast.Unknown)))), l) in let base = to_ast_nexp k_env b in @@ -206,9 +206,9 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) | Parse_ast.ATyp_app(Parse_ast.Id_aux(Parse_ast.Id "vector_sugar_r",il), [b;r;ord;ti]) -> let make_sub_one t = match t with - | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,_) -> Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (sub_big_int t unit_big_int),l) + | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,_) -> Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.sub t (Big_int.of_int 1)),l) | t -> (Parse_ast.ATyp_aux - (Parse_ast.ATyp_sum (t, Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (minus_big_int unit_big_int),Parse_ast.Unknown)), + (Parse_ast.ATyp_sum (t, Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (Big_int.negate (Big_int.of_int 1)),Parse_ast.Unknown)), Parse_ast.Unknown)) in let (base,rise) = match def_ord with | Ord_aux(Ord_inc,dl) -> (to_ast_nexp k_env b), (to_ast_nexp k_env r) @@ -291,10 +291,7 @@ and to_ast_effects (k_env : kind Envmap.t) (e : Parse_ast.atyp) : Ast.effect = let v = to_ast_var v in let mk = Envmap.apply k_env (var_to_string v) in (match mk with - | Some(k) -> (match k.k with - | K_Efct -> Effect_var v - | K_infer -> k.k <- K_Efct; Effect_var v - | _ -> typ_error l "Required a variable with kind Effect, encountered " None (Some v) (Some k)) + | Some k -> typ_error l "Required a variable with kind Effect, encountered " None (Some v) (Some k) | None -> typ_error l "Encountered an unbound variable" None (Some v) None) | Parse_ast.ATyp_set(effects) -> Effect_set( List.map @@ -475,6 +472,7 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | None -> E_block(List.map (to_ast_exp k_env def_ord) exps)) | Parse_ast.E_nondet(exps) -> E_nondet(List.map (to_ast_exp k_env def_ord) exps) | Parse_ast.E_id(id) -> E_id(to_ast_id id) + | Parse_ast.E_ref(id) -> E_ref(to_ast_id id) | Parse_ast.E_lit(lit) -> E_lit(to_ast_lit lit) | Parse_ast.E_cast(typ,exp) -> E_cast(to_ast_typ k_env def_ord typ, to_ast_exp k_env def_ord exp) | Parse_ast.E_app(f,args) -> @@ -516,18 +514,21 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | Parse_ast.E_try (exp, pexps) -> E_try (to_ast_exp k_env def_ord exp, List.map (to_ast_case k_env def_ord) pexps) | Parse_ast.E_let(leb,exp) -> E_let(to_ast_letbind k_env def_ord leb, to_ast_exp k_env def_ord exp) | Parse_ast.E_assign(lexp,exp) -> E_assign(to_ast_lexp k_env def_ord lexp, to_ast_exp k_env def_ord exp) + | Parse_ast.E_var(lexp,exp1,exp2) -> E_var(to_ast_lexp k_env def_ord lexp, to_ast_exp k_env def_ord exp1, to_ast_exp k_env def_ord exp2) | Parse_ast.E_sizeof(nexp) -> E_sizeof(to_ast_nexp k_env nexp) | Parse_ast.E_constraint nc -> E_constraint (to_ast_nexp_constraint k_env nc) | Parse_ast.E_exit exp -> E_exit(to_ast_exp k_env def_ord exp) | Parse_ast.E_throw exp -> E_throw (to_ast_exp k_env def_ord exp) | Parse_ast.E_return exp -> E_return(to_ast_exp k_env def_ord exp) | Parse_ast.E_assert(cond,msg) -> E_assert(to_ast_exp k_env def_ord cond, to_ast_exp k_env def_ord msg) + | _ -> raise (Reporting_basic.err_unreachable l "Unparsable construct in to_ast_exp") ), (l,())) and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : unit lexp = LEXP_aux( (match exp with | Parse_ast.E_id(id) -> LEXP_id(to_ast_id id) + | Parse_ast.E_deref(exp) -> LEXP_deref(to_ast_exp k_env def_ord exp) | Parse_ast.E_cast(typ,Parse_ast.E_aux(Parse_ast.E_id(id),l')) -> LEXP_cast(to_ast_typ k_env def_ord typ, to_ast_id id) | Parse_ast.E_tuple(tups) -> @@ -535,7 +536,7 @@ and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l let is_ok_in_tup (LEXP_aux (le,(l,_))) = match le with | LEXP_id _ | LEXP_cast _ | LEXP_vector _ | LEXP_field _ | LEXP_vector_range _ | LEXP_tup _ -> () - | LEXP_memory _ -> + | LEXP_memory _ | LEXP_deref _ -> typ_error l "only identifiers, fields, and vectors may be set in a tuple" None None None in List.iter is_ok_in_tup ltups; LEXP_tup(ltups) @@ -690,13 +691,12 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (unit type_de let td_enum = TD_aux(TD_enum(id,to_ast_namescm name_scm_opt,enums,false),(l,())) in (* Add check that all enums have unique names *) let k_env = List.fold_right (fun k k_env -> Envmap.insert k_env (k,{k=K_Nat})) keys (Envmap.insert k_env (key,{k=K_Typ})) in td_enum, (names,k_env,def_ord) - | Parse_ast.TD_register(id,t1,t2,ranges) -> + | Parse_ast.TD_bitfield(id,typ,ranges) -> let id = to_ast_id id in let key = id_to_string id in - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - let ranges = List.map (fun (range,id) -> (to_ast_range range),to_ast_id id) ranges in - TD_aux(TD_register(id,n1,n2,ranges),(l,())), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) + let typ = to_ast_typ k_env def_ord typ in + let ranges = List.map (fun (id, range) -> (to_ast_id id, to_ast_range range)) ranges in + TD_aux(TD_bitfield(id,typ,ranges),(l,())), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (unit kind_def) envs_out = match td with @@ -750,7 +750,7 @@ let to_ast_fundef (names,k_env,def_ord) (Parse_ast.FD_aux(fd,l):Parse_ast.funde (*let _ = Printf.eprintf "to_ast_fundef\n" in*) let tannot_opt, k_env,_ = to_ast_tannot_opt k_env def_ord tannot_opt in FD_aux(FD_function(to_ast_rec rec_opt, tannot_opt, to_ast_effects_opt k_env effects_opt, List.map (to_ast_funcl (names, k_env, def_ord)) funcls), (l,())), (names,k_env,def_ord) - + type def_progress = No_def | Def_place_holder of id * Parse_ast.l @@ -826,6 +826,9 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | Parse_ast.DEF_reg_dec(dec) -> let d = to_ast_dec envs dec in ((Finished(DEF_reg_dec(d))),envs),partial_defs + | Parse_ast.DEF_internal_mutrec _ -> + (* Should never occur because of remove_mutrec *) + typ_error Parse_ast.Unknown "Internal mutual block found when processing scattered defs" None None None | Parse_ast.DEF_scattered(Parse_ast.SD_aux(sd,l)) -> (match sd with | Parse_ast.SD_scattered_function(rec_opt, tannot_opt, effects_opt, id) -> @@ -890,8 +893,8 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out ((Finished def), envs),partial_defs | _, true -> typ_error l "Scattered definition ended multiple times" (Some id) None None - | _ -> raise (Reporting_basic.err_unreachable l "Something in partial_defs other than fundef and type")))) - + | _ -> raise (Reporting_basic.err_unreachable l "Something in partial_defs other than fundef and type")))) + let rec to_ast_defs_helper envs partial_defs = function | [] -> ([],envs,partial_defs) | d::ds -> let ((d', envs), partial_defs) = to_ast_def envs partial_defs d in @@ -943,20 +946,26 @@ let initial_kind_env = ("list", {k = K_Lam( [{k = K_Typ}], {k = K_Typ})}); ("reg", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); ("register", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); + ("ref", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); ("range", {k = K_Lam( [ {k = K_Nat}; {k= K_Nat}], {k = K_Typ}) }); - ("vector", {k = K_Lam( [ {k = K_Nat}; {k = K_Nat}; {k= K_Ord} ; {k=K_Typ}], {k=K_Typ}) } ); + ("vector", {k = K_Lam( [{k = K_Nat}; {k= K_Ord} ; {k=K_Typ}], {k=K_Typ}) } ); ("atom", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})}); ("option", { k = K_Lam( [{k=K_Typ}], {k=K_Typ}) }); ("implicit", {k = K_Lam( [{k = K_Nat}], {k=K_Typ})} ); ("itself", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})}); ] +let exp_of_string order str = + let exp = Parser.exp_eof Lexer.token (Lexing.from_string str) in + to_ast_exp initial_kind_env order exp + let typschm_of_string order str = - let typschm = Parser2.typschm_eof Lexer2.token (Lexing.from_string str) in + let typschm = Parser.typschm_eof Lexer.token (Lexing.from_string str) in let (typschm, _, _) = to_ast_typschm initial_kind_env order typschm in typschm -let val_spec_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> Some (string_of_id id)), false)) +let extern_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> Some (string_of_id id)), false)) +let val_spec_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> None), false)) let val_spec_ids (Defs defs) = let val_spec_id (VS_aux (vs_aux, _)) = @@ -991,28 +1000,39 @@ let undefined_typschm id typq = let ret_typ = app_typ id (List.concat (List.map quant_item_arg qis)) in mk_typschm typq (mk_typ (Typ_fn (arg_typ, ret_typ, mk_effect [BE_undef]))) +let have_undefined_builtins = ref false + let generate_undefineds vs_ids (Defs defs) = let gen_vs id str = - if (IdSet.mem id vs_ids) then [] else [val_spec_of_string dec_ord id str] + if (IdSet.mem id vs_ids) then [] else [extern_of_string dec_ord id str] in - let undefined_builtins = List.concat - [gen_vs (mk_id "internal_pick") "forall ('a:Type). list('a) -> 'a effect {undef}"; - gen_vs (mk_id "undefined_bool") "unit -> bool effect {undef}"; - gen_vs (mk_id "undefined_bit") "unit -> bit effect {undef}"; - gen_vs (mk_id "undefined_int") "unit -> int effect {undef}"; - gen_vs (mk_id "undefined_nat") "unit -> nat effect {undef}"; - gen_vs (mk_id "undefined_real") "unit -> real effect {undef}"; - gen_vs (mk_id "undefined_string") "unit -> string effect {undef}"; - gen_vs (mk_id "undefined_list") "forall ('a:Type). 'a -> list('a) effect {undef}"; - gen_vs (mk_id "undefined_range") "forall 'n 'm. (atom('n), atom('m)) -> range('n,'m) effect {undef}"; - (* FIXME: How to handle inc/dec order correctly? *) - gen_vs (mk_id "undefined_vector") "forall 'n 'm ('a:Type). (atom('n), atom('m), 'a) -> vector('n, 'm, dec,'a) effect {undef}"; - (* Only used with lem_mwords *) - gen_vs (mk_id "undefined_bitvector") "forall 'n 'm. (atom('n), atom('m)) -> vector('n, 'm, dec,bit) effect {undef}"; - gen_vs (mk_id "undefined_unit") "unit -> unit effect {undef}"] + let undefined_builtins = + if !have_undefined_builtins then + [] + else + begin + have_undefined_builtins := true; + List.concat + [gen_vs (mk_id "internal_pick") "forall ('a:Type). list('a) -> 'a effect {undef}"; + gen_vs (mk_id "undefined_bool") "unit -> bool effect {undef}"; + gen_vs (mk_id "undefined_bit") "unit -> bit effect {undef}"; + gen_vs (mk_id "undefined_int") "unit -> int effect {undef}"; + gen_vs (mk_id "undefined_nat") "unit -> nat effect {undef}"; + gen_vs (mk_id "undefined_real") "unit -> real effect {undef}"; + gen_vs (mk_id "undefined_string") "unit -> string effect {undef}"; + gen_vs (mk_id "undefined_list") "forall ('a:Type). 'a -> list('a) effect {undef}"; + gen_vs (mk_id "undefined_range") "forall 'n 'm. (atom('n), atom('m)) -> range('n,'m) effect {undef}"; + (* FIXME: How to handle inc/dec order correctly? *) + gen_vs (mk_id "undefined_vector") "forall 'n ('a:Type) ('ord : Order). (atom('n), 'a) -> vector('n, 'ord,'a) effect {undef}"; + (* Only used with lem_mwords *) + gen_vs (mk_id "undefined_bitvector") "forall 'n. atom('n) -> vector('n, dec, bit) effect {undef}"; + gen_vs (mk_id "undefined_unit") "unit -> unit effect {undef}"] + end in let undefined_tu = function | Tu_aux (Tu_id id, _) -> mk_exp (E_id id) + | Tu_aux (Tu_ty_id (Typ_aux (Typ_tup typs, _), id), _) -> + mk_exp (E_app (id, List.map (fun _ -> mk_lit_exp L_undef) typs)) | Tu_aux (Tu_ty_id (typ, id), _) -> mk_exp (E_app (id, [mk_lit_exp L_undef])) in let undefined_td = function @@ -1077,3 +1097,7 @@ let process_ast order defs = let ast = generate_undefineds vs_ids ast in generate_initialize_registers vs_ids ast end + +let ast_of_def_string order str = + let def = Parser.def_eof Lexer.token (Lexing.from_string str) in + process_ast order (Parse_ast.Defs [def]) diff --git a/src/initial_check.mli b/src/initial_check.mli index 01cf3bec..9d1e0d30 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -54,8 +54,11 @@ open Ast_util val opt_undefined_gen : bool ref val opt_magic_hash : bool ref +val ast_of_def_string : order -> string -> unit defs val process_ast : order -> Parse_ast.defs -> unit defs val val_spec_ids : 'a defs -> IdSet.t val val_spec_of_string : order -> id -> string -> unit def + +val exp_of_string : order -> string -> unit exp diff --git a/src/interpreter.ml b/src/interpreter.ml new file mode 100644 index 00000000..a0482f27 --- /dev/null +++ b/src/interpreter.ml @@ -0,0 +1,671 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* 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 Ast_util +open Value + +type gstate = + { registers : value Bindings.t; + letbinds : (Type_check.tannot letbind) list; + } + +type lstate = + { locals : value Bindings.t } + +type state = lstate * gstate + +let rec ast_letbinds (Defs defs) = + match defs with + | [] -> [] + | DEF_val lb :: defs -> lb :: ast_letbinds (Defs defs) + | _ :: defs -> ast_letbinds (Defs defs) + +let initial_gstate ast = + { registers = Bindings.empty; + letbinds = ast_letbinds ast; + } + +let initial_lstate = + { locals = Bindings.empty } + +let initial_state ast = initial_lstate, initial_gstate ast + +let value_of_lit (L_aux (l_aux, _)) = + match l_aux with + | L_unit -> V_unit + | L_zero -> V_bit Sail_lib.B0 + | L_one -> V_bit Sail_lib.B1 + | L_true -> V_bool true + | L_false -> V_bool false + | L_string str -> V_string str + | L_num n -> V_int n + | L_hex str -> + Util.string_to_list str + |> List.map (fun c -> List.map (fun b -> V_bit b) (Sail_lib.hex_char c)) + |> List.concat + |> (fun v -> V_vector v) + | _ -> failwith "Unimplemented value_of_lit" (* TODO *) + +let is_value = function + | (E_aux (E_internal_value _, _)) -> true + | _ -> false + +let is_true = function + | (E_aux (E_internal_value (V_bool b), _)) -> b == true + | _ -> false + +let is_false = function + | (E_aux (E_internal_value (V_bool b), _)) -> b == false + | _ -> false + +let exp_of_value v = (E_aux (E_internal_value v, (Parse_ast.Unknown, None))) +let value_of_exp = function + | (E_aux (E_internal_value v, _)) -> v + | _ -> failwith "value_of_exp coerction failed" + +(**************************************************************************) +(* 1. Interpreter Monad *) +(**************************************************************************) + +type 'a response = + | Early_return of value + | Exception of value + | Assertion_failed of string + | Call of id * value list * (value -> 'a) + | Gets of (state -> 'a) + | Puts of state * (unit -> 'a) + +and 'a monad = + | Pure of 'a + | Yield of ('a monad response) + +let map_response f = function + | Early_return v -> Early_return v + | Exception v -> Exception v + | Assertion_failed str -> Assertion_failed str + | Gets g -> Gets (fun s -> f (g s)) + | Puts (s, cont) -> Puts (s, fun () -> f (cont ())) + | Call (id, vals, cont) -> Call (id, vals, fun v -> f (cont v)) + +let rec liftM f = function + | Pure x -> Pure (f x) + | Yield g -> Yield (map_response (liftM f) g) + +let return x = Pure x + +let rec bind m f = + match m with + | Pure x -> f x + | Yield m -> Yield (map_response (fun m -> bind m f) m) + +let ( >>= ) m f = bind m f + +let ( >> ) m1 m2 = bind m1 (function () -> m2) + +type ('a, 'b) either = + | Left of 'a + | Right of 'b + +(* Support for interpreting exceptions *) + +let catch m = + match m with + | Pure x -> Pure (Right x) + | Yield (Exception v) -> Pure (Left v) + | Yield resp -> Yield (map_response (fun m -> liftM (fun r -> Right r) m) resp) + +let call (f : id) (args : value list) : value monad = + Yield (Call (f, args, fun v -> Pure v)) + +let throw v = Yield (Exception v) + +let gets : state monad = + Yield (Gets (fun s -> Pure s)) + +let puts (s : state) : unit monad = + Yield (Puts (s, fun () -> Pure ())) + +let early_return v = Yield (Early_return v) + +let assertion_failed msg = Yield (Assertion_failed msg) + +let liftM2 f m1 m2 = m1 >>= fun x -> m2 >>= fun y -> return (f x y) + +let rec pat_ids (P_aux (pat_aux, _)) = + match pat_aux with + | P_lit _ | P_wild -> IdSet.empty + | P_id id -> IdSet.singleton id + | P_as (pat, id) -> IdSet.add id (pat_ids pat) + | P_var (pat, _) | P_typ (_, pat) -> pat_ids pat + | P_app (_, pats) | P_tup pats | P_vector pats | P_vector_concat pats | P_list pats -> + List.fold_right IdSet.union (List.map pat_ids pats) IdSet.empty + | P_cons (pat1, pat2) -> + IdSet.union (pat_ids pat1) (pat_ids pat2) + | P_record (fpats, _) -> + List.fold_right IdSet.union (List.map fpat_ids fpats) IdSet.empty +and fpat_ids (FP_aux (FP_Fpat (_, pat), _)) = pat_ids pat + +let letbind_pat_ids (LB_aux (LB_val (pat, _), _)) = pat_ids pat + +let rec subst id value (E_aux (e_aux, annot) as exp) = + let wrap e_aux = E_aux (e_aux, annot) in + let e_aux = match e_aux with + | E_block exps -> E_block (List.map (subst id value) exps) + | E_nondet exps -> E_nondet (List.map (subst id value) exps) + | E_id id' -> if Id.compare id id' = 0 then unaux_exp (exp_of_value value) else E_id id' + | E_lit lit -> E_lit lit + | E_cast (typ, exp) -> E_cast (typ, subst id value exp) + + | E_app (fn, exps) -> E_app (fn, List.map (subst id value) exps) + | E_app_infix (exp1, op, exp2) -> E_app_infix (subst id value exp1, op, subst id value exp2) + + | E_tuple exps -> E_tuple (List.map (subst id value) exps) + + | E_if (cond, then_exp, else_exp) -> + E_if (subst id value cond, subst id value then_exp, subst id value else_exp) + + | E_loop (loop, cond, body) -> + E_loop (loop, subst id value cond, subst id value body) + | E_for (id', exp1, exp2, exp3, order, body) when Id.compare id id' = 0 -> + E_for (id', exp1, exp2, exp3, order, body) + | E_for (id', exp1, exp2, exp3, order, body) -> + E_for (id', subst id value exp1, subst id value exp2, subst id value exp3, order, subst id value body) + + | E_vector exps -> E_vector (List.map (subst id value) exps) + | E_vector_access (exp1, exp2) -> E_vector_access (subst id value exp1, subst id value exp2) + | E_vector_subrange (exp1, exp2, exp3) -> E_vector_subrange (subst id value exp1, subst id value exp2, subst id value exp3) + | E_vector_update (exp1, exp2, exp3) -> E_vector_update (subst id value exp1, subst id value exp2, subst id value exp3) + | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> + E_vector_update_subrange (subst id value exp1, subst id value exp2, subst id value exp3, subst id value exp4) + | E_vector_append (exp1, exp2) -> E_vector_append (subst id value exp1, subst id value exp2) + + | E_list exps -> E_list (List.map (subst id value) exps) + | E_cons (exp1, exp2) -> E_cons (subst id value exp1, subst id value exp2) + + | E_record fexps -> E_record (subst_fexps id value fexps) + | E_record_update (exp, fexps) -> E_record_update (subst id value exp, subst_fexps id value fexps) + | E_field (exp, id') -> E_field (subst id value exp, id') + + | E_case (exp, pexps) -> + E_case (subst id value exp, List.map (subst_pexp id value) pexps) + + | E_let (LB_aux (LB_val (pat, bind), lb_annot), body) -> + E_let (LB_aux (LB_val (pat, subst id value bind), lb_annot), + if IdSet.mem id (pat_ids pat) then body else subst id value body) + + | E_assign (lexp, exp) -> E_assign (subst_lexp id value lexp, subst id value exp) (* Shadowing... *) + + (* Should be re-written *) + | E_sizeof nexp -> E_sizeof nexp + | E_constraint nc -> E_constraint nc + + | E_return exp -> E_return (subst id value exp) + | E_exit exp -> E_exit (subst id value exp) + (* Not sure about this, but id should always be immutable while id' must be mutable so should be ok. *) + | E_ref id' -> E_ref id' + | E_throw exp -> E_throw (subst id value exp) + + | E_try (exp, pexps) -> + E_try (subst id value exp, List.map (subst_pexp id value) pexps) + + | E_assert (exp1, exp2) -> E_assert (subst id value exp1, subst id value exp2) + + | E_internal_value v -> E_internal_value v + | _ -> failwith ("subst " ^ string_of_exp exp) + in + wrap e_aux + +and subst_pexp id value (Pat_aux (pexp_aux, annot)) = + let pexp_aux = match pexp_aux with + | Pat_exp (pat, exp) when IdSet.mem id (pat_ids pat) -> Pat_exp (pat, exp) + | Pat_exp (pat, exp) -> Pat_exp (pat, subst id value exp) + | Pat_when (pat, guard, exp) when IdSet.mem id (pat_ids pat) -> Pat_when (pat, guard, exp) + | Pat_when (pat, guard, exp) -> Pat_when (pat, subst id value guard, subst id value exp) + in + Pat_aux (pexp_aux, annot) + + +and subst_fexps id value (FES_aux (FES_Fexps (fexps, flag), annot)) = + FES_aux (FES_Fexps (List.map (subst_fexp id value) fexps, flag), annot) + +and subst_fexp id value (FE_aux (FE_Fexp (id', exp), annot)) = + FE_aux (FE_Fexp (id', subst id value exp), annot) + +and subst_lexp id value (LEXP_aux (lexp_aux, annot) as lexp) = + let wrap lexp_aux = LEXP_aux (lexp_aux, annot) in + let lexp_aux = match lexp_aux with + | LEXP_deref exp -> LEXP_deref (subst id value exp) + | LEXP_id id' -> LEXP_id id' + | LEXP_memory (f, exps) -> LEXP_memory (f, List.map (subst id value) exps) + | LEXP_cast (typ, id') -> LEXP_cast (typ, id') + | LEXP_tup lexps -> LEXP_tup (List.map (subst_lexp id value) lexps) + | LEXP_vector (lexp, exp) -> LEXP_vector (subst_lexp id value lexp, subst id value exp) + | LEXP_vector_range (lexp, exp1, exp2) -> LEXP_vector_range (subst_lexp id value lexp, subst id value exp1, subst id value exp2) + | LEXP_field (lexp, id') -> LEXP_field (subst_lexp id value lexp, id') + in + wrap lexp_aux + +(**************************************************************************) +(* 2. Expression Evaluation *) +(**************************************************************************) + +let unit_exp = E_lit (L_aux (L_unit, Parse_ast.Unknown)) + +let is_value_fexp (FE_aux (FE_Fexp (id, exp), _)) = is_value exp +let value_of_fexp (FE_aux (FE_Fexp (id, exp), _)) = (string_of_id id, value_of_exp exp) + +let rec build_letchain id lbs (E_aux (_, annot) as exp) = + (* print_endline ("LETCHAIN " ^ string_of_exp exp); *) + match lbs with + | [] -> exp + | lb :: lbs when IdSet.mem id (letbind_pat_ids lb)-> + let exp = E_aux (E_let (lb, exp), annot) in + build_letchain id lbs exp + | _ :: lbs -> build_letchain id lbs exp + +let rec step (E_aux (e_aux, annot) as orig_exp) = + let wrap e_aux' = return (E_aux (e_aux', annot)) in + match e_aux with + | E_block [] -> wrap (E_lit (L_aux (L_unit, Parse_ast.Unknown))) + | E_block [exp] when is_value exp -> return exp + | E_block (exp :: exps) when is_value exp -> wrap (E_block exps) + | E_block (exp :: exps) -> + step exp >>= fun exp' -> wrap (E_block (exp' :: exps)) + + | E_lit lit -> return (exp_of_value (value_of_lit lit)) + + | E_if (exp, then_exp, else_exp) when is_true exp -> return then_exp + | E_if (exp, then_exp, else_exp) when is_false exp -> return else_exp + | E_if (exp, then_exp, else_exp) -> + step exp >>= fun exp' -> wrap (E_if (exp', then_exp, else_exp)) + + | E_loop (While, exp, body) when not (is_value exp) -> + step exp >>= fun exp' -> wrap (E_loop (While, exp', body)) + | E_loop (While, exp, body) when is_true exp -> wrap (E_block [body; orig_exp]) + | E_loop (While, exp, body) when is_false exp -> wrap unit_exp + | E_loop _ -> assert false (* Impossible *) + + | E_assert (exp, msg) when is_true exp -> wrap unit_exp + | E_assert (exp, msg) when is_false exp -> assertion_failed "FIXME" + | E_assert (exp, msg) -> + step exp >>= fun exp' -> wrap (E_assert (exp', msg)) + + | E_vector exps -> + let evaluated, unevaluated = Util.take_drop is_value exps in + begin + match unevaluated with + | exp :: exps -> + step exp >>= fun exp' -> wrap (E_vector (evaluated @ exp' :: exps)) + | [] -> return (exp_of_value (V_vector (List.map value_of_exp evaluated))) + end + + | E_list exps -> + let evaluated, unevaluated = Util.take_drop is_value exps in + begin + match unevaluated with + | exp :: exps -> + step exp >>= fun exp' -> wrap (E_list (evaluated @ exp' :: exps)) + | [] -> return (exp_of_value (V_list (List.map value_of_exp evaluated))) + end + + (* Special rules for short circuting boolean operators *) + | E_app (id, [x; y]) when (string_of_id id = "and_bool" || string_of_id id = "or_bool") && not (is_value x) -> + step x >>= fun x' -> wrap (E_app (id, [x'; y])) + | E_app (id, [x; y]) when string_of_id id = "and_bool" && is_false x -> + return (exp_of_value (V_bool false)) + | E_app (id, [x; y]) when string_of_id id = "or_bool" && is_true x -> + return (exp_of_value (V_bool true)) + + | E_let (LB_aux (LB_val (pat, bind), lb_annot), body) when not (is_value bind) -> + step bind >>= fun bind' -> wrap (E_let (LB_aux (LB_val (pat, bind'), lb_annot), body)) + | E_let (LB_aux (LB_val (pat, bind), lb_annot), body) -> + let matched, bindings = pattern_match (Type_check.env_of orig_exp) pat (value_of_exp bind) in + if matched then + return (List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings)) + else + failwith "Match failure" + + | E_vector_update (vec, n, x) -> + wrap (E_app (mk_id "vector_update", [vec; n; x])) + + (* otherwise left-to-right evaluation order for function applications *) + | E_app (id, exps) -> + let evaluated, unevaluated = Util.take_drop is_value exps in + begin + let open Type_check in + match unevaluated with + | exp :: exps -> + step exp >>= fun exp' -> wrap (E_app (id, evaluated @ exp' :: exps)) + | [] when Env.is_union_constructor id (env_of_annot annot) -> + return (exp_of_value (V_ctor (string_of_id id, List.map value_of_exp evaluated))) + | [] when Env.is_extern id (env_of_annot annot) "interpreter" -> + begin + let extern = Env.get_extern id (env_of_annot annot) "interpreter" in + if extern = "reg_deref" then + let regname = List.hd evaluated |> value_of_exp |> coerce_ref in + gets >>= fun (_, gstate) -> + return (exp_of_value (Bindings.find (mk_id regname) gstate.registers)) + else + let primop = try StringMap.find extern primops with Not_found -> failwith ("No primop " ^ extern) in + return (exp_of_value (primop (List.map value_of_exp evaluated))) + end + | [] -> liftM exp_of_value (call id (List.map value_of_exp evaluated)) + end + | E_app_infix (x, id, y) when is_value x && is_value y -> + liftM exp_of_value (call id [value_of_exp x; value_of_exp y]) + | E_app_infix (x, id, y) when is_value x -> + step y >>= fun y' -> wrap (E_app_infix (x, id, y')) + | E_app_infix (x, id, y) -> + step x >>= fun x' -> wrap (E_app_infix (x', id, y)) + + | E_return exp when is_value exp -> early_return (value_of_exp exp) + | E_return exp -> step exp >>= fun exp' -> wrap (E_return exp') + + | E_tuple exps -> + let evaluated, unevaluated = Util.take_drop is_value exps in + begin + match unevaluated with + | exp :: exps -> + step exp >>= fun exp' -> wrap (E_tuple (evaluated @ exp' :: exps)) + | [] -> return (exp_of_value (tuple_value (List.map value_of_exp exps))) + end + + | E_case (exp, pexps) when not (is_value exp) -> + step exp >>= fun exp' -> wrap (E_case (exp', pexps)) + | E_case (_, []) -> failwith "Pattern matching failed" + | E_case (exp, Pat_aux (Pat_exp (pat, body), _) :: pexps) -> + let matched, bindings = pattern_match (Type_check.env_of body) pat (value_of_exp exp) in + if matched then + return (List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings)) + else + wrap (E_case (exp, pexps)) + | E_case (exp, Pat_aux (Pat_when (pat, guard, body), pat_annot) :: pexps) when not (is_value guard) -> + let matched, bindings = pattern_match (Type_check.env_of body) pat (value_of_exp exp) in + if matched then + let guard = List.fold_left (fun guard (id, v) -> subst id v guard) guard (Bindings.bindings bindings) in + let body = List.fold_left (fun body (id, v) -> subst id v body) body (Bindings.bindings bindings) in + step guard >>= fun guard' -> + wrap (E_case (exp, Pat_aux (Pat_when (pat, guard', body), pat_annot) :: pexps)) + else + wrap (E_case (exp, pexps)) + | E_case (exp, Pat_aux (Pat_when (pat, guard, body), pat_annot) :: pexps) when is_true guard -> return body + | E_case (exp, Pat_aux (Pat_when (pat, guard, body), pat_annot) :: pexps) when is_false guard -> wrap (E_case (exp, pexps)) + + | E_cast (typ, exp) -> return exp + + | E_throw exp when is_value exp -> throw (value_of_exp exp) + | E_throw exp -> step exp >>= fun exp' -> wrap (E_throw exp') + | E_exit exp when is_value exp -> throw (V_ctor ("Exit", [value_of_exp exp])) + | E_exit exp -> step exp >>= fun exp' -> wrap (E_exit exp') + + | E_ref id -> return (exp_of_value (V_ref (string_of_id id))) + | E_id id -> + begin + let open Type_check in + gets >>= fun (lstate, gstate) -> + match Env.lookup_id id (env_of_annot annot) with + | Register _ -> + let exp = + try exp_of_value (Bindings.find id gstate.registers) with + | Not_found -> + let exp = mk_exp (E_app (mk_id ("undefined_" ^ string_of_typ (typ_of orig_exp)), [mk_exp (E_lit (mk_lit (L_unit)))])) in + Type_check.check_exp (env_of_annot annot) exp (typ_of orig_exp) + in + return exp + | Local (Mutable, _) -> return (exp_of_value (Bindings.find id lstate.locals)) + | Local (Immutable, _) -> + let chain = build_letchain id gstate.letbinds orig_exp in + return chain + | Enum _ -> + return (exp_of_value (V_ctor (string_of_id id, []))) + | _ -> failwith "id" + end + + | E_record (FES_aux (FES_Fexps (fexps, flag), fes_annot)) -> + let evaluated, unevaluated = Util.take_drop is_value_fexp fexps in + begin + match unevaluated with + | FE_aux (FE_Fexp (id, exp), fe_annot) :: fexps -> + step exp >>= fun exp' -> + wrap (E_record (FES_aux (FES_Fexps (evaluated @ FE_aux (FE_Fexp (id, exp'), fe_annot) :: fexps, flag), fes_annot))) + | [] -> + List.map value_of_fexp fexps + |> List.fold_left (fun record (field, v) -> StringMap.add field v record) StringMap.empty + |> (fun record -> V_record record) + |> exp_of_value + |> return + end + + | E_record_update (exp, fexps) when not (is_value exp) -> + step exp >>= fun exp' -> wrap (E_record_update (exp', fexps)) + | E_record_update (record, FES_aux (FES_Fexps (fexps, flag), fes_annot)) -> + let evaluated, unevaluated = Util.take_drop is_value_fexp fexps in + begin + match unevaluated with + | FE_aux (FE_Fexp (id, exp), fe_annot) :: fexps -> + step exp >>= fun exp' -> + wrap (E_record_update (record, FES_aux (FES_Fexps (evaluated @ FE_aux (FE_Fexp (id, exp'), fe_annot) :: fexps, flag), fes_annot))) + | [] -> + List.map value_of_fexp fexps + |> List.fold_left (fun record (field, v) -> StringMap.add field v record) (coerce_record (value_of_exp record)) + |> (fun record -> V_record record) + |> exp_of_value + |> return + end + + | E_field (exp, id) when not (is_value exp) -> + step exp >>= fun exp' -> wrap (E_field (exp', id)) + | E_field (exp, id) -> + let record = coerce_record (value_of_exp exp) in + return (exp_of_value (StringMap.find (string_of_id id) record)) + + | E_assign (lexp, exp) when not (is_value exp) -> step exp >>= fun exp' -> wrap (E_assign (lexp, exp')) + | E_assign (LEXP_aux (LEXP_memory (id, args), _), exp) -> wrap (E_app (id, args @ [exp])) + | E_assign (LEXP_aux (LEXP_field (lexp, id), ul), exp) -> + let open Type_check in + let lexp_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp lexp)) in + let exp' = E_aux (E_record_update (lexp_exp, FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), ul)], false), ul)), ul) in + wrap (E_assign (lexp, exp')) + | E_assign (LEXP_aux (LEXP_vector (vec, n), lexp_annot), exp) -> + let open Type_check in + let vec_exp = infer_exp (env_of_annot annot) (exp_of_lexp (strip_lexp vec)) in + let exp' = E_aux (E_vector_update (vec_exp, n, exp), lexp_annot) in + wrap (E_assign (vec, exp')) + | E_assign (LEXP_aux (LEXP_id id, _), exp) | E_assign (LEXP_aux (LEXP_cast (_, id), _), exp) -> + begin + let open Type_check in + gets >>= fun (lstate, gstate) -> + match Env.lookup_id id (env_of_annot annot) with + | Register _ -> + puts (lstate, { gstate with registers = Bindings.add id (value_of_exp exp) gstate.registers }) >> wrap unit_exp + | Local (Mutable, _) | Unbound -> + puts ({ locals = Bindings.add id (value_of_exp exp) lstate.locals }, gstate) >> wrap unit_exp + | _ -> failwith "Assign" + end + | E_assign (LEXP_aux (LEXP_deref reference, annot), exp) when not (is_value reference) -> + step reference >>= fun reference' -> wrap (E_assign (LEXP_aux (LEXP_deref reference', annot), exp)) + | E_assign (LEXP_aux (LEXP_deref reference, annot), exp) -> + let id = Id_aux (Id (coerce_ref (value_of_exp reference)), Parse_ast.Unknown) in + gets >>= fun (lstate, gstate) -> + puts (lstate, { gstate with registers = Bindings.add id (value_of_exp exp) gstate.registers }) >> wrap unit_exp + | E_assign (LEXP_aux (LEXP_tup lexps, annot), exp) -> failwith "Tuple assignment" + (* + let values = coerce_tuple (value_of_exp exp) in + wrap (E_block (List.map2 (fun lexp v -> E_aux (E_assign (lexp, exp_of_value v), (Parse_ast.Unknown, None))) lexps values)) + *) + | E_assign _ -> failwith (string_of_exp orig_exp); + + | E_try (exp, pexps) when is_value exp -> return exp + | E_try (exp, pexps) -> + begin + catch (step exp) >>= fun exp' -> + match exp' with + | Left exn -> wrap (E_case (exp_of_value exn, pexps)) + | Right exp' -> wrap (E_try (exp', pexps)) + end + + | E_sizeof _ | E_constraint _ -> assert false (* Must be re-written before interpreting *) + + | _ -> failwith ("Unimplemented " ^ string_of_exp orig_exp) + +and combine _ v1 v2 = + match (v1, v2) with + | None, None -> None + | Some v1, None -> Some v1 + | None, Some v2 -> Some v2 + | Some v1, Some v2 -> failwith "Pattern binds same identifier twice!" + +and exp_of_lexp (LEXP_aux (lexp_aux, _) as lexp) = + match lexp_aux with + | LEXP_id id -> mk_exp (E_id id) + | LEXP_memory (f, args) -> mk_exp (E_app (f, args)) + | LEXP_cast (typ, id) -> mk_exp (E_cast (typ, mk_exp (E_id id))) + | LEXP_deref exp -> mk_exp (E_app (mk_id "_reg_deref", [exp])) + | LEXP_tup lexps -> mk_exp (E_tuple (List.map exp_of_lexp lexps)) + | LEXP_vector (lexp, exp) -> mk_exp (E_vector_access (exp_of_lexp lexp, exp)) + | LEXP_vector_range (lexp, exp1, exp2) -> mk_exp (E_vector_subrange (exp_of_lexp lexp, exp1, exp2)) + | LEXP_field (lexp, id) -> mk_exp (E_field (exp_of_lexp lexp, id)) + +and pattern_match env (P_aux (p_aux, _) as pat) value = + (* print_endline ("Matching: " ^ string_of_pat pat ^ " with " ^ string_of_value value |> Util.yellow |> Util.clear); *) + match p_aux with + | P_lit lit -> eq_value (value_of_lit lit) value, Bindings.empty + | P_wild -> true, Bindings.empty + | P_as (pat, id) -> + let matched, bindings = pattern_match env pat value in + matched, Bindings.add id value bindings + | P_typ (_, pat) -> pattern_match env pat value + | P_id id -> + let open Type_check in + begin + match Env.lookup_id id env with + | Enum _ | Union _ -> + if is_ctor value && string_of_id id = fst (coerce_ctor value) + then true, Bindings.empty + else false, Bindings.empty + | _ -> true, Bindings.singleton id value + end + | P_var (pat, _) -> pattern_match env pat value + | P_app (id, pats) -> + let (ctor, vals) = coerce_ctor value in + if Id.compare id (mk_id ctor) = 0 then + let matches = List.map2 (pattern_match env) pats vals in + List.for_all fst matches, List.fold_left (Bindings.merge combine) Bindings.empty (List.map snd matches) + else + false, Bindings.empty + | P_record _ -> assert false (* TODO *) + | P_vector pats -> + let matches = List.map2 (pattern_match env) pats (coerce_gv value) in + List.for_all fst matches, List.fold_left (Bindings.merge combine) Bindings.empty (List.map snd matches) + | P_vector_concat _ -> assert false (* TODO *) + | P_tup pats | P_list pats -> + let matches = List.map2 (pattern_match env) pats (coerce_listlike value) in + List.for_all fst matches, List.fold_left (Bindings.merge combine) Bindings.empty (List.map snd matches) + | P_cons _ -> assert false (* TODO *) + +let exp_of_fundef (FD_aux (FD_function (_, _, _, funcls), annot)) value = + let pexp_of_funcl (FCL_aux (FCL_Funcl (_, pexp), _)) = pexp in + E_aux (E_case (exp_of_value value, List.map pexp_of_funcl funcls), annot) + +let rec get_fundef id (Defs defs) = + match defs with + | [] -> failwith (string_of_id id ^ " definition not found") + | (DEF_fundef fdef) :: _ when Id.compare id (id_of_fundef fdef) = 0 -> fdef + | _ :: defs -> get_fundef id (Defs defs) + +let stack_cont (_, _, cont) = cont +let stack_string (str, _, _) = str +let stack_state (_, lstate, _) = lstate + +type frame = + | Done of state * value + | Step of string * state * (Type_check.tannot exp) monad * (string * lstate * (value -> (Type_check.tannot exp) monad)) list + | Break of frame + +let rec eval_frame' ast = function + | Done (state, v) -> Done (state, v) + | Break frame -> Break frame + | Step (out, state, m, stack) -> + match (m, stack) with + | Pure v, [] when is_value v -> Done (state, value_of_exp v) + | Pure v, (head :: stack') when is_value v -> + (* print_endline ("Returning value: " ^ string_of_value (value_of_exp v) |> Util.cyan |> Util.clear); *) + Step (stack_string head, (stack_state head, snd state), stack_cont head (value_of_exp v), stack') + | Pure exp', _ -> + let out' = Pretty_print_sail.to_string (Pretty_print_sail.doc_exp exp') in + Step (out', state, step exp', stack) + | Yield (Call(id, vals, cont)), _ when string_of_id id = "break" -> + let arg = if List.length vals != 1 then tuple_value vals else List.hd vals in + let body = exp_of_fundef (get_fundef id ast) arg in + Break (Step ("", (initial_lstate, snd state), return body, (out, fst state, cont) :: stack)) + | Yield (Call(id, vals, cont)), _ -> + (* print_endline ("Calling " ^ string_of_id id |> Util.cyan |> Util.clear); *) + let arg = if List.length vals != 1 then tuple_value vals else List.hd vals in + let body = exp_of_fundef (get_fundef id ast) arg in + Step ("", (initial_lstate, snd state), return body, (out, fst state, cont) :: stack) + | Yield (Gets cont), _ -> + eval_frame' ast (Step (out, state, cont state, stack)) + | Yield (Puts (state', cont)), _ -> + eval_frame' ast (Step (out, state', cont (), stack)) + | Yield (Early_return v), [] -> Done (state, v) + | Yield (Early_return v), (head :: stack') -> + (* print_endline ("Returning value: " ^ string_of_value v |> Util.cyan |> Util.clear); *) + Step (stack_string head, (stack_state head, snd state), stack_cont head v, stack') + | Yield (Assertion_failed msg), _ -> + failwith msg + | Yield (Exception v), _ -> + print_endline ("Uncaught Exception" |> Util.cyan |> Util.clear); + Done (state, v) + +let eval_frame ast frame = + try eval_frame' ast frame with + | Type_check.Type_error (l, err) -> + raise (Reporting_basic.err_typ l (Type_check.string_of_type_error err)) diff --git a/src/isail.ml b/src/isail.ml new file mode 100644 index 00000000..d8aa55c1 --- /dev/null +++ b/src/isail.ml @@ -0,0 +1,244 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* 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 Sail + +open Ast +open Ast_util +open Interpreter +open Pretty_print_sail + +type mode = + | Evaluation of frame + | Normal + +let current_mode = ref Normal + +let prompt () = + match !current_mode with + | Normal -> "sail> " + | Evaluation _ -> "eval> " + +let mode_clear () = + match !current_mode with + | Normal -> () + | Evaluation _ -> LNoise.clear_screen () + +let rec user_input callback = + match LNoise.linenoise (prompt ()) with + | None -> () + | Some v -> + mode_clear (); + begin + try callback v with + | Reporting_basic.Fatal_error e -> Reporting_basic.report_error e + end; + user_input callback + +let termcode n = "\x1B[" ^ string_of_int n ^ "m" +let bold str = termcode 1 ^ str +let red str = termcode 91 ^ str +let clear str = str ^ termcode 0 + +let sail_logo = + let banner str = str |> bold |> red |> clear in + [ {| ___ ___ ___ ___ |}; + {| /\ \ /\ \ /\ \ /\__\|}; + {| /::\ \ /::\ \ _\:\ \ /:/ /|}; + {| /\:\:\__\ /::\:\__\ /\/::\__\ /:/__/ |}; + {| \:\:\/__/ \/\::/ / \::/\/__/ \:\ \ |}; + {| \::/ / /:/ / \:\__\ \:\__\|}; + {| \/__/ \/__/ \/__/ \/__/|}; + "" + ] + |> List.map banner + +let vs_ids = ref (Initial_check.val_spec_ids !interactive_ast) + +let print_program () = + match !current_mode with + | Normal -> () + | Evaluation (Step (out, _, _, stack)) -> + let sep = "-----------------------------------------------------" |> Util.blue |> Util.clear in + List.map stack_string stack |> List.rev |> List.iter (fun code -> print_endline code; print_endline sep); + print_endline out + | Evaluation _ -> () + +let interactive_state = ref (initial_state !interactive_ast) + +let rec run () = + match !current_mode with + | Normal -> () + | Evaluation frame -> + begin + match frame with + | Done (state, v) -> + interactive_state := state; + print_endline ("Result = " ^ Value.string_of_value v); + current_mode := Normal + | Step (out, state, _, stack) -> + current_mode := Evaluation (eval_frame !interactive_ast frame); + run () + | Break frame -> + print_endline "Breakpoint"; + current_mode := Evaluation frame + end + +let rec run_steps n = + match !current_mode with + | _ when n <= 0 -> () + | Normal -> () + | Evaluation frame -> + begin + match frame with + | Done (state, v) -> + interactive_state := state; + print_endline ("Result = " ^ Value.string_of_value v); + current_mode := Normal + | Step (out, state, _, stack) -> + current_mode := Evaluation (eval_frame !interactive_ast frame); + run_steps (n - 1) + | Break frame -> + print_endline "Breakpoint"; + current_mode := Evaluation frame + end + +let handle_input input = + LNoise.history_add input |> ignore; + match !current_mode with + | Normal -> + begin + if input <> "" && input.[0] = ':' then + let n = try String.index input ' ' with Not_found -> String.length input in + let cmd = Str.string_before input n in + let arg = String.trim (Str.string_after input n) in + match cmd with + | ":t" | ":type" -> + let typq, typ = Type_check.Env.get_val_spec (mk_id arg) !interactive_env in + pretty_sail stdout (doc_binding (typq, typ)); + print_newline (); + | ":elf" -> + Elf_loader.load_elf arg + | ":q" | ":quit" -> exit 0 + | ":i" | ":infer" -> + let exp = Initial_check.exp_of_string dec_ord arg in + let exp = Type_check.infer_exp !interactive_env exp in + pretty_sail stdout (doc_typ (Type_check.typ_of exp)); + print_newline () + | ":v" | ":verbose" -> + Type_check.opt_tc_debug := (!Type_check.opt_tc_debug + 1) mod 3; + print_endline ("Verbosity: " ^ string_of_int !Type_check.opt_tc_debug) + + | _ -> print_endline ("Unrecognised command " ^ input) + else if input <> "" then + let exp = Type_check.infer_exp !interactive_env (Initial_check.exp_of_string Ast_util.dec_ord input) in + current_mode := Evaluation (eval_frame !interactive_ast (Step ("", !interactive_state, return exp, []))); + print_program () + else () + end + | Evaluation frame -> + begin + if input <> "" && input.[0] = ':' then + let n = try String.index input ' ' with Not_found -> String.length input in + let cmd = Str.string_before input n in + let arg = String.trim (Str.string_after input n) in + match cmd with + | ":r" | ":run" -> + run () + | ":s" | ":step" -> + run_steps (int_of_string arg) + | ":q" | ":quit" -> exit 0 + | _ -> print_endline ("Unrecognised command " ^ input) + else + match frame with + | Done (state, v) -> + interactive_state := state; + print_endline ("Result = " ^ Value.string_of_value v); + current_mode := Normal + | Step (out, state, _, stack) -> + interactive_state := state; + current_mode := Evaluation (eval_frame !interactive_ast frame); + print_program () + | Break frame -> + print_endline "Breakpoint"; + current_mode := Evaluation frame + end + +let () = + (* Auto complete function names based on val specs *) + LNoise.set_completion_callback + begin + fun line_so_far ln_completions -> + let line_so_far, last_id = + try + let p = Str.search_backward (Str.regexp "[^a-zA-Z0-9_]") line_so_far (String.length line_so_far - 1) in + Str.string_before line_so_far (p + 1), Str.string_after line_so_far (p + 1) + with + | Not_found -> "", line_so_far + | Invalid_argument _ -> line_so_far, "" + in + if last_id <> "" then + IdSet.elements !vs_ids + |> List.map string_of_id + |> List.filter (fun id -> Str.string_match (Str.regexp_string last_id) id 0) + |> List.map (fun completion -> line_so_far ^ completion) + |> List.iter (LNoise.add_completion ln_completions) + else () + end; + + LNoise.history_load ~filename:"sail_history" |> ignore; + LNoise.history_set ~max_length:100 |> ignore; + + if !opt_interactive then + begin + List.iter print_endline sail_logo; + user_input handle_input + end + else () diff --git a/src/lexer.mll b/src/lexer.mll index 35ab6627..ccbe12a5 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -50,7 +50,8 @@ { open Parser -open Big_int +module Big_int = Nat_big_num +open Parse_ast module M = Map.Make(String) exception LexError of string * Lexing.position @@ -58,81 +59,103 @@ let r = fun s -> s (* Ulib.Text.of_latin1 *) (* Available as Scanf.unescaped since OCaml 4.0 but 3.12 is still common *) let unescaped s = Scanf.sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) +let mk_operator prec n op = + match prec, n with + | Infix, 0 -> Op0 op + | Infix, 1 -> Op1 op + | Infix, 2 -> Op2 op + | Infix, 3 -> Op3 op + | Infix, 4 -> Op4 op + | Infix, 5 -> Op5 op + | Infix, 6 -> Op6 op + | Infix, 7 -> Op7 op + | Infix, 8 -> Op8 op + | Infix, 9 -> Op9 op + | InfixL, 0 -> Op0l op + | InfixL, 1 -> Op1l op + | InfixL, 2 -> Op2l op + | InfixL, 3 -> Op3l op + | InfixL, 4 -> Op4l op + | InfixL, 5 -> Op5l op + | InfixL, 6 -> Op6l op + | InfixL, 7 -> Op7l op + | InfixL, 8 -> Op8l op + | InfixL, 9 -> Op9l op + | InfixR, 0 -> Op0r op + | InfixR, 1 -> Op1r op + | InfixR, 2 -> Op2r op + | InfixR, 3 -> Op3r op + | InfixR, 4 -> Op4r op + | InfixR, 5 -> Op5r op + | InfixR, 6 -> Op6r op + | InfixR, 7 -> Op7r op + | InfixR, 8 -> Op8r op + | InfixR, 9 -> Op9r op + | _, _ -> assert false + +let operators = ref M.empty + let kw_table = List.fold_left (fun r (x,y) -> M.add x y r) M.empty [ ("and", (fun _ -> And)); - ("alias", (fun _ -> Alias)); ("as", (fun _ -> As)); ("assert", (fun _ -> Assert)); ("bitzero", (fun _ -> Bitzero)); ("bitone", (fun _ -> Bitone)); - ("bits", (fun _ -> Bits)); ("by", (fun _ -> By)); - ("case", (fun _ -> Case)); + ("match", (fun _ -> Match)); ("clause", (fun _ -> Clause)); - ("const", (fun _ -> Const)); ("dec", (fun _ -> Dec)); - ("def", (fun _ -> Def)); + ("operator", (fun _ -> Op)); ("default", (fun _ -> Default)); - ("deinfix", (fun _ -> Deinfix)); ("effect", (fun _ -> Effect)); - ("Effect", (fun _ -> EFFECT)); ("end", (fun _ -> End)); - ("enumerate", (fun _ -> Enumerate)); + ("enum", (fun _ -> Enum)); ("else", (fun _ -> Else)); ("exit", (fun _ -> Exit)); - ("extern", (fun _ -> Extern)); ("cast", (fun _ -> Cast)); ("false", (fun _ -> False)); - ("try", (fun _ -> Try)); - ("catch", (fun _ -> Catch)); - ("throw", (fun _ -> Throw)); ("forall", (fun _ -> Forall)); - ("exist", (fun _ -> Exist)); ("foreach", (fun _ -> Foreach)); ("function", (fun x -> Function_)); ("overload", (fun _ -> Overload)); + ("throw", (fun _ -> Throw)); + ("try", (fun _ -> Try)); + ("catch", (fun _ -> Catch)); ("if", (fun x -> If_)); ("in", (fun x -> In)); ("inc", (fun _ -> Inc)); - ("IN", (fun x -> IN)); ("let", (fun x -> Let_)); - ("member", (fun x -> Member)); - ("Nat", (fun x -> Nat)); - ("Num", (fun x -> NatNum)); + ("var", (fun _ -> Var)); + ("ref", (fun _ -> Ref)); + ("record", (fun _ -> Record)); + ("Int", (fun x -> Int)); ("Order", (fun x -> Order)); ("pure", (fun x -> Pure)); - ("rec", (fun x -> Rec)); ("register", (fun x -> Register)); ("return", (fun x -> Return)); ("scattered", (fun x -> Scattered)); ("sizeof", (fun x -> Sizeof)); ("constraint", (fun x -> Constraint)); ("struct", (fun x -> Struct)); - ("switch", (fun x -> Switch)); ("then", (fun x -> Then)); ("true", (fun x -> True)); ("Type", (fun x -> TYPE)); - ("typedef", (fun x -> Typedef)); + ("type", (fun x -> Typedef)); ("undefined", (fun x -> Undefined)); ("union", (fun x -> Union)); + ("newtype", (fun x -> Newtype)); ("with", (fun x -> With)); - ("when", (fun x -> When)); - ("repeat", (fun x -> Repeat)); - ("until", (fun x -> Until)); - ("while", (fun x -> While)); - ("do", (fun x -> Do)); ("val", (fun x -> Val)); - - ("div", (fun x -> Div_)); - ("mod", (fun x -> Mod)); - ("mod_s", (fun x -> ModUnderS)); - ("quot", (fun x -> Quot)); - ("quot_s", (fun x -> QuotUnderS)); - ("rem", (fun x -> Rem)); + ("repeat", (fun _ -> Repeat)); + ("until", (fun _ -> Until)); + ("while", (fun _ -> While)); + ("do", (fun _ -> Do)); + ("mutual", (fun _ -> Mutual)); + ("bitfield", (fun _ -> Bitfield)); ("barr", (fun x -> Barr)); ("depend", (fun x -> Depend)); @@ -149,17 +172,14 @@ let kw_table = ("unspec", (fun x -> Unspec)); ("nondet", (fun x -> Nondet)); ("escape", (fun x -> Escape)); + ] -] -let default_type_names = ["bool";"unit";"vector";"range";"list";"bit";"nat"; "int"; "real"; - "uint8";"uint16";"uint32";"uint64";"atom";"implicit";"string";"option"] -let custom_type_names : string list ref = ref [] } let ws = [' ''\t']+ -let letter = ['a'-'z''A'-'Z'] +let letter = ['a'-'z''A'-'Z''?'] let digit = ['0'-'9'] let binarydigit = ['0'-'1'] let hexdigit = ['0'-'9''A'-'F''a'-'f'] @@ -167,7 +187,8 @@ let alphanum = letter|digit let startident = letter|'_' let ident = alphanum|['_''\'''#'] let tyvar_start = '\'' -let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''?''@''^''|''~'] +let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''@''^''|'] +let operator = (oper_char+ ('_' ident)?) let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) rule token = parse @@ -176,162 +197,69 @@ rule token = parse | "\n" { Lexing.new_line lexbuf; token lexbuf } - | "&" { (Amp(r"&")) } - | "@" { (At(r"@")) } - | "|" { Bar } - | "^" { (Carrot(r"^")) } + | "@" { (At "@") } + | "2" ws "^" { TwoCaret } + | "^" { (Caret(r"^")) } | ":" { Colon(r ":") } | "," { Comma } + | ".." { DotDot } | "." { Dot } + | "==" as op + { try M.find op !operators + with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } | "=" { (Eq(r"=")) } - | "!" { (Excl(r"!")) } | ">" { (Gt(r">")) } | "-" { Minus } | "<" { (Lt(r"<")) } | "+" { (Plus(r"+")) } | ";" { Semi } | "*" { (Star(r"*")) } - | "~" { (Tilde(r"~")) } | "_" { Under } + | "[|" { LsquareBar } + | "|]" { RsquareBar } + | "{|" { LcurlyBar } + | "|}" { RcurlyBar } + | "|" { Bar } | "{" { Lcurly } | "}" { Rcurly } + | "()" { Unit(r"()") } | "(" { Lparen } | ")" { Rparen } | "[" { Lsquare } | "]" { Rsquare } - | "&&" as i { (AmpAmp(r i)) } - | "||" { BarBar } - | "||]" { BarBarSquare } - | "|]" { BarSquare } - | "^^" { (CarrotCarrot(r"^^")) } - | "::" as i { (ColonColon(r i)) } - | ":=" { ColonEq } - | ":>" { ColonGt } - | ":]" { ColonSquare } - | ".." { DotDot } - | "==" { (EqEq(r"==")) } | "!=" { (ExclEq(r"!=")) } - | "!!" { (ExclExcl(r"!!")) } | ">=" { (GtEq(r">=")) } - | ">=+" { (GtEqPlus(r">=+")) } - | ">>" { (GtGt(r">>")) } - | ">>>" { (GtGtGt(r">>>")) } - | ">+" { (GtPlus(r">+")) } - | "#>>" { (HashGtGt(r"#>>")) } - | "#<<" { (HashLtLt(r"#<<")) } | "->" { MinusGt } - | "<:" { LtColon } + | "=>" { EqGt(r "=>") } | "<=" { (LtEq(r"<=")) } - | "<=+" { (LtEqPlus(r"<=+")) } - | "<>" { (LtGt(r"<>")) } - | "<<" { (LtLt(r"<<")) } - | "<<<" { (LtLtLt(r"<<<")) } - | "<+" { (LtPlus(r"<+")) } - | "**" { (StarStar(r"**")) } - | "[|" { SquareBar } - | "[||" { SquareBarBar } - | "[:" { SquareColon } - | "~^" { (TildeCarrot(r"~^")) } - - | "+_s" { (PlusUnderS(r"+_s")) } - | "-_s" { (MinusUnderS(r"-_s")) } - | ">=_s" { (GtEqUnderS(r">=_s")) } - | ">=_si" { (GtEqUnderSi(r">=_si")) } - | ">=_u" { (GtEqUnderU(r">=_u")) } - | ">=_ui" { (GtEqUnderUi(r">=_ui")) } - | ">>_u" { (GtGtUnderU(r">>_u")) } - | ">_s" { (GtUnderS(r">_s")) } - | ">_si" { (GtUnderSi(r">_si")) } - | ">_u" { (GtUnderU(r">_u")) } - | ">_ui" { (GtUnderUi(r">_ui")) } - | "<=_s" { (LtEqUnderS(r"<=_s")) } - | "<=_si" { (LtEqUnderSi(r"<=_si")) } - | "<=_u" { (LtEqUnderU(r"<=_u")) } - | "<=_ui" { (LtEqUnderUi(r"<=_ui")) } - | "<_s" { (LtUnderS(r"<_s")) } - | "<_si" { (LtUnderSi(r"<_si")) } - | "<_u" { (LtUnderU(r"<_u")) } - | "<_ui" { (LtUnderUi(r"<_ui")) } - | "*_s" { (StarUnderS(r"*_s")) } - | "**_s" { (StarStarUnderS(r"**_s")) } - | "**_si" { (StarStarUnderSi(r"**_si")) } - | "*_u" { (StarUnderU(r"*_u")) } - | "*_ui" { (StarUnderUi(r"*_ui")) } - | "2^" { (TwoCarrot(r"2^")) } - | "2**" { TwoStarStar } - - - | "(*" { comment (Lexing.lexeme_start_p lexbuf) 0 lexbuf; token lexbuf } - | "*)" { raise (LexError("Unbalanced comment", Lexing.lexeme_start_p lexbuf)) } - + | "/*" { comment (Lexing.lexeme_start_p lexbuf) 0 lexbuf; token lexbuf } + | "*/" { raise (LexError("Unbalanced comment", Lexing.lexeme_start_p lexbuf)) } + | "infix" ws (digit as p) ws (operator as op) + { operators := M.add op (mk_operator Infix (int_of_string (Char.escaped p)) op) !operators; + Fixity (Infix, Big_int.of_string (Char.escaped p), op) } + | "infixl" ws (digit as p) ws (operator as op) + { operators := M.add op (mk_operator InfixL (int_of_string (Char.escaped p)) op) !operators; + Fixity (InfixL, Big_int.of_string (Char.escaped p), op) } + | "infixr" ws (digit as p) ws (operator as op) + { operators := M.add op (mk_operator InfixR (int_of_string (Char.escaped p)) op) !operators; + Fixity (InfixR, Big_int.of_string (Char.escaped p), op) } + | operator as op + { try M.find op !operators + with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } | tyvar_start startident ident* as i { TyVar(r i) } + | "~" { Id(r"~") } | startident ident* as i { if M.mem i kw_table then (M.find i kw_table) () - else if + (* else if List.mem i default_type_names || List.mem i !custom_type_names then - TyId(r i) - else Id(r i) } - | "&" oper_char+ as i { (AmpI(r i)) } - | "@" oper_char+ as i { (AtI(r i)) } - | "^" oper_char+ as i { (CarrotI(r i)) } - | "/" oper_char+ as i { (DivI(r i)) } - | "=" oper_char+ as i { (EqI(r i)) } - | "!" oper_char+ as i { (ExclI(r i)) } - | ">" oper_char+ as i { (GtI(r i)) } - | "<" oper_char+ as i { (LtI(r i)) } - | "+" oper_char+ as i { (PlusI(r i)) } - | "*" oper_char+ as i { (StarI(r i)) } - | "~" oper_char+ as i { (TildeI(r i)) } - | "&&" oper_char+ as i { (AmpAmpI(r i)) } - | "^^" oper_char+ as i { (CarrotCarrotI(r i)) } - | "::" oper_char+ as i { (ColonColonI(r i)) } - | "==" oper_char+ as i { (EqEqI(r i)) } - | "!=" oper_char+ as i { (ExclEqI(r i)) } - | "!!" oper_char+ as i { (ExclExclI(r i)) } - | ">=" oper_char+ as i { (GtEqI(r i)) } - | ">=+" oper_char+ as i { (GtEqPlusI(r i)) } - | ">>" oper_char+ as i { (GtGtI(r i)) } - | ">>>" oper_char+ as i { (GtGtGtI(r i)) } - | ">+" oper_char+ as i { (GtPlusI(r i)) } - | "#>>" oper_char+ as i { (HashGtGt(r i)) } - | "#<<" oper_char+ as i { (HashLtLt(r i)) } - | "<=" oper_char+ as i { (LtEqI(r i)) } - | "<=+" oper_char+ as i { (LtEqPlusI(r i)) } - | "<<" oper_char+ as i { (LtLtI(r i)) } - | "<<<" oper_char+ as i { (LtLtLtI(r i)) } - | "<+" oper_char+ as i { (LtPlusI(r i)) } - | "**" oper_char+ as i { (StarStarI(r i)) } - | "~^" oper_char+ as i { (TildeCarrot(r i)) } - - | ">=_s" oper_char+ as i { (GtEqUnderSI(r i)) } - | ">=_si" oper_char+ as i { (GtEqUnderSiI(r i)) } - | ">=_u" oper_char+ as i { (GtEqUnderUI(r i)) } - | ">=_ui" oper_char+ as i { (GtEqUnderUiI(r i)) } - | ">>_u" oper_char+ as i { (GtGtUnderUI(r i)) } - | ">_s" oper_char+ as i { (GtUnderSI(r i)) } - | ">_si" oper_char+ as i { (GtUnderSiI(r i)) } - | ">_u" oper_char+ as i { (GtUnderUI(r i)) } - | ">_ui" oper_char+ as i { (GtUnderUiI(r i)) } - | "<=_s" oper_char+ as i { (LtEqUnderSI(r i)) } - | "<=_si" oper_char+ as i { (LtEqUnderSiI(r i)) } - | "<=_u" oper_char+ as i { (LtEqUnderUI(r i)) } - | "<=_ui" oper_char+ as i { (LtEqUnderUiI(r i)) } - | "<_s" oper_char+ as i { (LtUnderSI(r i)) } - | "<_si" oper_char+ as i { (LtUnderSiI(r i)) } - | "<_u" oper_char+ as i { (LtUnderUI(r i)) } - | "<_ui" oper_char+ as i { (LtUnderUiI(r i)) } - | "**_s" oper_char+ as i { (StarStarUnderSI(r i)) } - | "**_si" oper_char+ as i { (StarStarUnderSiI(r i)) } - | "*_u" oper_char+ as i { (StarUnderUI(r i)) } - | "*_ui" oper_char+ as i { (StarUnderUiI(r i)) } - | "2^" oper_char+ as i { (TwoCarrotI(r i)) } - + TyId(r i) *) + else Id(r i) } | (digit+ as i1) "." (digit+ as i2) { (Real (i1 ^ "." ^ i2)) } | "-" (digit* as i1) "." (digit+ as i2) { (Real ("-" ^ i1 ^ "." ^ i2)) } - | digit+ as i { (Num(big_int_of_string i)) } - | "-" digit+ as i { (Num(big_int_of_string i)) } + | digit+ as i { (Num(Big_int.of_string i)) } + | "-" digit+ as i { (Num(Big_int.of_string i)) } | "0b" (binarydigit+ as i) { (Bin(i)) } | "0x" (hexdigit+ as i) { (Hex(i)) } | '"' { (String( @@ -343,8 +271,8 @@ rule token = parse and comment pos depth = parse - | "(*" { comment pos (depth+1) lexbuf } - | "*)" { if depth = 0 then () + | "/*" { comment pos (depth+1) lexbuf } + | "*/" { if depth = 0 then () else if depth > 0 then comment pos (depth-1) lexbuf else assert false } | "\n" { Lexing.new_line lexbuf; diff --git a/src/lexer2.mll b/src/lexer2.mll deleted file mode 100644 index e43bd3e1..00000000 --- a/src/lexer2.mll +++ /dev/null @@ -1,294 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* 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 Parser2 -open Big_int -open Parse_ast -module M = Map.Make(String) -exception LexError of string * Lexing.position - -let r = fun s -> s (* Ulib.Text.of_latin1 *) -(* Available as Scanf.unescaped since OCaml 4.0 but 3.12 is still common *) -let unescaped s = Scanf.sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) - -let mk_operator prec n op = - match prec, n with - | Infix, 0 -> Op0 op - | Infix, 1 -> Op1 op - | Infix, 2 -> Op2 op - | Infix, 3 -> Op3 op - | Infix, 4 -> Op4 op - | Infix, 5 -> Op5 op - | Infix, 6 -> Op6 op - | Infix, 7 -> Op7 op - | Infix, 8 -> Op8 op - | Infix, 9 -> Op9 op - | InfixL, 0 -> Op0l op - | InfixL, 1 -> Op1l op - | InfixL, 2 -> Op2l op - | InfixL, 3 -> Op3l op - | InfixL, 4 -> Op4l op - | InfixL, 5 -> Op5l op - | InfixL, 6 -> Op6l op - | InfixL, 7 -> Op7l op - | InfixL, 8 -> Op8l op - | InfixL, 9 -> Op9l op - | InfixR, 0 -> Op0r op - | InfixR, 1 -> Op1r op - | InfixR, 2 -> Op2r op - | InfixR, 3 -> Op3r op - | InfixR, 4 -> Op4r op - | InfixR, 5 -> Op5r op - | InfixR, 6 -> Op6r op - | InfixR, 7 -> Op7r op - | InfixR, 8 -> Op8r op - | InfixR, 9 -> Op9r op - | _, _ -> assert false - -let operators = ref M.empty - -let kw_table = - List.fold_left - (fun r (x,y) -> M.add x y r) - M.empty - [ - ("and", (fun _ -> And)); - ("as", (fun _ -> As)); - ("assert", (fun _ -> Assert)); - ("bitzero", (fun _ -> Bitzero)); - ("bitone", (fun _ -> Bitone)); - ("by", (fun _ -> By)); - ("match", (fun _ -> Match)); - ("clause", (fun _ -> Clause)); - ("dec", (fun _ -> Dec)); - ("operator", (fun _ -> Op)); - ("default", (fun _ -> Default)); - ("effect", (fun _ -> Effect)); - ("end", (fun _ -> End)); - ("enum", (fun _ -> Enum)); - ("else", (fun _ -> Else)); - ("exit", (fun _ -> Exit)); - ("cast", (fun _ -> Cast)); - ("false", (fun _ -> False)); - ("forall", (fun _ -> Forall)); - ("foreach", (fun _ -> Foreach)); - ("function", (fun x -> Function_)); - ("overload", (fun _ -> Overload)); - ("throw", (fun _ -> Throw)); - ("try", (fun _ -> Try)); - ("catch", (fun _ -> Catch)); - ("if", (fun x -> If_)); - ("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)); - ("register", (fun x -> Register)); - ("return", (fun x -> Return)); - ("scattered", (fun x -> Scattered)); - ("sizeof", (fun x -> Sizeof)); - ("constraint", (fun x -> Constraint)); - ("struct", (fun x -> Struct)); - ("then", (fun x -> Then)); - ("true", (fun x -> True)); - ("Type", (fun x -> TYPE)); - ("type", (fun x -> Typedef)); - ("undefined", (fun x -> Undefined)); - ("union", (fun x -> Union)); - ("with", (fun x -> With)); - ("val", (fun x -> Val)); - ("repeat", (fun _ -> Repeat)); - ("until", (fun _ -> Until)); - ("while", (fun _ -> While)); - ("do", (fun _ -> Do)); - ("mutual", (fun _ -> Mutual)); - - ("barr", (fun x -> Barr)); - ("depend", (fun x -> Depend)); - ("rreg", (fun x -> Rreg)); - ("wreg", (fun x -> Wreg)); - ("rmem", (fun x -> Rmem)); - ("rmemt", (fun x -> Rmemt)); - ("wmem", (fun x -> Wmem)); - ("wmv", (fun x -> Wmv)); - ("wmvt", (fun x -> Wmvt)); - ("eamem", (fun x -> Eamem)); - ("exmem", (fun x -> Exmem)); - ("undef", (fun x -> Undef)); - ("unspec", (fun x -> Unspec)); - ("nondet", (fun x -> Nondet)); - ("escape", (fun x -> Escape)); - ] - -} - -let ws = [' ''\t']+ -let letter = ['a'-'z''A'-'Z''?'] -let digit = ['0'-'9'] -let binarydigit = ['0'-'1'] -let hexdigit = ['0'-'9''A'-'F''a'-'f'] -let alphanum = letter|digit -let startident = letter|'_' -let ident = alphanum|['_''\'''#'] -let tyvar_start = '\'' -let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''@''^''|'] -let operator = (oper_char+ ('_' ident)?) -let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) - -rule token = parse - | ws - { token lexbuf } - | "\n" - { Lexing.new_line lexbuf; - token lexbuf } - | "&" { (Amp(r"&")) } - | "@" { (At "@") } - | "2" ws "^" { TwoCaret } - | "^" { (Caret(r"^")) } - | ":" { Colon(r ":") } - | "," { Comma } - | ".." { DotDot } - | "." { Dot } - | "==" as op - { try M.find op !operators - with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } - | "=" { (Eq(r"=")) } - | ">" { (Gt(r">")) } - | "-" { Minus } - | "<" { (Lt(r"<")) } - | "+" { (Plus(r"+")) } - | ";" { Semi } - | "*" { (Star(r"*")) } - | "_" { Under } - | "[|" { LsquareBar } - | "|]" { RsquareBar } - | "{|" { LcurlyBar } - | "|}" { RcurlyBar } - | "|" { Bar } - | "{" { Lcurly } - | "}" { Rcurly } - | "()" { Unit(r"()") } - | "(" { Lparen } - | ")" { Rparen } - | "[" { Lsquare } - | "]" { Rsquare } - | "!=" { (ExclEq(r"!=")) } - | ">=" { (GtEq(r">=")) } - | "->" { MinusGt } - | "=>" { EqGt(r "=>") } - | "<=" { (LtEq(r"<=")) } - | "infix" ws (digit as p) ws (operator as op) - { operators := M.add op (mk_operator Infix (int_of_string (Char.escaped p)) op) !operators; - Fixity (Infix, big_int_of_string (Char.escaped p), op) } - | "infixl" ws (digit as p) ws (operator as op) - { operators := M.add op (mk_operator InfixL (int_of_string (Char.escaped p)) op) !operators; - Fixity (InfixL, big_int_of_string (Char.escaped p), op) } - | "infixr" ws (digit as p) ws (operator as op) - { operators := M.add op (mk_operator InfixR (int_of_string (Char.escaped p)) op) !operators; - Fixity (InfixR, big_int_of_string (Char.escaped p), op) } - | operator as op - { try M.find op !operators - with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } - | "(*" { comment (Lexing.lexeme_start_p lexbuf) 0 lexbuf; token lexbuf } - | "*)" { raise (LexError("Unbalanced comment", Lexing.lexeme_start_p lexbuf)) } - | tyvar_start startident ident* as i { TyVar(r i) } - | "~" { Id(r"~") } - | startident ident* as i { if M.mem i kw_table then - (M.find i kw_table) () - (* else if - List.mem i default_type_names || - List.mem i !custom_type_names then - TyId(r i) *) - else Id(r i) } - | (digit+ as i1) "." (digit+ as i2) { (Real (i1 ^ "." ^ i2)) } - | "-" (digit* as i1) "." (digit+ as i2) { (Real ("-" ^ i1 ^ "." ^ i2)) } - | digit+ as i { (Num(big_int_of_string i)) } - | "-" digit+ as i { (Num(big_int_of_string i)) } - | "0b" (binarydigit+ as i) { (Bin(i)) } - | "0x" (hexdigit+ as i) { (Hex(i)) } - | '"' { (String( - string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf)) } - | eof { Eof } - | _ as c { raise (LexError( - Printf.sprintf "Unexpected character: %c" c, - Lexing.lexeme_start_p lexbuf)) } - - -and comment pos depth = parse - | "(*" { comment pos (depth+1) lexbuf } - | "*)" { if depth = 0 then () - else if depth > 0 then comment pos (depth-1) lexbuf - else assert false } - | "\n" { Lexing.new_line lexbuf; - comment pos depth lexbuf } - | '"' { ignore(string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf); - comment pos depth lexbuf } - | _ { comment pos depth lexbuf } - | eof { raise (LexError("Unbalanced comment", pos)) } - -and string pos b = parse - | ([^'"''\n''\\']*'\n' as i) { Lexing.new_line lexbuf; - Buffer.add_string b i; - string pos b lexbuf } - | ([^'"''\n''\\']* as i) { Buffer.add_string b i; string pos b lexbuf } - | escape_sequence as i { Buffer.add_string b i; string pos b lexbuf } - | '\\' '\n' ws { Lexing.new_line lexbuf; string pos b lexbuf } - | '\\' { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "illegal backslash escape in string"*) } - | '"' { let s = unescaped(Buffer.contents b) in - (*try Ulib.UTF8.validate s; s - with Ulib.UTF8.Malformed_code -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "String literal is not valid utf8"))) *) s } - | eof { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "String literal not terminated")))*) } diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 0cbeda49..06f0683a 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -51,7 +51,7 @@ open Parse_ast open Ast open Ast_util -open Big_int +module Big_int = Nat_big_num open Type_check let size_set_limit = 8 @@ -102,7 +102,7 @@ let rec subst_nc substs (NC_aux (nc,l) as n_constraint) = begin match KBindings.find kid substs with | Nexp_aux (Nexp_constant i,_) -> - if List.exists (fun j -> Big_int.eq_big_int i j) is then re NC_true else re NC_false + if List.exists (fun j -> Big_int.equal i j) is then re NC_true else re NC_false | nexp -> raise (Reporting_basic.err_general l ("Unable to substitute " ^ string_of_nexp nexp ^ @@ -138,18 +138,18 @@ let subst_src_typ substs t = in s_styp substs t let make_vector_lit sz i = - let f j = if eq_big_int (mod_big_int (shift_right_big_int i (sz-j-1)) (big_int_of_int 2)) zero_big_int then '0' else '1' in + let f j = if Big_int.equal (Big_int.modulus (Big_int.shift_right i (sz-j-1)) (Big_int.of_int 2)) Big_int.zero then '0' else '1' in let s = String.init sz f in L_aux (L_bin s,Generated Unknown) let tabulate f n = let rec aux acc n = let acc' = f n::acc in - if eq_big_int n zero_big_int then acc' else aux acc' (sub_big_int n unit_big_int) - in if eq_big_int n zero_big_int then [] else aux [] (sub_big_int n unit_big_int) + if Big_int.equal n Big_int.zero then acc' else aux acc' (Big_int.sub n (Big_int.of_int 1)) + in if Big_int.equal n Big_int.zero then [] else aux [] (Big_int.sub n (Big_int.of_int 1)) let make_vectors sz = - tabulate (make_vector_lit sz) (shift_left_big_int unit_big_int sz) + tabulate (make_vector_lit sz) (Big_int.shift_left (Big_int.of_int 1) sz) let pat_id_is_variable env id = match Env.lookup_id id env with @@ -412,7 +412,7 @@ let split_src_type id ty (TypQ_aux (q,ql)) = in let name_seg = function | (_,None) -> "" - | (k,Some i) -> string_of_kid k ^ string_of_big_int i + | (k,Some i) -> string_of_kid k ^ Big_int.to_string i in let name l i = String.concat "_" (i::(List.map name_seg l)) in Some (List.map (fun (l,ty) -> (l, wrap (name l),ty)) variants) @@ -421,11 +421,11 @@ let reduce_nexp subst ne = let rec eval (Nexp_aux (ne,_) as nexp) = match ne with | Nexp_constant i -> i - | Nexp_sum (n1,n2) -> add_big_int (eval n1) (eval n2) - | Nexp_minus (n1,n2) -> sub_big_int (eval n1) (eval n2) - | Nexp_times (n1,n2) -> mult_big_int (eval n1) (eval n2) - | Nexp_exp n -> shift_left_big_int (eval n) 1 - | Nexp_neg n -> minus_big_int (eval n) + | Nexp_sum (n1,n2) -> Big_int.add (eval n1) (eval n2) + | Nexp_minus (n1,n2) -> Big_int.sub (eval n1) (eval n2) + | Nexp_times (n1,n2) -> Big_int.mul (eval n1) (eval n2) + | Nexp_exp n -> Big_int.shift_left (eval n) 1 + | Nexp_neg n -> Big_int.negate (eval n) | _ -> raise (Reporting_basic.err_general Unknown ("Couldn't turn nexp " ^ string_of_nexp nexp ^ " into concrete value")) @@ -465,7 +465,7 @@ let refine_constructor refinements l env id args = (fun v (_,w) -> match v,w with | _,None -> true - | Some (U_nexp (Nexp_aux (Nexp_constant n, _))),Some m -> eq_big_int n m + | Some (U_nexp (Nexp_aux (Nexp_constant n, _))),Some m -> Big_int.equal n m | _,_ -> false) bindings mapping in match List.find matches_refinement irefinements with @@ -551,7 +551,7 @@ let nexp_subst_fns substs = | E_assert (e1,e2) -> re (E_assert (s_exp e1,s_exp e2)) | E_internal_cast ((l,ann),e) -> re (E_internal_cast ((l,s_tannot ann),s_exp e)) | E_comment_struc e -> re (E_comment_struc e) - | E_internal_let (le,e1,e2) -> re (E_internal_let (s_lexp le, s_exp e1, s_exp e2)) + | E_var (le,e1,e2) -> re (E_var (s_lexp le, s_exp e1, s_exp e2)) | E_internal_plet (p,e1,e2) -> re (E_internal_plet (s_pat p, s_exp e1, s_exp e2)) | E_internal_return e -> re (E_internal_return (s_exp e)) | E_throw e -> re (E_throw (s_exp e)) @@ -617,7 +617,7 @@ let remove_bound env pat = let lit_match = function | (L_zero | L_false), (L_zero | L_false) -> true | (L_one | L_true ), (L_one | L_true ) -> true - | L_num i1, L_num i2 -> eq_big_int i1 i2 + | L_num i1, L_num i2 -> Big_int.equal i1 i2 | l1,l2 -> l1 = l2 (* There's no undefined nexp, so replace undefined sizes with a plausible size. @@ -660,8 +660,8 @@ let rec drop_casts = function | exp -> exp let int_of_str_lit = function - | L_hex hex -> big_int_of_string ("0x" ^ hex) - | L_bin bin -> big_int_of_string ("0b" ^ bin) + | L_hex hex -> Big_int.of_string ("0x" ^ hex) + | L_bin bin -> Big_int.of_string ("0b" ^ bin) | _ -> assert false let lit_eq (L_aux (l1,_)) (L_aux (l2,_)) = @@ -670,9 +670,9 @@ let lit_eq (L_aux (l1,_)) (L_aux (l2,_)) = | (L_one |L_true ), (L_one |L_true) -> Some true | (L_hex _| L_bin _), (L_hex _|L_bin _) - -> Some (eq_big_int (int_of_str_lit l1) (int_of_str_lit l2)) + -> Some (Big_int.equal (int_of_str_lit l1) (int_of_str_lit l2)) | L_undef, _ | _, L_undef -> None - | L_num i1, L_num i2 -> Some (eq_big_int i1 i2) + | L_num i1, L_num i2 -> Some (Big_int.equal i1 i2) | _ -> Some (l1 = l2) let try_app (l,ann) (id,args) = @@ -704,12 +704,12 @@ let try_app (l,ann) (id,args) = else if is_id "shl_int" then match args with | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> - Some (E_aux (E_lit (L_aux (L_num (shift_left_big_int i (int_of_big_int j)),new_l)),(l,ann))) + Some (E_aux (E_lit (L_aux (L_num (Big_int.shift_left i (Big_int.to_int j)),new_l)),(l,ann))) | _ -> None else if is_id "mult_int" then match args with | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> - Some (E_aux (E_lit (L_aux (L_num (mult_big_int i j),new_l)),(l,ann))) + Some (E_aux (E_lit (L_aux (L_num (Big_int.mul i j),new_l)),(l,ann))) | _ -> None else if is_id "ex_int" then match args with @@ -720,8 +720,8 @@ let try_app (l,ann) (id,args) = | [E_aux (E_lit L_aux ((L_hex _ | L_bin _) as lit,_),_); E_aux (E_lit L_aux (L_num i,_),_)] -> let v = int_of_str_lit lit in - let b = and_big_int (shift_right_big_int v (int_of_big_int i)) unit_big_int in - let lit' = if eq_big_int b unit_big_int then L_one else L_zero in + let b = Big_int.bitwise_and (Big_int.shift_right v (Big_int.to_int i)) (Big_int.of_int 1) in + let lit' = if Big_int.equal b (Big_int.of_int 1) then L_one else L_zero in Some (E_aux (E_lit (L_aux (lit',new_l)),(l,ann))) | _ -> None else None @@ -1040,7 +1040,7 @@ let split_defs splits defs = | E_comment_struc e -> re (E_comment_struc e) assigns | E_app_infix _ - | E_internal_let _ + | E_var _ | E_internal_plet _ | E_internal_return _ -> raise (Reporting_basic.err_unreachable l @@ -1231,14 +1231,14 @@ let split_defs splits defs = | Typ_app (Id_aux (Id "vector",_), [_;Typ_arg_aux (Typ_arg_nexp len,_);_;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> (match len with | Nexp_aux (Nexp_constant sz,_) -> - if int_of_big_int sz <= vector_split_limit then - let lits = make_vectors (int_of_big_int sz) in + if Big_int.to_int sz <= vector_split_limit then + let lits = make_vectors (Big_int.to_int sz) in List.map (fun lit -> P_aux (P_lit lit,(l,annot)), [var,E_aux (E_lit lit,(new_l,annot))]) lits else raise (Reporting_basic.err_general l - ("Refusing to split vector type of length " ^ string_of_big_int sz ^ + ("Refusing to split vector type of length " ^ Big_int.to_string sz ^ " above limit " ^ string_of_int vector_split_limit ^ " for variable " ^ v)) | _ -> @@ -1458,7 +1458,7 @@ let split_defs splits defs = | E_assert (e1,e2) -> re (E_assert (map_exp e1,map_exp e2)) | E_internal_cast (ann,e) -> re (E_internal_cast (ann,map_exp e)) | E_comment_struc e -> re (E_comment_struc e) - | E_internal_let (le,e1,e2) -> re (E_internal_let (map_lexp le, map_exp e1, map_exp e2)) + | E_var (le,e1,e2) -> re (E_var (map_lexp le, map_exp e1, map_exp e2)) | E_internal_plet (p,e1,e2) -> re (E_internal_plet (check_single_pat p, map_exp e1, map_exp e2)) | E_internal_return e -> re (E_internal_return (map_exp e)) and map_opt_default ((Def_val_aux (ed,annot)) as eda) = @@ -2226,7 +2226,7 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = -> raise (Reporting_basic.err_unreachable l ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp)) - | E_internal_let (lexp,e1,e2) -> + | E_var (lexp,e1,e2) -> (* Really we ought to remove the assignment after e2 *) let d1,assigns,r1 = analyse_exp fn_id env assigns e1 in let assigns,r' = analyse_lexp fn_id env assigns d1 lexp in diff --git a/src/myocamlbuild.ml b/src/myocamlbuild.ml index a437e7e6..ae58f7b2 100644 --- a/src/myocamlbuild.ml +++ b/src/myocamlbuild.ml @@ -69,8 +69,6 @@ let split ch s = let lem_dir = try Sys.getenv "LEM_DIR" (* LEM_DIR must contain an absolute path *) with Not_found -> "../../../lem" ;; -let lem_libdir = lem_dir / "ocaml-lib" ;; -let lem_lib = lem_libdir / "extract" ;; let lem = lem_dir / "lem" ;; (* All -wl ignores should be removed if you want to see the pattern compilation, exhaustive, and unused var warnings *) @@ -80,14 +78,13 @@ let lem_opts = [A "-lib"; P "../lem_interp"; A "-wl_pat_fail"; P "ign"; A "-wl_unused_vars"; P "ign"; (* A "-suppress_renaming";*) -] ;; + ] ;; dispatch begin function | After_rules -> (* ocaml_lib "lem_interp/interp"; *) - ocaml_lib ~extern:true ~dir:lem_libdir ~tag_name:"use_lem" lem_lib; ocaml_lib ~extern:false ~dir:"pprint/src" ~tag_name:"use_pprint" "pprint/src/PPrintLib"; - + rule "lem -> ml" ~prod: "%.ml" ~dep: "%.lem" @@ -109,11 +106,5 @@ dispatch begin function mv (basename (env "%.lem")) (dirname (env "%.lem")) ]); - rule "old parser" - ~insert:(`top) - ~prods: ["parser.ml"; "parser.mli"] - ~dep: "parser.mly" - (fun env builder -> Cmd(S[V"OCAMLYACC"; T(tags_of_pathname "parser.mly"++"ocaml"++"parser"++"ocamlyacc"); Px "parser.mly"])); - | _ -> () end ;; diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index ac6f6ef3..55695114 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -53,6 +53,8 @@ open Ast_util open PPrint open Type_check +module Big_int = Nat_big_num + (* Option to turn tracing features on or off *) let opt_trace_ocaml = ref false @@ -144,6 +146,7 @@ let ocaml_typ_id ctx = function | id when Id.compare id (mk_id "real") = 0 -> string "Num.num" | id when Id.compare id (mk_id "exception") = 0 -> string "exn" | id when Id.compare id (mk_id "register") = 0 -> string "ref" + | id when Id.compare id (mk_id "ref") = 0 -> string "ref" | id -> zencode ctx id let rec ocaml_typ ctx (Typ_aux (typ_aux, _)) = @@ -179,7 +182,7 @@ let ocaml_lit (L_aux (lit_aux, _)) = | L_one -> string "B1" | L_true -> string "true" | L_false -> string "false" - | L_num n -> parens (string "big_int_of_string" ^^ space ^^ string ("\"" ^ Big_int.string_of_big_int n ^ "\"")) + | L_num n -> parens (string "big_int_of_string" ^^ space ^^ string ("\"" ^ Big_int.to_string n ^ "\"")) | L_undef -> failwith "undefined should have been re-written prior to ocaml backend" | L_string str -> string_lit str | L_real str -> parens (string "real_of_string" ^^ space ^^ dquotes (string (String.escaped str))) @@ -252,7 +255,7 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = | E_let (lb, exp) -> separate space [string "let"; ocaml_letbind ctx lb; string "in"] ^/^ ocaml_exp ctx exp - | E_internal_let (lexp, exp1, exp2) -> + | E_var (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 (Rewrites.simple_typ (typ_of exp1))); string "in"] ^/^ ocaml_exp ctx exp2 @@ -276,18 +279,20 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = (string "let rec loop () =" ^//^ loop_body) ^/^ string "in" ^/^ string "loop ()" - | E_lit _ | E_list _ | E_id _ | E_tuple _ -> ocaml_atomic_exp ctx exp + | E_lit _ | E_list _ | E_id _ | E_tuple _ | E_ref _ -> ocaml_atomic_exp ctx exp | E_for (id, exp_from, exp_to, exp_step, ord, exp_body) -> let loop_var = separate space [string "let"; zencode ctx id; equals; string "ref"; ocaml_atomic_exp ctx exp_from; string "in"] in let loop_mod = match ord with | Ord_aux (Ord_inc, _) -> string "add_big_int" ^^ space ^^ zencode ctx id ^^ space ^^ ocaml_atomic_exp ctx exp_step | Ord_aux (Ord_dec, _) -> string "sub_big_int" ^^ space ^^ zencode ctx id ^^ space ^^ ocaml_atomic_exp ctx exp_step + | Ord_aux (Ord_var _, _) -> failwith "Cannot have variable loop order!" in let loop_compare = match ord with | Ord_aux (Ord_inc, _) -> string "le_big_int" | Ord_aux (Ord_dec, _) -> string "gt_big_int" + | Ord_aux (Ord_var _, _) -> failwith "Cannot have variable loop order!" in let loop_body = separate space [string "if"; loop_compare; zencode ctx id; ocaml_atomic_exp ctx exp_to] @@ -322,6 +327,7 @@ and ocaml_fexp ctx (FE_aux (FE_Fexp (id, exp), _)) = and ocaml_atomic_exp ctx (E_aux (exp_aux, _) as exp) = match exp_aux with | E_lit lit -> ocaml_lit lit + | E_ref id -> zencode ctx id | E_id id -> begin match Env.lookup_id id (env_of exp) with @@ -358,10 +364,13 @@ and ocaml_assignment ctx (LEXP_aux (lexp_aux, _) as lexp) exp = separate space [zencode ctx id; string ":="; traced_exp] | _ -> separate space [zencode ctx id; string ":="; ocaml_exp ctx exp] end + | LEXP_deref ref_exp -> + separate space [ocaml_atomic_exp ctx ref_exp; string ":="; ocaml_exp ctx exp] | _ -> string ("LEXP<" ^ string_of_lexp lexp ^ ">") and ocaml_lexp ctx (LEXP_aux (lexp_aux, _) as lexp) = match lexp_aux with | LEXP_cast _ | LEXP_id _ -> ocaml_atomic_lexp ctx lexp + | LEXP_deref exp -> ocaml_exp ctx exp | _ -> string ("LEXP<" ^ string_of_lexp lexp ^ ">") and ocaml_atomic_lexp ctx (LEXP_aux (lexp_aux, _) as lexp) = match lexp_aux with @@ -440,7 +449,11 @@ let ocaml_funcls ctx = function | [] -> failwith "Ocaml: empty function" | [FCL_aux (FCL_Funcl (id, pexp),_)] -> - let Typ_aux (Typ_fn (typ1, typ2, _), _) = Bindings.find id ctx.val_specs in + let typ1, typ2 = + match Bindings.find id ctx.val_specs with + | Typ_aux (Typ_fn (typ1, typ2, _), _) -> (typ1, typ2) + | _ -> failwith "Found val spec which was not a function!" + in let pat_sym = gensym () in let pat, exp = match pexp with @@ -464,7 +477,11 @@ let ocaml_funcls ctx = ocaml_funcl call string_of_arg string_of_ret | funcls -> let id = funcls_id funcls in - let Typ_aux (Typ_fn (typ1, typ2, _), _) = Bindings.find id ctx.val_specs in + let typ1, typ2 = + match Bindings.find id ctx.val_specs with + | Typ_aux (Typ_fn (typ1, typ2, _), _) -> (typ1, typ2) + | _ -> failwith "Found val spec which was not a function!" + in let pat_sym = gensym () in let call_header = function_header () in let arg_sym, string_of_arg, ret_sym, string_of_ret = trace_info typ1 typ2 in @@ -538,6 +555,9 @@ let ocaml_string_of_abbrev ctx id typq typ = separate space [string "let"; ocaml_string_of id; parens (arg ^^ space ^^ colon ^^ space ^^ zencode ctx id); equals] ^//^ ocaml_string_typ typ arg +let ocaml_string_of_variant ctx id typq cases = + separate space [string "let"; ocaml_string_of id; string "_"; equals; string "\"VARIANT\""] + let ocaml_typedef ctx (TD_aux (td_aux, _)) = match td_aux with | TD_record (id, _, typq, fields, _) -> @@ -549,8 +569,10 @@ let ocaml_typedef ctx (TD_aux (td_aux, _)) = | TD_variant (id, _, _, cases, _) when string_of_id id = "exception" -> ocaml_exceptions ctx cases | TD_variant (id, _, typq, cases, _) -> - separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals] - ^//^ ocaml_cases ctx cases + (separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals] + ^//^ ocaml_cases ctx cases) + ^^ ocaml_def_end + ^^ ocaml_string_of_variant ctx id typq cases | TD_enum (id, _, ids, _) -> (separate space [string "type"; zencode ctx id; equals] ^//^ (bar ^^ space ^^ ocaml_enum ctx ids)) @@ -597,7 +619,7 @@ let val_spec_typs (Defs defs) = | _ :: defs -> vs_typs defs | [] -> [] in - vs_typs defs; + ignore (vs_typs defs); !typs let ocaml_defs (Defs defs) = @@ -625,7 +647,7 @@ let ocaml_main spec = ^//^ (string "Random.self_init ();" ^/^ string "load_elf ();" ^/^ string (if !opt_trace_ocaml then "Sail_lib.opt_trace := true;" else "Sail_lib.opt_trace := false;") - ^/^ string "initialize_registers ();" + ^/^ string "zinitializze_registers ();" ^/^ string "Printexc.record_backtrace true;" ^/^ string "zmain ()") ] diff --git a/src/parse_ast.ml b/src/parse_ast.ml index b684725f..362333f3 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -50,7 +50,7 @@ (* generated by Ott 0.25 from: l2_parse.ott *) -open Big_int +module Big_int = Nat_big_num type text = string @@ -139,7 +139,7 @@ type atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders, and effects after parsing *) ATyp_id of id (* identifier *) | ATyp_var of kid (* ticked variable *) - | ATyp_constant of big_int (* constant *) + | ATyp_constant of Big_int.num (* constant *) | ATyp_times of atyp * atyp (* product *) | ATyp_sum of atyp * atyp (* sum *) | ATyp_minus of atyp * atyp (* subtraction *) @@ -170,7 +170,7 @@ n_constraint_aux = (* constraint over kind $_$ *) | NC_bounded_ge of atyp * atyp | NC_bounded_le of atyp * atyp | NC_not_equal of atyp * atyp - | NC_set of kid * (big_int) list + | NC_set of kid * (Big_int.num) list | NC_or of n_constraint * n_constraint | NC_and of n_constraint * n_constraint | NC_true @@ -213,7 +213,7 @@ lit_aux = (* Literal constant *) | L_one (* $_ : _$ *) | L_true (* $_ : _$ *) | L_false (* $_ : _$ *) - | L_num of big_int (* natural number constant *) + | L_num of Big_int.num (* natural number constant *) | L_hex of string (* bit vector constant, C-style *) | L_bin of string (* bit vector constant, C-style *) | L_undef (* undefined value *) @@ -267,6 +267,8 @@ exp_aux = (* Expression *) E_block of (exp) list (* block (parsing conflict with structs?) *) | E_nondet of (exp) list (* block that can evaluate the contained expressions in any ordering *) | E_id of id (* identifier *) + | E_ref of id + | E_deref of exp | E_lit of lit (* literal constant *) | E_cast of atyp * exp (* cast *) | E_app of id * (exp) list (* function application *) @@ -296,7 +298,7 @@ exp_aux = (* Expression *) | E_try of exp * pexp list | E_return of exp | E_assert of exp * exp - | E_internal_let of exp * exp * exp + | E_var of exp * exp * exp and exp = E_aux of exp_aux * l @@ -396,8 +398,8 @@ type_union = type index_range_aux = (* index specification, for bitfields in register types *) - BF_single of big_int (* single index *) - | BF_range of big_int * big_int (* index range *) + BF_single of Big_int.num (* single index *) + | BF_range of Big_int.num * Big_int.num (* index range *) | BF_concat of index_range * index_range (* concatenation of index ranges *) and index_range = @@ -427,8 +429,7 @@ type_def_aux = (* Type definition body *) | TD_record of id * name_scm_opt * typquant * ((atyp * id)) list * bool (* struct type definition *) | TD_variant of id * name_scm_opt * typquant * (type_union) list * bool (* union type definition *) | TD_enum of id * name_scm_opt * (id) list * bool (* enumeration type definition *) - | TD_register of id * atyp * atyp * ((index_range * id)) list (* register mutable bitfield type definition *) - + | TD_bitfield of id * atyp * (id * index_range) list (* register mutable bitfield type definition *) type val_spec_aux = (* Value type specification *) @@ -492,7 +493,7 @@ scattered_def = type prec = Infix | InfixL | InfixR -type fixity_token = (prec * big_int * string) +type fixity_token = (prec * Big_int.num * string) type def = (* Top-level definition *) @@ -501,7 +502,7 @@ def = (* Top-level definition *) | DEF_fundef of fundef (* function definition *) | DEF_val of letbind (* value definition *) | DEF_overload of id * id list (* operator overload specifications *) - | DEF_fixity of prec * big_int * id (* fixity declaration *) + | DEF_fixity of prec * Big_int.num * id (* fixity declaration *) | DEF_spec of val_spec (* top-level type constraint *) | DEF_default of default_typing_spec (* default kind and type assumptions *) | DEF_scattered of scattered_def (* scattered definition *) diff --git a/src/parser.mly b/src/parser.mly index 5e4a2cad..7af70687 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -52,314 +52,561 @@ let r = fun x -> x (* Ulib.Text.of_latin1 *) -open Big_int +module Big_int = Nat_big_num open Parse_ast -let loc () = Range(Parsing.symbol_start_pos(),Parsing.symbol_end_pos()) -let locn m n = Range(Parsing.rhs_start_pos m,Parsing.rhs_end_pos n) +let loc n m = Range (n, m) -let id_of_kid = function - | Kid_aux (Var v, l) -> Id_aux (Id (String.sub v 1 (String.length v - 1)), l) +let default_opt x = function + | None -> x + | Some y -> y -let idl i = Id_aux(i, loc()) +let assoc_opt key assocs = + try Some (List.assoc key assocs) with + | Not_found -> None let string_of_id = function | Id_aux (Id str, _) -> str | Id_aux (DeIid str, _) -> str -let efl e = BE_aux(e, loc()) - -let ploc p = P_aux(p,loc ()) -let eloc e = E_aux(e,loc ()) -let peloc pe = Pat_aux(pe,loc ()) -let lbloc lb = LB_aux(lb,loc ()) - -let bkloc k = BK_aux(k,loc ()) -let kloc k = K_aux(k,loc ()) -let kiloc ki = KOpt_aux(ki,loc ()) -let tloc t = ATyp_aux(t,loc ()) -let tlocl t l1 l2 = ATyp_aux(t,locn l1 l2) -let lloc l = L_aux(l,loc ()) -let ploc p = P_aux(p,loc ()) -let fploc p = FP_aux(p,loc ()) - -let funclloc f = FCL_aux(f,loc ()) -let typql t = TypQ_aux(t, loc()) -let irloc r = BF_aux(r, loc()) -let defloc df = DT_aux(df, loc()) - -let tdloc td = TD_aux(td, loc()) -let kdloc kd = KD_aux(kd, loc()) -let funloc fn = FD_aux(fn, loc()) -let vloc v = VS_aux(v, loc ()) -let sdloc sd = SD_aux(sd, loc ()) -let dloc d = d - -let mk_typschm tq t s e = TypSchm_aux((TypSchm_ts(tq,t)),(locn s e)) -let mk_rec i = (Rec_aux((Rec_rec), locn i i)) -let mk_recn _ = (Rec_aux((Rec_nonrec), Unknown)) -let mk_typqn _ = (TypQ_aux(TypQ_no_forall,Unknown)) -let mk_tannot tq t s e = Typ_annot_opt_aux(Typ_annot_opt_some(tq,t),(locn s e)) -let mk_tannotn _ = Typ_annot_opt_aux(Typ_annot_opt_none,Unknown) -let mk_eannot e i = Effect_opt_aux((Effect_opt_effect(e)),(locn i i)) -let mk_eannotn _ = Effect_opt_aux(Effect_opt_pure,Unknown) -let mk_namesectn _ = Name_sect_aux(Name_sect_none,Unknown) - -let make_range_sugar_bounded typ1 typ2 = - ATyp_app(Id_aux(Id("range"),Unknown),[typ1; typ2;]) -let make_range_sugar typ1 = - make_range_sugar_bounded (ATyp_aux(ATyp_constant(zero_big_int), Unknown)) typ1 -let make_atom_sugar typ1 = - ATyp_app(Id_aux(Id("atom"),Unknown),[typ1]) - -let make_r bot top = - match bot,top with - | ATyp_aux(ATyp_constant b,_),ATyp_aux(ATyp_constant t,l) -> - ATyp_aux(ATyp_constant (add_big_int (sub_big_int t b) unit_big_int),l) - | bot,(ATyp_aux(_,l) as top) -> - ATyp_aux((ATyp_sum ((ATyp_aux (ATyp_sum (top, ATyp_aux(ATyp_constant unit_big_int,Unknown)), Unknown)), - (ATyp_aux ((ATyp_neg bot),Unknown)))), l) - -let make_vector_sugar_bounded order_set is_inc name typ typ1 typ2 = - let (rise,ord,name) = - if order_set - then if is_inc - then (make_r typ1 typ2,ATyp_inc,name) - else (make_r typ2 typ1,ATyp_dec,name) - else if name = "vector" - then (typ2, ATyp_default_ord,"vector_sugar_tb") (* rise not calculated, but top and bottom came from specification *) - else (typ2, ATyp_default_ord,"vector_sugar_r") (* rise and base not calculated, rise only from specification *) in - ATyp_app(Id_aux(Id(name),Unknown),[typ1;rise;ATyp_aux(ord,Unknown);typ]) -let make_vector_sugar order_set is_inc typ typ1 = - let zero = (ATyp_aux(ATyp_constant zero_big_int,Unknown)) in - let (typ1,typ2) = match (order_set,is_inc,typ1) with - | (true,true,ATyp_aux(ATyp_constant t,l)) -> zero,ATyp_aux(ATyp_constant (sub_big_int t unit_big_int),l) - | (true,true,ATyp_aux(_, l)) -> zero,ATyp_aux (ATyp_sum (typ1, - ATyp_aux(ATyp_neg(ATyp_aux(ATyp_constant unit_big_int,Unknown)), Unknown)), l) - | (true,false,_) -> typ1,zero - | (false,_,_) -> zero,typ1 in - make_vector_sugar_bounded order_set is_inc "vector_sugar_r" typ typ1 typ2 +let prepend_id str1 = function + | Id_aux (Id str2, loc) -> Id_aux (Id (str1 ^ str2), loc) + | _ -> assert false + +let mk_id i n m = Id_aux (i, loc n m) +let mk_kid str n m = Kid_aux (Var str, loc n m) + +let id_of_kid = function + | Kid_aux (Var v, l) -> Id_aux (Id (String.sub v 1 (String.length v - 1)), l) + +let deinfix = function + | (Id_aux (Id v, l)) -> Id_aux (DeIid v, l) + | (Id_aux (DeIid v, l)) -> Id_aux (Id v, l) + +let mk_effect e n m = BE_aux (e, loc n m) +let mk_typ t n m = ATyp_aux (t, loc n m) +let mk_pat p n m = P_aux (p, loc n m) +let mk_pexp p n m = Pat_aux (p, loc n m) +let mk_exp e n m = E_aux (e, loc n m) +let mk_lit l n m = L_aux (l, loc n m) +let mk_lit_exp l n m = mk_exp (E_lit (mk_lit l n m)) n m +let mk_typschm tq t n m = TypSchm_aux (TypSchm_ts (tq, t), loc n m) +let mk_nc nc n m = NC_aux (nc, loc n m) +let mk_sd s n m = SD_aux (s, loc n m) +let mk_ir r n m = BF_aux (r, loc n m) + +let mk_funcl f n m = FCL_aux (f, loc n m) +let mk_fun fn n m = FD_aux (fn, loc n m) +let mk_td t n m = TD_aux (t, loc n m) +let mk_vs v n m = VS_aux (v, loc n m) +let mk_reg_dec d n m = DEC_aux (d, loc n m) +let mk_default d n m = DT_aux (d, loc n m) + +let qi_id_of_kopt (KOpt_aux (kopt_aux, l) as kopt) = QI_aux (QI_id kopt, l) + +let mk_recn = (Rec_aux((Rec_nonrec), Unknown)) +let mk_typqn = (TypQ_aux(TypQ_no_forall,Unknown)) +let mk_tannotn = Typ_annot_opt_aux(Typ_annot_opt_none,Unknown) +let mk_eannotn = Effect_opt_aux(Effect_opt_pure,Unknown) +let mk_namesectn = Name_sect_aux(Name_sect_none,Unknown) + +type lchain = + LC_lt +| LC_lteq +| LC_nexp of atyp + +let rec desugar_lchain chain s e = + match chain with + | [LC_nexp n1; LC_lteq; LC_nexp n2] -> + mk_nc (NC_bounded_le (n1, n2)) s e + | [LC_nexp n1; LC_lt; LC_nexp n2] -> + mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e, n2)) s e + | (LC_nexp n1 :: LC_lteq :: LC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_le (n1, n2)) s e in + mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e + | (LC_nexp n1 :: LC_lt :: LC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e, n2)) s e in + mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e + | _ -> assert false + +type rchain = + RC_gt +| RC_gteq +| RC_nexp of atyp + +let rec desugar_rchain chain s e = + match chain with + | [RC_nexp n1; RC_gteq; RC_nexp n2] -> + mk_nc (NC_bounded_ge (n1, n2)) s e + | [RC_nexp n1; RC_gt; RC_nexp n2] -> + mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e)) s e + | (RC_nexp n1 :: RC_gteq :: RC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_ge (n1, n2)) s e in + mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e + | (RC_nexp n1 :: RC_gt :: RC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant (Big_int.of_int 1)) s e)) s e)) s e in + mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e + | _ -> assert false %} /*Terminals with no content*/ -%token And Alias As Assert Bitzero Bitone Bits By Case Clause Const Dec Def Default Deinfix Effect EFFECT End -%token Enumerate Else Exit Extern False Forall Exist Foreach Overload Function_ If_ In IN Inc Let_ Member Nat NatNum Order Cast -%token Pure Rec Register Return Scattered Sizeof Struct Switch Then True TwoStarStar Type TYPE Typedef -%token Undefined Union With When Val Constraint Try Catch Throw +%token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op +%token Enum Else False Forall Foreach Overload Function_ If_ In Inc Let_ Int Order Cast +%token Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef +%token Undefined Union Newtype With Val Constraint Throw Try Catch Exit Bitfield %token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape -%token While Do Repeat Until +%token Repeat Until While Do Record Mutual Var Ref - -/* Avoid shift/reduce conflict - see right_atomic_exp rule */ %nonassoc Then %nonassoc Else -%token Div_ Mod ModUnderS Quot Rem QuotUnderS - -%token Bar Comma Dot Eof Minus Semi Under -%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare -%token BarBar BarSquare BarBarSquare ColonEq ColonGt ColonSquare DotDot -%token MinusGt LtBar LtColon SquareBar SquareBarBar SquareColon +%token Bar Comma Dot Eof Minus Semi Under DotDot +%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar LsquareBar RsquareBar +%token MinusGt /*Terminals with content*/ -%token <string> Id TyVar TyId -%token <Big_int.big_int> Num +%token <string> Id TyVar +%token <Nat_big_num.num> Num %token <string> String Bin Hex Real -%token <string> Amp At Carrot Div Eq Excl Gt Lt Plus Star Tilde -%token <string> AmpAmp CarrotCarrot Colon ColonColon EqEq ExclEq ExclExcl -%token <string> GtEq GtEqPlus GtGt GtGtGt GtPlus HashGtGt HashLtLt -%token <string> LtEq LtEqPlus LtGt LtLt LtLtLt LtPlus StarStar TildeCarrot - -%token <string> GtEqUnderS GtEqUnderSi GtEqUnderU GtEqUnderUi GtGtUnderU GtUnderS -%token <string> GtUnderSi GtUnderU GtUnderUi LtEqUnderS LtEqUnderSi LtEqUnderU -%token <string> LtEqUnderUi LtUnderS LtUnderSi LtUnderU LtUnderUi StarStarUnderS StarStarUnderSi StarUnderS -%token <string> StarUnderSi StarUnderU StarUnderUi TwoCarrot PlusUnderS MinusUnderS - -%token <string> AmpI AtI CarrotI DivI EqI ExclI GtI LtI PlusI StarI TildeI -%token <string> AmpAmpI CarrotCarrotI ColonColonI EqEqI ExclEqI ExclExclI -%token <string> GtEqI GtEqPlusI GtGtI GtGtGtI GtPlusI HashGtGtI HashLtLtI -%token <string> LtEqI LtEqPlusI LtGtI LtLtI LtLtLtI LtPlusI StarStarI TildeCarrotI - -%token <string> GtEqUnderSI GtEqUnderSiI GtEqUnderUI GtEqUnderUiI GtGtUnderUI GtUnderSI -%token <string> GtUnderSiI GtUnderUI GtUnderUiI LtEqUnderSI LtEqUnderSiI LtEqUnderUI -%token <string> LtEqUnderUiI LtUnderSI LtUnderSiI LtUnderUI LtUnderUiI StarStarUnderSI StarStarUnderSiI StarUnderSI -%token <string> StarUnderSiI StarUnderUI StarUnderUiI TwoCarrotI - - -%start file nonempty_exp_list -%type <Parse_ast.defs> defs -%type <Parse_ast.atyp> typ -%type <Parse_ast.pat> pat -%type <Parse_ast.exp> exp -%type <Parse_ast.exp list> nonempty_exp_list -%type <Parse_ast.defs> file +%token <string> Amp At Caret Eq Gt Lt Plus Star EqGt Unit +%token <string> Colon ExclEq +%token <string> GtEq +%token <string> LtEq + +%token <string> Op0 Op1 Op2 Op3 Op4 Op5 Op6 Op7 Op8 Op9 +%token <string> Op0l Op1l Op2l Op3l Op4l Op5l Op6l Op7l Op8l Op9l +%token <string> Op0r Op1r Op2r Op3r Op4r Op5r Op6r Op7r Op8r Op9r +%token <Parse_ast.fixity_token> Fixity + +%start file +%start typschm_eof +%start exp_eof +%start def_eof +%type <Parse_ast.typschm> typschm_eof +%type <Parse_ast.exp> exp_eof +%type <Parse_ast.def> def_eof +%type <Parse_ast.defs> file %% id: - | Id - { idl (Id($1)) } - | Tilde - { idl (Id($1)) } - | Lparen Deinfix Amp Rparen - { idl (DeIid($3)) } - | Lparen Deinfix At Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Carrot Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Div Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Quot Rparen - { idl (DeIid("quot")) } - | Lparen Deinfix QuotUnderS Rparen - { idl (DeIid("quot_s")) } - | Lparen Deinfix Eq Rparen - { Id_aux(DeIid($3),loc ()) } - | Lparen Deinfix Excl Lparen - { idl (DeIid($3)) } - | Lparen Deinfix Gt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Lt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtUnderS Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtUnderS Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Minus Rparen - { idl (DeIid("-")) } - | Lparen Deinfix MinusUnderS Rparen - { idl (DeIid("-_s")) } - | Lparen Deinfix Mod Rparen - { idl (DeIid("mod")) } - | Lparen Deinfix Plus Rparen - { idl (DeIid($3)) } - | Lparen Deinfix PlusUnderS Rparen - { idl (DeIid("+_s")) } - | Lparen Deinfix Star Rparen - { idl (DeIid($3)) } - | Lparen Deinfix StarUnderS Rparen - { idl (DeIid("*_s")) } - | Lparen Deinfix AmpAmp Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Bar Rparen - { idl (DeIid("|")) } - | Lparen Deinfix BarBar Rparen - { idl (DeIid("||")) } - | Lparen Deinfix CarrotCarrot Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Colon Rparen - { idl (DeIid($3)) } - | Lparen Deinfix ColonColon Rparen - { idl (DeIid($3)) } - | Lparen Deinfix EqEq Rparen - { idl (DeIid($3)) } - | Lparen Deinfix ExclEq Rparen - { idl (DeIid($3)) } - | Lparen Deinfix ExclExcl Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtEq Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtEqUnderS Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtEqPlus Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtGt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtGtGt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix GtPlus Rparen - { idl (DeIid($3)) } - | Lparen Deinfix HashGtGt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix HashLtLt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtEq Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtEqUnderS Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtLt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtLtLt Rparen - { idl (DeIid($3)) } - | Lparen Deinfix LtPlus Rparen - { idl (DeIid($3)) } - | Lparen Deinfix StarStar Rparen - { idl (DeIid($3)) } - | Lparen Deinfix Tilde Rparen - { idl (DeIid($3)) } - | Lparen Deinfix TildeCarrot Rparen - { idl (DeIid($3)) } - -tid: - | TyId - { (idl (Id($1))) } - -tyvar: + | Id { mk_id (Id $1) $startpos $endpos } + + | Op Op0 { mk_id (DeIid $2) $startpos $endpos } + | Op Op1 { mk_id (DeIid $2) $startpos $endpos } + | Op Op2 { mk_id (DeIid $2) $startpos $endpos } + | Op Op3 { mk_id (DeIid $2) $startpos $endpos } + | Op Op4 { mk_id (DeIid $2) $startpos $endpos } + | Op Op5 { mk_id (DeIid $2) $startpos $endpos } + | Op Op6 { mk_id (DeIid $2) $startpos $endpos } + | Op Op7 { mk_id (DeIid $2) $startpos $endpos } + | Op Op8 { mk_id (DeIid $2) $startpos $endpos } + | Op Op9 { mk_id (DeIid $2) $startpos $endpos } + + | Op Op0l { mk_id (DeIid $2) $startpos $endpos } + | Op Op1l { mk_id (DeIid $2) $startpos $endpos } + | Op Op2l { mk_id (DeIid $2) $startpos $endpos } + | Op Op3l { mk_id (DeIid $2) $startpos $endpos } + | Op Op4l { mk_id (DeIid $2) $startpos $endpos } + | Op Op5l { mk_id (DeIid $2) $startpos $endpos } + | Op Op6l { mk_id (DeIid $2) $startpos $endpos } + | Op Op7l { mk_id (DeIid $2) $startpos $endpos } + | Op Op8l { mk_id (DeIid $2) $startpos $endpos } + | Op Op9l { mk_id (DeIid $2) $startpos $endpos } + + | Op Op0r { mk_id (DeIid $2) $startpos $endpos } + | Op Op1r { mk_id (DeIid $2) $startpos $endpos } + | Op Op2r { mk_id (DeIid $2) $startpos $endpos } + | Op Op3r { mk_id (DeIid $2) $startpos $endpos } + | Op Op4r { mk_id (DeIid $2) $startpos $endpos } + | Op Op5r { mk_id (DeIid $2) $startpos $endpos } + | Op Op6r { mk_id (DeIid $2) $startpos $endpos } + | Op Op7r { mk_id (DeIid $2) $startpos $endpos } + | Op Op8r { mk_id (DeIid $2) $startpos $endpos } + | Op Op9r { mk_id (DeIid $2) $startpos $endpos } + + | Op Plus { mk_id (DeIid "+") $startpos $endpos } + | Op Minus { mk_id (DeIid "-") $startpos $endpos } + | Op Star { mk_id (DeIid "*") $startpos $endpos } + | Op ExclEq { mk_id (DeIid "!=") $startpos $endpos } + | Op Lt { mk_id (DeIid "<") $startpos $endpos } + | Op Gt { mk_id (DeIid ">") $startpos $endpos } + | Op LtEq { mk_id (DeIid "<=") $startpos $endpos } + | Op GtEq { mk_id (DeIid ">=") $startpos $endpos } + | Op Amp { mk_id (DeIid "&") $startpos $endpos } + | Op Bar { mk_id (DeIid "|") $startpos $endpos } + | Op Caret { mk_id (DeIid "^") $startpos $endpos } + +op0: Op0 { mk_id (Id $1) $startpos $endpos } +op1: Op1 { mk_id (Id $1) $startpos $endpos } +op2: Op2 { mk_id (Id $1) $startpos $endpos } +op3: Op3 { mk_id (Id $1) $startpos $endpos } +op4: Op4 { mk_id (Id $1) $startpos $endpos } +op5: Op5 { mk_id (Id $1) $startpos $endpos } +op6: Op6 { mk_id (Id $1) $startpos $endpos } +op7: Op7 { mk_id (Id $1) $startpos $endpos } +op8: Op8 { mk_id (Id $1) $startpos $endpos } +op9: Op9 { mk_id (Id $1) $startpos $endpos } + +op0l: Op0l { mk_id (Id $1) $startpos $endpos } +op1l: Op1l { mk_id (Id $1) $startpos $endpos } +op2l: Op2l { mk_id (Id $1) $startpos $endpos } +op3l: Op3l { mk_id (Id $1) $startpos $endpos } +op4l: Op4l { mk_id (Id $1) $startpos $endpos } +op5l: Op5l { mk_id (Id $1) $startpos $endpos } +op6l: Op6l { mk_id (Id $1) $startpos $endpos } +op7l: Op7l { mk_id (Id $1) $startpos $endpos } +op8l: Op8l { mk_id (Id $1) $startpos $endpos } +op9l: Op9l { mk_id (Id $1) $startpos $endpos } + +op0r: Op0r { mk_id (Id $1) $startpos $endpos } +op1r: Op1r { mk_id (Id $1) $startpos $endpos } +op2r: Op2r { mk_id (Id $1) $startpos $endpos } +op3r: Op3r { mk_id (Id $1) $startpos $endpos } +op4r: Op4r { mk_id (Id $1) $startpos $endpos } +op5r: Op5r { mk_id (Id $1) $startpos $endpos } +op6r: Op6r { mk_id (Id $1) $startpos $endpos } +op7r: Op7r { mk_id (Id $1) $startpos $endpos } +op8r: Op8r { mk_id (Id $1) $startpos $endpos } +op9r: Op9r { mk_id (Id $1) $startpos $endpos } + +id_list: + | id + { [$1] } + | id Comma id_list + { $1 :: $3 } + +kid: | TyVar - { (Kid_aux((Var($1)),loc ())) } + { mk_kid $1 $startpos $endpos } -tyvars: - | tyvar +kid_list: + | kid { [$1] } - | tyvar tyvars + | kid kid_list { $1 :: $2 } -atomic_kind: +nc: + | nc Bar nc_and + { mk_nc (NC_or ($1, $3)) $startpos $endpos } + | nc_and + { $1 } + +nc_and: + | nc_and Amp atomic_nc + { mk_nc (NC_and ($1, $3)) $startpos $endpos } + | atomic_nc + { $1 } + +atomic_nc: + | True + { mk_nc NC_true $startpos $endpos } + | False + { mk_nc NC_false $startpos $endpos } + | typ Eq typ + { mk_nc (NC_equal ($1, $3)) $startpos $endpos } + | typ ExclEq typ + { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } + | nc_lchain + { desugar_lchain $1 $startpos $endpos } + | nc_rchain + { desugar_rchain $1 $startpos $endpos } + | Lparen nc Rparen + { $2 } + | kid In Lcurly num_list Rcurly + { mk_nc (NC_set ($1, $4)) $startpos $endpos } + +num_list: + | Num + { [$1] } + | Num Comma num_list + { $1 :: $3 } + +nc_lchain: + | typ LtEq typ + { [LC_nexp $1; LC_lteq; LC_nexp $3] } + | typ Lt typ + { [LC_nexp $1; LC_lt; LC_nexp $3] } + | typ LtEq nc_lchain + { LC_nexp $1 :: LC_lteq :: $3 } + | typ Lt nc_lchain + { LC_nexp $1 :: LC_lt :: $3 } + +nc_rchain: + | typ GtEq typ + { [RC_nexp $1; RC_gteq; RC_nexp $3] } + | typ Gt typ + { [RC_nexp $1; RC_gt; RC_nexp $3] } + | typ GtEq nc_rchain + { RC_nexp $1 :: RC_gteq :: $3 } + | typ Gt nc_rchain + { RC_nexp $1 :: RC_gt :: $3 } + +typ: + | typ0 + { $1 } + +/* The following implements all nine levels of user-defined precedence for +operators in types, with both left, right and non-associative operators */ + +typ0: + | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ0l op0l typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 op0r typ0r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 { $1 } +typ0l: + | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ0l op0l typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 { $1 } +typ0r: + | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 op0r typ0r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 { $1 } + +typ1: + | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1l op1l typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 op1r typ1r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 { $1 } +typ1l: + | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1l op1l typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 { $1 } +typ1r: + | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 op1r typ1r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 { $1 } + +typ2: + | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 { $1 } +typ2l: + | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 { $1 } +typ2r: + | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 { $1 } + +typ3: + | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 { $1 } +typ3l: + | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 { $1 } +typ3r: + | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 { $1 } + +typ4: + | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 { $1 } +typ4l: + | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 { $1 } +typ4r: + | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 { $1 } + +typ5: + | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5l op5l typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 op5r typ5r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 { $1 } +typ5l: + | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5l op5l typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 { $1 } +typ5r: + | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 op5r typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 { $1 } + +typ6: + | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l op6l typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7 op6r typ6r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l Plus typ7 { mk_typ (ATyp_sum ($1, $3)) $startpos $endpos } + | typ6l Minus typ7 { mk_typ (ATyp_minus ($1, $3)) $startpos $endpos } + | typ7 { $1 } +typ6l: + | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l op6l typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l Plus typ7 { mk_typ (ATyp_sum ($1, $3)) $startpos $endpos } + | typ6l Minus typ7 { mk_typ (ATyp_minus ($1, $3)) $startpos $endpos } + | typ7 { $1 } +typ6r: + | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7 op6r typ6r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7 { $1 } + +typ7: + | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l op7l typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8 op7r typ7r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l Star typ8 { mk_typ (ATyp_times ($1, $3)) $startpos $endpos } + | typ8 { $1 } +typ7l: + | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l op7l typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l Star typ8 { mk_typ (ATyp_times ($1, $3)) $startpos $endpos } + | typ8 { $1 } +typ7r: + | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8 op7r typ7r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8 { $1 } + +typ8: + | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8l op8l typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9 op8r typ8r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } + | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} + | typ9 { $1 } +typ8l: + | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8l op8l typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } + | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} + | typ9 { $1 } +typ8r: + | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9 op8r typ8r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } + | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} + | typ9 { $1 } + +typ9: + | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ { $1 } +typ9l: + | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ { $1 } +typ9r: + | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ { $1 } + +atomic_typ: + | id + { mk_typ (ATyp_id $1) $startpos $endpos } + | kid + { mk_typ (ATyp_var $1) $startpos $endpos } + | Num + { mk_typ (ATyp_constant $1) $startpos $endpos } + | Dec + { mk_typ ATyp_dec $startpos $endpos } + | Inc + { mk_typ ATyp_inc $startpos $endpos } + | id Lparen typ_list Rparen + { mk_typ (ATyp_app ($1, $3)) $startpos $endpos } + | Register Lparen typ Rparen + { let register_id = mk_id (Id "register") $startpos($1) $endpos($1) in + mk_typ (ATyp_app (register_id, [$3])) $startpos $endpos } + | Ref Lparen typ Rparen + { let ref_id = mk_id (Id "ref") $startpos($1) $endpos($1) in + mk_typ (ATyp_app (ref_id, [$3])) $startpos $endpos } + | Lparen typ Rparen + { $2 } + | Lparen typ Comma typ_list Rparen + { mk_typ (ATyp_tup ($2 :: $4)) $startpos $endpos } + | LcurlyBar num_list RcurlyBar + { let v = mk_kid "n" $startpos $endpos in + let atom_id = mk_id (Id "atom") $startpos $endpos in + let atom_of_v = mk_typ (ATyp_app (atom_id, [mk_typ (ATyp_var v) $startpos $endpos])) $startpos $endpos in + mk_typ (ATyp_exist ([v], NC_aux (NC_set (v, $2), loc $startpos($2) $endpos($2)), atom_of_v)) $startpos $endpos } + | Lcurly kid_list Dot typ Rcurly + { mk_typ (ATyp_exist ($2, NC_aux (NC_true, loc $startpos $endpos), $4)) $startpos $endpos } + | Lcurly kid_list Comma nc Dot typ Rcurly + { mk_typ (ATyp_exist ($2, $4, $6)) $startpos $endpos } + +typ_list: + | typ + { [$1] } + | typ Comma typ_list + { $1 :: $3 } + +base_kind: + | Int + { BK_aux (BK_nat, loc $startpos $endpos) } | TYPE - { bkloc BK_type } - | Nat - { bkloc BK_nat } - | NatNum - { bkloc BK_nat } + { BK_aux (BK_type, loc $startpos $endpos) } | Order - { bkloc BK_order } - -kind_help: - | atomic_kind - { [ $1 ] } - | atomic_kind MinusGt kind_help - { $1::$3 } + { BK_aux (BK_order, loc $startpos $endpos) } kind: - | kind_help - { K_aux(K_kind($1), loc ()) } + | base_kind + { K_aux (K_kind [$1], loc $startpos $endpos) } + +kopt: + | Lparen kid Colon kind Rparen + { KOpt_aux (KOpt_kind ($4, $2), loc $startpos $endpos) } + | kid + { KOpt_aux (KOpt_none $1, loc $startpos $endpos) } + +kopt_list: + | kopt + { [$1] } + | kopt kopt_list + { $1 :: $2 } + +typquant: + | kopt_list Comma nc + { let qi_nc = QI_aux (QI_const $3, loc $startpos($3) $endpos($3)) in + TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1 @ [qi_nc]), loc $startpos $endpos) } + | kopt_list + { TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1), loc $startpos $endpos) } effect: | Barr - { efl BE_barr } + { mk_effect BE_barr $startpos $endpos } | Depend - { efl BE_depend } - | Rreg - { efl BE_rreg } + { mk_effect BE_depend $startpos $endpos } + | Rreg + { mk_effect BE_rreg $startpos $endpos } | Wreg - { efl BE_wreg } + { mk_effect BE_wreg $startpos $endpos } | Rmem - { efl BE_rmem } + { mk_effect BE_rmem $startpos $endpos } | Rmemt - { efl BE_rmemt } + { mk_effect BE_rmemt $startpos $endpos } | Wmem - { efl BE_wmem } + { mk_effect BE_wmem $startpos $endpos } | Wmv - { efl BE_wmv } + { mk_effect BE_wmv $startpos $endpos } | Wmvt - { efl BE_wmvt } + { mk_effect BE_wmvt $startpos $endpos } | Eamem - { efl BE_eamem } + { mk_effect BE_eamem $startpos $endpos } | Exmem - { efl BE_exmem } + { mk_effect BE_exmem $startpos $endpos } | Undef - { efl BE_undef } + { mk_effect BE_undef $startpos $endpos } | Unspec - { efl BE_unspec } + { mk_effect BE_unspec $startpos $endpos } | Nondet - { efl BE_nondet } + { mk_effect BE_nondet $startpos $endpos } | Escape - { efl BE_escape } + { mk_effect BE_escape $startpos $endpos } effect_list: | effect @@ -367,994 +614,620 @@ effect_list: | effect Comma effect_list { $1::$3 } -effect_typ: +effect_set: | Lcurly effect_list Rcurly - { tloc (ATyp_set($2)) } + { mk_typ (ATyp_set $2) $startpos $endpos } | Pure - { tloc (ATyp_set([])) } - -vec_typ: - | tid Lsquare nexp_typ Rsquare - { tloc (make_vector_sugar false false (ATyp_aux ((ATyp_id $1), locn 1 1)) $3) } - | tid Lsquare nexp_typ Colon nexp_typ Rsquare - { tloc (make_vector_sugar_bounded false false "vector" (ATyp_aux ((ATyp_id $1), locn 1 1)) $3 $5) } - | tid Lsquare nexp_typ LtColon nexp_typ Rsquare - { tloc (make_vector_sugar_bounded true true "vector" (ATyp_aux ((ATyp_id $1), locn 1 1)) $3 $5) } - | tid Lsquare nexp_typ ColonGt nexp_typ Rsquare - { tloc (make_vector_sugar_bounded true false "vector" (ATyp_aux ((ATyp_id $1), locn 1 1)) $3 $5) } - | tyvar Lsquare nexp_typ Rsquare - { tloc (make_vector_sugar false false (ATyp_aux ((ATyp_var $1), locn 1 1)) $3) } - | tyvar Lsquare nexp_typ Colon nexp_typ Rsquare - { tloc (make_vector_sugar_bounded false false "vector" (ATyp_aux ((ATyp_var $1), locn 1 1)) $3 $5) } - | tyvar Lsquare nexp_typ LtColon nexp_typ Rsquare - { tloc (make_vector_sugar_bounded true true "vector" (ATyp_aux ((ATyp_var $1), locn 1 1)) $3 $5) } - | tyvar Lsquare nexp_typ ColonGt nexp_typ Rsquare - { tloc (make_vector_sugar_bounded true false "vector" (ATyp_aux ((ATyp_var $1), locn 1 1)) $3 $5) } - -app_typs: - | atomic_typ - { [$1] } - | atomic_typ Comma app_typs - { $1::$3 } - -atomic_typ: - | vec_typ - { $1 } - | range_typ - { $1 } - | nexp_typ - { $1 } - | Inc - { tloc (ATyp_inc) } - | Dec - { tloc (ATyp_dec) } - | tid Lt app_typs Gt - { tloc (ATyp_app($1,$3)) } - | Register Lt app_typs Gt - { tloc (ATyp_app(Id_aux(Id "register", locn 1 1),$3)) } - -range_typ: - | SquareBar nexp_typ BarSquare - { tloc (make_range_sugar $2) } - | SquareBar nexp_typ Colon nexp_typ BarSquare - { tloc (make_range_sugar_bounded $2 $4) } - | SquareColon nexp_typ ColonSquare - { tloc (make_atom_sugar $2) } - -nexp_typ: - | nexp_typ Plus nexp_typ2 - { tloc (ATyp_sum ($1, $3)) } - | nexp_typ Minus nexp_typ2 - { tloc (ATyp_minus ($1, $3)) } - | Minus nexp_typ2 - { tloc (ATyp_neg $2) } - | nexp_typ2 + { mk_typ (ATyp_set []) $startpos $endpos } + +typschm: + | typ MinusGt typ + { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_fn ($1, $3, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } + | Forall typquant Dot typ MinusGt typ + { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } + | typ MinusGt typ Effect effect_set + { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_fn ($1, $3, $5)) s e) s e) $startpos $endpos } + | Forall typquant Dot typ MinusGt typ Effect effect_set + { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, $8)) s e) s e) $startpos $endpos } + +typschm_eof: + | typschm Eof { $1 } -nexp_typ2: - | nexp_typ2 Star nexp_typ3 - { tloc (ATyp_times ($1, $3)) } - | nexp_typ3 +pat1: + | atomic_pat { $1 } + | atomic_pat At pat_concat + { mk_pat (P_vector_concat ($1 :: $3)) $startpos $endpos } -nexp_typ3: - | TwoStarStar nexp_typ4 - { tloc (ATyp_exp $2) } - | nexp_typ4 - { $1 } - -nexp_typ4: - | Num - { tlocl (ATyp_constant $1) 1 1 } - | tid - { tloc (ATyp_id $1) } - | Lcurly id Rcurly - { tloc (ATyp_id $2) } - | tyvar - { tloc (ATyp_var $1) } - | Lparen exist_typ Rparen - { $2 } +pat_concat: + | atomic_pat + { [$1] } + | atomic_pat At pat_concat + { $1 :: $3 } -tup_typ_list: - | atomic_typ Comma atomic_typ - { [$1;$3] } - | atomic_typ Comma tup_typ_list - { $1::$3 } - -tup_typ: - | atomic_typ - { $1 } - | Lparen tup_typ_list Rparen - { tloc (ATyp_tup $2) } - -exist_typ: - | Exist tyvars Comma nexp_constraint Dot tup_typ - { tloc (ATyp_exist ($2, $4, $6)) } - | Exist tyvars Dot tup_typ - { tloc (ATyp_exist ($2, NC_aux (NC_true, loc ()), $4)) } - | tup_typ +pat: + | pat1 { $1 } + | pat1 As id + { mk_pat (P_as ($1, $3)) $startpos $endpos } + | pat1 As kid + { mk_pat (P_var ($1, $3)) $startpos $endpos } -typ: - | exist_typ - { $1 } - | tup_typ MinusGt exist_typ Effect effect_typ - { tloc (ATyp_fn($1,$3,$5)) } +pat_list: + | pat + { [$1] } + | pat Comma pat_list + { $1 :: $3 } + +atomic_pat: + | Under + { mk_pat (P_wild) $startpos $endpos } + | lit + { mk_pat (P_lit $1) $startpos $endpos } + | id + { mk_pat (P_id $1) $startpos $endpos } + | kid + { mk_pat (P_var (mk_pat (P_id (id_of_kid $1)) $startpos $endpos, $1)) $startpos $endpos } + | id Lparen pat_list Rparen + { mk_pat (P_app ($1, $3)) $startpos $endpos } + | atomic_pat Colon typ + { mk_pat (P_typ ($3, $1)) $startpos $endpos } + | Lparen pat Rparen + { $2 } + | Lparen pat Comma pat_list Rparen + { mk_pat (P_tup ($2 :: $4)) $startpos $endpos } + | Lsquare pat_list Rsquare + { mk_pat (P_vector $2) $startpos $endpos } lit: | True - { lloc L_true } + { mk_lit L_true $startpos $endpos } | False - { lloc L_false } + { mk_lit L_false $startpos $endpos } + | Unit + { mk_lit L_unit $startpos $endpos } | Num - { lloc (L_num $1) } - | String - { lloc (L_string $1) } - | Lparen Rparen - { lloc L_unit } - | Bin - { lloc (L_bin $1) } - | Hex - { lloc (L_hex $1) } - | Real - { lloc (L_real $1) } + { mk_lit (L_num $1) $startpos $endpos } | Undefined - { lloc L_undef } + { mk_lit L_undef $startpos $endpos } | Bitzero - { lloc L_zero } + { mk_lit L_zero $startpos $endpos } | Bitone - { lloc L_one } - -atomic_pat: - | lit - { ploc (P_lit $1) } - | Under - { ploc P_wild } - | Lparen pat As id Rparen - { ploc (P_as($2,$4)) } - | Lparen exist_typ Rparen atomic_pat - { ploc (P_typ($2,$4)) } - | id - { ploc (P_app($1,[])) } - | tyvar - { ploc (P_var (ploc (P_id (id_of_kid $1)), $1)) } - | Lcurly fpats Rcurly - { ploc (P_record((fst $2, snd $2))) } - | Lsquare comma_pats Rsquare - { ploc (P_vector($2)) } - | Lsquare pat Rsquare - { ploc (P_vector([$2])) } - | Lsquare Rsquare - { ploc (P_vector []) } - | Lparen comma_pats Rparen - { ploc (P_tup($2)) } - | SquareBarBar BarBarSquare - { ploc (P_list([])) } - | SquareBarBar pat BarBarSquare - { ploc (P_list([$2])) } - | SquareBarBar semi_pats BarBarSquare - { ploc (P_list($2)) } - | atomic_pat ColonColon pat - { ploc (P_cons ($1, $3)) } - | Lparen pat Rparen - { $2 } - -app_pat: - | atomic_pat - { $1 } - | id Lparen comma_pats Rparen - { ploc (P_app($1,$3)) } - | id Lparen pat Rparen - { ploc (P_app($1,[$3])) } - -pat_colons: - | atomic_pat Colon atomic_pat - { ([$1;$3]) } - | atomic_pat Colon pat_colons - { ($1::$3) } - -pat: - | app_pat - { $1 } - | pat_colons - { ploc (P_vector_concat($1)) } - -comma_pats: - | atomic_pat Comma atomic_pat - { [$1;$3] } - | atomic_pat Comma comma_pats - { $1::$3 } - -semi_pats: - | atomic_pat Semi atomic_pat - { [$1;$3] } - | atomic_pat Semi semi_pats - { $1::$3 } - -fpat: - | id Eq pat - { fploc (FP_Fpat($1,$3)) } - -fpats: - | fpat - { ([$1], false) } - | fpat Semi - { ([$1], true) } - | fpat Semi fpats - { ($1::fst $3, snd $3) } - -npat: - | Num Eq pat - { ($1,$3) } - -npats: - | npat - { [$1] } - | npat Comma npats - { ($1::$3) } - -atomic_exp: - | Lcurly semi_exps Rcurly - { eloc (E_block $2) } - | Nondet Lcurly semi_exps Rcurly - { eloc (E_nondet $3) } - | id - { eloc (E_id($1)) } - | lit - { eloc (E_lit($1)) } - | Lparen exp Rparen - { $2 } - | Lparen exist_typ Rparen atomic_exp - { eloc (E_cast($2,$4)) } - | Lparen comma_exps Rparen - { eloc (E_tuple($2)) } - | Lcurly exp With semi_exps Rcurly - { eloc (E_record_update($2,$4)) } - | Lsquare Rsquare - { eloc (E_vector([])) } - | Lsquare exp Rsquare - { eloc (E_vector([$2])) } - | Lsquare comma_exps Rsquare - { eloc (E_vector($2)) } - | Lsquare exp With atomic_exp Eq exp Rsquare - { eloc (E_vector_update($2,$4,$6)) } - | Lsquare exp With atomic_exp Colon atomic_exp Eq exp Rsquare - { eloc (E_vector_update_subrange($2,$4,$6,$8)) } - | SquareBarBar BarBarSquare - { eloc (E_list []) } - | SquareBarBar exp BarBarSquare - { eloc (E_list [$2]) } - | SquareBarBar comma_exps BarBarSquare - { eloc (E_list($2)) } - | Switch exp Lcurly case_exps Rcurly - { eloc (E_case($2,$4)) } - | Try exp Catch Lcurly case_exps Rcurly - { eloc (E_try ($2, $5)) } - | Sizeof atomic_typ - { eloc (E_sizeof($2)) } - | Constraint Lparen nexp_constraint Rparen - { eloc (E_constraint $3) } - | Throw atomic_exp - { eloc (E_throw $2) } - | Exit atomic_exp - { eloc (E_exit $2) } - | Return atomic_exp - { eloc (E_return $2) } - | Assert Lparen exp Comma exp Rparen - { eloc (E_assert ($3,$5)) } - -field_exp: - | atomic_exp - { $1 } - | atomic_exp Dot id - { eloc (E_field($1,$3)) } + { mk_lit L_one $startpos $endpos } + | Bin + { mk_lit (L_bin $1) $startpos $endpos } + | Hex + { mk_lit (L_hex $1) $startpos $endpos } + | String + { mk_lit (L_string $1) $startpos $endpos } + | Real + { mk_lit (L_real $1) $startpos $endpos } -vaccess_exp: - | field_exp +exp_eof: + | exp Eof { $1 } - | atomic_exp Lsquare exp Rsquare - { eloc (E_vector_access($1,$3)) } - | atomic_exp Lsquare exp DotDot exp Rsquare - { eloc (E_vector_subrange($1,$3,$5)) } -app_exp: - | vaccess_exp +exp: + | exp0 { $1 } - | id Lparen Rparen - { eloc (E_app($1, [eloc (E_lit (lloc L_unit))])) } - /* we wrap into a tuple here, but this is unwrapped in initial_check.ml */ - | id Lparen exp Rparen - { eloc (E_app($1,[ E_aux((E_tuple [$3]),locn 3 3)])) } - | id Lparen comma_exps Rparen - { eloc (E_app($1,[E_aux (E_tuple $3,locn 3 3)])) } - -right_atomic_exp: + | atomic_exp Eq exp + { mk_exp (E_assign ($1, $3)) $startpos $endpos } + | Let_ letbind In exp + { mk_exp (E_let ($2, $4)) $startpos $endpos } + | Var atomic_exp Eq exp In exp + { mk_exp (E_var ($2, $4, $6)) $startpos $endpos } + | Star atomic_exp + { mk_exp (E_deref $2) $startpos $endpos } + | Lcurly block Rcurly + { mk_exp (E_block $2) $startpos $endpos } + | Return exp + { mk_exp (E_return $2) $startpos $endpos } + | Throw exp + { mk_exp (E_throw $2) $startpos $endpos } | If_ exp Then exp Else exp - { eloc (E_if($2,$4,$6)) } + { mk_exp (E_if ($2, $4, $6)) $startpos $endpos } | If_ exp Then exp - { eloc (E_if($2,$4, eloc (E_lit(lloc L_unit)))) } + { mk_exp (E_if ($2, $4, mk_lit_exp L_unit $endpos($4) $endpos($4))) $startpos $endpos } + | Match exp Lcurly case_list Rcurly + { mk_exp (E_case ($2, $4)) $startpos $endpos } + | Try exp Catch Lcurly case_list Rcurly + { mk_exp (E_try ($2, $5)) $startpos $endpos } | Foreach Lparen id Id atomic_exp Id atomic_exp By atomic_exp In typ Rparen exp { if $4 <> "from" then - raise (Parse_error_locn ((loc ()),"Missing \"from\" in foreach loop")); + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); if $6 <> "to" then - raise (Parse_error_locn ((loc ()),"Missing \"to\" in foreach loop")); - eloc (E_for($3,$5,$7,$9,$11,$13)) } + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" in foreach loop")); + mk_exp (E_for ($3, $5, $7, $9, $11, $13)) $startpos $endpos } | Foreach Lparen id Id atomic_exp Id atomic_exp By atomic_exp Rparen exp { if $4 <> "from" then - raise (Parse_error_locn ((loc ()),"Missing \"from\" in foreach loop")); + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); if $6 <> "to" && $6 <> "downto" then - raise (Parse_error_locn ((loc ()),"Missing \"to\" or \"downto\" in foreach loop")); + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" or \"downto\" in foreach loop")); let order = if $6 = "to" - then ATyp_aux(ATyp_inc,(locn 6 6)) - else ATyp_aux(ATyp_dec,(locn 6 6)) in - eloc (E_for($3,$5,$7,$9,order,$11)) } + then ATyp_aux(ATyp_inc,loc $startpos($6) $endpos($6)) + else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) + in + mk_exp (E_for ($3, $5, $7, $9, order, $11)) $startpos $endpos } | Foreach Lparen id Id atomic_exp Id atomic_exp Rparen exp { if $4 <> "from" then - raise (Parse_error_locn ((loc ()),"Missing \"from\" in foreach loop")); + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); if $6 <> "to" && $6 <> "downto" then - raise (Parse_error_locn ((loc ()),"Missing \"to\" or \"downto\" in foreach loop")); - let step = eloc (E_lit(lloc (L_num unit_big_int))) in + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" or \"downto\" in foreach loop")); + let step = mk_lit_exp (L_num (Big_int.of_int 1)) $startpos $endpos in let ord = if $6 = "to" - then ATyp_aux(ATyp_inc,(locn 6 6)) - else ATyp_aux(ATyp_dec,(locn 6 6)) in - eloc (E_for($3,$5,$7,step,ord,$9)) } + then ATyp_aux(ATyp_inc,loc $startpos($6) $endpos($6)) + else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) + in + mk_exp (E_for ($3, $5, $7, step, ord, $9)) $startpos $endpos } + | Repeat exp Until exp + { mk_exp (E_loop (Until, $4, $2)) $startpos $endpos } | While exp Do exp - { eloc (E_loop (While, $2, $4)) } - | letbind In exp - { eloc (E_let($1,$3)) } - -starstar_exp: - | app_exp - { $1 } - | starstar_exp StarStar app_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -/* this is where we diverge from the non-right_atomic path; - here we go directly to right_atomic whereas the other one - goes through app_exp, vaccess_exp and field_exp too. */ -starstar_right_atomic_exp: - | right_atomic_exp - { $1 } - | starstar_exp StarStar right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -star_exp: - | starstar_exp - { $1 } - | star_exp Star starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp Div starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp Div_ starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("div"), locn 2 2), $3)) } - | star_exp Quot starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("quot"), locn 2 2), $3)) } - | star_exp QuotUnderS starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("quot_s"), locn 2 2), $3)) } - | star_exp Rem starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("rem"), locn 2 2), $3)) } - | star_exp Mod starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("mod"), locn 2 2), $3)) } - | star_exp ModUnderS starstar_exp - { eloc (E_app_infix($1,Id_aux(Id("mod_s"), locn 2 2), $3)) } - | star_exp StarUnderS starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderSi starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderU starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderUi starstar_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -star_right_atomic_exp: - | starstar_right_atomic_exp - { $1 } - | star_exp Star starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp Div starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp Div_ starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("div"), locn 2 2), $3)) } - | star_exp Quot starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("quot"), locn 2 2), $3)) } - | star_exp QuotUnderS starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("quot_s"), locn 2 2), $3)) } - | star_exp Rem starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("rem"), locn 2 2), $3)) } - | star_exp Mod starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("mod"), locn 2 2), $3)) } - | star_exp ModUnderS starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("mod_s"), locn 2 2), $3)) } - | star_exp StarUnderS starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderSi starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderU starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | star_exp StarUnderUi starstar_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -plus_exp: - | star_exp - { $1 } - | plus_exp Plus star_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | plus_exp PlusUnderS star_exp - { eloc (E_app_infix($1, Id_aux(Id($2), locn 2 2), $3)) } - | plus_exp Minus star_exp - { eloc (E_app_infix($1,Id_aux(Id("-"), locn 2 2), $3)) } - | plus_exp MinusUnderS star_exp - { eloc (E_app_infix($1,Id_aux(Id("-_s"),locn 2 2), $3)) } - -plus_right_atomic_exp: - | star_right_atomic_exp - { $1 } - | plus_exp Plus star_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | plus_exp Minus star_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("-"), locn 2 2), $3)) } - | plus_exp PlusUnderS star_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | plus_exp MinusUnderS star_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("-_s"), locn 2 2), $3)) } - -shift_exp: - | plus_exp - { $1 } - | shift_exp GtGt plus_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp GtGtGt plus_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp LtLt plus_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp LtLtLt plus_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -shift_right_atomic_exp: - | plus_right_atomic_exp - { $1 } - | shift_exp GtGt plus_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp GtGtGt plus_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp LtLt plus_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | shift_exp LtLtLt plus_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - - -cons_exp: - | shift_exp - { $1 } - | shift_exp ColonColon cons_exp - { eloc (E_cons($1,$3)) } - | shift_exp Colon cons_exp - { eloc (E_vector_append($1, $3)) } - -cons_right_atomic_exp: - | shift_right_atomic_exp - { $1 } - | shift_exp ColonColon cons_right_atomic_exp - { eloc (E_cons($1,$3)) } - | shift_exp Colon cons_right_atomic_exp - { eloc (E_vector_append($1, $3)) } - -at_exp: - | cons_exp - { $1 } - | cons_exp At at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp CarrotCarrot at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp Carrot at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp TildeCarrot at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -at_right_atomic_exp: - | cons_right_atomic_exp - { $1 } - | cons_exp At at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp CarrotCarrot at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp Carrot at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | cons_exp TildeCarrot at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -eq_exp: - | at_exp - { $1 } - /* XXX check for consistency */ - | eq_exp Eq at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp EqEq at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp ExclEq at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEq at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEqUnderS at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEqUnderU at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp Gt at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtUnderS at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtUnderU at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtEq at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtEqUnderS at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp Lt at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderS at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderSi at_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderU at_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - /* XXX assignement should not have the same precedence as equal, - otherwise a := b > c requires extra parens... */ - | eq_exp ColonEq at_exp - { eloc (E_assign($1,$3)) } - -eq_right_atomic_exp: - | at_right_atomic_exp - { $1 } - | eq_exp Eq at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp EqEq at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp ExclEq at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEq at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEqUnderS at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtEqUnderU at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp Gt at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtUnderS at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp GtUnderU at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtEq at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtEqUnderS at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp Lt at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderS at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderSi at_right_atomic_exp - { eloc (E_app_infix ($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp LtUnderU at_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp ColonEq at_right_atomic_exp - { eloc (E_assign($1,$3)) } - -and_exp: - | eq_exp - { $1 } - | eq_exp Amp and_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp AmpAmp and_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -and_right_atomic_exp: - | eq_right_atomic_exp - { $1 } - | eq_exp Amp and_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - | eq_exp AmpAmp and_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id($2), locn 2 2), $3)) } - -or_exp: - | and_exp - { $1 } - | and_exp Bar or_exp - { eloc (E_app_infix($1,Id_aux(Id("|"), locn 2 2), $3)) } - | and_exp BarBar or_exp - { eloc (E_app_infix($1,Id_aux(Id("||"), locn 2 2), $3)) } - -or_right_atomic_exp: - | and_right_atomic_exp - { $1 } - | and_exp Bar or_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("|"), locn 2 2), $3)) } - | and_exp BarBar or_right_atomic_exp - { eloc (E_app_infix($1,Id_aux(Id("||"), locn 2 2), $3)) } - -exp: - | or_exp - { $1 } - | or_right_atomic_exp - { $1 } - -comma_exps: - | exp Comma exp - { [$1;$3] } - | exp Comma comma_exps - { $1::$3 } + { mk_exp (E_loop (While, $2, $4)) $startpos $endpos } + +/* The following implements all nine levels of user-defined precedence for +operators in expressions, with both left, right and non-associative operators */ + +exp0: + | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp0l op0l exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 op0r exp0r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 { $1 } +exp0l: + | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp0l op0l exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 { $1 } +exp0r: + | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 op0r exp0r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 { $1 } + +exp1: + | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1l op1l exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 op1r exp1r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 { $1 } +exp1l: + | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1l op1l exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 { $1 } +exp1r: + | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 op1r exp1r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 { $1 } + +exp2: + | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2l op2l exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 op2r exp2r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 Bar exp2r { mk_exp (E_app_infix ($1, mk_id (Id "|") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp3 { $1 } +exp2l: + | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2l op2l exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 { $1 } +exp2r: + | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 op2r exp2r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 Bar exp2r { mk_exp (E_app_infix ($1, mk_id (Id "|") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp3 { $1 } + +exp3: + | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3l op3l exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 op3r exp3r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 Amp exp3r { mk_exp (E_app_infix ($1, mk_id (Id "&") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp4 { $1 } +exp3l: + | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3l op3l exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 { $1 } +exp3r: + | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 op3r exp3r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 Amp exp3r { mk_exp (E_app_infix ($1, mk_id (Id "&") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp4 { $1 } + +exp4: + | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 Lt exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 Gt exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 LtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 GtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 ExclEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "!=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 { $1 } +exp4l: + | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 { $1 } +exp4r: + | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 { $1 } + +exp5: + | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5l op5l exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 op5r exp5r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 At exp5r { mk_exp (E_vector_append ($1, $3)) $startpos $endpos } + | exp6 { $1 } +exp5l: + | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5l op5l exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 { $1 } +exp5r: + | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 op5r exp5r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 At exp5r { mk_exp (E_vector_append ($1, $3)) $startpos $endpos } + | exp6 { $1 } + +exp6: + | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l op6l exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7 op6r exp6r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l Plus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "+") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp6l Minus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "-") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp7 { $1 } +exp6l: + | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l op6l exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l Plus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "+") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp6l Minus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "-") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp7 { $1 } +exp6r: + | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7 op6r exp6r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7 { $1 } + +exp7: + | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l op7l exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8 op7r exp7r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l Star exp8 { mk_exp (E_app_infix ($1, mk_id (Id "*") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp8 { $1 } +exp7l: + | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l op7l exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l Star exp8 { mk_exp (E_app_infix ($1, mk_id (Id "*") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp8 { $1 } +exp7r: + | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8 op7r exp7r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8 { $1 } + +exp8: + | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8l op8l exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 op8r exp8r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 Caret exp8r { mk_exp (E_app_infix ($1, mk_id (Id "^") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } + | exp9 { $1 } +exp8l: + | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8l op8l exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } + | exp9 { $1 } +exp8r: + | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 op8r exp8r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 Caret exp8r { mk_exp (E_app_infix ($1, mk_id (Id "^") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } + | exp9 { $1 } + +exp9: + | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9l op9l atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp op9r exp9r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp { $1 } +exp9l: + | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9l op9l atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp { $1 } +exp9r: + | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp op9r exp9r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp { $1 } + +case: + | pat EqGt exp + { mk_pexp (Pat_exp ($1, $3)) $startpos $endpos } + | pat If_ exp EqGt exp + { mk_pexp (Pat_when ($1, $3, $5)) $startpos $endpos } + +case_list: + | case + { [$1] } + | case Comma case_list + { $1 :: $3 } -semi_exps_help: +block: | exp { [$1] } - | exp Semi + | Let_ letbind Semi block + { [mk_exp (E_let ($2, mk_exp (E_block $4) $startpos($4) $endpos)) $startpos $endpos] } + | Var atomic_exp Eq exp Semi block + { [mk_exp (E_var ($2, $4, mk_exp (E_block $6) $startpos($6) $endpos)) $startpos $endpos] } + | exp Semi /* Allow trailing semicolon in block */ { [$1] } - | exp Semi semi_exps_help - { $1::$3 } + | exp Semi block + { $1 :: $3 } -semi_exps: - | - { [] } - | semi_exps_help - { $1 } +%inline letbind: + | pat Eq exp + { LB_aux (LB_val ($1, $3), loc $startpos $endpos) } -case_exp: - | Case patsexp +atomic_exp: + | atomic_exp Colon atomic_typ + { mk_exp (E_cast ($3, $1)) $startpos $endpos } + | lit + { mk_exp (E_lit $1) $startpos $endpos } + | id MinusGt id Unit + { mk_exp (E_app (prepend_id "_mod_" $3, [mk_exp (E_ref $1) $startpos($1) $endpos($1)])) $startpos $endpos } + | id MinusGt id Lparen exp_list Rparen + { mk_exp (E_app (prepend_id "_mod_" $3, mk_exp (E_ref $1) $startpos($1) $endpos($1) :: $5)) $startpos $endpos } + | atomic_exp Dot id Unit + { mk_exp (E_app (prepend_id "_mod_" $3, [$1])) $startpos $endpos } + | atomic_exp Dot id Lparen exp_list Rparen + { mk_exp (E_app (prepend_id "_mod_" $3, $1 :: $5)) $startpos $endpos } + | atomic_exp Dot id + { mk_exp (E_field ($1, $3)) $startpos $endpos } + | id + { mk_exp (E_id $1) $startpos $endpos } + | kid + { mk_exp (E_sizeof (mk_typ (ATyp_var $1) $startpos $endpos)) $startpos $endpos } + | Ref id + { mk_exp (E_ref $2) $startpos $endpos } + | id Unit + { mk_exp (E_app ($1, [mk_lit_exp L_unit $startpos($2) $endpos])) $startpos $endpos } + | id Lparen exp_list Rparen + { mk_exp (E_app ($1, $3)) $startpos $endpos } + | Exit Lparen exp Rparen + { mk_exp (E_exit $3) $startpos $endpos } + | Sizeof Lparen typ Rparen + { mk_exp (E_sizeof $3) $startpos $endpos } + | Constraint Lparen nc Rparen + { mk_exp (E_constraint $3) $startpos $endpos } + | Assert Lparen exp Rparen + { mk_exp (E_assert ($3, mk_lit_exp (L_string "") $startpos($4) $endpos($4))) $startpos $endpos } + | Assert Lparen exp Comma exp Rparen + { mk_exp (E_assert ($3, $5)) $startpos $endpos } + | atomic_exp Lsquare exp Rsquare + { 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 } -case_exps: - | case_exp - { [$1] } - | case_exp case_exps - { $1::$2 } +fexp_exp: + | atomic_exp Eq exp + { mk_exp (E_app_infix ($1, mk_id (Id "=") $startpos($2) $endpos($2), $3)) $startpos $endpos } -patsexp: - | atomic_pat MinusGt exp - { peloc (Pat_exp($1,$3)) } - | atomic_pat When exp MinusGt exp - { peloc (Pat_when ($1, $3, $5)) } +fexp_exp_list: + | fexp_exp + { [$1] } + | fexp_exp Comma fexp_exp_list + { $1 :: $3 } -letbind: - | Let_ atomic_pat Eq exp - { lbloc (LB_val($2,$4)) } +exp_list: + | exp + { [$1] } + | exp Comma exp_list + { $1 :: $3 } -patsexp_funcl: - | atomic_pat Eq exp - { peloc (Pat_exp($1,$3)) } - | Lparen atomic_pat When exp Rparen Eq exp - { peloc (Pat_when ($2, $4, $7)) } +funcl_patexp: + | pat Eq exp + { mk_pexp (Pat_exp ($1, $3)) $startpos $endpos } + | Lparen pat If_ exp Rparen Eq exp + { mk_pexp (Pat_when ($2, $4, $7)) $startpos $endpos } funcl: - | id patsexp_funcl - { funclloc (FCL_Funcl($1,$2)) } + | id funcl_patexp + { mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos } -funcl_ands: - | funcl - { [$1] } - | funcl And funcl_ands - { $1::$3 } - -/* This causes ambiguity because without a type quantifier it's unclear whether the first id is a function name or a type name for the optional types.*/ -fun_def: - | Function_ Rec typquant typ Effect effect_typ funcl_ands - { funloc (FD_function(mk_rec 2, mk_tannot $3 $4 3 4, mk_eannot $6 6, $7)) } - | Function_ Rec typquant typ funcl_ands - { funloc (FD_function(mk_rec 2, mk_tannot $3 $4 3 4, mk_eannotn (), $5)) } - | Function_ Rec typ Effect effect_typ funcl_ands - { funloc (FD_function(mk_rec 2, mk_tannot (mk_typqn ()) $3 3 3, mk_eannot $5 5, $6)) } - | Function_ Rec Effect effect_typ funcl_ands - { funloc (FD_function(mk_rec 2,mk_tannotn (), mk_eannot $4 4, $5)) } - | Function_ Rec typ funcl_ands - { funloc (FD_function(mk_rec 2,mk_tannot (mk_typqn ()) $3 3 3, mk_eannotn (), $4)) } - | Function_ Rec funcl_ands - { funloc (FD_function(mk_rec 2, mk_tannotn (), mk_eannotn (), $3)) } - | Function_ typquant typ Effect effect_typ funcl_ands - { funloc (FD_function(mk_recn (), mk_tannot $2 $3 2 3, mk_eannot $5 5, $6)) } - | Function_ typquant typ funcl_ands - { funloc (FD_function(mk_recn (), mk_tannot $2 $3 2 2, mk_eannotn (), $4)) } - | Function_ typ Effect effect_typ funcl_ands - { funloc (FD_function(mk_recn (), mk_tannot (mk_typqn ()) $2 2 2, mk_eannot $4 4, $5)) } - | Function_ Effect effect_typ funcl_ands - { funloc (FD_function(mk_recn (),mk_tannotn (), mk_eannot $3 3, $4)) } - | Function_ typ funcl_ands - { funloc (FD_function(mk_recn (),mk_tannot (mk_typqn ()) $2 2 2, mk_eannotn (), $3)) } - | Function_ funcl_ands - { funloc (FD_function(mk_recn (), mk_tannotn (), mk_eannotn (), $2)) } - - -val_spec: - | Val typquant typ id - { vloc (VS_val_spec(mk_typschm $2 $3 2 3,$4, (fun _ -> None), false)) } - | Val typ id - { vloc (VS_val_spec(mk_typschm (mk_typqn ()) $2 2 2,$3, (fun _ -> None), false)) } - | Val Cast typquant typ id - { vloc (VS_val_spec (mk_typschm $3 $4 3 4,$5, (fun _ -> None), true)) } - | Val Cast typ id - { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $3 3 3, $4, (fun _ -> None), true)) } - | Val Extern typquant typ id - { vloc (VS_val_spec (mk_typschm $3 $4 3 4,$5, (fun _ -> Some (string_of_id $5)), false)) } - | Val Extern typ id - { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $3 3 3, $4, (fun _ -> Some (string_of_id $4)), false)) } - | Val Extern typquant typ id Eq String - { vloc (VS_val_spec (mk_typschm $3 $4 3 4,$5, (fun _ -> Some $7), false)) } - | Val Extern typ id Eq String - { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $3 3 3,$4, (fun _ -> Some $6), false)) } - | Val Cast Extern typquant typ id - { vloc (VS_val_spec (mk_typschm $4 $5 4 5,$6, (fun _ -> Some (string_of_id $6)), true)) } - | Val Cast Extern typ id - { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $4 4 4, $5, (fun _ -> Some (string_of_id $5)), true)) } - | Val Cast Extern typquant typ id Eq String - { vloc (VS_val_spec (mk_typschm $4 $5 4 5,$6, (fun _ -> Some $8), true)) } - | Val Cast Extern typ id Eq String - { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $4 4 4,$5, (fun _ -> Some $7), true)) } - -kinded_id: - | tyvar - { kiloc (KOpt_none $1) } - | kind tyvar - { kiloc (KOpt_kind($1,$2))} - -/*kinded_ids: - | kinded_id - { [$1] } - | kinded_id kinded_ids - { $1::$2 }*/ +funcls: + | id funcl_patexp + { [mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos] } + | id funcl_patexp And funcls + { mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos :: $4 } -nums: +index_range: | Num - { [$1] } - | Num Comma nums - { $1::$3 } - -nexp_constraint: - | nexp_constraint1 - { $1 } - | nexp_constraint1 Bar nexp_constraint - { NC_aux (NC_or ($1, $3), loc ()) } - -nexp_constraint1: - | nexp_constraint2 - { $1 } - | nexp_constraint2 Amp nexp_constraint1 - { NC_aux (NC_and ($1, $3), loc ()) } - -nexp_constraint2: - | nexp_typ Eq nexp_typ - { NC_aux(NC_equal($1,$3), loc () ) } - | nexp_typ ExclEq nexp_typ - { NC_aux (NC_not_equal ($1, $3), loc ()) } - | nexp_typ GtEq nexp_typ - { NC_aux(NC_bounded_ge($1,$3), loc () ) } - | nexp_typ LtEq nexp_typ - { NC_aux(NC_bounded_le($1,$3), loc () ) } - | tyvar In Lcurly nums Rcurly - { NC_aux(NC_set($1,$4), loc ()) } - | tyvar IN Lcurly nums Rcurly - { NC_aux(NC_set($1,$4), loc ()) } - | True - { NC_aux (NC_true, loc ()) } - | False - { NC_aux (NC_false, loc ()) } - | Lparen nexp_constraint Rparen - { $2 } + { mk_ir (BF_single $1) $startpos $endpos } + | Num DotDot Num + { mk_ir (BF_range ($1, $3)) $startpos $endpos } -id_constraint: - | nexp_constraint - { QI_aux((QI_const $1), loc())} - | kinded_id - { QI_aux((QI_id $1), loc()) } +r_id_def: + | id Colon index_range + { $1, $3 } -id_constraints: - | id_constraint - { [$1] } - | id_constraint Comma id_constraints - { $1::$3 } +r_def_body: + | r_id_def + { [$1] } + | r_id_def Comma + { [$1] } + | r_id_def Comma r_def_body + { $1 :: $3 } -typquant: - | Forall id_constraints Dot - { typql(TypQ_tq($2)) } - -name_sect: - | Lsquare Id Eq String Rsquare - { - if $2 <> "name" then - raise (Parse_error_locn ((loc ()),"Unexpected id \""^$2^"\" in name_sect (should be \"name\")")); - Name_sect_aux(Name_sect_some($4), loc ()) } - -c_def_body: - | typ id - { [($1,$2)],false } - | typ id Semi - { [($1,$2)],true } - | typ id Semi c_def_body - { ($1,$2)::(fst $4), snd $4 } - -union_body: +type_def: + | Typedef id typquant Eq typ + { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm $3 $5 $startpos($3) $endpos)) $startpos $endpos } + | Typedef id Eq typ + { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm mk_typqn $4 $startpos($4) $endpos)) $startpos $endpos } + | Struct id Eq Lcurly struct_fields Rcurly + { mk_td (TD_record ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } + | Struct id typquant Eq Lcurly struct_fields Rcurly + { mk_td (TD_record ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } + | Enum id Eq enum_bar + { mk_td (TD_enum ($2, mk_namesectn, $4, false)) $startpos $endpos } + | Enum id Eq Lcurly enum Rcurly + { mk_td (TD_enum ($2, mk_namesectn, $5, false)) $startpos $endpos } + | Newtype id Eq type_union + { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), [$4], false)) $startpos $endpos } + | Newtype id typquant Eq type_union + { mk_td (TD_variant ($2, mk_namesectn, $3, [$5], false)) $startpos $endpos } + | Union id Eq Lcurly type_unions Rcurly + { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } + | Union id typquant Eq Lcurly type_unions Rcurly + { mk_td (TD_variant ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } + | Bitfield id Colon typ Eq Lcurly r_def_body Rcurly + { mk_td (TD_bitfield ($2, $4, $7)) $startpos $endpos } + +enum_bar: | id - { [Tu_aux( Tu_id $1, loc())],false } - | typ id - { [Tu_aux( Tu_ty_id ($1,$2), loc())],false } - | id Semi - { [Tu_aux( Tu_id $1, loc())],true } - | typ id Semi - { [Tu_aux( Tu_ty_id ($1,$2),loc())],true } - | id Semi union_body - { (Tu_aux( Tu_id $1, loc()))::(fst $3), snd $3 } - | typ id Semi union_body - { (Tu_aux(Tu_ty_id($1,$2),loc()))::(fst $4), snd $4 } - -index_range_atomic: - | Num - { irloc (BF_single($1)) } - | Num DotDot Num - { irloc (BF_range($1,$3)) } - | Lparen index_range Rparen - { $2 } + { [$1] } + | id Bar enum_bar + { $1 :: $3 } -enum_body: +enum: | id - { [$1] } - | id Semi - { [$1] } - | id Semi enum_body - { $1::$3 } + { [$1] } + | id Comma enum + { $1 :: $3 } -index_range: - | index_range_atomic - { $1 } - | index_range_atomic Comma index_range - { irloc(BF_concat($1,$3)) } +struct_field: + | id Colon typ + { ($3, $1) } -r_id_def: - | index_range Colon id - { $1,$3 } +struct_fields: + | struct_field + { [$1] } + | struct_field Comma + { [$1] } + | struct_field Comma struct_fields + { $1 :: $3 } -r_def_body: - | r_id_def +type_union: + | id Colon typ + { Tu_aux (Tu_ty_id ($3, $1), loc $startpos $endpos) } + | id + { Tu_aux (Tu_id $1, loc $startpos $endpos) } + +type_unions: + | type_union { [$1] } - | r_id_def Semi + | type_union Comma { [$1] } - | r_id_def Semi r_def_body - { $1::$3 } + | type_union Comma type_unions + { $1 :: $3 } -type_def: - | Typedef tid name_sect Eq typquant typ - { tdloc (TD_abbrev($2,$3,mk_typschm $5 $6 5 6)) } - | Typedef tid name_sect Eq typ - { tdloc (TD_abbrev($2,$3,mk_typschm (mk_typqn ()) $5 5 5)) } - | Typedef tid Eq typquant typ - { tdloc (TD_abbrev($2,mk_namesectn (), mk_typschm $4 $5 4 5))} - | Typedef tid Eq typ - { tdloc (TD_abbrev($2,mk_namesectn (),mk_typschm (mk_typqn ()) $4 4 4)) } - /* The below adds 4 shift/reduce conflicts. Due to c_def_body and confusions in id id and parens */ - | Typedef tid name_sect Eq Const Struct typquant Lcurly c_def_body Rcurly - { tdloc (TD_record($2,$3,$7,fst $9, snd $9)) } - | Typedef tid name_sect Eq Const Struct Lcurly c_def_body Rcurly - { tdloc (TD_record($2,$3,(mk_typqn ()), fst $8, snd $8)) } - | Typedef tid Eq Const Struct typquant Lcurly c_def_body Rcurly - { tdloc (TD_record($2,mk_namesectn (), $6, fst $8, snd $8)) } - | Typedef tid Eq Const Struct Lcurly c_def_body Rcurly - { tdloc (TD_record($2, mk_namesectn (), mk_typqn (), fst $7, snd $7)) } - | Typedef tid name_sect Eq Const Union typquant Lcurly union_body Rcurly - { tdloc (TD_variant($2,$3, $7, fst $9, snd $9)) } - | Typedef tid Eq Const Union typquant Lcurly union_body Rcurly - { tdloc (TD_variant($2,mk_namesectn (), $6, fst $8, snd $8)) } - | Typedef tid name_sect Eq Const Union Lcurly union_body Rcurly - { tdloc (TD_variant($2, $3, mk_typqn (), fst $8, snd $8)) } - | Typedef tid Eq Const Union Lcurly union_body Rcurly - { tdloc (TD_variant($2, mk_namesectn (), mk_typqn (), fst $7, snd $7)) } - | Typedef tid Eq Enumerate Lcurly enum_body Rcurly - { tdloc (TD_enum($2, mk_namesectn (), $6,false)) } - | Typedef tid name_sect Eq Enumerate Lcurly enum_body Rcurly - { tdloc (TD_enum($2,$3,$7,false)) } - | Typedef tid Eq Register Bits Lsquare nexp_typ Colon nexp_typ Rsquare Lcurly r_def_body Rcurly - { tdloc (TD_register($2, $7, $9, $12)) } - -default_typ: - | Default atomic_kind tyvar - { defloc (DT_kind($2,$3)) } - | Default atomic_kind Inc - { defloc (DT_order($2, tloc (ATyp_inc))) } - | Default atomic_kind Dec - { defloc (DT_order($2, tloc (ATyp_dec))) } - | Default typquant typ id - { defloc (DT_typ((mk_typschm $2 $3 2 3),$4)) } - | Default typ id - { defloc (DT_typ((mk_typschm (mk_typqn ()) $2 2 2),$3)) } +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 } + +externs: + | id Colon String + { [(string_of_id $1, $3)] } + | id Colon String Comma externs + { (string_of_id $1, $3) :: $5 } + +val_spec_def: + | Val id Colon typschm + { mk_vs (VS_val_spec ($4, $2, (fun _ -> None), false)) $startpos $endpos } + | Val Cast id Colon typschm + { mk_vs (VS_val_spec ($5, $3, (fun _ -> None), true)) $startpos $endpos } + | Val id Eq String Colon typschm + { mk_vs (VS_val_spec ($6, $2, (fun _ -> Some $4), false)) $startpos $endpos } + | Val Cast id Eq String Colon typschm + { mk_vs (VS_val_spec ($7, $3, (fun _ -> Some $5), true)) $startpos $endpos } + | Val String Colon typschm + { mk_vs (VS_val_spec ($4, mk_id (Id $2) $startpos($2) $endpos($2), (fun _ -> Some $2), false)) $startpos $endpos } + | Val Cast String Colon typschm + { mk_vs (VS_val_spec ($5, mk_id (Id $3) $startpos($3) $endpos($3), (fun _ -> Some $3), true)) $startpos $endpos } + | Val id Eq Lcurly externs Rcurly Colon typschm + { mk_vs (VS_val_spec ($8, $2, (fun backend -> (assoc_opt backend $5)), false)) $startpos $endpos } + | Val Cast id Eq Lcurly externs Rcurly Colon typschm + { mk_vs (VS_val_spec ($9, $3, (fun backend -> (assoc_opt backend $6)), true)) $startpos $endpos } + +register_def: + | Register id Colon typ + { mk_reg_dec (DEC_reg ($4, $2)) $startpos $endpos } + +default_def: + | Default base_kind Inc + { mk_default (DT_order ($2, mk_typ ATyp_inc $startpos($3) $endpos)) $startpos $endpos } + | Default base_kind Dec + { mk_default (DT_order ($2, mk_typ ATyp_dec $startpos($3) $endpos)) $startpos $endpos } scattered_def: - | Function_ Rec typquant typ Effect effect_typ id - { sdloc (SD_scattered_function(mk_rec 2, mk_tannot $3 $4 3 4, mk_eannot $6 6, $7)) } - | Function_ Rec typ Effect effect_typ id - { sdloc (SD_scattered_function(mk_rec 2, mk_tannot (mk_typqn ()) $3 3 3, mk_eannot $5 5, $6)) } - | Function_ Rec typquant typ id - { sdloc (SD_scattered_function(mk_rec 2, mk_tannot $3 $4 3 4, mk_eannotn (), $5)) } - | Function_ Rec Effect effect_typ id - { sdloc (SD_scattered_function (mk_rec 2, mk_tannotn (), mk_eannot $4 4, $5)) } - | Function_ Rec typ id - { sdloc (SD_scattered_function(mk_rec 2,mk_tannot (mk_typqn ()) $3 3 3, mk_eannotn (), $4)) } - | Function_ Rec id - { sdloc (SD_scattered_function(mk_rec 2,mk_tannotn (), mk_eannotn (),$3)) } - | Function_ typquant typ Effect effect_typ id - { sdloc (SD_scattered_function(mk_recn (),mk_tannot $2 $3 2 3, mk_eannot $5 5, $6)) } - | Function_ typ Effect effect_typ id - { sdloc (SD_scattered_function(mk_recn (), mk_tannot (mk_typqn ()) $2 2 2, mk_eannot $4 4, $5)) } - | Function_ typquant typ id - { sdloc (SD_scattered_function(mk_recn (), mk_tannot $2 $3 2 3, mk_eannotn (), $4)) } - | Function_ Effect effect_typ id - { sdloc (SD_scattered_function(mk_recn (), mk_tannotn (), mk_eannot $3 3, $4)) } - | Function_ typ id - { sdloc (SD_scattered_function(mk_recn (), mk_tannot (mk_typqn ()) $2 2 2, mk_eannotn (), $3)) } + | Union id typquant + { mk_sd (SD_scattered_variant($2, mk_namesectn, $3)) $startpos $endpos } + | Union id + { mk_sd (SD_scattered_variant($2, mk_namesectn, mk_typqn)) $startpos $endpos } | Function_ id - { sdloc (SD_scattered_function(mk_recn (), mk_tannotn (), mk_eannotn (), $2)) } - | Typedef tid name_sect Eq Const Union typquant - { sdloc (SD_scattered_variant($2,$3,$7)) } - | Typedef tid Eq Const Union typquant - { sdloc (SD_scattered_variant($2,(mk_namesectn ()),$6)) } - | Typedef tid name_sect Eq Const Union - { sdloc (SD_scattered_variant($2,$3,mk_typqn ())) } - | Typedef tid Eq Const Union - { sdloc (SD_scattered_variant($2,mk_namesectn (),mk_typqn ())) } - -ktype_def: - | Def kind tid name_sect Eq typquant typ - { kdloc (KD_abbrev($2,$3,$4,mk_typschm $6 $7 6 7)) } - | Def kind tid name_sect Eq typ - { kdloc (KD_abbrev($2,$3,$4,mk_typschm (mk_typqn ()) $6 6 6)) } - | Def kind tid Eq typquant typ - { kdloc (KD_abbrev($2,$3,mk_namesectn (), mk_typschm $5 $6 5 6)) } - | Def kind tid Eq typ - { kdloc (KD_abbrev($2,$3,mk_namesectn (),mk_typschm (mk_typqn ()) $5 5 5)) } - | Def kind tid Eq Num - { kdloc (KD_abbrev($2,$3,mk_namesectn (),mk_typschm (mk_typqn ()) (tlocl (ATyp_constant $5) 5 5) 5 5)) } + { mk_sd (SD_scattered_function(mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } def: - | type_def - { dloc (DEF_type($1)) } - | ktype_def - { dloc (DEF_kind($1)) } | fun_def - { dloc (DEF_fundef($1)) } - | letbind - { dloc (DEF_val($1)) } - | val_spec - { dloc (DEF_spec($1)) } - | default_typ - { dloc (DEF_default($1)) } - | Overload id Lsquare enum_body Rsquare - { dloc (DEF_overload($2,$4)) } - | Register typ id - { dloc (DEF_reg_dec(DEC_aux(DEC_reg($2,$3),loc ()))) } - | Register Alias id Eq exp - { dloc (DEF_reg_dec(DEC_aux(DEC_alias($3,$5),loc ()))) } - | Register Alias typ id Eq exp - { dloc (DEF_reg_dec(DEC_aux(DEC_typ_alias($3,$4,$6), loc ()))) } + { DEF_fundef $1 } + | Fixity + { let (prec, n, op) = $1 in DEF_fixity (prec, n, Id_aux (Id op, loc $startpos $endpos)) } + | val_spec_def + { DEF_spec $1 } + | type_def + { DEF_type $1 } + | let_def + { DEF_val $1 } + | register_def + { DEF_reg_dec $1 } + | Overload id Eq Lcurly id_list Rcurly + { DEF_overload ($2, $5) } + | Overload id Eq enum_bar + { DEF_overload ($2, $4) } | Scattered scattered_def - { dloc (DEF_scattered $2) } + { DEF_scattered $2 } | Function_ Clause funcl - { dloc (DEF_scattered (sdloc (SD_scattered_funcl($3)))) } - | Union tid Member typ id - { dloc (DEF_scattered (sdloc (SD_scattered_unioncl($2,Tu_aux(Tu_ty_id($4,$5), locn 4 5))))) } - | Union tid Member id - { dloc (DEF_scattered (sdloc (SD_scattered_unioncl($2,Tu_aux(Tu_id($4), locn 4 4))))) } + { DEF_scattered (mk_sd (SD_scattered_funcl $3) $startpos $endpos) } + | Union Clause id Eq type_union + { DEF_scattered (mk_sd (SD_scattered_unioncl ($3, $5)) $startpos $endpos) } | End id - { dloc (DEF_scattered (sdloc (SD_scattered_end($2)))) } - | End tid - { dloc (DEF_scattered (sdloc (SD_scattered_end($2)))) } + { 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_help: +defs_list: | def { [$1] } - | def defs_help + | def defs_list { $1::$2 } +def_eof: + | def Eof + { $1 } + defs: - | defs_help + | defs_list { (Defs $1) } file: | defs Eof { $1 } - -nonempty_exp_list: - | semi_exps_help Eof { $1 } diff --git a/src/parser2.mly b/src/parser2.mly deleted file mode 100644 index 59c7f1c4..00000000 --- a/src/parser2.mly +++ /dev/null @@ -1,1171 +0,0 @@ -/**************************************************************************/ -/* Sail */ -/* */ -/* Copyright (c) 2013-2017 */ -/* Kathyrn Gray */ -/* Shaked Flur */ -/* Stephen Kell */ -/* Gabriel Kerneis */ -/* Robert Norton-Wright */ -/* Christopher Pulte */ -/* Peter Sewell */ -/* Alasdair Armstrong */ -/* Brian Campbell */ -/* Thomas Bauereiss */ -/* Anthony Fox */ -/* Jon French */ -/* Dominic Mulligan */ -/* Stephen Kell */ -/* Mark Wassell */ -/* */ -/* 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. */ -/**************************************************************************/ - -%{ - -let r = fun x -> x (* Ulib.Text.of_latin1 *) - -open Big_int -open Parse_ast - -let loc n m = Range (n, m) - -let default_opt x = function - | None -> x - | Some y -> y - -let assoc_opt key assocs = - try Some (List.assoc key assocs) with - | Not_found -> None - -let string_of_id = function - | Id_aux (Id str, _) -> str - | Id_aux (DeIid str, _) -> str - -let mk_id i n m = Id_aux (i, loc n m) -let mk_kid str n m = Kid_aux (Var str, loc n m) - -let id_of_kid = function - | Kid_aux (Var v, l) -> Id_aux (Id (String.sub v 1 (String.length v - 1)), l) - -let deinfix (Id_aux (Id v, l)) = Id_aux (DeIid v, l) - -let mk_effect e n m = BE_aux (e, loc n m) -let mk_typ t n m = ATyp_aux (t, loc n m) -let mk_pat p n m = P_aux (p, loc n m) -let mk_pexp p n m = Pat_aux (p, loc n m) -let mk_exp e n m = E_aux (e, loc n m) -let mk_lit l n m = L_aux (l, loc n m) -let mk_lit_exp l n m = mk_exp (E_lit (mk_lit l n m)) n m -let mk_typschm tq t n m = TypSchm_aux (TypSchm_ts (tq, t), loc n m) -let mk_nc nc n m = NC_aux (nc, loc n m) -let mk_sd s n m = SD_aux (s, loc n m) - -let mk_funcl f n m = FCL_aux (f, loc n m) -let mk_fun fn n m = FD_aux (fn, loc n m) -let mk_td t n m = TD_aux (t, loc n m) -let mk_vs v n m = VS_aux (v, loc n m) -let mk_reg_dec d n m = DEC_aux (d, loc n m) -let mk_default d n m = DT_aux (d, loc n m) - -let qi_id_of_kopt (KOpt_aux (kopt_aux, l) as kopt) = QI_aux (QI_id kopt, l) - -let mk_recn = (Rec_aux((Rec_nonrec), Unknown)) -let mk_typqn = (TypQ_aux(TypQ_no_forall,Unknown)) -let mk_tannotn = Typ_annot_opt_aux(Typ_annot_opt_none,Unknown) -let mk_eannotn = Effect_opt_aux(Effect_opt_pure,Unknown) -let mk_namesectn = Name_sect_aux(Name_sect_none,Unknown) - -type lchain = - LC_lt -| LC_lteq -| LC_nexp of atyp - -let rec desugar_lchain chain s e = - match chain with - | [LC_nexp n1; LC_lteq; LC_nexp n2] -> - mk_nc (NC_bounded_le (n1, n2)) s e - | [LC_nexp n1; LC_lt; LC_nexp n2] -> - mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant unit_big_int) s e)) s e, n2)) s e - | (LC_nexp n1 :: LC_lteq :: LC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_le (n1, n2)) s e in - mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e - | (LC_nexp n1 :: LC_lt :: LC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant unit_big_int) s e)) s e, n2)) s e in - mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e - | _ -> assert false - -type rchain = - RC_gt -| RC_gteq -| RC_nexp of atyp - -let rec desugar_rchain chain s e = - match chain with - | [RC_nexp n1; RC_gteq; RC_nexp n2] -> - mk_nc (NC_bounded_ge (n1, n2)) s e - | [RC_nexp n1; RC_gt; RC_nexp n2] -> - mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant unit_big_int) s e)) s e)) s e - | (RC_nexp n1 :: RC_gteq :: RC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_ge (n1, n2)) s e in - mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e - | (RC_nexp n1 :: RC_gt :: RC_nexp n2 :: chain) -> - let nc1 = mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant unit_big_int) s e)) s e)) s e in - mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e - | _ -> assert false - -%} - -/*Terminals with no content*/ - -%token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op -%token Enum Else False Forall Foreach Overload Function_ If_ In Inc Let_ Int Order Cast -%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 Record Mutual - -%nonassoc Then -%nonassoc Else - -%token Bar Comma Dot Eof Minus Semi Under DotDot -%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar LsquareBar RsquareBar -%token MinusGt - -/*Terminals with content*/ - -%token <string> Id TyVar -%token <Big_int.big_int> Num -%token <string> String Bin Hex Real - -%token <string> Amp At Caret Eq Gt Lt Plus Star EqGt Unit -%token <string> Colon ExclEq -%token <string> GtEq -%token <string> LtEq - -%token <string> Op0 Op1 Op2 Op3 Op4 Op5 Op6 Op7 Op8 Op9 -%token <string> Op0l Op1l Op2l Op3l Op4l Op5l Op6l Op7l Op8l Op9l -%token <string> Op0r Op1r Op2r Op3r Op4r Op5r Op6r Op7r Op8r Op9r - -%token <Parse_ast.fixity_token> Fixity - -%start file -%start typschm_eof -%type <Parse_ast.typschm> typschm_eof -%type <Parse_ast.defs> file - -%% - -id: - | Id { mk_id (Id $1) $startpos $endpos } - - | Op Op0 { mk_id (DeIid $2) $startpos $endpos } - | Op Op1 { mk_id (DeIid $2) $startpos $endpos } - | Op Op2 { mk_id (DeIid $2) $startpos $endpos } - | Op Op3 { mk_id (DeIid $2) $startpos $endpos } - | Op Op4 { mk_id (DeIid $2) $startpos $endpos } - | Op Op5 { mk_id (DeIid $2) $startpos $endpos } - | Op Op6 { mk_id (DeIid $2) $startpos $endpos } - | Op Op7 { mk_id (DeIid $2) $startpos $endpos } - | Op Op8 { mk_id (DeIid $2) $startpos $endpos } - | Op Op9 { mk_id (DeIid $2) $startpos $endpos } - - | Op Op0l { mk_id (DeIid $2) $startpos $endpos } - | Op Op1l { mk_id (DeIid $2) $startpos $endpos } - | Op Op2l { mk_id (DeIid $2) $startpos $endpos } - | Op Op3l { mk_id (DeIid $2) $startpos $endpos } - | Op Op4l { mk_id (DeIid $2) $startpos $endpos } - | Op Op5l { mk_id (DeIid $2) $startpos $endpos } - | Op Op6l { mk_id (DeIid $2) $startpos $endpos } - | Op Op7l { mk_id (DeIid $2) $startpos $endpos } - | Op Op8l { mk_id (DeIid $2) $startpos $endpos } - | Op Op9l { mk_id (DeIid $2) $startpos $endpos } - - | Op Op0r { mk_id (DeIid $2) $startpos $endpos } - | Op Op1r { mk_id (DeIid $2) $startpos $endpos } - | Op Op2r { mk_id (DeIid $2) $startpos $endpos } - | Op Op3r { mk_id (DeIid $2) $startpos $endpos } - | Op Op4r { mk_id (DeIid $2) $startpos $endpos } - | Op Op5r { mk_id (DeIid $2) $startpos $endpos } - | Op Op6r { mk_id (DeIid $2) $startpos $endpos } - | Op Op7r { mk_id (DeIid $2) $startpos $endpos } - | Op Op8r { mk_id (DeIid $2) $startpos $endpos } - | Op Op9r { mk_id (DeIid $2) $startpos $endpos } - - | Op Plus { mk_id (DeIid "+") $startpos $endpos } - | Op Minus { mk_id (DeIid "-") $startpos $endpos } - | Op Star { mk_id (DeIid "*") $startpos $endpos } - | Op ExclEq { mk_id (DeIid "!=") $startpos $endpos } - | Op Lt { mk_id (DeIid "<") $startpos $endpos } - | Op Gt { mk_id (DeIid ">") $startpos $endpos } - | Op LtEq { mk_id (DeIid "<=") $startpos $endpos } - | Op GtEq { mk_id (DeIid ">=") $startpos $endpos } - | Op Amp { mk_id (DeIid "&") $startpos $endpos } - | Op Bar { mk_id (DeIid "|") $startpos $endpos } - | Op Caret { mk_id (DeIid "^") $startpos $endpos } - -op0: Op0 { mk_id (Id $1) $startpos $endpos } -op1: Op1 { mk_id (Id $1) $startpos $endpos } -op2: Op2 { mk_id (Id $1) $startpos $endpos } -op3: Op3 { mk_id (Id $1) $startpos $endpos } -op4: Op4 { mk_id (Id $1) $startpos $endpos } -op5: Op5 { mk_id (Id $1) $startpos $endpos } -op6: Op6 { mk_id (Id $1) $startpos $endpos } -op7: Op7 { mk_id (Id $1) $startpos $endpos } -op8: Op8 { mk_id (Id $1) $startpos $endpos } -op9: Op9 { mk_id (Id $1) $startpos $endpos } - -op0l: Op0l { mk_id (Id $1) $startpos $endpos } -op1l: Op1l { mk_id (Id $1) $startpos $endpos } -op2l: Op2l { mk_id (Id $1) $startpos $endpos } -op3l: Op3l { mk_id (Id $1) $startpos $endpos } -op4l: Op4l { mk_id (Id $1) $startpos $endpos } -op5l: Op5l { mk_id (Id $1) $startpos $endpos } -op6l: Op6l { mk_id (Id $1) $startpos $endpos } -op7l: Op7l { mk_id (Id $1) $startpos $endpos } -op8l: Op8l { mk_id (Id $1) $startpos $endpos } -op9l: Op9l { mk_id (Id $1) $startpos $endpos } - -op0r: Op0r { mk_id (Id $1) $startpos $endpos } -op1r: Op1r { mk_id (Id $1) $startpos $endpos } -op2r: Op2r { mk_id (Id $1) $startpos $endpos } -op3r: Op3r { mk_id (Id $1) $startpos $endpos } -op4r: Op4r { mk_id (Id $1) $startpos $endpos } -op5r: Op5r { mk_id (Id $1) $startpos $endpos } -op6r: Op6r { mk_id (Id $1) $startpos $endpos } -op7r: Op7r { mk_id (Id $1) $startpos $endpos } -op8r: Op8r { mk_id (Id $1) $startpos $endpos } -op9r: Op9r { mk_id (Id $1) $startpos $endpos } - -id_list: - | id - { [$1] } - | id Comma id_list - { $1 :: $3 } - -kid: - | TyVar - { mk_kid $1 $startpos $endpos } - -kid_list: - | kid - { [$1] } - | kid kid_list - { $1 :: $2 } - -nc: - | nc Bar nc_and - { mk_nc (NC_or ($1, $3)) $startpos $endpos } - | nc_and - { $1 } - -nc_and: - | nc_and Amp atomic_nc - { mk_nc (NC_and ($1, $3)) $startpos $endpos } - | atomic_nc - { $1 } - -atomic_nc: - | True - { mk_nc NC_true $startpos $endpos } - | False - { mk_nc NC_false $startpos $endpos } - | typ Eq typ - { mk_nc (NC_equal ($1, $3)) $startpos $endpos } - | typ ExclEq typ - { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } - | nc_lchain - { desugar_lchain $1 $startpos $endpos } - | nc_rchain - { desugar_rchain $1 $startpos $endpos } - | Lparen nc Rparen - { $2 } - | kid In Lcurly num_list Rcurly - { mk_nc (NC_set ($1, $4)) $startpos $endpos } - -num_list: - | Num - { [$1] } - | Num Comma num_list - { $1 :: $3 } - -nc_lchain: - | typ LtEq typ - { [LC_nexp $1; LC_lteq; LC_nexp $3] } - | typ Lt typ - { [LC_nexp $1; LC_lt; LC_nexp $3] } - | typ LtEq nc_lchain - { LC_nexp $1 :: LC_lteq :: $3 } - | typ Lt nc_lchain - { LC_nexp $1 :: LC_lt :: $3 } - -nc_rchain: - | typ GtEq typ - { [RC_nexp $1; RC_gteq; RC_nexp $3] } - | typ Gt typ - { [RC_nexp $1; RC_gt; RC_nexp $3] } - | typ GtEq nc_rchain - { RC_nexp $1 :: RC_gteq :: $3 } - | typ Gt nc_rchain - { RC_nexp $1 :: RC_gt :: $3 } - -typ: - | typ0 - { $1 } - -/* The following implements all nine levels of user-defined precedence for -operators in types, with both left, right and non-associative operators */ - -typ0: - | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ0l op0l typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1 op0r typ0r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1 { $1 } -typ0l: - | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ0l op0l typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1 { $1 } -typ0r: - | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1 op0r typ0r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1 { $1 } - -typ1: - | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1l op1l typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2 op1r typ1r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2 { $1 } -typ1l: - | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ1l op1l typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2 { $1 } -typ1r: - | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2 op1r typ1r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2 { $1 } - -typ2: - | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3 { $1 } -typ2l: - | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3 { $1 } -typ2r: - | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3 { $1 } - -typ3: - | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4 { $1 } -typ3l: - | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4 { $1 } -typ3r: - | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4 { $1 } - -typ4: - | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5 { $1 } -typ4l: - | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5 { $1 } -typ4r: - | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5 { $1 } - -typ5: - | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5l op5l typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6 op5r typ5r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6 { $1 } -typ5l: - | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ5l op5l typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6 { $1 } -typ5r: - | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6 op5r typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6 { $1 } - -typ6: - | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6l op6l typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7 op6r typ6r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6l Plus typ7 { mk_typ (ATyp_sum ($1, $3)) $startpos $endpos } - | typ6l Minus typ7 { mk_typ (ATyp_minus ($1, $3)) $startpos $endpos } - | typ7 { $1 } -typ6l: - | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6l op6l typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ6l Plus typ7 { mk_typ (ATyp_sum ($1, $3)) $startpos $endpos } - | typ6l Minus typ7 { mk_typ (ATyp_minus ($1, $3)) $startpos $endpos } - | typ7 { $1 } -typ6r: - | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7 op6r typ6r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7 { $1 } - -typ7: - | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7l op7l typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ8 op7r typ7r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7l Star typ8 { mk_typ (ATyp_times ($1, $3)) $startpos $endpos } - | typ8 { $1 } -typ7l: - | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7l op7l typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ7l Star typ8 { mk_typ (ATyp_times ($1, $3)) $startpos $endpos } - | typ8 { $1 } -typ7r: - | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ8 op7r typ7r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ8 { $1 } - -typ8: - | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ8l op8l typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ9 op8r typ8r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } - | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} - | typ9 { $1 } -typ8l: - | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ8l op8l typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } - | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} - | typ9 { $1 } -typ8r: - | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ9 op8r typ8r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } - | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} - | typ9 { $1 } - -typ9: - | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | atomic_typ { $1 } -typ9l: - | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | atomic_typ { $1 } -typ9r: - | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } - | atomic_typ { $1 } - -atomic_typ: - | id - { mk_typ (ATyp_id $1) $startpos $endpos } - | kid - { mk_typ (ATyp_var $1) $startpos $endpos } - | Num - { mk_typ (ATyp_constant $1) $startpos $endpos } - | Dec - { mk_typ ATyp_dec $startpos $endpos } - | Inc - { mk_typ ATyp_inc $startpos $endpos } - | id Lparen typ_list Rparen - { mk_typ (ATyp_app ($1, $3)) $startpos $endpos } - | Register Lparen typ Rparen - { let register_id = mk_id (Id "register") $startpos $endpos in - mk_typ (ATyp_app (register_id, [$3])) $startpos $endpos } - | Lparen typ Rparen - { $2 } - | Lparen typ Comma typ_list Rparen - { mk_typ (ATyp_tup ($2 :: $4)) $startpos $endpos } - | LcurlyBar num_list RcurlyBar - { let v = mk_kid "n" $startpos $endpos in - let atom_id = mk_id (Id "atom") $startpos $endpos in - let atom_of_v = mk_typ (ATyp_app (atom_id, [mk_typ (ATyp_var v) $startpos $endpos])) $startpos $endpos in - mk_typ (ATyp_exist ([v], NC_aux (NC_set (v, $2), loc $startpos($2) $endpos($2)), atom_of_v)) $startpos $endpos } - | Lcurly kid_list Dot typ Rcurly - { mk_typ (ATyp_exist ($2, NC_aux (NC_true, loc $startpos $endpos), $4)) $startpos $endpos } - | Lcurly kid_list Comma nc Dot typ Rcurly - { mk_typ (ATyp_exist ($2, $4, $6)) $startpos $endpos } - -typ_list: - | typ - { [$1] } - | typ Comma typ_list - { $1 :: $3 } - -base_kind: - | Int - { BK_aux (BK_nat, loc $startpos $endpos) } - | TYPE - { BK_aux (BK_type, loc $startpos $endpos) } - | Order - { BK_aux (BK_order, loc $startpos $endpos) } - -kind: - | base_kind - { K_aux (K_kind [$1], loc $startpos $endpos) } - -kopt: - | Lparen kid Colon kind Rparen - { KOpt_aux (KOpt_kind ($4, $2), loc $startpos $endpos) } - | kid - { KOpt_aux (KOpt_none $1, loc $startpos $endpos) } - -kopt_list: - | kopt - { [$1] } - | kopt kopt_list - { $1 :: $2 } - -typquant: - | kopt_list Comma nc - { let qi_nc = QI_aux (QI_const $3, loc $startpos($3) $endpos($3)) in - TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1 @ [qi_nc]), loc $startpos $endpos) } - | kopt_list - { TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1), loc $startpos $endpos) } - -effect: - | Barr - { mk_effect BE_barr $startpos $endpos } - | Depend - { mk_effect BE_depend $startpos $endpos } - | Rreg - { mk_effect BE_rreg $startpos $endpos } - | Wreg - { mk_effect BE_wreg $startpos $endpos } - | Rmem - { mk_effect BE_rmem $startpos $endpos } - | Rmemt - { mk_effect BE_rmemt $startpos $endpos } - | Wmem - { mk_effect BE_wmem $startpos $endpos } - | Wmv - { mk_effect BE_wmv $startpos $endpos } - | Wmvt - { mk_effect BE_wmvt $startpos $endpos } - | Eamem - { mk_effect BE_eamem $startpos $endpos } - | Exmem - { mk_effect BE_exmem $startpos $endpos } - | Undef - { mk_effect BE_undef $startpos $endpos } - | Unspec - { mk_effect BE_unspec $startpos $endpos } - | Nondet - { mk_effect BE_nondet $startpos $endpos } - | Escape - { mk_effect BE_escape $startpos $endpos } - -effect_list: - | effect - { [$1] } - | effect Comma effect_list - { $1::$3 } - -effect_set: - | Lcurly effect_list Rcurly - { mk_typ (ATyp_set $2) $startpos $endpos } - | Pure - { mk_typ (ATyp_set []) $startpos $endpos } - -typschm: - | typ MinusGt typ - { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_fn ($1, $3, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } - | Forall typquant Dot typ MinusGt typ - { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } - | typ MinusGt typ Effect effect_set - { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_fn ($1, $3, $5)) s e) s e) $startpos $endpos } - | Forall typquant Dot typ MinusGt typ Effect effect_set - { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, $8)) s e) s e) $startpos $endpos } - -typschm_eof: - | typschm Eof - { $1 } - -pat1: - | atomic_pat - { $1 } - | atomic_pat At pat_concat - { mk_pat (P_vector_concat ($1 :: $3)) $startpos $endpos } - -pat_concat: - | atomic_pat - { [$1] } - | atomic_pat At pat_concat - { $1 :: $3 } - -pat: - | pat1 - { $1 } - | pat1 As id - { mk_pat (P_as ($1, $3)) $startpos $endpos } - | pat1 As kid - { mk_pat (P_var ($1, $3)) $startpos $endpos } - -pat_list: - | pat - { [$1] } - | pat Comma pat_list - { $1 :: $3 } - -atomic_pat: - | Under - { mk_pat (P_wild) $startpos $endpos } - | lit - { mk_pat (P_lit $1) $startpos $endpos } - | id - { mk_pat (P_id $1) $startpos $endpos } - | kid - { mk_pat (P_var (mk_pat (P_id (id_of_kid $1)) $startpos $endpos, $1)) $startpos $endpos } - | id Lparen pat_list Rparen - { mk_pat (P_app ($1, $3)) $startpos $endpos } - | atomic_pat Colon typ - { mk_pat (P_typ ($3, $1)) $startpos $endpos } - | Lparen pat Rparen - { $2 } - | Lparen pat Comma pat_list Rparen - { mk_pat (P_tup ($2 :: $4)) $startpos $endpos } - | Lsquare pat_list Rsquare - { mk_pat (P_vector $2) $startpos $endpos } - -lit: - | True - { mk_lit L_true $startpos $endpos } - | False - { mk_lit L_false $startpos $endpos } - | Unit - { mk_lit L_unit $startpos $endpos } - | Num - { mk_lit (L_num $1) $startpos $endpos } - | Undefined - { mk_lit L_undef $startpos $endpos } - | Bitzero - { mk_lit L_zero $startpos $endpos } - | Bitone - { mk_lit L_one $startpos $endpos } - | Bin - { mk_lit (L_bin $1) $startpos $endpos } - | Hex - { mk_lit (L_hex $1) $startpos $endpos } - | String - { mk_lit (L_string $1) $startpos $endpos } - | Real - { mk_lit (L_real $1) $startpos $endpos } - -exp: - | exp0 - { $1 } - | atomic_exp Eq exp - { mk_exp (E_assign ($1, $3)) $startpos $endpos } - | Let_ letbind In exp - { mk_exp (E_let ($2, $4)) $startpos $endpos } - | Lcurly block Rcurly - { mk_exp (E_block $2) $startpos $endpos } - | Return exp - { mk_exp (E_return $2) $startpos $endpos } - | Throw exp - { mk_exp (E_throw $2) $startpos $endpos } - | If_ exp Then exp Else exp - { mk_exp (E_if ($2, $4, $6)) $startpos $endpos } - | If_ exp Then exp - { mk_exp (E_if ($2, $4, mk_lit_exp L_unit $endpos($4) $endpos($4))) $startpos $endpos } - | Match exp Lcurly case_list Rcurly - { mk_exp (E_case ($2, $4)) $startpos $endpos } - | Try exp Catch Lcurly case_list Rcurly - { mk_exp (E_try ($2, $5)) $startpos $endpos } - | Foreach Lparen id Id atomic_exp Id atomic_exp By atomic_exp In typ Rparen exp - { if $4 <> "from" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); - if $6 <> "to" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" in foreach loop")); - mk_exp (E_for ($3, $5, $7, $9, $11, $13)) $startpos $endpos } - | Foreach Lparen id Id atomic_exp Id atomic_exp By atomic_exp Rparen exp - { if $4 <> "from" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); - if $6 <> "to" && $6 <> "downto" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" or \"downto\" in foreach loop")); - let order = - if $6 = "to" - then ATyp_aux(ATyp_inc,loc $startpos($6) $endpos($6)) - else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) - in - mk_exp (E_for ($3, $5, $7, $9, order, $11)) $startpos $endpos } - | Foreach Lparen id Id atomic_exp Id atomic_exp Rparen exp - { if $4 <> "from" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); - if $6 <> "to" && $6 <> "downto" then - raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" or \"downto\" in foreach loop")); - let step = mk_lit_exp (L_num unit_big_int) $startpos $endpos in - let ord = - if $6 = "to" - then ATyp_aux(ATyp_inc,loc $startpos($6) $endpos($6)) - else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) - in - mk_exp (E_for ($3, $5, $7, step, ord, $9)) $startpos $endpos } - | Repeat exp Until exp - { mk_exp (E_loop (Until, $4, $2)) $startpos $endpos } - | While exp Do exp - { mk_exp (E_loop (While, $2, $4)) $startpos $endpos } - -/* The following implements all nine levels of user-defined precedence for -operators in expressions, with both left, right and non-associative operators */ - -exp0: - | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp0l op0l exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1 op0r exp0r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1 { $1 } -exp0l: - | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp0l op0l exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1 { $1 } -exp0r: - | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1 op0r exp0r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1 { $1 } - -exp1: - | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1l op1l exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2 op1r exp1r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2 { $1 } -exp1l: - | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp1l op1l exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2 { $1 } -exp1r: - | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2 op1r exp1r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2 { $1 } - -exp2: - | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2l op2l exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3 op2r exp2r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3 Bar exp2r { mk_exp (E_app_infix ($1, mk_id (Id "|") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp3 { $1 } -exp2l: - | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp2l op2l exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3 { $1 } -exp2r: - | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3 op2r exp2r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3 Bar exp2r { mk_exp (E_app_infix ($1, mk_id (Id "|") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp3 { $1 } - -exp3: - | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3l op3l exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4 op3r exp3r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4 Amp exp3r { mk_exp (E_app_infix ($1, mk_id (Id "&") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp4 { $1 } -exp3l: - | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp3l op3l exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4 { $1 } -exp3r: - | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4 op3r exp3r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4 Amp exp3r { mk_exp (E_app_infix ($1, mk_id (Id "&") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp4 { $1 } - -exp4: - | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 Lt exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp5 Gt exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp5 LtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<=") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp5 GtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">=") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp5 ExclEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "!=") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 { $1 } -exp4l: - | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 { $1 } -exp4r: - | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5 { $1 } - -exp5: - | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5l op5l exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6 op5r exp5r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6 At exp5r { mk_exp (E_vector_append ($1, $3)) $startpos $endpos } - | exp6 { $1 } -exp5l: - | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp5l op5l exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6 { $1 } -exp5r: - | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6 op5r exp5r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6 At exp5r { mk_exp (E_vector_append ($1, $3)) $startpos $endpos } - | exp6 { $1 } - -exp6: - | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6l op6l exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7 op6r exp6r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6l Plus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "+") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp6l Minus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "-") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp7 { $1 } -exp6l: - | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6l op6l exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp6l Plus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "+") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp6l Minus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "-") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp7 { $1 } -exp6r: - | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7 op6r exp6r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7 { $1 } - -exp7: - | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7l op7l exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp8 op7r exp7r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7l Star exp8 { mk_exp (E_app_infix ($1, mk_id (Id "*") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp8 { $1 } -exp7l: - | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7l op7l exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp7l Star exp8 { mk_exp (E_app_infix ($1, mk_id (Id "*") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | exp8 { $1 } -exp7r: - | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp8 op7r exp7r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp8 { $1 } - -exp8: - | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp8l op8l exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9 op8r exp8r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9 Caret exp8r { mk_exp (E_app_infix ($1, mk_id (Id "^") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } - | exp9 { $1 } -exp8l: - | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp8l op8l exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } - | exp9 { $1 } -exp8r: - | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9 op8r exp8r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9 Caret exp8r { mk_exp (E_app_infix ($1, mk_id (Id "^") $startpos($2) $endpos($2), $3)) $startpos $endpos } - | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } - | exp9 { $1 } - -exp9: - | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9l op9l atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | atomic_exp op9r exp9r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | atomic_exp { $1 } -exp9l: - | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | exp9l op9l atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | atomic_exp { $1 } -exp9r: - | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | atomic_exp op9r exp9r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } - | atomic_exp { $1 } - -case: - | pat EqGt exp - { mk_pexp (Pat_exp ($1, $3)) $startpos $endpos } - | pat If_ exp EqGt exp - { mk_pexp (Pat_when ($1, $3, $5)) $startpos $endpos } - -case_list: - | case - { [$1] } - | case Comma case_list - { $1 :: $3 } - -block: - | exp - { [$1] } - | Let_ letbind Semi block - { [mk_exp (E_let ($2, mk_exp (E_block $4) $startpos($4) $endpos)) $startpos $endpos] } - | exp Semi /* Allow trailing semicolon in block */ - { [$1] } - | exp Semi block - { $1 :: $3 } - -%inline letbind: - | pat Eq exp - { LB_aux (LB_val ($1, $3), loc $startpos $endpos) } - -atomic_exp: - | atomic_exp Colon atomic_typ - { mk_exp (E_cast ($3, $1)) $startpos $endpos } - | lit - { mk_exp (E_lit $1) $startpos $endpos } - | atomic_exp Dot id - { mk_exp (E_field ($1, $3)) $startpos $endpos } - | id - { mk_exp (E_id $1) $startpos $endpos } - | kid - { mk_exp (E_sizeof (mk_typ (ATyp_var $1) $startpos $endpos)) $startpos $endpos } - | id Unit - { mk_exp (E_app ($1, [mk_lit_exp L_unit $startpos($2) $endpos])) $startpos $endpos } - | id Lparen exp_list Rparen - { mk_exp (E_app ($1, $3)) $startpos $endpos } - | Exit Lparen exp Rparen - { mk_exp (E_exit $3) $startpos $endpos } - | Sizeof Lparen typ Rparen - { mk_exp (E_sizeof $3) $startpos $endpos } - | Constraint Lparen nc Rparen - { mk_exp (E_constraint $3) $startpos $endpos } - | Assert Lparen exp Rparen - { mk_exp (E_assert ($3, mk_lit_exp (L_string "") $startpos($4) $endpos($4))) $startpos $endpos } - | Assert Lparen exp Comma exp Rparen - { mk_exp (E_assert ($3, $5)) $startpos $endpos } - | atomic_exp Lsquare exp Rsquare - { 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] } - | exp Comma exp_list - { $1 :: $3 } - -funcl_patexp: - | pat Eq exp - { mk_pexp (Pat_exp ($1, $3)) $startpos $endpos } - | Lparen pat If_ exp Rparen Eq exp - { mk_pexp (Pat_when ($2, $4, $7)) $startpos $endpos } - -funcl: - | id funcl_patexp - { mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos } - -funcls: - | id funcl_patexp - { [mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos] } - | id funcl_patexp And funcls - { mk_funcl (FCL_Funcl ($1, $2)) $startpos $endpos :: $4 } - -type_def: - | Typedef id typquant Eq typ - { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm $3 $5 $startpos($3) $endpos)) $startpos $endpos } - | Typedef id Eq typ - { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm mk_typqn $4 $startpos($4) $endpos)) $startpos $endpos } - | Struct id Eq Lcurly struct_fields Rcurly - { mk_td (TD_record ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } - | Struct id typquant Eq Lcurly struct_fields Rcurly - { mk_td (TD_record ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } - | Enum id Eq enum_bar - { mk_td (TD_enum ($2, mk_namesectn, $4, false)) $startpos $endpos } - | Enum id Eq Lcurly enum Rcurly - { mk_td (TD_enum ($2, mk_namesectn, $5, false)) $startpos $endpos } - | Union id Eq Lcurly type_unions Rcurly - { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } - | Union id typquant Eq Lcurly type_unions Rcurly - { mk_td (TD_variant ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } - -enum_bar: - | id - { [$1] } - | id Bar enum_bar - { $1 :: $3 } - -enum: - | id - { [$1] } - | id Comma enum - { $1 :: $3 } - -struct_field: - | id Colon typ - { ($3, $1) } - -struct_fields: - | struct_field - { [$1] } - | struct_field Comma - { [$1] } - | struct_field Comma struct_fields - { $1 :: $3 } - -type_union: - | id Colon typ - { Tu_aux (Tu_ty_id ($3, $1), loc $startpos $endpos) } - | id - { Tu_aux (Tu_id $1, loc $startpos $endpos) } - -type_unions: - | type_union - { [$1] } - | type_union Comma - { [$1] } - | type_union Comma type_unions - { $1 :: $3 } - -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 } - -externs: - | id Colon String - { [(string_of_id $1, $3)] } - | id Colon String Comma externs - { (string_of_id $1, $3) :: $5 } - -val_spec_def: - | Val id Colon typschm - { mk_vs (VS_val_spec ($4, $2, (fun _ -> None), false)) $startpos $endpos } - | Val Cast id Colon typschm - { mk_vs (VS_val_spec ($5, $3, (fun _ -> None), true)) $startpos $endpos } - | Val id Eq String Colon typschm - { mk_vs (VS_val_spec ($6, $2, (fun _ -> Some $4), false)) $startpos $endpos } - | Val Cast id Eq String Colon typschm - { mk_vs (VS_val_spec ($7, $3, (fun _ -> Some $5), true)) $startpos $endpos } - | Val String Colon typschm - { mk_vs (VS_val_spec ($4, mk_id (Id $2) $startpos($2) $endpos($2), (fun _ -> Some $2), false)) $startpos $endpos } - | Val Cast String Colon typschm - { mk_vs (VS_val_spec ($5, mk_id (Id $3) $startpos($3) $endpos($3), (fun _ -> Some $3), true)) $startpos $endpos } - | Val id Eq Lcurly externs Rcurly Colon typschm - { mk_vs (VS_val_spec ($8, $2, (fun backend -> (assoc_opt backend $5)), false)) $startpos $endpos } - | Val Cast id Eq Lcurly externs Rcurly Colon typschm - { mk_vs (VS_val_spec ($9, $3, (fun backend -> (assoc_opt backend $6)), true)) $startpos $endpos } - -register_def: - | Register id Colon typ - { mk_reg_dec (DEC_reg ($4, $2)) $startpos $endpos } - -default_def: - | Default base_kind Inc - { mk_default (DT_order ($2, mk_typ ATyp_inc $startpos($3) $endpos)) $startpos $endpos } - | Default base_kind Dec - { mk_default (DT_order ($2, mk_typ ATyp_dec $startpos($3) $endpos)) $startpos $endpos } - -scattered_def: - | Union id typquant - { mk_sd (SD_scattered_variant($2, mk_namesectn, $3)) $startpos $endpos } - | Union id - { mk_sd (SD_scattered_variant($2, mk_namesectn, mk_typqn)) $startpos $endpos } - | Function_ id - { mk_sd (SD_scattered_function(mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } - -def: - | fun_def - { DEF_fundef $1 } - | Fixity - { let (prec, n, op) = $1 in DEF_fixity (prec, n, Id_aux (Id op, loc $startpos $endpos)) } - | val_spec_def - { DEF_spec $1 } - | type_def - { DEF_type $1 } - | let_def - { DEF_val $1 } - | register_def - { DEF_reg_dec $1 } - | Overload id Eq Lcurly id_list Rcurly - { DEF_overload ($2, $5) } - | Overload id Eq enum_bar - { DEF_overload ($2, $4) } - | Scattered scattered_def - { DEF_scattered $2 } - | Function_ Clause funcl - { DEF_scattered (mk_sd (SD_scattered_funcl $3) $startpos $endpos) } - | Union Clause id Eq type_union - { DEF_scattered (mk_sd (SD_scattered_unioncl ($3, $5)) $startpos $endpos) } - | End id - { 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 - { [$1] } - | def defs_list - { $1::$2 } - -defs: - | defs_list - { (Defs $1) } - -file: - | defs Eof - { $1 } diff --git a/src/pre_lexer.mll b/src/pre_lexer.mll deleted file mode 100644 index 3c308b99..00000000 --- a/src/pre_lexer.mll +++ /dev/null @@ -1,205 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* 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 Pre_parser -module M = Map.Make(String) -exception LexError of string * Lexing.position - -let r = fun s -> s (* Ulib.Text.of_latin1 *) -(* Available as Scanf.unescaped since OCaml 4.0 but 3.12 is still common *) -let unescaped s = Scanf.sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) - -let kw_table = - List.fold_left - (fun r (x,y) -> M.add x y r) - M.empty - [ - ("and", (fun _ -> Other)); - ("as", (fun _ -> Other)); - ("bits", (fun _ -> Other)); - ("by", (fun _ -> Other)); - ("case", (fun _ -> Other)); - ("clause", (fun _ -> Other)); - ("const", (fun _ -> Other)); - ("dec", (fun _ -> Other)); - ("default", (fun _ -> Other)); - ("deinfix", (fun _ -> Other)); - ("effect", (fun _ -> Other)); - ("Effects", (fun _ -> Other)); - ("end", (fun _ -> Other)); - ("enumerate", (fun _ -> Other)); - ("else", (fun _ -> Other)); - ("extern", (fun _ -> Other)); - ("false", (fun _ -> Other)); - ("forall", (fun _ -> Other)); - ("foreach", (fun _ -> Other)); - ("function", (fun x -> Other)); - ("if", (fun x -> Other)); - ("in", (fun x -> Other)); - ("IN", (fun x -> Other)); - ("Inc", (fun x -> Other)); - ("let", (fun x -> Other)); - ("member", (fun x -> Other)); - ("Nat", (fun x -> Other)); - ("Order", (fun x -> Other)); - ("pure", (fun x -> Other)); - ("rec", (fun x -> Other)); - ("register", (fun x -> Other)); - ("return", (fun x -> Other)); - ("scattered", (fun x -> Other)); - ("struct", (fun x -> Other)); - ("sizeof", (fun x -> Other)); - ("switch", (fun x -> Other)); - ("then", (fun x -> Other)); - ("true", (fun x -> Other)); - ("Type", (fun x -> Other)); - ("typedef", (fun x -> Typedef)); - ("def", (fun x -> Def)); - ("undefined", (fun x -> Other)); - ("union", (fun x -> Other)); - ("with", (fun x -> Other)); - ("val", (fun x -> Other)); - - ("AND", (fun x -> Other)); - ("div", (fun x -> Other)); - ("EOR", (fun x -> Other)); - ("mod", (fun x -> Other)); - ("OR", (fun x -> Other)); - ("quot", (fun x -> Other)); - ("rem", (fun x -> Other)); -] - -} - -let ws = [' ''\t']+ -let letter = ['a'-'z''A'-'Z'] -let digit = ['0'-'9'] -let binarydigit = ['0'-'1'] -let hexdigit = ['0'-'9''A'-'F''a'-'f'] -let alphanum = letter|digit -let startident = letter|'_' -let ident = alphanum|['_''\'''#'] -let tyvar_start = '\'' -let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''?''@''^''|''~'] -let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) - -rule token = parse - | ws - { token lexbuf } - | "\n" - { Lexing.new_line lexbuf; - token lexbuf } - - | "2**" | "&" | "@" | "|" | "^" | ":" | "," | "." | "/" | "=" | "!" | ">" | "-" | "<" | - "+" | ";" | "*" | "~" | "_" | "{" | "}" | "(" | ")" | "[" | "]" | "&&" | "||" | "|]" | "||]" | - "^^" | "::" | ":>" | ":=" | ".." | "=/=" | "==" | "!=" | "!!" | ">=" | ">=+" | ">>" | ">>>" | ">+" | - "#>>" | "#<<" | "->" | "<:" | "<=" | "<=+" | "<>" | "<<" | "<<<" | "<+" | "**" | "~^" | ">=_s" | - ">=_si" | ">=_u" | ">=_ui" | ">>_u" | ">_s" | ">_si" | ">_u" | ">_ui" | "<=_s" | "<=_si" | - "<=_u" | "<=_ui" | "<_s" | "<_si" | "<_u" | "<_ui" | "**_s" | "**_si" | "*_u" | "*_ui"| "2^" { Other } - - - | "(*" { comment (Lexing.lexeme_start_p lexbuf) 0 lexbuf; token lexbuf } - | "*)" { raise (LexError("Unbalanced comment", Lexing.lexeme_start_p lexbuf)) } - - | startident ident* as i { if M.mem i kw_table then - (M.find i kw_table) () - else - Id(r i) } - | tyvar_start startident ident* { Other } - | "&" oper_char+ | "@" oper_char+ | "^" oper_char+ | "/" oper_char+ | "=" oper_char+ | - "!" oper_char+ | ">" oper_char+ | "<" oper_char+ | "+" oper_char+ | "*" oper_char+ | - "~" oper_char+ | "&&" oper_char+ | "^^" oper_char+| "::" oper_char+| "=/=" oper_char+ | - "==" oper_char+ | "!=" oper_char+ | "!!" oper_char+ | ">=" oper_char+ | ">=+" oper_char+ | - ">>" oper_char+ | ">>>" oper_char+ | ">+" oper_char+ | "#>>" oper_char+ | "#<<" oper_char+ | - "<=" oper_char+ | "<=+" oper_char+ | "<<" oper_char+ | "<<<" oper_char+ | "<+" oper_char+ | - "**" oper_char+ | "~^" oper_char+ | ">=_s" oper_char+ | ">=_si" oper_char+ | ">=_u" oper_char+ | - ">=_ui" oper_char+ | ">>_u" oper_char+ | ">_s" oper_char+ | ">_si" oper_char+| ">_u" oper_char+ | - ">_ui" oper_char+ | "<=_s" oper_char+ | "<=_si" oper_char+ | "<=_u" oper_char+ | "<=_ui" oper_char+ | - "<_s" oper_char+ | "<_si" oper_char+ | "<_u" oper_char+ | "<_ui" oper_char+ | "**_s" oper_char+ | - "**_si" oper_char+ | "*_u" oper_char+ | "*_ui" oper_char+ | "2^" oper_char+ { Other } - | digit+ { Other } - | "0b" (binarydigit+) { Other } - | "0x" (hexdigit+) { Other } - | '"' { let _ = string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf in Other } - | eof { Eof } - | _ as c { raise (LexError( - Printf.sprintf "Unexpected character: %c" c, - Lexing.lexeme_start_p lexbuf)) } - - -and comment pos depth = parse - | "(*" { comment pos (depth+1) lexbuf } - | "*)" { if depth = 0 then () - else if depth > 0 then comment pos (depth-1) lexbuf - else assert false } - | "\n" { Lexing.new_line lexbuf; - comment pos depth lexbuf } - | '"' { ignore(string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf); - comment pos depth lexbuf } - | _ { comment pos depth lexbuf } - | eof { raise (LexError("Unbalanced comment", pos)) } - -and string pos b = parse - | ([^'"''\n''\\']*'\n' as i) { Lexing.new_line lexbuf; - Buffer.add_string b i; - string pos b lexbuf } - | ([^'"''\n''\\']* as i) { Buffer.add_string b i; string pos b lexbuf } - | escape_sequence as i { Buffer.add_string b i; string pos b lexbuf } - | '\\' '\n' ws { Lexing.new_line lexbuf; string pos b lexbuf } - | '\\' { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "illegal backslash escape in string"*) } - | '"' { let s = unescaped(Buffer.contents b) in - (*try Ulib.UTF8.validate s; s - with Ulib.UTF8.Malformed_code -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "String literal is not valid utf8"))) *) s } - | eof { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, - "String literal not terminated")))*) } diff --git a/src/pre_parser.mly b/src/pre_parser.mly deleted file mode 100644 index 0b4833a1..00000000 --- a/src/pre_parser.mly +++ /dev/null @@ -1,94 +0,0 @@ -/**************************************************************************/ -/* Sail */ -/* */ -/* Copyright (c) 2013-2017 */ -/* Kathyrn Gray */ -/* Shaked Flur */ -/* Stephen Kell */ -/* Gabriel Kerneis */ -/* Robert Norton-Wright */ -/* Christopher Pulte */ -/* Peter Sewell */ -/* Alasdair Armstrong */ -/* Brian Campbell */ -/* Thomas Bauereiss */ -/* Anthony Fox */ -/* Jon French */ -/* Dominic Mulligan */ -/* Stephen Kell */ -/* Mark Wassell */ -/* */ -/* 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. */ -/**************************************************************************/ - -%{ - -let r = fun x -> x (* Ulib.Text.of_latin1 *) - -%} - -/*Terminals with no content*/ - -%token Scattered Typedef Def Other Eof - -%token <string> Id -%start file -%type <string list> file - -%% - -id_found: - | Typedef Id - { $2 } - | Def Other Id - { $3 } - -skip: - | Scattered - { () } - | Id - { () } - | Other - { () } - -scan_file: - | id_found Eof - { [$1] } - | skip Eof - { [] } - | id_found scan_file - { $1::$2 } - | skip scan_file - { $2 } - -file: - | scan_file - { $1 } - diff --git a/src/pretty_print.ml b/src/pretty_print.ml index 8047ff32..8f0c0386 100644 --- a/src/pretty_print.ml +++ b/src/pretty_print.ml @@ -49,5 +49,4 @@ (**************************************************************************) include Pretty_print_lem_ast -include Pretty_print_sail include Pretty_print_lem diff --git a/src/pretty_print.mli b/src/pretty_print.mli index c01e0b93..b459926b 100644 --- a/src/pretty_print.mli +++ b/src/pretty_print.mli @@ -51,11 +51,6 @@ open Ast open Type_check -(* Prints the defs following source syntax *) -val pp_defs : out_channel -> 'a defs -> unit -val pp_exp : Buffer.t -> 'a exp -> unit -val pat_to_string : 'a pat -> string - (* Prints on formatter the defs as Lem Ast nodes *) val pp_lem_defs : Format.formatter -> tannot defs -> unit val pp_defs_lem : (out_channel * string list) -> (out_channel * string list) -> tannot defs -> string -> unit diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml index bad03034..254af4d7 100644 --- a/src/pretty_print_common.ml +++ b/src/pretty_print_common.ml @@ -49,7 +49,7 @@ (**************************************************************************) open Ast -open Big_int +module Big_int = Nat_big_num open PPrint let pipe = string "|" @@ -76,7 +76,7 @@ let comma_sp = comma ^^ space let colon_sp = spaces colon let doc_var (Kid_aux(Var v,_)) = string v -let doc_int i = string (string_of_big_int i) +let doc_int i = string (Big_int.to_string i) let doc_op symb a b = infix 2 1 symb a b let doc_unop symb a = prefix 2 1 symb a @@ -102,6 +102,8 @@ let doc_effect (BE_aux (e,_)) = | BE_wmem -> "wmem" | BE_wmv -> "wmv" | BE_wmvt -> "wmvt" + | BE_lset -> "lset" + | BE_lret -> "lret" | BE_eamem -> "eamem" | BE_exmem -> "exmem" | BE_barr -> "barr" @@ -112,7 +114,6 @@ let doc_effect (BE_aux (e,_)) = | BE_nondet -> "nondet") let doc_effects (Effect_aux(e,_)) = match e with - | Effect_var v -> doc_var v | Effect_set [] -> string "pure" | Effect_set s -> braces (separate_map comma_sp doc_effect s) @@ -134,51 +135,12 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = | Typ_tup typs -> parens (separate_map comma_sp app_typ typs) | _ -> app_typ ty and app_typ ((Typ_aux (t, _)) as ty) = match t with - (*TODO Need to un bid-endian-ify this here, since both can transform to the shorthand, especially with <: and :> *) - (* Special case simple vectors to improve legibility - * XXX we assume big-endian here, as usual *) -(* - | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant n, _)), _); - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant m, _)), _); - Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_inc, _)), _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> - (doc_id id) ^^ (brackets (if n = 0 then doc_int m else doc_op colon (doc_int n) (doc_int (n+m-1)))) - | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant n, _)), _); - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant m, _)), _); - Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_dec, _)), _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> - (doc_id id) ^^ (brackets (if n = m-1 then doc_int m else doc_op colon (doc_int n) (doc_int (m+1 -n)))) - | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux(Typ_arg_nexp - (Nexp_aux(Nexp_minus (Nexp_aux(Nexp_constant n, _), - Nexp_aux(Nexp_constant 1, _)),_)),_); - Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant m, _)), _); - Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_dec, _)), _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> - (doc_id id) ^^ (brackets (if n = m then doc_int m else doc_op colon (doc_int m) (doc_int (n-1)))) - | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux(Typ_arg_nexp - (Nexp_aux(Nexp_minus (n', Nexp_aux((Nexp_constant 1), _)),_) as n_n),_); - Typ_arg_aux(Typ_arg_nexp m_nexp, _); - Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_dec, _)), _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> - (doc_id id) ^^ (brackets (if n' = m_nexp then nexp m_nexp else doc_op colon (nexp m_nexp) (nexp n_n))) - | Typ_app(Id_aux (Id "vector", _), [ - Typ_arg_aux(Typ_arg_nexp - (Nexp_aux(Nexp_sum (n', Nexp_aux((Nexp_constant -1), _)),_) as n_n),_); - Typ_arg_aux(Typ_arg_nexp m_nexp, _); - Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_dec, _)), _); - Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> - (doc_id id) ^^ (brackets (if n' = m_nexp then nexp m_nexp else doc_op colon (nexp m_nexp) (nexp n_n))) - *) | Typ_app(Id_aux (Id "range", _), [ Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant n, _)), _); Typ_arg_aux(Typ_arg_nexp m, _);]) -> - (squarebars (if eq_big_int n zero_big_int then nexp m else doc_op colon (doc_int n) (nexp m))) + (squarebars (if Big_int.equal n Big_int.zero then nexp m else doc_op colon (doc_int n) (nexp m))) | Typ_app(Id_aux (Id "atom", _), [Typ_arg_aux(Typ_arg_nexp n,_)]) -> - (squarecolons (nexp n)) + (squarecolons (nexp n)) | Typ_app(id,args) -> (* trailing space to avoid >> token in case of nested app types *) (doc_id id) ^^ (angles (separate_map comma_sp doc_typ_arg args)) ^^ space @@ -186,7 +148,7 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = and atomic_typ ((Typ_aux (t, _)) as ty) = match t with | Typ_id id -> doc_id id | Typ_var v -> doc_var v - | Typ_app _ | Typ_tup _ | Typ_fn _ -> + | Typ_app _ | Typ_tup _ | Typ_fn _ | Typ_exist _ -> (* exhaustiveness matters here to avoid infinite loops * if we add a new Typ constructor *) group (parens (typ ty)) @@ -220,7 +182,8 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = and atomic_nexp_typ ((Nexp_aux(n,_)) as ne) = match n with | Nexp_var v -> doc_var v | Nexp_id i -> braces (doc_id i) - | Nexp_constant i -> if lt_big_int i zero_big_int then parens(doc_int i) else doc_int i + | Nexp_app (op, args) -> doc_id op ^^ parens (separate_map (comma ^^ space) nexp args) + | Nexp_constant i -> if Big_int.less i Big_int.zero then parens(doc_int i) else doc_int i | Nexp_neg _ | Nexp_exp _ | Nexp_times _ | Nexp_sum _ | Nexp_minus _-> group (parens (nexp ne)) diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 6a3d1293..0002f8cc 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -52,7 +52,6 @@ open Type_check open Ast open Ast_util open Rewriter -open Big_int open PPrint open Pretty_print_common @@ -152,27 +151,23 @@ let effectful_set = | BE_escape -> true | _ -> false) -let effectful (Effect_aux (eff,_)) = - match eff with - | Effect_var _ -> failwith "effectful: Effect_var not supported" - | Effect_set effs -> effectful_set effs +let effectful (Effect_aux (Effect_set effs, _)) = effectful_set effs let is_regtyp (Typ_aux (typ, _)) env = match typ with | Typ_app(id, _) when string_of_id id = "register" -> true - | Typ_id(id) when Env.is_regtyp id env -> true | _ -> false let doc_nexp_lem nexp = let (Nexp_aux (nexp, l) as full_nexp) = nexp_simp nexp in match nexp with - | Nexp_constant i -> string ("ty" ^ string_of_big_int i) + | Nexp_constant i -> string ("ty" ^ Big_int.to_string i) | Nexp_var v -> string (string_of_kid (orig_kid v)) | _ -> let rec mangle_nexp (Nexp_aux (nexp, _)) = begin match nexp with | Nexp_id id -> string_of_id id | Nexp_var kid -> string_of_id (id_of_kid (orig_kid kid)) - | Nexp_constant i -> Pretty_print_lem_ast.lemnum string_of_big_int i + | Nexp_constant i -> Pretty_print_lem_ast.lemnum Big_int.to_string i | Nexp_times (n1, n2) -> mangle_nexp n1 ^ "_times_" ^ mangle_nexp n2 | Nexp_sum (n1, n2) -> mangle_nexp n1 ^ "_plus_" ^ mangle_nexp n2 | Nexp_minus (n1, n2) -> mangle_nexp n1 ^ "_minus_" ^ mangle_nexp n2 @@ -369,10 +364,10 @@ let doc_lit_lem in_pat (L_aux(lit,l)) a = | L_false -> utf8string "false" | L_true -> utf8string "true" | L_num i -> - let ipp = string_of_big_int i in + let ipp = Big_int.to_string i in utf8string ( if in_pat then "("^ipp^":nn)" - else if lt_big_int i zero_big_int then "((0"^ipp^"):ii)" + else if Big_int.less i Big_int.zero then "((0"^ipp^"):ii)" else "("^ipp^":ii)") | L_hex n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0x" ^ n) ^ ")" (*shouldn't happen*)*) | L_bin n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0b" ^ n) ^ ")" (*shouldn't happen*)*) @@ -398,14 +393,14 @@ let doc_lit_lem in_pat (L_aux(lit,l)) a = using this would require adding a dependency on ZArith to Sail. *) let parts = Util.split_on_char '.' s in let (num, denom) = match parts with - | [i] -> (big_int_of_string i, unit_big_int) + | [i] -> (Big_int.of_string i, Big_int.of_int 1) | [i;f] -> - let denom = power_int_positive_int 10 (String.length f) in - (add_big_int (mult_big_int (big_int_of_string i) denom) (big_int_of_string f), denom) + let denom = Big_int.pow_int_positive 10 (String.length f) in + (Big_int.add (Big_int.mul (Big_int.of_string i) denom) (Big_int.of_string f), denom) | _ -> raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax_locn (l, "could not parse real literal"))) in - separate space (List.map string ["realFromFrac"; string_of_big_int num; string_of_big_int denom]) + separate space (List.map string ["realFromFrac"; Big_int.to_string num; Big_int.to_string denom]) (* typ_doc is the doc for the type being quantified *) let doc_quant_item vars_included (QI_aux (qi, _)) = match qi with @@ -735,18 +730,6 @@ let doc_exp_lem, doc_let_lem = | E_field((E_aux(_,(l,fannot)) as fexp),id) -> let ft = typ_of_annot (l,fannot) in (match fannot with - | Some(env, (Typ_aux (Typ_id tid, _)), _) - | Some(env, (Typ_aux (Typ_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id tid, _)), _)]), _)), _) - when Env.is_regtyp tid env -> - let t = (* Env.base_typ_of (env_of full_exp) *) (typ_of full_exp) in - let eff = effect_of full_exp in - let field_f = doc_id_lem tid ^^ underscore ^^ doc_id_lem id ^^ dot ^^ string "get_field" in - let (ta,aexp_needed) = - if typ_needs_printed t - then (doc_tannot_lem (effectful eff) t, true) - else (empty, aexp_needed) in - let epp = field_f ^^ space ^^ (expY fexp) in - if aexp_needed then parens (align epp ^^ ta) else (epp ^^ ta) | Some(env, (Typ_aux (Typ_id tid, _)), _) when Env.is_record tid env -> let fname = if prefix_recordtype @@ -802,7 +785,7 @@ let doc_exp_lem, doc_let_lem = "E_vector of non-vector type") in let dir,dir_out = if is_order_inc order then (true,"true") else (false, "false") in let start = match nexp_simp start with - | Nexp_aux (Nexp_constant i, _) -> string_of_big_int i + | Nexp_aux (Nexp_constant i, _) -> Big_int.to_string i | _ -> if dir then "0" else string_of_int (List.length exps) in let expspp = match exps with @@ -875,8 +858,8 @@ let doc_exp_lem, doc_let_lem = | E_app_infix (e1,id,e2) -> raise (Reporting_basic.err_unreachable l "E_app_infix should have been rewritten before pretty-printing") - | E_internal_let(lexp, eq_exp, in_exp) -> - raise (report l "E_internal_lets should have been removed before pretty-printing") + | E_var(lexp, eq_exp, in_exp) -> + raise (report l "E_vars should have been removed before pretty-printing") | E_internal_plet (pat,e1,e2) -> let epp = let b = match e1 with E_aux (E_if _,_) -> true | _ -> false in @@ -997,12 +980,12 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with raise (Reporting_basic.err_unreachable Parse_ast.Unknown ("register " ^ string_of_id id ^ " has non-constant start index " ^ string_of_nexp start)) with - | _ -> (zero_big_int, true) in + | _ -> (Big_int.zero, true) in doc_op equals (concat [string "let "; parens (concat [doc_id_lem id; underscore; doc_id_lem fid; rfannot])]) (anglebars (concat [space; doc_op equals (string "field_name") (string_lit (doc_id_lem fid)); semi_sp; - doc_op equals (string "field_start") (string (string_of_big_int start)); semi_sp; + doc_op equals (string "field_start") (string (Big_int.to_string start)); semi_sp; doc_op equals (string "field_is_inc") (string (if is_inc then "true" else "false")); semi_sp; doc_op equals (string "get_field") (parens (doc_op arrow (string "fun rec_val") get)); semi_sp; doc_op equals (string "set_field") (parens (doc_op arrow (string "fun rec_val v") set)); space])) in @@ -1191,36 +1174,6 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with fromInterpValuePP ^^ hardline ^^ hardline ^^ fromToInterpValuePP ^^ hardline else empty) - | TD_register(id,n1,n2,rs) -> - 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 - let dir_suffix = (if dir_b then "_inc" else "_dec") in - let ord = Ord_aux ((if dir_b then Ord_inc else Ord_dec), Parse_ast.Unknown) in - let size = if dir_b then add_big_int (sub_big_int i2 i1) unit_big_int else add_big_int (sub_big_int i1 i2) unit_big_int in - let vtyp = vector_typ (nconstant i1) (nconstant size) ord bit_typ in - let tannot = doc_tannot_lem false vtyp in - let doc_rid (r,id) = parens (separate comma_sp [string_lit (doc_id_lem id); - doc_range_lem r;]) in - let doc_rids = group (separate_map (semi ^^ (break 1)) doc_rid rs) in - doc_op equals - (concat [string "type";space;doc_id_lem id]) - (doc_typ_lem vtyp) - ^^ hardline ^^ - doc_op equals - (concat [string "let";space;string "cast_";doc_id_lem id;space;string "reg"]) - (string "reg") - ^^ hardline ^^ - doc_op equals - (concat [string "let";space;string "cast_to_";doc_id_lem id;space;string "reg"]) - (string "reg") - ^^ hardline ^^ - 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; string dir; - break 0 ^^ brackets (align doc_rids)])) | _ -> raise (Reporting_basic.err_unreachable l "register with non-constant indices") let args_of_typ l env typ = @@ -1377,29 +1330,22 @@ let doc_dec_lem (DEC_aux (reg, ((l, _) as annot))) = if !opt_sequential then empty else let env = env_of_annot annot in - (match typ with - | Typ_aux (Typ_id idt, _) when Env.is_regtyp idt env -> - separate space [string "let";doc_id_lem id;equals; - string "build_" ^^ string (string_of_id idt);string_lit (doc_id_lem id)] ^/^ hardline - | _ -> - let rt = Env.base_typ_of env typ in - if is_vector_typ rt then - let (start, size, order, etyp) = vector_typ_args_of rt in - if is_bit_typ etyp && is_nexp_constant start && is_nexp_constant size then - let o = if is_order_inc order then "true" else "false" in - (doc_op equals) - (string "let" ^^ space ^^ doc_id_lem id) - (string "Register" ^^ space ^^ - align (separate space [string_lit(doc_id_lem id); - doc_nexp (size); - doc_nexp (start); - string o; - string "[]"])) - ^/^ hardline - else raise (Reporting_basic.err_unreachable l - ("can't deal with register type " ^ string_of_typ typ)) - else raise (Reporting_basic.err_unreachable l - ("can't deal with register type " ^ string_of_typ typ))) + let rt = Env.base_typ_of env typ in + if is_vector_typ rt then + let (start, size, order, etyp) = vector_typ_args_of rt in + if is_bit_typ etyp && is_nexp_constant start && is_nexp_constant size then + let o = if is_order_inc order then "true" else "false" in + (doc_op equals) + (string "let" ^^ space ^^ doc_id_lem id) + (string "Register" ^^ space ^^ + align (separate space [string_lit(doc_id_lem id); + doc_nexp (size); + doc_nexp (start); + string o; + string "[]"])) + ^/^ hardline + else raise (Reporting_basic.err_unreachable l ("can't deal with register type " ^ string_of_typ typ)) + else raise (Reporting_basic.err_unreachable l ("can't deal with register type " ^ string_of_typ typ)) | DEC_alias(id,alspec) -> empty | DEC_typ_alias(typ,id,alspec) -> empty @@ -1412,15 +1358,6 @@ let doc_spec_lem (VS_aux (valspec,annot)) = (* | VS_val_spec (_,_,Some _,_) -> empty *) | _ -> empty -let find_regtypes defs = - List.fold_left - (fun acc def -> - match def with - | DEF_type (TD_aux(TD_register (Id_aux (Id tname, _), n1, n2, fields),_)) -> - (tname, (n1, n2, fields)) :: acc - | _ -> acc - ) [] defs - let is_field_accessor regtypes fdef = let is_field_of regtyp field = List.exists (fun (tname, (_, _, fields)) -> tname = regtyp && @@ -1443,11 +1380,11 @@ let doc_regtype_fields (tname, (n1, n2, fields)) = | BF_aux (BF_range (i, j), _) -> (i, j) | _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown ("Unsupported type in field " ^ string_of_id fid ^ " of " ^ tname)) in - let fsize = succ_big_int (abs_big_int (sub_big_int i j)) in + let fsize = Big_int.succ (Big_int.abs (Big_int.sub i j)) in (* TODO Assumes normalised, decreasing bitvector slices; however, since start indices or indexing order do not appear in Lem type annotations, this does not matter. *) - let ftyp = vector_typ (nconstant (pred_big_int fsize)) (nconstant fsize) dec_ord bit_typ in + let ftyp = vector_typ (nconstant fsize) dec_ord bit_typ in let reftyp = mk_typ (Typ_app (Id_aux (Id "field_ref", Parse_ast.Unknown), [mk_typ_arg (Typ_arg_typ (mk_id_typ (mk_id tname))); @@ -1457,7 +1394,7 @@ let doc_regtype_fields (tname, (n1, n2, fields)) = (concat [string "let "; parens (concat [string tname; underscore; doc_id_lem fid; rfannot])]) (concat [ space; langlebar; string " field_name = \"" ^^ doc_id_lem fid ^^ string "\";"; hardline; - space; space; space; string (" field_start = " ^ string_of_big_int i ^ ";"); hardline; + space; space; space; string (" field_start = " ^ Big_int.to_string i ^ ";"); hardline; space; space; space; string (" field_is_inc = " ^ dir ^ ";"); hardline; space; space; space; string (" get_field = get_" ^ tname ^ "_" ^ string_of_id fid ^ ";"); hardline; space; space; space; string (" set_field = set_" ^ tname ^ "_" ^ string_of_id fid ^ " "); ranglebar]) @@ -1491,7 +1428,7 @@ let rec doc_def_lem regtypes def = let doc_defs_lem (Defs defs) = - let regtypes = find_regtypes defs in + let regtypes = [] in let field_refs = separate_map hardline doc_regtype_fields regtypes in let (typdefs,valdefs) = List.split (List.map (doc_def_lem regtypes) defs) in (separate empty typdefs ^^ field_refs, separate empty valdefs) @@ -1564,10 +1501,10 @@ let doc_register_refs_lem registers = raise (Reporting_basic.err_unreachable Parse_ast.Unknown ("register " ^ string_of_id id ^ " has non-constant start index " ^ string_of_nexp start)) with - | _ -> (zero_big_int, true) in + | _ -> (Big_int.zero, true) in concat [string "let "; idd; string " = <|"; hardline; string " reg_name = \""; idd; string "\";"; hardline; - string " reg_start = "; string (string_of_big_int start); string ";"; hardline; + string " reg_start = "; string (Big_int.to_string start); string ";"; hardline; string " reg_is_inc = "; string (if is_inc then "true" else "false"); string ";"; hardline; string " read_from = (fun s -> s."; field; string ");"; hardline; string " write_to = (fun s v -> (<| s with "; field; string " = v |>)) |>"] in diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index 3b7a7345..21001f55 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -51,7 +51,6 @@ open Type_check open Ast open Format -open Big_int open Pretty_print_common (**************************************************************************** @@ -78,11 +77,11 @@ let base ppf s = fprintf ppf "%s" s let quot_string ppf s = fprintf ppf "\"%s\"" s let lemnum default n = - if le_big_int zero_big_int n && le_big_int n (big_int_of_int 128) then - "int" ^ string_of_big_int n - else if ge_big_int n zero_big_int then + if Big_int.less_equal Big_int.zero n && Big_int.less_equal n (Big_int.of_int 128) then + "int" ^ Big_int.to_string n + else if Big_int.greater_equal n Big_int.zero then default n - else ("(int0 - " ^ (default (abs_big_int n)) ^ ")") + else ("(int0 - " ^ (default (Big_int.abs n)) ^ ")") let pp_format_id (Id_aux(i,_)) = match i with @@ -151,7 +150,8 @@ and pp_format_nexp_lem (Nexp_aux(n,l)) = (match n with | Nexp_id(i) -> "(Nexp_id " ^ pp_format_id_lem i ^ ")" | Nexp_var(v) -> "(Nexp_var " ^ pp_format_var_lem v ^ ")" - | Nexp_constant(i) -> "(Nexp_constant " ^ (lemnum string_of_big_int i) ^ ")" + | Nexp_app(op,args) -> "(Nexp_app [" ^ Util.string_of_list ", " pp_format_nexp_lem args ^ "])" + | Nexp_constant(i) -> "(Nexp_constant " ^ (lemnum Big_int.to_string i) ^ ")" | Nexp_sum(n1,n2) -> "(Nexp_sum " ^ (pp_format_nexp_lem n1) ^ " " ^ (pp_format_nexp_lem n2) ^ ")" | Nexp_minus(n1,n2) -> "(Nexp_minus " ^ (pp_format_nexp_lem n1)^ " " ^ (pp_format_nexp_lem n2) ^ ")" | Nexp_times(n1,n2) -> "(Nexp_times " ^ (pp_format_nexp_lem n1) ^ " " ^ (pp_format_nexp_lem n2) ^ ")" @@ -189,7 +189,6 @@ and pp_format_base_effect_lem (BE_aux(e,l)) = and pp_format_effects_lem (Effect_aux(e,l)) = "(Effect_aux " ^ (match e with - | Effect_var(v) -> "(Effect_var " ^ pp_format_var v ^ ")" | Effect_set(efcts) -> "(Effect_set [" ^ (list_format "; " pp_format_base_effect_lem efcts) ^ " ])") ^ " " ^ @@ -215,7 +214,7 @@ and pp_format_nexp_constraint_lem (NC_aux(nc,l)) = | NC_set(id,bounds) -> "(NC_set " ^ pp_format_var_lem id ^ " [" ^ - list_format "; " string_of_big_int bounds ^ + list_format "; " Big_int.to_string bounds ^ "])") ^ " " ^ (pp_format_l_lem l) ^ ")" @@ -278,7 +277,7 @@ let pp_format_lit_lem (L_aux(lit,l)) = | L_one -> "L_one" | L_true -> "L_true" | L_false -> "L_false" - | L_num(i) -> "(L_num " ^ (lemnum string_of_big_int i) ^ ")" + | L_num(i) -> "(L_num " ^ (lemnum Big_int.to_string i) ^ ")" | L_hex(n) -> "(L_hex \"" ^ n ^ "\")" | L_bin(n) -> "(L_bin \"" ^ n ^ "\")" | L_undef -> "L_undef" @@ -356,6 +355,7 @@ and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = (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_tag (tag_id id env)) annot + | E_ref(id) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_ref" 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 @@ -408,6 +408,9 @@ and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = | E_case(exp,pexps) -> fprintf ppf "@[<0>(E_aux (E_case %a [%a]) (%a, %a))@]" pp_lem_exp exp (list_pp pp_semi_lem_case pp_lem_case) pexps pp_lem_l l pp_annot annot + | E_try(exp,pexps) -> + fprintf ppf "@[<0>(E_aux (E_try %a [%a]) (%a, %a))@]" + pp_lem_exp exp (list_pp pp_semi_lem_case pp_lem_case) pexps pp_lem_l l pp_annot annot | E_let(leb,exp) -> fprintf ppf "@[<0>(E_aux (E_let %a %a) (%a, %a))@]" pp_lem_let leb pp_lem_exp exp pp_lem_l l pp_annot annot | E_assign(lexp,exp) -> fprintf ppf "@[<0>(E_aux (E_assign %a %a) (%a, %a))@]" @@ -418,38 +421,20 @@ and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = fprintf ppf "@[<0>(E_aux (E_constraint %a) (%a, %a))@]" pp_lem_nexp_constraint nc pp_lem_l l pp_annot annot | E_exit exp -> fprintf ppf "@[<0>(E_aux (E_exit %a) (%a, %a))@]" pp_lem_exp exp pp_lem_l l pp_annot annot + | E_throw exp -> + fprintf ppf "@[<0>(E_aux (E_throw %a) (%a, %a))@]" pp_lem_exp exp pp_lem_l l pp_annot annot | E_return exp -> fprintf ppf "@[<0>(E_aux (E_return %a) (%a, %a))@]" pp_lem_exp exp pp_lem_l l pp_annot annot | E_assert(c,msg) -> fprintf ppf "@[<0>(E_aux (E_assert %a %a) (%a, %a))@]" pp_lem_exp c pp_lem_exp msg pp_lem_l l pp_annot annot - (* - | E_internal_exp ((l, Base((_,t),_,_,_,_,bindings))) -> - (*TODO use bindings where appropriate*) - (match t.t with - | Tapp("register",[TA_typ {t=Tapp("vector",[TA_nexp _;TA_nexp r;_;_])}]) - | Tapp("vector",[TA_nexp _;TA_nexp r;_;_]) -> - (match r.nexp with - | Nconst bi -> fprintf ppf "@[<0>(E_aux (E_lit (L_aux (L_num %a) %a)) (%a, %a))@]" - kwd (lemnum string_of_int (int_of_big_int bi)) pp_lem_l l pp_lem_l l pp_annot (Base(([],nat_t),Emp_local,[],pure_e,pure_e,nob)) - | Nvar v -> fprintf ppf "@[<0>(E_aux (E_id (Id_aux (Id \"%a\") %a)) (%a,%a))@]" - kwd v pp_lem_l l pp_lem_l l pp_annot (Base(([],nat_t),Emp_local,[],pure_e,pure_e,nob)) - | _ -> raise (Reporting_basic.err_unreachable l "Internal exp given vector without known length")) - | Tapp("implicit",[TA_nexp r]) -> - (match r.nexp with - | Nconst bi -> fprintf ppf "@[<0>(E_aux (E_lit (L_aux (L_num %a) %a)) (%a, %a))@]" - kwd (lemnum string_of_int (int_of_big_int bi)) pp_lem_l l pp_lem_l l pp_annot (Base(([],nat_t),Emp_local,[],pure_e,pure_e,nob)) - | Nvar v -> fprintf ppf "@[<0>(E_aux (E_id (Id_aux (Id \"%a\") %a)) (%a,%a))@]" - kwd v pp_lem_l l pp_lem_l l pp_annot (Base(([],nat_t),Emp_local,[],pure_e,pure_e,nob)) - | _ -> raise (Reporting_basic.err_unreachable l "Internal_exp given implicit without variable or const")) - | _ -> raise (Reporting_basic.err_unreachable l "Internal exp given non-vector or implicit")*) | E_comment _ | E_comment_struc _ -> fprintf ppf "@[(E_aux (E_lit (L_aux L_unit %a)) (%a,%a))@]" pp_lem_l l pp_lem_l l pp_annot annot | E_internal_cast _ | E_internal_exp _ -> raise (Reporting_basic.err_unreachable l "Found internal cast or exp") | E_internal_exp_user _ -> (raise (Reporting_basic.err_unreachable l "Found non-rewritten internal_exp_user")) | E_sizeof_internal _ -> (raise (Reporting_basic.err_unreachable l "Internal sizeof not removed")) - | E_internal_let (lexp,exp1,exp2) -> - fprintf ppf "@[<0>(E_aux (E_internal_let %a %a %a) (%a, %a))@]" + | E_var (lexp,exp1,exp2) -> + fprintf ppf "@[<0>(E_aux (E_var %a %a %a) (%a, %a))@]" pp_lem_lexp lexp pp_lem_exp exp1 pp_lem_exp exp2 pp_lem_l l pp_annot annot | E_internal_return exp -> fprintf ppf "@[<0>(E_aux (E_internal_return %a) (%a, %a))@]" @@ -457,6 +442,7 @@ and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = | E_internal_plet (pat,exp1,exp2) -> fprintf ppf "@[<0>(E_aux (E_internal_plet %a %a %a) (%a, %a))@]" pp_lem_pat pat pp_lem_exp exp1 pp_lem_exp exp2 pp_lem_l l pp_annot annot + | E_internal_value _ -> raise (Reporting_basic.err_unreachable l "Found internal_value") in print_e ppf e @@ -476,15 +462,17 @@ 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))) = let print_le ppf lexp = match lexp with - | LEXP_id(id) -> fprintf ppf "(%a %a)" kwd "LEXP_id" pp_lem_id id - | LEXP_memory(id,args) -> - fprintf ppf "(LEXP_memory %a [%a])" pp_lem_id id (list_pp pp_semi_lem_exp pp_lem_exp) args - | LEXP_cast(typ,id) -> fprintf ppf "(LEXP_cast %a %a)" pp_lem_typ typ pp_lem_id id - | LEXP_tup tups -> fprintf ppf "(LEXP_tup [%a])" (list_pp pp_semi_lem_lexp pp_lem_lexp) tups - | LEXP_vector(v,exp) -> fprintf ppf "@[(%a %a %a)@]" kwd "LEXP_vector" pp_lem_lexp v pp_lem_exp exp - | LEXP_vector_range(v,e1,e2) -> - fprintf ppf "@[(%a %a %a %a)@]" kwd "LEXP_vector_range" pp_lem_lexp v pp_lem_exp e1 pp_lem_exp e2 - | LEXP_field(v,id) -> fprintf ppf "@[(%a %a %a)@]" kwd "LEXP_field" pp_lem_lexp v pp_lem_id id + | LEXP_id(id) -> fprintf ppf "(%a %a)" kwd "LEXP_id" pp_lem_id id + | LEXP_deref exp -> + fprintf ppf "(LEXP_deref %a)" pp_lem_exp exp + | LEXP_memory(id,args) -> + fprintf ppf "(LEXP_memory %a [%a])" pp_lem_id id (list_pp pp_semi_lem_exp pp_lem_exp) args + | LEXP_cast(typ,id) -> fprintf ppf "(LEXP_cast %a %a)" pp_lem_typ typ pp_lem_id id + | LEXP_tup tups -> fprintf ppf "(LEXP_tup [%a])" (list_pp pp_semi_lem_lexp pp_lem_lexp) tups + | LEXP_vector(v,exp) -> fprintf ppf "@[(%a %a %a)@]" kwd "LEXP_vector" pp_lem_lexp v pp_lem_exp exp + | LEXP_vector_range(v,e1,e2) -> + fprintf ppf "@[(%a %a %a %a)@]" kwd "LEXP_vector_range" pp_lem_lexp v pp_lem_exp e1 pp_lem_exp e2 + | LEXP_field(v,id) -> fprintf ppf "@[(%a %a %a)@]" kwd "LEXP_field" pp_lem_lexp v pp_lem_id id in fprintf ppf "@[(LEXP_aux %a (%a, %a))@]" print_le lexp pp_lem_l l pp_annot annot and pp_semi_lem_lexp ppf le = fprintf ppf "@[<1>%a%a@]" pp_lem_lexp le kwd ";" @@ -502,12 +490,8 @@ let pp_lem_default ppf (DT_aux(df,l)) = (* FIXME *) let pp_lem_spec ppf (VS_aux(v,(l,annot))) = - let print_spec ppf v = - match v with - | VS_val_spec(ts,id,ext_opt,is_cast) -> - (* FIXME: None *) - fprintf ppf "@[<0>(%a %a %a %a %a)@]@\n" kwd "VS_val_spec" pp_lem_typscm ts pp_lem_id id (pp_option_lem quot_string) None pp_bool_lem is_cast - | _ -> failwith "Invalid valspec" + let print_spec ppf (VS_val_spec(ts, id, ext_opt, is_cast)) = + fprintf ppf "@[<0>(%a %a %a %a %a)@]@\n" kwd "VS_val_spec" pp_lem_typscm ts pp_lem_id id (pp_option_lem quot_string) None pp_bool_lem is_cast in fprintf ppf "@[<0>(VS_aux %a (%a, %a))@]" print_spec v pp_lem_l l pp_annot annot @@ -518,8 +502,8 @@ let pp_lem_namescm ppf (Name_sect_aux(ns,l)) = let rec pp_lem_range ppf (BF_aux(r,l)) = match r with - | BF_single(i) -> fprintf ppf "(BF_aux (BF_single %i) %a)" (int_of_big_int i) pp_lem_l l - | BF_range(i1,i2) -> fprintf ppf "(BF_aux (BF_range %i %i) %a)" (int_of_big_int i1) (int_of_big_int i2) pp_lem_l l + | BF_single(i) -> fprintf ppf "(BF_aux (BF_single %i) %a)" (Big_int.to_int i) pp_lem_l l + | BF_range(i1,i2) -> fprintf ppf "(BF_aux (BF_range %i %i) %a)" (Big_int.to_int i1) (Big_int.to_int i2) pp_lem_l l | BF_concat(ir1,ir2) -> fprintf ppf "(BF_aux (BF_concat %a %a) %a)" pp_lem_range ir1 pp_lem_range ir2 pp_lem_l l let pp_lem_typdef ppf (TD_aux(td,(l,annot))) = @@ -545,11 +529,11 @@ let pp_lem_typdef ppf (TD_aux(td,(l,annot))) = let pp_id_semi ppf id = fprintf ppf "%a%a " pp_lem_id id kwd ";" in fprintf ppf "@[<0>(%a %a %a [%a] false)@]" kwd "TD_enum" pp_lem_id id pp_lem_namescm ns (list_pp pp_id_semi pp_lem_id) enums - | TD_register(id,n1,n2,rs) -> - let pp_rid ppf (r,id) = fprintf ppf "(%a, %a)%a " pp_lem_range r pp_lem_id id kwd ";" in + | TD_bitfield(id,typ,rs) -> + let pp_rid ppf (id, r) = fprintf ppf "(%a, %a)%a " pp_lem_range r pp_lem_id id kwd ";" in let pp_rids = (list_pp pp_rid pp_rid) in - fprintf ppf "@[<0>(%a %a %a %a [%a])@]" - kwd "TD_register" pp_lem_id id pp_lem_nexp n1 pp_lem_nexp n2 pp_rids rs + fprintf ppf "@[<0>(%a %a %a [%a])@]" + kwd "TD_bitfield" pp_lem_id id pp_lem_typ typ pp_rids rs in fprintf ppf "@[<0>(TD_aux %a (%a, %a))@]" print_td td pp_lem_l l pp_annot annot @@ -626,7 +610,7 @@ let rec pp_lem_def ppf d = | DEF_val(lbind) -> fprintf ppf "(DEF_val %a);@\n" pp_lem_let lbind | DEF_reg_dec(dec) -> fprintf ppf "(DEF_reg_dec %a);@\n" pp_lem_dec dec | DEF_comm d -> fprintf ppf "" - | DEF_fixity (prec, n, id) -> fprintf ppf "(DEF_fixity %a %s %a);@\n" pp_lem_prec prec (lemnum string_of_big_int n) pp_lem_id id + | DEF_fixity (prec, n, id) -> fprintf ppf "(DEF_fixity %a %s %a);@\n" pp_lem_prec prec (lemnum Big_int.to_string n) pp_lem_id id | DEF_internal_mutrec f_defs -> List.iter (fun f_def -> pp_lem_def ppf (DEF_fundef f_def)) f_defs | _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "initial_check didn't remove all scattered Defs") diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 3868502b..930da39c 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -50,45 +50,146 @@ open Ast open Ast_util -open Big_int open PPrint -open Pretty_print_common - -(**************************************************************************** - * PPrint-based source-to-source pretty printer -****************************************************************************) - -let doc_bkind (BK_aux(k,_)) = - string (match k with - | BK_type -> "Type" - | BK_nat -> "Nat" - | BK_order -> "Order") - -let doc_kind (K_aux(K_kind(klst),_)) = - separate_map (spaces arrow) doc_bkind klst - -let doc_qi (QI_aux(qi,_)) = match qi with - | QI_const n_const -> doc_nexp_constraint n_const - | QI_id(KOpt_aux(ki,_)) -> - match ki with - | KOpt_none v -> doc_var v - | KOpt_kind(k,v) -> separate space [doc_kind k; doc_var v] - -(* typ_doc is the doc for the type being quantified *) -let doc_typquant (TypQ_aux(tq,_)) typ_doc = match tq with - | TypQ_no_forall -> typ_doc - | TypQ_tq [] -> typ_doc - | TypQ_tq qlist -> - (* include trailing break because the caller doesn't know if tq is empty *) - doc_op dot - (separate space [string "forall"; separate_map comma_sp doc_qi qlist]) - typ_doc - -let doc_typscm (TypSchm_aux(TypSchm_ts(tq,t),_)) = - (doc_typquant tq (doc_typ t)) - -let doc_typscm_atomic (TypSchm_aux(TypSchm_ts(tq,t),_)) = - (doc_typquant tq (doc_atomic_typ t)) + +module Big_int = Nat_big_num + +let doc_op symb a b = infix 2 1 symb a b + +let doc_id (Id_aux (id_aux, _)) = + string (match id_aux with + | Id v -> v + | DeIid op -> "operator " ^ op) + +let doc_kid kid = string (Ast_util.string_of_kid kid) + +let doc_int n = string (Big_int.to_string n) + +let doc_ord (Ord_aux(o,_)) = match o with + | Ord_var v -> doc_kid v + | Ord_inc -> string "inc" + | Ord_dec -> string "dec" + +let rec doc_nexp = + let rec atomic_nexp (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_constant c -> string (Big_int.to_string c) + | Nexp_id id -> doc_id id + | Nexp_var kid -> doc_kid kid + | _ -> parens (nexp0 nexp) + and nexp0 (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_sum (n1, Nexp_aux (Nexp_neg n2, _)) | Nexp_minus (n1, n2) -> + separate space [nexp0 n1; string "-"; nexp1 n2] + | Nexp_sum (n1, Nexp_aux (Nexp_constant c, _)) when Big_int.less c Big_int.zero -> + separate space [nexp0 n1; string "-"; doc_int (Big_int.abs c)] + | Nexp_sum (n1, n2) -> separate space [nexp0 n1; string "+"; nexp1 n2] + | _ -> nexp1 nexp + and nexp1 (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_times (n1, n2) -> separate space [nexp1 n1; string "*"; nexp2 n2] + | _ -> nexp2 nexp + and nexp2 (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_neg n -> separate space [string "-"; atomic_nexp n] + | Nexp_exp n -> separate space [string "2"; string "^"; atomic_nexp n] + | _ -> atomic_nexp nexp + in + nexp0 + +let doc_nc = + let nc_op op n1 n2 = separate space [doc_nexp n1; string op; doc_nexp n2] in + let rec atomic_nc (NC_aux (nc_aux, _) as nc) = + match nc_aux with + | NC_true -> string "true" + | NC_false -> string "false" + | NC_equal (n1, n2) -> nc_op "=" n1 n2 + | NC_not_equal (n1, n2) -> nc_op "!=" n1 n2 + | NC_bounded_ge (n1, n2) -> nc_op ">=" n1 n2 + | NC_bounded_le (n1, n2) -> nc_op "<=" n1 n2 + | NC_set (kid, ints) -> + separate space [doc_kid kid; string "in"; braces (separate_map (comma ^^ space) doc_int ints)] + | _ -> parens (nc0 nc) + and nc0 (NC_aux (nc_aux, _) as nc) = + match nc_aux with + | NC_or (c1, c2) -> separate space [nc0 c1; string "|"; nc1 c2] + | _ -> nc1 nc + and nc1 (NC_aux (nc_aux, _) as nc) = + match nc_aux with + | NC_and (c1, c2) -> separate space [nc1 c1; string "&"; atomic_nc c2] + | _ -> atomic_nc nc + in + nc0 + +let rec doc_typ (Typ_aux (typ_aux, _)) = + match typ_aux with + | Typ_id id -> doc_id id + | Typ_app (id, []) -> doc_id id + | Typ_app (Id_aux (DeIid str, _), [x; y]) -> + separate space [doc_typ_arg x; doc_typ_arg y] + (* + | Typ_app (id, [_; len; _; Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id tid, _)), _)]) when Id.compare (mk_id "vector") id == 0 && Id.compare (mk_id "bit") tid == 0-> + string "bits" ^^ parens (doc_typ_arg len) + *) + | Typ_app (id, typs) -> doc_id id ^^ parens (separate_map (string ", ") doc_typ_arg typs) + | Typ_tup typs -> parens (separate_map (string ", ") doc_typ typs) + | Typ_var kid -> doc_kid kid + (* Resugar set types like {|1, 2, 3|} *) + | Typ_exist ([kid1], NC_aux (NC_set (kid2, ints), _), Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid3, _)), _)]), _)) + when Kid.compare kid1 kid2 == 0 && Kid.compare kid2 kid3 == 0 && Id.compare (mk_id "atom") id == 0 -> + enclose (string "{|") (string "|}") (separate_map (string ", ") doc_int ints) + | Typ_exist (kids, nc, typ) -> + braces (separate_map space doc_kid kids ^^ comma ^^ space ^^ doc_nc nc ^^ dot ^^ space ^^ doc_typ typ) + | Typ_fn (typ1, typ2, Effect_aux (Effect_set [], _)) -> + separate space [doc_typ typ1; string "->"; doc_typ typ2] + | Typ_fn (typ1, typ2, Effect_aux (Effect_set effs, _)) -> + let ocaml_eff = braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs)) in + separate space [doc_typ typ1; string "->"; doc_typ typ2; string "effect"; ocaml_eff] +and doc_typ_arg (Typ_arg_aux (ta_aux, _)) = + match ta_aux with + | Typ_arg_typ typ -> doc_typ typ + | Typ_arg_nexp nexp -> doc_nexp nexp + | Typ_arg_order o -> doc_ord o + +let doc_quants quants = + let doc_qi_kopt (QI_aux (qi_aux, _)) = + match qi_aux with + | QI_id (KOpt_aux (KOpt_none kid, _)) -> [doc_kid kid] + | QI_id kopt when is_nat_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Int"])] + | QI_id kopt when is_typ_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"])] + | QI_id kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"])] + | QI_const nc -> [] + in + let qi_nc (QI_aux (qi_aux, _)) = + match qi_aux with + | QI_const nc -> [nc] + | _ -> [] + in + let kdoc = separate space (List.concat (List.map doc_qi_kopt quants)) in + let ncs = List.concat (List.map qi_nc quants) in + match ncs with + | [] -> kdoc + | [nc] -> kdoc ^^ comma ^^ space ^^ doc_nc nc + | nc :: ncs -> kdoc ^^ comma ^^ space ^^ doc_nc (List.fold_left nc_and nc ncs) + + + +let doc_binding (TypQ_aux (tq_aux, _), typ) = + match tq_aux with + | TypQ_no_forall -> doc_typ typ + | TypQ_tq [] -> doc_typ typ + | TypQ_tq qs -> + string "forall" ^^ space ^^ doc_quants qs ^^ dot ^//^ doc_typ typ + +let doc_typschm (TypSchm_aux (TypSchm_ts (typq, typ), _)) = doc_binding (typq, typ) + +let doc_typschm_typ (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = doc_typ typ + +let doc_typschm_quants (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = + match tq_aux with + | TypQ_no_forall -> None + | TypQ_tq [] -> None + | TypQ_tq qs -> Some (doc_quants qs) let doc_lit (L_aux(l,_)) = utf8string (match l with @@ -97,473 +198,343 @@ let doc_lit (L_aux(l,_)) = | L_one -> "bitone" | L_true -> "true" | L_false -> "false" - | L_num i -> string_of_big_int i + | L_num i -> Big_int.to_string i | L_hex n -> "0x" ^ n | L_bin n -> "0b" ^ n | L_real r -> r | L_undef -> "undefined" | L_string s -> "\"" ^ String.escaped s ^ "\"") -let doc_pat, doc_atomic_pat = - let rec pat pa = pat_colons pa - and pat_colons ((P_aux(p,l)) as pa) = match p with - (* XXX add leading indentation if not flat - we need to define our own - * combinator for that *) - | P_vector_concat pats -> separate_map (space ^^ colon ^^ break 1) atomic_pat pats - | _ -> app_pat pa - and app_pat ((P_aux(p,l)) as pa) = match p with - | P_app(id, ((_ :: _) as pats)) -> doc_unop (doc_id id) (parens (separate_map comma_sp atomic_pat pats)) - | _ -> atomic_pat pa - and atomic_pat ((P_aux(p,(l,annot))) as pa) = match p with - | P_lit lit -> doc_lit lit - | P_wild -> underscore +let rec doc_pat (P_aux (p_aux, _) as pat) = + match p_aux with | P_id id -> doc_id id + | P_tup pats -> lparen ^^ separate_map (comma ^^ space) doc_pat pats ^^ rparen + | P_typ (typ, pat) -> separate space [doc_pat pat; colon; doc_typ typ] + | P_lit lit -> doc_lit lit + (* P_var short form sugar *) | P_var (P_aux (P_id id, _), kid) when Id.compare (id_of_kid kid) id == 0 -> - doc_var kid - | P_var(p,kid) -> parens (separate space [pat p; string "as"; doc_var kid]) - | P_as(p,id) -> parens (separate space [pat p; string "as"; doc_id id]) - | P_typ(typ,p) -> separate space [parens (doc_typ typ); atomic_pat p] - | P_app(id,[]) -> doc_id id - | P_record(fpats,_) -> braces (separate_map semi_sp fpat fpats) - | P_vector pats -> brackets (separate_map comma_sp atomic_pat pats) - | P_tup pats -> parens (separate_map comma_sp atomic_pat pats) - | P_list pats -> squarebarbars (separate_map semi_sp atomic_pat pats) - | P_cons (pat1, pat2) -> separate space [atomic_pat pat1; coloncolon; pat pat2] - | P_app(_, _ :: _) | P_vector_concat _ -> - group (parens (pat pa)) - and fpat (FP_aux(FP_Fpat(id,fpat),_)) = doc_op equals (doc_id id) (pat fpat) - and npat (i,p) = doc_op equals (doc_int i) (pat p) - - (* expose doc_pat and doc_atomic_pat *) - in pat, atomic_pat - -let doc_exp, doc_let = - let rec exp e = group (or_exp e) - and or_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ("|" | "||"),_) as op),r) -> - doc_op (doc_id op) (and_exp l) (or_exp r) - | _ -> and_exp expr - and and_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ("&" | "&&"),_) as op),r) -> - doc_op (doc_id op) (eq_exp l) (and_exp r) - | _ -> eq_exp expr - and eq_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ( - (* XXX this is not very consistent - is the parser bogus here? *) - "=" | "==" | "!=" - | ">=" | ">=_s" | ">=_u" | ">" | ">_s" | ">_u" - | "<=" | "<=_s" | "<" | "<_s" | "<_si" | "<_u" - ),_) as op),r) -> - doc_op (doc_id op) (eq_exp l) (at_exp r) - (* XXX assignment should not have the same precedence as equal etc. *) - | E_assign(le,exp) -> doc_op coloneq (doc_lexp le) (at_exp exp) - | _ -> at_exp expr - and at_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ("@" | "^^" | "^" | "~^"),_) as op),r) -> - doc_op (doc_id op) (cons_exp l) (at_exp r) - | _ -> cons_exp expr - and cons_exp ((E_aux(e,_)) as expr) = match e with - | E_vector_append(l,r) -> - doc_op colon (shift_exp l) (cons_exp r) - | E_cons(l,r) -> - doc_op coloncolon (shift_exp l) (cons_exp r) - | _ -> shift_exp expr - and shift_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id (">>" | ">>>" | "<<" | "<<<"),_) as op),r) -> - doc_op (doc_id op) (shift_exp l) (plus_exp r) - | _ -> plus_exp expr - and plus_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ("+" | "-" | "+_s" | "-_s"),_) as op),r) -> - doc_op (doc_id op) (plus_exp l) (star_exp r) - | _ -> star_exp expr - and star_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id ( - "*" | "/" - | "div" | "quot" | "quot_s" | "rem" | "mod" - | "*_s" | "*_si" | "*_u" | "*_ui"),_) as op),r) -> - doc_op (doc_id op) (star_exp l) (starstar_exp r) - | _ -> starstar_exp expr - and starstar_exp ((E_aux(e,_)) as expr) = match e with - | E_app_infix(l,(Id_aux(Id "**",_) as op),r) -> - doc_op (doc_id op) (starstar_exp l) (app_exp r) - | E_if _ | E_for _ | E_loop _ | E_let _ - | E_internal_let _ | E_internal_plet _ -> right_atomic_exp expr - | _ -> app_exp expr - and right_atomic_exp ((E_aux(e,_)) as expr) = match e with - (* Special case: omit "else ()" when the else branch is empty. *) - | E_if(c,t,E_aux(E_block [], _)) -> - string "if" ^^ space ^^ group (exp c) ^/^ - string "then" ^^ space ^^ group (exp t) - | E_if(c,t,e) -> - string "if" ^^ space ^^ group (exp c) ^/^ - string "then" ^^ space ^^ group (exp t) ^/^ - string "else" ^^ space ^^ group (exp e) - | E_loop (While, c, e) -> - separate space [string "while"; atomic_exp c; string "do"] ^/^ - exp e - | E_loop (Until, c, e) -> - (string "repeat" - ^/^ exp e) - ^/^ (string "until" ^^ space ^^ atomic_exp c) - | E_for(id,exp1,exp2,exp3,order,exp4) -> - string "foreach" ^^ space ^^ - group (parens ( - separate (break 1) [ - doc_id id; - string "from " ^^ atomic_exp exp1; - string "to " ^^ atomic_exp exp2; - string "by " ^^ atomic_exp exp3; - string "in " ^^ doc_ord order - ] - )) ^/^ - exp exp4 - | E_let(leb,e) -> doc_op (string "in") (let_exp leb) (exp e) - | E_internal_let (lexp, exp1, exp2) -> - let le = - prefix 2 1 - (separate space [string "internal_let"; doc_lexp lexp; equals]) - (exp exp1) in - doc_op (string "in") le (exp exp2) + doc_kid kid + | P_var (pat, kid) -> separate space [doc_pat pat; string "as"; doc_kid kid] + | P_vector pats -> brackets (separate_map (comma ^^ space) doc_pat pats) + | P_vector_concat pats -> separate_map (space ^^ string "@" ^^ space) doc_pat pats + | P_wild -> string "_" + | P_as (pat, id) -> separate space [doc_pat pat; string "as"; doc_id id] + | P_app (id, pats) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_pat pats) + | _ -> string (string_of_pat pat) + +(* if_block_x is true if x should be printed like a block, i.e. with + newlines. Blocks are automatically printed as blocks, so this + returns false for them. *) +let if_block_then (E_aux (e_aux, _)) = + match e_aux with + | E_assign _ | E_if _ -> true + | _ -> false + +let if_block_else (E_aux (e_aux, _)) = + match e_aux with + | E_assign _ -> true + | _ -> false + +let fixities = + let fixities' = + List.fold_left + (fun r (x, y) -> Bindings.add x y r) + Bindings.empty + [ + (mk_id "^", (InfixR, 8)); + (mk_id "*", (InfixL, 7)); + (mk_id "+", (InfixL, 6)); + (mk_id "-", (InfixL, 6)); + (mk_id "!=", (Infix, 4)); + (mk_id ">", (Infix, 4)); + (mk_id "<", (Infix, 4)); + (mk_id ">=", (Infix, 4)); + (mk_id "<=", (Infix, 4)); + (mk_id "&", (InfixR, 3)); + (mk_id "|", (InfixR, 2)); + ] + in + ref (fixities' : (prec * int) Bindings.t) + +let rec doc_exp (E_aux (e_aux, _) as exp) = + match e_aux with + | E_block [] -> string "()" + | E_block [exp] -> doc_exp exp + | E_block exps -> surround 2 0 lbrace (doc_block exps) rbrace + | E_nondet exps -> assert false + (* This is mostly for the -convert option *) + | E_app_infix (x, id, y) when Id.compare (mk_id "quot") id == 0 -> + separate space [doc_atomic_exp x; string "/"; doc_atomic_exp y] + | E_app_infix _ -> doc_infix 0 exp + | E_tuple exps -> parens (separate_map (comma ^^ space) doc_exp exps) + + (* Various rules to try to format if blocks nicely based on content *) + | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp && if_block_else else_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) + ^/^ (string "else" ^//^ doc_exp else_exp) + | E_if (if_exp, then_exp, (E_aux (E_if _, _) as else_exp)) when if_block_then then_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) + ^/^ (string "else" ^^ space ^^ doc_exp else_exp) + | E_if (if_exp, then_exp, else_exp) when if_block_else else_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp]) + ^^ space ^^ (string "else" ^//^ doc_exp else_exp) + | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) + ^/^ (string "else" ^^ space ^^ doc_exp else_exp) + | E_if (if_exp, then_exp, else_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 -> 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) -> + 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] + | 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_plet (pat, exp1, exp2) -> let le = prefix 2 1 (separate space [string "internal_plet"; doc_pat pat; equals]) - (exp exp1) in - doc_op (string "in") le (exp exp2) - | _ -> group (parens (exp expr)) - and app_exp ((E_aux(e,_)) as expr) = match e with - | E_app(f,args) -> - (doc_id f) ^^ (parens (separate_map comma exp args)) - | _ -> vaccess_exp expr - and vaccess_exp ((E_aux(e,_)) as expr) = match e with - | E_vector_access(v,e) -> - atomic_exp v ^^ brackets (exp e) - | E_vector_subrange(v,e1,e2) -> - atomic_exp v ^^ brackets (doc_op dotdot (exp e1) (exp e2)) - | _ -> field_exp expr - and field_exp ((E_aux(e,_)) as expr) = match e with - | E_field(fexp,id) -> atomic_exp fexp ^^ dot ^^ doc_id id - | _ -> atomic_exp expr - and atomic_exp ((E_aux(e,_)) as expr) = match e with - (* Special case: an empty block is equivalent to unit, but { } would - * be parsed as a struct. *) - | E_block [] -> string "()" - | E_block exps -> - let exps_doc = separate_map (semi ^^ hardline) exp exps in - surround 2 1 lbrace exps_doc rbrace - | E_nondet exps -> - let exps_doc = separate_map (semi ^^ hardline) exp exps in - string "nondet" ^^ space ^^ (surround 2 1 lbrace exps_doc rbrace) - | E_comment s -> string ("(*" ^ s ^ "*) ()") - | E_comment_struc e -> string "(*" ^^ exp e ^^ string "*) ()" - | E_id id -> doc_id id + (doc_exp exp1) in + doc_op (string "in") le (doc_exp exp2) + | E_var (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) -> + begin + let header = + string "foreach" ^^ space ^^ + group (parens (separate (break 1) + [ doc_id id; + string "from " ^^ doc_atomic_exp exp1; + string "to " ^^ doc_atomic_exp exp2; + string "by " ^^ doc_atomic_exp exp3; + string "in " ^^ doc_ord order ])) + in + match exp4 with + | E_aux (E_block [_], _) -> header ^//^ doc_exp exp4 + | E_aux (E_block _, _) -> header ^^ space ^^ doc_exp exp4 + | _ -> header ^//^ doc_exp exp4 + end + (* Resugar an assert with an empty message *) + | E_throw exp -> string "throw" ^^ parens (doc_exp exp) + | E_try (exp, pexps) -> + separate space [string "try"; doc_exp exp; string "catch"; doc_pexps pexps] + | E_return exp -> string "return" ^^ parens (doc_exp exp) + | E_internal_return exp -> string "internal_return" ^^ parens (doc_exp exp) + | E_app (id, [exp]) when Id.compare (mk_id "pow2") id == 0 -> + separate space [string "2"; string "^"; doc_atomic_exp exp] + | _ -> doc_atomic_exp exp +and doc_infix n (E_aux (e_aux, _) as exp) = + match e_aux with + | E_app_infix (l, op, r) when n < 10 -> + begin + try + match Bindings.find op !fixities with + | (Infix, m) when m >= n -> separate space [doc_infix (m + 1) l; doc_id op; doc_infix (m + 1) r] + | (Infix, m) when m < n -> parens (separate space [doc_infix (m + 1) l; doc_id op; doc_infix (m + 1) r]) + | (InfixL, m) when m >= n -> separate space [doc_infix m l; doc_id op; doc_infix (m + 1) r] + | (InfixL, m) when m < n -> parens (separate space [doc_infix m l; doc_id op; doc_infix (m + 1) r]) + | (InfixR, m) when m >= n -> separate space [doc_infix (m + 1) l; doc_id op; doc_infix m r] + | (InfixR, m) when m < n -> parens (separate space [doc_infix (m + 1) l; doc_id op; doc_infix m r]) + | _ -> assert false + with + | Not_found -> + separate space [doc_atomic_exp l; doc_id op; doc_atomic_exp r] + end + | _ -> doc_atomic_exp exp +and doc_atomic_exp (E_aux (e_aux, _) as exp) = + match e_aux with + | E_cast (typ, exp) -> + separate space [doc_atomic_exp exp; colon; doc_typ typ] | E_lit lit -> doc_lit lit - | E_cast(typ,e) -> prefix 2 1 (parens (doc_typ typ)) (group (atomic_exp e)) - (* - | E_internal_cast((_,NoTyp),e) -> atomic_exp e - | E_internal_cast((_,Base((_,t),_,_,_,_,bindings)), (E_aux(_,(_,eannot)) as e)) -> - (match t.t,eannot with - (* XXX I don't understand why we can hide the internal cast here - AAA Because an internal cast between vectors is only generated to reset the base access; - the type checker generates far more than are needed and they're pruned off here, after constraint resolution *) - | Tapp("vector",[TA_nexp n1;_;_;_]),Base((_,{t=Tapp("vector",[TA_nexp n2;_;_;_])}),_,_,_,_,_) - when nexp_eq n1 n2 -> atomic_exp e - | _ -> prefix 2 1 (parens (doc_typ (t_to_typ t))) (group (atomic_exp e))) - *) - | E_tuple exps -> - parens (separate_map comma exp exps) - | E_record(FES_aux(FES_Fexps(fexps,_),_)) -> - (* XXX E_record is not handled by parser currently - AAA The parser can't handle E_record due to ambiguity with blocks; initial_check looks for blocks that are all field assignments and converts *) - braces (separate_map semi_sp doc_fexp fexps) - | E_record_update(e,(FES_aux(FES_Fexps(fexps,_),_))) -> - braces (doc_op (string "with") (exp e) (separate_map semi_sp doc_fexp fexps)) - | E_vector exps -> - let default_print _ = brackets (separate_map comma exp exps) in - (match exps with - | [] -> default_print () - | E_aux(e,_)::es -> - (match e with - | E_lit (L_aux(L_one, _)) | E_lit (L_aux(L_zero, _)) -> - utf8string - ("0b" ^ - (List.fold_right (fun (E_aux( e,_)) rst -> - (match e with - | E_lit(L_aux(l, _)) -> - ((match l with | L_one -> "1" | L_zero -> "0" | L_undef -> "u" | _ -> assert false) ^ rst) - | _ -> assert false)) exps "")) - | _ -> default_print ())) - | E_vector_update(v,e1,e2) -> - brackets (doc_op (string "with") (exp v) (doc_op equals (atomic_exp e1) (exp e2))) - | E_vector_update_subrange(v,e1,e2,e3) -> - brackets ( - doc_op (string "with") (exp v) - (doc_op equals (atomic_exp e1 ^^ colon ^^ atomic_exp e2) (exp e3))) - | E_list exps -> - squarebarbars (separate_map comma exp exps) - | E_try(e,pexps) -> - let opening = separate space [string "try"; exp e; string "catch"; lbrace] in - let cases = separate_map (break 1) doc_case pexps in - surround 2 1 opening cases rbrace - | E_case(e,pexps) -> - let opening = separate space [string "switch"; exp e; lbrace] in - let cases = separate_map (break 1) doc_case pexps in - surround 2 1 opening cases rbrace - | E_sizeof n -> - parens (separate space [string "sizeof"; doc_nexp n]) - | E_constraint nc -> - string "constraint" ^^ parens (doc_nexp_constraint nc) - | E_exit e -> - separate space [string "exit"; atomic_exp e;] - | E_throw e -> - separate space [string "throw"; atomic_exp e;] - | E_return e -> - separate space [string "return"; atomic_exp e;] - | E_assert(c,m) -> - separate space [string "assert"; parens (separate comma [exp c; exp m])] - (* adding parens and loop for lower precedence *) - | E_app (_, _)|E_vector_access (_, _)|E_vector_subrange (_, _, _) - | E_cons (_, _)|E_field (_, _)|E_assign (_, _) - | E_if _ | E_for _ | E_loop _ | E_let _ - | E_internal_let _ | E_internal_plet _ - | E_vector_append _ - | E_app_infix (_, - (* for every app_infix operator caught at a higher precedence, - * we need to wrap around with parens *) - (Id_aux(Id("|" | "||" - | "&" | "&&" - | "=" | "==" | "!=" - | ">=" | ">=_s" | ">=_u" | ">" | ">_s" | ">_u" - | "<=" | "<=_s" | "<" | "<_s" | "<_si" | "<_u" - | "@" | "^^" | "^" | "~^" - | ">>" | ">>>" | "<<" | "<<<" - | "+" | "-" | "+_s" | "-_s" - | "*" | "/" - | "div" | "quot" | "quot_s" | "rem" | "mod" - | "*_s" | "*_si" | "*_u" | "*_ui" - | "**"), _)) - , _) -> - group (parens (exp expr)) - (* XXX default precedence for app_infix? *) - | E_app_infix(l,op,r) -> - failwith ("unexpected app_infix operator " ^ (pp_format_id op)) - (* doc_op (doc_id op) (exp l) (exp r) *) - | E_comment s -> comment (string s) - | E_comment_struc e -> comment (exp e) - (* - | E_internal_exp((l, Base((_,t),_,_,_,_,bindings))) -> (*TODO use bindings, and other params*) - (match t.t with - | Tapp("register",[TA_typ {t=Tapp("vector",[TA_nexp _;TA_nexp r;_;_])}]) - | Tapp("vector",[TA_nexp _;TA_nexp r;_;_]) -> - (match r.nexp with - | Nvar v -> utf8string v - | Nconst bi -> utf8string (Big_int.string_of_big_int bi) - | _ -> raise (Reporting_basic.err_unreachable l - ("Internal exp given vector without known length, instead given " ^ n_to_string r))) - | Tapp("implicit",[TA_nexp r]) -> - (match r.nexp with - | Nconst bi -> utf8string (Big_int.string_of_big_int bi) - | Nvar v -> utf8string v - | _ -> raise (Reporting_basic.err_unreachable l "Internal exp given implicit without var or const")) - | _ -> raise (Reporting_basic.err_unreachable l ("Internal exp given non-vector, non-implicit " ^ t_to_string t))) - | E_internal_exp_user _ -> raise (Reporting_basic.err_unreachable Unknown ("internal_exp_user not rewritten away")) - | E_internal_cast ((_, Overload (_, _,_ )), _) | E_internal_exp _ -> assert false - *) - | E_internal_return exp1 -> - separate space [string "internal_return"; exp exp1] - | _ -> failwith ("Cannot print: " ^ Ast_util.string_of_exp expr) - and let_exp (LB_aux(lb,_)) = match lb with - | LB_val(pat,e) -> - prefix 2 1 - (separate space [string "let"; doc_atomic_pat pat; equals]) - (atomic_exp e) - - and doc_fexp (FE_aux(FE_Fexp(id,e),_)) = doc_op equals (doc_id id) (exp e) - - and doc_case (Pat_aux (pexp, _)) = - match pexp with - | Pat_exp(pat, e) -> - doc_op arrow (separate space [string "case"; doc_atomic_pat pat]) (group (exp e)) - | Pat_when(pat, guard, e) -> - doc_op arrow (separate space [string "case"; doc_atomic_pat pat; string "when"; exp guard]) (group (exp e)) - - (* lexps are parsed as eq_exp - we need to duplicate the precedence - * structure for them *) - and doc_lexp le = app_lexp le - and app_lexp ((LEXP_aux(lexp,_)) as le) = match lexp with - | LEXP_memory(id,args) -> doc_id id ^^ parens (separate_map comma exp args) - | _ -> vaccess_lexp le - and vaccess_lexp ((LEXP_aux(lexp,_)) as le) = match lexp with - | LEXP_vector(v,e) -> atomic_lexp v ^^ brackets (exp e) - | LEXP_vector_range(v,e1,e2) -> - atomic_lexp v ^^ brackets (exp e1 ^^ dotdot ^^ exp e2) - | _ -> field_lexp le - and field_lexp ((LEXP_aux(lexp,_)) as le) = match lexp with - | LEXP_field(v,id) -> atomic_lexp v ^^ dot ^^ doc_id id - | _ -> atomic_lexp le - and atomic_lexp ((LEXP_aux(lexp,_)) as le) = match lexp with + | E_id id -> doc_id id + | E_ref id -> string "ref" ^^ space ^^ doc_id id + | E_field (exp, id) -> doc_atomic_exp exp ^^ dot ^^ doc_id id + | E_sizeof (Nexp_aux (Nexp_var kid, _)) -> doc_kid kid + | E_sizeof nexp -> string "sizeof" ^^ parens (doc_nexp nexp) + (* Format a function with a unit argument as f() rather than f(()) *) + | E_app (id, [E_aux (E_lit (L_aux (L_unit, _)), _)]) -> doc_id id ^^ string "()" + | E_app (id, exps) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_exp exps) + | E_constraint nc -> string "constraint" ^^ parens (doc_nc nc) + | E_assert (exp1, E_aux (E_lit (L_aux (L_string "", _)), _)) -> string "assert" ^^ parens (doc_exp exp1) + | E_assert (exp1, exp2) -> string "assert" ^^ parens (doc_exp exp1 ^^ comma ^^ space ^^ doc_exp exp2) + | E_exit exp -> string "exit" ^^ parens (doc_exp exp) + | E_vector_access (exp1, exp2) -> doc_atomic_exp exp1 ^^ brackets (doc_exp exp2) + | E_vector_subrange (exp1, exp2, exp3) -> doc_atomic_exp exp1 ^^ brackets (separate space [doc_exp exp2; string ".."; doc_exp exp3]) + | E_vector exps -> brackets (separate_map (comma ^^ space) doc_exp exps) + | E_vector_update (exp1, exp2, exp3) -> + brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; equals; doc_exp exp3]) + | 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]) + | E_internal_value v -> string (Value.string_of_value v |> Util.green |> Util.clear) + | _ -> 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, _)), _)] -> + separate space [string "let"; doc_pat pat; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps + | [E_aux (E_var (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) = + match l_aux with + | LEXP_cast (typ, id) -> separate space [doc_id id; colon; doc_typ typ] + | _ -> doc_atomic_lexp lexp +and doc_atomic_lexp (LEXP_aux (l_aux, _) as lexp) = + match l_aux with | LEXP_id id -> doc_id id - | LEXP_cast(typ,id) -> prefix 2 1 (parens (doc_typ typ)) (doc_id id) - | LEXP_memory _ | LEXP_vector _ | LEXP_vector_range _ - | LEXP_field _ -> group (parens (doc_lexp le)) - | LEXP_tup tups -> parens (separate_map comma doc_lexp tups) - - (* expose doc_exp and doc_let *) - in exp, let_exp + | LEXP_deref exp -> lparen ^^ string "*" ^^ doc_atomic_exp exp ^^ rparen + | LEXP_tup lexps -> lparen ^^ separate_map (comma ^^ space) doc_lexp lexps ^^ rparen + | LEXP_field (lexp, id) -> doc_atomic_lexp lexp ^^ dot ^^ doc_id id + | LEXP_vector (lexp, exp) -> doc_atomic_lexp lexp ^^ brackets (doc_exp exp) + | LEXP_vector_range (lexp, exp1, exp2) -> doc_atomic_lexp lexp ^^ brackets (separate space [doc_exp exp1; string ".."; doc_exp exp2]) + | LEXP_memory (id, exps) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_exp exps) + | _ -> parens (doc_lexp lexp) +and doc_pexps pexps = surround 2 0 lbrace (separate_map (comma ^^ hardline) doc_pexp pexps) rbrace +and doc_pexp (Pat_aux (pat_aux, _)) = + match pat_aux with + | Pat_exp (pat, exp) -> separate space [doc_pat pat; string "=>"; doc_exp exp] + | Pat_when (pat, wh, exp) -> + separate space [doc_pat pat; string "if"; doc_exp wh; string "=>"; doc_exp exp] +and doc_letbind (LB_aux (lb_aux, _)) = + match lb_aux with + | LB_val (pat, exp) -> + separate space [doc_pat pat; equals; doc_exp exp] + +let doc_funcl funcl = string "FUNCL" + +let doc_funcl (FCL_aux (FCL_Funcl (id, Pat_aux (pexp,_)), _)) = + match pexp with + | Pat_exp (pat,exp) -> + group (separate space [doc_id id; doc_pat pat; equals; doc_exp exp]) + | Pat_when (pat,wh,exp) -> + group (separate space [doc_id id; parens (separate space [doc_pat pat; string "if"; doc_exp wh]); string "="; doc_exp exp]) let doc_default (DT_aux(df,_)) = match df with - | DT_kind(bk,v) -> separate space [string "default"; doc_bkind bk; doc_var v] - | DT_typ(ts,id) -> separate space [string "default"; doc_typscm ts; doc_id id] + | DT_kind(bk,v) -> string "DT_kind" (* separate space [string "default"; doc_bkind bk; doc_var v] *) + | DT_typ(ts,id) -> separate space [string "default"; doc_typschm ts; doc_id id] | DT_order(ord) -> separate space [string "default"; string "Order"; doc_ord ord] -let doc_spec (VS_aux(v,_)) = match v with - | VS_val_spec(ts,id,ext_opt,is_cast) -> - let cast_pp = if is_cast then [string "cast"] else [] in - (* This sail syntax only supports a single extern name, so just use the ocaml version *) - let extern_kwd_pp, id_pp = match ext_opt "ocaml" with - | Some ext -> [string "extern"], doc_op equals (doc_id id) (dquotes (string (ext))) - | None -> [], doc_id id - in - separate space ([string "val"] @ cast_pp @ extern_kwd_pp @ [doc_typscm ts] @ [id_pp]) - | _ -> failwith "Invalid valspec" - -let doc_namescm (Name_sect_aux(ns,_)) = match ns with - | Name_sect_none -> empty - (* include leading space because the caller doesn't know if ns is - * empty, and trailing break already added by the following equals *) - | Name_sect_some s -> space ^^ brackets (doc_op equals (string "name") (dquotes (string s))) - -let doc_type_union (Tu_aux(typ_u,_)) = match typ_u with - | Tu_ty_id(typ,id) -> separate space [doc_typ typ; doc_id id] - | Tu_id id -> doc_id id - -let doc_typdef (TD_aux(td,_)) = match td with - | TD_abbrev(id,nm,typschm) -> - doc_op equals (concat [string "typedef"; space; doc_id id; doc_namescm nm]) (doc_typscm typschm) - | TD_record(id,nm,typq,fs,_) -> - let f_pp (typ,id) = concat [doc_typ typ; space; doc_id id; semi] in - let fs_doc = group (separate_map (break 1) f_pp fs) in - doc_op equals - (concat [string "typedef"; space; doc_id id; doc_namescm nm]) - (string "const struct" ^^ space ^^ doc_typquant typq (braces fs_doc)) - | TD_variant(id,nm,typq,ar,_) -> - let ar_doc = group (separate_map (semi ^^ break 1) doc_type_union ar) in - doc_op equals - (concat [string "typedef"; space; doc_id id; doc_namescm nm]) - (string "const union" ^^ space ^^ doc_typquant typq (braces ar_doc)) - | TD_enum(id,nm,enums,_) -> - let enums_doc = group (separate_map (semi ^^ break 1) doc_id enums) in - doc_op equals - (concat [string "typedef"; space; doc_id id; doc_namescm nm]) - (string "enumerate" ^^ space ^^ braces enums_doc) - | TD_register(id,n1,n2,rs) -> - let doc_rid (r,id) = separate space [doc_range r; colon; doc_id id] ^^ semi in - let doc_rids = group (separate_map (break 1) doc_rid rs) in - doc_op equals - (string "typedef" ^^ space ^^ doc_id id) - (separate space [ - string "register bits"; - brackets (doc_nexp n1 ^^ colon ^^ doc_nexp n2); - braces doc_rids; - ]) - -let doc_kindef (KD_aux(kd,_)) = match kd with - | KD_nabbrev(kind,id,nm,n) -> - doc_op equals (concat [string "def"; space; doc_kind kind; space; doc_id id; doc_namescm nm]) (doc_nexp n) - -let doc_rec (Rec_aux(r,_)) = match r with - | Rec_nonrec -> empty - (* include trailing space because caller doesn't know if we return - * empty *) - | Rec_rec -> space ^^ string "rec" - -let doc_tannot_opt (Typ_annot_opt_aux(t,_)) = match t with - | Typ_annot_opt_some(tq,typ) -> space ^^ doc_typquant tq (doc_typ typ) - | Typ_annot_opt_none -> empty - -let doc_effects_opt (Effect_opt_aux(e,_)) = match e with - | Effect_opt_pure -> string "pure" - | Effect_opt_effect e -> doc_effects e - -let doc_funcl (FCL_aux(FCL_Funcl(id,pexp),_)) = - match pexp with - | Pat_aux (Pat_exp (pat,exp),_) -> - group (doc_op equals (separate space [doc_id id; doc_atomic_pat pat]) (doc_exp exp)) - | Pat_aux (Pat_when (pat,wh,exp),_) -> - group (doc_op equals (doc_id id ^^ space ^^ parens (separate space [doc_atomic_pat pat; string "when"; doc_exp wh])) - (doc_exp exp)) - -let doc_fundef (FD_aux(FD_function(r, typa, efa, fcls),_)) = - match fcls with - | [] -> failwith "FD_function with empty function list" +let doc_fundef (FD_aux (FD_function (r, typa, efa, funcls), _)) = + match funcls with + | [] -> failwith "Empty function list" | _ -> - let sep = hardline ^^ string "and" ^^ space in - let clauses = separate_map sep doc_funcl fcls in - separate space ([string "function" ^^ doc_rec r ^^ doc_tannot_opt typa]@ - (match efa with - | Effect_opt_aux (Effect_opt_pure,_) -> [] - | _ -> [string "effect"; - doc_effects_opt efa;]) - @[clauses]) - -let doc_alias (AL_aux (alspec,_)) = - match alspec with - | AL_subreg((RI_aux (RI_id id,_)),subid) -> doc_id id ^^ dot ^^ doc_id subid - | AL_bit((RI_aux (RI_id id,_)),ac) -> doc_id id ^^ brackets (doc_exp ac) - | AL_slice((RI_aux (RI_id id,_)),b,e) -> doc_id id ^^ brackets (doc_op dotdot (doc_exp b) (doc_exp e)) - | AL_concat((RI_aux (RI_id f,_)),(RI_aux (RI_id s,_))) -> doc_op colon (doc_id f) (doc_id s) + let sep = hardline ^^ string "and" ^^ space in + let clauses = separate_map sep doc_funcl funcls in + string "function" ^^ space ^^ clauses let doc_dec (DEC_aux (reg,_)) = match reg with - | DEC_reg(typ,id) -> separate space [string "register"; doc_typ typ; doc_id id] - | DEC_alias(id,alspec) -> - doc_op equals (string "register alias" ^^ space ^^ doc_id id) (doc_alias alspec) - | DEC_typ_alias(typ,id,alspec) -> - doc_op equals (string "register alias" ^^ space ^^ doc_typ typ) (doc_alias alspec) - -let doc_scattered (SD_aux (sdef, _)) = match sdef with - | SD_scattered_function (r, typa, efa, id) -> - separate space ([ - string "scattered function"; - doc_rec r ^^ doc_tannot_opt typa;]@ - (match efa with - | Effect_opt_aux (Effect_opt_pure,_) -> [] - | _ -> [string "effect"; doc_effects_opt efa;]) - @[doc_id id]) - | SD_scattered_variant (id, ns, tq) -> - doc_op equals - (string "scattered typedef" ^^ space ^^ doc_id id ^^ doc_namescm ns) - (string "const union" ^^ space ^^ (doc_typquant tq empty)) - | SD_scattered_funcl funcl -> - string "function clause" ^^ space ^^ doc_funcl funcl - | SD_scattered_unioncl (id, tu) -> - separate space [string "union"; doc_id id; - string "member"; doc_type_union tu] - | SD_scattered_end id -> string "end" ^^ space ^^ doc_id id + | DEC_reg (typ, id) -> separate space [string "register"; doc_id id; colon; doc_typ typ] + | DEC_alias(id,alspec) -> string "ALIAS" + | DEC_typ_alias(typ,id,alspec) -> string "ALIAS" + +let doc_field (typ, id) = + separate space [doc_id id; colon; doc_typ typ] + +let doc_union (Tu_aux (tu, l)) = match tu with + | Tu_id id -> doc_id id + | Tu_ty_id (typ, id) -> separate space [doc_id id; colon; doc_typ typ] + +let doc_typdef (TD_aux(td,_)) = match td with + | TD_abbrev (id, _, typschm) -> + begin + match doc_typschm_quants typschm with + | Some qdoc -> + doc_op equals (concat [string "type"; space; doc_id id; space; qdoc]) (doc_typschm_typ typschm) + | None -> + doc_op equals (concat [string "type"; space; doc_id id]) (doc_typschm_typ typschm) + end + | TD_enum (id, _, ids, _) -> + separate space [string "enum"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] + | TD_record (id, _, TypQ_aux (TypQ_no_forall, _), fields, _) | TD_record (id, _, TypQ_aux (TypQ_tq [], _), fields, _) -> + separate space [string "struct"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] + | TD_record (id, _, TypQ_aux (TypQ_tq qs, _), fields, _) -> + separate space [string "struct"; doc_id id; doc_quants qs; equals; + surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] + | TD_variant (id, _, TypQ_aux (TypQ_no_forall, _), unions, _) | TD_variant (id, _, TypQ_aux (TypQ_tq [], _), unions, _) -> + separate space [string "union"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] + | TD_variant (id, _, TypQ_aux (TypQ_tq qs, _), unions, _) -> + separate space [string "union"; doc_id id; doc_quants qs; equals; + surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] + | _ -> string "TYPEDEF" + +let doc_spec (VS_aux(v,_)) = + let doc_extern ext = + 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 equals ^^ space ^^ braces (separate (comma ^^ space) docs) + in + match v with + | VS_val_spec(ts,id,ext,is_cast) -> + string "val" ^^ space + ^^ (if is_cast then (string "cast" ^^ space) else empty) + ^^ doc_id id ^^ space + ^^ doc_extern ext + ^^ colon ^^ space + ^^ doc_typschm ts + +let doc_prec = function + | Infix -> string "infix" + | InfixL -> string "infixl" + | InfixR -> string "infixr" + +let doc_kind_def (KD_aux (KD_nabbrev (_, id, _, nexp), _)) = + separate space [string "integer"; doc_id id; equals; doc_nexp nexp] + +let rec doc_scattered (SD_aux (sd_aux, _)) = + match sd_aux with + | SD_scattered_function (_, _, _, id) -> + string "scattered" ^^ space ^^ string "function" ^^ space ^^ doc_id id + | SD_scattered_funcl funcl -> + string "function" ^^ space ^^ string "clause" ^^ space ^^ doc_funcl funcl + | SD_scattered_end id -> + string "end" ^^ space ^^ doc_id id + | _ -> string "SCATTERED" let rec doc_def def = group (match def with | DEF_default df -> doc_default df | DEF_spec v_spec -> doc_spec v_spec | DEF_type t_def -> doc_typdef t_def - | DEF_kind k_def -> doc_kindef k_def + | DEF_kind k_def -> doc_kind_def k_def | DEF_fundef f_def -> doc_fundef f_def - | DEF_val lbind -> doc_let lbind + | 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) -> + fixities := Bindings.add id (prec, Big_int.to_int n) !fixities; + separate space [doc_prec prec; doc_int n; doc_id id] | DEF_overload (id, ids) -> - let ids_doc = group (separate_map (semi ^^ break 1) doc_id ids) in - string "overload" ^^ space ^^ doc_id id ^^ space ^^ brackets ids_doc - | DEF_comm (DC_comm s) -> comment (string s) - | DEF_comm (DC_comm_struct d) -> comment (doc_def d) - | DEF_fixity _ -> empty + separate space [string "overload"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] + | DEF_comm (DC_comm s) -> string "TOPLEVEL" + | DEF_comm (DC_comm_struct d) -> string "TOPLEVEL" ) ^^ hardline let doc_defs (Defs(defs)) = separate_map hardline doc_def defs -let pp_defs f d = print f (doc_defs d) -let pp_exp b e = to_buf b (doc_exp e) -let pat_to_string p = - let b = Buffer.create 20 in - to_buf b (doc_pat p); +let pp_defs f d = ToChannel.pretty 1. 80 f (doc_defs d) + +let pretty_sail f doc = ToChannel.pretty 1. 120 f doc + +let to_string doc = + let b = Buffer.create 120 in + ToBuffer.pretty 1. 120 b doc; Buffer.contents b diff --git a/src/pretty_print_sail2.ml b/src/pretty_print_sail2.ml deleted file mode 100644 index 0c531301..00000000 --- a/src/pretty_print_sail2.ml +++ /dev/null @@ -1,525 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* 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 Ast_util -open Big_int -open PPrint - -let doc_op symb a b = infix 2 1 symb a b - -let doc_id (Id_aux (id_aux, _)) = - string (match id_aux with - | Id v -> v - | DeIid op -> "operator " ^ op) - -let doc_kid kid = string (Ast_util.string_of_kid kid) - -let doc_int n = string (string_of_big_int n) - -let doc_ord (Ord_aux(o,_)) = match o with - | Ord_var v -> doc_kid v - | Ord_inc -> string "inc" - | Ord_dec -> string "dec" - -let rec doc_nexp = - let rec atomic_nexp (Nexp_aux (n_aux, _) as nexp) = - match n_aux with - | Nexp_constant c -> string (string_of_big_int c) - | Nexp_id id -> doc_id id - | Nexp_var kid -> doc_kid kid - | _ -> parens (nexp0 nexp) - and nexp0 (Nexp_aux (n_aux, _) as nexp) = - match n_aux with - | Nexp_sum (n1, Nexp_aux (Nexp_neg n2, _)) | Nexp_minus (n1, n2) -> - separate space [nexp0 n1; string "-"; nexp1 n2] - | Nexp_sum (n1, Nexp_aux (Nexp_constant c, _)) when lt_big_int c zero_big_int -> - separate space [nexp0 n1; string "-"; doc_int (abs_big_int c)] - | Nexp_sum (n1, n2) -> separate space [nexp0 n1; string "+"; nexp1 n2] - | _ -> nexp1 nexp - and nexp1 (Nexp_aux (n_aux, _) as nexp) = - match n_aux with - | Nexp_times (n1, n2) -> separate space [nexp1 n1; string "*"; nexp2 n2] - | _ -> nexp2 nexp - and nexp2 (Nexp_aux (n_aux, _) as nexp) = - match n_aux with - | Nexp_neg n -> separate space [string "-"; atomic_nexp n] - | Nexp_exp n -> separate space [string "2"; string "^"; atomic_nexp n] - | _ -> atomic_nexp nexp - in - nexp0 - -let doc_nc = - let nc_op op n1 n2 = separate space [doc_nexp n1; string op; doc_nexp n2] in - let rec atomic_nc (NC_aux (nc_aux, _) as nc) = - match nc_aux with - | NC_true -> string "true" - | NC_false -> string "false" - | NC_equal (n1, n2) -> nc_op "=" n1 n2 - | NC_not_equal (n1, n2) -> nc_op "!=" n1 n2 - | NC_bounded_ge (n1, n2) -> nc_op ">=" n1 n2 - | NC_bounded_le (n1, n2) -> nc_op "<=" n1 n2 - | NC_set (kid, ints) -> - separate space [doc_kid kid; string "in"; braces (separate_map (comma ^^ space) doc_int ints)] - | _ -> parens (nc0 nc) - and nc0 (NC_aux (nc_aux, _) as nc) = - match nc_aux with - | NC_or (c1, c2) -> separate space [nc0 c1; string "|"; nc1 c2] - | _ -> nc1 nc - and nc1 (NC_aux (nc_aux, _) as nc) = - match nc_aux with - | NC_and (c1, c2) -> separate space [nc1 c1; string "&"; atomic_nc c2] - | _ -> atomic_nc nc - in - nc0 - -let rec doc_typ (Typ_aux (typ_aux, _)) = - match typ_aux with - | Typ_id id -> doc_id id - | Typ_app (id, []) -> doc_id id - | Typ_app (Id_aux (DeIid str, _), [x; y]) -> - separate space [doc_typ_arg x; doc_typ_arg y] - (* - | Typ_app (id, [_; len; _; Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id tid, _)), _)]) when Id.compare (mk_id "vector") id == 0 && Id.compare (mk_id "bit") tid == 0-> - string "bits" ^^ parens (doc_typ_arg len) - *) - | Typ_app (id, typs) -> doc_id id ^^ parens (separate_map (string ", ") doc_typ_arg typs) - | Typ_tup typs -> parens (separate_map (string ", ") doc_typ typs) - | Typ_var kid -> doc_kid kid - (* Resugar set types like {|1, 2, 3|} *) - | Typ_exist ([kid1], NC_aux (NC_set (kid2, ints), _), Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid3, _)), _)]), _)) - when Kid.compare kid1 kid2 == 0 && Kid.compare kid2 kid3 == 0 && Id.compare (mk_id "atom") id == 0 -> - enclose (string "{|") (string "|}") (separate_map (string ", ") doc_int ints) - | Typ_exist (kids, nc, typ) -> - braces (separate_map space doc_kid kids ^^ comma ^^ space ^^ doc_nc nc ^^ dot ^^ space ^^ doc_typ typ) - | Typ_fn (typ1, typ2, Effect_aux (Effect_set [], _)) -> - separate space [doc_typ typ1; string "->"; doc_typ typ2] - | Typ_fn (typ1, typ2, Effect_aux (Effect_set effs, _)) -> - let ocaml_eff = braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs)) in - separate space [doc_typ typ1; string "->"; doc_typ typ2; string "effect"; ocaml_eff] -and doc_typ_arg (Typ_arg_aux (ta_aux, _)) = - match ta_aux with - | Typ_arg_typ typ -> doc_typ typ - | Typ_arg_nexp nexp -> doc_nexp nexp - | Typ_arg_order o -> doc_ord o - -let doc_quants quants = - let doc_qi_kopt (QI_aux (qi_aux, _)) = - match qi_aux with - | QI_id (KOpt_aux (KOpt_none kid, _)) -> [doc_kid kid] - | QI_id kopt when is_nat_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Int"])] - | QI_id kopt when is_typ_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"])] - | QI_id kopt when is_order_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"])] - | QI_const nc -> [] - in - let qi_nc (QI_aux (qi_aux, _)) = - match qi_aux with - | QI_const nc -> [nc] - | _ -> [] - in - let kdoc = separate space (List.concat (List.map doc_qi_kopt quants)) in - let ncs = List.concat (List.map qi_nc quants) in - match ncs with - | [] -> kdoc - | [nc] -> kdoc ^^ comma ^^ space ^^ doc_nc nc - | nc :: ncs -> kdoc ^^ comma ^^ space ^^ doc_nc (List.fold_left nc_and nc ncs) - -let doc_typschm (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = - match tq_aux with - | TypQ_no_forall -> doc_typ typ - | TypQ_tq [] -> doc_typ typ - | TypQ_tq qs -> - string "forall" ^^ space ^^ doc_quants qs ^^ dot ^//^ doc_typ typ - -let doc_typschm_typ (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = doc_typ typ - -let doc_typschm_quants (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = - match tq_aux with - | TypQ_no_forall -> None - | TypQ_tq [] -> None - | TypQ_tq qs -> Some (doc_quants qs) - -let doc_lit (L_aux(l,_)) = - utf8string (match l with - | L_unit -> "()" - | L_zero -> "bitzero" - | L_one -> "bitone" - | L_true -> "true" - | L_false -> "false" - | L_num i -> string_of_big_int i - | L_hex n -> "0x" ^ n - | L_bin n -> "0b" ^ n - | L_real r -> r - | L_undef -> "undefined" - | L_string s -> "\"" ^ String.escaped s ^ "\"") - -let rec doc_pat (P_aux (p_aux, _) as pat) = - match p_aux with - | P_id id -> doc_id id - | P_tup pats -> lparen ^^ separate_map (comma ^^ space) doc_pat pats ^^ rparen - | P_app (id, pats) -> doc_id id ^^ lparen ^^ separate_map (comma ^^ space) doc_pat pats ^^ rparen - | P_typ (typ, pat) -> separate space [doc_pat pat; colon; doc_typ typ] - | P_lit lit -> doc_lit lit - (* P_var short form sugar *) - | P_var (P_aux (P_id id, _), kid) when Id.compare (id_of_kid kid) id == 0 -> - doc_kid kid - | P_var (pat, kid) -> separate space [doc_pat pat; string "as"; doc_kid kid] - | P_vector pats -> brackets (separate_map (comma ^^ space) doc_pat pats) - | P_vector_concat pats -> separate_map (space ^^ string "@" ^^ space) doc_pat pats - | P_wild -> string "_" - | P_as (pat, id) -> separate space [doc_pat pat; string "as"; doc_id id] - | P_app (id, pats) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_pat pats) - | _ -> string (string_of_pat pat) - -(* if_block_x is true if x should be printed like a block, i.e. with - newlines. Blocks are automatically printed as blocks, so this - returns false for them. *) -let if_block_then (E_aux (e_aux, _)) = - match e_aux with - | E_assign _ | E_if _ -> true - | _ -> false - -let if_block_else (E_aux (e_aux, _)) = - match e_aux with - | E_assign _ -> true - | _ -> false - -let fixities = - let fixities' = - List.fold_left - (fun r (x, y) -> Bindings.add x y r) - Bindings.empty - [ - (mk_id "^", (InfixR, 8)); - (mk_id "*", (InfixL, 7)); - (mk_id "+", (InfixL, 6)); - (mk_id "-", (InfixL, 6)); - (mk_id "!=", (Infix, 4)); - (mk_id ">", (Infix, 4)); - (mk_id "<", (Infix, 4)); - (mk_id ">=", (Infix, 4)); - (mk_id "<=", (Infix, 4)); - (mk_id "&", (InfixR, 3)); - (mk_id "|", (InfixR, 2)); - ] - in - ref (fixities' : (prec * int) Bindings.t) - -let rec doc_exp (E_aux (e_aux, _) as exp) = - match e_aux with - | E_block [] -> string "()" - | E_block [exp] -> doc_exp exp - | E_block exps -> surround 2 0 lbrace (doc_block exps) rbrace - | E_nondet exps -> assert false - (* This is mostly for the -convert option *) - | E_app_infix (x, id, y) when Id.compare (mk_id "quot") id == 0 -> - separate space [doc_atomic_exp x; string "/"; doc_atomic_exp y] - | E_app_infix _ -> doc_infix 0 exp - | E_tuple exps -> parens (separate_map (comma ^^ space) doc_exp exps) - - (* Various rules to try to format if blocks nicely based on content *) - | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp && if_block_else else_exp -> - (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) - ^/^ (string "else" ^//^ doc_exp else_exp) - | E_if (if_exp, then_exp, (E_aux (E_if _, _) as else_exp)) when if_block_then then_exp -> - (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) - ^/^ (string "else" ^^ space ^^ doc_exp else_exp) - | E_if (if_exp, then_exp, else_exp) when if_block_else else_exp -> - (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp]) - ^^ space ^^ (string "else" ^//^ doc_exp else_exp) - | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp -> - (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) - ^/^ (string "else" ^^ space ^^ doc_exp else_exp) - | E_if (if_exp, then_exp, else_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 -> 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) -> - 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] - | 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_plet (pat, exp1, exp2) -> - let le = - prefix 2 1 - (separate space [string "internal_plet"; doc_pat pat; equals]) - (doc_exp exp1) in - doc_op (string "in") le (doc_exp exp2) - | 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) -> - begin - let header = - string "foreach" ^^ space ^^ - group (parens (separate (break 1) - [ doc_id id; - string "from " ^^ doc_atomic_exp exp1; - string "to " ^^ doc_atomic_exp exp2; - string "by " ^^ doc_atomic_exp exp3; - string "in " ^^ doc_ord order ])) - in - match exp4 with - | E_aux (E_block [_], _) -> header ^//^ doc_exp exp4 - | E_aux (E_block _, _) -> header ^^ space ^^ doc_exp exp4 - | _ -> header ^//^ doc_exp exp4 - end - (* Resugar an assert with an empty message *) - | E_throw exp -> string "throw" ^^ parens (doc_exp exp) - | E_try (exp, pexps) -> assert false - | E_return exp -> string "return" ^^ parens (doc_exp exp) - | E_internal_return exp -> string "internal_return" ^^ parens (doc_exp exp) - | E_app (id, [exp]) when Id.compare (mk_id "pow2") id == 0 -> - separate space [string "2"; string "^"; doc_atomic_exp exp] - | _ -> doc_atomic_exp exp -and doc_infix n (E_aux (e_aux, _) as exp) = - match e_aux with - | E_app_infix (l, op, r) when n < 10 -> - begin - try - match Bindings.find op !fixities with - | (Infix, m) when m >= n -> separate space [doc_infix (m + 1) l; doc_id op; doc_infix (m + 1) r] - | (Infix, m) when m < n -> parens (separate space [doc_infix (m + 1) l; doc_id op; doc_infix (m + 1) r]) - | (InfixL, m) when m >= n -> separate space [doc_infix m l; doc_id op; doc_infix (m + 1) r] - | (InfixL, m) when m < n -> parens (separate space [doc_infix m l; doc_id op; doc_infix (m + 1) r]) - | (InfixR, m) when m >= n -> separate space [doc_infix (m + 1) l; doc_id op; doc_infix m r] - | (InfixR, m) when m < n -> parens (separate space [doc_infix (m + 1) l; doc_id op; doc_infix m r]) - with - | Not_found -> - separate space [doc_atomic_exp l; doc_id op; doc_atomic_exp r] - end - | _ -> doc_atomic_exp exp -and doc_atomic_exp (E_aux (e_aux, _) as exp) = - match e_aux with - | E_cast (typ, exp) -> - separate space [doc_atomic_exp exp; colon; doc_typ typ] - | E_lit lit -> doc_lit lit - | E_id id -> doc_id id - | E_field (exp, id) -> doc_atomic_exp exp ^^ dot ^^ doc_id id - | E_sizeof (Nexp_aux (Nexp_var kid, _)) -> doc_kid kid - | E_sizeof nexp -> string "sizeof" ^^ parens (doc_nexp nexp) - (* Format a function with a unit argument as f() rather than f(()) *) - | E_app (id, [E_aux (E_lit (L_aux (L_unit, _)), _)]) -> doc_id id ^^ string "()" - | E_app (id, exps) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_exp exps) - | E_constraint nc -> string "constraint" ^^ parens (doc_nc nc) - | E_assert (exp1, E_aux (E_lit (L_aux (L_string "", _)), _)) -> string "assert" ^^ parens (doc_exp exp1) - | E_assert (exp1, exp2) -> string "assert" ^^ parens (doc_exp exp1 ^^ comma ^^ space ^^ doc_exp exp2) - | E_exit exp -> string "exit" ^^ parens (doc_exp exp) - | E_vector_access (exp1, exp2) -> doc_atomic_exp exp1 ^^ brackets (doc_exp exp2) - | E_vector_subrange (exp1, exp2, exp3) -> doc_atomic_exp exp1 ^^ brackets (separate space [doc_exp exp2; string ".."; doc_exp exp3]) - | E_vector exps -> brackets (separate_map (comma ^^ space) doc_exp exps) - | E_vector_update (exp1, exp2, exp3) -> - brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; equals; doc_exp exp3]) - | 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, _)), _)] -> - 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) = - match l_aux with - | LEXP_cast (typ, id) -> separate space [doc_id id; colon; doc_typ typ] - | _ -> doc_atomic_lexp lexp -and doc_atomic_lexp (LEXP_aux (l_aux, _) as lexp) = - match l_aux with - | LEXP_id id -> doc_id id - | LEXP_tup lexps -> lparen ^^ separate_map (comma ^^ space) doc_lexp lexps ^^ rparen - | LEXP_field (lexp, id) -> doc_atomic_lexp lexp ^^ dot ^^ doc_id id - | LEXP_vector (lexp, exp) -> doc_atomic_lexp lexp ^^ brackets (doc_exp exp) - | LEXP_vector_range (lexp, exp1, exp2) -> doc_atomic_lexp lexp ^^ brackets (separate space [doc_exp exp1; string ".."; doc_exp exp2]) - | LEXP_memory (id, exps) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_exp exps) - | _ -> parens (doc_lexp lexp) -and doc_pexps pexps = surround 2 0 lbrace (separate_map (comma ^^ hardline) doc_pexp pexps) rbrace -and doc_pexp (Pat_aux (pat_aux, _)) = - match pat_aux with - | Pat_exp (pat, exp) -> separate space [doc_pat pat; string "=>"; doc_exp exp] - | Pat_when (pat, wh, exp) -> - separate space [doc_pat pat; string "if"; doc_exp wh; string "=>"; doc_exp exp] -and doc_letbind (LB_aux (lb_aux, _)) = - match lb_aux with - | LB_val (pat, exp) -> - separate space [doc_pat pat; equals; doc_exp exp] - -let doc_funcl funcl = string "FUNCL" - -let doc_funcl (FCL_aux (FCL_Funcl (id, Pat_aux (pexp,_)), _)) = - match pexp with - | Pat_exp (pat,exp) -> - group (separate space [doc_id id; doc_pat pat; equals; doc_exp exp]) - | Pat_when (pat,wh,exp) -> - group (separate space [doc_id id; parens (separate space [doc_pat pat; string "if"; doc_exp wh]); string "="; doc_exp exp]) - -let doc_default (DT_aux(df,_)) = match df with - | DT_kind(bk,v) -> string "DT_kind" (* separate space [string "default"; doc_bkind bk; doc_var v] *) - | DT_typ(ts,id) -> separate space [string "default"; doc_typschm ts; doc_id id] - | DT_order(ord) -> separate space [string "default"; string "Order"; doc_ord ord] - -let doc_fundef (FD_aux (FD_function (r, typa, efa, funcls), _)) = - match funcls with - | [] -> failwith "Empty function list" - | _ -> - let sep = hardline ^^ string "and" ^^ space in - let clauses = separate_map sep doc_funcl funcls in - string "function" ^^ space ^^ clauses - -let doc_dec (DEC_aux (reg,_)) = - match reg with - | DEC_reg (typ, id) -> separate space [string "register"; doc_id id; colon; doc_typ typ] - | DEC_alias(id,alspec) -> string "ALIAS" - | DEC_typ_alias(typ,id,alspec) -> string "ALIAS" - -let doc_field (typ, id) = - separate space [doc_id id; colon; doc_typ typ] - -let doc_union (Tu_aux (tu, l)) = match tu with - | Tu_id id -> doc_id id - | Tu_ty_id (typ, id) -> separate space [doc_id id; colon; doc_typ typ] - -let doc_typdef (TD_aux(td,_)) = match td with - | TD_abbrev (id, _, typschm) -> - begin - match doc_typschm_quants typschm with - | Some qdoc -> - doc_op equals (concat [string "type"; space; doc_id id; space; qdoc]) (doc_typschm_typ typschm) - | None -> - doc_op equals (concat [string "type"; space; doc_id id]) (doc_typschm_typ typschm) - end - | TD_enum (id, _, ids, _) -> - separate space [string "enum"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] - | TD_record (id, _, TypQ_aux (TypQ_no_forall, _), fields, _) | TD_record (id, _, TypQ_aux (TypQ_tq [], _), fields, _) -> - separate space [string "struct"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] - | TD_record (id, _, TypQ_aux (TypQ_tq qs, _), fields, _) -> - separate space [string "struct"; doc_id id; doc_quants qs; equals; - surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] - | TD_variant (id, _, TypQ_aux (TypQ_no_forall, _), unions, _) | TD_variant (id, _, TypQ_aux (TypQ_tq [], _), unions, _) -> - separate space [string "union"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] - | TD_variant (id, _, TypQ_aux (TypQ_tq qs, _), unions, _) -> - separate space [string "union"; doc_id id; doc_quants qs; equals; - surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] - | _ -> string "TYPEDEF" - -let doc_spec (VS_aux(v,_)) = - let doc_extern ext = - 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 equals ^^ space ^^ braces (separate (comma ^^ space) docs) - in - match v with - | VS_val_spec(ts,id,ext,is_cast) -> - string "val" ^^ space - ^^ (if is_cast then (string "cast" ^^ space) else empty) - ^^ doc_id id ^^ space - ^^ doc_extern ext - ^^ colon ^^ space - ^^ doc_typschm ts - -let doc_prec = function - | Infix -> string "infix" - | InfixL -> string "infixl" - | InfixR -> string "infixr" - -let doc_kind_def (KD_aux (KD_nabbrev (_, id, _, nexp), _)) = - separate space [string "integer"; doc_id id; equals; doc_nexp nexp] - -let rec doc_scattered (SD_aux (sd_aux, _)) = - match sd_aux with - | SD_scattered_function (_, _, _, id) -> - string "scattered" ^^ space ^^ string "function" ^^ space ^^ doc_id id - | SD_scattered_funcl funcl -> - string "function" ^^ space ^^ string "clause" ^^ space ^^ doc_funcl funcl - | SD_scattered_end id -> - string "end" ^^ space ^^ doc_id id - | _ -> string "SCATTERED" - -let rec doc_def def = group (match def with - | DEF_default df -> doc_default df - | DEF_spec v_spec -> doc_spec v_spec - | DEF_type t_def -> doc_typdef t_def - | DEF_kind k_def -> doc_kind_def k_def - | DEF_fundef f_def -> doc_fundef f_def - | DEF_internal_mutrec f_defs -> separate_map hardline doc_fundef f_defs - | 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) -> - fixities := Bindings.add id (prec, int_of_big_int n) !fixities; - separate space [doc_prec prec; doc_int n; doc_id id] - | DEF_overload (id, ids) -> - separate space [string "overload"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] - | DEF_comm (DC_comm s) -> string "TOPLEVEL" - | DEF_comm (DC_comm_struct d) -> string "TOPLEVEL" - ) ^^ hardline - -let doc_defs (Defs(defs)) = - separate_map hardline doc_def defs - -let pp_defs f d = ToChannel.pretty 1. 80 f (doc_defs d) diff --git a/src/process_file.ml b/src/process_file.ml index 83cfd8a3..ca23d876 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -48,7 +48,8 @@ (* SUCH DAMAGE. *) (**************************************************************************) -let opt_new_parser = ref false +let opt_lem_sequential = ref false +let opt_lem_mwords = ref false type out_type = | Lem_ast_out @@ -64,42 +65,14 @@ let get_lexbuf f = lexbuf, in_chan let parse_file (f : string) : Parse_ast.defs = - if not !opt_new_parser - then - let scanbuf, in_chan = get_lexbuf f in - let type_names = - try - Pre_parser.file Pre_lexer.token scanbuf - with - | Parsing.Parse_error -> - let pos = Lexing.lexeme_start_p scanbuf in - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "pre"))) - | Parse_ast.Parse_error_locn(l,m) -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax_locn (l, m))) - | Lexer.LexError(s,p) -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_lex (p, s))) - in - close_in in_chan; - Lexer.custom_type_names := !Lexer.custom_type_names @ type_names - else (); - let lexbuf, in_chan = get_lexbuf f in try - let ast = - if !opt_new_parser - then Parser2.file Lexer2.token lexbuf - else Parser.file Lexer.token lexbuf - in + let ast = Parser.file Lexer.token lexbuf in close_in in_chan; ast with - | Parser2.Error -> + | Parser.Error -> let pos = Lexing.lexeme_start_p lexbuf in raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "no information"))) - | Parsing.Parse_error -> - let pos = Lexing.lexeme_start_p lexbuf in - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "main"))) - | Parse_ast.Parse_error_locn(l,m) -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax_locn (l, m))) | Lexer.LexError(s,p) -> raise (Reporting_basic.Fatal_error (Reporting_basic.Err_lex (p, s))) @@ -119,7 +92,7 @@ let opt_dno_cast = ref false let check_ast (defs : unit Ast.defs) : Type_check.tannot Ast.defs * Type_check.Env.t = let ienv = if !opt_dno_cast then Type_check.Env.no_casts Type_check.initial_env else Type_check.initial_env in let ast, env = Type_check.check ienv defs in - let () = if !opt_ddump_tc_ast then Pretty_print.pp_defs stdout ast else () in + let () = if !opt_ddump_tc_ast then Pretty_print_sail.pp_defs stdout ast else () in let () = if !opt_just_check then exit 0 else () in (ast, env) @@ -130,7 +103,7 @@ let opt_auto_mono = ref false let monomorphise_ast locs type_env ast = let ast = Monomorphise.monomorphise (!Pretty_print_lem.opt_mwords) (!opt_auto_mono) (!opt_dmono_analysis) locs type_env ast in - let () = if !opt_ddump_raw_mono_ast then Pretty_print.pp_defs stdout ast else () in + let () = if !opt_ddump_raw_mono_ast then Pretty_print_sail.pp_defs stdout ast else () in let ienv = Type_check.Env.no_casts Type_check.initial_env in Type_check.check ienv ast @@ -216,7 +189,7 @@ let rewrite_step defs (name,rewriter) = let filename = f ^ "_rewrite_" ^ string_of_int i ^ "_" ^ name ^ ".sail" in (* 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; + Pretty_print_sail.pp_defs ot defs; close_output_with_check ext_ot; opt_ddump_rewrite_ast := Some (f, i + 1) end @@ -232,5 +205,6 @@ let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)] let rewrite_undefined = rewrite [("undefined", fun x -> Rewrites.rewrite_undefined !Pretty_print_lem.opt_mwords x)] let rewrite_ast_lem = rewrite Rewrites.rewrite_defs_lem let rewrite_ast_ocaml = rewrite Rewrites.rewrite_defs_ocaml +let rewrite_ast_interpreter = rewrite Rewrites.rewrite_defs_interpreter 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 88c9b9fb..1d98afc6 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -56,13 +56,15 @@ 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_interpreter : 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 val load_file : Ast.order -> Type_check.Env.t -> string -> Type_check.tannot Ast.defs * Type_check.Env.t -val opt_new_parser : bool ref +val opt_lem_sequential : bool ref +val opt_lem_mwords : bool ref val opt_just_check : bool ref val opt_ddump_tc_ast : bool ref val opt_ddump_rewrite_ast : ((string * int) option) ref diff --git a/src/reporting_basic.ml b/src/reporting_basic.ml index 166e0517..af1f85d0 100644 --- a/src/reporting_basic.ml +++ b/src/reporting_basic.ml @@ -97,7 +97,7 @@ let rec skip_lines in_chan = function | n when n <= 0 -> () - | n -> input_line in_chan; skip_lines in_chan (n - 1) + | n -> ignore (input_line in_chan); skip_lines in_chan (n - 1) let rec read_lines in_chan = function | n when n <= 0 -> [] @@ -186,9 +186,9 @@ let read_from_file_pos2 p1 p2 = let ic = open_in p1.Lexing.pos_fname in let _ = seek_in ic s in let l = (e - s) in - let buf = String.create l in + let buf = Bytes.create l in let _ = input ic buf 0 l in - let _ = match multi with None -> () | Some sk -> String.fill buf 0 sk ' ' in + let _ = match multi with None -> () | Some sk -> Bytes.fill buf 0 sk ' ' in let _ = close_in ic in (buf, not (multi = None)) diff --git a/src/rewriter.ml b/src/rewriter.ml index 31bcb577..9e9409ec 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -48,7 +48,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Big_int +module Big_int = Nat_big_num open Ast open Ast_util open Type_check @@ -107,7 +107,7 @@ let fix_eff_exp (E_aux (e,((l,_) as annot))) = match snd annot with let effsum = match e with | E_block es -> union_eff_exps es | E_nondet es -> union_eff_exps es - | E_id _ + | E_id _ | E_ref _ | E_lit _ -> eff | E_cast (_,e) -> effect_of e | E_app (f,es) -> @@ -141,11 +141,12 @@ let fix_eff_exp (E_aux (e,((l,_) as annot))) = match snd annot with | E_internal_cast (_,e) -> effect_of e | E_internal_exp _ -> no_effect | E_internal_exp_user _ -> no_effect - | E_internal_let (lexp,e1,e2) -> + | E_var (lexp,e1,e2) -> union_effects (effect_of_lexp lexp) (union_effects (effect_of e1) (effect_of e2)) | E_internal_plet (_,e1,e2) -> union_effects (effect_of e1) (effect_of e2) | E_internal_return e1 -> effect_of e1 + | E_internal_value v -> no_effect in E_aux (e, (l, Some (env, typ, effsum))) | None -> @@ -156,6 +157,7 @@ let fix_eff_lexp (LEXP_aux (lexp,((l,_) as annot))) = match snd annot with let effsum = union_effects eff (match lexp with | LEXP_id _ -> no_effect | LEXP_cast _ -> no_effect + | LEXP_deref e -> effect_of e | LEXP_memory (_,es) -> union_eff_exps es | LEXP_tup les -> List.fold_left (fun eff le -> union_effects eff (effect_of_lexp le)) no_effect les @@ -204,24 +206,6 @@ let fix_eff_lb (LB_aux (lb,((l,_) as annot))) = match snd annot with | None -> LB_aux (lb, (l, None)) -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 id_to_string (Id_aux(id,l)) = - match id with - | Id(s) -> s - | DeIid(s) -> s *) - 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) [] @@ -338,8 +322,8 @@ let rewrite_exp rewriters (E_aux (exp,(l,annot)) as orig_exp) = | 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)) - | E_internal_let (lexp, e1, e2) -> - rewrap (E_internal_let (rewriters.rewrite_lexp rewriters lexp, rewriters.rewrite_exp rewriters e1, rewriters.rewrite_exp rewriters e2)) + | E_var (lexp, e1, e2) -> + rewrap (E_var (rewriters.rewrite_lexp rewriters lexp, rewriters.rewrite_exp rewriters e1, rewriters.rewrite_exp rewriters e2)) | 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") | _ -> rewrap exp @@ -355,6 +339,7 @@ let rewrite_lexp rewriters (LEXP_aux(lexp,(l,annot))) = let rewrap le = LEXP_aux(le,(l,annot)) in match lexp with | LEXP_id _ | LEXP_cast _ -> rewrap lexp + | LEXP_deref exp -> rewrap (LEXP_deref (rewriters.rewrite_exp rewriters exp)) | LEXP_tup tupls -> rewrap (LEXP_tup (List.map (rewriters.rewrite_lexp rewriters) tupls)) | LEXP_memory (id,exps) -> rewrap (LEXP_memory(id,List.map (rewriters.rewrite_exp rewriters) exps)) | LEXP_vector (lexp,exp) -> @@ -488,6 +473,7 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, { e_block : 'exp list -> 'exp_aux ; e_nondet : 'exp list -> 'exp_aux ; e_id : id -> 'exp_aux + ; e_ref : id -> 'exp_aux ; e_lit : lit -> 'exp_aux ; e_cast : Ast.typ * 'exp -> 'exp_aux ; e_app : id * 'exp list -> 'exp_aux @@ -525,8 +511,10 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_internal_let : 'lexp * 'exp * 'exp -> 'exp_aux ; e_internal_plet : 'pat * 'exp * 'exp -> 'exp_aux ; e_internal_return : 'exp -> 'exp_aux + ; e_internal_value : Value.value -> 'exp_aux ; e_aux : 'exp_aux * 'a annot -> 'exp ; lEXP_id : id -> 'lexp_aux + ; lEXP_deref : 'exp -> 'lexp_aux ; lEXP_memory : id * 'exp list -> 'lexp_aux ; lEXP_cast : Ast.typ * id -> 'lexp_aux ; lEXP_tup : 'lexp list -> 'lexp_aux @@ -553,6 +541,7 @@ let rec fold_exp_aux alg = function | E_block es -> alg.e_block (List.map (fold_exp alg) es) | E_nondet es -> alg.e_nondet (List.map (fold_exp alg) es) | E_id id -> alg.e_id id + | E_ref id -> alg.e_ref id | E_lit lit -> alg.e_lit lit | E_cast (typ,e) -> alg.e_cast (typ, fold_exp alg e) | E_app (id,es) -> alg.e_app (id, List.map (fold_exp alg) es) @@ -594,14 +583,16 @@ let rec fold_exp_aux alg = function | E_internal_exp_user (annot1,annot2) -> alg.e_internal_exp_user (annot1,annot2) | E_comment c -> alg.e_comment c | E_comment_struc e -> alg.e_comment_struc (fold_exp alg e) - | E_internal_let (lexp,e1,e2) -> + | E_var (lexp,e1,e2) -> alg.e_internal_let (fold_lexp alg lexp, fold_exp alg e1, fold_exp alg e2) | E_internal_plet (pat,e1,e2) -> alg.e_internal_plet (fold_pat alg.pat_alg pat, fold_exp alg e1, fold_exp alg e2) | E_internal_return e -> alg.e_internal_return (fold_exp alg e) + | E_internal_value v -> alg.e_internal_value v and fold_exp alg (E_aux (exp_aux,annot)) = alg.e_aux (fold_exp_aux alg exp_aux, annot) and fold_lexp_aux alg = function | LEXP_id id -> alg.lEXP_id id + | LEXP_deref exp -> alg.lEXP_deref (fold_exp alg exp) | LEXP_memory (id,es) -> alg.lEXP_memory (id, List.map (fold_exp alg) es) | LEXP_tup les -> alg.lEXP_tup (List.map (fold_lexp alg) les) | LEXP_cast (typ,id) -> alg.lEXP_cast (typ,id) @@ -632,6 +623,7 @@ let id_exp_alg = { e_block = (fun es -> E_block es) ; e_nondet = (fun es -> E_nondet es) ; e_id = (fun id -> E_id id) + ; e_ref = (fun id -> E_ref id) ; e_lit = (fun lit -> (E_lit lit)) ; e_cast = (fun (typ,e) -> E_cast (typ,e)) ; e_app = (fun (id,es) -> E_app (id,es)) @@ -666,11 +658,13 @@ let id_exp_alg = ; e_internal_exp_user = (fun (a1,a2) -> E_internal_exp_user (a1,a2)) ; e_comment = (fun c -> E_comment c) ; e_comment_struc = (fun e -> E_comment_struc e) - ; e_internal_let = (fun (lexp, e2, e3) -> E_internal_let (lexp,e2,e3)) + ; e_internal_let = (fun (lexp, e2, e3) -> E_var (lexp,e2,e3)) ; e_internal_plet = (fun (pat, e1, e2) -> E_internal_plet (pat,e1,e2)) ; e_internal_return = (fun e -> E_internal_return e) + ; e_internal_value = (fun v -> E_internal_value v) ; e_aux = (fun (e,annot) -> E_aux (e,annot)) ; lEXP_id = (fun id -> LEXP_id id) + ; lEXP_deref = (fun e -> LEXP_deref e) ; lEXP_memory = (fun (id,es) -> LEXP_memory (id,es)) ; lEXP_cast = (fun (typ,id) -> LEXP_cast (typ,id)) ; lEXP_tup = (fun tups -> LEXP_tup tups) @@ -725,6 +719,7 @@ let compute_exp_alg bot join = { e_block = split_join (fun es -> E_block es) ; e_nondet = split_join (fun es -> E_nondet es) ; e_id = (fun id -> (bot, E_id id)) + ; e_ref = (fun id -> (bot, E_ref id)) ; e_lit = (fun lit -> (bot, E_lit lit)) ; e_cast = (fun (typ,(v,e)) -> (v, E_cast (typ,e))) ; e_app = (fun (id,es) -> split_join (fun es -> E_app (id,es)) es) @@ -766,12 +761,14 @@ let compute_exp_alg bot join = ; e_comment = (fun c -> (bot, E_comment c)) ; e_comment_struc = (fun (v,e) -> (bot, E_comment_struc e)) (* ignore value by default, since it is comes from a comment *) ; e_internal_let = (fun ((vl, lexp), (v2,e2), (v3,e3)) -> - (join_list [vl;v2;v3], E_internal_let (lexp,e2,e3))) + (join_list [vl;v2;v3], E_var (lexp,e2,e3))) ; e_internal_plet = (fun ((vp,pat), (v1,e1), (v2,e2)) -> (join_list [vp;v1;v2], E_internal_plet (pat,e1,e2))) ; e_internal_return = (fun (v,e) -> (v, E_internal_return e)) + ; e_internal_value = (fun v -> (bot, E_internal_value v)) ; e_aux = (fun ((v,e),annot) -> (v, E_aux (e,annot))) ; lEXP_id = (fun id -> (bot, LEXP_id id)) + ; lEXP_deref = (fun (v, e) -> (v, LEXP_deref e)) ; lEXP_memory = (fun (id,es) -> split_join (fun es -> LEXP_memory (id,es)) es) ; lEXP_cast = (fun (typ,id) -> (bot, LEXP_cast (typ,id))) ; lEXP_tup = (fun ls -> diff --git a/src/rewriter.mli b/src/rewriter.mli index dc592a4d..c3c384bf 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -48,7 +48,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Big_int +module Big_int = Nat_big_num open Ast open Type_check @@ -108,6 +108,7 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, { e_block : 'exp list -> 'exp_aux ; e_nondet : 'exp list -> 'exp_aux ; e_id : id -> 'exp_aux + ; e_ref : id -> 'exp_aux ; e_lit : lit -> 'exp_aux ; e_cast : Ast.typ * 'exp -> 'exp_aux ; e_app : id * 'exp list -> 'exp_aux @@ -145,8 +146,10 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_internal_let : 'lexp * 'exp * 'exp -> 'exp_aux ; e_internal_plet : 'pat * 'exp * 'exp -> 'exp_aux ; e_internal_return : 'exp -> 'exp_aux + ; e_internal_value : Value.value -> 'exp_aux ; e_aux : 'exp_aux * 'a annot -> 'exp ; lEXP_id : id -> 'lexp_aux + ; lEXP_deref : 'exp -> 'lexp_aux ; lEXP_memory : id * 'exp list -> 'lexp_aux ; lEXP_cast : Ast.typ * id -> 'lexp_aux ; lEXP_tup : 'lexp list -> 'lexp_aux diff --git a/src/rewrites.ml b/src/rewrites.ml index 32ffe54a..e14ced08 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -48,7 +48,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Big_int +module Big_int = Nat_big_num open Ast open Ast_util open Type_check @@ -102,7 +102,6 @@ let effectful_effs = function | 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)) @@ -169,12 +168,12 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = 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 + let one_exp = infer_exp env (mk_lit_exp (L_num (Big_int.of_int 1))) 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 - | Some (_, len, _, _) when prove env (nc_eq len nexp) -> + | 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 @@ -329,6 +328,7 @@ let rewrite_sizeof (Defs defs) = { 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_ref = (fun id -> (E_ref id, E_ref 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'))) @@ -363,11 +363,13 @@ let rewrite_sizeof (Defs defs) = ; 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_let = (fun ((lexp,lexp'), (e2,e2'), (e3,e3')) -> (E_var (lexp,e2,e3), E_var (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_internal_value = (fun v -> (E_internal_value v, E_internal_value v)) ; 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_deref = (fun (e, e') -> (LEXP_deref e, LEXP_deref e')) ; 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')) @@ -643,8 +645,8 @@ let remove_vector_concat_pat pat = 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) + then Big_int.sub (Big_int.add start length) (Big_int.of_int 1) + else Big_int.add (Big_int.sub start length) (Big_int.of_int 1)) | _ -> raise (Reporting_basic.err_unreachable (fst rannot') ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern"))) in @@ -654,8 +656,8 @@ let remove_vector_concat_pat pat = 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) + then (Big_int.add pos i, Big_int.sub (Big_int.add pos i) (Big_int.of_int 1)) + else (Big_int.sub pos i, Big_int.add (Big_int.sub pos i) (Big_int.of_int 1)) | Nexp_aux (_,l) -> if is_last then (pos,last_idx) else @@ -755,8 +757,8 @@ let remove_vector_concat_pat pat = 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 rec aux a b = if Big_int.greater a b then [] else a :: aux (Big_int.add a (Big_int.of_int 1)) b in + if Big_int.greater a b then List.rev (aux b a) else aux a b in let remove_vector_concats = let p_vector_concat ps = @@ -770,9 +772,9 @@ let remove_vector_concat_pat pat = 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))) + acc @ (List.map wild (range Big_int.zero (Big_int.sub length (Big_int.of_int 1)))) | _, _ -> - (*if is_last then*) acc @ [wild zero_big_int] + (*if is_last then*) acc @ [wild Big_int.zero] else raise (Reporting_basic.err_unreachable l ("remove_vector_concats: Non-vector in vector-concat pattern " ^ @@ -942,6 +944,7 @@ let rec pat_to_exp (P_aux (pat,(l,annot))) = | P_wild -> raise (Reporting_basic.err_unreachable l "pat_to_exp given wildcard pattern") | P_as (pat,id) -> rewrap (E_id id) + | P_var (pat, _) -> pat_to_exp pat | 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)) @@ -1036,7 +1039,7 @@ let compose_guard_opt g1 g2 = match g1, g2 with 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_as (pat,_) | P_typ (_,pat) | P_var (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 @@ -1112,7 +1115,7 @@ let remove_bitvector_pat (P_aux (_, (l, _)) as pat) = 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)) -> + when Big_int.equal s i && Big_int.equal l (Big_int.of_int (List.length lits)) -> mk_exp (E_id rootid) | _ -> mk_exp (E_vector_subrange (mk_exp (E_id rootid), mk_num_exp i, mk_num_exp j)) in @@ -1139,7 +1142,7 @@ let remove_bitvector_pat (P_aux (_, (l, _)) as 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 + let idx' = if is_order_inc ord then Big_int.add idx (Big_int.of_int 1) else Big_int.sub idx (Big_int.of_int 1) in (match ps with | pat :: ps' -> (match pat with @@ -1365,7 +1368,7 @@ let rewrite_fun_guarded_pats rewriters (FD_aux (FD_function (r,t,e,funcls),(l,fd (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,construct_pexp (pat,None,exp,(Unknown,None))),annot)) cs + FCL_aux (FCL_Funcl(id,construct_pexp (pat,None,exp,(Parse_ast.Unknown,None))),annot)) cs | _ -> funcls (* TODO is the empty list possible here? *) in FD_aux (FD_function(r,t,e,funcls),(l,fdannot)) @@ -1383,7 +1386,7 @@ let id_is_unbound id env = match Env.lookup_id id env with | _ -> false let rec lexp_is_local (LEXP_aux (lexp, _)) env = match lexp with - | LEXP_memory _ -> false + | LEXP_memory _ | LEXP_deref _ -> 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 @@ -1392,7 +1395,7 @@ let rec lexp_is_local (LEXP_aux (lexp, _)) env = match lexp with | LEXP_field (lexp,_) -> lexp_is_local lexp env let rec lexp_is_local_intro (LEXP_aux (lexp, _)) env = match lexp with - | LEXP_memory _ -> false + | LEXP_memory _ | LEXP_deref _ -> 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 @@ -1407,7 +1410,7 @@ let lexp_is_effectful (LEXP_aux (_, (_, annot))) = match annot with let rec rewrite_lexp_to_rhs (do_rewrite : tannot lexp -> bool) ((LEXP_aux(lexp,((l,_) as annot))) as le) = if do_rewrite le then match lexp with - | LEXP_id _ | LEXP_cast (_, _) | LEXP_tup _ -> (le, (fun exp -> exp)) + | LEXP_id _ | LEXP_cast (_, _) | LEXP_tup _ | LEXP_deref _ -> (le, (fun exp -> exp)) | LEXP_vector (lexp, e) -> let (lhs, rhs) = rewrite_lexp_to_rhs do_rewrite lexp in (lhs, (fun exp -> rhs (E_aux (E_vector_update (lexp_to_exp lexp, e, exp), annot)))) @@ -1420,21 +1423,6 @@ let rec rewrite_lexp_to_rhs (do_rewrite : tannot lexp -> bool) ((LEXP_aux(lexp,( let (LEXP_aux (_, lannot)) = lexp in let env = env_of_annot lannot in match Env.expand_synonyms env (typ_of_annot lannot) with - | Typ_aux (Typ_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id regtyp_id, _)), _)]), _) - | Typ_aux (Typ_id regtyp_id, _) when Env.is_regtyp regtyp_id env -> - let base, top, ranges = Env.get_regtyp regtyp_id env in - let range, _ = - try List.find (fun (_, fid) -> Id.compare fid id = 0) ranges with - | Not_found -> - raise (Reporting_basic.err_typ l ("Field " ^ string_of_id id ^ " doesn't exist for register type " ^ string_of_id regtyp_id)) - in - let lexp_exp = E_aux (E_app (mk_id ("cast_" ^ string_of_id regtyp_id), [lexp_to_exp lexp]), (l, None)) in - let n, m = match range with - | BF_aux (BF_single n, _) -> n, n - | BF_aux (BF_range (n, m), _) -> n, m - | _ -> raise (Reporting_basic.err_unreachable l ("Unsupported lexp: " ^ string_of_lexp le)) in - let rhs' exp = rhs (E_aux (E_vector_update_subrange (lexp_exp, simple_num l n, simple_num l m, exp), lannot)) in - (lhs, rhs') | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> 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), lannot)))) @@ -1469,7 +1457,7 @@ let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as f 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))] + [fix_eff_exp (E_aux (E_var(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 @@ -1506,7 +1494,7 @@ let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as f (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)), + ([E_aux (E_var (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)))), @@ -1522,7 +1510,7 @@ let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as f let e' = re' (rewrite_base e) in let block = annot_exp (E_block []) l (env_of full_exp) unit_typ in check_exp (env_of full_exp) - (strip_exp (E_aux (E_internal_let(le', e', block), annot))) (typ_of full_exp) + (strip_exp (E_aux (E_var(le', e', block), annot))) (typ_of full_exp) | _ -> rewrite_base full_exp let rewrite_lexp_lift_assign_intro rewriters ((LEXP_aux(lexp,annot)) as le) = @@ -1571,46 +1559,8 @@ let rewrite_register_ref_writes (Defs defs) = | None -> E_assign (lexp, exp) in let rewrite_exp _ = fold_exp { id_exp_alg with e_assign = e_assign } in - let generate_field_accessors l env id n1 n2 fields = - let i1, i2 = match n1, n2 with - | Nexp_aux(Nexp_constant i1, _),Nexp_aux(Nexp_constant i2, _) -> i1, i2 - | _ -> raise (Reporting_basic.err_typ l - ("Non-constant indices in register type " ^ string_of_id id)) in - let dir_b = i1 < i2 in - let dir = (if dir_b then "true" else "false") in - let ord = Ord_aux ((if dir_b then Ord_inc else Ord_dec), Parse_ast.Unknown) in - let size = if dir_b then succ_big_int (sub_big_int i2 i1) else succ_big_int (sub_big_int i1 i2) in - let rtyp = mk_id_typ id in - let vtyp = vector_typ (nconstant i1) (nconstant size) ord bit_typ in - let accessors (fr, fid) = - let i, j = match fr with - | BF_aux (BF_single i, _) -> (i, i) - | BF_aux (BF_range (i, j), _) -> (i, j) - | _ -> raise (Reporting_basic.err_unreachable l "unsupported field type") in - let mk_num_exp i = mk_lit_exp (L_num i) in - let reg_pat, reg_env = bind_pat env (mk_pat (P_typ (rtyp, mk_pat (P_id (mk_id "reg"))))) rtyp in - let inferred_get = infer_exp reg_env (mk_exp (E_vector_subrange - (mk_exp (E_id (mk_id "reg")), mk_num_exp i, mk_num_exp j))) in - let ftyp = typ_of inferred_get in - let v_pat, v_env = bind_pat reg_env (mk_pat (P_typ (ftyp, mk_pat (P_id (mk_id "v"))))) ftyp in - let inferred_set = infer_exp v_env (mk_exp (E_vector_update_subrange - (mk_exp (E_id (mk_id "reg")), mk_num_exp i, mk_num_exp j, mk_exp (E_id (mk_id "v"))))) in - let set_args = P_aux (P_tup [reg_pat; v_pat], (l, Some (env, tuple_typ [rtyp; ftyp], no_effect))) in - let fsuffix = "_" ^ string_of_id id ^ "_" ^ string_of_id fid in - let rec_opt = Rec_aux (Rec_nonrec, l) in - let tannot ret_typ = Typ_annot_opt_aux (Typ_annot_opt_some (TypQ_aux (TypQ_tq [], l), ret_typ), l) in - let eff_opt = Effect_opt_aux (Effect_opt_pure, l) in - let mk_funcl id pat exp = FCL_aux (FCL_Funcl (mk_id id, Pat_aux (Pat_exp (pat, exp),(l,None))), (l, None)) in - let mk_fundef id pat exp ret_typ = DEF_fundef (FD_aux (FD_function (rec_opt, tannot ret_typ, eff_opt, [mk_funcl id pat exp]), (l, None))) in - [mk_fundef ("get" ^ fsuffix) reg_pat inferred_get ftyp; - mk_fundef ("set" ^ fsuffix) set_args inferred_set (typ_of inferred_set)] in - List.concat (List.map accessors fields) in - let rewriters = { rewriters_base with rewrite_exp = rewrite_exp } in let rec rewrite ds = match ds with - | (DEF_type (TD_aux (TD_register (id, n1, n2, fields), (l, Some (env, _, _)))) as d) :: ds -> - let (Defs d), env = check env (Defs [d]) in - d @ (generate_field_accessors l env id n1 n2 fields) @ rewrite ds | d::ds -> (rewriters.rewrite_def rewriters d)::(rewrite ds) | [] -> [] in Defs (rewrite (write_reg_spec @ defs)) @@ -1653,8 +1603,8 @@ let rewrite_register_ref_writes (Defs defs) = (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)) + | E_var (lexp,exp,body) -> + rewrap (E_var (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 @@ -1797,6 +1747,7 @@ let rewrite_fix_val_specs (Defs defs) = 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' + | _ -> assert false (* find_vs must return a function type *) in let annot = add_effect_annot annot eff in (Bindings.add id vs val_specs, @@ -1926,7 +1877,7 @@ let rewrite_type_def_typs rw_typ rw_typquant rw_typschm (TD_aux (td, 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) + | TD_bitfield _ -> assert false (* Processed before re-writing *) (* FIXME: other reg_dec types *) let rewrite_dec_spec_typs rw_typ (DEC_aux (ds, annot)) = @@ -1966,7 +1917,7 @@ let rewrite_undefined mwords = 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 (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") @@ -2048,15 +1999,15 @@ let rewrite_tuple_vector_assignments defs = 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 + | _ -> (Big_int.of_int 1) + else (Big_int.of_int 1) 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 + then (Big_int.sub (Big_int.add i step) (Big_int.of_int 1), Big_int.add i step) + else (Big_int.add (Big_int.sub i step) (Big_int.of_int 1), Big_int.sub 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 + | _ -> if is_order_inc ord then Big_int.zero 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 @@ -2189,8 +2140,8 @@ let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list match l with | [] -> k [] | exp :: exps -> f exp (fun exp -> mapCont f exps (fun exps -> k (exp :: exps))) - -let rewrite_defs_letbind_effects = + +let rewrite_defs_letbind_effects = let rec value ((E_aux (exp_aux,_)) as exp) = not (effectful exp || updates_vars exp) @@ -2212,7 +2163,7 @@ let rewrite_defs_letbind_effects = 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 -> + 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 = @@ -2252,6 +2203,9 @@ let rewrite_defs_letbind_effects = let (LEXP_aux (lexp_aux,annot)) = lexp in match lexp_aux with | LEXP_id _ -> k lexp + | LEXP_deref exp -> + n_exp exp (fun exp -> + k (fix_eff_lexp (LEXP_aux (LEXP_deref exp, annot)))) | LEXP_memory (id,es) -> n_exp_nameL es (fun es -> k (fix_eff_lexp (LEXP_aux (LEXP_memory (id,es),annot)))) @@ -2297,6 +2251,7 @@ let rewrite_defs_letbind_effects = | 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_ref id -> k exp | E_lit _ -> k exp | E_cast (typ,exp') -> n_exp_name exp' (fun exp' -> @@ -2320,7 +2275,7 @@ let rewrite_defs_letbind_effects = 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 start (fun start -> n_exp_name stop (fun stop -> n_exp_name by (fun by -> let body = n_exp_term (effectful body) body in @@ -2337,19 +2292,19 @@ let rewrite_defs_letbind_effects = 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 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 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 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) -> @@ -2359,14 +2314,14 @@ let rewrite_defs_letbind_effects = | E_list exps -> n_exp_nameL exps (fun exps -> k (rewrap (E_list exps))) - | E_cons (exp1,exp2) -> + | 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) -> + | E_record_update (exp1,fexps) -> n_exp_name exp1 (fun exp1 -> n_fexps fexps (fun fexps -> k (rewrap (E_record_update (exp1,fexps))))) @@ -2375,7 +2330,7 @@ let rewrite_defs_letbind_effects = 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_exp_name exp1 (fun exp1 -> n_pexpL newreturn pexps (fun pexps -> k (rewrap (E_case (exp1,pexps))))) | E_try (exp1,pexps) -> @@ -2384,7 +2339,7 @@ let rewrite_defs_letbind_effects = n_pexpL newreturn pexps (fun pexps -> k (rewrap (E_try (exp1,pexps))))) | E_let (lb,body) -> - n_lb lb (fun lb -> + n_lb lb (fun lb -> rewrap (E_let (lb,n_exp body k))) | E_sizeof nexp -> k (rewrap (E_sizeof nexp)) @@ -2406,18 +2361,20 @@ let rewrite_defs_letbind_effects = k (rewrap (E_internal_cast (annot',exp')))) | E_internal_exp _ -> k exp | E_internal_exp_user _ -> k exp - | E_internal_let (lexp,exp1,exp2) -> + | E_var (lexp,exp1,exp2) -> n_lexp lexp (fun lexp -> n_exp exp1 (fun exp1 -> - rewrap (E_internal_let (lexp,exp1,n_exp exp2 k)))) + rewrap (E_var (lexp,exp1,n_exp exp2 k)))) | E_internal_return exp1 -> n_exp_name exp1 (fun exp1 -> k (rewrap (E_internal_return exp1))) + | E_internal_value v -> + k (rewrap (E_internal_value v)) | E_comment str -> - k (rewrap (E_comment str)) + k (rewrap (E_comment str)) | E_comment_struc exp' -> n_exp exp' (fun exp' -> - k (rewrap (E_comment_struc exp'))) + k (rewrap (E_comment_struc exp'))) | E_return exp' -> n_exp_name exp' (fun exp' -> k (rewrap (E_return exp'))) @@ -2487,7 +2444,7 @@ let rewrite_defs_internal_lets = (P_id id, annot) | LEXP_aux (LEXP_cast (typ, id), annot) -> (P_typ (typ, P_aux (P_id id, annot)), annot) - | _ -> failwith "E_internal_let with unexpected lexp" in + | _ -> failwith "E_var with unexpected lexp" in if effectful exp1 then E_internal_plet (P_aux (paux, annot), exp1, exp2) else @@ -2595,9 +2552,9 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = | 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) -> + | E_var (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_aux (E_var (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) @@ -2791,8 +2748,8 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = 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 *) + | E_var (lexp,v,body) -> + (* Rewrite E_var into E_let and call recursively *) let paux, typ = match lexp with | LEXP_aux (LEXP_id id, _) -> P_id id, typ_of v @@ -2800,7 +2757,7 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = P_typ (typ, annot_pat (P_id id) l env (typ_of v)), typ | _ -> raise (Reporting_basic.err_unreachable l - "E_internal_let with a lexp that is not a variable") in + "E_var with a lexp that is not a variable") in let lb = annot_letbind (paux, v) l env typ in let exp = propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) in rewrite_var_updates exp @@ -3001,6 +2958,15 @@ let rewrite_defs_ocaml = [ (* ("separate_numbs", rewrite_defs_separate_numbs) *) ] +let rewrite_defs_interpreter = [ + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ] + let rewrite_defs_sil = [ ("top_sort_defs", top_sort_defs); ("tuple_vector_assignments", rewrite_tuple_vector_assignments); diff --git a/src/rewrites.mli b/src/rewrites.mli index ce24a4c4..8fceadff 100644 --- a/src/rewrites.mli +++ b/src/rewrites.mli @@ -57,6 +57,9 @@ 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 interpreter *) +val rewrite_defs_interpreter : (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 diff --git a/src/sail.ml b/src/sail.ml index 9bb7cfcb..41ca792c 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -52,6 +52,7 @@ open Process_file let lib = ref ([] : string list) let opt_file_out : string option ref = ref None +let opt_interactive = ref false let opt_print_version = ref false let opt_print_initial_env = ref false let opt_print_verbose = ref false @@ -59,7 +60,6 @@ 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 let opt_sanity = ref false let opt_libs_lem = ref ([]:string list) @@ -71,6 +71,9 @@ let options = Arg.align ([ ( "-o", Arg.String (fun f -> opt_file_out := Some f), "<prefix> select output filename prefix"); + ( "-i", + Arg.Tuple [Arg.Set opt_interactive; Arg.Set Initial_check.opt_undefined_gen], + " start interactive interpreter"); ( "-ocaml", Arg.Tuple [Arg.Set opt_print_ocaml; Arg.Set Initial_check.opt_undefined_gen], " output an OCaml translated version of the input"); @@ -114,12 +117,6 @@ let options = Arg.align ([ ( "-no_effects", Arg.Set Type_check.opt_no_effects, " (experimental) turn off effect checking"); - ( "-new_parser", - Arg.Set Process_file.opt_new_parser, - " (experimental) use new parser"); - ( "-convert", - Arg.Set opt_convert, - " (experimental) convert sail to new syntax for use with -new_parser"); ( "-just_check", Arg.Set opt_just_check, " (experimental) terminate immediately after typechecking"); @@ -169,6 +166,8 @@ let _ = opt_file_arguments := (!opt_file_arguments) @ [s]) usage_msg +let interactive_ast = ref (Ast.Defs []) +let interactive_env = ref Type_check.initial_env let main() = if !opt_print_version @@ -182,10 +181,6 @@ let main() = -> Parse_ast.Defs (ast_nodes@later_nodes)) parsed (Parse_ast.Defs []) in let ast = convert_ast Ast_util.inc_ord ast in - if !opt_convert - then (Pretty_print_sail2.pp_defs stdout ast; exit 0) - else (); - let (ast, type_envs) = check_ast ast in let (ast, type_envs) = @@ -208,13 +203,17 @@ let main() = (*let _ = Printf.eprintf "Type checked, next to pretty print" in*) begin + (if !(opt_interactive) + then + (interactive_ast := Process_file.rewrite_ast_interpreter ast; interactive_env := type_envs) + else ()); (if !(opt_sanity) then let _ = rewrite_ast_check ast in () else ()); (if !(opt_print_verbose) - then ((Pretty_print.pp_defs stdout) ast) + then ((Pretty_print_sail.pp_defs stdout) ast) else ()); (if !(opt_print_lem_ast) then output "" Lem_ast_out [out_name,ast] @@ -222,7 +221,7 @@ let main() = (if !(opt_print_sil) then let ast = rewrite_ast_sil ast in - Pretty_print_sail2.pp_defs stdout ast + Pretty_print_sail.pp_defs stdout ast else ()); (if !(opt_print_ocaml) then diff --git a/src/sail_lib.ml b/src/sail_lib.ml new file mode 100644 index 00000000..849aa16c --- /dev/null +++ b/src/sail_lib.ml @@ -0,0 +1,479 @@ +module Big_int = Nat_big_num + +type 'a return = { return : 'b . 'a -> 'b } + +let opt_trace = ref false + +let trace_depth = ref 0 +let random = ref false + +let sail_call (type t) (f : _ -> t) = + let module M = + struct exception Return of t end + in + let return = { return = (fun x -> raise (M.Return x)) } in + try + f return + with M.Return x -> x + +let trace str = + if !opt_trace + then + begin + if !trace_depth < 0 then trace_depth := 0 else (); + prerr_endline (String.make (!trace_depth * 2) ' ' ^ str) + end + else () + +let trace_write name str = + trace ("Write: " ^ name ^ " " ^ str) + +let trace_read name str = + trace ("Read: " ^ name ^ " " ^ str) + +let sail_trace_call (type t) (name : string) (in_string : string) (string_of_out : t -> string) (f : _ -> t) = + let module M = + struct exception Return of t end + in + let return = { return = (fun x -> raise (M.Return x)) } in + trace ("Call: " ^ name ^ " " ^ in_string); + incr trace_depth; + let result = try f return with M.Return x -> x in + decr trace_depth; + trace ("Return: " ^ string_of_out result); + result + +let trace_call str = + trace str; incr trace_depth + +type bit = B0 | B1 + +let and_bit = function + | B1, B1 -> B1 + | _, _ -> B0 + +let or_bit = function + | B0, B0 -> B0 + | _, _ -> B1 + +let xor_bit = function + | B1, B0 -> B1 + | B0, B1 -> B1 + | _, _ -> B0 + +let and_vec (xs, ys) = + assert (List.length xs = List.length ys); + List.map2 (fun x y -> and_bit (x, y)) xs ys + +let and_bool (b1, b2) = b1 && b2 + +let or_vec (xs, ys) = + assert (List.length xs = List.length ys); + List.map2 (fun x y -> or_bit (x, y)) xs ys + +let or_bool (b1, b2) = b1 || b2 + +let xor_vec (xs, ys) = + assert (List.length xs = List.length ys); + List.map2 (fun x y -> xor_bit (x, y)) xs ys + +let xor_bool (b1, b2) = (b1 || b2) && (b1 != b2) + +let undefined_bit () = + if !random + then (if Random.bool () then B0 else B1) + else B0 + +let undefined_bool () = + if !random then Random.bool () else false + +let rec undefined_vector (len, item) = + if Big_int.equal len Big_int.zero + then [] + else item :: undefined_vector (Big_int.sub len (Big_int.of_int 1), item) + +let undefined_string () = "" + +let undefined_unit () = () + +let undefined_int () = + if !random then Big_int.of_int (Random.int 0xFFFF) else Big_int.zero + +let undefined_nat () = Big_int.zero + +let undefined_range (lo, hi) = lo + +let internal_pick list = + if !random + then List.nth list (Random.int (List.length list)) + else List.nth list 0 + +let eq_int (n, m) = Big_int.equal n m + +let rec drop n xs = + match n, xs with + | 0, xs -> xs + | n, [] -> [] + | n, (x :: xs) -> drop (n -1) xs + +let rec take n xs = + match n, xs with + | 0, xs -> [] + | n, (x :: xs) -> x :: take (n - 1) xs + | n, [] -> [] + +let subrange (list, n, m) = + let n = Big_int.to_int n in + let m = Big_int.to_int m in + List.rev (take (n - (m - 1)) (drop m (List.rev list))) + +let slice (list, n, m) = + let n = Big_int.to_int n in + let m = Big_int.to_int m in + List.rev (take m (drop n (List.rev list))) + +let eq_list (xs, ys) = List.for_all2 (fun x y -> x = y) xs ys + +let access (xs, n) = List.nth (List.rev xs) (Big_int.to_int n) + +let append (xs, ys) = xs @ ys + +let update (xs, n, x) = + let n = (List.length xs - Big_int.to_int n) - 1 in + take n xs @ [x] @ drop (n + 1) xs + +let update_subrange (xs, n, m, ys) = + let rec aux xs o = function + | [] -> xs + | (y :: ys) -> aux (update (xs, o, y)) (Big_int.sub o (Big_int.of_int 1)) ys + in + aux xs n ys + + +let length xs = Big_int.of_int (List.length xs) + +let big_int_of_bit = function + | B0 -> Big_int.zero + | B1 -> (Big_int.of_int 1) + +let uint xs = + let uint_bit x (n, pos) = + Big_int.add n (Big_int.mul (Big_int.pow_int_positive 2 pos) (big_int_of_bit x)), pos + 1 + in + fst (List.fold_right uint_bit xs (Big_int.zero, 0)) + +let sint = function + | [] -> Big_int.zero + | [msb] -> Big_int.negate (big_int_of_bit msb) + | msb :: xs -> + let msb_pos = List.length xs in + let complement = + Big_int.negate (Big_int.mul (Big_int.pow_int_positive 2 msb_pos) (big_int_of_bit msb)) + in + Big_int.add complement (uint xs) + +let add (x, y) = Big_int.add x y +let sub (x, y) = Big_int.sub x y +let mult (x, y) = Big_int.mul x y +let quotient (x, y) = Big_int.div x y +let modulus (x, y) = Big_int.modulus x y + +let add_bit_with_carry (x, y, carry) = + match x, y, carry with + | B0, B0, B0 -> B0, B0 + | B0, B1, B0 -> B1, B0 + | B1, B0, B0 -> B1, B0 + | B1, B1, B0 -> B0, B1 + | B0, B0, B1 -> B1, B0 + | B0, B1, B1 -> B0, B1 + | B1, B0, B1 -> B0, B1 + | B1, B1, B1 -> B1, B1 + +let sub_bit_with_carry (x, y, carry) = + match x, y, carry with + | B0, B0, B0 -> B0, B0 + | B0, B1, B0 -> B0, B1 + | B1, B0, B0 -> B1, B0 + | B1, B1, B0 -> B0, B0 + | B0, B0, B1 -> B1, B0 + | B0, B1, B1 -> B0, B0 + | B1, B0, B1 -> B1, B1 + | B1, B1, B1 -> B1, B0 + +let not_bit = function + | B0 -> B1 + | B1 -> B0 + +let not_vec xs = List.map not_bit xs + +let add_vec_carry (xs, ys) = + assert (List.length xs = List.length ys); + let (carry, result) = + List.fold_right2 (fun x y (c, result) -> let (z, c) = add_bit_with_carry (x, y, c) in (c, z :: result)) xs ys (B0, []) + in + carry, result + +let add_vec (xs, ys) = snd (add_vec_carry (xs, ys)) + +let rec replicate_bits (bits, n) = + if Big_int.less_equal n Big_int.zero + then [] + else bits @ replicate_bits (bits, Big_int.sub n (Big_int.of_int 1)) + +let identity x = x + +let rec bits_of_big_int bit n = + if not (Big_int.equal bit Big_int.zero) + then + begin + if Big_int.greater (Big_int.div n bit) Big_int.zero + then B1 :: bits_of_big_int (Big_int.div bit (Big_int.of_int 2)) (Big_int.sub n bit) + else B0 :: bits_of_big_int (Big_int.div bit (Big_int.of_int 2)) n + end + else [] + +let add_vec_int (v, n) = + let n_bits = bits_of_big_int (Big_int.pow_int_positive 2 (List.length v - 1)) n in + add_vec(v, n_bits) + +let sub_vec (xs, ys) = add_vec (xs, add_vec_int (not_vec ys, (Big_int.of_int 1))) + +let sub_vec_int (v, n) = + let n_bits = bits_of_big_int (Big_int.pow_int_positive 2 (List.length v - 1)) n in + sub_vec(v, n_bits) + +let get_slice_int (n, m, o) = + let bits = bits_of_big_int (Big_int.pow_int_positive 2 (Big_int.add n o |> Big_int.to_int)) (Big_int.abs m) in + let bits = + if Big_int.less m Big_int.zero + then sub_vec (List.map (fun _ -> B0) bits, bits) + else bits + in + let slice = List.rev (take (Big_int.to_int n) (drop (Big_int.to_int o) (List.rev bits))) in + assert (Big_int.equal (Big_int.of_int (List.length slice)) n); + slice + +let hex_char = function + | '0' -> [B0; B0; B0; B0] + | '1' -> [B0; B0; B0; B1] + | '2' -> [B0; B0; B1; B0] + | '3' -> [B0; B0; B1; B1] + | '4' -> [B0; B1; B0; B0] + | '5' -> [B0; B1; B0; B1] + | '6' -> [B0; B1; B1; B0] + | '7' -> [B0; B1; B1; B1] + | '8' -> [B1; B0; B0; B0] + | '9' -> [B1; B0; B0; B1] + | 'A' | 'a' -> [B1; B0; B1; B0] + | 'B' | 'b' -> [B1; B0; B1; B1] + | 'C' | 'c' -> [B1; B1; B0; B0] + | 'D' | 'd' -> [B1; B1; B0; B1] + | 'E' | 'e' -> [B1; B1; B1; B0] + | 'F' | 'f' -> [B1; B1; B1; B1] + | _ -> failwith "Invalid hex character" + +let list_of_string s = + let rec aux i acc = + if i < 0 then acc + else aux (i-1) (s.[i] :: acc) + in aux (String.length s - 1) [] + +let bits_of_string str = + List.concat (List.map hex_char (list_of_string str)) + +let concat_str (str1, str2) = str1 ^ str2 + +let rec break n = function + | [] -> [] + | (_ :: _ as xs) -> [take n xs] @ break n (drop n xs) + +let string_of_bit = function + | B0 -> "0" + | B1 -> "1" + +let string_of_hex = function + | [B0; B0; B0; B0] -> "0" + | [B0; B0; B0; B1] -> "1" + | [B0; B0; B1; B0] -> "2" + | [B0; B0; B1; B1] -> "3" + | [B0; B1; B0; B0] -> "4" + | [B0; B1; B0; B1] -> "5" + | [B0; B1; B1; B0] -> "6" + | [B0; B1; B1; B1] -> "7" + | [B1; B0; B0; B0] -> "8" + | [B1; B0; B0; B1] -> "9" + | [B1; B0; B1; B0] -> "A" + | [B1; B0; B1; B1] -> "B" + | [B1; B1; B0; B0] -> "C" + | [B1; B1; B0; B1] -> "D" + | [B1; B1; B1; B0] -> "E" + | [B1; B1; B1; B1] -> "F" + | _ -> failwith "Cannot convert binary sequence to hex" + +let string_of_bits bits = + if List.length bits mod 4 == 0 + then "0x" ^ String.concat "" (List.map string_of_hex (break 4 bits)) + else "0b" ^ String.concat "" (List.map string_of_bit bits) + +let hex_slice (str, n, m) = + let bits = List.concat (List.map hex_char (list_of_string (String.sub str 2 (String.length str - 2)))) in + let padding = replicate_bits([B0], n) in + let bits = padding @ bits in + let slice = List.rev (take (Big_int.to_int n) (drop (Big_int.to_int m) (List.rev bits))) in + slice + +let putchar n = + print_char (char_of_int (Big_int.to_int n)); + flush stdout + +let rec bits_of_int bit n = + if bit <> 0 + then + begin + if n / bit > 0 + then B1 :: bits_of_int (bit / 2) (n - bit) + else B0 :: bits_of_int (bit / 2) n + end + else [] + +let byte_of_int n = bits_of_int 128 n + +module BigIntHash = + struct + type t = Big_int.num + let equal i j = Big_int.equal i j + let hash i = Hashtbl.hash i + end + +module RAM = Hashtbl.Make(BigIntHash) + +let ram : int RAM.t = RAM.create 256 + +let write_ram' (addr_size, data_size, hex_ram, addr, data) = + let data = List.map (fun byte -> Big_int.to_int (uint byte)) (break 8 data) in + let rec write_byte i byte = + trace (Printf.sprintf "Store: %s 0x%02X" (Big_int.to_string (Big_int.add addr (Big_int.of_int i))) byte); + RAM.add ram (Big_int.add addr (Big_int.of_int i)) byte + in + List.iteri write_byte (List.rev data) + +let write_ram (addr_size, data_size, hex_ram, addr, data) = + write_ram' (addr_size, data_size, hex_ram, uint addr, data) + +let wram addr byte = + RAM.add ram addr byte + +let read_ram (addr_size, data_size, hex_ram, addr) = + let addr = uint addr in + let rec read_byte i = + if Big_int.equal i Big_int.zero + then [] + else + begin + let loc = Big_int.sub (Big_int.add addr i) (Big_int.of_int 1) in + let byte = try RAM.find ram loc with Not_found -> 0 in + trace (Printf.sprintf "Load: %s 0x%02X" (Big_int.to_string loc) byte); + byte_of_int byte @ read_byte (Big_int.sub i (Big_int.of_int 1)) + end + in + read_byte data_size + +let rec reverse_endianness bits = + if List.length bits <= 8 then bits else + reverse_endianness (drop 8 bits) @ (take 8 bits) + +(* FIXME: Casts can't be externed *) +let zcast_unit_vec x = [x] + +let shl_int (n, m) = Big_int.shift_left n (Big_int.to_int m) +let shr_int (n, m) = Big_int.shift_right n (Big_int.to_int m) + +let debug (str1, n, str2, v) = prerr_endline (str1 ^ Big_int.to_string n ^ str2 ^ string_of_bits v) + +let eq_string (str1, str2) = String.compare str1 str2 == 0 + +let lt_int (x, y) = Big_int.less x y + +let set_slice (out_len, slice_len, out, n, slice) = + let out = update_subrange(out, Big_int.add n (Big_int.of_int (List.length slice - 1)), n, slice) in + assert (List.length out = Big_int.to_int out_len); + out + +let set_slice_int (_, _, _, _) = assert false + +(* +let eq_real (x, y) = Num.eq_num x y +let lt_real (x, y) = Num.lt_num x y +let gt_real (x, y) = Num.gt_num x y +let lteq_real (x, y) = Num.le_num x y +let gteq_real (x, y) = Num.ge_num x y + +let round_down x = Num.big_int_of_num (Num.floor_num x) +let round_up x = Num.big_int_of_num (Num.ceiling_num x) +let quotient_real (x, y) = Num.div_num x y +let mult_real (x, y) = Num.mult_num x y +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) = Big_int.less x y +let gt (x, y) = Big_int.greater x y +let lteq (x, y) = Big_int.less_equal x y +let gteq (x, y) = Big_int.greater_equal x y + +let pow2 x = Big_int.pow_int x 2 + +let max_int (x, y) = Big_int.max x y +let min_int (x, y) = Big_int.min x y +let abs_int x = Big_int.abs x + +(* +let undefined_real () = Num.num_of_int 0 + +let real_of_string str = + try + let point = String.index str '.' in + let whole = Num.num_of_string (String.sub str 0 point) in + let frac_str = String.sub str (point + 1) (String.length str - (point + 1)) in + let frac = Num.div_num (Num.num_of_string frac_str) (Num.num_of_big_int (Big_int.pow_int_positive 10 (String.length frac_str))) in + Num.add_num whole frac + with + | Not_found -> Num.num_of_string str + +(* Not a very good sqrt implementation *) +let sqrt_real x = real_of_string (string_of_float (sqrt (Num.float_of_num x))) + *) + +let print_int (str, x) = + print_endline (str ^ Big_int.to_string x) + +let print_bits (str, xs) = + print_endline (str ^ string_of_bits xs) + +let reg_deref r = !r + +let string_of_zbit = function + | B0 -> "0" + | B1 -> "1" +let string_of_znat n = Big_int.to_string n +let string_of_zint n = Big_int.to_string n +let string_of_zunit () = "()" +let string_of_zbool = function + | true -> "true" + | false -> "false" +(* let string_of_zreal r = Num.string_of_num r *) +let string_of_zstring str = "\"" ^ String.escaped str ^ "\"" + +let rec string_of_list sep string_of = function + | [] -> "" + | [x] -> string_of x + | x::ls -> (string_of x) ^ sep ^ (string_of_list sep string_of ls) + +let zero_extend (vec, n) = + let m = Big_int.to_int n in + if m <= List.length vec + then take m vec + else replicate_bits ([B0], Big_int.of_int (m - List.length vec)) @ vec diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index b35bc48f..23ce6663 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -101,64 +101,64 @@ let rec default_order (Defs defs) = | (Nneg n, Nconst max) | (Nneg n, N2n(_, Some max))-> (match n.nexp with | Nconst abs_min | N2n(_,Some abs_min) -> - (minus_big_int abs_min), max + (Big_int.negate abs_min), max | _ -> assert false (*Put a better error message here*)) | (Nconst min,Nneg n) | (N2n(_, Some min), Nneg n) -> (match n.nexp with | Nconst abs_max | N2n(_,Some abs_max) -> - min, (minus_big_int abs_max) + min, (Big_int.negate abs_max) | _ -> assert false (*Put a better error message here*)) | (Nneg nmin, Nneg nmax) -> ((match nmin.nexp with - | Nconst abs_min | N2n(_,Some abs_min) -> (minus_big_int abs_min) + | Nconst abs_min | N2n(_,Some abs_min) -> (Big_int.negate abs_min) | _ -> assert false (*Put a better error message here*)), (match nmax.nexp with - | Nconst abs_max | N2n(_,Some abs_max) -> (minus_big_int abs_max) + | Nconst abs_max | N2n(_,Some abs_max) -> (Big_int.negate abs_max) | _ -> assert false (*Put a better error message here*))) | _ -> assert false - in le_big_int min candidate && le_big_int candidate max + in Big_int.less_equal min candidate && Big_int.less_equal candidate max | _ -> assert false (*Rmove me when switch to zarith*) let rec power_big_int b n = - if eq_big_int n zero_big_int - then unit_big_int - else mult_big_int b (power_big_int b (sub_big_int n unit_big_int)) + if Big_int.equal n Big_int.zero + then (Big_int.of_int 1) + else Big_int.mul b (power_big_int b (Big_int.sub n (Big_int.of_int 1))) let unpower_of_2 b = - let two = big_int_of_int 2 in - let four = big_int_of_int 4 in - let eight = big_int_of_int 8 in - let sixteen = big_int_of_int 16 in - let thirty_two = big_int_of_int 32 in - let sixty_four = big_int_of_int 64 in - let onetwentyeight = big_int_of_int 128 in - let twofiftysix = big_int_of_int 256 in - let fivetwelve = big_int_of_int 512 in - let oneotwentyfour = big_int_of_int 1024 in - let to_the_sixteen = big_int_of_int 65536 in - let to_the_thirtytwo = big_int_of_string "4294967296" in - let to_the_sixtyfour = big_int_of_string "18446744073709551616" in - let ck i = eq_big_int b i in - if ck unit_big_int then zero_big_int - else if ck two then unit_big_int + let two = Big_int.of_int 2 in + let four = Big_int.of_int 4 in + let eight = Big_int.of_int 8 in + let sixteen = Big_int.of_int 16 in + let thirty_two = Big_int.of_int 32 in + let sixty_four = Big_int.of_int 64 in + let onetwentyeight = Big_int.of_int 128 in + let twofiftysix = Big_int.of_int 256 in + let fivetwelve = Big_int.of_int 512 in + let oneotwentyfour = Big_int.of_int 1024 in + let to_the_sixteen = Big_int.of_int 65536 in + let to_the_thirtytwo = Big_int.of_string "4294967296" in + let to_the_sixtyfour = Big_int.of_string "18446744073709551616" in + let ck i = Big_int.equal b i in + if ck (Big_int.of_int 1) then Big_int.zero + else if ck two then (Big_int.of_int 1) else if ck four then two - else if ck eight then big_int_of_int 3 + else if ck eight then Big_int.of_int 3 else if ck sixteen then four - else if ck thirty_two then big_int_of_int 5 - else if ck sixty_four then big_int_of_int 6 - else if ck onetwentyeight then big_int_of_int 7 + else if ck thirty_two then Big_int.of_int 5 + else if ck sixty_four then Big_int.of_int 6 + else if ck onetwentyeight then Big_int.of_int 7 else if ck twofiftysix then eight - else if ck fivetwelve then big_int_of_int 9 - else if ck oneotwentyfour then big_int_of_int 10 + else if ck fivetwelve then Big_int.of_int 9 + else if ck oneotwentyfour then Big_int.of_int 10 else if ck to_the_sixteen then sixteen else if ck to_the_thirtytwo then thirty_two else if ck to_the_sixtyfour then sixty_four else let rec unpower b power = - if eq_big_int b unit_big_int + if Big_int.equal b (Big_int.of_int 1) then power - else (unpower (div_big_int b two) (succ_big_int power)) in - unpower b zero_big_int + else (unpower (Big_int.div b two) (Big_int.succ power)) in + unpower b Big_int.zero let is_within_range candidate range constraints = let candidate_actual = match candidate.t with @@ -183,7 +183,7 @@ let is_within_range candidate range constraints = | Tapp("vector", [_; TA_nexp size ; _; _]) -> (match size.nexp with | Nconst i | N2n(_, Some i) -> - if check_in_range (power_big_int (big_int_of_int 2) i) range + if check_in_range (power_big_int (Big_int.of_int 2) i) range then Yes else No | _ -> Maybe) @@ -342,7 +342,7 @@ let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset. | E_let(lebind,e) -> let b,u,s = fv_of_let consider_var bound used set lebind in fv_of_exp consider_var b u s e - | E_internal_let (lexp, exp1, exp2) -> + | E_var (lexp, exp1, exp2) -> let b,u,s = fv_of_lexp consider_var bound used set lexp in let _,used,set = fv_of_exp consider_var bound used set exp1 in fv_of_exp consider_var b used set exp2 @@ -367,13 +367,13 @@ and fv_of_pes consider_var bound used set pes = let bound_g,us_g,set_g = fv_of_exp consider_var bound_p us_p set g in let bound_e,us_e,set_e = fv_of_exp consider_var bound_g us_g set_g e in fv_of_pes consider_var bound us_e set_e pes - + and fv_of_let consider_var bound used set (LB_aux(lebind,_)) = match lebind with | LB_val(pat,exp) -> let bound_p, us_p = pat_bindings consider_var bound used pat in let _,us_e,set_e = fv_of_exp consider_var bound used set exp in bound_p,Nameset.union us_p us_e,set_e - + and fv_of_lexp consider_var bound used set (LEXP_aux(lexp,(_,tannot))) = match lexp with | LEXP_id id -> @@ -382,6 +382,8 @@ and fv_of_lexp consider_var bound used set (LEXP_aux(lexp,(_,tannot))) = if Nameset.mem i bound then bound, used, Nameset.add i set else Nameset.add i bound, Nameset.add i used, set + | LEXP_deref exp -> + fv_of_exp consider_var bound used set exp | LEXP_cast(typ,id) -> let used = Nameset.union (free_type_names_tannot consider_var tannot) used in let i = string_of_id id in @@ -432,8 +434,8 @@ let fv_of_type_def consider_var (TD_aux(t,_)) = match t with typ_variants consider_var bindings tunions | TD_enum(id,_,ids,_) -> Nameset.of_list (List.map string_of_id (id::ids)),mt - | TD_register(id,n1,n2,_) -> - init_env (string_of_id id), fv_of_nexp consider_var mt (fv_of_nexp consider_var mt mt n1) n2 + | TD_bitfield(id,typ,_) -> + init_env (string_of_id id), Nameset.empty (* fv_of_typ consider_var mt typ *) let fv_of_tannot_opt consider_var (Typ_annot_opt_aux (t,_)) = match t with @@ -577,6 +579,10 @@ let fv_of_def consider_var consider_scatter_as_one all_defs = function | DEF_fixity _ -> mt,mt | DEF_overload (id,ids) -> init_env (string_of_id id), List.fold_left (fun ns id -> Nameset.add (string_of_id id) ns) mt ids | DEF_default def -> mt,mt + | DEF_internal_mutrec fdefs -> + let fvs = List.map (fv_of_fun consider_var) fdefs in + List.fold_left Nameset.union Nameset.empty (List.map fst fvs), + List.fold_left Nameset.union Nameset.empty (List.map snd fvs) | DEF_scattered sdef -> fv_of_scattered consider_var consider_scatter_as_one all_defs sdef | DEF_reg_dec rdec -> fv_of_rd consider_var rdec | DEF_comm _ -> mt,mt @@ -621,7 +627,7 @@ let merge_mutrecs defs = | DEF_fundef fundef -> fundef :: fundefs | DEF_internal_mutrec fundefs' -> fundefs' @ fundefs | _ -> - (* let _ = Pretty_print_sail2.pp_defs stderr (Defs [def]) in *) + (* let _ = Pretty_print_sail.pp_defs stderr (Defs [def]) in *) raise (Reporting_basic.err_unreachable (def_loc def) "Trying to merge non-function definition with mutually recursive functions") in (* let _ = Printf.eprintf " - Merging %s (using %s)\n" (set_to_string binds') (set_to_string uses') in *) diff --git a/src/type_check.ml b/src/type_check.ml index dee17fee..30845727 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -51,7 +51,7 @@ open Ast open Util open Ast_util -open Big_int +module Big_int = Nat_big_num (* opt_tc_debug controls the verbosity of the type checker. 0 is silent, 1 prints a tree of the type derivation and 2 is like 1 but @@ -76,7 +76,7 @@ type type_error = (* First parameter is the error that caused us to start doing type coercions, the second is the errors encountered by all possible coercions *) - | Err_no_casts of type_error * type_error list + | Err_no_casts of unit exp * type_error * type_error list | Err_no_overloading of id * (id * type_error) list | Err_unresolved_quants of id * quant_item list | Err_subtype of typ * typ * n_constraint list @@ -86,11 +86,13 @@ type type_error = let pp_type_error err = let open PPrint in let rec pp_err = function - | Err_no_casts (trigger, []) -> - (string "Tried performing type coercion because" ^//^ pp_err trigger) - ^/^ string "No possible coercions" - | Err_no_casts (trigger, errs) -> - (string "Tried performing type coerction because" ^//^ pp_err trigger) + | Err_no_casts (exp, trigger, []) -> + (string "Tried performing type coercion on" ^//^ Pretty_print_sail.doc_exp exp) + ^/^ (string "Failed because" ^//^ pp_err trigger) + ^/^ string "There were no possible casts" + | Err_no_casts (exp, trigger, errs) -> + (string "Tried performing type coercion on" ^//^ Pretty_print_sail.doc_exp exp) + ^/^ string "Failed because" ^//^ pp_err trigger | Err_no_overloading (id, errs) -> string ("No overloadings for " ^ string_of_id id ^ ", tried:") ^//^ group (separate_map hardline (fun (id, err) -> string (string_of_id id) ^^ colon ^^ space ^^ pp_err err) errs) @@ -106,6 +108,9 @@ let pp_type_error err = ^//^ string (string_of_list ", " string_of_n_constraint constrs) | Err_no_num_ident id -> string "No num identifier" ^^ space ^^ string (string_of_id id) + | Err_unresolved_quants (id, quants) -> + string "Could not resolve quantifiers for" ^^ space ^^ string (string_of_id id) + ^//^ group (separate_map hardline (fun quant -> string (string_of_quant_item quant)) quants) | Err_other str -> string str in pp_err err @@ -293,7 +298,8 @@ module Env : sig val is_union_constructor : id -> t -> bool val add_record : id -> typquant -> (typ * id) list -> t -> t val is_record : id -> t -> bool - val get_accessor : id -> id -> t -> typquant * typ + val get_accessor_fn : id -> id -> t -> typquant * typ + val get_accessor : id -> id -> t -> typquant * typ * typ * effect val add_local : id -> mut * typ -> t -> t val get_locals : t -> (mut * typ) Bindings.t val add_variant : id -> typquant * type_union list -> t -> t @@ -303,9 +309,6 @@ module Env : sig val is_register : id -> t -> bool val get_register : id -> t -> typ val add_register : id -> typ -> t -> t - val add_regtyp : id -> big_int -> big_int -> (index_range * id) list -> t -> t - val is_regtyp : id -> t -> bool - val get_regtyp : id -> t -> big_int * big_int * (index_range * id) list val is_mutable : id -> t -> bool val get_constraints : t -> n_constraint list val add_constraint : n_constraint -> t -> t @@ -360,7 +363,6 @@ end = struct locals : (mut * typ) Bindings.t; union_ids : (typquant * typ) Bindings.t; registers : typ Bindings.t; - regtyps : (big_int * big_int * (index_range * id) list) Bindings.t; variants : (typquant * type_union list) Bindings.t; typ_vars : base_kind_aux KBindings.t; typ_synonyms : (t -> typ_arg list -> typ) Bindings.t; @@ -386,7 +388,6 @@ end = struct locals = Bindings.empty; union_ids = Bindings.empty; registers = Bindings.empty; - regtyps = Bindings.empty; variants = Bindings.empty; typ_vars = KBindings.empty; typ_synonyms = Bindings.empty; @@ -424,8 +425,9 @@ end = struct List.fold_left (fun m (name, kinds) -> Bindings.add (mk_id name) (kinds_typq kinds) m) Bindings.empty [ ("range", [BK_nat; BK_nat]); ("atom", [BK_nat]); - ("vector", [BK_nat; BK_nat; BK_order; BK_type]); + ("vector", [BK_nat; BK_order; BK_type]); ("register", [BK_type]); + ("ref", [BK_type]); ("bit", []); ("unit", []); ("int", []); @@ -441,7 +443,6 @@ end = struct Bindings.mem id env.typ_synonyms || Bindings.mem id env.variants || Bindings.mem id env.records - || Bindings.mem id env.regtyps || Bindings.mem id env.enums || Bindings.mem id builtin_typs @@ -451,7 +452,8 @@ end = struct let add_overloads id ids env = typ_print ("Adding overloads for " ^ string_of_id id ^ " [" ^ string_of_list ", " string_of_id ids ^ "]"); - { env with overloads = Bindings.add id ids env.overloads } + let existing = try Bindings.find id env.overloads with Not_found -> [] in + { env with overloads = Bindings.add id (existing @ ids) env.overloads } let add_smt_op id str env = typ_print ("Adding smt binding " ^ string_of_id id ^ " to " ^ str); @@ -472,7 +474,7 @@ end = struct fst (Bindings.find id env.variants) else if Bindings.mem id env.records then fst (Bindings.find id env.records) - else if Bindings.mem id env.enums || Bindings.mem id env.regtyps then + else if Bindings.mem id env.enums then mk_typquant [] else if Bindings.mem id env.typ_synonyms then typ_error (id_loc id) ("Cannot infer kind of type synonym " ^ string_of_id id) @@ -490,8 +492,8 @@ end = struct | kopt :: kopts, Typ_arg_aux (Typ_arg_order arg, _) :: args when is_order_kopt kopt -> subst_args kopts args | [], [] -> ncs - | _, Typ_arg_aux (_, l) :: _ -> typ_error l "ERROR 1" - | _, _ -> typ_error Parse_ast.Unknown "ERROR 2" + | _, Typ_arg_aux (_, l) :: _ -> typ_error l ("Error when processing type quantifer arguments " ^ string_of_typquant typq) + | _, _ -> typ_error Parse_ast.Unknown ("Error when processing type quantifer arguments " ^ string_of_typquant typq) in let ncs = subst_args kopts args in if List.for_all (env.prove env) ncs @@ -685,12 +687,18 @@ end = struct accessors = List.fold_left fold_accessors env.accessors fields } end - let get_accessor rec_id id env = + let get_accessor_fn rec_id id env = let freshen_bind bind = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in try freshen_bind (Bindings.find (field_name rec_id id) env.accessors) with | Not_found -> typ_error (id_loc id) ("No accessor found for " ^ string_of_id (field_name rec_id id)) + let get_accessor rec_id id env = + match get_accessor_fn rec_id id env with + | (typq, Typ_aux (Typ_fn (rec_typ, field_typ, effect), _)) -> + (typq, rec_typ, field_typ, effect) + | _ -> typ_error (id_loc id) ("Accessor with non-function type found for " ^ string_of_id (field_name rec_id id)) + let is_mutable id env = try let (mut, _) = Bindings.find id env.locals in @@ -698,7 +706,7 @@ end = struct | Mutable -> true | Immutable -> false with - | Not_found -> typ_error (id_loc id) ("No local binding found for " ^ string_of_id id) + | Not_found -> false let string_of_mtyp (mut, typ) = match mut with | Immutable -> string_of_typ typ @@ -758,29 +766,6 @@ end = struct let get_casts env = env.casts - let check_index_range cmp f t (BF_aux (ir, l)) = - match ir with - | BF_single n -> - if cmp f n && cmp n t - then n - else typ_error l ("Badly ordered index range: " ^ string_of_list ", " string_of_big_int [f; n; t]) - | BF_range (n1, n2) -> - if cmp f n1 && cmp n1 n2 && cmp n2 t - then n2 - else typ_error l ("Badly ordered index range: " ^ string_of_list ", " string_of_big_int [f; n1; n2; t]) - | BF_concat _ -> typ_error l "Index range concatenation currently unsupported" - - let rec check_index_ranges ids cmp base top = function - | [] -> () - | ((range, id) :: ranges) -> - if IdSet.mem id ids - then typ_error (id_loc id) ("Duplicate id " ^ string_of_id id ^ " in register typedef") - else - begin - let base' = check_index_range cmp base top range in - check_index_ranges (IdSet.add id ids) cmp base' top ranges - end - let add_register id typ env = wf_typ env typ; if Bindings.mem id env.registers @@ -791,24 +776,6 @@ end = struct { env with registers = Bindings.add id typ env.registers } end - let add_regtyp id base top ranges env = - if Bindings.mem id env.regtyps - then typ_error (id_loc id) ("Register type " ^ string_of_id id ^ " is already bound") - else - begin - typ_print ("Adding register type " ^ string_of_id id); - if gt_big_int base top - then check_index_ranges IdSet.empty gt_big_int (add_big_int base unit_big_int) (sub_big_int top unit_big_int) ranges - else check_index_ranges IdSet.empty lt_big_int (sub_big_int base unit_big_int) (add_big_int top unit_big_int) ranges; - { env with regtyps = Bindings.add id (base, top, ranges) env.regtyps } - end - - let is_regtyp id env = Bindings.mem id env.regtyps - - let get_regtyp id env = - try Bindings.find id env.regtyps with - | Not_found -> typ_error (id_loc id) (string_of_id id ^ " is not a register type") - let get_locals env = env.locals let lookup_id id env = @@ -913,16 +880,11 @@ end = struct rewrap (Typ_fn (aux t1, aux t2, eff)) | Typ_tup ts -> rewrap (Typ_tup (List.map aux ts)) - | Typ_app (register, [Typ_arg_aux (Typ_arg_typ rtyp,_)]) - when string_of_id register = "register" -> + | Typ_app (r, [Typ_arg_aux (Typ_arg_typ rtyp,_)]) + when string_of_id r = "register" || string_of_id r = "ref" -> aux rtyp | Typ_app (id, targs) -> rewrap (Typ_app (id, List.map aux_arg targs)) - | Typ_id id when is_regtyp id env -> - let base, top, ranges = get_regtyp id env in - let len = succ_big_int (abs_big_int (sub_big_int top base)) in - vector_typ (nconstant base) (nconstant len) (get_default_order env) bit_typ - (* TODO registers with non-default order? non-bitvector registers? *) | t -> rewrap t and aux_arg (Typ_arg_aux (targ,a)) = let rewrap targ = Typ_arg_aux (targ,a) in @@ -953,14 +915,10 @@ let add_typquant (quant : typquant) (env : Env.t) : Env.t = (* Create vectors with the default order from the environment *) -let dvector_typ env n m typ = vector_typ n m (Env.get_default_order env) typ +let default_order_error_string = + "No default Order (if you have set a default Order, move it earlier in the specification)" -let lvector_typ env l typ = - match Env.get_default_order env with - | Ord_aux (Ord_inc, _) as ord -> - vector_typ (nint 0) l ord typ - | Ord_aux (Ord_dec, _) as ord -> - vector_typ (nminus l (nint 1)) l ord typ +let dvector_typ env n typ = vector_typ n (Env.get_default_order env) typ let ex_counter = ref 0 @@ -988,10 +946,9 @@ let exist_typ constr typ = let destruct_vector env typ = let destruct_vector' = function | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n1, _); - Typ_arg_aux (Typ_arg_nexp n2, _); Typ_arg_aux (Typ_arg_order o, _); Typ_arg_aux (Typ_arg_typ vtyp, _)] - ), _) when string_of_id id = "vector" -> Some (n1, n2, o, vtyp) + ), _) when string_of_id id = "vector" -> Some (n1, o, vtyp) | typ -> None in destruct_vector' (Env.expand_synonyms env typ) @@ -1124,7 +1081,7 @@ let rec nexp_constraint env var_of (Nexp_aux (nexp, l)) = | Nexp_sum (nexp1, nexp2) -> Constraint.add (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) | Nexp_minus (nexp1, nexp2) -> Constraint.sub (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) | Nexp_exp nexp -> Constraint.pow2 (nexp_constraint env var_of nexp) - | Nexp_neg nexp -> Constraint.sub (Constraint.constant (big_int_of_int 0)) (nexp_constraint env var_of nexp) + | Nexp_neg nexp -> Constraint.sub (Constraint.constant (Big_int.of_int 0)) (nexp_constraint env var_of nexp) | Nexp_app (id, nexps) -> Constraint.app (Env.get_smt_op id env) (List.map (nexp_constraint env var_of) nexps) let rec nc_constraint env var_of (NC_aux (nc, l)) = @@ -1179,9 +1136,9 @@ let prove env (NC_aux (nc_aux, _) as nc) = | _, _ -> false in match nc_aux with - | NC_equal (nexp1, nexp2) when compare_const eq_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> true - | NC_bounded_le (nexp1, nexp2) when compare_const le_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> true - | NC_bounded_ge (nexp1, nexp2) when compare_const ge_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_equal (nexp1, nexp2) when compare_const Big_int.equal (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_bounded_le (nexp1, nexp2) when compare_const Big_int.less_equal (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_bounded_ge (nexp1, nexp2) when compare_const Big_int.greater_equal (nexp_simp nexp1) (nexp_simp nexp2) -> true | NC_true -> true | _ -> prove_z3 env nc @@ -1272,6 +1229,7 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = | Typ_tup typs -> List.fold_left KidSet.union KidSet.empty (List.map (typ_frees ~exs:exs) typs) | Typ_app (f, args) -> List.fold_left KidSet.union KidSet.empty (List.map (typ_arg_frees ~exs:exs) args) | Typ_exist (kids, nc, typ) -> typ_frees ~exs:(KidSet.of_list kids) typ + | Typ_fn (typ1, typ2, _) -> KidSet.union (typ_frees ~exs:exs typ1) (typ_frees ~exs:exs typ2) and typ_arg_frees ?exs:(exs=KidSet.empty) (Typ_arg_aux (typ_arg_aux, l)) = match typ_arg_aux with | Typ_arg_nexp n -> nexp_frees ~exs:exs n @@ -1282,7 +1240,7 @@ let rec nexp_identical (Nexp_aux (nexp1, _)) (Nexp_aux (nexp2, _)) = match nexp1, nexp2 with | Nexp_id v1, Nexp_id v2 -> Id.compare v1 v2 = 0 | Nexp_var kid1, Nexp_var kid2 -> Kid.compare kid1 kid2 = 0 - | Nexp_constant c1, Nexp_constant c2 -> eq_big_int c1 c2 + | Nexp_constant c1, Nexp_constant c2 -> Big_int.equal c1 c2 | Nexp_times (n1a, n1b), Nexp_times (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b | Nexp_sum (n1a, n1b), Nexp_sum (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b | Nexp_minus (n1a, n1b), Nexp_minus (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b @@ -1334,6 +1292,7 @@ let typ_identical env typ1 typ2 = | Typ_arg_nexp n1, Typ_arg_nexp n2 -> nexp_identical n1 n2 | Typ_arg_typ typ1, Typ_arg_typ typ2 -> typ_identical' typ1 typ2 | Typ_arg_order ord1, Typ_arg_order ord2 -> ord_identical ord1 ord2 + | _, _ -> false in typ_identical' (Env.expand_synonyms env typ1) (Env.expand_synonyms env typ2) @@ -1394,8 +1353,8 @@ let rec unify_nexps l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (ne | Nexp_constant c2 -> begin match n1a with - | Nexp_aux (Nexp_constant c1,_) when eq_big_int (mod_big_int c2 c1) zero_big_int -> - unify_nexps l env goals n1b (mk_nexp (Nexp_constant (div_big_int c2 c1))) + | Nexp_aux (Nexp_constant c1,_) when Big_int.equal (Big_int.modulus c2 c1) Big_int.zero -> + unify_nexps l env goals n1b (mk_nexp (Nexp_constant (Big_int.div c2 c1))) | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) end | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) @@ -1648,8 +1607,12 @@ let rec subtyp l env typ1 typ2 = when is_some (destruct_atom_kid env typ1) && is_some (destruct_atom_kid env typ2) -> let env = List.fold_left (fun env kid -> Env.add_typ_var kid BK_nat env) env kids1 in let env = Env.add_constraint nc1 env in - let Some atom_kid1 = destruct_atom_kid env typ1 in - let Some atom_kid2 = destruct_atom_kid env typ2 in + + (* Guaranteed to succeed because of the guard *) + let destruct_some x = match x with Some y -> y | _ -> assert false in + let atom_kid1 = destruct_some (destruct_atom_kid env typ1) in + let atom_kid2 = destruct_some (destruct_atom_kid env typ2) in + let kids2 = List.filter (fun kid -> Kid.compare atom_kid2 kid <> 0) kids2 in let env = Env.add_typ_var atom_kid2 BK_nat env in let env = Env.add_constraint (nc_eq (nvar atom_kid1) (nvar atom_kid2)) env in @@ -1675,6 +1638,7 @@ let rec subtyp l env typ1 typ2 = let env = List.fold_left (fun env kid -> Env.add_typ_var kid BK_nat env) env existential_kids in let env = List.fold_left uv_nexp_constraint env (KBindings.bindings unifiers) in Env.add_constraint enc env + | _, None -> assert false (* Cannot have existential_kids without existential_nc *) in if prove env nc then () else typ_error l ("Could not show " ^ string_of_typ typ1 ^ " is a subset of existential " ^ string_of_typ typ2) @@ -1711,24 +1675,16 @@ let infer_lit env (L_aux (lit_aux, l) as lit) = | L_bin str -> begin match Env.get_default_order env with - | Ord_aux (Ord_inc, _) -> - dvector_typ env (nint 0) (nint (String.length str)) (mk_typ (Typ_id (mk_id "bit"))) - | Ord_aux (Ord_dec, _) -> - dvector_typ env - (nint (String.length str - 1)) - (nint (String.length str)) - (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_inc, _) | Ord_aux (Ord_dec, _) -> + dvector_typ env (nint (String.length str)) (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_var _, _) -> typ_error l default_order_error_string end | L_hex str -> begin match Env.get_default_order env with - | Ord_aux (Ord_inc, _) -> - dvector_typ env (nint 0) (nint (String.length str * 4)) (mk_typ (Typ_id (mk_id "bit"))) - | Ord_aux (Ord_dec, _) -> - dvector_typ env - (nint (String.length str * 4 - 1)) - (nint (String.length str * 4)) - (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_inc, _) | Ord_aux (Ord_dec, _) -> + dvector_typ env (nint (String.length str * 4)) (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_var _, _) -> typ_error l default_order_error_string end | L_undef -> typ_error l "Cannot infer the type of undefined" @@ -1776,10 +1732,9 @@ let rec instantiate_quants quants kid uvar = match quants with let destruct_vec_typ l env typ = let destruct_vec_typ' l = function | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n1, _); - Typ_arg_aux (Typ_arg_nexp n2, _); Typ_arg_aux (Typ_arg_order o, _); Typ_arg_aux (Typ_arg_typ vtyp, _)] - ), _) when string_of_id id = "vector" -> (n1, n2, o, vtyp) + ), _) when string_of_id id = "vector" -> (n1, o, vtyp) | typ -> typ_error l ("Expected vector type, got " ^ string_of_typ typ) in destruct_vec_typ' l (Env.expand_synonyms env typ) @@ -1812,13 +1767,13 @@ let pat_env_of (P_aux (_, (l, tannot))) = env_of_annot (l, tannot) let rec big_int_of_nexp (Nexp_aux (nexp, _)) = match nexp with | Nexp_constant c -> Some c | Nexp_times (n1, n2) -> - Util.option_binop add_big_int (big_int_of_nexp n1) (big_int_of_nexp n2) + Util.option_binop Big_int.add (big_int_of_nexp n1) (big_int_of_nexp n2) | Nexp_sum (n1, n2) -> - Util.option_binop add_big_int (big_int_of_nexp n1) (big_int_of_nexp n2) + Util.option_binop Big_int.add (big_int_of_nexp n1) (big_int_of_nexp n2) | Nexp_minus (n1, n2) -> - Util.option_binop add_big_int (big_int_of_nexp n1) (big_int_of_nexp n2) + Util.option_binop Big_int.add (big_int_of_nexp n1) (big_int_of_nexp n2) | Nexp_exp n -> - Util.option_map (power_int_positive_big_int 2) (big_int_of_nexp n) + Util.option_map (fun n -> Big_int.pow_int_positive 2 (Big_int.to_int n)) (big_int_of_nexp n) | _ -> None let destruct_atom (Typ_aux (typ_aux, _)) = @@ -1830,7 +1785,7 @@ let destruct_atom (Typ_aux (typ_aux, _)) = when string_of_id f = "range" -> begin match big_int_of_nexp nexp1, big_int_of_nexp nexp2 with - | Some c1, Some c2 -> if eq_big_int c1 c2 then Some (c1, nexp1) else None + | Some c1, Some c2 -> if Big_int.equal c1 c2 then Some (c1, nexp1) else None | _ -> None end | _ -> None @@ -1865,8 +1820,8 @@ let rec assert_constraint env (E_aux (exp_aux, _) as exp) = None type flow_constraint = - | Flow_lteq of big_int * nexp - | Flow_gteq of big_int * nexp + | Flow_lteq of Big_int.num * nexp + | Flow_gteq of Big_int.num * nexp let restrict_range_upper c1 nexp1 (Typ_aux (typ_aux, l) as typ) = match typ_aux with @@ -1875,7 +1830,7 @@ let restrict_range_upper c1 nexp1 (Typ_aux (typ_aux, l) as typ) = begin match big_int_of_nexp nexp2 with | Some c2 -> - let upper = if (lt_big_int c1 c2) then nexp1 else nexp2 in + let upper = if (Big_int.less c1 c2) then nexp1 else nexp2 in range_typ nexp upper | _ -> typ end @@ -1888,7 +1843,7 @@ let restrict_range_lower c1 nexp1 (Typ_aux (typ_aux, l) as typ) = begin match big_int_of_nexp nexp2 with | Some c2 -> - let lower = if (gt_big_int c1 c2) then nexp1 else nexp2 in + let lower = if (Big_int.greater c1 c2) then nexp1 else nexp2 in range_typ lower nexp | _ -> typ end @@ -1897,10 +1852,10 @@ let restrict_range_lower c1 nexp1 (Typ_aux (typ_aux, l) as typ) = let apply_flow_constraint = function | Flow_lteq (c, nexp) -> (restrict_range_upper c nexp, - restrict_range_lower (succ_big_int c) (nexp_simp (nsum nexp (nint 1)))) + restrict_range_lower (Big_int.succ c) (nexp_simp (nsum nexp (nint 1)))) | Flow_gteq (c, nexp) -> (restrict_range_lower c nexp, - restrict_range_upper (pred_big_int c) (nexp_simp (nminus nexp (nint 1)))) + restrict_range_upper (Big_int.pred c) (nexp_simp (nminus nexp (nint 1)))) let rec infer_flow env (E_aux (exp_aux, (l, _)) as exp) = match exp_aux with @@ -1909,7 +1864,7 @@ let rec infer_flow env (E_aux (exp_aux, (l, _)) as exp) = begin match destruct_atom (typ_of y) with | Some (c, nexp) -> - [(v, Flow_lteq (pred_big_int c, nexp_simp (nminus nexp (nint 1))))], [] + [(v, Flow_lteq (Big_int.pred c, nexp_simp (nminus nexp (nint 1))))], [] | _ -> [], [] end | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "lteq_range_atom" -> @@ -1924,7 +1879,7 @@ let rec infer_flow env (E_aux (exp_aux, (l, _)) as exp) = begin match destruct_atom (typ_of y) with | Some (c, nexp) -> - [(v, Flow_gteq (succ_big_int c, nexp_simp (nsum nexp (nint 1))))], [] + [(v, Flow_gteq (Big_int.succ c, nexp_simp (nsum nexp (nint 1))))], [] | _ -> [], [] end | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "gteq_range_atom" -> @@ -2017,7 +1972,10 @@ let strip_lexp : 'a lexp -> unit lexp = function lexp -> map_lexp_annot (fun (l, let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ_aux, _) as typ) : tannot exp = let annot_exp_effect exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in - let add_effect (E_aux (exp, (l, Some (env, typ, _)))) eff = E_aux (exp, (l, Some (env, typ, eff))) in + let add_effect exp eff = match exp with + | (E_aux (exp, (l, Some (env, typ, _)))) -> E_aux (exp, (l, Some (env, typ, eff))) + | _ -> failwith "Tried to add effect to unannoted expression" + in let annot_exp exp typ = annot_exp_effect exp typ no_effect in match (exp_aux, typ_aux) with | E_block exps, _ -> @@ -2090,7 +2048,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = - let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in @@ -2105,7 +2063,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = - let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in @@ -2165,10 +2123,13 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | E_throw exp, _ -> let checked_exp = crule check_exp env exp exc_typ in annot_exp_effect (E_throw checked_exp) typ (mk_effect [BE_escape]) - | E_internal_let (lexp, bind, exp), _ -> - let E_aux (E_assign (lexp, bind), _), env = bind_assignment env lexp bind in + | E_var (lexp, bind, exp), _ -> + let lexp, bind, env = match bind_assignment env lexp bind with + | E_aux (E_assign (lexp, bind), _), env -> lexp, bind, env + | _, _ -> assert false + in let checked_exp = crule check_exp env exp typ in - annot_exp (E_internal_let (lexp, bind, checked_exp)) typ + annot_exp (E_var (lexp, bind, checked_exp)) typ | E_internal_return exp, _ -> let checked_exp = crule check_exp env exp typ in annot_exp (E_internal_return checked_exp) typ @@ -2191,7 +2152,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ let checked_body = crule check_exp env body typ in annot_exp (E_internal_plet (tpat, bind_exp, checked_body)) typ | E_vector vec, _ -> - let (start, len, ord, vtyp) = destruct_vec_typ l env typ in + let (len, ord, vtyp) = destruct_vec_typ l env typ in let checked_items = List.map (fun i -> crule check_exp env i vtyp) vec in if prove env (nc_eq (nint (List.length vec)) (nexp_simp len)) then annot_exp (E_vector checked_items) typ else typ_error l "List length didn't match" (* FIXME: improve error message *) @@ -2199,11 +2160,6 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ if is_typ_monomorphic typ || Env.polymorphic_undefineds env then annot_exp_effect (E_lit lit) typ (mk_effect [BE_undef]) else typ_error l ("Type " ^ string_of_typ typ ^ " failed undefined monomorphism restriction") - (* This rule allows registers of type t to be passed by name with type register<t>*) - | E_id reg, Typ_app (id, [Typ_arg_aux (Typ_arg_typ arg_typ, _)]) - when string_of_id id = "register" && Env.is_register reg env -> - let rtyp = Env.get_register reg env in - subtyp l env rtyp arg_typ; annot_exp (E_id reg) typ (* CHECK: is this subtyp the correct way around? *) | E_id id, _ when is_union_id id env -> begin match Env.lookup_id id env with @@ -2249,9 +2205,12 @@ and check_case env pat_typ pexp typ = and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in - let switch_typ (E_aux (exp, (l, Some (env, _, eff)))) typ = E_aux (exp, (l, Some (env, typ, eff))) in + let switch_typ exp typ = match exp with + | (E_aux (exp, (l, Some (env, _, eff)))) -> E_aux (exp, (l, Some (env, typ, eff))) + | _ -> failwith "Cannot switch type for unannotated function" + in let rec try_casts trigger errs = function - | [] -> typ_raise l (Err_no_casts (trigger, errs)) + | [] -> typ_raise l (Err_no_casts (strip_exp annotated_exp, trigger, errs)) | (cast :: casts) -> begin typ_print ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " to " ^ string_of_typ typ); try @@ -2280,7 +2239,10 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in - let switch_typ (E_aux (exp, (l, Some (env, _, eff)))) typ = E_aux (exp, (l, Some (env, typ, eff))) in + let switch_typ exp typ = match exp with + | (E_aux (exp, (l, Some (env, _, eff)))) -> E_aux (exp, (l, Some (env, typ, eff))) + | _ -> failwith "Cannot switch type for unannotated expression" + in let rec try_casts = function | [] -> unify_error l "No valid casts resulted in unification" | (cast :: casts) -> begin @@ -2307,7 +2269,10 @@ and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) = typ_print ("Binding " ^ string_of_pat pat ^ " to " ^ string_of_typ typ); let annot_pat pat typ = P_aux (pat, (l, Some (env, typ, no_effect))) in - let switch_typ (P_aux (pat_aux, (l, Some (env, _, eff)))) typ = P_aux (pat_aux, (l, Some (env, typ, eff))) in + let switch_typ pat typ = match pat with + | (P_aux (pat_aux, (l, Some (env, _, eff)))) -> P_aux (pat_aux, (l, Some (env, typ, eff))) + | _ -> failwith "Cannot switch type of unannotated pattern" + in let bind_tuple_pat (tpats, env) pat typ = let tpat, env = bind_pat env pat typ in tpat :: tpats, env in @@ -2446,7 +2411,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = | P_id v -> begin match Env.lookup_id v env with - | Local (Immutable, _) | Unbound -> + | Local (Immutable, _) | Unbound | Union _ -> typ_error l ("Cannot infer identifier in pattern " ^ string_of_pat pat ^ " - try adding a type annotation") | Local (Mutable, _) | Register _ -> typ_error l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat) @@ -2463,26 +2428,26 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = let typed_pat, env = bind_pat env pat bit_typ in pats @ [typed_pat], env in - let ((typed_pat :: typed_pats) as pats), env = + let pats, env = List.fold_left fold_pats ([], env) (pat :: pats) in let len = nexp_simp (nint (List.length pats)) in - let etyp = pat_typ_of typed_pat in - List.map (fun pat -> typ_equality l env etyp (pat_typ_of pat)) pats; - annot_pat (P_vector pats) (lvector_typ env len etyp), env + let etyp = pat_typ_of (List.hd pats) in + List.iter (fun pat -> typ_equality l env etyp (pat_typ_of pat)) pats; + annot_pat (P_vector pats) (dvector_typ env len etyp), env | P_vector_concat (pat :: pats) -> let fold_pats (pats, env) pat = let inferred_pat, env = infer_pat env pat in pats @ [inferred_pat], env in - let (inferred_pat :: inferred_pats), env = List.fold_left fold_pats ([], env) (pat :: pats) in - let (_, len, _, vtyp) = destruct_vec_typ l env (pat_typ_of inferred_pat) in + let inferred_pats, env = List.fold_left fold_pats ([], env) (pat :: pats) in + let (len, _, vtyp) = destruct_vec_typ l env (pat_typ_of (List.hd inferred_pats)) in let fold_len len pat = - let (_, len', _, vtyp') = destruct_vec_typ l env (pat_typ_of pat) in + let (len', _, vtyp') = destruct_vec_typ l env (pat_typ_of pat) in typ_equality l env vtyp vtyp'; nsum len len' in - let len = nexp_simp (List.fold_left fold_len len inferred_pats) in - annot_pat (P_vector_concat (inferred_pat :: inferred_pats)) (lvector_typ env len vtyp), env + let len = nexp_simp (List.fold_left fold_len len (List.tl inferred_pats)) in + annot_pat (P_vector_concat inferred_pats) (dvector_typ env len vtyp), env | P_as (pat, id) -> let (typed_pat, env) = infer_pat env pat in annot_pat (P_as (typed_pat, id)) (pat_typ_of typed_pat), Env.add_local id (Immutable, pat_typ_of typed_pat) env @@ -2513,38 +2478,26 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as let is_immutable, vtyp, is_register = match Env.lookup_id v env with | Unbound -> typ_error l "Cannot assign to element of unbound vector" | Enum _ -> typ_error l "Cannot vector assign to enumeration element" + | Union _ -> typ_error l "Cannot vector assign to union element" | Local (Immutable, vtyp) -> true, vtyp, false | Local (Mutable, vtyp) -> false, vtyp, false | Register vtyp -> false, vtyp, true in let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in - let E_aux (E_app (_, [_; inferred_exp]), _) = access in + let inferred_exp = match access with + | E_aux (E_app (_, [_; inferred_exp]), _) -> inferred_exp + | _ -> assert false + in typ_of access, LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp), is_register end + | _ -> typ_error l "Field l-expression must be either a vector or an identifier" in let regtyp, inferred_flexp, is_register = infer_flexp flexp in typ_debug ("REGTYP: " ^ string_of_typ regtyp ^ " / " ^ string_of_typ (Env.expand_synonyms env regtyp)); match Env.expand_synonyms env regtyp with - | Typ_aux (Typ_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id regtyp_id, _)), _)]), _) - | Typ_aux (Typ_id regtyp_id, _) when Env.is_regtyp regtyp_id env -> - let eff = mk_effect [BE_wreg] in - let base, top, ranges = Env.get_regtyp regtyp_id env in - let range, _ = - try List.find (fun (_, id) -> Id.compare id field = 0) ranges with - | Not_found -> typ_error l ("Field " ^ string_of_id field ^ " doesn't exist for register type " ^ string_of_id regtyp_id) - in - let vec_typ = match range, Env.get_default_order env with - | BF_aux (BF_single n, _), Ord_aux (Ord_dec, _) -> - dvector_typ env (nconstant n) (nint 1) (mk_typ (Typ_id (mk_id "bit"))) - | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) -> - dvector_typ env (nconstant n) (nconstant (add_big_int (sub_big_int n m) unit_big_int)) (mk_typ (Typ_id (mk_id "bit"))) - | _, _ -> typ_error l "Not implemented this register field type yet..." - in - let checked_exp = crule check_exp env exp vec_typ in - annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp eff, field)) vec_typ) checked_exp, env | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> let eff = if is_register then mk_effect [BE_wreg] else no_effect in - let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q regtyp with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let checked_exp = crule check_exp env exp field_typ' in @@ -2574,10 +2527,20 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some (env, typ, eff))) in let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in match lexp_aux with + | LEXP_deref exp -> + let inferred_exp = infer_exp env exp in + begin match typ_of inferred_exp with + | Typ_aux (Typ_app (r, [Typ_arg_aux (Typ_arg_typ vtyp, _)]), _) when string_of_id r = "ref" -> + subtyp l env typ vtyp; annot_lexp (LEXP_deref inferred_exp) typ, env + | Typ_aux (Typ_app (r, [Typ_arg_aux (Typ_arg_typ vtyp, _)]), _) when string_of_id r = "register" -> + subtyp l env typ vtyp; annot_lexp_effect (LEXP_deref inferred_exp) typ (mk_effect [BE_wreg]), env + | _ -> + typ_error l (string_of_typ typ ^ " must be a ref or register type in (*" ^ string_of_exp exp ^ ")") + end | LEXP_id v -> begin match Env.lookup_id v env with - | Local (Immutable, _) | Enum _ -> - typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + | Local (Immutable, _) | Enum _ | Union _ -> + typ_error l ("Cannot modify let-bound constant, union or enumeration constructor " ^ string_of_id v) | Local (Mutable, vtyp) -> subtyp l env typ vtyp; annot_lexp (LEXP_id v) typ, env | Register vtyp -> subtyp l env typ vtyp; annot_lexp_effect (LEXP_id v) typ (mk_effect [BE_wreg]), env | Unbound -> annot_lexp (LEXP_id v) typ, Env.add_local v (Mutable, typ) env @@ -2585,8 +2548,8 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = | LEXP_cast (typ_annot, v) -> begin match Env.lookup_id v env with - | Local (Immutable, _) | Enum _ -> - typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + | Local (Immutable, _) | Enum _ | Union _ -> + typ_error l ("Cannot modify let-bound constant, union or enumeration constructor " ^ string_of_id v) | Local (Mutable, vtyp) -> begin subtyp l env typ typ_annot; @@ -2624,19 +2587,19 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = | Typ_app (id, _) when Id.compare id (mk_id "vector") == 0 -> begin match destruct_vector env typ with - | Some (_, vec_len, _, _) -> + | Some (vec_len, _, _) -> let bind_bits_tuple lexp (tlexps, env, llen) = match lexp with | LEXP_aux (LEXP_id v, _) -> begin match Env.lookup_id v env with - | Local (Immutable, _) | Enum _ -> - typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + | Local (Immutable, _) | Enum _ | Union _ -> + typ_error l ("Cannot modify let-bound constant, union or enumeration constructor " ^ string_of_id v) | Unbound -> typ_error l "Unbound variable in vector tuple assignment" | Local (Mutable, vtyp) | Register vtyp -> let llen' = match destruct_vector env vtyp with - | Some (_, llen', _, _) -> llen' + | Some (llen', _, _) -> llen' | None -> typ_error l "Variables in vector tuple assignment must be vectors" in let tlexp, env = bind_lexp env lexp vtyp in @@ -2649,9 +2612,9 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = | Register (Typ_aux (Typ_id rec_id, _)) -> rec_id | _ -> typ_error l (string_of_lexp lexp ^ " must be a record register here") in - let typq, (Typ_aux (Typ_fn (_, vtyp, _), _)) = Env.get_accessor rec_id fid env in + let typq, _, vtyp, _ = Env.get_accessor rec_id fid env in let llen' = match destruct_vector env vtyp with - | Some (_, llen', _, _) -> llen' + | Some (llen', _, _) -> llen' | None -> typ_error l "Variables in vector tuple assignment must be vectors" in let tlexp, env = bind_lexp env lexp vtyp in @@ -2671,16 +2634,17 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = let is_immutable, is_register, vtyp = match Env.lookup_id v env with | Unbound -> typ_error l "Cannot assign to element of unbound vector" | Enum _ -> typ_error l "Cannot vector assign to enumeration element" + | Union _ -> typ_error l "Cannot vector assign to union element" | Local (Immutable, vtyp) -> true, false, vtyp | Local (Mutable, vtyp) -> false, false, vtyp | Register vtyp -> false, true, vtyp in let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_subrange", [E_aux (E_id v, (l, ())); exp1; exp2]), (l, ()))) in - let E_aux (E_app (_, [_; inferred_exp1; inferred_exp2]), _) = access in + let inferred_exp1, inferred_exp2 = match access with + | E_aux (E_app (_, [_; inferred_exp1; inferred_exp2]), _) -> inferred_exp1, inferred_exp2 + | _ -> assert false + in match typ_of access with - | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_typ deref_typ, _)]), _) when string_of_id id = "register" -> - subtyp l env typ deref_typ; - annot_lexp (LEXP_vector_range (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp1, inferred_exp2)) typ, env | _ when not is_immutable && is_register -> subtyp l env typ (typ_of access); annot_lexp (LEXP_vector_range (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp1, inferred_exp2)) typ, env @@ -2695,16 +2659,17 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = let is_immutable, is_register, vtyp = match Env.lookup_id v env with | Unbound -> typ_error l "Cannot assign to element of unbound vector" | Enum _ -> typ_error l "Cannot vector assign to enumeration element" + | Union _ -> typ_error l "Cannot vector assign to union element" | Local (Immutable, vtyp) -> true, false, vtyp | Local (Mutable, vtyp) -> false, false, vtyp | Register vtyp -> false, true, vtyp in let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in - let E_aux (E_app (_, [_; inferred_exp]), _) = access in + let inferred_exp = match access with + | E_aux (E_app (_, [_; inferred_exp]), _) -> inferred_exp + | _ -> assert false + in match typ_of access with - | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_typ deref_typ, _)]), _) when string_of_id id = "register" -> - subtyp l env typ deref_typ; - annot_lexp (LEXP_vector (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp)) typ, env | _ when not is_immutable && is_register -> subtyp l env typ (typ_of access); annot_lexp (LEXP_vector (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp)) typ, env @@ -2720,7 +2685,7 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = | Register (Typ_aux (Typ_id rec_id, _)) -> rec_id | _ -> typ_error l (string_of_lexp lexp ^ " must be a record register here") in - let typq, (Typ_aux (Typ_fn (_, ret_typ, _), _)) = Env.get_accessor rec_id fid env in + let typq, _, ret_typ, _ = Env.get_accessor rec_id fid env in annot_lexp_effect (LEXP_field (annot_lexp (LEXP_id v) (mk_id_typ rec_id), fid)) ret_typ (mk_effect [BE_wreg]), env | _ -> typ_error l ("Unhandled l-expression " ^ string_of_lexp lexp) @@ -2750,35 +2715,10 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = begin let inferred_exp = irule infer_exp env exp in match Env.expand_synonyms env (typ_of inferred_exp) with - (* Accessing a (bit) field of a register *) - | Typ_aux (Typ_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ ((Typ_aux (Typ_id regtyp, _) as regtyp_aux)), _)]), _) - | (Typ_aux (Typ_id regtyp, _) as regtyp_aux) when Env.is_regtyp regtyp env -> - let base, top, ranges = Env.get_regtyp regtyp env in - let range, _ = - try List.find (fun (_, id) -> Id.compare id field = 0) ranges with - | Not_found -> typ_error l ("Field " ^ string_of_id field ^ " doesn't exist for register type " ^ string_of_id regtyp) - in - let checked_exp = crule check_exp env (strip_exp inferred_exp) regtyp_aux in - begin - match range, Env.get_default_order env with - | BF_aux (BF_single n, _), Ord_aux (Ord_dec, _) -> - let vec_typ = dvector_typ env (nconstant n) (nint 1) bit_typ in - annot_exp (E_field (checked_exp, field)) vec_typ - | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) -> - let vec_typ = dvector_typ env (nconstant n) (nconstant (add_big_int (sub_big_int n m) unit_big_int)) bit_typ in - annot_exp (E_field (checked_exp, field)) vec_typ - | BF_aux (BF_single n, _), Ord_aux (Ord_inc, _) -> - let vec_typ = dvector_typ env (nconstant n) (nint 1) bit_typ in - annot_exp (E_field (checked_exp, field)) vec_typ - | BF_aux (BF_range (n, m), _), Ord_aux (Ord_inc, _) -> - let vec_typ = dvector_typ env (nconstant n) (nconstant (add_big_int (sub_big_int m n) unit_big_int)) bit_typ in - annot_exp (E_field (checked_exp, field)) vec_typ - | _, _ -> typ_error l "Invalid register field type" - end (* Accessing a field of a record *) | Typ_aux (Typ_id rectyp, _) as typ when Env.is_record rectyp env -> begin - let inferred_acc, _ = infer_funapp' l (Env.no_casts env) field (Env.get_accessor rectyp field env) [strip_exp inferred_exp] None in + let inferred_acc, _ = infer_funapp' l (Env.no_casts env) field (Env.get_accessor_fn rectyp field env) [strip_exp inferred_exp] None in match inferred_acc with | E_aux (E_app (field, [inferred_exp]) ,_) -> annot_exp (E_field (inferred_exp, field)) (typ_of inferred_acc) | _ -> assert false (* Unreachable *) @@ -2799,7 +2739,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") in let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = - let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in let field_typ' = subst_unifiers unifiers field_typ in let inferred_exp = crule check_exp env exp field_typ' in @@ -2832,6 +2772,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = let f, t, is_dec = match ord with | Ord_aux (Ord_inc, _) -> f, t, false | Ord_aux (Ord_dec, _) -> t, f, true (* reverse direction to typechecking downto as upto loop *) + | Ord_aux (Ord_var _, _) -> typ_error l "Cannot check a loop with variable direction!" (* This should never happen *) in let inferred_f = irule infer_exp env f in let inferred_t = irule infer_exp env t in @@ -2874,20 +2815,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | E_vector ((item :: items) as vec) -> let inferred_item = irule infer_exp env item in let checked_items = List.map (fun i -> crule check_exp env i (typ_of inferred_item)) items in - let vec_typ = match Env.get_default_order env with - | Ord_aux (Ord_inc, _) -> - mk_typ (Typ_app (mk_id "vector", - [mk_typ_arg (Typ_arg_nexp (nint 0)); - mk_typ_arg (Typ_arg_nexp (nint (List.length vec))); - mk_typ_arg (Typ_arg_order (Env.get_default_order env)); - mk_typ_arg (Typ_arg_typ (typ_of inferred_item))])) - | Ord_aux (Ord_dec, _) -> - mk_typ (Typ_app (mk_id "vector", - [mk_typ_arg (Typ_arg_nexp (nint (List.length vec - 1))); - mk_typ_arg (Typ_arg_nexp (nint (List.length vec))); - mk_typ_arg (Typ_arg_order (Env.get_default_order env)); - mk_typ_arg (Typ_arg_typ (typ_of inferred_item))])) - in + let vec_typ = dvector_typ env (nint (List.length vec)) (typ_of inferred_item) in annot_exp (E_vector (inferred_item :: checked_items)) vec_typ | E_assert (test, msg) -> let checked_test = crule check_exp env test bool_typ in @@ -2926,6 +2854,12 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = let tpat, env = bind_pat env pat ptyp in let inferred_exp = irule infer_exp env exp in annot_exp (E_let (LB_aux (LB_val (tpat, bind_exp), (let_loc, None)), inferred_exp)) (typ_of inferred_exp) + | E_ref id when Env.is_mutable id env -> + let (_, typ) = Bindings.find id (Env.get_locals env) in + annot_exp (E_ref id) (ref_typ typ) + | E_ref id when Env.is_register id env -> + let typ = Env.get_register id env in + annot_exp (E_ref id) (register_typ typ) | _ -> typ_error l ("Cannot infer type of: " ^ string_of_exp exp) and infer_funapp l env f xs ret_ctx_typ = fst (infer_funapp' l env f (Env.get_val_spec f env) xs ret_ctx_typ) @@ -2938,7 +2872,10 @@ and instantiation_of (E_aux (exp_aux, (l, _)) as exp) = and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = let annot_exp exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in - let switch_annot env typ (E_aux (exp, (l, Some (_, _, eff)))) = E_aux (exp, (l, Some (env, typ, eff))) in + let switch_annot env typ = function + | (E_aux (exp, (l, Some (_, _, eff)))) -> E_aux (exp, (l, Some (env, typ, eff))) + | _ -> failwith "Cannot switch annot for unannotated function" + in let all_unifiers = ref KBindings.empty in let ex_goal = ref None in let prove_goal env = match !ex_goal with @@ -2996,6 +2933,7 @@ and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = let enc = List.fold_left (fun nc kid -> nc_subst_nexp kid (Nexp_var (prepend_kid ex_tag kid)) nc) enc ex_kids in let env = List.fold_left (fun env kid -> Env.add_typ_var (prepend_kid ex_tag kid) BK_nat env) env ex_kids in Env.add_constraint enc env + | _, None -> assert false (* Cannot have ex_kids without ex_nc *) in let tag_unifier uvar = List.fold_left (fun uvar kid -> uvar_subst_nexp kid (Nexp_var (prepend_kid ex_tag kid)) uvar) uvar ex_kids in let unifiers = KBindings.map tag_unifier unifiers in @@ -3123,6 +3061,7 @@ and propagate_exp_effect_aux = function let p_xs = List.map propagate_exp_effect xs in E_nondet p_xs, collect_effects p_xs | E_id id -> E_id id, no_effect + | E_ref id -> E_ref id, no_effect | E_lit lit -> E_lit lit, no_effect | E_cast (typ, exp) -> let p_exp = propagate_exp_effect exp in @@ -3211,11 +3150,11 @@ and propagate_exp_effect_aux = function let p_lexp = propagate_lexp_effect lexp in let p_exp = propagate_exp_effect exp in E_assign (p_lexp, p_exp), union_effects (effect_of p_exp) (effect_of_lexp p_lexp) - | E_internal_let (lexp, bind, exp) -> + | E_var (lexp, bind, exp) -> let p_lexp = propagate_lexp_effect lexp in let p_bind = propagate_exp_effect bind in let p_exp = propagate_exp_effect exp in - E_internal_let (p_lexp, p_bind, p_exp), union_effects (effect_of_lexp p_lexp) (collect_effects [p_bind; p_exp]) + E_var (p_lexp, p_bind, p_exp), union_effects (effect_of_lexp p_lexp) (collect_effects [p_bind; p_exp]) | E_sizeof nexp -> E_sizeof nexp, no_effect | E_constraint nc -> E_constraint nc, no_effect | E_exit exp -> @@ -3234,12 +3173,6 @@ and propagate_exp_effect_aux = function | E_field (exp, id) -> let p_exp = propagate_exp_effect exp in E_field (p_exp, id), effect_of p_exp - | E_internal_let (lexp, exp, body) -> - let p_lexp = propagate_lexp_effect lexp in - let p_exp = propagate_exp_effect exp in - let p_body = propagate_exp_effect body in - E_internal_let (p_lexp, p_exp, p_body), - union_effects (effect_of_lexp p_lexp) (collect_effects [p_exp; p_body]) | E_internal_plet (pat, exp, body) -> let p_pat = propagate_pat_effect pat in let p_exp = propagate_exp_effect exp in @@ -3337,6 +3270,9 @@ and propagate_lexp_effect (LEXP_aux (lexp, annot)) = add_effect_lexp (LEXP_aux (p_lexp, annot)) eff and propagate_lexp_effect_aux = function | LEXP_id id -> LEXP_id id, no_effect + | LEXP_deref exp -> + let p_exp = propagate_exp_effect exp in + LEXP_deref p_exp, effect_of p_exp | LEXP_memory (id, exps) -> let p_exps = List.map propagate_exp_effect exps in LEXP_memory (id, p_exps), collect_effects p_exps @@ -3357,7 +3293,6 @@ and propagate_lexp_effect_aux = function | LEXP_field (lexp, id) -> let p_lexp = propagate_lexp_effect lexp in LEXP_field (p_lexp, id),effect_of_lexp p_lexp - | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in lexp" (**************************************************************************) (* 6. Checking toplevel definitions *) @@ -3446,12 +3381,16 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls) | None -> typ_error l "funcl list is empty" in typ_print ("\nChecking function " ^ string_of_id id); - let have_val_spec, (quant, (Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) as typ)), env = + let have_val_spec, (quant, typ), env = try true, Env.get_val_spec id env, env with | Type_error (l, _) -> let (quant, typ) = infer_funtyp l env tannotopt funcls in false, (quant, typ), env in + let vtyp_arg, vtyp_ret, declared_eff, vl = match typ with + | Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) -> vtyp_arg, vtyp_ret, declared_eff, vl + | _ -> typ_error l "Function val spec was not a function type" + in check_tannotopt env quant vtyp_ret tannotopt; typ_debug ("Checking fundef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ)); let funcl_env = add_typquant quant env in @@ -3477,6 +3416,7 @@ let check_val_spec env (VS_aux (vs, (l, _))) = | VS_val_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id, ext_opt, is_cast) -> let env = match ext_opt "smt" with Some op -> Env.add_smt_op id op env | None -> env in Env.wf_typ (add_typquant quants env) typ; + typ_debug "CHECKED WELL-FORMED VAL SPEC"; let env = (* match ext_opt with | None -> env @@ -3486,7 +3426,7 @@ let check_val_spec env (VS_aux (vs, (l, _))) = let env = if is_cast then Env.add_cast id env else env in (id, quants, typ, env) in - [DEF_spec (VS_aux (vs, (l, None)))], Env.add_val_spec id (quants, Env.expand_synonyms env typ) env + [DEF_spec (VS_aux (vs, (l, None)))], Env.add_val_spec id (quants, Env.expand_synonyms (add_typquant quants env) typ) env let check_default env (DT_aux (ds, l)) = match ds with @@ -3497,23 +3437,6 @@ let check_default env (DT_aux (ds, l)) = (* This branch allows us to write something like: default forall Nat 'n. [|'n|] name... what does this even mean?! *) | DT_typ (typschm, id) -> typ_error l ("Unsupported default construct") -let check_register env id base top ranges = - match base, top with - | Nexp_aux (Nexp_constant basec, _), Nexp_aux (Nexp_constant topc, _) -> - let no_typq = TypQ_aux (TypQ_tq [], Parse_ast.Unknown) (* Maybe could be TypQ_no_forall? *) in - (* FIXME: wrong for default Order inc? *) - let vec_typ = dvector_typ env base (nconstant (add_big_int (sub_big_int basec topc) unit_big_int)) bit_typ in - let cast_typ = mk_typ (Typ_fn (mk_id_typ id, vec_typ, no_effect)) in - let cast_to_typ = mk_typ (Typ_fn (vec_typ, mk_id_typ id, no_effect)) in - env - |> Env.add_regtyp id basec topc ranges - (* |> Env.add_typ_synonym id (fun _ -> vec_typ) *) - |> Env.add_val_spec (mk_id ("cast_" ^ string_of_id id)) (no_typq, cast_typ) - |> Env.add_cast (mk_id ("cast_" ^ string_of_id id)) - |> Env.add_val_spec (mk_id ("cast_to_" ^ string_of_id id)) (no_typq, cast_to_typ) - |> Env.add_cast (mk_id ("cast_to_" ^ string_of_id id)) - | _, _ -> typ_error (id_loc id) "Num expressions in register type declaration do not evaluate to constants" - let kinded_id_arg kind_id = let typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) in match kind_id with @@ -3523,6 +3446,7 @@ let kinded_id_arg kind_id = typ_arg (Typ_arg_order (Ord_aux (Ord_var kid, Parse_ast.Unknown))) | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), kid), _) -> typ_arg (Typ_arg_typ (mk_typ (Typ_var kid))) + | KOpt_aux (KOpt_kind (K_aux (K_kind kinds, _), kid), l) -> typ_error l "Badly formed kind" let fold_union_quant quants (QI_aux (qi, l)) = match qi with @@ -3562,35 +3486,53 @@ let mk_synonym typq typ = let typ, ncs = subst_args kopts args in if List.for_all (prove env) ncs then typ - else typ_error Parse_ast.Unknown "Could not prove constraints in type synonym" + else typ_error Parse_ast.Unknown ("Could not prove constraints " ^ string_of_list ", " string_of_n_constraint ncs + ^ " in type synonym " ^ string_of_typ typ + ^ " with " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env)) -let check_typedef env (TD_aux (tdef, (l, _))) = +let check_kinddef env (KD_aux (kdef, (l, _))) = + let kd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented kind def") in + match kdef with + | KD_nabbrev ((K_aux(K_kind([BK_aux (BK_nat, _)]),_) as kind), id, nmscm, nexp) -> + [DEF_kind (KD_aux (KD_nabbrev (kind, id, nmscm, nexp), (l, None)))], + Env.add_num_def id nexp env + | _ -> kd_err () + +let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t = + fun env (TD_aux (tdef, (l, _))) -> let td_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented Typedef") in match tdef with - | TD_abbrev(id, nmscm, (TypSchm_aux (TypSchm_ts (typq, typ), _))) -> + | TD_abbrev (id, nmscm, (TypSchm_aux (TypSchm_ts (typq, typ), _))) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (mk_synonym typq typ) env - | TD_record(id, nmscm, typq, fields, _) -> + | TD_record (id, nmscm, typq, fields, _) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env - | TD_variant(id, nmscm, typq, arms, _) -> + | TD_variant (id, nmscm, typq, arms, _) -> let env = env |> Env.add_variant id (typq, arms) |> (fun env -> List.fold_left (fun env tu -> check_type_union env id typq tu) env arms) in [DEF_type (TD_aux (tdef, (l, None)))], env - | TD_enum(id, nmscm, ids, _) -> + | TD_enum (id, nmscm, ids, _) -> [DEF_type (TD_aux (tdef, (l, None)))], Env.add_enum id ids env - | TD_register(id, base, top, ranges) -> [DEF_type (TD_aux (tdef, (l, Some (env, unit_typ, no_effect))))], check_register env id base top ranges - -let check_kinddef env (KD_aux (kdef, (l, _))) = - let kd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented kind def") in - match kdef with - | KD_nabbrev ((K_aux(K_kind([BK_aux (BK_nat, _)]),_) as kind), id, nmscm, nexp) -> - [DEF_kind (KD_aux (KD_nabbrev (kind, id, nmscm, nexp), (l, None)))], - Env.add_num_def id nexp env - | _ -> kd_err () + | TD_bitfield (id, typ, ranges) -> + let typ = Env.expand_synonyms env typ in + begin + match typ with + (* The type of a bitfield must be a constant-width bitvector *) + | Typ_aux (Typ_app (v, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant size, _)), _); + Typ_arg_aux (Typ_arg_order order, _); + Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id b, _)), _)]), _) + when string_of_id v = "vector" && string_of_id b = "bit" -> + let size = Big_int.to_int size in + let (Defs defs), env = check' env (Bitfield.macro id size order ranges) in + defs, env + | _ -> + typ_error l "Bad bitfield type" + end -let rec check_def env def = +and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t = + fun env def -> let cd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented Case") in match def with | DEF_kind kdef -> check_kinddef env kdef @@ -3619,7 +3561,8 @@ let rec check_def env def = let defs, env = check_def env def in List.map (fun def -> DEF_comm (DC_comm_struct def)) defs, env -let rec check' env (Defs defs) = +and check' : 'a. Env.t -> 'a defs -> tannot defs * Env.t = + fun env (Defs defs) -> match defs with | [] -> (Defs []), env | def :: defs -> @@ -3627,7 +3570,8 @@ let rec check' env (Defs defs) = let (Defs defs, env) = check' env (Defs defs) in (Defs (def @ defs)), env -let check env defs = +let check : 'a. Env.t -> 'a defs -> tannot defs * Env.t = + fun env defs -> try check' env defs with | Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) diff --git a/src/type_check.mli b/src/type_check.mli index 92949c85..b43cab6b 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -50,13 +50,13 @@ open Ast open Ast_util -open Big_int +module Big_int = Nat_big_num val opt_tc_debug : int ref val opt_no_effects : bool ref type type_error = - | Err_no_casts of type_error * type_error list + | Err_no_casts of unit exp * type_error * type_error list | Err_no_overloading of id * (id * type_error) list | Err_unresolved_quants of id * quant_item list | Err_subtype of typ * typ * n_constraint list @@ -84,15 +84,10 @@ module Env : sig val get_register : id -> t -> typ - val get_regtyp : id -> t -> big_int * big_int * (index_range * id) list - (* Return all the identifiers in an enumeration. Throws a type error if the enumeration doesn't exist. *) val get_enum : id -> t -> id list - (* Returns true if id is a register type, false otherwise *) - val is_regtyp : id -> t -> bool - val get_locals : t -> (mut * typ) Bindings.t val add_local : id -> mut * typ -> t -> t @@ -113,7 +108,8 @@ module Env : sig val is_record : id -> t -> bool - val get_accessor : id -> id -> t -> typquant * typ + (* Return type is: quantifier, argument type, return type, effect *) + val get_accessor : id -> id -> t -> typquant * typ * typ * effect (* If the environment is checking a function, then this will get the expected return type of the function. It's useful for checking or @@ -176,10 +172,7 @@ val add_typquant : typquant -> Env.t -> Env.t val orig_kid : kid -> kid (* Vector with default order. *) -val dvector_typ : Env.t -> nexp -> nexp -> typ -> typ - -(* Vector of specific length with default order, i.e. lvector_typ env n bit_typ = bit[n]. *) -val lvector_typ : Env.t -> nexp -> typ -> typ +val dvector_typ : Env.t -> nexp -> typ -> typ val exist_typ : (kid -> n_constraint) -> (kid -> typ) -> typ @@ -230,7 +223,7 @@ val destruct_atom_nexp : Env.t -> typ -> nexp option existential to ensure that no name-clashes occur. *) val destruct_exist : Env.t -> typ -> (kid list * n_constraint * typ) option -val destruct_vector : Env.t -> typ -> (nexp * nexp * order * typ) option +val destruct_vector : Env.t -> typ -> (nexp * order * typ) option type uvar = | U_nexp of nexp diff --git a/src/util.ml b/src/util.ml index 6f7d6a95..51ed8926 100644 --- a/src/util.ml +++ b/src/util.ml @@ -372,9 +372,25 @@ let is_some = function | Some _ -> true | None -> false +let rec take_drop f = function + | [] -> ([], []) + | (x :: xs) when not (f x) -> ([], x :: xs) + | (x :: xs) -> + let (ys, zs) = take_drop f xs in + (x :: ys, zs) + let is_none opt = not (is_some opt) let rec take n xs = match n, xs with | 0, _ -> [] | n, [] -> [] | n, (x :: xs) -> x :: take (n - 1) xs + +let termcode n = "\x1B[" ^ string_of_int n ^ "m" +let bold str = termcode 1 ^ str +let green str = termcode 92 ^ str +let yellow str = termcode 93 ^ str +let red str = termcode 91 ^ str +let cyan str = termcode 96 ^ str +let blue str = termcode 94 ^ str +let clear str = str ^ termcode 0 diff --git a/src/util.mli b/src/util.mli index 73dbd30b..39bc8a19 100644 --- a/src/util.mli +++ b/src/util.mli @@ -228,3 +228,15 @@ val is_some : 'a option -> bool val is_none : 'a option -> bool val take : int -> 'a list -> 'a list + +val take_drop : ('a -> bool) -> 'a list -> ('a list * 'a list) + +(* Terminal color codes *) +val termcode : int -> string +val bold : string -> string +val green : string -> string +val red : string -> string +val yellow : string -> string +val cyan : string -> string +val blue : string -> string +val clear : string -> string diff --git a/src/value.ml b/src/value.ml new file mode 100644 index 00000000..7dd3b30b --- /dev/null +++ b/src/value.ml @@ -0,0 +1,407 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* 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. *) +(**************************************************************************) + +module Big_int = Nat_big_num + +module StringMap = Map.Make(String) + +type value = + | V_vector of value list + | V_list of value list + | V_int of Big_int.num + | V_bool of bool + | V_bit of Sail_lib.bit + | V_tuple of value list + | V_unit + | V_string of string + | V_ref of string + | V_ctor of string * value list + | V_record of value StringMap.t + +let coerce_bit = function + | V_bit b -> b + | _ -> assert false + +let coerce_ctor = function + | V_ctor (str, vals) -> (str, vals) + | _ -> assert false + +let coerce_bool = function + | V_bool b -> b + | _ -> assert false + +let coerce_record = function + | V_record record -> record + | _ -> assert false + +let and_bool = function + | [v1; v2] -> V_bool (coerce_bool v1 && coerce_bool v2) + | _ -> assert false + +let or_bool = function + | [v1; v2] -> V_bool (coerce_bool v1 || coerce_bool v2) + | _ -> assert false + +let tuple_value (vs : value list) : value = V_tuple vs + +let mk_vector (bits : Sail_lib.bit list) : value = V_vector (List.map (fun bit -> V_bit bit) bits) + +let coerce_bit = function + | V_bit b -> b + | _ -> assert false + +let coerce_tuple = function + | V_tuple vs -> vs + | _ -> assert false + +let coerce_listlike = function + | V_tuple vs -> vs + | V_list vs -> vs + | V_unit -> [] + | _ -> assert false + +let coerce_int = function + | V_int i -> i + | _ -> assert false + +let coerce_cons = function + | V_list (v :: vs) -> Some (v, vs) + | V_list [] -> None + | _ -> assert false + +let coerce_gv = function + | V_vector vs -> vs + | _ -> assert false + +let coerce_bv = function + | V_vector vs -> List.map coerce_bit vs + | _ -> assert false + +let coerce_string = function + | V_string str -> str + | _ -> assert false + +let coerce_ref = function + | V_ref str -> str + | _ -> assert false + +let unit_value = V_unit + +let value_eq_int = function + | [v1; v2] -> V_bool (Sail_lib.eq_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value eq_int" + +let value_lteq = function + | [v1; v2] -> V_bool (Sail_lib.lteq (coerce_int v1, coerce_int v2)) + | _ -> failwith "value lteq" + +let value_gteq = function + | [v1; v2] -> V_bool (Sail_lib.gteq (coerce_int v1, coerce_int v2)) + | _ -> failwith "value gteq" + +let value_lt = function + | [v1; v2] -> V_bool (Sail_lib.lt (coerce_int v1, coerce_int v2)) + | _ -> failwith "value lt" + +let value_gt = function + | [v1; v2] -> V_bool (Sail_lib.gt (coerce_int v1, coerce_int v2)) + | _ -> failwith "value gt" + +let value_eq_list = function + | [v1; v2] -> V_bool (Sail_lib.eq_list (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value eq_list" + +let value_eq_string = function + | [v1; v2] -> V_bool (Sail_lib.eq_string (coerce_string v1, coerce_string v2)) + | _ -> failwith "value eq_string" + +let value_length = function + | [v] -> V_int (coerce_gv v |> List.length |> Big_int.of_int) + | _ -> failwith "value length" + +let value_subrange = function + | [v1; v2; v3] -> mk_vector (Sail_lib.subrange (coerce_bv v1, coerce_int v2, coerce_int v3)) + | _ -> failwith "value subrange" + +let value_access = function + | [v1; v2] -> Sail_lib.access (coerce_gv v1, coerce_int v2) + | _ -> failwith "value access" + +let value_update = function + | [v1; v2; v3] -> V_vector (Sail_lib.update (coerce_gv v1, coerce_int v2, v3)) + | _ -> failwith "value update" + +let value_update_subrange = function + | [v1; v2; v3; v4] -> mk_vector (Sail_lib.update_subrange (coerce_bv v1, coerce_int v2, coerce_int v3, coerce_bv v4)) + | _ -> failwith "value update_subrange" + +let value_append = function + | [v1; v2] -> V_vector (coerce_gv v1 @ coerce_gv v2) + | _ -> failwith "value append" + +let value_slice = function + | [v1; v2; v3] -> V_vector (Sail_lib.slice (coerce_gv v1, coerce_int v2, coerce_int v3)) + | _ -> failwith "value slice" + +let value_not = function + | [v] -> V_bool (not (coerce_bool v)) + | _ -> failwith "value not" + +let value_not_vec = function + | [v] -> mk_vector (Sail_lib.not_vec (coerce_bv v)) + | _ -> failwith "value not_vec" + +let value_and_vec = function + | [v1; v2] -> mk_vector (Sail_lib.and_vec (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value not_vec" + +let value_or_vec = function + | [v1; v2] -> mk_vector (Sail_lib.or_vec (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value not_vec" + +let value_uint = function + | [v] -> V_int (Sail_lib.uint (coerce_bv v)) + | _ -> failwith "value uint" + +let value_sint = function + | [v] -> V_int (Sail_lib.sint (coerce_bv v)) + | _ -> failwith "value sint" + +let value_get_slice_int = function + | [v1; v2; v3] -> mk_vector (Sail_lib.get_slice_int (coerce_int v1, coerce_int v2, coerce_int v3)) + | _ -> failwith "value get_slice_int" + +let value_set_slice_int = function + | [v1; v2; v3; v4] -> + V_int (Sail_lib.set_slice_int (coerce_int v1, coerce_int v2, coerce_int v3, coerce_bv v4)) + | _ -> failwith "value set_slice_int" + +let value_set_slice = function + | [v1; v2; v3; v4; v5] -> + mk_vector (Sail_lib.set_slice (coerce_int v1, coerce_int v2, coerce_bv v3, coerce_int v4, coerce_bv v5)) + | _ -> failwith "value set_slice" + +let value_hex_slice = function + | [v1; v2; v3] -> + mk_vector (Sail_lib.hex_slice (coerce_string v1, coerce_int v2, coerce_int v3)) + | _ -> failwith "value hex_slice" + +let value_add = function + | [v1; v2] -> V_int (Sail_lib.add (coerce_int v1, coerce_int v2)) + | _ -> failwith "value add" + +let value_sub = function + | [v1; v2] -> V_int (Sail_lib.sub (coerce_int v1, coerce_int v2)) + | _ -> failwith "value sub" + +let value_mult = function + | [v1; v2] -> V_int (Sail_lib.mult (coerce_int v1, coerce_int v2)) + | _ -> failwith "value mult" + +let value_quotient = function + | [v1; v2] -> V_int (Sail_lib.quotient (coerce_int v1, coerce_int v2)) + | _ -> failwith "value quotient" + +let value_modulus = function + | [v1; v2] -> V_int (Sail_lib.modulus (coerce_int v1, coerce_int v2)) + | _ -> failwith "value modulus" + +let value_add_vec_int = function + | [v1; v2] -> mk_vector (Sail_lib.add_vec_int (coerce_bv v1, coerce_int v2)) + | _ -> failwith "value add_vec_int" + +let value_add_vec = function + | [v1; v2] -> mk_vector (Sail_lib.add_vec (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value add_vec" + +let value_sub_vec = function + | [v1; v2] -> mk_vector (Sail_lib.sub_vec (coerce_bv v1, coerce_bv v2)) + | _ -> failwith "value sub_vec" + +let value_shl_int = function + | [v1; v2] -> V_int (Sail_lib.shl_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value shl_int" + +let value_shr_int = function + | [v1; v2] -> V_int (Sail_lib.shr_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value shr_int" + +let value_max_int = function + | [v1; v2] -> V_int (Sail_lib.max_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value max_int" + +let value_min_int = function + | [v1; v2] -> V_int (Sail_lib.min_int (coerce_int v1, coerce_int v2)) + | _ -> failwith "value min_int" + +let value_replicate_bits = function + | [v1; v2] -> mk_vector (Sail_lib.replicate_bits (coerce_bv v1, coerce_int v2)) + | _ -> failwith "value replicate_bits" + +let is_bit = function + | V_bit _ -> true + | _ -> false + + +let is_ctor = function + | V_ctor _ -> true + | _ -> false + +let rec string_of_value = function + | V_vector vs when List.for_all is_bit vs -> Sail_lib.string_of_bits (List.map coerce_bit vs) + | V_vector vs -> "[" ^ Util.string_of_list ", " string_of_value vs ^ "]" + | V_bool true -> "true" + | V_bool false -> "false" + | V_bit Sail_lib.B0 -> "bitzero" + | V_bit Sail_lib.B1 -> "bitone" + | V_int n -> Big_int.to_string n + | V_tuple vals -> "(" ^ Util.string_of_list ", " string_of_value vals ^ ")" + | V_list vals -> "[|" ^ Util.string_of_list ", " string_of_value vals ^ "|]" + | V_unit -> "()" + | V_string str -> "\"" ^ str ^ "\"" + | V_ref str -> "ref " ^ str + | V_ctor (str, vals) -> str ^ "(" ^ Util.string_of_list ", " string_of_value vals ^ ")" + | V_record record -> + "{" ^ Util.string_of_list ", " (fun (field, v) -> field ^ "=" ^ string_of_value v) (StringMap.bindings record) ^ "}" + +let eq_value v1 v2 = string_of_value v1 = string_of_value v2 + +let value_eq_anything = function + | [v1; v2] -> V_bool (eq_value v1 v2) + | _ -> failwith "value eq_anything" + +let value_print = function + | [v] -> print_endline (string_of_value v |> Util.red |> Util.clear); V_unit + | _ -> assert false + +let value_internal_pick = function + | [v1] -> List.hd (coerce_listlike v1); + | _ -> failwith "value internal_pick" + +let value_undefined_vector = function + | [v1; v2] -> V_vector (Sail_lib.undefined_vector (coerce_int v1, v2)) + | _ -> failwith "value undefined_vector" + +let value_read_ram = function + | [v1; v2; v3; v4] -> mk_vector (Sail_lib.read_ram (coerce_int v1, coerce_int v2, coerce_bv v3, coerce_bv v4)) + | _ -> failwith "value read_ram" + +let value_write_ram = function + | [v1; v2; v3; v4; v5] -> + Sail_lib.write_ram (coerce_int v1, coerce_int v2, coerce_bv v3, coerce_bv v4, coerce_bv v5); + V_unit + | _ -> failwith "value write_ram" + +let value_putchar = function + | [v] -> Sail_lib.putchar (coerce_int v); V_unit + | _ -> failwith "value putchar" + +let value_print_bits = function + | [msg; bits] -> print_endline (coerce_string msg ^ string_of_value bits); V_unit + | _ -> failwith "value print_bits" + +let primops = + List.fold_left + (fun r (x, y) -> StringMap.add x y r) + StringMap.empty + [ ("and_bool", and_bool); + ("or_bool", or_bool); + ("print_endline", value_print); + ("prerr_endline", value_print); + ("putchar", value_putchar); + ("string_of_bits", fun vs -> V_string (string_of_value (List.hd vs))); + ("print_bits", value_print_bits); + ("eq_int", value_eq_int); + ("lteq", value_lteq); + ("gteq", value_gteq); + ("lt", value_lt); + ("gt", value_gt); + ("eq_list", value_eq_list); + ("eq_string", value_eq_string); + ("eq_anything", value_eq_anything); + ("length", value_length); + ("subrange", value_subrange); + ("access", value_access); + ("update", value_update); + ("update_subrange", value_update_subrange); + ("slice", value_slice); + ("append", value_append); + ("not", value_not); + ("not_vec", value_not_vec); + ("and_vec", value_and_vec); + ("or_vec", value_or_vec); + ("uint", value_uint); + ("sint", value_sint); + ("get_slice_int", value_get_slice_int); + ("set_slice_int", value_set_slice_int); + ("set_slice", value_set_slice); + ("hex_slice", value_hex_slice); + ("add", value_add); + ("sub", value_sub); + ("mult", value_mult); + ("quotient", value_quotient); + ("modulus", value_modulus); + ("shr_int", value_shr_int); + ("shl_int", value_shl_int); + ("max_int", value_max_int); + ("min_int", value_min_int); + ("add_vec_int", value_add_vec_int); + ("add_vec", value_add_vec); + ("sub_vec", value_sub_vec); + ("read_ram", value_read_ram); + ("write_ram", value_write_ram); + ("undefined_bit", fun _ -> V_bit Sail_lib.B0); + ("undefined_int", fun _ -> V_int Big_int.zero); + ("undefined_bool", fun _ -> V_bool false); + ("undefined_vector", value_undefined_vector); + ("internal_pick", value_internal_pick); + ("replicate_bits", value_replicate_bits); + ("Elf_loader.elf_entry", fun _ -> V_int (!Elf_loader.opt_elf_entry)); + ] diff --git a/test/ocaml/bitfield/bitfield.sail b/test/ocaml/bitfield/bitfield.sail new file mode 100644 index 00000000..5a70d52e --- /dev/null +++ b/test/ocaml/bitfield/bitfield.sail @@ -0,0 +1,32 @@ + +val _reg_deref = "reg_deref" : forall ('a : Type). register('a) -> 'a + +bitfield cr : bits(8) = { + CR0 : 7 .. 4, + LT : 7, + CR1 : 3 .. 2, + CR2 : 1, + CR3 : 0, +} + +register CR : cr + +bitfield dr : vector(4, inc, bit) = { + DR0 : 2 .. 3 +} + +register DR : dr + +val main : unit -> unit effect {rreg, wreg} + +function main () = { + CR->bits() = 0xFF; + print_bits("CR: ", CR.bits()); + ref CR.CR0() = 0x0; + print_bits("CR: ", CR.bits()); + CR->LT() = 0b1; + print_bits("CR.CR0: ", CR.CR0()); + print_bits("CR: ", CR.bits()); + CR->CR3() = 0b0; + print_bits("CR: ", CR.bits()) +} diff --git a/test/ocaml/bitfield/expect b/test/ocaml/bitfield/expect new file mode 100644 index 00000000..63247dfd --- /dev/null +++ b/test/ocaml/bitfield/expect @@ -0,0 +1,5 @@ +CR: 0xFF +CR: 0x0F +CR.CR0: 0x8 +CR: 0x8F +CR: 0x8E diff --git a/test/ocaml/lsl/lsl.sail b/test/ocaml/lsl/lsl.sail index 8c3e9700..fab04306 100644 --- a/test/ocaml/lsl/lsl.sail +++ b/test/ocaml/lsl/lsl.sail @@ -2,7 +2,7 @@ val zeros : forall ('n : Int), 'n >= 0. atom('n) -> bits('n) function zeros n = replicate_bits(0b0, 'n) -val lslc : forall ('n : Int) ('shift : Int), 'n >= 0. +val lslc : forall ('n : Int) ('shift : Int), 'n >= 1. (bits('n), atom('shift)) -> (bits('n), bit) effect {escape} function lslc (vec, shift) = { @@ -13,7 +13,7 @@ function lslc (vec, shift) = { return((result, c)) } -val lsl : forall ('n : Int) ('shift : Int), 'n >= 0. +val lsl : forall ('n : Int) ('shift : Int), 'n >= 1. (bits('n), atom('shift)) -> bits('n) effect {escape} function lsl (vec, shift) = if shift == 0 then vec else let (result, _) = lslc(vec, shift) in result diff --git a/test/ocaml/prelude.sail b/test/ocaml/prelude.sail index b56ce7e2..add43eec 100644 --- a/test/ocaml/prelude.sail +++ b/test/ocaml/prelude.sail @@ -1,6 +1,6 @@ default Order dec -type bits ('n : Int) = vector('n - 1, 'n, dec, bit) +type bits ('n : Int) = vector('n, dec, bit) infix 4 == @@ -20,37 +20,49 @@ val eq_real = "eq_real" : (real, real) -> bool val eq_anything = "(fun (x, y) -> x = y)" : forall ('a : Type). ('a, 'a) -> bool -val length = "length" : forall 'n ('a : Type). vector('n - 1, 'n, dec, 'a) -> atom('n) +val length = "length" : forall 'n ('a : Type). vector('n, dec, 'a) -> atom('n) overload operator == = {eq_atom, eq_int, eq_vec, eq_string, eq_real, eq_anything} -val vector_subrange_A = "subrange" : forall ('n : Int) ('m : Int) ('o : Int), 'o <= 'm <= 'n. +val vector_subrange_dec = "subrange" : forall ('n : Int) ('m : Int) ('o : Int), 'o <= 'm <= 'n. (bits('n), atom('m), atom('o)) -> bits('m - ('o - 1)) +val vector_subrange_inc = "subrange" : forall ('n : Int) ('m : Int) ('o : Int), 'm <= 'o <= 'n. + (vector('n, inc, bit), atom('m), atom('o)) -> vector('o - ('m - 1), inc, bit) + +/* val vector_subrange_B = "subrange" : forall ('n : Int) ('m : Int) ('o : Int). (bits('n), atom('m), atom('o)) -> bits('m - ('o - 1)) +*/ -overload vector_subrange = {vector_subrange_A, vector_subrange_B} +overload vector_subrange = {vector_subrange_dec, vector_subrange_inc} -val vector_access_A = "access" : forall ('n : Int) ('m : Int) ('a : Type), 0 <= 'm < 'n. - (vector('n - 1, 'n, dec, 'a), atom('m)) -> 'a +val vector_access_dec = "access" : forall ('n : Int) ('m : Int) ('a : Type), 0 <= 'm < 'n. + (vector('n, dec, 'a), atom('m)) -> 'a +/* val vector_access_B = "access" : forall ('n : Int) ('a : Type). - (vector('n - 1, 'n, dec, 'a), int) -> 'a + (vector('n, dec, 'a), int) -> 'a +*/ -overload vector_access = {vector_access_A, vector_access_B} +overload vector_access = {vector_access_dec} val vector_update = "update" : forall 'n ('a : Type). - (vector('n - 1, 'n, dec, 'a), int, 'a) -> vector('n - 1, 'n, dec, 'a) + (vector('n, dec, 'a), int, 'a) -> vector('n, dec, 'a) -val vector_update_subrange = "update_subrange" : forall 'n 'm 'o. +val vector_update_subrange_dec = "update_subrange" : forall 'n 'm 'o. (bits('n), atom('m), atom('o), bits('m - ('o - 1))) -> bits('n) +val vector_update_subrange_inc = "update_subrange" : forall 'n 'm 'o. + (vector('n, inc, bit), atom('m), atom('o), vector('o - ('m - 1), inc, bit)) -> vector('n, inc, bit) + +overload vector_update_subrange = {vector_update_subrange_dec, vector_update_subrange_inc} + val vcons : forall ('n : Int) ('a : Type). - ('a, vector('n - 1, 'n, dec, 'a)) -> vector('n, 'n + 1, dec, 'a) + ('a, vector('n, dec, 'a)) -> vector('n + 1, dec, 'a) val append = "append" : forall ('n : Int) ('m : Int) ('a : Type). - (vector('n - 1, 'n, dec, 'a), vector('m - 1, 'm, dec, 'a)) -> vector('n + 'm - 1, 'n + 'm, dec, 'a) + (vector('n, dec, 'a), vector('m, dec, 'a)) -> vector('n + 'm, dec, 'a) val not_bool = "not" : bool -> bool diff --git a/test/ocaml/reg_alias/expect b/test/ocaml/reg_alias/expect new file mode 100644 index 00000000..21493790 --- /dev/null +++ b/test/ocaml/reg_alias/expect @@ -0,0 +1,7 @@ +CR = 0x00 +CR = 0xCA +CR.CR0 = 0xC +CR.CR1 = 0b10 +CR.CR2 = 0b10 +CR = 0xFA +CR = 0xF8 diff --git a/test/ocaml/reg_alias/ra.sail b/test/ocaml/reg_alias/ra.sail new file mode 100644 index 00000000..f4e6d529 --- /dev/null +++ b/test/ocaml/reg_alias/ra.sail @@ -0,0 +1,79 @@ + +val "reg_deref" : forall ('a : Type). register('a) -> 'a effect {rreg} +val _reg_deref = "reg_deref" : forall ('a : Type). register('a) -> 'a + +struct cr = { + CR0 : bits(4), + CR1 : bits(2), + CR2 : bits(2) +} + +val _set_CR0 : (register(cr), bits(4)) -> unit effect {wreg} +val _get_CR0 : register(cr) -> bits(4) effect {rreg} + +val _set_CR1 : (register(cr), bits(2)) -> unit effect {wreg} +val _get_CR1 : register(cr) -> bits(2) effect {rreg} + +val _set_CR2 : (register(cr), bits(2)) -> unit effect {wreg} +val _get_CR2 : register(cr) -> bits(2) effect {rreg} + +function _set_CR0 (cr_ref, v) = { + cr = _reg_deref(cr_ref); + cr.CR0 = v; + (*cr_ref) = cr; +} +function _get_CR0 cr = reg_deref(cr).CR0 + +function _set_CR1 (cr_ref, v) = { + cr = _reg_deref(cr_ref); + cr.CR1 = v; + (*cr_ref) = cr; +} +function _get_CR1 cr = reg_deref(cr).CR1 + +function _set_CR2 (cr_ref, v) = { + cr = _reg_deref(cr_ref); + cr.CR2 = v; + (*cr_ref) = cr; +} +function _get_CR2 cr = reg_deref(cr).CR2 + +overload _mod_CR0 = {_set_CR0, _get_CR0} +overload _mod_CR1 = {_set_CR1, _get_CR1} +overload _mod_CR2 = {_set_CR2, _get_CR2} + +val _get_cr : register(cr) -> bits(8) effect {rreg} + +function _get_cr cr_ref = + let cr = reg_deref(cr_ref) in cr.CR0 @ cr.CR1 @ cr.CR2 + +val _set_cr : (register(cr), bits(8)) -> unit effect {wreg} + +function _set_cr (cr_ref, v) = { + cr = _reg_deref(cr_ref); + cr.CR0 = v[7 .. 4]; + cr.CR1 = v[3 .. 2]; + cr.CR2 = v[1 .. 0]; + (*cr_ref) = cr +} + +overload _mod_cr = {_set_cr, _get_cr} + +register CR : cr + +val main : unit -> unit effect {wreg, rreg} + +function main () = { + CR->cr() = 0x00; + print_bits("CR = ", CR->cr()); + CR->cr() = 0xCA; + print_bits("CR = ", CR->cr()); + print_bits("CR.CR0 = ", CR->CR0()); + print_bits("CR.CR1 = ", CR->CR1()); + print_bits("CR.CR2 = ", CR->CR2()); + CR->CR0() = 0xF; + print_bits("CR = ", CR->cr()); + CR->CR2() = 0b00; + print_bits("CR = ", CR->cr()); + () +}
\ No newline at end of file diff --git a/test/ocaml/reg_passing/reg_passing.sail b/test/ocaml/reg_passing/reg_passing.sail index 94acdf7e..d84f98e0 100644 --- a/test/ocaml/reg_passing/reg_passing.sail +++ b/test/ocaml/reg_passing/reg_passing.sail @@ -17,8 +17,8 @@ function f R = { val g : unit -> unit effect {rreg, wreg} function g () = { - f(R1); - f(R2); + f(ref R1); + f(ref R2); } val main : unit -> unit effect {rreg, wreg} @@ -28,7 +28,7 @@ function main () = { R2 = 5; g (); R3 = 10; - f(R3); + f(ref R3); R2 = 20; output("R1 = ", R1); output("R2 = ", R2); diff --git a/test/ocaml/reg_ref/expect b/test/ocaml/reg_ref/expect new file mode 100644 index 00000000..904fc765 --- /dev/null +++ b/test/ocaml/reg_ref/expect @@ -0,0 +1,51 @@ +Testing register references +Register 1 +Assigning 0x00000000 +Register 2 +Assigning 0x00000000 +Register 3 +Assigning 0x00000000 +1 = 0x00000000 +2 = 0x00000000 +3 = 0x00000000 +Register 1 +Assigning 0xCAFEBEEF +1 = 0xCAFEBEEF +2 = 0x00000000 +3 = 0x00000000 +Reading 1 to variable +v = 0xCAFEBEEF +Register 3 +Assigning 0x00BEEF00 +1 = 0xCAFEBEEF +2 = 0x00000000 +3 = 0x00BEEF00 +Reading zero register +0 = 0x00000000 +Register 2 +Assigning 0xDEADCAFE +2 = 0xDEADCAFE +Assigning register 2 to register 1 +Register 2 +Assigning 0xCAFEBEEF +1 = 0xCAFEBEEF +2 = 0xCAFEBEEF +3 = 0x00BEEF00 + +Testing slicing +s = 0b111 +s = 0b01110 +s = 0xE +b = 0b01110 +b = 0b01010 +b = 0b01111 + +Testing bit aliasing +CR0 = 0x0 +LT = 0b0 +Setting LT to bitone +CR0 = 0x8 +LT = 0b1 +Setting CR0 to 0b0111 +CR0 = 0x7 +LT = 0b0 diff --git a/test/ocaml/reg_ref/rr.sail b/test/ocaml/reg_ref/rr.sail new file mode 100644 index 00000000..f6d40a08 --- /dev/null +++ b/test/ocaml/reg_ref/rr.sail @@ -0,0 +1,177 @@ + +val "reg_deref" : forall ('a : Type). register('a) -> 'a effect {rreg} +val deref = "reg_deref" : forall ('a : Type). ref('a) -> 'a + +/* *** Register reference list example *** */ + +type regno ('n : Int), 0 <= 'n < 4 = atom('n) + +/* regiser x0 : bits(32) is always 0 */ +register x1 : bits(32) +register x2 : bits(32) +register x3 : bits(32) + +let GPRs : vector(3, dec, register(bits(32))) = + [ ref x3, ref x2, ref x1 ] + +val rGPR : forall 'n, 0 <= 'n < 4. regno('n) -> bits(32) effect {rreg} + +function rGPR 0 = 0x00000000 +and rGPR (r if r > 0) = reg_deref(GPRs[r - 1]) + +val wGPR : forall 'n, 1 <= 'n < 4. (regno('n), bits(32)) -> unit effect {wreg} + +function wGPR (r, v) = { + print_int("Register ", r); + print_bits("Assigning ", v); + (*GPRs[r - 1]) = v +} + +overload _mod_GPR = { rGPR, wGPR } + +/* *** Power style vector slicing *** */ + +/* Create a new type which is a pair of a bitvector and a start index + + slice('n, 'm) is equivalent to old-sail vector('n, 'm, dec, bit) */ +newtype slice ('n : Int) ('m : Int) = MkSlice : (atom('n), bits('m)) + +/* Extract the bitvector from a slice */ +val slice_bits : forall 'n 'm. slice('n, 'm) -> bits('m) + +function slice_bits MkSlice(_, xs) = xs + +/* Take a slice from a bitvector */ +val vector_slice : forall 'n 'm 'o, 0 <= 'm <= 'o <= 'n. + (bits('n), atom('o), atom('m)) -> slice('m, 'o - ('m - 1)) + +function vector_slice (v, to, from) = MkSlice(from, v[to .. from]) + +val slice_slice : forall 'n 'm 'o 'p, 'm <= 'o & 'o - 'p <= 'n. + (slice('p, 'n), atom('o), atom('m)) -> slice('m, 'o - ('m - 1)) + +function slice_slice (MkSlice(start, v), to, from) = MkSlice(from, v[to - start .. from - start]) + +/* We can update a bitvector from another bitvector or a slice */ +val _set_slice : forall 'n 'm 'o, 0 <= 'm <= 'o <= 'n. + (ref(bits('n)), atom('o), atom('m), bits('o - ('m - 1))) -> unit + +function _set_slice (v, stop, start, update) = { + v2 = deref(v); + v2[stop .. start] = update; + (*v) = v2; +} + +val _set_slice2 : forall 'n 'm 'o 'p, 0 <= 'm <= 'o <= 'n. + (ref(bits('n)), atom('o), atom('m), slice('p, 'o - ('m - 1))) -> unit + +function _set_slice2 (v, stop, start, MkSlice(_, update)) = _set_slice(v, stop, start, update) + +val slice_bit : forall 'n. slice('n, 1) -> bit + +function slice_bit MkSlice(_, [b]) = b + +/* Overload slice modifier */ +overload _mod_slice = {_set_slice, _set_slice2, vector_slice, slice_slice} + +/* Set up a struct with an aliased LT bit in CR0, mimicing old-style syntax */ +infix 1 ... + +type operator ... ('n : Int) ('m : Int) = slice('m, 'n - ('m - 1)) + +struct cr = { + CR0 : 7 ... 4, + /* 7 : LT; 6 : GT; 5 : EQ; 4 : SO; */ + CR1 : 3 ... 2, + CR3 : 1 ... 0, +} + +register CR : cr + +val _get_LT : cr -> bit +val _set_LT : (register(cr), bit) -> unit effect {rreg, wreg} + +function _get_LT cr = slice_bit(cr.CR0.slice(7, 7)) +function _set_LT (cr_ref, b) = { + cr = reg_deref(cr_ref); + cr.CR0 = MkSlice(4, [slice_bits(cr.CR0) with (7 - 4) = b]); + (*cr_ref) = cr; +} + +overload _mod_LT = {_get_LT, _set_LT} + +/* *** Test Program *** */ + +val main : unit -> unit effect {wreg, rreg} + +val print_regs : unit -> unit effect {rreg} + +function print_regs () = { + print_bits("1 = ", rGPR(1)); + print_bits("2 = ", rGPR(2)); + print_bits("3 = ", rGPR(3)); +} + +function main () = { + print("Testing register references"); + wGPR(1) = 0x00000000; + wGPR(2) = 0x00000000; + wGPR(3) = 0x00000000; + + print_regs (); + + /* Assign to lowest assignable register */ + wGPR(1) = 0xCAFEBEEF; + print_regs (); + + /* Reading to variable */ + print("Reading 1 to variable"); + v = rGPR(1); + print_bits("v = ", v); + + /* Assign to highest register */ + wGPR(3) = 0x00BEEF00; + print_regs (); + + print("Reading zero register"); + print_bits("0 = ", rGPR(0)); + + /* Test overloaded version */ + _mod_GPR(2) = 0xDEADCAFE; + print_bits("2 = ", _mod_GPR(2)); + + /* Method syntax */ + print("Assigning register 2 to register 1"); + 2.GPR() = 1.GPR(); + print_regs(); + + /* Slice testing */ + print("\nTesting slicing"); + let s = 0b01110.slice(3, 1); + print_bits("s = ", slice_bits(s)); + let s = 0b01110.slice(4, 0); + print_bits("s = ", slice_bits(s)); + let s = 0b01110.slice(3, 0); + print_bits("s = ", slice_bits(s)); + + /* Updating slices */ + b = 0b01110; + print_bits("b = ", b); + b->slice(3, 1) = 0b101; + print_bits("b = ", b); + b->slice(2, 0) = 0xFF.slice(5, 3); + print_bits("b = ", b); + + /* Bit aliasing */ + print("\nTesting bit aliasing"); + print_bits("CR0 = ", slice_bits(CR.CR0)); + print_bits("LT = ", [CR.LT()]); + print("Setting LT to bitone"); + CR->LT() = bitone; + print_bits("CR0 = ", slice_bits(CR.CR0)); + print_bits("LT = ", [CR.LT()]); + print("Setting CR0 to 0b0111"); + CR.CR0 = MkSlice(4, 0b0111); + print_bits("CR0 = ", slice_bits(CR.CR0)); + print_bits("LT = ", [CR.LT()]); +} diff --git a/test/ocaml/run_tests.sh b/test/ocaml/run_tests.sh index 9ed00494..aad3aa39 100755 --- a/test/ocaml/run_tests.sh +++ b/test/ocaml/run_tests.sh @@ -50,7 +50,7 @@ printf "<testsuites>\n" >> $DIR/tests.xml for i in `ls -d */`; do cd $DIR/$i; - if $SAILDIR/sail -new_parser -o out -ocaml ../prelude.sail `ls *.sail` 1> /dev/null; + if $SAILDIR/sail -o out -ocaml ../prelude.sail `ls *.sail` 1> /dev/null; then ./out > result; if diff expect result; @@ -74,7 +74,7 @@ cd $DIR for i in `ls -d */`; do cd $DIR/$i; - if $SAILDIR/sail -new_parser -o out -ocaml_trace ../prelude.sail `ls *.sail` 1> /dev/null; + if $SAILDIR/sail -o out -ocaml_trace ../prelude.sail `ls *.sail` 1> /dev/null; then ./out > result 2> /dev/null; if diff expect result; diff --git a/test/ocaml/vec_32_64/vec_32_64.sail b/test/ocaml/vec_32_64/vec_32_64.sail index eb518515..60fa0e46 100644 --- a/test/ocaml/vec_32_64/vec_32_64.sail +++ b/test/ocaml/vec_32_64/vec_32_64.sail @@ -1,6 +1,6 @@ -(* This example is more testing the typechecker flow typing rather +/* This example is more testing the typechecker flow typing rather than the ocaml backend, but it does test that recursive functions work -correctly *) +correctly */ val get_size : unit -> {|32, 64|} @@ -8,7 +8,7 @@ function get_size () = 32 val only64 = { ocaml: "(fun _ -> ())" } : bits(64) -> unit -val zeros : forall 'n. atom('n) -> vector('n - 1, 'n, dec, bit) +val zeros : forall 'n. atom('n) -> vector('n, dec, bit) function zeros n = if (n == 1 + 0) then 0b0 else 0b0 @ zeros('n - 1) |