diff options
Diffstat (limited to 'backend')
32 files changed, 2075 insertions, 11274 deletions
diff --git a/backend/CMlexer.mli b/backend/CMlexer.mli new file mode 100644 index 00000000..c6afb72c --- /dev/null +++ b/backend/CMlexer.mli @@ -0,0 +1,17 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +val token: Lexing.lexbuf -> CMparser.token +exception Error of string diff --git a/backend/CMlexer.mll b/backend/CMlexer.mll new file mode 100644 index 00000000..9854117c --- /dev/null +++ b/backend/CMlexer.mll @@ -0,0 +1,132 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +{ +open Camlcoq +open CMparser +exception Error of string +} + +let blank = [' ' '\009' '\012' '\010' '\013'] +let floatlit = + ['0'-'9'] ['0'-'9' '_']* + ('.' ['0'-'9' '_']* )? + (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? +let ident = ['A'-'Z' 'a'-'z' '_'] ['A'-'Z' 'a'-'z' '_' '0'-'9']* +let intlit = "-"? ( ['0'-'9']+ | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+ + | "0o" ['0'-'7']+ | "0b" ['0'-'1']+ ) +let stringlit = "\"" [ ^ '"' ] * '"' + +rule token = parse + | blank + { token lexbuf } + | "/*" { comment lexbuf; token lexbuf } + | "absf" { ABSF } + | "alloc" { ALLOC } + | "&" { AMPERSAND } + | "&&" { AMPERSANDAMPERSAND } + | "!" { BANG } + | "!=" { BANGEQUAL } + | "!=f" { BANGEQUALF } + | "!=u" { BANGEQUALU } + | "|" { BAR } + | "||" { BARBAR } + | "^" { CARET } + | "case" { CASE } + | ":" { COLON } + | "," { COMMA } + | "default" { DEFAULT } + | "$" { DOLLAR } + | "else" { ELSE } + | "=" { EQUAL } + | "==" { EQUALEQUAL } + | "==f" { EQUALEQUALF } + | "==u" { EQUALEQUALU } + | "exit" { EXIT } + | "extern" { EXTERN } + | "float" { FLOAT } + | "float32" { FLOAT32 } + | "float64" { FLOAT64 } + | "floatofint" { FLOATOFINT } + | "floatofintu" { FLOATOFINTU } + | ">" { GREATER } + | ">f" { GREATERF } + | ">u" { GREATERU } + | ">=" { GREATEREQUAL } + | ">=f" { GREATEREQUALF } + | ">=u" { GREATEREQUALU } + | ">>" { GREATERGREATER } + | ">>u" { GREATERGREATERU } + | "if" { IF } + | "in" { IN } + | "int" { INT } + | "int16s" { INT16S } + | "int16u" { INT16U } + | "int32" { INT32 } + | "int8s" { INT8S } + | "int8u" { INT8U } + | "intoffloat" { INTOFFLOAT } + | "intuoffloat" { INTUOFFLOAT } + | "{" { LBRACE } + | "{{" { LBRACELBRACE } + | "[" { LBRACKET } + | "<" { LESS } + | "<u" { LESSU } + | "<f" { LESSF } + | "<=" { LESSEQUAL } + | "<=u" { LESSEQUALU } + | "<=f" { LESSEQUALF } + | "<<" { LESSLESS } + | "let" { LET } + | "loop" { LOOP } + | "(" { LPAREN } + | "match" { MATCH } + | "-" { MINUS } + | "->" { MINUSGREATER } + | "-f" { MINUSF } + | "%" { PERCENT } + | "%u" { PERCENTU } + | "+" { PLUS } + | "+f" { PLUSF } + | "?" { QUESTION } + | "}" { RBRACE } + | "}}" { RBRACERBRACE } + | "]" { RBRACKET } + | "return" { RETURN } + | ")" { RPAREN } + | ";" { SEMICOLON } + | "/" { SLASH } + | "/f" { SLASHF } + | "/u" { SLASHU } + | "stack" { STACK } + | "*" { STAR } + | "*f" { STARF } + | "switch" { SWITCH } + | "tailcall" { TAILCALL } + | "~" { TILDE } + | "var" { VAR } + | "void" { VOID } + + | intlit { INTLIT(Int32.of_string(Lexing.lexeme lexbuf)) } + | floatlit { FLOATLIT(float_of_string(Lexing.lexeme lexbuf)) } + | stringlit { let s = Lexing.lexeme lexbuf in + STRINGLIT(intern_string(String.sub s 1 (String.length s - 2))) } + | ident { IDENT(intern_string(Lexing.lexeme lexbuf)) } + | eof { EOF } + | _ { raise(Error("illegal character `" ^ Char.escaped (Lexing.lexeme_char lexbuf 0) ^ "'")) } + +and comment = parse + "*/" { () } + | eof { raise(Error "unterminated comment") } + | _ { comment lexbuf } diff --git a/backend/CMparser.mly b/backend/CMparser.mly new file mode 100644 index 00000000..25fb0321 --- /dev/null +++ b/backend/CMparser.mly @@ -0,0 +1,541 @@ +/* *********************************************************************/ +/* */ +/* The Compcert verified compiler */ +/* */ +/* Xavier Leroy, INRIA Paris-Rocquencourt */ +/* */ +/* Copyright Institut National de Recherche en Informatique et en */ +/* Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU General Public License as published by */ +/* the Free Software Foundation, either version 2 of the License, or */ +/* (at your option) any later version. This file is also distributed */ +/* under the terms of the INRIA Non-Commercial License Agreement. */ +/* */ +/* *********************************************************************/ + +%{ +open Datatypes +open CList +open Camlcoq +open BinPos +open BinInt +open Integers +open AST +open Cminor + +(** Naming function calls in expressions *) + +type rexpr = + | Rvar of ident + | Rconst of constant + | Runop of unary_operation * rexpr + | Rbinop of binary_operation * rexpr * rexpr + | Rload of memory_chunk * rexpr + | Rcondition of rexpr * rexpr * rexpr + | Rcall of signature * rexpr * rexpr list + | Ralloc of rexpr + +let temp_counter = ref 0 + +let temporaries = ref [] + +let mktemp () = + incr temp_counter; + let n = Printf.sprintf "__t%d" !temp_counter in + let id = intern_string n in + temporaries := id :: !temporaries; + id + +let convert_accu = ref [] + +let rec convert_rexpr = function + | Rvar id -> Evar id + | Rconst c -> Econst c + | Runop(op, e1) -> Eunop(op, convert_rexpr e1) + | Rbinop(op, e1, e2) -> + let c1 = convert_rexpr e1 in + let c2 = convert_rexpr e2 in + Ebinop(op, c1, c2) + | Rload(chunk, e1) -> Eload(chunk, convert_rexpr e1) + | Rcondition(e1, e2, e3) -> + let c1 = convert_rexpr e1 in + let c2 = convert_rexpr e2 in + let c3 = convert_rexpr e3 in + Econdition(c1, c2, c3) + | Rcall(sg, e1, el) -> + let c1 = convert_rexpr e1 in + let cl = convert_rexpr_list el in + let t = mktemp() in + convert_accu := Scall(Some t, sg, c1, cl) :: !convert_accu; + Evar t + | Ralloc e1 -> + let c1 = convert_rexpr e1 in + let t = mktemp() in + convert_accu := Salloc(t, c1) :: !convert_accu; + Evar t + +and convert_rexpr_list = function + | [] -> [] + | e1 :: el -> + let c1 = convert_rexpr e1 in + let cl = convert_rexpr_list el in + c1 :: cl + +let rec prepend_seq stmts last = + match stmts with + | [] -> last + | s1 :: sl -> prepend_seq sl (Sseq(s1, last)) + +let mkeval e = + convert_accu := []; + match e with + | Rcall(sg, e1, el) -> + let c1 = convert_rexpr e1 in + let cl = convert_rexpr_list el in + prepend_seq !convert_accu (Scall(None, sg, c1, cl)) + | _ -> + ignore (convert_rexpr e); + prepend_seq !convert_accu Sskip + +let mkassign id e = + convert_accu := []; + match e with + | Rcall(sg, e1, el) -> + let c1 = convert_rexpr e1 in + let cl = convert_rexpr_list el in + prepend_seq !convert_accu (Scall(Some id, sg, c1, cl)) + | Ralloc(e1) -> + let c1 = convert_rexpr e1 in + prepend_seq !convert_accu (Salloc(id, c1)) + | _ -> + let c = convert_rexpr e in + prepend_seq !convert_accu (Sassign(id, c)) + +let mkstore chunk e1 e2 = + convert_accu := []; + let c1 = convert_rexpr e1 in + let c2 = convert_rexpr e2 in + prepend_seq !convert_accu (Sstore(chunk, c1, c2)) + +let mkifthenelse e s1 s2 = + convert_accu := []; + let c = convert_rexpr e in + prepend_seq !convert_accu (Sifthenelse(c, s1, s2)) + +let mkreturn_some e = + convert_accu := []; + let c = convert_rexpr e in + prepend_seq !convert_accu (Sreturn (Some c)) + +let mktailcall sg e1 el = + convert_accu := []; + let c1 = convert_rexpr e1 in + let cl = convert_rexpr_list el in + prepend_seq !convert_accu (Stailcall(sg, c1, cl)) + +(** Other constructors *) + +let intconst n = + Rconst(Ointconst(coqint_of_camlint n)) + +let andbool e1 e2 = + Rcondition(e1, e2, intconst 0l) +let orbool e1 e2 = + Rcondition(e1, intconst 1l, e2) + +let exitnum n = nat_of_camlint(Int32.pred n) + +let mkswitch expr (cases, dfl) = + convert_accu := []; + let c = convert_rexpr expr in + let rec mktable = function + | [] -> [] + | (key, exit) :: rem -> + Coq_pair(coqint_of_camlint key, exitnum exit) :: mktable rem in + prepend_seq !convert_accu (Sswitch(c, mktable cases, exitnum dfl)) + +(*** + match (a) { case 0: s0; case 1: s1; case 2: s2; } ---> + + block { + block { + block { + block { + switch(a) { case 0: exit 0; case 1: exit 1; default: exit 2; } + }; s0; exit 2; + }; s1; exit 1; + }; s2; + } + + Note that matches are assumed to be exhaustive +***) + +let mkmatch_aux expr cases = + let ncases = Int32.of_int (List.length cases) in + let rec mktable n = function + | [] -> assert false + | [key, action] -> [] + | (key, action) :: rem -> + Coq_pair(coqint_of_camlint key, nat_of_camlint n) + :: mktable (Int32.succ n) rem in + let sw = + Sswitch(expr, mktable 0l cases, nat_of_camlint (Int32.pred ncases)) in + let rec mkblocks body n = function + | [] -> assert false + | [key, action] -> + Sblock(Sseq(body, action)) + | (key, action) :: rem -> + mkblocks + (Sblock(Sseq(body, Sseq(action, Sexit (nat_of_camlint n))))) + (Int32.pred n) + rem in + mkblocks (Sblock sw) (Int32.pred ncases) cases + +let mkmatch expr cases = + convert_accu := []; + let c = convert_rexpr expr in + let s = + match cases with + | [] -> Sskip (* ??? *) + | [key, action] -> action + | _ -> mkmatch_aux c cases in + prepend_seq !convert_accu s + +%} + +%token ABSF +%token AMPERSAND +%token AMPERSANDAMPERSAND +%token ALLOC +%token BANG +%token BANGEQUAL +%token BANGEQUALF +%token BANGEQUALU +%token BAR +%token BARBAR +%token CARET +%token CASE +%token COLON +%token COMMA +%token DEFAULT +%token DOLLAR +%token ELSE +%token EQUAL +%token EQUALEQUAL +%token EQUALEQUALF +%token EQUALEQUALU +%token EOF +%token EXIT +%token EXTERN +%token FLOAT +%token FLOAT32 +%token FLOAT64 +%token <float> FLOATLIT +%token FLOATOFINT +%token FLOATOFINTU +%token GREATER +%token GREATERF +%token GREATERU +%token GREATEREQUAL +%token GREATEREQUALF +%token GREATEREQUALU +%token GREATERGREATER +%token GREATERGREATERU +%token <AST.ident> IDENT +%token IF +%token IN +%token INT +%token INT16S +%token INT16U +%token INT32 +%token INT8S +%token INT8U +%token <int32> INTLIT +%token INTOFFLOAT +%token INTUOFFLOAT +%token LBRACE +%token LBRACELBRACE +%token LBRACKET +%token LESS +%token LESSU +%token LESSF +%token LESSEQUAL +%token LESSEQUALU +%token LESSEQUALF +%token LESSLESS +%token LET +%token LOOP +%token LPAREN +%token MATCH +%token MINUS +%token MINUSF +%token MINUSGREATER +%token PERCENT +%token PERCENTU +%token PLUS +%token PLUSF +%token QUESTION +%token RBRACE +%token RBRACERBRACE +%token RBRACKET +%token RETURN +%token RPAREN +%token SEMICOLON +%token SLASH +%token SLASHF +%token SLASHU +%token STACK +%token STAR +%token STARF +%token <AST.ident> STRINGLIT +%token SWITCH +%token TILDE +%token TAILCALL +%token VAR +%token VOID + +/* Precedences from low to high */ + +%left COMMA +%left p_let +%right EQUAL +%right QUESTION COLON +%left BARBAR +%left AMPERSANDAMPERSAND +%left BAR +%left CARET +%left AMPERSAND +%left EQUALEQUAL BANGEQUAL LESS LESSEQUAL GREATER GREATEREQUAL EQUALEQUALU BANGEQUALU LESSU LESSEQUALU GREATERU GREATEREQUALU EQUALEQUALF BANGEQUALF LESSF LESSEQUALF GREATERF GREATEREQUALF +%left LESSLESS GREATERGREATER GREATERGREATERU +%left PLUS PLUSF MINUS MINUSF +%left STAR SLASH PERCENT STARF SLASHF SLASHU PERCENTU +%nonassoc BANG TILDE p_uminus ABSF INTOFFLOAT INTUOFFLOAT FLOATOFINT FLOATOFINTU INT8S INT8U INT16S INT16U FLOAT32 ALLOC +%left LPAREN + +/* Entry point */ + +%start prog +%type <Cminor.program> prog + +%% + +/* Programs */ + +prog: + global_declarations proc_list EOF + { { prog_funct = CList.rev $2; + prog_main = intern_string "main"; + prog_vars = CList.rev $1; } } +; + +global_declarations: + /* empty */ { [] } + | global_declarations global_declaration { $2 :: $1 } +; + +global_declaration: + VAR STRINGLIT LBRACKET INTLIT RBRACKET + { Coq_pair(Coq_pair($2, [ Init_space (z_of_camlint $4) ]), ()) } +; + +proc_list: + /* empty */ { [] } + | proc_list proc { $2 :: $1 } +; + +/* Procedures */ + +proc: + STRINGLIT LPAREN parameters RPAREN COLON signature + LBRACE + stack_declaration + var_declarations + stmt_list + RBRACE + { let tmp = !temporaries in + temporaries := []; + temp_counter := 0; + Coq_pair($1, + Internal { fn_sig = $6; + fn_params = CList.rev $3; + fn_vars = CList.rev (CList.app tmp $9); + fn_stackspace = $8; + fn_body = $10 }) } + | EXTERN STRINGLIT COLON signature + { Coq_pair($2, + External { ef_id = $2; + ef_sig = $4 }) } +; + +signature: + type_ + { {sig_args = []; sig_res = Some $1} } + | VOID + { {sig_args = []; sig_res = None} } + | type_ MINUSGREATER signature + { let s = $3 in {s with sig_args = $1 :: s.sig_args} } +; + +parameters: + /* empty */ { [] } + | parameter_list { $1 } +; + +parameter_list: + IDENT { $1 :: [] } + | parameter_list COMMA IDENT { $3 :: $1 } +; + +stack_declaration: + /* empty */ { Z0 } + | STACK INTLIT SEMICOLON { z_of_camlint $2 } +; + +var_declarations: + /* empty */ { [] } + | var_declarations var_declaration { CList.app $2 $1 } +; + +var_declaration: + VAR parameter_list SEMICOLON { $2 } +; + +/* Statements */ + +stmt: + expr SEMICOLON { mkeval $1 } + | IDENT EQUAL expr SEMICOLON { mkassign $1 $3 } + | memory_chunk LBRACKET expr RBRACKET EQUAL expr SEMICOLON + { mkstore $1 $3 $6 } + | IF LPAREN expr RPAREN stmts ELSE stmts { mkifthenelse $3 $5 $7 } + | IF LPAREN expr RPAREN stmts { mkifthenelse $3 $5 Sskip } + | LOOP stmts { Sloop($2) } + | LBRACELBRACE stmt_list RBRACERBRACE { Sblock($2) } + | EXIT SEMICOLON { Sexit O } + | EXIT INTLIT SEMICOLON { Sexit (exitnum $2) } + | RETURN SEMICOLON { Sreturn None } + | RETURN expr SEMICOLON { mkreturn_some $2 } + | SWITCH LPAREN expr RPAREN LBRACE switch_cases RBRACE + { mkswitch $3 $6 } + | MATCH LPAREN expr RPAREN LBRACE match_cases RBRACE + { mkmatch $3 $6 } + | TAILCALL expr LPAREN expr_list RPAREN COLON signature SEMICOLON + { mktailcall $7 $2 $4 } +; + +stmts: + LBRACE stmt_list RBRACE { $2 } + | stmt { $1 } +; + +stmt_list: + /* empty */ { Sskip } + | stmt stmt_list { Sseq($1, $2) } +; + +switch_cases: + DEFAULT COLON EXIT INTLIT SEMICOLON + { ([], $4) } + | CASE INTLIT COLON EXIT INTLIT SEMICOLON switch_cases + { let (cases, dfl) = $7 in (($2, $5) :: cases, dfl) } +; + +match_cases: + /* empty */ { [] } + | CASE INTLIT COLON stmt_list match_cases { ($2, $4) :: $5 } +; + +/* Expressions */ + +expr: + LPAREN expr RPAREN { $2 } + | IDENT { Rvar $1 } + | INTLIT { intconst $1 } + | FLOATLIT { Rconst(Ofloatconst $1) } + | STRINGLIT { Rconst(Oaddrsymbol($1, Int.zero)) } + | AMPERSAND INTLIT { Rconst(Oaddrstack(coqint_of_camlint $2)) } + | MINUS expr %prec p_uminus { Rbinop(Osub, intconst 0l, $2) } /***FIXME***/ + | MINUSF expr %prec p_uminus { Runop(Onegf, $2) } + | ABSF expr { Runop(Oabsf, $2) } + | INTOFFLOAT expr { Runop(Ointoffloat, $2) } + | INTUOFFLOAT expr { Runop(Ointuoffloat, $2) } + | FLOATOFINT expr { Runop(Ofloatofint, $2) } + | FLOATOFINTU expr { Runop(Ofloatofintu, $2) } + | TILDE expr { Runop(Onotint, $2) } + | BANG expr { Runop(Onotbool, $2) } + | INT8S expr { Runop(Ocast8signed, $2) } + | INT8U expr { Runop(Ocast8unsigned, $2) } + | INT16S expr { Runop(Ocast16signed, $2) } + | INT16U expr { Runop(Ocast16unsigned, $2) } + | FLOAT32 expr { Runop(Osingleoffloat, $2) } + | expr PLUS expr { Rbinop(Oadd, $1, $3) } + | expr MINUS expr { Rbinop(Osub, $1, $3) } + | expr STAR expr { Rbinop(Omul, $1, $3) } + | expr SLASH expr { Rbinop(Odiv, $1, $3) } + | expr PERCENT expr { Rbinop(Omod, $1, $3) } + | expr SLASHU expr { Rbinop(Odivu, $1, $3) } + | expr PERCENTU expr { Rbinop(Omodu, $1, $3) } + | expr AMPERSAND expr { Rbinop(Oand, $1, $3) } + | expr BAR expr { Rbinop(Oor, $1, $3) } + | expr CARET expr { Rbinop(Oxor, $1, $3) } + | expr LESSLESS expr { Rbinop(Oshl, $1, $3) } + | expr GREATERGREATER expr { Rbinop(Oshr, $1, $3) } + | expr GREATERGREATERU expr { Rbinop(Oshru, $1, $3) } + | expr PLUSF expr { Rbinop(Oaddf, $1, $3) } + | expr MINUSF expr { Rbinop(Osubf, $1, $3) } + | expr STARF expr { Rbinop(Omulf, $1, $3) } + | expr SLASHF expr { Rbinop(Odivf, $1, $3) } + | expr EQUALEQUAL expr { Rbinop(Ocmp Ceq, $1, $3) } + | expr BANGEQUAL expr { Rbinop(Ocmp Cne, $1, $3) } + | expr LESS expr { Rbinop(Ocmp Clt, $1, $3) } + | expr LESSEQUAL expr { Rbinop(Ocmp Cle, $1, $3) } + | expr GREATER expr { Rbinop(Ocmp Cgt, $1, $3) } + | expr GREATEREQUAL expr { Rbinop(Ocmp Cge, $1, $3) } + | expr EQUALEQUALU expr { Rbinop(Ocmpu Ceq, $1, $3) } + | expr BANGEQUALU expr { Rbinop(Ocmpu Cne, $1, $3) } + | expr LESSU expr { Rbinop(Ocmpu Clt, $1, $3) } + | expr LESSEQUALU expr { Rbinop(Ocmpu Cle, $1, $3) } + | expr GREATERU expr { Rbinop(Ocmpu Cgt, $1, $3) } + | expr GREATEREQUALU expr { Rbinop(Ocmpu Cge, $1, $3) } + | expr EQUALEQUALF expr { Rbinop(Ocmpf Ceq, $1, $3) } + | expr BANGEQUALF expr { Rbinop(Ocmpf Cne, $1, $3) } + | expr LESSF expr { Rbinop(Ocmpf Clt, $1, $3) } + | expr LESSEQUALF expr { Rbinop(Ocmpf Cle, $1, $3) } + | expr GREATERF expr { Rbinop(Ocmpf Cgt, $1, $3) } + | expr GREATEREQUALF expr { Rbinop(Ocmpf Cge, $1, $3) } + | memory_chunk LBRACKET expr RBRACKET { Rload($1, $3) } + | expr AMPERSANDAMPERSAND expr { andbool $1 $3 } + | expr BARBAR expr { orbool $1 $3 } + | expr QUESTION expr COLON expr { Rcondition($1, $3, $5) } + | expr LPAREN expr_list RPAREN COLON signature{ Rcall($6, $1, $3) } + | ALLOC expr { Ralloc $2 } +; + +expr_list: + /* empty */ { [] } + | expr_list_1 { $1 } +; + +expr_list_1: + expr %prec COMMA { $1 :: [] } + | expr COMMA expr_list_1 { $1 :: $3 } +; + +memory_chunk: + INT8S { Mint8signed } + | INT8U { Mint8unsigned } + | INT16S { Mint16signed } + | INT16U { Mint16unsigned } + | INT32 { Mint32 } + | INT { Mint32 } + | FLOAT32 { Mfloat32 } + | FLOAT64 { Mfloat64 } + | FLOAT { Mfloat64 } +; + +/* Types */ + +type_: + INT { Tint } + | FLOAT { Tfloat } +; diff --git a/backend/CMtypecheck.ml b/backend/CMtypecheck.ml new file mode 100644 index 00000000..d761f759 --- /dev/null +++ b/backend/CMtypecheck.ml @@ -0,0 +1,370 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* A type-checker for Cminor *) + +open Printf +open Datatypes +open CList +open Camlcoq +open AST +open Integers +open Cminor + +exception Error of string + +let name_of_typ = function Tint -> "int" | Tfloat -> "float" + +type ty = Base of typ | Var of ty option ref + +let newvar () = Var (ref None) +let tint = Base Tint +let tfloat = Base Tfloat + +let ty_of_typ = function Tint -> tint | Tfloat -> tfloat + +let ty_of_sig_args tyl = List.map ty_of_typ tyl + +let rec repr t = + match t with + | Base _ -> t + | Var r -> match !r with None -> t | Some t' -> repr t' + +let unify t1 t2 = + match (repr t1, repr t2) with + | Base b1, Base b2 -> + if b1 <> b2 then + raise (Error (sprintf "Expected type %s, actual type %s\n" + (name_of_typ b1) (name_of_typ b2))) + | Base b, Var r -> r := Some (Base b) + | Var r, Base b -> r := Some (Base b) + | Var r1, Var r2 -> r1 := Some (Var r2) + +let unify_list l1 l2 = + let ll1 = List.length l1 and ll2 = List.length l2 in + if ll1 <> ll2 then + raise (Error (sprintf "Arity mismatch: expected %d, actual %d\n" ll1 ll2)); + List.iter2 unify l1 l2 + +let type_var env id = + try + List.assoc id env + with Not_found -> + raise (Error (sprintf "Unbound variable %s\n" (extern_atom id))) + +let type_letvar env n = + let n = camlint_of_nat n in + try + List.nth env n + with Not_found -> + raise (Error (sprintf "Unbound let variable #%d\n" n)) + +let name_of_comparison = function + | Ceq -> "eq" + | Cne -> "ne" + | Clt -> "lt" + | Cle -> "le" + | Cgt -> "gt" + | Cge -> "ge" + +let type_constant = function + | Ointconst _ -> tint + | Ofloatconst _ -> tfloat + | Oaddrsymbol _ -> tint + | Oaddrstack _ -> tint + +let type_unary_operation = function + | Ocast8signed -> tint, tint + | Ocast16signed -> tint, tint + | Ocast8unsigned -> tint, tint + | Ocast16unsigned -> tint, tint + | Onegint -> tint, tint + | Onotbool -> tint, tint + | Onotint -> tint, tint + | Onegf -> tfloat, tfloat + | Oabsf -> tfloat, tfloat + | Osingleoffloat -> tfloat, tfloat + | Ointoffloat -> tfloat, tint + | Ointuoffloat -> tfloat, tint + | Ofloatofint -> tint, tfloat + | Ofloatofintu -> tint, tfloat + +let type_binary_operation = function + | Oadd -> tint, tint, tint + | Osub -> tint, tint, tint + | Omul -> tint, tint, tint + | Odiv -> tint, tint, tint + | Odivu -> tint, tint, tint + | Omod -> tint, tint, tint + | Omodu -> tint, tint, tint + | Oand -> tint, tint, tint + | Oor -> tint, tint, tint + | Oxor -> tint, tint, tint + | Oshl -> tint, tint, tint + | Oshr -> tint, tint, tint + | Oshru -> tint, tint, tint + | Oaddf -> tfloat, tfloat, tfloat + | Osubf -> tfloat, tfloat, tfloat + | Omulf -> tfloat, tfloat, tfloat + | Odivf -> tfloat, tfloat, tfloat + | Ocmp _ -> tint, tint, tint + | Ocmpu _ -> tint, tint, tint + | Ocmpf _ -> tfloat, tfloat, tint + +let name_of_constant = function + | Ointconst n -> sprintf "intconst %ld" (camlint_of_coqint n) + | Ofloatconst n -> sprintf "floatconst %g" n + | Oaddrsymbol (s, ofs) -> sprintf "addrsymbol %s %ld" (extern_atom s) (camlint_of_coqint ofs) + | Oaddrstack n -> sprintf "addrstack %ld" (camlint_of_coqint n) + +let name_of_unary_operation = function + | Ocast8signed -> "cast8signed" + | Ocast16signed -> "cast16signed" + | Ocast8unsigned -> "cast8unsigned" + | Ocast16unsigned -> "cast16unsigned" + | Onegint -> "negint" + | Onotbool -> "notbool" + | Onotint -> "notint" + | Onegf -> "negf" + | Oabsf -> "absf" + | Osingleoffloat -> "singleoffloat" + | Ointoffloat -> "intoffloat" + | Ointuoffloat -> "intuoffloat" + | Ofloatofint -> "floatofint" + | Ofloatofintu -> "floatofintu" + +let name_of_binary_operation = function + | Oadd -> "add" + | Osub -> "sub" + | Omul -> "mul" + | Odiv -> "div" + | Odivu -> "divu" + | Omod -> "mod" + | Omodu -> "modu" + | Oand -> "and" + | Oor -> "or" + | Oxor -> "xor" + | Oshl -> "shl" + | Oshr -> "shr" + | Oshru -> "shru" + | Oaddf -> "addf" + | Osubf -> "subf" + | Omulf -> "mulf" + | Odivf -> "divf" + | Ocmp c -> sprintf "cmp %s" (name_of_comparison c) + | Ocmpu c -> sprintf "cmpu %s" (name_of_comparison c) + | Ocmpf c -> sprintf "cmpf %s" (name_of_comparison c) + +let type_chunk = function + | Mint8signed -> tint + | Mint8unsigned -> tint + | Mint16signed -> tint + | Mint16unsigned -> tint + | Mint32 -> tint + | Mfloat32 -> tfloat + | Mfloat64 -> tfloat + +let name_of_chunk = function + | Mint8signed -> "int8signed" + | Mint8unsigned -> "int8unsigned" + | Mint16signed -> "int16signed" + | Mint16unsigned -> "int16unsigned" + | Mint32 -> "int32" + | Mfloat32 -> "float32" + | Mfloat64 -> "float64" + +let rec type_expr env lenv e = + match e with + | Evar id -> + type_var env id + | Econst cst -> + type_constant cst + | Eunop(op, e1) -> + let te1 = type_expr env lenv e1 in + let (targ, tres) = type_unary_operation op in + begin try + unify targ te1 + with Error s -> + raise (Error (sprintf "In application of operator %s:\n%s" + (name_of_unary_operation op) s)) + end; + tres + | Ebinop(op, e1, e2) -> + let te1 = type_expr env lenv e1 in + let te2 = type_expr env lenv e2 in + let (targ1, targ2, tres) = type_binary_operation op in + begin try + unify targ1 te1; unify targ2 te2 + with Error s -> + raise (Error (sprintf "In application of operator %s:\n%s" + (name_of_binary_operation op) s)) + end; + tres + | Eload(chunk, e) -> + let te = type_expr env lenv e in + begin try + unify tint te + with Error s -> + raise (Error (sprintf "In load %s:\n%s" + (name_of_chunk chunk) s)) + end; + type_chunk chunk + | Econdition(e1, e2, e3) -> + type_condexpr env lenv e1; + let te2 = type_expr env lenv e2 in + let te3 = type_expr env lenv e3 in + begin try + unify te2 te3 + with Error s -> + raise (Error (sprintf "In conditional expression:\n%s" s)) + end; + te2 +(* + | Elet(e1, e2) -> + let te1 = type_expr env lenv e1 in + let te2 = type_expr env (te1 :: lenv) e2 in + te2 + | Eletvar n -> + type_letvar lenv n +*) + +and type_exprlist env lenv el = + match el with + | [] -> [] + | e1 :: et -> + let te1 = type_expr env lenv e1 in + let tet = type_exprlist env lenv et in + (te1 :: tet) + +and type_condexpr env lenv e = + let te = type_expr env lenv e in + begin try + unify tint te + with Error s -> + raise (Error (sprintf "In condition:\n%s" s)) + end + +let rec type_stmt env blk ret s = + match s with + | Sskip -> () + | Sassign(id, e1) -> + let tid = type_var env id in + let te1 = type_expr env [] e1 in + begin try + unify tid te1 + with Error s -> + raise (Error (sprintf "In assignment to %s:\n%s" (extern_atom id) s)) + end + | Sstore(chunk, e1, e2) -> + let te1 = type_expr env [] e1 in + let te2 = type_expr env [] e2 in + begin try + unify tint te1; + unify (type_chunk chunk) te2 + with Error s -> + raise (Error (sprintf "In store %s:\n%s" + (name_of_chunk chunk) s)) + end + | Scall(optid, sg, e1, el) -> + let te1 = type_expr env [] e1 in + let tel = type_exprlist env [] el in + begin try + unify tint te1; + unify_list (ty_of_sig_args sg.sig_args) tel; + let ty_res = + match sg.sig_res with + | None -> tint (*???*) + | Some t -> ty_of_typ t in + begin match optid with + | None -> () + | Some id -> unify (type_var env id) ty_res + end + with Error s -> + raise (Error (sprintf "In call:\n%s" s)) + end + | Salloc(id, e) -> + let tid = type_var env id in + let te = type_expr env [] e in + begin try + unify tint te; + unify tint tid + with Error s -> + raise (Error (sprintf "In alloc:\n%s" s)) + end + | Sseq(s1, s2) -> + type_stmt env blk ret s1; + type_stmt env blk ret s2 + | Sifthenelse(ce, s1, s2) -> + type_condexpr env [] ce; + type_stmt env blk ret s1; + type_stmt env blk ret s2 + | Sloop s1 -> + type_stmt env blk ret s1 + | Sblock s1 -> + type_stmt env (blk + 1) ret s1 + | Sexit n -> + if camlint_of_nat n >= blk then + raise (Error (sprintf "Bad exit(%d)\n" (camlint_of_nat n))) + | Sswitch(e, cases, deflt) -> + unify (type_expr env [] e) tint + | Sreturn None -> + begin match ret with + | None -> () + | Some tret -> raise (Error ("return without argument")) + end + | Sreturn (Some e) -> + begin match ret with + | None -> raise (Error "return with argument") + | Some tret -> + begin try + unify (type_expr env [] e) (ty_of_typ tret) + with Error s -> + raise (Error (sprintf "In return:\n%s" s)) + end + end + | Stailcall(sg, e1, el) -> + let te1 = type_expr env [] e1 in + let tel = type_exprlist env [] el in + begin try + unify tint te1; + unify_list (ty_of_sig_args sg.sig_args) tel + with Error s -> + raise (Error (sprintf "In tail call:\n%s" s)) + end + | Slabel(lbl, s1) -> + type_stmt env blk ret s1 + | Sgoto lbl -> + () + +let rec env_of_vars idl = + match idl with + | [] -> [] + | id1 :: idt -> (id1, newvar()) :: env_of_vars idt + +let type_function id f = + try + type_stmt + (env_of_vars f.fn_vars @ env_of_vars f.fn_params) + 0 f.fn_sig.sig_res f.fn_body + with Error s -> + raise (Error (sprintf "In function %s:\n%s" (extern_atom id) s)) + +let type_fundef (Coq_pair (id, fd)) = + match fd with + | Internal f -> type_function id f + | External ef -> () + +let type_program p = + List.iter type_fundef p.prog_funct; p diff --git a/backend/CMtypecheck.mli b/backend/CMtypecheck.mli new file mode 100644 index 00000000..44c76544 --- /dev/null +++ b/backend/CMtypecheck.mli @@ -0,0 +1,19 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +exception Error of string + +val type_program: Cminor.program -> Cminor.program + diff --git a/backend/CSE.v b/backend/CSE.v index b7e19c1b..49b84899 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -72,12 +72,9 @@ Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}. Proof. generalize Int.eq_dec; intro. generalize Float.eq_dec; intro. - assert (forall (x y: ident), {x=y}+{x<>y}). exact peq. - assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. - assert (forall (x y: condition), {x=y}+{x<>y}). decide equality. - assert (forall (x y: operation), {x=y}+{x<>y}). decide equality. + generalize eq_operation; intro. + generalize eq_addressing; intro. assert (forall (x y: memory_chunk), {x=y}+{x<>y}). decide equality. - assert (forall (x y: addressing), {x=y}+{x<>y}). decide equality. generalize eq_valnum; intro. generalize eq_list_valnum; intro. decide equality. diff --git a/backend/Coloringaux.ml b/backend/Coloringaux.ml new file mode 100644 index 00000000..19efe434 --- /dev/null +++ b/backend/Coloringaux.ml @@ -0,0 +1,626 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Camlcoq +open Datatypes +open BinPos +open BinInt +open AST +open Maps +open Registers +open Machregs +open Locations +open RTL +open RTLtyping +open InterfGraph +open Conventions + +(* George-Appel graph coloring *) + +(* \subsection{Internal representation of the interference graph} *) + +(* To implement George-Appel coloring, we first transform the representation + of the interference graph, switching to the following + imperative representation that is well suited to the coloring algorithm. *) + +(* Each node of the graph (i.e. each pseudo-register) is represented as + follows. *) + +type node = + { ident: reg; (*r register identifier *) + typ: typ; (*r its type *) + regclass: int; (*r identifier of register class *) + spillcost: float; (*r estimated cost of spilling *) + mutable adjlist: node list; (*r all nodes it interferes with *) + mutable degree: int; (*r number of adjacent nodes *) + mutable movelist: move list; (*r list of moves it is involved in *) + mutable alias: node option; (*r [Some n] if coalesced with [n] *) + mutable color: loc option; (*r chosen color *) + mutable nstate: nodestate; (*r in which set of nodes it is *) + mutable nprev: node; (*r for double linking *) + mutable nnext: node (*r for double linking *) + } + +(* These are the possible states for nodes. *) + +and nodestate = + | Colored + | Initial + | SimplifyWorklist + | FreezeWorklist + | SpillWorklist + | CoalescedNodes + | SelectStack + +(* Each move (i.e. wish to be put in the same location) is represented + as follows. *) + +and move = + { src: node; (*r source of the move *) + dst: node; (*r destination of the move *) + mutable mstate: movestate; (*r in which set of moves it is *) + mutable mprev: move; (*r for double linking *) + mutable mnext: move (*r for double linking *) + } + +(* These are the possible states for moves *) + +and movestate = + | CoalescedMoves + | ConstrainedMoves + | FrozenMoves + | WorklistMoves + | ActiveMoves + +(* The algorithm manipulates partitions of the nodes and of the moves + according to their states, frequently moving a node or a move from + a state to another, and frequently enumerating all nodes or all moves + of a given state. To support these operations efficiently, + nodes or moves having the same state are put into imperative doubly-linked + lists, allowing for constant-time insertion and removal, and linear-time + scanning. We now define the operations over these doubly-linked lists. *) + +module DLinkNode = struct + type t = node + let make state = + let rec empty = + { ident = Coq_xH; typ = Tint; regclass = 0; + adjlist = []; degree = 0; spillcost = 0.0; + movelist = []; alias = None; color = None; + nstate = state; nprev = empty; nnext = empty } + in empty + let dummy = make Colored + let clear dl = dl.nnext <- dl; dl.nprev <- dl + let notempty dl = dl.nnext != dl + let insert n dl = + n.nstate <- dl.nstate; + n.nnext <- dl.nnext; n.nprev <- dl; + dl.nnext.nprev <- n; dl.nnext <- n + let remove n dl = + assert (n.nstate = dl.nstate); + n.nnext.nprev <- n.nprev; n.nprev.nnext <- n.nnext + let move n dl1 dl2 = + remove n dl1; insert n dl2 + let pick dl = + let n = dl.nnext in remove n dl; n + let iter f dl = + let rec iter n = if n != dl then (f n; iter n.nnext) + in iter dl.nnext + let fold f dl accu = + let rec fold n accu = if n == dl then accu else fold n.nnext (f n accu) + in fold dl.nnext accu +end + +module DLinkMove = struct + type t = move + let make state = + let rec empty = + { src = DLinkNode.dummy; dst = DLinkNode.dummy; + mstate = state; mprev = empty; mnext = empty } + in empty + let dummy = make CoalescedMoves + let clear dl = dl.mnext <- dl; dl.mprev <- dl + let notempty dl = dl.mnext != dl + let insert m dl = + m.mstate <- dl.mstate; + m.mnext <- dl.mnext; m.mprev <- dl; + dl.mnext.mprev <- m; dl.mnext <- m + let remove m dl = + assert (m.mstate = dl.mstate); + m.mnext.mprev <- m.mprev; m.mprev.mnext <- m.mnext + let move m dl1 dl2 = + remove m dl1; insert m dl2 + let pick dl = + let m = dl.mnext in remove m dl; m + let iter f dl = + let rec iter m = if m != dl then (f m; iter m.mnext) + in iter dl.mnext + let fold f dl accu = + let rec fold m accu = if m == dl then accu else fold m.mnext (f m accu) + in fold dl.mnext accu +end + +(* \subsection{The George-Appel algorithm} *) + +(* Below is a straigthforward translation of the pseudo-code at the end + of the TOPLAS article by George and Appel. Two bugs were fixed + and are marked as such. Please refer to the article for explanations. *) + +(* Low-degree, non-move-related nodes *) +let simplifyWorklist = DLinkNode.make SimplifyWorklist + +(* Low-degree, move-related nodes *) +let freezeWorklist = DLinkNode.make FreezeWorklist + +(* High-degree nodes *) +let spillWorklist = DLinkNode.make SpillWorklist + +(* Nodes that have been coalesced *) +let coalescedNodes = DLinkNode.make CoalescedNodes + +(* Moves that have been coalesced *) +let coalescedMoves = DLinkMove.make CoalescedMoves + +(* Moves whose source and destination interfere *) +let constrainedMoves = DLinkMove.make ConstrainedMoves + +(* Moves that will no longer be considered for coalescing *) +let frozenMoves = DLinkMove.make FrozenMoves + +(* Moves enabled for possible coalescing *) +let worklistMoves = DLinkMove.make WorklistMoves + +(* Moves not yet ready for coalescing *) +let activeMoves = DLinkMove.make ActiveMoves + +(* Initialization of all global data structures *) + +let init() = + DLinkNode.clear simplifyWorklist; + DLinkNode.clear freezeWorklist; + DLinkNode.clear spillWorklist; + DLinkNode.clear coalescedNodes; + DLinkMove.clear coalescedMoves; + DLinkMove.clear frozenMoves; + DLinkMove.clear worklistMoves; + DLinkMove.clear activeMoves + +(* Determine if two nodes interfere *) + +let interfere n1 n2 = + if n1.degree < n2.degree + then List.memq n2 n1.adjlist + else List.memq n1 n2.adjlist + +(* Add an edge to the graph. Assume edge is not in graph already *) + +let addEdge n1 n2 = + n1.adjlist <- n2 :: n1.adjlist; + n1.degree <- 1 + n1.degree; + n2.adjlist <- n1 :: n2.adjlist; + n2.degree <- 1 + n2.degree + +(* Apply the given function to the relevant adjacent nodes of a node *) + +let iterAdjacent f n = + List.iter + (fun n -> + match n.nstate with + | SelectStack | CoalescedNodes -> () + | _ -> f n) + n.adjlist + +(* Determine the moves affecting a node *) + +let moveIsActiveOrWorklist m = + match m.mstate with + | ActiveMoves | WorklistMoves -> true + | _ -> false + +let nodeMoves n = + List.filter moveIsActiveOrWorklist n.movelist + +(* Determine whether a node is involved in a move *) + +let moveRelated n = + List.exists moveIsActiveOrWorklist n.movelist + +(*i +(* Check invariants *) + +let degreeInvariant n = + let c = ref 0 in + iterAdjacent (fun n -> incr c) n; + if !c <> n.degree then + fatal_error("degree invariant violated by " ^ name_of_node n) + +let simplifyWorklistInvariant n = + if n.degree < num_available_registers.(n.regclass) + && not (moveRelated n) + then () + else fatal_error("simplify worklist invariant violated by " ^ name_of_node n) + +let freezeWorklistInvariant n = + if n.degree < num_available_registers.(n.regclass) + && moveRelated n + then () + else fatal_error("freeze worklist invariant violated by " ^ name_of_node n) + +let spillWorklistInvariant n = + if n.degree >= num_available_registers.(n.regclass) + then () + else fatal_error("spill worklist invariant violated by " ^ name_of_node n) + +let checkInvariants () = + DLinkNode.iter + (fun n -> degreeInvariant n; simplifyWorklistInvariant n) + simplifyWorklist; + DLinkNode.iter + (fun n -> degreeInvariant n; freezeWorklistInvariant n) + freezeWorklist; + DLinkNode.iter + (fun n -> degreeInvariant n; spillWorklistInvariant n) + spillWorklist +i*) + +(* Register classes *) + +let class_of_type = function Tint -> 0 | Tfloat -> 1 + +let num_register_classes = 2 + +let caller_save_registers = [| + Array.of_list Conventions.int_caller_save_regs; + Array.of_list Conventions.float_caller_save_regs +|] + +let callee_save_registers = [| + Array.of_list Conventions.int_callee_save_regs; + Array.of_list Conventions.float_callee_save_regs +|] + +let num_available_registers = + [| Array.length caller_save_registers.(0) + + Array.length callee_save_registers.(0); + Array.length caller_save_registers.(1) + + Array.length callee_save_registers.(1) |] + +(* Build the internal representation of the graph *) + +let nodeOfReg r typenv spillcosts = + let ty = typenv r in + { ident = r; typ = ty; regclass = class_of_type ty; + spillcost = (try float(Hashtbl.find spillcosts r) with Not_found -> 0.0); + adjlist = []; degree = 0; movelist = []; alias = None; + color = None; + nstate = Initial; + nprev = DLinkNode.dummy; nnext = DLinkNode.dummy } + +let nodeOfMreg mr = + let ty = mreg_type mr in + { ident = Coq_xH; typ = ty; regclass = class_of_type ty; + spillcost = 0.0; + adjlist = []; degree = 0; movelist = []; alias = None; + color = Some (R mr); + nstate = Colored; + nprev = DLinkNode.dummy; nnext = DLinkNode.dummy } + +let build g typenv spillcosts = + (* Associate an internal node to each pseudo-register and each location *) + let reg_mapping = Hashtbl.create 27 + and mreg_mapping = Hashtbl.create 27 in + let find_reg_node r = + try + Hashtbl.find reg_mapping r + with Not_found -> + let n = nodeOfReg r typenv spillcosts in + Hashtbl.add reg_mapping r n; + n + and find_mreg_node mr = + try + Hashtbl.find mreg_mapping mr + with Not_found -> + let n = nodeOfMreg mr in + Hashtbl.add mreg_mapping mr n; + n in + (* Fill the adjacency lists and compute the degrees. *) + SetRegReg.fold + (fun (Coq_pair(r1, r2)) () -> + addEdge (find_reg_node r1) (find_reg_node r2)) + g.interf_reg_reg (); + SetRegMreg.fold + (fun (Coq_pair(r1, mr2)) () -> + addEdge (find_reg_node r1) (find_mreg_node mr2)) + g.interf_reg_mreg (); + (* Process the moves and insert them in worklistMoves *) + let add_move n1 n2 = + let m = + { src = n1; dst = n2; mstate = WorklistMoves; + mnext = DLinkMove.dummy; mprev = DLinkMove.dummy } in + n1.movelist <- m :: n1.movelist; + n2.movelist <- m :: n2.movelist; + DLinkMove.insert m worklistMoves in + SetRegReg.fold + (fun (Coq_pair(r1, r2)) () -> + add_move (find_reg_node r1) (find_reg_node r2)) + g.pref_reg_reg (); + SetRegMreg.fold + (fun (Coq_pair(r1, mr2)) () -> + add_move (find_reg_node r1) (find_mreg_node mr2)) + g.pref_reg_mreg (); + (* Initial partition of nodes into spill / freeze / simplify *) + Hashtbl.iter + (fun r n -> + assert (n.nstate = Initial); + let k = num_available_registers.(n.regclass) in + if n.degree >= k then + DLinkNode.insert n spillWorklist + else if moveRelated n then + DLinkNode.insert n freezeWorklist + else + DLinkNode.insert n simplifyWorklist) + reg_mapping; + reg_mapping + +(* Enable moves that have become low-degree related *) + +let enableMoves n = + List.iter + (fun m -> + if m.mstate = ActiveMoves + then DLinkMove.move m activeMoves worklistMoves) + (nodeMoves n) + +(* Simulate the removal of a node from the graph *) + +let decrementDegree n = + let k = num_available_registers.(n.regclass) in + let d = n.degree in + n.degree <- d - 1; + if d = k then begin + enableMoves n; + iterAdjacent enableMoves n; + if n.nstate <> Colored then begin + if moveRelated n + then DLinkNode.move n spillWorklist freezeWorklist + else DLinkNode.move n spillWorklist simplifyWorklist + end + end + +(* Simulate the effect of combining nodes [n1] and [n3] on [n2], + where [n2] is a node adjacent to [n3]. *) + +let combineEdge n1 n2 = + assert (n1 != n2); + if interfere n1 n2 then begin + decrementDegree n2 + end else begin + n1.adjlist <- n2 :: n1.adjlist; + n2.adjlist <- n1 :: n2.adjlist; + n1.degree <- n1.degree + 1 + end + +(* Simplification of a low-degree node *) + +let simplify () = + let n = DLinkNode.pick simplifyWorklist in + (*i Printf.printf "Simplifying %s\n" (name_of_node n); i*) + n.nstate <- SelectStack; + iterAdjacent decrementDegree n; + n + +(* Briggs' conservative coalescing criterion *) + +let canConservativelyCoalesce n1 n2 = + let seen = ref Regset.empty in + let k = num_available_registers.(n1.regclass) in + let c = ref 0 in + let consider n = + if not (Regset.mem n.ident !seen) then begin + seen := Regset.add n.ident !seen; + if n.degree >= k then incr c + end in + iterAdjacent consider n1; + iterAdjacent consider n2; + !c < k + +(* Update worklists after a move was processed *) + +let addWorkList u = + if (not (u.nstate = Colored)) + && u.degree < num_available_registers.(u.regclass) + && (not (moveRelated u)) + then DLinkNode.move u freezeWorklist simplifyWorklist + +(* Return the canonical representative of a possibly coalesced node *) + +let rec getAlias n = + match n.alias with None -> n | Some n' -> getAlias n' + +(* Combine two nodes *) + +let combine u v = + (*i Printf.printf "Combining %s and %s\n" (name_of_node u) (name_of_node v); i*) + if v.nstate = FreezeWorklist + then DLinkNode.move v freezeWorklist coalescedNodes + else DLinkNode.move v spillWorklist coalescedNodes; + v.alias <- Some u; + u.movelist <- u.movelist @ v.movelist; + iterAdjacent (combineEdge u) v; (*r original code using [decrementDegree] is buggy *) + enableMoves v; (*r added as per Appel's book erratum *) + if u.degree >= num_available_registers.(u.regclass) + && u.nstate = FreezeWorklist + then DLinkNode.move u freezeWorklist spillWorklist + +(* Attempt coalescing *) + +let coalesce () = + let m = DLinkMove.pick worklistMoves in + let x = getAlias m.src and y = getAlias m.dst in + let (u, v) = if y.nstate = Colored then (y, x) else (x, y) in + if u == v then begin + DLinkMove.insert m coalescedMoves; + addWorkList u + end else if v.nstate = Colored || interfere u v then begin + DLinkMove.insert m constrainedMoves; + addWorkList u; + addWorkList v + end else if canConservativelyCoalesce u v then begin + DLinkMove.insert m coalescedMoves; + combine u v; + addWorkList u + end else begin + DLinkMove.insert m activeMoves + end + +(* Freeze moves associated with node [u] *) + +let freezeMoves u = + let au = getAlias u in + let freeze m = + let y = getAlias m.src in + let v = if y == au then getAlias m.dst else y in + DLinkMove.move m activeMoves frozenMoves; + if not (moveRelated v) + && v.degree < num_available_registers.(v.regclass) + && v.nstate <> Colored + then DLinkNode.move v freezeWorklist simplifyWorklist in + List.iter freeze (nodeMoves u) + +(* Pick a move and freeze it *) + +let freeze () = + let u = DLinkNode.pick freezeWorklist in + (*i Printf.printf "Freezing %s\n" (name_of_node u); i*) + DLinkNode.insert u simplifyWorklist; + freezeMoves u + +(* Chaitin's cost measure *) + +let spillCost n = n.spillcost /. float n.degree + +(* Spill a node *) + +let selectSpill () = + (* Find a spillable node of minimal cost *) + let (n, cost) = + DLinkNode.fold + (fun n (best_node, best_cost as best) -> + let cost = spillCost n in + if cost < best_cost then (n, cost) else best) + spillWorklist (DLinkNode.dummy, infinity) in + assert (n != DLinkNode.dummy); + DLinkNode.remove n spillWorklist; + (*i Printf.printf "Spilling %s\n" (name_of_node n); i*) + freezeMoves n; + n.nstate <- SelectStack; + iterAdjacent decrementDegree n; + n + +(* Produce the order of nodes that we'll use for coloring *) + +let rec nodeOrder stack = + (*i checkInvariants(); i*) + if DLinkNode.notempty simplifyWorklist then + (let n = simplify() in nodeOrder (n :: stack)) + else if DLinkMove.notempty worklistMoves then + (coalesce(); nodeOrder stack) + else if DLinkNode.notempty freezeWorklist then + (freeze(); nodeOrder stack) + else if DLinkNode.notempty spillWorklist then + (let n = selectSpill() in nodeOrder (n :: stack)) + else + stack + +(* Assign a color (i.e. a hardware register or a stack location) + to a node. The color is chosen among the colors that are not + assigned to nodes with which this node interferes. The choice + is guided by the following heuristics: consider first caller-save + hardware register of the correct type; second, callee-save registers; + third, a stack location. Callee-save registers and stack locations + are ``expensive'' resources, so we try to minimize their number + by picking the smallest available callee-save register or stack location. + In contrast, caller-save registers are ``free'', so we pick an + available one pseudo-randomly. *) + +module Locset = + Set.Make(struct type t = loc let compare = compare end) + +let start_points = Array.make num_register_classes 0 + +let find_reg conflicts regclass = + let rec find avail curr last = + if curr >= last then None else begin + let l = R avail.(curr) in + if Locset.mem l conflicts + then find avail (curr + 1) last + else Some l + end in + let caller_save = caller_save_registers.(regclass) + and callee_save = callee_save_registers.(regclass) + and start = start_points.(regclass) in + match find caller_save start (Array.length caller_save) with + | Some _ as res -> + start_points.(regclass) <- + (if start + 1 < Array.length caller_save then start + 1 else 0); + res + | None -> + match find caller_save 0 start with + | Some _ as res -> + start_points.(regclass) <- + (if start + 1 < Array.length caller_save then start + 1 else 0); + res + | None -> + find callee_save 0 (Array.length callee_save) + +let find_slot conflicts typ = + let rec find curr = + let l = S(Local(curr, typ)) in + if Locset.mem l conflicts then find (coq_Zsucc curr) else l + in find Z0 + +let assign_color n = + let conflicts = ref Locset.empty in + List.iter + (fun n' -> + match (getAlias n').color with + | None -> () + | Some l -> conflicts := Locset.add l !conflicts) + n.adjlist; + match find_reg !conflicts n.regclass with + | Some loc -> + n.color <- Some loc + | None -> + n.color <- Some (find_slot !conflicts n.typ) + +(* Extract the location of a node *) + +let location_of_node n = + match n.color with + | None -> assert false + | Some loc -> loc + +(* Estimate spilling costs - TODO *) + +let spill_costs f = Hashtbl.create 7 + +(* This is the entry point for graph coloring. *) + +let graph_coloring (f: coq_function) (g: graph) (env: regenv) (regs: Regset.t) + : (reg -> loc) = + init(); + Array.fill start_points 0 num_register_classes 0; + let mapping = build g env (spill_costs f) in + List.iter assign_color (nodeOrder []); + fun r -> + try location_of_node (getAlias (Hashtbl.find mapping r)) + with Not_found -> R IT1 (* any location *) diff --git a/backend/Coloringaux.mli b/backend/Coloringaux.mli new file mode 100644 index 00000000..c5070f20 --- /dev/null +++ b/backend/Coloringaux.mli @@ -0,0 +1,20 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Registers +open Locations +open RTL +open RTLtyping +open InterfGraph + +val graph_coloring: + coq_function -> graph -> regenv -> Regset.t -> (reg -> loc) diff --git a/backend/Constprop.v b/backend/Constprop.v deleted file mode 100644 index 75fb1486..00000000 --- a/backend/Constprop.v +++ /dev/null @@ -1,1093 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Constant propagation over RTL. This is the first of the two - optimizations performed at RTL level. It proceeds by a standard - dataflow analysis and the corresponding code transformation. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Globalenvs. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Lattice. -Require Import Kildall. - -(** * Static analysis *) - -(** To each pseudo-register at each program point, the static analysis - associates a compile-time approximation taken from the following set. *) - -Inductive approx : Set := - | Novalue: approx (** No value possible, code is unreachable. *) - | Unknown: approx (** All values are possible, - no compile-time information is available. *) - | I: int -> approx (** A known integer value. *) - | F: float -> approx (** A known floating-point value. *) - | S: ident -> int -> approx. - (** The value is the address of the given global - symbol plus the given integer offset. *) - -(** We equip this set of approximations with a semi-lattice structure. - The ordering is inclusion between the sets of values denoted by - the approximations. *) - -Module Approx <: SEMILATTICE_WITH_TOP. - Definition t := approx. - Definition eq (x y: t) := (x = y). - Definition eq_refl: forall x, eq x x := (@refl_equal t). - Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t). - Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t). - Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}. - Proof. - decide equality. - apply Int.eq_dec. - apply Float.eq_dec. - apply Int.eq_dec. - apply ident_eq. - Qed. - Definition beq (x y: t) := if eq_dec x y then true else false. - Lemma beq_correct: forall x y, beq x y = true -> x = y. - Proof. - unfold beq; intros. destruct (eq_dec x y). auto. congruence. - Qed. - Definition ge (x y: t) : Prop := - x = Unknown \/ y = Novalue \/ x = y. - Lemma ge_refl: forall x y, eq x y -> ge x y. - Proof. - unfold eq, ge; tauto. - Qed. - Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. - Proof. - unfold ge; intuition congruence. - Qed. - Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'. - Proof. - unfold eq, ge; intros; congruence. - Qed. - Definition bot := Novalue. - Definition top := Unknown. - Lemma ge_bot: forall x, ge x bot. - Proof. - unfold ge, bot; tauto. - Qed. - Lemma ge_top: forall x, ge top x. - Proof. - unfold ge, bot; tauto. - Qed. - Definition lub (x y: t) : t := - if eq_dec x y then x else - match x, y with - | Novalue, _ => y - | _, Novalue => x - | _, _ => Unknown - end. - Lemma lub_commut: forall x y, eq (lub x y) (lub y x). - Proof. - unfold lub, eq; intros. - case (eq_dec x y); case (eq_dec y x); intros; try congruence. - destruct x; destruct y; auto. - Qed. - Lemma ge_lub_left: forall x y, ge (lub x y) x. - Proof. - unfold lub; intros. - case (eq_dec x y); intro. - apply ge_refl. apply eq_refl. - destruct x; destruct y; unfold ge; tauto. - Qed. -End Approx. - -Module D := LPMap Approx. - -(** We now define the abstract interpretations of conditions and operators - over this set of approximations. For instance, the abstract interpretation - of the operator [Oaddf] applied to two expressions [a] and [b] is - [F(Float.add f g)] if [a] and [b] have static approximations [Vfloat f] - and [Vfloat g] respectively, and [Unknown] otherwise. - - The static approximations are defined by large pattern-matchings over - the approximations of the results. We write these matchings in the - indirect style described in file [Cmconstr] to avoid excessive - duplication of cases in proofs. *) - -(* -Definition eval_static_condition (cond: condition) (vl: list approx) := - match cond, vl with - | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2) - | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2) - | Ccompimm c n, I n1 :: nil => Some(Int.cmp c n1 n) - | Ccompuimm c n, I n1 :: nil => Some(Int.cmpu c n1 n) - | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2) - | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2)) - | Cmaskzero n, I n1 :: nil => Some(Int.eq (Int.and n1 n) Int.zero) - | Cmasknotzero n, n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero)) - | _, _ => None - end. -*) - -Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Set := - | eval_static_condition_case1: - forall c n1 n2, - eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) - | eval_static_condition_case2: - forall c n1 n2, - eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) - | eval_static_condition_case3: - forall c n n1, - eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) - | eval_static_condition_case4: - forall c n n1, - eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) - | eval_static_condition_case5: - forall c n1 n2, - eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case6: - forall c n1 n2, - eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case7: - forall n n1, - eval_static_condition_cases (Cmaskzero n) (I n1 :: nil) - | eval_static_condition_case8: - forall n n1, - eval_static_condition_cases (Cmasknotzero n) (I n1 :: nil) - | eval_static_condition_default: - forall (cond: condition) (vl: list approx), - eval_static_condition_cases cond vl. - -Definition eval_static_condition_match (cond: condition) (vl: list approx) := - match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with - | Ccomp c, I n1 :: I n2 :: nil => - eval_static_condition_case1 c n1 n2 - | Ccompu c, I n1 :: I n2 :: nil => - eval_static_condition_case2 c n1 n2 - | Ccompimm c n, I n1 :: nil => - eval_static_condition_case3 c n n1 - | Ccompuimm c n, I n1 :: nil => - eval_static_condition_case4 c n n1 - | Ccompf c, F n1 :: F n2 :: nil => - eval_static_condition_case5 c n1 n2 - | Cnotcompf c, F n1 :: F n2 :: nil => - eval_static_condition_case6 c n1 n2 - | Cmaskzero n, I n1 :: nil => - eval_static_condition_case7 n n1 - | Cmasknotzero n, I n1 :: nil => - eval_static_condition_case8 n n1 - | cond, vl => - eval_static_condition_default cond vl - end. - -Definition eval_static_condition (cond: condition) (vl: list approx) := - match eval_static_condition_match cond vl with - | eval_static_condition_case1 c n1 n2 => - Some(Int.cmp c n1 n2) - | eval_static_condition_case2 c n1 n2 => - Some(Int.cmpu c n1 n2) - | eval_static_condition_case3 c n n1 => - Some(Int.cmp c n1 n) - | eval_static_condition_case4 c n n1 => - Some(Int.cmpu c n1 n) - | eval_static_condition_case5 c n1 n2 => - Some(Float.cmp c n1 n2) - | eval_static_condition_case6 c n1 n2 => - Some(negb(Float.cmp c n1 n2)) - | eval_static_condition_case7 n n1 => - Some(Int.eq (Int.and n1 n) Int.zero) - | eval_static_condition_case8 n n1 => - Some(negb(Int.eq (Int.and n1 n) Int.zero)) - | eval_static_condition_default cond vl => - None - end. - -(* -Definition eval_static_operation (op: operation) (vl: list approx) := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => I n - | Ofloatconst n, nil => F n - | Oaddrsymbol s n, nil => S s n - | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n) - | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n) - | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n) - | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n) - | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2) - | Oadd, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 n2) - | Oaddimm n, I n1 :: nil => I (Int.add n1 n) - | Oaddimm n, S s1 n1 :: nil => S s1 (Int.add n1 n) - | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2) - | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2) - | Osubimm n, I n1 :: nil => I (Int.sub n n1) - | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2) - | Omulimm n, I n1 :: nil => I(Int.mul n1 n) - | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) - | Odivu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) - | Oand, I n1 :: I n2 :: nil => I(Int.and n1 n2) - | Oandimm n, I n1 :: nil => I(Int.and n1 n) - | Oor, I n1 :: I n2 :: nil => I(Int.or n1 n2) - | Oorimm n, I n1 :: nil => I(Int.or n1 n) - | Oxor, I n1 :: I n2 :: nil => I(Int.xor n1 n2) - | Oxorimm n, I n1 :: nil => I(Int.xor n1 n) - | Onand, I n1 :: I n2 :: nil => I(Int.xor (Int.and n1 n2) Int.mone) - | Onor, I n1 :: I n2 :: nil => I(Int.xor (Int.or n1 n2) Int.mone) - | Onxor, I n1 :: I n2 :: nil => I(Int.xor (Int.xor n1 n2) Int.mone) - | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown - | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown - | Oshrimm n, I n1 :: nil => if Int.ltu n (Int.repr 32) then I(Int.shr n1 n) else Unknown - | Oshrximm n, I n1 :: nil => if Int.ltu n (Int.repr 32) then I(Int.shrx n1 n) else Unknown - | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown - | Orolm amount mask, I n1 :: nil => I(Int.rolm n1 amount mask) - | Onegf, F n1 :: nil => F(Float.neg n1) - | Oabsf, F n1 :: nil => F(Float.abs n1) - | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2) - | Osubf, F n1 :: F n2 :: nil => F(Float.sub n1 n2) - | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2) - | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) - | Omuladdf, F n1 :: F n2 :: F n3 :: nil => F(Float.add (Float.mul n1 n2) n3) - | Omulsubf, F n1 :: F n2 :: F n3 :: nil => F(Float.sub (Float.mul n1 n2) n3) - | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) - | Ointoffloat, F n1 :: nil => I(Float.intoffloat n1) - | Ointuoffloat, F n1 :: nil => I(Float.intuoffloat n1) - | Ofloatofint, I n1 :: nil => F(Float.floatofint n1) - | Ofloatofintu, I n1 :: nil => F(Float.floatofintu n1) - | Ocmp c, vl => - match eval_static_condition c vl with - | None => Unknown - | Some b => I(if b then Int.one else Int.zero) - end - | _, _ => Unknown - end. -*) - -Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Set := - | eval_static_operation_case1: - forall v1, - eval_static_operation_cases (Omove) (v1::nil) - | eval_static_operation_case2: - forall n, - eval_static_operation_cases (Ointconst n) (nil) - | eval_static_operation_case3: - forall n, - eval_static_operation_cases (Ofloatconst n) (nil) - | eval_static_operation_case4: - forall s n, - eval_static_operation_cases (Oaddrsymbol s n) (nil) - | eval_static_operation_case6: - forall n1, - eval_static_operation_cases (Ocast8signed) (I n1 :: nil) - | eval_static_operation_case7: - forall n1, - eval_static_operation_cases (Ocast16signed) (I n1 :: nil) - | eval_static_operation_case8: - forall n1 n2, - eval_static_operation_cases (Oadd) (I n1 :: I n2 :: nil) - | eval_static_operation_case9: - forall s1 n1 n2, - eval_static_operation_cases (Oadd) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case11: - forall n n1, - eval_static_operation_cases (Oaddimm n) (I n1 :: nil) - | eval_static_operation_case12: - forall n s1 n1, - eval_static_operation_cases (Oaddimm n) (S s1 n1 :: nil) - | eval_static_operation_case13: - forall n1 n2, - eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) - | eval_static_operation_case14: - forall s1 n1 n2, - eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case15: - forall n n1, - eval_static_operation_cases (Osubimm n) (I n1 :: nil) - | eval_static_operation_case16: - forall n1 n2, - eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) - | eval_static_operation_case17: - forall n n1, - eval_static_operation_cases (Omulimm n) (I n1 :: nil) - | eval_static_operation_case18: - forall n1 n2, - eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) - | eval_static_operation_case19: - forall n1 n2, - eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) - | eval_static_operation_case20: - forall n1 n2, - eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) - | eval_static_operation_case21: - forall n n1, - eval_static_operation_cases (Oandimm n) (I n1 :: nil) - | eval_static_operation_case22: - forall n1 n2, - eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) - | eval_static_operation_case23: - forall n n1, - eval_static_operation_cases (Oorimm n) (I n1 :: nil) - | eval_static_operation_case24: - forall n1 n2, - eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) - | eval_static_operation_case25: - forall n n1, - eval_static_operation_cases (Oxorimm n) (I n1 :: nil) - | eval_static_operation_case26: - forall n1 n2, - eval_static_operation_cases (Onand) (I n1 :: I n2 :: nil) - | eval_static_operation_case27: - forall n1 n2, - eval_static_operation_cases (Onor) (I n1 :: I n2 :: nil) - | eval_static_operation_case28: - forall n1 n2, - eval_static_operation_cases (Onxor) (I n1 :: I n2 :: nil) - | eval_static_operation_case29: - forall n1 n2, - eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) - | eval_static_operation_case30: - forall n1 n2, - eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) - | eval_static_operation_case31: - forall n n1, - eval_static_operation_cases (Oshrimm n) (I n1 :: nil) - | eval_static_operation_case32: - forall n n1, - eval_static_operation_cases (Oshrximm n) (I n1 :: nil) - | eval_static_operation_case33: - forall n1 n2, - eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) - | eval_static_operation_case34: - forall amount mask n1, - eval_static_operation_cases (Orolm amount mask) (I n1 :: nil) - | eval_static_operation_case35: - forall n1, - eval_static_operation_cases (Onegf) (F n1 :: nil) - | eval_static_operation_case36: - forall n1, - eval_static_operation_cases (Oabsf) (F n1 :: nil) - | eval_static_operation_case37: - forall n1 n2, - eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) - | eval_static_operation_case38: - forall n1 n2, - eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) - | eval_static_operation_case39: - forall n1 n2, - eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) - | eval_static_operation_case40: - forall n1 n2, - eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) - | eval_static_operation_case41: - forall n1 n2 n3, - eval_static_operation_cases (Omuladdf) (F n1 :: F n2 :: F n3 :: nil) - | eval_static_operation_case42: - forall n1 n2 n3, - eval_static_operation_cases (Omulsubf) (F n1 :: F n2 :: F n3 :: nil) - | eval_static_operation_case43: - forall n1, - eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) - | eval_static_operation_case44: - forall n1, - eval_static_operation_cases (Ointoffloat) (F n1 :: nil) - | eval_static_operation_case45: - forall n1, - eval_static_operation_cases (Ofloatofint) (I n1 :: nil) - | eval_static_operation_case46: - forall n1, - eval_static_operation_cases (Ofloatofintu) (I n1 :: nil) - | eval_static_operation_case47: - forall c vl, - eval_static_operation_cases (Ocmp c) (vl) - | eval_static_operation_case48: - forall n1, - eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) - | eval_static_operation_case49: - forall n1, - eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) - | eval_static_operation_case50: - forall n1, - eval_static_operation_cases (Ointuoffloat) (F n1 :: nil) - | eval_static_operation_default: - forall (op: operation) (vl: list approx), - eval_static_operation_cases op vl. - -Definition eval_static_operation_match (op: operation) (vl: list approx) := - match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with - | Omove, v1::nil => - eval_static_operation_case1 v1 - | Ointconst n, nil => - eval_static_operation_case2 n - | Ofloatconst n, nil => - eval_static_operation_case3 n - | Oaddrsymbol s n, nil => - eval_static_operation_case4 s n - | Ocast8signed, I n1 :: nil => - eval_static_operation_case6 n1 - | Ocast16signed, I n1 :: nil => - eval_static_operation_case7 n1 - | Oadd, I n1 :: I n2 :: nil => - eval_static_operation_case8 n1 n2 - | Oadd, S s1 n1 :: I n2 :: nil => - eval_static_operation_case9 s1 n1 n2 - | Oaddimm n, I n1 :: nil => - eval_static_operation_case11 n n1 - | Oaddimm n, S s1 n1 :: nil => - eval_static_operation_case12 n s1 n1 - | Osub, I n1 :: I n2 :: nil => - eval_static_operation_case13 n1 n2 - | Osub, S s1 n1 :: I n2 :: nil => - eval_static_operation_case14 s1 n1 n2 - | Osubimm n, I n1 :: nil => - eval_static_operation_case15 n n1 - | Omul, I n1 :: I n2 :: nil => - eval_static_operation_case16 n1 n2 - | Omulimm n, I n1 :: nil => - eval_static_operation_case17 n n1 - | Odiv, I n1 :: I n2 :: nil => - eval_static_operation_case18 n1 n2 - | Odivu, I n1 :: I n2 :: nil => - eval_static_operation_case19 n1 n2 - | Oand, I n1 :: I n2 :: nil => - eval_static_operation_case20 n1 n2 - | Oandimm n, I n1 :: nil => - eval_static_operation_case21 n n1 - | Oor, I n1 :: I n2 :: nil => - eval_static_operation_case22 n1 n2 - | Oorimm n, I n1 :: nil => - eval_static_operation_case23 n n1 - | Oxor, I n1 :: I n2 :: nil => - eval_static_operation_case24 n1 n2 - | Oxorimm n, I n1 :: nil => - eval_static_operation_case25 n n1 - | Onand, I n1 :: I n2 :: nil => - eval_static_operation_case26 n1 n2 - | Onor, I n1 :: I n2 :: nil => - eval_static_operation_case27 n1 n2 - | Onxor, I n1 :: I n2 :: nil => - eval_static_operation_case28 n1 n2 - | Oshl, I n1 :: I n2 :: nil => - eval_static_operation_case29 n1 n2 - | Oshr, I n1 :: I n2 :: nil => - eval_static_operation_case30 n1 n2 - | Oshrimm n, I n1 :: nil => - eval_static_operation_case31 n n1 - | Oshrximm n, I n1 :: nil => - eval_static_operation_case32 n n1 - | Oshru, I n1 :: I n2 :: nil => - eval_static_operation_case33 n1 n2 - | Orolm amount mask, I n1 :: nil => - eval_static_operation_case34 amount mask n1 - | Onegf, F n1 :: nil => - eval_static_operation_case35 n1 - | Oabsf, F n1 :: nil => - eval_static_operation_case36 n1 - | Oaddf, F n1 :: F n2 :: nil => - eval_static_operation_case37 n1 n2 - | Osubf, F n1 :: F n2 :: nil => - eval_static_operation_case38 n1 n2 - | Omulf, F n1 :: F n2 :: nil => - eval_static_operation_case39 n1 n2 - | Odivf, F n1 :: F n2 :: nil => - eval_static_operation_case40 n1 n2 - | Omuladdf, F n1 :: F n2 :: F n3 :: nil => - eval_static_operation_case41 n1 n2 n3 - | Omulsubf, F n1 :: F n2 :: F n3 :: nil => - eval_static_operation_case42 n1 n2 n3 - | Osingleoffloat, F n1 :: nil => - eval_static_operation_case43 n1 - | Ointoffloat, F n1 :: nil => - eval_static_operation_case44 n1 - | Ofloatofint, I n1 :: nil => - eval_static_operation_case45 n1 - | Ofloatofintu, I n1 :: nil => - eval_static_operation_case46 n1 - | Ocmp c, vl => - eval_static_operation_case47 c vl - | Ocast8unsigned, I n1 :: nil => - eval_static_operation_case48 n1 - | Ocast16unsigned, I n1 :: nil => - eval_static_operation_case49 n1 - | Ointuoffloat, F n1 :: nil => - eval_static_operation_case50 n1 - | op, vl => - eval_static_operation_default op vl - end. - -Definition eval_static_operation (op: operation) (vl: list approx) := - match eval_static_operation_match op vl with - | eval_static_operation_case1 v1 => - v1 - | eval_static_operation_case2 n => - I n - | eval_static_operation_case3 n => - F n - | eval_static_operation_case4 s n => - S s n - | eval_static_operation_case6 n1 => - I(Int.sign_ext 8 n1) - | eval_static_operation_case7 n1 => - I(Int.sign_ext 16 n1) - | eval_static_operation_case8 n1 n2 => - I(Int.add n1 n2) - | eval_static_operation_case9 s1 n1 n2 => - S s1 (Int.add n1 n2) - | eval_static_operation_case11 n n1 => - I (Int.add n1 n) - | eval_static_operation_case12 n s1 n1 => - S s1 (Int.add n1 n) - | eval_static_operation_case13 n1 n2 => - I(Int.sub n1 n2) - | eval_static_operation_case14 s1 n1 n2 => - S s1 (Int.sub n1 n2) - | eval_static_operation_case15 n n1 => - I (Int.sub n n1) - | eval_static_operation_case16 n1 n2 => - I(Int.mul n1 n2) - | eval_static_operation_case17 n n1 => - I(Int.mul n1 n) - | eval_static_operation_case18 n1 n2 => - if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) - | eval_static_operation_case19 n1 n2 => - if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) - | eval_static_operation_case20 n1 n2 => - I(Int.and n1 n2) - | eval_static_operation_case21 n n1 => - I(Int.and n1 n) - | eval_static_operation_case22 n1 n2 => - I(Int.or n1 n2) - | eval_static_operation_case23 n n1 => - I(Int.or n1 n) - | eval_static_operation_case24 n1 n2 => - I(Int.xor n1 n2) - | eval_static_operation_case25 n n1 => - I(Int.xor n1 n) - | eval_static_operation_case26 n1 n2 => - I(Int.xor (Int.and n1 n2) Int.mone) - | eval_static_operation_case27 n1 n2 => - I(Int.xor (Int.or n1 n2) Int.mone) - | eval_static_operation_case28 n1 n2 => - I(Int.xor (Int.xor n1 n2) Int.mone) - | eval_static_operation_case29 n1 n2 => - if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown - | eval_static_operation_case30 n1 n2 => - if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown - | eval_static_operation_case31 n n1 => - if Int.ltu n (Int.repr 32) then I(Int.shr n1 n) else Unknown - | eval_static_operation_case32 n n1 => - if Int.ltu n (Int.repr 32) then I(Int.shrx n1 n) else Unknown - | eval_static_operation_case33 n1 n2 => - if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown - | eval_static_operation_case34 amount mask n1 => - I(Int.rolm n1 amount mask) - | eval_static_operation_case35 n1 => - F(Float.neg n1) - | eval_static_operation_case36 n1 => - F(Float.abs n1) - | eval_static_operation_case37 n1 n2 => - F(Float.add n1 n2) - | eval_static_operation_case38 n1 n2 => - F(Float.sub n1 n2) - | eval_static_operation_case39 n1 n2 => - F(Float.mul n1 n2) - | eval_static_operation_case40 n1 n2 => - F(Float.div n1 n2) - | eval_static_operation_case41 n1 n2 n3 => - F(Float.add (Float.mul n1 n2) n3) - | eval_static_operation_case42 n1 n2 n3 => - F(Float.sub (Float.mul n1 n2) n3) - | eval_static_operation_case43 n1 => - F(Float.singleoffloat n1) - | eval_static_operation_case44 n1 => - I(Float.intoffloat n1) - | eval_static_operation_case45 n1 => - F(Float.floatofint n1) - | eval_static_operation_case46 n1 => - F(Float.floatofintu n1) - | eval_static_operation_case47 c vl => - match eval_static_condition c vl with - | None => Unknown - | Some b => I(if b then Int.one else Int.zero) - end - | eval_static_operation_case48 n1 => - I(Int.zero_ext 8 n1) - | eval_static_operation_case49 n1 => - I(Int.zero_ext 16 n1) - | eval_static_operation_case50 n1 => - I(Float.intuoffloat n1) - | eval_static_operation_default op vl => - Unknown - end. - -(** The transfer function for the dataflow analysis is straightforward: - for [Iop] instructions, we set the approximation of the destination - register to the result of executing abstractly the operation; - for [Iload] and [Icall], we set the approximation of the destination - to [Unknown]. *) - -Definition approx_regs (rl: list reg) (approx: D.t) := - List.map (fun r => D.get r approx) rl. - -Definition transfer (f: function) (pc: node) (before: D.t) := - match f.(fn_code)!pc with - | None => before - | Some i => - match i with - | Inop s => - before - | Iop op args res s => - let a := eval_static_operation op (approx_regs args before) in - D.set res a before - | Iload chunk addr args dst s => - D.set dst Unknown before - | Istore chunk addr args src s => - before - | Icall sig ros args res s => - D.set res Unknown before - | Itailcall sig ros args => - before - | Ialloc arg res s => - D.set res Unknown before - | Icond cond args ifso ifnot => - before - | Ireturn optarg => - before - end - end. - -(** The static analysis itself is then an instantiation of Kildall's - generic solver for forward dataflow inequations. [analyze f] - returns a mapping from program points to mappings of pseudo-registers - to approximations. It can fail to reach a fixpoint in a reasonable - number of iterations, in which case [None] is returned. *) - -Module DS := Dataflow_Solver(D)(NodeSetForward). - -Definition analyze (f: RTL.function): PMap.t D.t := - match DS.fixpoint (successors f) f.(fn_nextpc) (transfer f) - ((f.(fn_entrypoint), D.top) :: nil) with - | None => PMap.init D.top - | Some res => res - end. - -(** * Code transformation *) - -(** ** Operator strength reduction *) - -(** We now define auxiliary functions for strength reduction of - operators and addressing modes: replacing an operator with a cheaper - one if some of its arguments are statically known. These are again - large pattern-matchings expressed in indirect style. *) - -Section STRENGTH_REDUCTION. - -Variable approx: D.t. - -Definition intval (r: reg) : option int := - match D.get r approx with I n => Some n | _ => None end. - -Inductive cond_strength_reduction_cases: condition -> list reg -> Set := - | csr_case1: - forall c r1 r2, - cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) - | csr_case2: - forall c r1 r2, - cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) - | csr_default: - forall c rl, - cond_strength_reduction_cases c rl. - -Definition cond_strength_reduction_match (cond: condition) (rl: list reg) := - match cond as x, rl as y return cond_strength_reduction_cases x y with - | Ccomp c, r1 :: r2 :: nil => - csr_case1 c r1 r2 - | Ccompu c, r1 :: r2 :: nil => - csr_case2 c r1 r2 - | cond, rl => - csr_default cond rl - end. - -Definition cond_strength_reduction - (cond: condition) (args: list reg) : condition * list reg := - match cond_strength_reduction_match cond args with - | csr_case1 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | csr_case2 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompuimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompuimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | csr_default cond args => - (cond, args) - end. - -Definition make_addimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oaddimm n, r :: nil). - -Definition make_shlimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Orolm n (Int.shl Int.mone n), r :: nil). - -Definition make_shrimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oshrimm n, r :: nil). - -Definition make_shruimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Orolm (Int.sub (Int.repr 32) n) (Int.shru Int.mone n), r :: nil). - -Definition make_mulimm (n: int) (r: reg) := - if Int.eq n Int.zero then - (Ointconst Int.zero, nil) - else if Int.eq n Int.one then - (Omove, r :: nil) - else - match Int.is_power2 n with - | Some l => make_shlimm l r - | None => (Omulimm n, r :: nil) - end. - -Definition make_andimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Ointconst Int.zero, nil) - else if Int.eq n Int.mone then (Omove, r :: nil) - else (Oandimm n, r :: nil). - -Definition make_orimm (n: int) (r: reg) := - if Int.eq n Int.zero then (Omove, r :: nil) - else if Int.eq n Int.mone then (Ointconst Int.mone, nil) - else (Oorimm n, r :: nil). - -Definition make_xorimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oxorimm n, r :: nil). - -Inductive op_strength_reduction_cases: operation -> list reg -> Set := - | op_strength_reduction_case1: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oadd (r1 :: r2 :: nil) - | op_strength_reduction_case2: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Osub (r1 :: r2 :: nil) - | op_strength_reduction_case3: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Omul (r1 :: r2 :: nil) - | op_strength_reduction_case4: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Odiv (r1 :: r2 :: nil) - | op_strength_reduction_case5: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Odivu (r1 :: r2 :: nil) - | op_strength_reduction_case6: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oand (r1 :: r2 :: nil) - | op_strength_reduction_case7: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oor (r1 :: r2 :: nil) - | op_strength_reduction_case8: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oxor (r1 :: r2 :: nil) - | op_strength_reduction_case9: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oshl (r1 :: r2 :: nil) - | op_strength_reduction_case10: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oshr (r1 :: r2 :: nil) - | op_strength_reduction_case11: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oshru (r1 :: r2 :: nil) - | op_strength_reduction_case12: - forall (c: condition) (rl: list reg), - op_strength_reduction_cases (Ocmp c) rl - | op_strength_reduction_default: - forall (op: operation) (args: list reg), - op_strength_reduction_cases op args. - -Definition op_strength_reduction_match (op: operation) (args: list reg) := - match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with - | Oadd, r1 :: r2 :: nil => - op_strength_reduction_case1 r1 r2 - | Osub, r1 :: r2 :: nil => - op_strength_reduction_case2 r1 r2 - | Omul, r1 :: r2 :: nil => - op_strength_reduction_case3 r1 r2 - | Odiv, r1 :: r2 :: nil => - op_strength_reduction_case4 r1 r2 - | Odivu, r1 :: r2 :: nil => - op_strength_reduction_case5 r1 r2 - | Oand, r1 :: r2 :: nil => - op_strength_reduction_case6 r1 r2 - | Oor, r1 :: r2 :: nil => - op_strength_reduction_case7 r1 r2 - | Oxor, r1 :: r2 :: nil => - op_strength_reduction_case8 r1 r2 - | Oshl, r1 :: r2 :: nil => - op_strength_reduction_case9 r1 r2 - | Oshr, r1 :: r2 :: nil => - op_strength_reduction_case10 r1 r2 - | Oshru, r1 :: r2 :: nil => - op_strength_reduction_case11 r1 r2 - | Ocmp c, rl => - op_strength_reduction_case12 c rl - | op, args => - op_strength_reduction_default op args - end. - -Definition op_strength_reduction (op: operation) (args: list reg) := - match op_strength_reduction_match op args with - | op_strength_reduction_case1 r1 r2 => (* Oadd *) - match intval r1, intval r2 with - | Some n, _ => make_addimm n r2 - | _, Some n => make_addimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case2 r1 r2 => (* Osub *) - match intval r1, intval r2 with - | Some n, _ => (Osubimm n, r2 :: nil) - | _, Some n => make_addimm (Int.neg n) r1 - | _, _ => (op, args) - end - | op_strength_reduction_case3 r1 r2 => (* Omul *) - match intval r1, intval r2 with - | Some n, _ => make_mulimm n r2 - | _, Some n => make_mulimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case4 r1 r2 => (* Odiv *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => (Oshrximm l, r1 :: nil) - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case5 r1 r2 => (* Odivu *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => make_shruimm l r1 - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case6 r1 r2 => (* Oand *) - match intval r1, intval r2 with - | Some n, _ => make_andimm n r2 - | _, Some n => make_andimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case7 r1 r2 => (* Oor *) - match intval r1, intval r2 with - | Some n, _ => make_orimm n r2 - | _, Some n => make_orimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case8 r1 r2 => (* Oxor *) - match intval r1, intval r2 with - | Some n, _ => make_xorimm n r2 - | _, Some n => make_xorimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case9 r1 r2 => (* Oshl *) - match intval r2 with - | Some n => - if Int.ltu n (Int.repr 32) - then make_shlimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case10 r1 r2 => (* Oshr *) - match intval r2 with - | Some n => - if Int.ltu n (Int.repr 32) - then make_shrimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case11 r1 r2 => (* Oshru *) - match intval r2 with - | Some n => - if Int.ltu n (Int.repr 32) - then make_shruimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case12 c args => (* Ocmp *) - let (c', args') := cond_strength_reduction c args in - (Ocmp c', args') - | op_strength_reduction_default op args => (* default *) - (op, args) - end. - -Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Set := - | addr_strength_reduction_case1: - forall (r1: reg) (r2: reg), - addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) - | addr_strength_reduction_case2: - forall (symb: ident) (ofs: int) (r1: reg), - addr_strength_reduction_cases (Abased symb ofs) (r1 :: nil) - | addr_strength_reduction_case3: - forall n r1, - addr_strength_reduction_cases (Aindexed n) (r1 :: nil) - | addr_strength_reduction_default: - forall (addr: addressing) (args: list reg), - addr_strength_reduction_cases addr args. - -Definition addr_strength_reduction_match (addr: addressing) (args: list reg) := - match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with - | Aindexed2, r1 :: r2 :: nil => - addr_strength_reduction_case1 r1 r2 - | Abased symb ofs, r1 :: nil => - addr_strength_reduction_case2 symb ofs r1 - | Aindexed n, r1 :: nil => - addr_strength_reduction_case3 n r1 - | addr, args => - addr_strength_reduction_default addr args - end. - -Definition addr_strength_reduction (addr: addressing) (args: list reg) := - match addr_strength_reduction_match addr args with - | addr_strength_reduction_case1 r1 r2 => (* Aindexed2 *) - match D.get r1 approx, D.get r2 approx with - | S symb n1, I n2 => (Aglobal symb (Int.add n1 n2), nil) - | S symb n1, _ => (Abased symb n1, r2 :: nil) - | I n1, S symb n2 => (Aglobal symb (Int.add n1 n2), nil) - | I n1, _ => (Aindexed n1, r2 :: nil) - | _, S symb n2 => (Abased symb n2, r1 :: nil) - | _, I n2 => (Aindexed n2, r1 :: nil) - | _, _ => (addr, args) - end - | addr_strength_reduction_case2 symb ofs r1 => (* Abased *) - match intval r1 with - | Some n => (Aglobal symb (Int.add ofs n), nil) - | _ => (addr, args) - end - | addr_strength_reduction_case3 n r1 => (* Aindexed *) - match D.get r1 approx with - | S symb ofs => (Aglobal symb (Int.add ofs n), nil) - | _ => (addr, args) - end - | addr_strength_reduction_default addr args => (* default *) - (addr, args) - end. - -End STRENGTH_REDUCTION. - -(** ** Code transformation *) - -(** The code transformation proceeds instruction by instruction. - Operators whose arguments are all statically known are turned - into ``load integer constant'', ``load float constant'' or - ``load symbol address'' operations. Operators for which some - but not all arguments are known are subject to strength reduction, - and similarly for the addressing modes of load and store instructions. - Other instructions are unchanged. *) - -Definition transf_ros (approx: D.t) (ros: reg + ident) : reg + ident := - match ros with - | inl r => - match D.get r approx with - | S symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros - | _ => ros - end - | inr s => ros - end. - -Definition transf_instr (approx: D.t) (instr: instruction) := - match instr with - | Iop op args res s => - match eval_static_operation op (approx_regs args approx) with - | I n => - Iop (Ointconst n) nil res s - | F n => - Iop (Ofloatconst n) nil res s - | S symb ofs => - Iop (Oaddrsymbol symb ofs) nil res s - | _ => - let (op', args') := op_strength_reduction approx op args in - Iop op' args' res s - end - | Iload chunk addr args dst s => - let (addr', args') := addr_strength_reduction approx addr args in - Iload chunk addr' args' dst s - | Istore chunk addr args src s => - let (addr', args') := addr_strength_reduction approx addr args in - Istore chunk addr' args' src s - | Icall sig ros args res s => - Icall sig (transf_ros approx ros) args res s - | Itailcall sig ros args => - Itailcall sig (transf_ros approx ros) args - | Ialloc arg res s => - Ialloc arg res s - | Icond cond args s1 s2 => - match eval_static_condition cond (approx_regs args approx) with - | Some b => - if b then Inop s1 else Inop s2 - | None => - let (cond', args') := cond_strength_reduction approx cond args in - Icond cond' args' s1 s2 - end - | _ => - instr - end. - -Definition transf_code (approxs: PMap.t D.t) (instrs: code) : code := - PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs. - -Lemma transf_code_wf: - forall f approxs, - (forall pc, Plt pc f.(fn_nextpc) \/ f.(fn_code)!pc = None) -> - (forall pc, Plt pc f.(fn_nextpc) - \/ (transf_code approxs f.(fn_code))!pc = None). -Proof. - intros. - elim (H pc); intro. - left; auto. - right. unfold transf_code. rewrite PTree.gmap. - unfold option_map; rewrite H0. reflexivity. -Qed. - -Definition transf_function (f: function) : function := - let approxs := analyze f in - mkfunction - f.(fn_sig) - f.(fn_params) - f.(fn_stacksize) - (transf_code approxs f.(fn_code)) - f.(fn_entrypoint) - f.(fn_nextpc) - (transf_code_wf f approxs f.(fn_code_wf)). - -Definition transf_fundef (fd: fundef) : fundef := - AST.transf_fundef transf_function fd. - -Definition transf_program (p: program) : program := - transform_program transf_fundef p. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v deleted file mode 100644 index e16f322e..00000000 --- a/backend/Constpropproof.v +++ /dev/null @@ -1,954 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for constant propagation. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Events. -Require Import Mem. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Lattice. -Require Import Kildall. -Require Import Constprop. - -(** * Correctness of the static analysis *) - -Section ANALYSIS. - -Variable ge: genv. - -(** We first show that the dataflow analysis is correct with respect - to the dynamic semantics: the approximations (sets of values) - of a register at a program point predicted by the static analysis - are a superset of the values actually encountered during concrete - executions. We formalize this correspondence between run-time values and - compile-time approximations by the following predicate. *) - -Definition val_match_approx (a: approx) (v: val) : Prop := - match a with - | Unknown => True - | I p => v = Vint p - | F p => v = Vfloat p - | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs - | _ => False - end. - -Definition regs_match_approx (a: D.t) (rs: regset) : Prop := - forall r, val_match_approx (D.get r a) rs#r. - -Lemma regs_match_approx_top: - forall rs, regs_match_approx D.top rs. -Proof. - intros. red; intros. simpl. rewrite PTree.gempty. - unfold Approx.top, val_match_approx. auto. -Qed. - -Lemma val_match_approx_increasing: - forall a1 a2 v, - Approx.ge a1 a2 -> val_match_approx a2 v -> val_match_approx a1 v. -Proof. - intros until v. - intros [A|[B|C]]. - subst a1. simpl. auto. - subst a2. simpl. tauto. - subst a2. auto. -Qed. - -Lemma regs_match_approx_increasing: - forall a1 a2 rs, - D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs. -Proof. - unfold D.ge, regs_match_approx. intros. - apply val_match_approx_increasing with (D.get r a2); auto. -Qed. - -Lemma regs_match_approx_update: - forall ra rs a v r, - val_match_approx a v -> - regs_match_approx ra rs -> - regs_match_approx (D.set r a ra) (rs#r <- v). -Proof. - intros; red; intros. rewrite Regmap.gsspec. - case (peq r0 r); intro. - subst r0. rewrite D.gss. auto. - rewrite D.gso; auto. -Qed. - -Inductive val_list_match_approx: list approx -> list val -> Prop := - | vlma_nil: - val_list_match_approx nil nil - | vlma_cons: - forall a al v vl, - val_match_approx a v -> - val_list_match_approx al vl -> - val_list_match_approx (a :: al) (v :: vl). - -Lemma approx_regs_val_list: - forall ra rs rl, - regs_match_approx ra rs -> - val_list_match_approx (approx_regs rl ra) rs##rl. -Proof. - induction rl; simpl; intros. - constructor. - constructor. apply H. auto. -Qed. - -Ltac SimplVMA := - match goal with - | H: (val_match_approx (I _) ?v) |- _ => - simpl in H; (try subst v); SimplVMA - | H: (val_match_approx (F _) ?v) |- _ => - simpl in H; (try subst v); SimplVMA - | H: (val_match_approx (S _ _) ?v) |- _ => - simpl in H; - (try (elim H; - let b := fresh "b" in let A := fresh in let B := fresh in - (intros b [A B]; subst v; clear H))); - SimplVMA - | _ => - idtac - end. - -Ltac InvVLMA := - match goal with - | H: (val_list_match_approx nil ?vl) |- _ => - inversion H - | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ => - inversion H; SimplVMA; InvVLMA - | _ => - idtac - end. - -(** We then show that [eval_static_operation] is a correct abstract - interpretations of [eval_operation]: if the concrete arguments match - the given approximations, the concrete results match the - approximations returned by [eval_static_operation]. *) - -Lemma eval_static_condition_correct: - forall cond al vl m b, - val_list_match_approx al vl -> - eval_static_condition cond al = Some b -> - eval_condition cond vl m = Some b. -Proof. - intros until b. - unfold eval_static_condition. - case (eval_static_condition_match cond al); intros; - InvVLMA; simpl; congruence. -Qed. - -Lemma eval_static_operation_correct: - forall op sp al vl m v, - val_list_match_approx al vl -> - eval_operation ge sp op vl m = Some v -> - val_match_approx (eval_static_operation op al) v. -Proof. - intros until v. - unfold eval_static_operation. - case (eval_static_operation_match op al); intros; - InvVLMA; simpl in *; FuncInv; try congruence. - - destruct (Genv.find_symbol ge s). exists b. intuition congruence. - congruence. - - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - - exists b. split. auto. congruence. - exists b. split. auto. congruence. - exists b. split. auto. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - subst v. unfold Int.not. congruence. - subst v. unfold Int.not. congruence. - subst v. unfold Int.not. congruence. - - replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - destruct (Int.ltu n (Int.repr 32)). - injection H0; intro; subst v. simpl. congruence. discriminate. - - destruct (Int.ltu n (Int.repr 32)). - injection H0; intro; subst v. simpl. congruence. discriminate. - - replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. - - caseEq (eval_static_condition c vl0). - intros. generalize (eval_static_condition_correct _ _ _ m _ H H1). - intro. rewrite H2 in H0. - destruct b; injection H0; intro; subst v; simpl; auto. - intros; simpl; auto. - - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - - auto. -Qed. - -(** The correctness of the static analysis follows from the results - above and the fact that the result of the static analysis is - a solution of the forward dataflow inequations. *) - -Lemma analyze_correct_1: - forall f pc rs pc', - In pc' (successors f pc) -> - regs_match_approx (transfer f pc (analyze f)!!pc) rs -> - regs_match_approx (analyze f)!!pc' rs. -Proof. - intros until pc'. unfold analyze. - caseEq (DS.fixpoint (successors f) (fn_nextpc f) (transfer f) - ((fn_entrypoint f, D.top) :: nil)). - intros approxs; intros. - apply regs_match_approx_increasing with (transfer f pc approxs!!pc). - eapply DS.fixpoint_solution; eauto. - elim (fn_code_wf f pc); intro. auto. - unfold successors in H0; rewrite H2 in H0; simpl; contradiction. - auto. - intros. rewrite PMap.gi. apply regs_match_approx_top. -Qed. - -Lemma analyze_correct_3: - forall f rs, - regs_match_approx (analyze f)!!(f.(fn_entrypoint)) rs. -Proof. - intros. unfold analyze. - caseEq (DS.fixpoint (successors f) (fn_nextpc f) (transfer f) - ((fn_entrypoint f, D.top) :: nil)). - intros approxs; intros. - apply regs_match_approx_increasing with D.top. - eapply DS.fixpoint_entry; eauto. auto with coqlib. - apply regs_match_approx_top. - intros. rewrite PMap.gi. apply regs_match_approx_top. -Qed. - -(** * Correctness of strength reduction *) - -(** We now show that strength reduction over operators and addressing - modes preserve semantics: the strength-reduced operations and - addressings evaluate to the same values as the original ones if the - actual arguments match the static approximations used for strength - reduction. *) - -Section STRENGTH_REDUCTION. - -Variable approx: D.t. -Variable sp: val. -Variable rs: regset. -Hypothesis MATCH: regs_match_approx approx rs. - -Lemma intval_correct: - forall r n, - intval approx r = Some n -> rs#r = Vint n. -Proof. - intros until n. - unfold intval. caseEq (D.get r approx); intros; try discriminate. - generalize (MATCH r). unfold val_match_approx. rewrite H. - congruence. -Qed. - -Lemma cond_strength_reduction_correct: - forall cond args m, - let (cond', args') := cond_strength_reduction approx cond args in - eval_condition cond' rs##args' m = eval_condition cond rs##args m. -Proof. - intros. unfold cond_strength_reduction. - case (cond_strength_reduction_match cond args); intros. - caseEq (intval approx r1); intros. - simpl. rewrite (intval_correct _ _ H). - destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. - destruct c; reflexivity. - caseEq (intval approx r2); intros. - simpl. rewrite (intval_correct _ _ H0). auto. - auto. - caseEq (intval approx r1); intros. - simpl. rewrite (intval_correct _ _ H). - destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto. - caseEq (intval approx r2); intros. - simpl. rewrite (intval_correct _ _ H0). auto. - auto. - auto. -Qed. - -Lemma make_addimm_correct: - forall n r m v, - let (op, args) := make_addimm n r in - eval_operation ge sp Oadd (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. -Proof. - intros; unfold make_addimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.add_zero in H. congruence. - rewrite Int.add_zero in H. congruence. - exact H0. -Qed. - -Lemma make_shlimm_correct: - forall n r m v, - let (op, args) := make_shlimm n r in - eval_operation ge sp Oshl (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. -Proof. - intros; unfold make_shlimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence. - simpl in *. FuncInv. caseEq (Int.ltu n (Int.repr 32)); intros. - rewrite H1 in H0. rewrite Int.shl_rolm in H0. auto. exact H1. - rewrite H1 in H0. discriminate. -Qed. - -Lemma make_shrimm_correct: - forall n r m v, - let (op, args) := make_shrimm n r in - eval_operation ge sp Oshr (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. -Proof. - intros; unfold make_shrimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence. - assumption. -Qed. - -Lemma make_shruimm_correct: - forall n r m v, - let (op, args) := make_shruimm n r in - eval_operation ge sp Oshru (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. -Proof. - intros; unfold make_shruimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence. - simpl in *. FuncInv. caseEq (Int.ltu n (Int.repr 32)); intros. - rewrite H1 in H0. rewrite Int.shru_rolm in H0. auto. exact H1. - rewrite H1 in H0. discriminate. -Qed. - -Lemma make_mulimm_correct: - forall n r m v, - let (op, args) := make_mulimm n r in - eval_operation ge sp Omul (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. -Proof. - intros; unfold make_mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in H0. FuncInv. rewrite Int.mul_zero in H. simpl. congruence. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. - subst n. simpl in H1. simpl. FuncInv. rewrite Int.mul_one in H0. congruence. - caseEq (Int.is_power2 n); intros. - replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m) - with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m). - apply make_shlimm_correct. - simpl. generalize (Int.is_power2_range _ _ H1). - change (Z_of_nat wordsize) with 32. intro. rewrite H2. - destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H1). auto. - exact H2. -Qed. - -Lemma make_andimm_correct: - forall n r m v, - let (op, args) := make_andimm n r in - eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. -Proof. - intros; unfold make_andimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence. - exact H1. -Qed. - -Lemma make_orimm_correct: - forall n r m v, - let (op, args) := make_orimm n r in - eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. -Proof. - intros; unfold make_orimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence. - exact H1. -Qed. - -Lemma make_xorimm_correct: - forall n r m v, - let (op, args) := make_xorimm n r in - eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v -> - eval_operation ge sp op rs##args m = Some v. -Proof. - intros; unfold make_xorimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. - subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence. - exact H0. -Qed. - -Lemma op_strength_reduction_correct: - forall op args m v, - let (op', args') := op_strength_reduction approx op args in - eval_operation ge sp op rs##args m = Some v -> - eval_operation ge sp op' rs##args' m = Some v. -Proof. - intros; unfold op_strength_reduction; - case (op_strength_reduction_match op args); intros; simpl List.map. - (* Oadd *) - caseEq (intval approx r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oadd (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Oadd (rs # r2 :: Vint i :: nil) m). - apply make_addimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.add_commut; auto. - caseEq (intval approx r2); intros. - rewrite (intval_correct _ _ H0). apply make_addimm_correct. - assumption. - (* Osub *) - caseEq (intval approx r1); intros. - rewrite (intval_correct _ _ H) in H0. assumption. - caseEq (intval approx r2); intros. - rewrite (intval_correct _ _ H0). - replace (eval_operation ge sp Osub (rs # r1 :: Vint i :: nil) m) - with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg i) :: nil) m). - apply make_addimm_correct. - simpl. destruct rs#r1; auto; rewrite Int.sub_add_opp; auto. - assumption. - (* Omul *) - caseEq (intval approx r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Omul (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Omul (rs # r2 :: Vint i :: nil) m). - apply make_mulimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.mul_commut; auto. - caseEq (intval approx r2); intros. - rewrite (intval_correct _ _ H0). apply make_mulimm_correct. - assumption. - (* Odiv *) - caseEq (intval approx r2); intros. - caseEq (Int.is_power2 i); intros. - rewrite (intval_correct _ _ H) in H1. - simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence. - change 32 with (Z_of_nat wordsize). - rewrite (Int.is_power2_range _ _ H0). - rewrite (Int.divs_pow2 i1 _ _ H0) in H1. auto. - assumption. - assumption. - (* Odivu *) - caseEq (intval approx r2); intros. - caseEq (Int.is_power2 i); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil) m) - with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil) m). - apply make_shruimm_correct. - simpl. destruct rs#r1; auto. - change 32 with (Z_of_nat wordsize). - rewrite (Int.is_power2_range _ _ H0). - generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros. - subst i. discriminate. - rewrite (Int.divu_pow2 i1 _ _ H0). auto. - assumption. - assumption. - (* Oand *) - caseEq (intval approx r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil) m). - apply make_andimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.and_commut; auto. - caseEq (intval approx r2); intros. - rewrite (intval_correct _ _ H0). apply make_andimm_correct. - assumption. - (* Oor *) - caseEq (intval approx r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil) m). - apply make_orimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.or_commut; auto. - caseEq (intval approx r2); intros. - rewrite (intval_correct _ _ H0). apply make_orimm_correct. - assumption. - (* Oxor *) - caseEq (intval approx r1); intros. - rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil) m) - with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil) m). - apply make_xorimm_correct. - simpl. destruct rs#r2; auto. rewrite Int.xor_commut; auto. - caseEq (intval approx r2); intros. - rewrite (intval_correct _ _ H0). apply make_xorimm_correct. - assumption. - (* Oshl *) - caseEq (intval approx r2); intros. - caseEq (Int.ltu i (Int.repr 32)); intros. - rewrite (intval_correct _ _ H). apply make_shlimm_correct. - assumption. - assumption. - (* Oshr *) - caseEq (intval approx r2); intros. - caseEq (Int.ltu i (Int.repr 32)); intros. - rewrite (intval_correct _ _ H). apply make_shrimm_correct. - assumption. - assumption. - (* Oshru *) - caseEq (intval approx r2); intros. - caseEq (Int.ltu i (Int.repr 32)); intros. - rewrite (intval_correct _ _ H). apply make_shruimm_correct. - assumption. - assumption. - (* Ocmp *) - generalize (cond_strength_reduction_correct c rl). - destruct (cond_strength_reduction approx c rl). - simpl. intro. rewrite H. auto. - (* default *) - assumption. -Qed. - -Ltac KnownApprox := - match goal with - | MATCH: (regs_match_approx ?approx ?rs), - H: (D.get ?r ?approx = ?a) |- _ => - generalize (MATCH r); rewrite H; intro; clear H; KnownApprox - | _ => idtac - end. - -Lemma addr_strength_reduction_correct: - forall addr args, - let (addr', args') := addr_strength_reduction approx addr args in - eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args. -Proof. - intros. - - (* Useful lemmas *) - assert (A0: forall r1 r2, - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r2 :: r1 :: nil))). - intros. simpl. destruct (rs#r1); destruct (rs#r2); auto; - rewrite Int.add_commut; auto. - - assert (A1: forall r1 r2 n, - val_match_approx (I n) rs#r2 -> - eval_addressing ge sp (Aindexed n) (rs ## (r1 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros; simpl in *. rewrite H. auto. - - assert (A2: forall r1 r2 n, - val_match_approx (I n) rs#r1 -> - eval_addressing ge sp (Aindexed n) (rs ## (r2 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. rewrite A0. apply A1. auto. - - assert (A3: forall r1 r2 id ofs, - val_match_approx (S id ofs) rs#r1 -> - eval_addressing ge sp (Abased id ofs) (rs ## (r2 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. elim H. intros b [A B]. simpl. rewrite A; rewrite B. auto. - - assert (A4: forall r1 r2 id ofs, - val_match_approx (S id ofs) rs#r2 -> - eval_addressing ge sp (Abased id ofs) (rs ## (r1 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. rewrite A0. apply A3. auto. - - assert (A5: forall r1 r2 id ofs n, - val_match_approx (S id ofs) rs#r1 -> - val_match_approx (I n) rs#r2 -> - eval_addressing ge sp (Aglobal id (Int.add ofs n)) nil = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. elim H. intros b [A B]. simpl. rewrite A; rewrite B. - simpl in H0. rewrite H0. auto. - - unfold addr_strength_reduction; - case (addr_strength_reduction_match addr args); intros. - - (* Aindexed2 *) - caseEq (D.get r1 approx); intros; - caseEq (D.get r2 approx); intros; - try reflexivity; KnownApprox; auto. - rewrite A0. rewrite Int.add_commut. apply A5; auto. - - (* Abased *) - caseEq (intval approx r1); intros. - simpl; rewrite (intval_correct _ _ H). auto. - auto. - - (* Aindexed *) - caseEq (D.get r1 approx); intros; auto. - simpl; KnownApprox. - elim H0. intros b [A B]. rewrite A; rewrite B. auto. - - (* default *) - reflexivity. -Qed. - -End STRENGTH_REDUCTION. - -End ANALYSIS. - -(** * Correctness of the code transformation *) - -(** We now show that the transformed code after constant propagation - has the same semantics as the original code. *) - -Section PRESERVATION. - -Variable prog: program. -Let tprog := transf_program prog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intros; unfold ge, tge, tprog, transf_program. - apply Genv.find_symbol_transf. -Qed. - -Lemma functions_translated: - forall (v: val) (f: fundef), - Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transf_fundef f). -Proof. - intros. - exact (Genv.find_funct_transf transf_fundef H). -Qed. - -Lemma function_ptr_translated: - forall (b: block) (f: fundef), - Genv.find_funct_ptr ge b = Some f -> - Genv.find_funct_ptr tge b = Some (transf_fundef f). -Proof. - intros. - exact (Genv.find_funct_ptr_transf transf_fundef H). -Qed. - -Lemma sig_function_translated: - forall f, - funsig (transf_fundef f) = funsig f. -Proof. - intros. destruct f; reflexivity. -Qed. - -Lemma transf_ros_correct: - forall ros rs f approx, - regs_match_approx ge approx rs -> - find_function ge ros rs = Some f -> - find_function tge (transf_ros approx ros) rs = Some (transf_fundef f). -Proof. - intros until approx; intro MATCH. - destruct ros; simpl. - intro. - exploit functions_translated; eauto. intro FIND. - caseEq (D.get r approx); intros; auto. - generalize (Int.eq_spec i0 Int.zero); case (Int.eq i0 Int.zero); intros; auto. - generalize (MATCH r). rewrite H0. intros [b [A B]]. - rewrite <- symbols_preserved in A. - rewrite B in FIND. rewrite H1 in FIND. - rewrite Genv.find_funct_find_funct_ptr in FIND. - simpl. rewrite A. auto. - rewrite symbols_preserved. destruct (Genv.find_symbol ge i). - intro. apply function_ptr_translated. auto. - congruence. -Qed. - -(** The proof of semantic preservation is a simulation argument - based on diagrams of the following form: -<< - st1 --------------- st2 - | | - t| |t - | | - v v - st1'--------------- st2' ->> - The left vertical arrow represents a transition in the - original RTL code. The top horizontal bar is the [match_states] - invariant between the initial state [st1] in the original RTL code - and an initial state [st2] in the transformed code. - This invariant expresses that all code fragments appearing in [st2] - are obtained by [transf_code] transformation of the corresponding - fragments in [st1]. Moreover, the values of registers in [st1] - must match their compile-time approximations at the current program - point. - These two parts of the diagram are the hypotheses. In conclusions, - we want to prove the other two parts: the right vertical arrow, - which is a transition in the transformed RTL code, and the bottom - horizontal bar, which means that the [match_state] predicate holds - between the final states [st1'] and [st2']. *) - -Inductive match_stackframes: stackframe -> stackframe -> Prop := - match_stackframe_intro: - forall res c sp pc rs f, - c = f.(RTL.fn_code) -> - (forall v, regs_match_approx ge (analyze f)!!pc (rs#res <- v)) -> - match_stackframes - (Stackframe res c sp pc rs) - (Stackframe res (transf_code (analyze f) c) sp pc rs). - -Inductive match_states: state -> state -> Prop := - | match_states_intro: - forall s c sp pc rs m f s' - (CF: c = f.(RTL.fn_code)) - (MATCH: regs_match_approx ge (analyze f)!!pc rs) - (STACKS: list_forall2 match_stackframes s s'), - match_states (State s c sp pc rs m) - (State s' (transf_code (analyze f) c) sp pc rs m) - | match_states_call: - forall s f args m s', - list_forall2 match_stackframes s s' -> - match_states (Callstate s f args m) - (Callstate s' (transf_fundef f) args m) - | match_states_return: - forall s s' v m, - list_forall2 match_stackframes s s' -> - match_states (Returnstate s v m) - (Returnstate s' v m). - -Ltac TransfInstr := - match goal with - | H1: (PTree.get ?pc ?c = Some ?instr), f: function |- _ => - cut ((transf_code (analyze f) c)!pc = Some(transf_instr (analyze f)!!pc instr)); - [ simpl - | unfold transf_code; rewrite PTree.gmap; - unfold option_map; rewrite H1; reflexivity ] - end. - -(** The proof of simulation proceeds by case analysis on the transition - taken in the source code. *) - -Lemma transf_step_correct: - forall s1 t s2, - step ge s1 t s2 -> - forall s1' (MS: match_states s1 s1'), - exists s2', step tge s1' t s2' /\ match_states s2 s2'. -Proof. - induction 1; intros; inv MS. - - (* Inop *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m); split. - TransfInstr; intro. eapply exec_Inop; eauto. - econstructor; eauto. - eapply analyze_correct_1 with (pc := pc); eauto. - unfold successors; rewrite H; auto with coqlib. - unfold transfer; rewrite H. auto. - - (* Iop *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- v) m); split. - TransfInstr. caseEq (op_strength_reduction (analyze f)!!pc op args); - intros op' args' OSR. - assert (eval_operation tge sp op' rs##args' m = Some v). - rewrite (eval_operation_preserved symbols_preserved). - generalize (op_strength_reduction_correct ge (analyze f)!!pc sp rs - MATCH op args m v). - rewrite OSR; simpl. auto. - generalize (eval_static_operation_correct ge op sp - (approx_regs args (analyze f)!!pc) rs##args m v - (approx_regs_val_list _ _ _ args MATCH) H0). - case (eval_static_operation op (approx_regs args (analyze f)!!pc)); intros; - simpl in H2; - eapply exec_Iop; eauto; simpl. - congruence. - congruence. - elim H2; intros b [A B]. rewrite symbols_preserved. - rewrite A; rewrite B; auto. - econstructor; eauto. - eapply analyze_correct_1 with (pc := pc); eauto. - unfold successors; rewrite H; auto with coqlib. - unfold transfer; rewrite H. - apply regs_match_approx_update; auto. - eapply eval_static_operation_correct; eauto. - apply approx_regs_val_list; auto. - - (* Iload *) - caseEq (addr_strength_reduction (analyze f)!!pc addr args); - intros addr' args' ASR. - assert (eval_addressing tge sp addr' rs##args' = Some a). - rewrite (eval_addressing_preserved symbols_preserved). - generalize (addr_strength_reduction_correct ge (analyze f)!!pc sp rs - MATCH addr args). - rewrite ASR; simpl. congruence. - TransfInstr. rewrite ASR. intro. - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#dst <- v) m); split. - eapply exec_Iload; eauto. - econstructor; eauto. - apply analyze_correct_1 with pc; auto. - unfold successors; rewrite H; auto with coqlib. - unfold transfer; rewrite H. - apply regs_match_approx_update; auto. simpl; auto. - - (* Istore *) - caseEq (addr_strength_reduction (analyze f)!!pc addr args); - intros addr' args' ASR. - assert (eval_addressing tge sp addr' rs##args' = Some a). - rewrite (eval_addressing_preserved symbols_preserved). - generalize (addr_strength_reduction_correct ge (analyze f)!!pc sp rs - MATCH addr args). - rewrite ASR; simpl. congruence. - TransfInstr. rewrite ASR. intro. - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m'); split. - eapply exec_Istore; eauto. - econstructor; eauto. - apply analyze_correct_1 with pc; auto. - unfold successors; rewrite H; auto with coqlib. - unfold transfer; rewrite H. auto. - - (* Icall *) - exploit transf_ros_correct; eauto. intro FIND'. - TransfInstr; intro. - econstructor; split. - eapply exec_Icall; eauto. apply sig_function_translated; auto. - constructor; auto. constructor; auto. - econstructor; eauto. - intros. apply analyze_correct_1 with pc; auto. - unfold successors; rewrite H; auto with coqlib. - unfold transfer; rewrite H. - apply regs_match_approx_update; auto. simpl. auto. - - (* Itailcall *) - exploit transf_ros_correct; eauto. intros FIND'. - TransfInstr; intro. - econstructor; split. - eapply exec_Itailcall; eauto. apply sig_function_translated; auto. - constructor; auto. - - (* Ialloc *) - TransfInstr; intro. - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- (Vptr b Int.zero)) m'); split. - eapply exec_Ialloc; eauto. - econstructor; eauto. - apply analyze_correct_1 with pc; auto. - unfold successors; rewrite H; auto with coqlib. - unfold transfer; rewrite H. - apply regs_match_approx_update; auto. simpl; auto. - - (* Icond, true *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp ifso rs m); split. - caseEq (cond_strength_reduction (analyze f)!!pc cond args); - intros cond' args' CSR. - assert (eval_condition cond' rs##args' m = Some true). - generalize (cond_strength_reduction_correct - ge (analyze f)!!pc rs MATCH cond args m). - rewrite CSR. intro. congruence. - TransfInstr. rewrite CSR. - caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). - intros b ESC. - generalize (eval_static_condition_correct ge cond _ _ m _ - (approx_regs_val_list _ _ _ args MATCH) ESC); intro. - replace b with true. intro; eapply exec_Inop; eauto. congruence. - intros. eapply exec_Icond_true; eauto. - econstructor; eauto. - apply analyze_correct_1 with pc; auto. - unfold successors; rewrite H; auto with coqlib. - unfold transfer; rewrite H; auto. - - (* Icond, false *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp ifnot rs m); split. - caseEq (cond_strength_reduction (analyze f)!!pc cond args); - intros cond' args' CSR. - assert (eval_condition cond' rs##args' m = Some false). - generalize (cond_strength_reduction_correct - ge (analyze f)!!pc rs MATCH cond args m). - rewrite CSR. intro. congruence. - TransfInstr. rewrite CSR. - caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). - intros b ESC. - generalize (eval_static_condition_correct ge cond _ _ m _ - (approx_regs_val_list _ _ _ args MATCH) ESC); intro. - replace b with false. intro; eapply exec_Inop; eauto. congruence. - intros. eapply exec_Icond_false; eauto. - econstructor; eauto. - apply analyze_correct_1 with pc; auto. - unfold successors; rewrite H; auto with coqlib. - unfold transfer; rewrite H; auto. - - (* Ireturn *) - exists (Returnstate s' (regmap_optget or Vundef rs) (free m stk)); split. - eapply exec_Ireturn; eauto. TransfInstr; auto. - constructor; auto. - - (* internal function *) - simpl. unfold transf_function. - econstructor; split. - eapply exec_function_internal; simpl; eauto. - simpl. econstructor; eauto. - apply analyze_correct_3; auto. - - (* external function *) - simpl. econstructor; split. - eapply exec_function_external; eauto. - constructor; auto. - - (* return *) - inv H3. inv H1. - econstructor; split. - eapply exec_return; eauto. - econstructor; eauto. -Qed. - -Lemma transf_initial_states: - forall st1, initial_state prog st1 -> - exists st2, initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inversion H. - exploit function_ptr_translated; eauto. intro FIND. - exists (Callstate nil (transf_fundef f) nil (Genv.init_mem tprog)); split. - econstructor; eauto. - replace (prog_main tprog) with (prog_main prog). - rewrite symbols_preserved. eauto. - reflexivity. - rewrite <- H2. apply sig_function_translated. - replace (Genv.init_mem tprog) with (Genv.init_mem prog). - constructor. constructor. auto. - symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> final_state st1 r -> final_state st2 r. -Proof. - intros. inv H0. inv H. inv H4. constructor. -Qed. - -(** The preservation of the observable behavior of the program then - follows, using the generic preservation theorem - [Smallstep.simulation_step_preservation]. *) - -Theorem transf_program_correct: - forall (beh: program_behavior), - exec_program prog beh -> exec_program tprog beh. -Proof. - unfold exec_program; intros. - eapply simulation_step_preservation; eauto. - eexact transf_initial_states. - eexact transf_final_states. - exact transf_step_correct. -Qed. - -End PRESERVATION. diff --git a/backend/Conventions.v b/backend/Conventions.v deleted file mode 100644 index b7d931f5..00000000 --- a/backend/Conventions.v +++ /dev/null @@ -1,805 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Function calling conventions and other conventions regarding the use of - machine registers and stack slots. *) - -Require Import Coqlib. -Require Import AST. -Require Import Locations. - -(** * Classification of machine registers *) - -(** Machine registers (type [mreg] in module [Locations]) are divided in - the following groups: -- Temporaries used for spilling, reloading, and parallel move operations. -- Allocatable registers, that can be assigned to RTL pseudo-registers. - These are further divided into: --- Callee-save registers, whose value is preserved across a function call. --- Caller-save registers that can be modified during a function call. - - We follow the PowerPC application binary interface (ABI) in our choice - of callee- and caller-save registers. -*) - -Definition int_caller_save_regs := - R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil. - -Definition float_caller_save_regs := - F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil. - -Definition int_callee_save_regs := - R13 :: R14 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: - R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. - -Definition float_callee_save_regs := - F14 :: F15 :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: - F23 :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 :: nil. - -Definition destroyed_at_call_regs := - int_caller_save_regs ++ float_caller_save_regs. - -Definition destroyed_at_call := - List.map R destroyed_at_call_regs. - -Definition int_temporaries := IT1 :: IT2 :: nil. - -Definition float_temporaries := FT1 :: FT2 :: FT3 :: nil. - -Definition temporaries := - R IT1 :: R IT2 :: R FT1 :: R FT2 :: R FT3 :: nil. - -(** The [index_int_callee_save] and [index_float_callee_save] associate - a unique positive integer to callee-save registers. This integer is - used in [Stacking] to determine where to save these registers in - the activation record if they are used by the current function. *) - -Definition index_int_callee_save (r: mreg) := - match r with - | R13 => 0 | R14 => 1 | R15 => 2 | R16 => 3 - | R17 => 4 | R18 => 5 | R19 => 6 | R20 => 7 - | R21 => 8 | R22 => 9 | R23 => 10 | R24 => 11 - | R25 => 12 | R26 => 13 | R27 => 14 | R28 => 15 - | R29 => 16 | R30 => 17 | R31 => 18 | _ => -1 - end. - -Definition index_float_callee_save (r: mreg) := - match r with - | F14 => 0 | F15 => 1 | F16 => 2 | F17 => 3 - | F18 => 4 | F19 => 5 | F20 => 6 | F21 => 7 - | F22 => 8 | F23 => 9 | F24 => 10 | F25 => 11 - | F26 => 12 | F27 => 13 | F28 => 14 | F29 => 15 - | F30 => 16 | F31 => 17 | _ => -1 - end. - -Ltac ElimOrEq := - match goal with - | |- (?x = ?y) \/ _ -> _ => - let H := fresh in - (intro H; elim H; clear H; - [intro H; rewrite <- H; clear H | ElimOrEq]) - | |- False -> _ => - let H := fresh in (intro H; contradiction) - end. - -Ltac OrEq := - match goal with - | |- (?x = ?x) \/ _ => left; reflexivity - | |- (?x = ?y) \/ _ => right; OrEq - | |- False => fail - end. - -Ltac NotOrEq := - match goal with - | |- (?x = ?y) \/ _ -> False => - let H := fresh in ( - intro H; elim H; clear H; [intro; discriminate | NotOrEq]) - | |- False -> False => - contradiction - end. - -Lemma index_int_callee_save_pos: - forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0. -Proof. - intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega. -Qed. - -Lemma index_float_callee_save_pos: - forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0. -Proof. - intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega. -Qed. - -Lemma index_int_callee_save_pos2: - forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs. -Proof. - destruct r; simpl; intro; omegaContradiction || OrEq. -Qed. - -Lemma index_float_callee_save_pos2: - forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs. -Proof. - destruct r; simpl; intro; omegaContradiction || OrEq. -Qed. - -Lemma index_int_callee_save_inj: - forall r1 r2, - In r1 int_callee_save_regs -> - In r2 int_callee_save_regs -> - r1 <> r2 -> - index_int_callee_save r1 <> index_int_callee_save r2. -Proof. - intros r1 r2. - simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save; - intros; congruence. -Qed. - -Lemma index_float_callee_save_inj: - forall r1 r2, - In r1 float_callee_save_regs -> - In r2 float_callee_save_regs -> - r1 <> r2 -> - index_float_callee_save r1 <> index_float_callee_save r2. -Proof. - intros r1 r2. - simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save; - intros; congruence. -Qed. - -(** The following lemmas show that - (temporaries, destroyed at call, integer callee-save, float callee-save) - is a partition of the set of machine registers. *) - -Lemma int_float_callee_save_disjoint: - list_disjoint int_callee_save_regs float_callee_save_regs. -Proof. - red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate. -Qed. - -Lemma register_classification: - forall r, - (In (R r) temporaries \/ In (R r) destroyed_at_call) \/ - (In r int_callee_save_regs \/ In r float_callee_save_regs). -Proof. - destruct r; - try (left; left; simpl; OrEq); - try (left; right; simpl; OrEq); - try (right; left; simpl; OrEq); - try (right; right; simpl; OrEq). -Qed. - -Lemma int_callee_save_not_destroyed: - forall r, - In (R r) temporaries \/ In (R r) destroyed_at_call -> - ~(In r int_callee_save_regs). -Proof. - intros; red; intros. elim H. - generalize H0. simpl; ElimOrEq; NotOrEq. - generalize H0. simpl; ElimOrEq; NotOrEq. -Qed. - -Lemma float_callee_save_not_destroyed: - forall r, - In (R r) temporaries \/ In (R r) destroyed_at_call -> - ~(In r float_callee_save_regs). -Proof. - intros; red; intros. elim H. - generalize H0. simpl; ElimOrEq; NotOrEq. - generalize H0. simpl; ElimOrEq; NotOrEq. -Qed. - -Lemma int_callee_save_type: - forall r, In r int_callee_save_regs -> mreg_type r = Tint. -Proof. - intro. simpl; ElimOrEq; reflexivity. -Qed. - -Lemma float_callee_save_type: - forall r, In r float_callee_save_regs -> mreg_type r = Tfloat. -Proof. - intro. simpl; ElimOrEq; reflexivity. -Qed. - -Ltac NoRepet := - match goal with - | |- list_norepet nil => - apply list_norepet_nil - | |- list_norepet (?a :: ?b) => - apply list_norepet_cons; [simpl; intuition discriminate | NoRepet] - end. - -Lemma int_callee_save_norepet: - list_norepet int_callee_save_regs. -Proof. - unfold int_callee_save_regs; NoRepet. -Qed. - -Lemma float_callee_save_norepet: - list_norepet float_callee_save_regs. -Proof. - unfold float_callee_save_regs; NoRepet. -Qed. - -(** * Acceptable locations for register allocation *) - -(** The following predicate describes the locations that can be assigned - to an RTL pseudo-register during register allocation: a non-temporary - machine register or a [Local] stack slot are acceptable. *) - -Definition loc_acceptable (l: loc) : Prop := - match l with - | R r => ~(In l temporaries) - | S (Local ofs ty) => ofs >= 0 - | S (Incoming _ _) => False - | S (Outgoing _ _) => False - end. - -Definition locs_acceptable (ll: list loc) : Prop := - forall l, In l ll -> loc_acceptable l. - -Lemma temporaries_not_acceptable: - forall l, loc_acceptable l -> Loc.notin l temporaries. -Proof. - unfold loc_acceptable; destruct l. - simpl. intuition congruence. - destruct s; try contradiction. - intro. simpl. tauto. -Qed. -Hint Resolve temporaries_not_acceptable: locs. - -Lemma locs_acceptable_disj_temporaries: - forall ll, locs_acceptable ll -> Loc.disjoint ll temporaries. -Proof. - intros. apply Loc.notin_disjoint. intros. - apply temporaries_not_acceptable. auto. -Qed. - -Lemma loc_acceptable_noteq_diff: - forall l1 l2, - loc_acceptable l1 -> l1 <> l2 -> Loc.diff l1 l2. -Proof. - unfold loc_acceptable, Loc.diff; destruct l1; destruct l2; - try (destruct s); try (destruct s0); intros; auto; try congruence. - case (zeq z z0); intro. - compare t t0; intro. - subst z0; subst t0; tauto. - tauto. tauto. - contradiction. contradiction. -Qed. - -Lemma loc_acceptable_notin_notin: - forall r ll, - loc_acceptable r -> - ~(In r ll) -> Loc.notin r ll. -Proof. - induction ll; simpl; intros. - auto. - split. apply loc_acceptable_noteq_diff. assumption. - apply sym_not_equal. tauto. - apply IHll. assumption. tauto. -Qed. - -(** * Function calling conventions *) - -(** The functions in this section determine the locations (machine registers - and stack slots) used to communicate arguments and results between the - caller and the callee during function calls. These locations are functions - of the signature of the function and of the call instruction. - Agreement between the caller and the callee on the locations to use - is guaranteed by our dynamic semantics for Cminor and RTL, which demand - that the signature of the call instruction is identical to that of the - called function. - - Calling conventions are largely arbitrary: they must respect the properties - proved in this section (such as no overlapping between the locations - of function arguments), but this leaves much liberty in choosing actual - locations. To ensure binary interoperability of code generated by our - compiler with libraries compiled by another PowerPC compiler, we - implement the standard conventions defined in the PowerPC application - binary interface. *) - -(** ** Location of function result *) - -(** The result value of a function is passed back to the caller in - registers [R3] or [F1], depending on the type of the returned value. - We treat a function without result as a function with one integer result. *) - -Definition loc_result (s: signature) : mreg := - match s.(sig_res) with - | None => R3 - | Some Tint => R3 - | Some Tfloat => F1 - end. - -(** The result location has the type stated in the signature. *) - -Lemma loc_result_type: - forall sig, - mreg_type (loc_result sig) = - match sig.(sig_res) with None => Tint | Some ty => ty end. -Proof. - intros; unfold loc_result. - destruct (sig_res sig). - destruct t; reflexivity. - reflexivity. -Qed. - -(** The result location is acceptable. *) - -Lemma loc_result_acceptable: - forall sig, loc_acceptable (R (loc_result sig)). -Proof. - intros. unfold loc_acceptable. red. - unfold loc_result. destruct (sig_res sig). - destruct t; simpl; NotOrEq. - simpl; NotOrEq. -Qed. - -(** The result location is a caller-save register. *) - -Lemma loc_result_caller_save: - forall (s: signature), In (R (loc_result s)) destroyed_at_call. -Proof. - intros; unfold loc_result. - destruct (sig_res s). - destruct t; simpl; OrEq. - simpl; OrEq. -Qed. - -(** The result location is not a callee-save register. *) - -Lemma loc_result_not_callee_save: - forall (s: signature), - ~(In (loc_result s) int_callee_save_regs \/ In (loc_result s) float_callee_save_regs). -Proof. - intros. generalize (loc_result_caller_save s). - generalize (int_callee_save_not_destroyed (loc_result s)). - generalize (float_callee_save_not_destroyed (loc_result s)). - tauto. -Qed. - -(** ** Location of function arguments *) - -(** The PowerPC ABI states the following convention for passing arguments - to a function: -- The first 8 integer arguments are passed in registers [R3] to [R10]. -- The first 10 float arguments are passed in registers [F1] to [F10]. -- Each float argument passed in a float register ``consumes'' two - integer arguments. -- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively - assigned (1 word for an integer argument, 2 words for a float), - starting at word offset 0. -- Stack space is reserved (as unused [Outgoing] slots) for the arguments - that are passed in registers. - -These conventions are somewhat baroque, but they are mandated by the ABI. -*) - -Fixpoint loc_arguments_rec - (tyl: list typ) (iregl: list mreg) (fregl: list mreg) - (ofs: Z) {struct tyl} : list loc := - match tyl with - | nil => nil - | Tint :: tys => - match iregl with - | nil => - S (Outgoing ofs Tint) :: loc_arguments_rec tys nil fregl (ofs + 1) - | ireg :: iregs => - R ireg :: loc_arguments_rec tys iregs fregl ofs - end - | Tfloat :: tys => - match fregl with - | nil => - S (Outgoing ofs Tfloat) :: loc_arguments_rec tys iregl nil (ofs + 2) - | freg :: fregs => - R freg :: loc_arguments_rec tys (list_drop2 iregl) fregs ofs - end - end. - -Definition int_param_regs := - R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil. -Definition float_param_regs := - F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil. - -(** [loc_arguments s] returns the list of locations where to store arguments - when calling a function with signature [s]. *) - -Definition loc_arguments (s: signature) : list loc := - loc_arguments_rec s.(sig_args) int_param_regs float_param_regs 8. - -(** [size_arguments s] returns the number of [Outgoing] slots used - to call a function with signature [s]. *) - -Fixpoint size_arguments_rec - (tyl: list typ) (iregl: list mreg) (fregl: list mreg) - (ofs: Z) {struct tyl} : Z := - match tyl with - | nil => ofs - | Tint :: tys => - match iregl with - | nil => size_arguments_rec tys nil fregl (ofs + 1) - | ireg :: iregs => size_arguments_rec tys iregs fregl ofs - end - | Tfloat :: tys => - match fregl with - | nil => size_arguments_rec tys iregl nil (ofs + 2) - | freg :: fregs => size_arguments_rec tys (list_drop2 iregl) fregs ofs - end - end. - -Definition size_arguments (s: signature) : Z := - size_arguments_rec s.(sig_args) int_param_regs float_param_regs 8. - -(** A tail-call is possible for a signature if the corresponding - arguments are all passed in registers. *) - -Definition tailcall_possible (s: signature) : Prop := - forall l, In l (loc_arguments s) -> - match l with R _ => True | S _ => False end. - -(** Argument locations are either non-temporary registers or [Outgoing] - stack slots at nonnegative offsets. *) - -Definition loc_argument_acceptable (l: loc) : Prop := - match l with - | R r => ~(In l temporaries) - | S (Outgoing ofs ty) => ofs >= 0 - | _ => False - end. - -Remark loc_arguments_rec_charact: - forall tyl iregl fregl ofs l, - In l (loc_arguments_rec tyl iregl fregl ofs) -> - match l with - | R r => In r iregl \/ In r fregl - | S (Outgoing ofs' ty) => ofs' >= ofs - | S _ => False - end. -Proof. - induction tyl; simpl loc_arguments_rec; intros. - elim H. - destruct a. - destruct iregl; elim H; intro. - subst l. omega. - generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega. - subst l. auto with coqlib. - generalize (IHtyl _ _ _ _ H0). destruct l; auto. simpl; intuition. - destruct fregl; elim H; intro. - subst l. omega. - generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega. - subst l. auto with coqlib. - generalize (IHtyl _ _ _ _ H0). destruct l; auto. - intros [A|B]. left; apply list_drop2_incl; auto. right; auto with coqlib. -Qed. - -Lemma loc_arguments_acceptable: - forall (s: signature) (r: loc), - In r (loc_arguments s) -> loc_argument_acceptable r. -Proof. - unfold loc_arguments; intros. - generalize (loc_arguments_rec_charact _ _ _ _ _ H). - destruct r. - intro H0; elim H0. simpl. unfold not. ElimOrEq; NotOrEq. - simpl. unfold not. ElimOrEq; NotOrEq. - destruct s0; try contradiction. - simpl. omega. -Qed. -Hint Resolve loc_arguments_acceptable: locs. - -(** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *) - -Remark loc_arguments_rec_notin_reg: - forall tyl iregl fregl ofs r, - ~(In r iregl) -> ~(In r fregl) -> - Loc.notin (R r) (loc_arguments_rec tyl iregl fregl ofs). -Proof. - induction tyl; simpl; intros. - auto. - destruct a. - destruct iregl; simpl. auto. - simpl in H. split. apply sym_not_equal. tauto. - apply IHtyl. tauto. tauto. - destruct fregl; simpl. auto. - simpl in H0. split. apply sym_not_equal. tauto. - apply IHtyl. - red; intro. apply H. apply list_drop2_incl. auto. - tauto. -Qed. - -Remark loc_arguments_rec_notin_local: - forall tyl iregl fregl ofs ofs0 ty0, - Loc.notin (S (Local ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). -Proof. - induction tyl; simpl; intros. - auto. - destruct a. - destruct iregl; simpl; auto. - destruct fregl; simpl; auto. -Qed. - -Remark loc_arguments_rec_notin_outgoing: - forall tyl iregl fregl ofs ofs0 ty0, - ofs0 + typesize ty0 <= ofs -> - Loc.notin (S (Outgoing ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). -Proof. - induction tyl; simpl; intros. - auto. - destruct a. - destruct iregl; simpl. - split. omega. eapply IHtyl. omega. - auto. - destruct fregl; simpl. - split. omega. eapply IHtyl. omega. - auto. -Qed. - -Lemma loc_arguments_norepet: - forall (s: signature), Loc.norepet (loc_arguments s). -Proof. - assert (forall tyl iregl fregl ofs, - list_norepet iregl -> - list_norepet fregl -> - list_disjoint iregl fregl -> - Loc.norepet (loc_arguments_rec tyl iregl fregl ofs)). - induction tyl; simpl; intros. - constructor. - destruct a. - destruct iregl; constructor. - apply loc_arguments_rec_notin_outgoing. simpl; omega. auto. - apply loc_arguments_rec_notin_reg. inversion H. auto. - apply list_disjoint_notin with (m :: iregl); auto with coqlib. - apply IHtyl. inv H; auto. auto. - eapply list_disjoint_cons_left; eauto. - destruct fregl; constructor. - apply loc_arguments_rec_notin_outgoing. simpl; omega. auto. - apply loc_arguments_rec_notin_reg. - red; intro. apply (H1 m m). apply list_drop2_incl; auto. - auto with coqlib. auto. inv H0; auto. - apply IHtyl. apply list_drop2_norepet; auto. - inv H0; auto. - red; intros. apply H1. apply list_drop2_incl; auto. auto with coqlib. - - intro. unfold loc_arguments. apply H. - unfold int_param_regs. NoRepet. - unfold float_param_regs. NoRepet. - red; intros x y; simpl. ElimOrEq; ElimOrEq; discriminate. -Qed. - -(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) - -Remark size_arguments_rec_above: - forall tyl iregl fregl ofs0, - ofs0 <= size_arguments_rec tyl iregl fregl ofs0. -Proof. - induction tyl; simpl; intros. - omega. - destruct a. - destruct iregl. apply Zle_trans with (ofs0 + 1); auto; omega. auto. - destruct fregl. apply Zle_trans with (ofs0 + 2); auto; omega. auto. -Qed. - -Lemma size_arguments_above: - forall s, size_arguments s >= 0. -Proof. - intros; unfold size_arguments. apply Zle_ge. apply Zle_trans with 8. omega. - apply size_arguments_rec_above. -Qed. - -Lemma loc_arguments_bounded: - forall (s: signature) (ofs: Z) (ty: typ), - In (S (Outgoing ofs ty)) (loc_arguments s) -> - ofs + typesize ty <= size_arguments s. -Proof. - intros. - assert (forall tyl iregl fregl ofs0, - In (S (Outgoing ofs ty)) (loc_arguments_rec tyl iregl fregl ofs0) -> - ofs + typesize ty <= size_arguments_rec tyl iregl fregl ofs0). - induction tyl; simpl; intros. - elim H0. - destruct a. destruct iregl; elim H0; intro. - inv H1. simpl. apply size_arguments_rec_above. auto. - discriminate. auto. - destruct fregl; elim H0; intro. - inv H1. simpl. apply size_arguments_rec_above. auto. - discriminate. auto. - unfold size_arguments. eapply H0. unfold loc_arguments in H. eauto. -Qed. - -(** Temporary registers do not overlap with argument locations. *) - -Lemma loc_arguments_not_temporaries: - forall sig, Loc.disjoint (loc_arguments sig) temporaries. -Proof. - intros; red; intros x1 x2 H. - generalize (loc_arguments_rec_charact _ _ _ _ _ H). - destruct x1. - intro H0; elim H0; simpl; (ElimOrEq; ElimOrEq; congruence). - destruct s; try contradiction. intro. - simpl; ElimOrEq; auto. -Qed. -Hint Resolve loc_arguments_not_temporaries: locs. - -(** Argument registers are caller-save. *) - -Lemma arguments_caller_save: - forall sig r, - In (R r) (loc_arguments sig) -> In (R r) destroyed_at_call. -Proof. - unfold loc_arguments; intros. - elim (loc_arguments_rec_charact _ _ _ _ _ H); simpl. - ElimOrEq; intuition. - ElimOrEq; intuition. -Qed. - -(** Callee-save registers do not overlap with argument locations. *) - -Lemma arguments_not_preserved: - forall sig l, - Loc.notin l destroyed_at_call -> loc_acceptable l -> - Loc.notin l (loc_arguments sig). -Proof. - intros. unfold loc_arguments. destruct l. - apply loc_arguments_rec_notin_reg. - generalize (Loc.notin_not_in _ _ H). intro; red; intro. - apply H1. generalize H2. simpl. ElimOrEq; OrEq. - generalize (Loc.notin_not_in _ _ H). intro; red; intro. - apply H1. generalize H2. simpl. ElimOrEq; OrEq. - destruct s; simpl in H0; try contradiction. - apply loc_arguments_rec_notin_local. -Qed. -Hint Resolve arguments_not_preserved: locs. - -(** Argument locations agree in number with the function signature. *) - -Lemma loc_arguments_length: - forall sig, - List.length (loc_arguments sig) = List.length sig.(sig_args). -Proof. - assert (forall tyl iregl fregl ofs, - List.length (loc_arguments_rec tyl iregl fregl ofs) = List.length tyl). - induction tyl; simpl; intros. - auto. - destruct a. - destruct iregl; simpl; decEq; auto. - destruct fregl; simpl; decEq; auto. - intros. unfold loc_arguments. auto. -Qed. - -(** Argument locations agree in types with the function signature. *) - -Lemma loc_arguments_type: - forall sig, List.map Loc.type (loc_arguments sig) = sig.(sig_args). -Proof. - assert (forall tyl iregl fregl ofs, - (forall r, In r iregl -> mreg_type r = Tint) -> - (forall r, In r fregl -> mreg_type r = Tfloat) -> - List.map Loc.type (loc_arguments_rec tyl iregl fregl ofs) = tyl). - induction tyl; simpl; intros. - auto. - destruct a; [destruct iregl|destruct fregl]; simpl; - f_equal; eauto with coqlib. - apply IHtyl. intros. apply H. apply list_drop2_incl; auto. - eauto with coqlib. - - intros. unfold loc_arguments. apply H. - intro; simpl. ElimOrEq; reflexivity. - intro; simpl. ElimOrEq; reflexivity. -Qed. - -(** There is no partial overlap between an argument location and an - acceptable location: they are either identical or disjoint. *) - -Lemma no_overlap_arguments: - forall args sg, - locs_acceptable args -> - Loc.no_overlap args (loc_arguments sg). -Proof. - unfold Loc.no_overlap; intros. - generalize (H r H0). - generalize (loc_arguments_acceptable _ _ H1). - destruct s; destruct r; simpl. - intros. case (mreg_eq m0 m); intro. left; congruence. tauto. - intros. right; destruct s; auto. - intros. right. auto. - destruct s; try tauto. destruct s0; tauto. -Qed. - -(** Decide whether a tailcall is possible. *) - -Definition tailcall_is_possible (sg: signature) : bool := - let fix tcisp (l: list loc) := - match l with - | nil => true - | R _ :: l' => tcisp l' - | S _ :: l' => false - end - in tcisp (loc_arguments sg). - -Lemma tailcall_is_possible_correct: - forall s, tailcall_is_possible s = true -> tailcall_possible s. -Proof. - intro s. unfold tailcall_is_possible, tailcall_possible. - generalize (loc_arguments s). induction l; simpl; intros. - elim H0. - destruct a. - destruct H0. subst l0. auto. apply IHl. auto. auto. discriminate. -Qed. - -(** ** Location of function parameters *) - -(** A function finds the values of its parameter in the same locations - where its caller stored them, except that the stack-allocated arguments, - viewed as [Outgoing] slots by the caller, are accessed via [Incoming] - slots (at the same offsets and types) in the callee. *) - -Definition parameter_of_argument (l: loc) : loc := - match l with - | S (Outgoing n ty) => S (Incoming n ty) - | _ => l - end. - -Definition loc_parameters (s: signature) := - List.map parameter_of_argument (loc_arguments s). - -Lemma loc_parameters_type: - forall sig, List.map Loc.type (loc_parameters sig) = sig.(sig_args). -Proof. - intros. unfold loc_parameters. - rewrite list_map_compose. - rewrite <- loc_arguments_type. - apply list_map_exten. - intros. destruct x; simpl. auto. - destruct s; reflexivity. -Qed. - -Lemma loc_parameters_length: - forall sg, List.length (loc_parameters sg) = List.length sg.(sig_args). -Proof. - intros. unfold loc_parameters. rewrite list_length_map. - apply loc_arguments_length. -Qed. - -Lemma loc_parameters_not_temporaries: - forall sig, Loc.disjoint (loc_parameters sig) temporaries. -Proof. - intro; red; intros. - unfold loc_parameters in H. - elim (list_in_map_inv _ _ _ H). intros y [EQ IN]. - generalize (loc_arguments_not_temporaries sig y x2 IN H0). - subst x1. destruct x2. - destruct y; simpl. auto. destruct s; auto. - byContradiction. generalize H0. simpl. NotOrEq. -Qed. - -Lemma no_overlap_parameters: - forall params sg, - locs_acceptable params -> - Loc.no_overlap (loc_parameters sg) params. -Proof. - unfold Loc.no_overlap; intros. - unfold loc_parameters in H0. - elim (list_in_map_inv _ _ _ H0). intros t [EQ IN]. - rewrite EQ. - generalize (loc_arguments_acceptable _ _ IN). - generalize (H s H1). - destruct s; destruct t; simpl. - intros. case (mreg_eq m0 m); intro. left; congruence. tauto. - intros. right; destruct s; simpl; auto. - intros; right; auto. - destruct s; try tauto. destruct s0; try tauto. - intros; simpl. tauto. -Qed. - -(** ** Location of argument and result for dynamic memory allocation *) - -Definition loc_alloc_argument := R3. -Definition loc_alloc_result := R3. diff --git a/backend/Linear.v b/backend/Linear.v index 900b6a50..629dcc53 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -337,7 +337,7 @@ Inductive initial_state (p: program): state -> Prop := Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r, - rs (R R3) = Vint r -> + rs (R (Conventions.loc_result (mksignature nil (Some Tint)))) = Vint r -> final_state (Returnstate nil rs m) r. Definition exec_program (p: program) (beh: program_behavior) : Prop := diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml new file mode 100644 index 00000000..2f2333fb --- /dev/null +++ b/backend/Linearizeaux.ml @@ -0,0 +1,85 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open BinPos +open Coqlib +open Datatypes +open LTL +open Lattice +open CList +open Maps +open Camlcoq + +(* Trivial enumeration, in decreasing order of PC *) + +(*** +let enumerate_aux f reach = + positive_rec + Coq_nil + (fun pc nodes -> + if PMap.get pc reach + then Coq_cons (pc, nodes) + else nodes) + f.fn_nextpc +***) + +(* More clever enumeration that flattens basic blocks *) + +let rec int_of_pos = function + | Coq_xI p -> (int_of_pos p lsl 1) + 1 + | Coq_xO p -> int_of_pos p lsl 1 + | Coq_xH -> 1 + +let rec pos_of_int n = + if n = 0 then assert false else + if n = 1 then Coq_xH else + if n land 1 = 0 + then Coq_xO (pos_of_int (n lsr 1)) + else Coq_xI (pos_of_int (n lsr 1)) + +(* Build the enumeration *) + +module IntSet = Set.Make(struct type t = int let compare = compare end) + +let enumerate_aux f reach = + let enum = ref [] in + let emitted = Array.make (int_of_pos f.fn_nextpc) false in + let rec emit_block pending pc = + let npc = int_of_pos pc in + if emitted.(npc) + then emit_restart pending + else begin + enum := pc :: !enum; + emitted.(npc) <- true; + match PTree.get pc f.fn_code with + | None -> assert false + | Some i -> + match i with + | Lnop s -> emit_block pending s + | Lop (op, args, res, s) -> emit_block pending s + | Lload (chunk, addr, args, dst, s) -> emit_block pending s + | Lstore (chunk, addr, args, src, s) -> emit_block pending s + | Lcall (sig0, ros, args, res, s) -> emit_block pending s + | Ltailcall (sig0, ros, args) -> emit_restart pending + | Lalloc (arg, res, s) -> emit_block pending s + | Lcond (cond, args, ifso, ifnot) -> + emit_restart (IntSet.add (int_of_pos ifso) + (IntSet.add (int_of_pos ifnot) pending)) + | Lreturn optarg -> emit_restart pending + end + and emit_restart pending = + if not (IntSet.is_empty pending) then begin + let npc = IntSet.max_elt pending in + emit_block (IntSet.remove npc pending) (pos_of_int npc) + end in + emit_block IntSet.empty f.fn_entrypoint; + CList.rev !enum diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index 3451cdb5..8378332e 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -546,8 +546,9 @@ Proof. exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. econstructor; split. eapply plus_left'. - eapply exec_Lload; eauto. + apply exec_Lload with a. rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + eauto. eapply add_branch_correct; eauto. eapply is_tail_add_branch. eapply is_tail_cons_left. eapply is_tail_find_label. eauto. @@ -562,8 +563,9 @@ Proof. exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. econstructor; split. eapply plus_left'. - eapply exec_Lstore; eauto. + apply exec_Lstore with a. rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + eauto. eapply add_branch_correct; eauto. eapply is_tail_add_branch. eapply is_tail_cons_left. eapply is_tail_find_label. eauto. diff --git a/backend/Locations.v b/backend/Locations.v index b03657c0..ca2f5272 100644 --- a/backend/Locations.v +++ b/backend/Locations.v @@ -17,102 +17,17 @@ Require Import Coqlib. Require Import Maps. Require Import AST. Require Import Values. +Require Export Machregs. (** * Representation of locations *) (** A location is either a processor register or (an abstract designation of) a slot in the activation record of the current function. *) -(** ** Machine registers *) - -(** The following type defines the machine registers that can be referenced - as locations. These include: -- Integer registers that can be allocated to RTL pseudo-registers ([Rxx]). -- Floating-point registers that can be allocated to RTL pseudo-registers - ([Fxx]). -- Two integer registers, not allocatable, reserved as temporaries for - spilling and reloading ([IT1, IT2]). -- Two float registers, not allocatable, reserved as temporaries for - spilling and reloading ([FT1, FT2]). - - The type [mreg] does not include special-purpose machine registers - such as the stack pointer and the condition codes. *) - -Inductive mreg: Set := - (** Allocatable integer regs *) - | R3: mreg | R4: mreg | R5: mreg | R6: mreg - | R7: mreg | R8: mreg | R9: mreg | R10: mreg - | R13: mreg | R14: mreg | R15: mreg | R16: mreg - | R17: mreg | R18: mreg | R19: mreg | R20: mreg - | R21: mreg | R22: mreg | R23: mreg | R24: mreg - | R25: mreg | R26: mreg | R27: mreg | R28: mreg - | R29: mreg | R30: mreg | R31: mreg - (** Allocatable float regs *) - | F1: mreg | F2: mreg | F3: mreg | F4: mreg - | F5: mreg | F6: mreg | F7: mreg | F8: mreg - | F9: mreg | F10: mreg | F14: mreg | F15: mreg - | F16: mreg | F17: mreg | F18: mreg | F19: mreg - | F20: mreg | F21: mreg | F22: mreg | F23: mreg - | F24: mreg | F25: mreg | F26: mreg | F27: mreg - | F28: mreg | F29: mreg | F30: mreg | F31: mreg - (** Integer temporaries *) - | IT1: mreg (* R11 *) | IT2: mreg (* R0 *) - (** Float temporaries *) - | FT1: mreg (* F11 *) | FT2: mreg (* F12 *) | FT3: mreg (* F0 *). - -Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. -Proof. decide equality. Qed. - -Definition mreg_type (r: mreg): typ := - match r with - | R3 => Tint | R4 => Tint | R5 => Tint | R6 => Tint - | R7 => Tint | R8 => Tint | R9 => Tint | R10 => Tint - | R13 => Tint | R14 => Tint | R15 => Tint | R16 => Tint - | R17 => Tint | R18 => Tint | R19 => Tint | R20 => Tint - | R21 => Tint | R22 => Tint | R23 => Tint | R24 => Tint - | R25 => Tint | R26 => Tint | R27 => Tint | R28 => Tint - | R29 => Tint | R30 => Tint | R31 => Tint - | F1 => Tfloat | F2 => Tfloat | F3 => Tfloat | F4 => Tfloat - | F5 => Tfloat | F6 => Tfloat | F7 => Tfloat | F8 => Tfloat - | F9 => Tfloat | F10 => Tfloat | F14 => Tfloat | F15 => Tfloat - | F16 => Tfloat | F17 => Tfloat | F18 => Tfloat | F19 => Tfloat - | F20 => Tfloat | F21 => Tfloat | F22 => Tfloat | F23 => Tfloat - | F24 => Tfloat | F25 => Tfloat | F26 => Tfloat | F27 => Tfloat - | F28 => Tfloat | F29 => Tfloat | F30 => Tfloat | F31 => Tfloat - | IT1 => Tint | IT2 => Tint - | FT1 => Tfloat | FT2 => Tfloat | FT3 => Tfloat - end. +(** ** Processor registers *) -Open Scope positive_scope. - -Module IndexedMreg <: INDEXED_TYPE. - Definition t := mreg. - Definition eq := mreg_eq. - Definition index (r: mreg): positive := - match r with - | R3 => 1 | R4 => 2 | R5 => 3 | R6 => 4 - | R7 => 5 | R8 => 6 | R9 => 7 | R10 => 8 - | R13 => 9 | R14 => 10 | R15 => 11 | R16 => 12 - | R17 => 13 | R18 => 14 | R19 => 15 | R20 => 16 - | R21 => 17 | R22 => 18 | R23 => 19 | R24 => 20 - | R25 => 21 | R26 => 22 | R27 => 23 | R28 => 24 - | R29 => 25 | R30 => 26 | R31 => 27 - | F1 => 28 | F2 => 29 | F3 => 30 | F4 => 31 - | F5 => 32 | F6 => 33 | F7 => 34 | F8 => 35 - | F9 => 36 | F10 => 37 | F14 => 38 | F15 => 39 - | F16 => 40 | F17 => 41 | F18 => 42 | F19 => 43 - | F20 => 44 | F21 => 45 | F22 => 46 | F23 => 47 - | F24 => 48 | F25 => 49 | F26 => 50 | F27 => 51 - | F28 => 52 | F29 => 53 | F30 => 54 | F31 => 55 - | IT1 => 56 | IT2 => 57 - | FT1 => 58 | FT2 => 59 | FT3 => 60 - end. - Lemma index_inj: - forall r1 r2, index r1 = index r2 -> r1 = r2. - Proof. - destruct r1; destruct r2; simpl; intro; discriminate || reflexivity. - Qed. -End IndexedMreg. +(** Processor registers usable for register allocation are defined + in module [Machregs]. *) (** ** Slots in activation records *) diff --git a/backend/Machabstr.v b/backend/Machabstr.v index 9ef75ec8..e145c896 100644 --- a/backend/Machabstr.v +++ b/backend/Machabstr.v @@ -26,7 +26,7 @@ Require Import Op. Require Import Locations. Require Conventions. Require Import Mach. -Require Stacking. +Require Stacklayout. (** This file defines the "abstract" semantics for the Mach intermediate language, as opposed to the more concrete @@ -134,7 +134,7 @@ Inductive extcall_arg: regset -> frame -> loc -> val -> Prop := | extcall_arg_reg: forall rs fr r, extcall_arg rs fr (R r) (rs r) | extcall_arg_stack: forall rs fr ofs ty v, - get_slot fr ty (Int.signed (Int.repr (Stacking.fe_ofs_arg + 4 * ofs))) v -> + get_slot fr ty (Int.signed (Int.repr (Stacklayout.fe_ofs_arg + 4 * ofs))) v -> extcall_arg rs fr (S (Outgoing ofs ty)) v. Inductive extcall_args: regset -> frame -> list loc -> list val -> Prop := @@ -323,7 +323,7 @@ Inductive initial_state (p: program): state -> Prop := Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r, - rs R3 = Vint r -> + rs (Conventions.loc_result (mksignature nil (Some Tint))) = Vint r -> final_state (Returnstate nil rs m) r. Definition exec_program (p: program) (beh: program_behavior) : Prop := diff --git a/backend/Machabstr2concr.v b/backend/Machabstr2concr.v index 2dd3134f..7eae610b 100644 --- a/backend/Machabstr2concr.v +++ b/backend/Machabstr2concr.v @@ -27,7 +27,7 @@ Require Import Mach. Require Import Machtyping. Require Import Machabstr. Require Import Machconcr. -Require Import PPCgenretaddr. +Require Import Asmgenretaddr. (** Two semantics were defined for the Mach intermediate language: - The concrete semantics (file [Mach]), where the whole activation @@ -43,7 +43,7 @@ Require Import PPCgenretaddr. abstract semantics, it also executes with the same behaviour in the concrete semantics. This result bridges the correctness proof in file [Stackingproof] (which uses the abstract Mach semantics - as output) and that in file [PPCgenproof] (which uses the concrete + as output) and that in file [Asmgenproof] (which uses the concrete Mach semantics as input). *) diff --git a/backend/Machconcr.v b/backend/Machconcr.v index 5ca3cad7..41216d25 100644 --- a/backend/Machconcr.v +++ b/backend/Machconcr.v @@ -25,8 +25,8 @@ Require Import Op. Require Import Locations. Require Conventions. Require Import Mach. -Require Stacking. -Require PPCgenretaddr. +Require Stacklayout. +Require Asmgenretaddr. (** In the concrete semantics for Mach, the three stack-related Mach instructions are interpreted as memory accesses relative to the @@ -45,14 +45,14 @@ In addition to this linking of activation records, the concrete semantics also make provisions for storing a back link at offset [f.(fn_link_ofs)] from the stack pointer, and a return address at offset [f.(fn_retaddr_ofs)]. The latter stack location will be used -by the PPC code generated by [PPCgen] to save the return address into +by the Asm code generated by [Asmgen] to save the return address into the caller at the beginning of a function, then restore it and jump to it at the end of a function. The Mach concrete semantics does not attach any particular meaning to the pointer stored in this reserved location, but makes sure that it is preserved during execution of a function. The [return_address_offset] predicate from module -[PPCgenretaddr] is used to guess the value of the return address that -the PPC code generated later will store in the reserved location. +[Asmgenretaddr] is used to guess the value of the return address that +the Asm code generated later will store in the reserved location. *) Definition chunk_of_type (ty: typ) := @@ -70,7 +70,7 @@ Inductive extcall_arg: regset -> mem -> val -> loc -> val -> Prop := | extcall_arg_reg: forall rs m sp r, extcall_arg rs m sp (R r) (rs r) | extcall_arg_stack: forall rs m sp ofs ty v, - load_stack m sp ty (Int.repr (Stacking.fe_ofs_arg + 4 * ofs)) = Some v -> + load_stack m sp ty (Int.repr (Stacklayout.fe_ofs_arg + 4 * ofs)) = Some v -> extcall_arg rs m sp (S (Outgoing ofs ty)) v. Inductive extcall_args: regset -> mem -> val -> list loc -> list val -> Prop := @@ -90,7 +90,7 @@ Inductive stackframe: Set := | Stackframe: forall (f: block) (**r pointer to calling function *) (sp: val) (**r stack pointer in calling function *) - (retaddr: val) (**r PPC return address in calling function *) + (retaddr: val) (**r Asm return address in calling function *) (c: code), (**r program point in calling function *) stackframe. @@ -174,7 +174,7 @@ Inductive step: state -> trace -> state -> Prop := forall s fb sp sig ros c rs m f f' ra, find_function_ptr ge ros rs = Some f' -> Genv.find_funct_ptr ge fb = Some (Internal f) -> - PPCgenretaddr.return_address_offset f c ra -> + Asmgenretaddr.return_address_offset f c ra -> step (State s fb sp (Mcall sig ros :: c) rs m) E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) f' rs m) @@ -252,7 +252,7 @@ Inductive initial_state (p: program): state -> Prop := Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r, - rs R3 = Vint r -> + rs (Conventions.loc_result (mksignature nil (Some Tint))) = Vint r -> final_state (Returnstate nil rs m) r. Definition exec_program (p: program) (beh: program_behavior) : Prop := diff --git a/backend/Op.v b/backend/Op.v deleted file mode 100644 index 5665d725..00000000 --- a/backend/Op.v +++ /dev/null @@ -1,906 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Operators and addressing modes. The abstract syntax and dynamic - semantics for the CminorSel, RTL, LTL and Mach languages depend on the - following types, defined in this library: -- [condition]: boolean conditions for conditional branches; -- [operation]: arithmetic and logical operations; -- [addressing]: addressing modes for load and store operations. - - These types are PowerPC-specific and correspond roughly to what the - processor can compute in one instruction. In other terms, these - types reflect the state of the program after instruction selection. - For a processor-independent set of operations, see the abstract - syntax and dynamic semantics of the Cminor language. -*) - -Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Globalenvs. - -Set Implicit Arguments. - -(** Conditions (boolean-valued operators). *) - -Inductive condition : Set := - | Ccomp: comparison -> condition (**r signed integer comparison *) - | Ccompu: comparison -> condition (**r unsigned integer comparison *) - | Ccompimm: comparison -> int -> condition (**r signed integer comparison with a constant *) - | Ccompuimm: comparison -> int -> condition (**r unsigned integer comparison with a constant *) - | Ccompf: comparison -> condition (**r floating-point comparison *) - | Cnotcompf: comparison -> condition (**r negation of a floating-point comparison *) - | Cmaskzero: int -> condition (**r test [(arg & constant) == 0] *) - | Cmasknotzero: int -> condition. (**r test [(arg & constant) != 0] *) - -(** Arithmetic and logical operations. In the descriptions, [rd] is the - result of the operation and [r1], [r2], etc, are the arguments. *) - -Inductive operation : Set := - | Omove: operation (**r [rd = r1] *) - | Ointconst: int -> operation (**r [rd] is set to the given integer constant *) - | Ofloatconst: float -> operation (**r [rd] is set to the given float constant *) - | Oaddrsymbol: ident -> int -> operation (**r [rd] is set to the the address of the symbol plus the offset *) - | Oaddrstack: int -> operation (**r [rd] is set to the stack pointer plus the given offset *) -(*c Integer arithmetic: *) - | Ocast8signed: operation (**r [rd] is 8-bit sign extension of [r1] *) - | Ocast8unsigned: operation (**r [rd] is 8-bit zero extension of [r1] *) - | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) - | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *) - | Oadd: operation (**r [rd = r1 + r2] *) - | Oaddimm: int -> operation (**r [rd = r1 + n] *) - | Osub: operation (**r [rd = r1 - r2] *) - | Osubimm: int -> operation (**r [rd = n - r1] *) - | Omul: operation (**r [rd = r1 * r2] *) - | Omulimm: int -> operation (**r [rd = r1 * n] *) - | Odiv: operation (**r [rd = r1 / r2] (signed) *) - | Odivu: operation (**r [rd = r1 / r2] (unsigned) *) - | Oand: operation (**r [rd = r1 & r2] *) - | Oandimm: int -> operation (**r [rd = r1 & n] *) - | Oor: operation (**r [rd = r1 | r2] *) - | Oorimm: int -> operation (**r [rd = r1 | n] *) - | Oxor: operation (**r [rd = r1 ^ r2] *) - | Oxorimm: int -> operation (**r [rd = r1 ^ n] *) - | Onand: operation (**r [rd = ~(r1 & r2)] *) - | Onor: operation (**r [rd = ~(r1 | r2)] *) - | Onxor: operation (**r [rd = ~(r1 ^ r2)] *) - | Oshl: operation (**r [rd = r1 << r2] *) - | Oshr: operation (**r [rd = r1 >> r2] (signed) *) - | Oshrimm: int -> operation (**r [rd = r1 >> n] (signed) *) - | Oshrximm: int -> operation (**r [rd = r1 / 2^n] (signed) *) - | Oshru: operation (**r [rd = r1 >> r2] (unsigned) *) - | Orolm: int -> int -> operation (**r rotate left and mask *) -(*c Floating-point arithmetic: *) - | Onegf: operation (**r [rd = - r1] *) - | Oabsf: operation (**r [rd = abs(r1)] *) - | Oaddf: operation (**r [rd = r1 + r2] *) - | Osubf: operation (**r [rd = r1 - r2] *) - | Omulf: operation (**r [rd = r1 * r2] *) - | Odivf: operation (**r [rd = r1 / r2] *) - | Omuladdf: operation (**r [rd = r1 * r2 + r3] *) - | Omulsubf: operation (**r [rd = r1 * r2 - r3] *) - | Osingleoffloat: operation (**r [rd] is [r1] truncated to single-precision float *) -(*c Conversions between int and float: *) - | Ointoffloat: operation (**r [rd = signed_int_of_float(r1)] *) - | Ointuoffloat: operation (**r [rd = unsigned_int_of_float(r1)] *) - | Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] *) - | Ofloatofintu: operation (**r [rd = float_of_unsigned_int(r1)] *) -(*c Boolean tests: *) - | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) - -(** Addressing modes. [r1], [r2], etc, are the arguments to the - addressing. *) - -Inductive addressing: Set := - | Aindexed: int -> addressing (**r Address is [r1 + offset] *) - | Aindexed2: addressing (**r Address is [r1 + r2] *) - | Aglobal: ident -> int -> addressing (**r Address is [symbol + offset] *) - | Abased: ident -> int -> addressing (**r Address is [symbol + offset + r1] *) - | Ainstack: int -> addressing. (**r Address is [stack_pointer + offset] *) - -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation is undefined: - wrong number of arguments, arguments of the wrong types, undefined - operations such as division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) - -Definition eval_compare_mismatch (c: comparison) : option bool := - match c with Ceq => Some false | Cne => Some true | _ => None end. - -Definition eval_condition (cond: condition) (vl: list val) (m: mem): - option bool := - match cond, vl with - | Ccomp c, Vint n1 :: Vint n2 :: nil => - Some (Int.cmp c n1 n2) - | Ccomp c, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if valid_pointer m b1 (Int.signed n1) - && valid_pointer m b2 (Int.signed n2) then - if eq_block b1 b2 - then Some (Int.cmp c n1 n2) - else eval_compare_mismatch c - else None - | Ccomp c, Vptr b1 n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then eval_compare_mismatch c else None - | Ccomp c, Vint n1 :: Vptr b2 n2 :: nil => - if Int.eq n1 Int.zero then eval_compare_mismatch c else None - | Ccompu c, Vint n1 :: Vint n2 :: nil => - Some (Int.cmpu c n1 n2) - | Ccompimm c n, Vint n1 :: nil => - Some (Int.cmp c n1 n) - | Ccompimm c n, Vptr b1 n1 :: nil => - if Int.eq n Int.zero then eval_compare_mismatch c else None - | Ccompuimm c n, Vint n1 :: nil => - Some (Int.cmpu c n1 n) - | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil => - Some (Float.cmp c f1 f2) - | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil => - Some (negb (Float.cmp c f1 f2)) - | Cmaskzero n, Vint n1 :: nil => - Some (Int.eq (Int.and n1 n) Int.zero) - | Cmasknotzero n, Vint n1 :: nil => - Some (negb (Int.eq (Int.and n1 n) Int.zero)) - | _, _ => - None - end. - -Definition offset_sp (sp: val) (delta: int) : option val := - match sp with - | Vptr b n => Some (Vptr b (Int.add n delta)) - | _ => None - end. - -Definition eval_operation - (F: Set) (genv: Genv.t F) (sp: val) - (op: operation) (vl: list val) (m: mem): option val := - match op, vl with - | Omove, v1::nil => Some v1 - | Ointconst n, nil => Some (Vint n) - | Ofloatconst n, nil => Some (Vfloat n) - | Oaddrsymbol s ofs, nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b ofs) - end - | Oaddrstack ofs, nil => offset_sp sp ofs - | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) - | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1) - | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) - | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1) - | Oadd, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 n2)) - | Oadd, Vint n1 :: Vptr b2 n2 :: nil => Some (Vptr b2 (Int.add n2 n1)) - | Oadd, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 n2)) - | Oaddimm n, Vint n1 :: nil => Some (Vint (Int.add n1 n)) - | Oaddimm n, Vptr b1 n1 :: nil => Some (Vptr b1 (Int.add n1 n)) - | Osub, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None - | Osubimm n, Vint n1 :: nil => Some (Vint (Int.sub n n1)) - | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2)) - | Omulimm n, Vint n1 :: nil => Some (Vint (Int.mul n1 n)) - | Odiv, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2)) - | Odivu, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2)) - | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2)) - | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n)) - | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2)) - | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n)) - | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2)) - | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n)) - | Onand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.and n1 n2))) - | Onor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.or n1 n2))) - | Onxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.xor n1 n2))) - | Oshl, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shl n1 n2)) else None - | Oshr, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shr n1 n2)) else None - | Oshrimm n, Vint n1 :: nil => - if Int.ltu n (Int.repr 32) then Some (Vint (Int.shr n1 n)) else None - | Oshrximm n, Vint n1 :: nil => - if Int.ltu n (Int.repr 32) then Some (Vint (Int.shrx n1 n)) else None - | Oshru, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shru n1 n2)) else None - | Orolm amount mask, Vint n1 :: nil => - Some (Vint (Int.rolm n1 amount mask)) - | Onegf, Vfloat f1 :: nil => Some (Vfloat (Float.neg f1)) - | Oabsf, Vfloat f1 :: nil => Some (Vfloat (Float.abs f1)) - | Oaddf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.add f1 f2)) - | Osubf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.sub f1 f2)) - | Omulf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.mul f1 f2)) - | Odivf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.div f1 f2)) - | Omuladdf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil => - Some (Vfloat (Float.add (Float.mul f1 f2) f3)) - | Omulsubf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil => - Some (Vfloat (Float.sub (Float.mul f1 f2) f3)) - | Osingleoffloat, v1 :: nil => - Some (Val.singleoffloat v1) - | Ointoffloat, Vfloat f1 :: nil => - Some (Vint (Float.intoffloat f1)) - | Ointuoffloat, Vfloat f1 :: nil => - Some (Vint (Float.intuoffloat f1)) - | Ofloatofint, Vint n1 :: nil => - Some (Vfloat (Float.floatofint n1)) - | Ofloatofintu, Vint n1 :: nil => - Some (Vfloat (Float.floatofintu n1)) - | Ocmp c, _ => - match eval_condition c vl m with - | None => None - | Some false => Some Vfalse - | Some true => Some Vtrue - end - | _, _ => None - end. - -Definition eval_addressing - (F: Set) (genv: Genv.t F) (sp: val) - (addr: addressing) (vl: list val) : option val := - match addr, vl with - | Aindexed n, Vptr b1 n1 :: nil => - Some (Vptr b1 (Int.add n1 n)) - | Aindexed2, Vptr b1 n1 :: Vint n2 :: nil => - Some (Vptr b1 (Int.add n1 n2)) - | Aindexed2, Vint n1 :: Vptr b2 n2 :: nil => - Some (Vptr b2 (Int.add n2 n1)) - | Aglobal s ofs, nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b ofs) - end - | Abased s ofs, Vint n1 :: nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b (Int.add ofs n1)) - end - | Ainstack ofs, nil => - offset_sp sp ofs - | _, _ => None - end. - -Definition negate_condition (cond: condition): condition := - match cond with - | Ccomp c => Ccomp(negate_comparison c) - | Ccompu c => Ccompu(negate_comparison c) - | Ccompimm c n => Ccompimm (negate_comparison c) n - | Ccompuimm c n => Ccompuimm (negate_comparison c) n - | Ccompf c => Cnotcompf c - | Cnotcompf c => Ccompf c - | Cmaskzero n => Cmasknotzero n - | Cmasknotzero n => Cmaskzero n - end. - -Ltac FuncInv := - match goal with - | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => - destruct x; simpl in H; try discriminate; FuncInv - | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => - destruct v; simpl in H; try discriminate; FuncInv - | H: (Some _ = Some _) |- _ => - injection H; intros; clear H; FuncInv - | _ => - idtac - end. - -Remark eval_negate_compare_mismatch: - forall c b, - eval_compare_mismatch c = Some b -> - eval_compare_mismatch (negate_comparison c) = Some (negb b). -Proof. - intros until b. unfold eval_compare_mismatch. - destruct c; intro EQ; inv EQ; auto. -Qed. - -Lemma eval_negate_condition: - forall (cond: condition) (vl: list val) (b: bool) (m: mem), - eval_condition cond vl m = Some b -> - eval_condition (negate_condition cond) vl m = Some (negb b). -Proof. - intros. - destruct cond; simpl in H; FuncInv; try subst b; simpl. - rewrite Int.negate_cmp. auto. - destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. discriminate. - destruct (Int.eq i0 Int.zero). apply eval_negate_compare_mismatch; auto. discriminate. - destruct (valid_pointer m b0 (Int.signed i) && - valid_pointer m b1 (Int.signed i0)). - destruct (eq_block b0 b1). rewrite Int.negate_cmp. congruence. - apply eval_negate_compare_mismatch; auto. - discriminate. - rewrite Int.negate_cmpu. auto. - rewrite Int.negate_cmp. auto. - destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. discriminate. - rewrite Int.negate_cmpu. auto. - auto. - rewrite negb_elim. auto. - auto. - rewrite negb_elim. auto. -Qed. - -(** [eval_operation] and [eval_addressing] depend on a global environment - for resolving references to global symbols. We show that they give - the same results if a global environment is replaced by another that - assigns the same addresses to the same symbols. *) - -Section GENV_TRANSF. - -Variable F1 F2: Set. -Variable ge1: Genv.t F1. -Variable ge2: Genv.t F2. -Hypothesis agree_on_symbols: - forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. - -Lemma eval_operation_preserved: - forall sp op vl m, - eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. -Proof. - intros. - unfold eval_operation; destruct op; try rewrite agree_on_symbols; - reflexivity. -Qed. - -Lemma eval_addressing_preserved: - forall sp addr vl, - eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. -Proof. - intros. - unfold eval_addressing; destruct addr; try rewrite agree_on_symbols; - reflexivity. -Qed. - -End GENV_TRANSF. - -(** [eval_condition] and [eval_operation] depend on a memory store - (to check pointer validity in pointer comparisons). - We show that their results are preserved by a change of - memory if this change preserves pointer validity. - In particular, this holds in case of a memory allocation - or a memory store. *) - -Lemma eval_condition_change_mem: - forall m m' c args b, - (forall b ofs, valid_pointer m b ofs = true -> valid_pointer m' b ofs = true) -> - eval_condition c args m = Some b -> eval_condition c args m' = Some b. -Proof. - intros until b. intro INV. destruct c; simpl; auto. - destruct args; auto. destruct v; auto. destruct args; auto. - destruct v; auto. destruct args; auto. - caseEq (valid_pointer m b0 (Int.signed i)); intro. - caseEq (valid_pointer m b1 (Int.signed i0)); intro. - simpl. rewrite (INV _ _ H). rewrite (INV _ _ H0). auto. - simpl; congruence. simpl; congruence. -Qed. - -Lemma eval_operation_change_mem: - forall (F: Set) m m' (ge: Genv.t F) sp op args v, - (forall b ofs, valid_pointer m b ofs = true -> valid_pointer m' b ofs = true) -> - eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v. -Proof. - intros until v; intro INV. destruct op; simpl; auto. - caseEq (eval_condition c args m); intros. - rewrite (eval_condition_change_mem _ _ _ _ INV H). auto. - discriminate. -Qed. - -Lemma eval_condition_alloc: - forall m lo hi m' b c args v, - Mem.alloc m lo hi = (m', b) -> - eval_condition c args m = Some v -> eval_condition c args m' = Some v. -Proof. - intros. apply eval_condition_change_mem with m; auto. - intros. eapply valid_pointer_alloc; eauto. -Qed. - -Lemma eval_operation_alloc: - forall (F: Set) m lo hi m' b (ge: Genv.t F) sp op args v, - Mem.alloc m lo hi = (m', b) -> - eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v. -Proof. - intros. apply eval_operation_change_mem with m; auto. - intros. eapply valid_pointer_alloc; eauto. -Qed. - -Lemma eval_condition_store: - forall chunk m b ofs v' m' c args v, - Mem.store chunk m b ofs v' = Some m' -> - eval_condition c args m = Some v -> eval_condition c args m' = Some v. -Proof. - intros. apply eval_condition_change_mem with m; auto. - intros. eapply valid_pointer_store; eauto. -Qed. - -Lemma eval_operation_store: - forall (F: Set) chunk m b ofs v' m' (ge: Genv.t F) sp op args v, - Mem.store chunk m b ofs v' = Some m' -> - eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v. -Proof. - intros. apply eval_operation_change_mem with m; auto. - intros. eapply valid_pointer_store; eauto. -Qed. - -(** Recognition of move operations. *) - -Definition is_move_operation - (A: Set) (op: operation) (args: list A) : option A := - match op, args with - | Omove, arg :: nil => Some arg - | _, _ => None - end. - -Lemma is_move_operation_correct: - forall (A: Set) (op: operation) (args: list A) (a: A), - is_move_operation op args = Some a -> - op = Omove /\ args = a :: nil. -Proof. - intros until a. unfold is_move_operation; destruct op; - try (intros; discriminate). - destruct args. intros; discriminate. - destruct args. intros. intuition congruence. - intros; discriminate. -Qed. - -(** Static typing of conditions, operators and addressing modes. *) - -Definition type_of_condition (c: condition) : list typ := - match c with - | Ccomp _ => Tint :: Tint :: nil - | Ccompu _ => Tint :: Tint :: nil - | Ccompimm _ _ => Tint :: nil - | Ccompuimm _ _ => Tint :: nil - | Ccompf _ => Tfloat :: Tfloat :: nil - | Cnotcompf _ => Tfloat :: Tfloat :: nil - | Cmaskzero _ => Tint :: nil - | Cmasknotzero _ => Tint :: nil - end. - -Definition type_of_operation (op: operation) : list typ * typ := - match op with - | Omove => (nil, Tint) (* treated specially *) - | Ointconst _ => (nil, Tint) - | Ofloatconst _ => (nil, Tfloat) - | Oaddrsymbol _ _ => (nil, Tint) - | Oaddrstack _ => (nil, Tint) - | Ocast8signed => (Tint :: nil, Tint) - | Ocast8unsigned => (Tint :: nil, Tint) - | Ocast16signed => (Tint :: nil, Tint) - | Ocast16unsigned => (Tint :: nil, Tint) - | Oadd => (Tint :: Tint :: nil, Tint) - | Oaddimm _ => (Tint :: nil, Tint) - | Osub => (Tint :: Tint :: nil, Tint) - | Osubimm _ => (Tint :: nil, Tint) - | Omul => (Tint :: Tint :: nil, Tint) - | Omulimm _ => (Tint :: nil, Tint) - | Odiv => (Tint :: Tint :: nil, Tint) - | Odivu => (Tint :: Tint :: nil, Tint) - | Oand => (Tint :: Tint :: nil, Tint) - | Oandimm _ => (Tint :: nil, Tint) - | Oor => (Tint :: Tint :: nil, Tint) - | Oorimm _ => (Tint :: nil, Tint) - | Oxor => (Tint :: Tint :: nil, Tint) - | Oxorimm _ => (Tint :: nil, Tint) - | Onand => (Tint :: Tint :: nil, Tint) - | Onor => (Tint :: Tint :: nil, Tint) - | Onxor => (Tint :: Tint :: nil, Tint) - | Oshl => (Tint :: Tint :: nil, Tint) - | Oshr => (Tint :: Tint :: nil, Tint) - | Oshrimm _ => (Tint :: nil, Tint) - | Oshrximm _ => (Tint :: nil, Tint) - | Oshru => (Tint :: Tint :: nil, Tint) - | Orolm _ _ => (Tint :: nil, Tint) - | Onegf => (Tfloat :: nil, Tfloat) - | Oabsf => (Tfloat :: nil, Tfloat) - | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) - | Osubf => (Tfloat :: Tfloat :: nil, Tfloat) - | Omulf => (Tfloat :: Tfloat :: nil, Tfloat) - | Odivf => (Tfloat :: Tfloat :: nil, Tfloat) - | Omuladdf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) - | Omulsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) - | Osingleoffloat => (Tfloat :: nil, Tfloat) - | Ointoffloat => (Tfloat :: nil, Tint) - | Ointuoffloat => (Tfloat :: nil, Tint) - | Ofloatofint => (Tint :: nil, Tfloat) - | Ofloatofintu => (Tint :: nil, Tfloat) - | Ocmp c => (type_of_condition c, Tint) - end. - -Definition type_of_addressing (addr: addressing) : list typ := - match addr with - | Aindexed _ => Tint :: nil - | Aindexed2 => Tint :: Tint :: nil - | Aglobal _ _ => nil - | Abased _ _ => Tint :: nil - | Ainstack _ => nil - end. - -Definition type_of_chunk (c: memory_chunk) : typ := - match c with - | Mint8signed => Tint - | Mint8unsigned => Tint - | Mint16signed => Tint - | Mint16unsigned => Tint - | Mint32 => Tint - | Mfloat32 => Tfloat - | Mfloat64 => Tfloat - end. - -(** Weak type soundness results for [eval_operation]: - the result values, when defined, are always of the type predicted - by [type_of_operation]. *) - -Section SOUNDNESS. - -Variable A: Set. -Variable genv: Genv.t A. - -Lemma type_of_operation_sound: - forall op vl sp v m, - op <> Omove -> - eval_operation genv sp op vl m = Some v -> - Val.has_type v (snd (type_of_operation op)). -Proof. - intros. - destruct op; simpl in H0; FuncInv; try subst v; try exact I. - congruence. - destruct (Genv.find_symbol genv i); simplify_eq H0; intro; subst v; exact I. - simpl. unfold offset_sp in H0. destruct sp; try discriminate. - inversion H0. exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct v0; exact I. - destruct (eq_block b b0). injection H0; intro; subst v; exact I. - discriminate. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i (Int.repr 32)). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i (Int.repr 32)). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v; exact I. discriminate. - destruct v0; exact I. - destruct (eval_condition c vl). - destruct b; injection H0; intro; subst v; exact I. - discriminate. -Qed. - -Lemma type_of_chunk_correct: - forall chunk m addr v, - Mem.loadv chunk m addr = Some v -> - Val.has_type v (type_of_chunk chunk). -Proof. - intro chunk. - assert (forall v, Val.has_type (Val.load_result chunk v) (type_of_chunk chunk)). - destruct v; destruct chunk; exact I. - intros until v. unfold Mem.loadv. - destruct addr; intros; try discriminate. - generalize (Mem.load_inv _ _ _ _ _ H0). - intros [X Y]. subst v. apply H. -Qed. - -End SOUNDNESS. - -(** Alternate definition of [eval_condition], [eval_op], [eval_addressing] - as total functions that return [Vundef] when not applicable - (instead of [None]). Used in the proof of [PPCgen]. *) - -Section EVAL_OP_TOTAL. - -Variable F: Set. -Variable genv: Genv.t F. - -Definition find_symbol_offset (id: ident) (ofs: int) : val := - match Genv.find_symbol genv id with - | Some b => Vptr b ofs - | None => Vundef - end. - -Definition eval_condition_total (cond: condition) (vl: list val) : val := - match cond, vl with - | Ccomp c, v1::v2::nil => Val.cmp c v1 v2 - | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2 - | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n) - | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n) - | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2 - | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2) - | Cmaskzero n, v1::nil => Val.notbool (Val.and v1 (Vint n)) - | Cmasknotzero n, v1::nil => Val.notbool(Val.notbool (Val.and v1 (Vint n))) - | _, _ => Vundef - end. - -Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => Vint n - | Ofloatconst n, nil => Vfloat n - | Oaddrsymbol s ofs, nil => find_symbol_offset s ofs - | Oaddrstack ofs, nil => Val.add sp (Vint ofs) - | Ocast8signed, v1::nil => Val.sign_ext 8 v1 - | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1 - | Ocast16signed, v1::nil => Val.sign_ext 16 v1 - | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1 - | Oadd, v1::v2::nil => Val.add v1 v2 - | Oaddimm n, v1::nil => Val.add v1 (Vint n) - | Osub, v1::v2::nil => Val.sub v1 v2 - | Osubimm n, v1::nil => Val.sub (Vint n) v1 - | Omul, v1::v2::nil => Val.mul v1 v2 - | Omulimm n, v1::nil => Val.mul v1 (Vint n) - | Odiv, v1::v2::nil => Val.divs v1 v2 - | Odivu, v1::v2::nil => Val.divu v1 v2 - | Oand, v1::v2::nil => Val.and v1 v2 - | Oandimm n, v1::nil => Val.and v1 (Vint n) - | Oor, v1::v2::nil => Val.or v1 v2 - | Oorimm n, v1::nil => Val.or v1 (Vint n) - | Oxor, v1::v2::nil => Val.xor v1 v2 - | Oxorimm n, v1::nil => Val.xor v1 (Vint n) - | Onand, v1::v2::nil => Val.notint(Val.and v1 v2) - | Onor, v1::v2::nil => Val.notint(Val.or v1 v2) - | Onxor, v1::v2::nil => Val.notint(Val.xor v1 v2) - | Oshl, v1::v2::nil => Val.shl v1 v2 - | Oshr, v1::v2::nil => Val.shr v1 v2 - | Oshrimm n, v1::nil => Val.shr v1 (Vint n) - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) - | Oshru, v1::v2::nil => Val.shru v1 v2 - | Orolm amount mask, v1::nil => Val.rolm v1 amount mask - | Onegf, v1::nil => Val.negf v1 - | Oabsf, v1::nil => Val.absf v1 - | Oaddf, v1::v2::nil => Val.addf v1 v2 - | Osubf, v1::v2::nil => Val.subf v1 v2 - | Omulf, v1::v2::nil => Val.mulf v1 v2 - | Odivf, v1::v2::nil => Val.divf v1 v2 - | Omuladdf, v1::v2::v3::nil => Val.addf (Val.mulf v1 v2) v3 - | Omulsubf, v1::v2::v3::nil => Val.subf (Val.mulf v1 v2) v3 - | Osingleoffloat, v1::nil => Val.singleoffloat v1 - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ointuoffloat, v1::nil => Val.intuoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ofloatofintu, v1::nil => Val.floatofintu v1 - | Ocmp c, _ => eval_condition_total c vl - | _, _ => Vundef - end. - -Definition eval_addressing_total - (sp: val) (addr: addressing) (vl: list val) : val := - match addr, vl with - | Aindexed n, v1::nil => Val.add v1 (Vint n) - | Aindexed2, v1::v2::nil => Val.add v1 v2 - | Aglobal s ofs, nil => find_symbol_offset s ofs - | Abased s ofs, v1::nil => Val.add (find_symbol_offset s ofs) v1 - | Ainstack ofs, nil => Val.add sp (Vint ofs) - | _, _ => Vundef - end. - -Lemma eval_compare_mismatch_weaken: - forall c b, - eval_compare_mismatch c = Some b -> - Val.cmp_mismatch c = Val.of_bool b. -Proof. - unfold eval_compare_mismatch. intros. destruct c; inv H; auto. -Qed. - -Lemma eval_compare_null_weaken: - forall n c b, - (if Int.eq n Int.zero then eval_compare_mismatch c else None) = Some b -> - (if Int.eq n Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b. -Proof. - intros. destruct (Int.eq n Int.zero). apply eval_compare_mismatch_weaken. auto. - discriminate. -Qed. - -Lemma eval_condition_weaken: - forall c vl m b, - eval_condition c vl m = Some b -> - eval_condition_total c vl = Val.of_bool b. -Proof. - intros. - unfold eval_condition in H; destruct c; FuncInv; - try subst b; try reflexivity; simpl; - try (apply eval_compare_null_weaken; auto). - destruct (valid_pointer m b0 (Int.signed i) && - valid_pointer m b1 (Int.signed i0)). - unfold eq_block in H. destruct (zeq b0 b1). - congruence. - apply eval_compare_mismatch_weaken; auto. - discriminate. - symmetry. apply Val.notbool_negb_1. - symmetry. apply Val.notbool_negb_1. -Qed. - -Lemma eval_operation_weaken: - forall sp op vl m v, - eval_operation genv sp op vl m = Some v -> - eval_operation_total sp op vl = v. -Proof. - intros. - unfold eval_operation in H; destruct op; FuncInv; - try subst v; try reflexivity; simpl. - unfold find_symbol_offset. - destruct (Genv.find_symbol genv i); try discriminate. - congruence. - unfold offset_sp in H. - destruct sp; try discriminate. simpl. congruence. - unfold eq_block in H. destruct (zeq b b0); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.ltu i0 (Int.repr 32)); congruence. - destruct (Int.ltu i0 (Int.repr 32)); congruence. - destruct (Int.ltu i (Int.repr 32)); congruence. - destruct (Int.ltu i (Int.repr 32)); congruence. - destruct (Int.ltu i0 (Int.repr 32)); congruence. - caseEq (eval_condition c vl m); intros; rewrite H0 in H. - replace v with (Val.of_bool b). - eapply eval_condition_weaken; eauto. - destruct b; simpl; congruence. - discriminate. -Qed. - -Lemma eval_addressing_weaken: - forall sp addr vl v, - eval_addressing genv sp addr vl = Some v -> - eval_addressing_total sp addr vl = v. -Proof. - intros. - unfold eval_addressing in H; destruct addr; FuncInv; - try subst v; simpl; try reflexivity. - unfold find_symbol_offset. - destruct (Genv.find_symbol genv i); congruence. - unfold find_symbol_offset. - destruct (Genv.find_symbol genv i); try congruence. - inversion H. reflexivity. - unfold offset_sp in H. destruct sp; simpl; congruence. -Qed. - -Lemma eval_condition_total_is_bool: - forall cond vl, Val.is_bool (eval_condition_total cond vl). -Proof. - intros; destruct cond; - destruct vl; try apply Val.undef_is_bool; - destruct vl; try apply Val.undef_is_bool; - try (destruct vl; try apply Val.undef_is_bool); simpl. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmpf_is_bool. - apply Val.notbool_is_bool. - apply Val.notbool_is_bool. - apply Val.notbool_is_bool. -Qed. - -End EVAL_OP_TOTAL. - -(** Compatibility of the evaluation functions with the - ``is less defined'' relation over values and memory states. *) - -Section EVAL_LESSDEF. - -Variable F: Set. -Variable genv: Genv.t F. -Variables m1 m2: mem. -Hypothesis MEM: Mem.lessdef m1 m2. - -Ltac InvLessdef := - match goal with - | [ H: Val.lessdef (Vint _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef (Vfloat _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef (Vptr _ _) _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef_list nil _ |- _ ] => - inv H; InvLessdef - | [ H: Val.lessdef_list (_ :: _) _ |- _ ] => - inv H; InvLessdef - | _ => idtac - end. - -Lemma eval_condition_lessdef: - forall cond vl1 vl2 b, - Val.lessdef_list vl1 vl2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. destruct cond; simpl in *; FuncInv; InvLessdef; auto. - generalize H0. - caseEq (valid_pointer m1 b0 (Int.signed i)); intro; simpl; try congruence. - caseEq (valid_pointer m1 b1 (Int.signed i0)); intro; simpl; try congruence. - rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H1). - rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H). simpl. - auto. -Qed. - -Ltac TrivialExists := - match goal with - | [ |- exists v2, Some ?v1 = Some v2 /\ Val.lessdef ?v1 v2 ] => - exists v1; split; [auto | constructor] - | _ => idtac - end. - -Lemma eval_operation_lessdef: - forall sp op vl1 vl2 v1, - Val.lessdef_list vl1 vl2 -> - eval_operation genv sp op vl1 m1 = Some v1 -> - exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. destruct op; simpl in *; FuncInv; InvLessdef; TrivialExists. - exists v2; auto. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. - exists v1; auto. - exists (Val.sign_ext 8 v2); split. auto. apply Val.sign_ext_lessdef; auto. - exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto. - exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto. - exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_lessdef; auto. - destruct (eq_block b b0); inv H0. TrivialExists. - destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. - destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. - destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists. - destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists. - destruct (Int.ltu i (Int.repr 32)); inv H0; TrivialExists. - destruct (Int.ltu i (Int.repr 32)); inv H0; TrivialExists. - destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists. - exists (Val.singleoffloat v2); split. auto. apply Val.singleoffloat_lessdef; auto. - caseEq (eval_condition c vl1 m1); intros. rewrite H1 in H0. - rewrite (eval_condition_lessdef c H H1). - destruct b; inv H0; TrivialExists. - rewrite H1 in H0. discriminate. -Qed. - -Lemma eval_addressing_lessdef: - forall sp addr vl1 vl2 v1, - Val.lessdef_list vl1 vl2 -> - eval_addressing genv sp addr vl1 = Some v1 -> - exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. destruct addr; simpl in *; FuncInv; InvLessdef; TrivialExists. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. - destruct (Genv.find_symbol genv i); inv H0. TrivialExists. - exists v1; auto. -Qed. - -End EVAL_LESSDEF. - -(** Transformation of addressing modes with two operands or more - into an equivalent arithmetic operation. This is used in the [Reload] - pass when a store instruction cannot be reloaded directly because - it runs out of temporary registers. *) - -(** For the PowerPC, there is only one binary addressing mode: [Aindexed2]. - The corresponding operation is [Oadd]. *) - -Definition op_for_binary_addressing (addr: addressing) : operation := Oadd. - -Lemma eval_op_for_binary_addressing: - forall (F: Set) (ge: Genv.t F) sp addr args m v, - (length args >= 2)%nat -> - eval_addressing ge sp addr args = Some v -> - eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. -Proof. - intros. - unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction; - simpl; congruence. -Qed. - -Lemma type_op_for_binary_addressing: - forall addr, - (length (type_of_addressing addr) >= 2)%nat -> - type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint). -Proof. - intros. destruct addr; simpl in H; reflexivity || omegaContradiction. -Qed. diff --git a/backend/PPC.v b/backend/PPC.v deleted file mode 100644 index e47cba01..00000000 --- a/backend/PPC.v +++ /dev/null @@ -1,843 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Abstract syntax and semantics for PowerPC assembly language *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. - -(** * Abstract syntax *) - -(** Integer registers, floating-point registers. *) - -Inductive ireg: Set := - | GPR0: ireg | GPR1: ireg | GPR2: ireg | GPR3: ireg - | GPR4: ireg | GPR5: ireg | GPR6: ireg | GPR7: ireg - | GPR8: ireg | GPR9: ireg | GPR10: ireg | GPR11: ireg - | GPR12: ireg | GPR13: ireg | GPR14: ireg | GPR15: ireg - | GPR16: ireg | GPR17: ireg | GPR18: ireg | GPR19: ireg - | GPR20: ireg | GPR21: ireg | GPR22: ireg | GPR23: ireg - | GPR24: ireg | GPR25: ireg | GPR26: ireg | GPR27: ireg - | GPR28: ireg | GPR29: ireg | GPR30: ireg | GPR31: ireg. - -Inductive freg: Set := - | FPR0: freg | FPR1: freg | FPR2: freg | FPR3: freg - | FPR4: freg | FPR5: freg | FPR6: freg | FPR7: freg - | FPR8: freg | FPR9: freg | FPR10: freg | FPR11: freg - | FPR12: freg | FPR13: freg | FPR14: freg | FPR15: freg - | FPR16: freg | FPR17: freg | FPR18: freg | FPR19: freg - | FPR20: freg | FPR21: freg | FPR22: freg | FPR23: freg - | FPR24: freg | FPR25: freg | FPR26: freg | FPR27: freg - | FPR28: freg | FPR29: freg | FPR30: freg | FPR31: freg. - -Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -(** Symbolic constants. Immediate operands to an arithmetic instruction - or an indexed memory access can be either integer literals - or the low or high 16 bits of a symbolic reference (the address - of a symbol plus a displacement). These symbolic references are - resolved later by the linker. -*) - -Inductive constant: Set := - | Cint: int -> constant - | Csymbol_low: ident -> int -> constant - | Csymbol_high: ident -> int -> constant. - -(** A note on constants: while immediate operands to PowerPC - instructions must be representable in 16 bits (with - sign extension or left shift by 16 positions for some instructions), - we do not attempt to capture these restrictions in the - abstract syntax nor in the semantics. The assembler will - emit an error if immediate operands exceed the representable - range. Of course, our PPC generator (file [PPCgen]) is - careful to respect this range. *) - -(** Bits in the condition register. We are only interested in the - first 4 bits. *) - -Inductive crbit: Set := - | CRbit_0: crbit - | CRbit_1: crbit - | CRbit_2: crbit - | CRbit_3: crbit. - -(** The instruction set. Most instructions correspond exactly to - actual instructions of the PowerPC processor. See the PowerPC - reference manuals for more details. Some instructions, - described below, are pseudo-instructions: they expand to - canned instruction sequences during the printing of the assembly - code. *) - -Definition label := positive. - -Inductive instruction : Set := - | Padd: ireg -> ireg -> ireg -> instruction (**r integer addition *) - | Paddi: ireg -> ireg -> constant -> instruction (**r add immediate *) - | Paddis: ireg -> ireg -> constant -> instruction (**r add immediate high *) - | Paddze: ireg -> ireg -> instruction (**r add Carry bit *) - | Pallocblock: instruction (**r allocate new heap block *) - | Pallocframe: Z -> Z -> int -> instruction (**r allocate new stack frame *) - | Pand_: ireg -> ireg -> ireg -> instruction (**r bitwise and *) - | Pandc: ireg -> ireg -> ireg -> instruction (**r bitwise and-complement *) - | Pandi_: ireg -> ireg -> constant -> instruction (**r and immediate and set conditions *) - | Pandis_: ireg -> ireg -> constant -> instruction (**r and immediate high and set conditions *) - | Pb: label -> instruction (**r unconditional branch *) - | Pbctr: instruction (**r branch to contents of register CTR *) - | Pbctrl: instruction (**r branch to contents of CTR and link *) - | Pbf: crbit -> label -> instruction (**r branch if false *) - | Pbl: ident -> instruction (**r branch and link *) - | Pbs: ident -> instruction (**r branch to symbol *) - | Pblr: instruction (**r branch to contents of register LR *) - | Pbt: crbit -> label -> instruction (**r branch if true *) - | Pcmplw: ireg -> ireg -> instruction (**r unsigned integer comparison *) - | Pcmplwi: ireg -> constant -> instruction (**r same, with immediate argument *) - | Pcmpw: ireg -> ireg -> instruction (**r signed integer comparison *) - | Pcmpwi: ireg -> constant -> instruction (**r same, with immediate argument *) - | Pcror: crbit -> crbit -> crbit -> instruction (**r or between condition bits *) - | Pdivw: ireg -> ireg -> ireg -> instruction (**r signed division *) - | Pdivwu: ireg -> ireg -> ireg -> instruction (**r unsigned division *) - | Peqv: ireg -> ireg -> ireg -> instruction (**r bitwise not-xor *) - | Pextsb: ireg -> ireg -> instruction (**r 8-bit sign extension *) - | Pextsh: ireg -> ireg -> instruction (**r 16-bit sign extension *) - | Pfreeframe: int -> instruction (**r deallocate stack frame and restore previous frame *) - | Pfabs: freg -> freg -> instruction (**r float absolute value *) - | Pfadd: freg -> freg -> freg -> instruction (**r float addition *) - | Pfcmpu: freg -> freg -> instruction (**r float comparison *) - | Pfcti: ireg -> freg -> instruction (**r float-to-signed-int conversion *) - | Pfctiu: ireg -> freg -> instruction (**r float-to-unsigned-int conversion *) - | Pfdiv: freg -> freg -> freg -> instruction (**r float division *) - | Pfmadd: freg -> freg -> freg -> freg -> instruction (**r float multiply-add *) - | Pfmr: freg -> freg -> instruction (**r float move *) - | Pfmsub: freg -> freg -> freg -> freg -> instruction (**r float multiply-sub *) - | Pfmul: freg -> freg -> freg -> instruction (**r float multiply *) - | Pfneg: freg -> freg -> instruction (**r float negation *) - | Pfrsp: freg -> freg -> instruction (**r float round to single precision *) - | Pfsub: freg -> freg -> freg -> instruction (**r float subtraction *) - | Pictf: freg -> ireg -> instruction (**r int-to-float conversion *) - | Piuctf: freg -> ireg -> instruction (**r unsigned int-to-float conversion *) - | Plbz: ireg -> constant -> ireg -> instruction (**r load 8-bit unsigned int *) - | Plbzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Plfd: freg -> constant -> ireg -> instruction (**r load 64-bit float *) - | Plfdx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Plfs: freg -> constant -> ireg -> instruction (**r load 32-bit float *) - | Plfsx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Plha: ireg -> constant -> ireg -> instruction (**r load 16-bit signed int *) - | Plhax: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Plhz: ireg -> constant -> ireg -> instruction (**r load 16-bit unsigned int *) - | Plhzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Plfi: freg -> float -> instruction (**r load float constant *) - | Plwz: ireg -> constant -> ireg -> instruction (**r load 32-bit int *) - | Plwzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Pmfcrbit: ireg -> crbit -> instruction (**r move condition bit to reg *) - | Pmflr: ireg -> instruction (**r move LR to reg *) - | Pmr: ireg -> ireg -> instruction (**r integer move *) - | Pmtctr: ireg -> instruction (**r move ireg to CTR *) - | Pmtlr: ireg -> instruction (**r move ireg to LR *) - | Pmulli: ireg -> ireg -> constant -> instruction (**r integer multiply immediate *) - | Pmullw: ireg -> ireg -> ireg -> instruction (**r integer multiply *) - | Pnand: ireg -> ireg -> ireg -> instruction (**r bitwise not-and *) - | Pnor: ireg -> ireg -> ireg -> instruction (**r bitwise not-or *) - | Por: ireg -> ireg -> ireg -> instruction (**r bitwise or *) - | Porc: ireg -> ireg -> ireg -> instruction (**r bitwise or-complement *) - | Pori: ireg -> ireg -> constant -> instruction (**r or with immediate *) - | Poris: ireg -> ireg -> constant -> instruction (**r or with immediate high *) - | Prlwinm: ireg -> ireg -> int -> int -> instruction (**r rotate and mask *) - | Pslw: ireg -> ireg -> ireg -> instruction (**r shift left *) - | Psraw: ireg -> ireg -> ireg -> instruction (**r shift right signed *) - | Psrawi: ireg -> ireg -> int -> instruction (**r shift right signed immediate *) - | Psrw: ireg -> ireg -> ireg -> instruction (**r shift right unsigned *) - | Pstb: ireg -> constant -> ireg -> instruction (**r store 8-bit int *) - | Pstbx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Pstfd: freg -> constant -> ireg -> instruction (**r store 64-bit float *) - | Pstfdx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Pstfs: freg -> constant -> ireg -> instruction (**r store 32-bit float *) - | Pstfsx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Psth: ireg -> constant -> ireg -> instruction (**r store 16-bit int *) - | Psthx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Pstw: ireg -> constant -> ireg -> instruction (**r store 32-bit int *) - | Pstwx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Psubfc: ireg -> ireg -> ireg -> instruction (**r reversed integer subtraction *) - | Psubfic: ireg -> ireg -> constant -> instruction (**r integer subtraction from immediate *) - | Pxor: ireg -> ireg -> ireg -> instruction (**r bitwise xor *) - | Pxori: ireg -> ireg -> constant -> instruction (**r bitwise xor with immediate *) - | Pxoris: ireg -> ireg -> constant -> instruction (**r bitwise xor with immediate high *) - | Plabel: label -> instruction. (**r define a code label *) - -(** The pseudo-instructions are the following: - -- [Plabel]: define a code label at the current program point -- [Plfi]: load a floating-point constant in a float register. - Expands to a float load [lfd] from an address in the constant data section - initialized with the floating-point constant: -<< - addis r2, 0, ha16(lbl) - lfd rdst, lo16(lbl)(r2) - .const_data -lbl: .double floatcst - .text ->> - Initialized data in the constant data section are not modeled here, - which is why we use a pseudo-instruction for this purpose. -- [Pfcti]: convert a float to a signed integer. This requires a transfer - via memory of a 32-bit integer from a float register to an int register, - which our memory model cannot express. Expands to: -<< - fctiwz f13, rsrc - stfdu f13, -8(r1) - lwz rdst, 4(r1) - addi r1, r1, 8 ->> -- [Pfctiu]: convert a float to an unsigned integer. The PowerPC way - to do this is to compare the argument against the floating-point - constant [2^31], subtract [2^31] if bigger, then convert to a signed - integer as above, then add back [2^31] if needed. Expands to: -<< - addis r2, 0, ha16(lbl1) - lfd f13, lo16(lbl1)(r2) - fcmpu cr7, rsrc, f13 - cror 30, 29, 30 - beq cr7, lbl2 - fctiwz f13, rsrc - stfdu f13, -8(r1) - lwz rdst, 4(r1) - b lbl3 -lbl2: fsub f13, rsrc, f13 - fctiwz f13, f13 - stfdu f13, -8(r1) - lwz rdst, 4(r1) - addis rdst, rdst, 0x8000 -lbl3: addi r1, r1, 8 - .const_data -lbl1: .long 0x41e00000, 0x00000000 # 2^31 in double precision - .text ->> -- [Pictf]: convert a signed integer to a float. This requires complicated - bit-level manipulations of IEEE floats through mixed float and integer - arithmetic over a memory word, which our memory model and axiomatization - of floats cannot express. Expands to: -<< - addis r2, 0, 0x4330 - stwu r2, -8(r1) - addis r2, rsrc, 0x8000 - stw r2, 4(r1) - addis r2, 0, ha16(lbl) - lfd f13, lo16(lbl)(r2) - lfd rdst, 0(r1) - addi r1, r1, 8 - fsub rdst, rdst, f13 - .const_data -lbl: .long 0x43300000, 0x80000000 - .text ->> - (Don't worry if you do not understand this instruction sequence: intimate - knowledge of IEEE float arithmetic is necessary.) -- [Piuctf]: convert an unsigned integer to a float. The expansion is close - to that [Pictf], and equally obscure. -<< - addis r2, 0, 0x4330 - stwu r2, -8(r1) - stw rsrc, 4(r1) - addis r2, 0, ha16(lbl) - lfd f13, lo16(lbl)(r2) - lfd rdst, 0(r1) - addi r1, r1, 8 - fsub rdst, rdst, f13 - .const_data -lbl: .long 0x43300000, 0x00000000 - .text ->> -- [Pallocframe lo hi ofs]: in the formal semantics, this pseudo-instruction - allocates a memory block with bounds [lo] and [hi], stores the value - of register [r1] (the stack pointer, by convention) at offset [ofs] - in this block, and sets [r1] to a pointer to the bottom of this - block. In the printed PowerPC assembly code, this allocation - is just a store-decrement of register [r1], assuming that [ofs = 0]: -<< - stwu r1, (lo - hi)(r1) ->> - This cannot be expressed in our memory model, which does not reflect - the fact that stack frames are adjacent and allocated/freed - following a stack discipline. -- [Pfreeframe ofs]: in the formal semantics, this pseudo-instruction - reads the word at offset [ofs] in the block pointed by [r1] (the - stack pointer), frees this block, and sets [r1] to the value of the - word at offset [ofs]. In the printed PowerPC assembly code, this - freeing is just a load of register [r1] relative to [r1] itself: -<< - lwz r1, ofs(r1) ->> - Again, our memory model cannot comprehend that this operation - frees (logically) the current stack frame. -- [Pallocheap]: in the formal semantics, this pseudo-instruction - allocates a heap block of size the contents of [GPR3], and leaves - a pointer to this block in [GPR3]. In the generated assembly code, - it is turned into a call to the allocation function of the run-time - system. -*) - -Definition code := list instruction. -Definition fundef := AST.fundef code. -Definition program := AST.program fundef unit. - -(** * Operational semantics *) - -(** The PowerPC has a great many registers, some general-purpose, some very - specific. We model only the following registers: *) - -Inductive preg: Set := - | IR: ireg -> preg (**r integer registers *) - | FR: freg -> preg (**r float registers *) - | PC: preg (**r program counter *) - | LR: preg (**r link register (return address) *) - | CTR: preg (**r count register, used for some branches *) - | CARRY: preg (**r carry bit of the status register *) - | CR0_0: preg (**r bit 0 of the condition register *) - | CR0_1: preg (**r bit 1 of the condition register *) - | CR0_2: preg (**r bit 2 of the condition register *) - | CR0_3: preg. (**r bit 3 of the condition register *) - -Coercion IR: ireg >-> preg. -Coercion FR: freg >-> preg. - -Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. -Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. - -Module PregEq. - Definition t := preg. - Definition eq := preg_eq. -End PregEq. - -Module Pregmap := EMap(PregEq). - -(** The semantics operates over a single mapping from registers - (type [preg]) to values. We maintain (but do not enforce) - the convention that integer registers are mapped to values of - type [Tint], float registers to values of type [Tfloat], - and boolean registers ([CARRY], [CR0_0], etc) to either - [Vzero] or [Vone]. *) - -Definition regset := Pregmap.t val. -Definition genv := Genv.t fundef. - -Notation "a # b" := (a b) (at level 1, only parsing). -Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level). - -Section RELSEM. - -(** Looking up instructions in a code sequence by position. *) - -Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction := - match c with - | nil => None - | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il - end. - -(** Position corresponding to a label *) - -Definition is_label (lbl: label) (instr: instruction) : bool := - match instr with - | Plabel lbl' => if peq lbl lbl' then true else false - | _ => false - end. - -Lemma is_label_correct: - forall lbl instr, - if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl. -Proof. - intros. destruct instr; simpl; try discriminate. - case (peq lbl l); intro; congruence. -Qed. - -Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := - match c with - | nil => None - | instr :: c' => - if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c' - end. - -(** Some PowerPC instructions treat register GPR0 as the integer literal 0 - when that register is used in argument position. *) - -Definition gpr_or_zero (rs: regset) (r: ireg) := - if ireg_eq r GPR0 then Vzero else rs#r. - -Variable ge: genv. - -Definition symbol_offset (id: ident) (ofs: int) : val := - match Genv.find_symbol ge id with - | Some b => Vptr b ofs - | None => Vundef - end. - -(** The four functions below axiomatize how the linker processes - symbolic references [symbol + offset] and splits their - actual values into two 16-bit halves. *) - -Parameter low_half: val -> val. -Parameter high_half: val -> val. - -(** The fundamental property of these operations is that, when applied - to the address of a symbol, their results can be recombined by - addition, rebuilding the original address. *) - -Axiom low_high_half: - forall id ofs, - Val.add (low_half (symbol_offset id ofs)) (high_half (symbol_offset id ofs)) - = symbol_offset id ofs. - -(** The other axioms we take is that the results of - the [low_half] and [high_half] functions are of type [Tint], - i.e. either integers, pointers or undefined values. *) - -Axiom low_half_type: - forall v, Val.has_type (low_half v) Tint. -Axiom high_half_type: - forall v, Val.has_type (high_half v) Tint. - -(** Armed with the [low_half] and [high_half] functions, - we can define the evaluation of a symbolic constant. - Note that for [const_high], integer constants - are shifted left by 16 bits, but not symbol addresses: - we assume (as in the [low_high_half] axioms above) - that the results of [high_half] are already shifted - (their 16 low bits are equal to 0). *) - -Definition const_low (c: constant) := - match c with - | Cint n => Vint n - | Csymbol_low id ofs => low_half (symbol_offset id ofs) - | Csymbol_high id ofs => Vundef - end. - -Definition const_high (c: constant) := - match c with - | Cint n => Vint (Int.shl n (Int.repr 16)) - | Csymbol_low id ofs => Vundef - | Csymbol_high id ofs => high_half (symbol_offset id ofs) - end. - -(** The semantics is purely small-step and defined as a function - from the current state (a register set + a memory state) - to either [OK rs' m'] where [rs'] and [m'] are the updated register - set and memory state after execution of the instruction at [rs#PC], - or [Error] if the processor is stuck. *) - -Inductive outcome: Set := - | OK: regset -> mem -> outcome - | Error: outcome. - -(** Manipulations over the [PC] register: continuing with the next - instruction ([nextinstr]) or branching to a label ([goto_label]). *) - -Definition nextinstr (rs: regset) := - rs#PC <- (Val.add rs#PC Vone). - -Definition goto_label (c: code) (lbl: label) (rs: regset) (m: mem) := - match label_pos lbl 0 c with - | None => Error - | Some pos => - match rs#PC with - | Vptr b ofs => OK (rs#PC <- (Vptr b (Int.repr pos))) m - | _ => Error - end - end. - -(** Auxiliaries for memory accesses, in two forms: one operand - (plus constant offset) or two operands. *) - -Definition load1 (chunk: memory_chunk) (rd: preg) - (cst: constant) (r1: ireg) (rs: regset) (m: mem) := - match Mem.loadv chunk m (Val.add (gpr_or_zero rs r1) (const_low cst)) with - | None => Error - | Some v => OK (nextinstr (rs#rd <- v)) m - end. - -Definition load2 (chunk: memory_chunk) (rd: preg) (r1 r2: ireg) - (rs: regset) (m: mem) := - match Mem.loadv chunk m (Val.add rs#r1 rs#r2) with - | None => Error - | Some v => OK (nextinstr (rs#rd <- v)) m - end. - -Definition store1 (chunk: memory_chunk) (r: preg) - (cst: constant) (r1: ireg) (rs: regset) (m: mem) := - match Mem.storev chunk m (Val.add (gpr_or_zero rs r1) (const_low cst)) (rs#r) with - | None => Error - | Some m' => OK (nextinstr rs) m' - end. - -Definition store2 (chunk: memory_chunk) (r: preg) (r1 r2: ireg) - (rs: regset) (m: mem) := - match Mem.storev chunk m (Val.add rs#r1 rs#r2) (rs#r) with - | None => Error - | Some m' => OK (nextinstr rs) m' - end. - -(** Operations over condition bits. *) - -Definition reg_of_crbit (bit: crbit) := - match bit with - | CRbit_0 => CR0_0 - | CRbit_1 => CR0_1 - | CRbit_2 => CR0_2 - | CRbit_3 => CR0_3 - end. - -Definition compare_sint (rs: regset) (v1 v2: val) := - rs#CR0_0 <- (Val.cmp Clt v1 v2) - #CR0_1 <- (Val.cmp Cgt v1 v2) - #CR0_2 <- (Val.cmp Ceq v1 v2) - #CR0_3 <- Vundef. - -Definition compare_uint (rs: regset) (v1 v2: val) := - rs#CR0_0 <- (Val.cmpu Clt v1 v2) - #CR0_1 <- (Val.cmpu Cgt v1 v2) - #CR0_2 <- (Val.cmpu Ceq v1 v2) - #CR0_3 <- Vundef. - -Definition compare_float (rs: regset) (v1 v2: val) := - rs#CR0_0 <- (Val.cmpf Clt v1 v2) - #CR0_1 <- (Val.cmpf Cgt v1 v2) - #CR0_2 <- (Val.cmpf Ceq v1 v2) - #CR0_3 <- Vundef. - -Definition val_cond_reg (rs: regset) := - Val.or (Val.shl rs#CR0_0 (Vint (Int.repr 31))) - (Val.or (Val.shl rs#CR0_1 (Vint (Int.repr 30))) - (Val.or (Val.shl rs#CR0_2 (Vint (Int.repr 29))) - (Val.shl rs#CR0_3 (Vint (Int.repr 28))))). - -(** Execution of a single instruction [i] in initial state - [rs] and [m]. Return updated state. For instructions - that correspond to actual PowerPC instructions, the cases are - straightforward transliterations of the informal descriptions - given in the PowerPC reference manuals. For pseudo-instructions, - refer to the informal descriptions given above. Note that - we set to [Vundef] the registers used as temporaries by the - expansions of the pseudo-instructions, so that the PPC code - we generate cannot use those registers to hold values that - must survive the execution of the pseudo-instruction. -*) - -Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome := - match i with - | Padd rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#r2))) m - | Paddi rd r1 cst => - OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_low cst)))) m - | Paddis rd r1 cst => - OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_high cst)))) m - | Paddze rd r1 => - OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#CARRY))) m - | Pallocblock => - match rs#GPR3 with - | Vint n => - let (m', b) := Mem.alloc m 0 (Int.signed n) in - OK (nextinstr (rs#GPR3 <- (Vptr b Int.zero) - #LR <- (Val.add rs#PC Vone))) m' - | _ => Error - end - | Pallocframe lo hi ofs => - let (m1, stk) := Mem.alloc m lo hi in - let sp := Vptr stk (Int.repr lo) in - match Mem.storev Mint32 m1 (Val.add sp (Vint ofs)) rs#GPR1 with - | None => Error - | Some m2 => OK (nextinstr (rs#GPR1 <- sp #GPR12 <- Vundef)) m2 - end - | Pand_ rd r1 r2 => - let v := Val.and rs#r1 rs#r2 in - OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m - | Pandc rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.and rs#r1 (Val.notint rs#r2)))) m - | Pandi_ rd r1 cst => - let v := Val.and rs#r1 (const_low cst) in - OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m - | Pandis_ rd r1 cst => - let v := Val.and rs#r1 (const_high cst) in - OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m - | Pb lbl => - goto_label c lbl rs m - | Pbctr => - OK (rs#PC <- (rs#CTR)) m - | Pbctrl => - OK (rs#LR <- (Val.add rs#PC Vone) #PC <- (rs#CTR)) m - | Pbf bit lbl => - match rs#(reg_of_crbit bit) with - | Vint n => if Int.eq n Int.zero then goto_label c lbl rs m else OK (nextinstr rs) m - | _ => Error - end - | Pbl ident => - OK (rs#LR <- (Val.add rs#PC Vone) #PC <- (symbol_offset ident Int.zero)) m - | Pbs ident => - OK (rs#PC <- (symbol_offset ident Int.zero)) m - | Pblr => - OK (rs#PC <- (rs#LR)) m - | Pbt bit lbl => - match rs#(reg_of_crbit bit) with - | Vint n => if Int.eq n Int.zero then OK (nextinstr rs) m else goto_label c lbl rs m - | _ => Error - end - | Pcmplw r1 r2 => - OK (nextinstr (compare_uint rs rs#r1 rs#r2)) m - | Pcmplwi r1 cst => - OK (nextinstr (compare_uint rs rs#r1 (const_low cst))) m - | Pcmpw r1 r2 => - OK (nextinstr (compare_sint rs rs#r1 rs#r2)) m - | Pcmpwi r1 cst => - OK (nextinstr (compare_sint rs rs#r1 (const_low cst))) m - | Pcror bd b1 b2 => - OK (nextinstr (rs#(reg_of_crbit bd) <- (Val.or rs#(reg_of_crbit b1) rs#(reg_of_crbit b2)))) m - | Pdivw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.divs rs#r1 rs#r2))) m - | Pdivwu rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.divu rs#r1 rs#r2))) m - | Peqv rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.notint (Val.xor rs#r1 rs#r2)))) m - | Pextsb rd r1 => - OK (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m - | Pextsh rd r1 => - OK (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m - | Pfreeframe ofs => - match Mem.loadv Mint32 m (Val.add rs#GPR1 (Vint ofs)) with - | None => Error - | Some v => - match rs#GPR1 with - | Vptr stk ofs => OK (nextinstr (rs#GPR1 <- v)) (Mem.free m stk) - | _ => Error - end - end - | Pfabs rd r1 => - OK (nextinstr (rs#rd <- (Val.absf rs#r1))) m - | Pfadd rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.addf rs#r1 rs#r2))) m - | Pfcmpu r1 r2 => - OK (nextinstr (compare_float rs rs#r1 rs#r2)) m - | Pfcti rd r1 => - OK (nextinstr (rs#rd <- (Val.intoffloat rs#r1) #FPR13 <- Vundef)) m - | Pfctiu rd r1 => - OK (nextinstr (rs#rd <- (Val.intuoffloat rs#r1) #FPR13 <- Vundef)) m - | Pfdiv rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m - | Pfmadd rd r1 r2 r3 => - OK (nextinstr (rs#rd <- (Val.addf (Val.mulf rs#r1 rs#r2) rs#r3))) m - | Pfmr rd r1 => - OK (nextinstr (rs#rd <- (rs#r1))) m - | Pfmsub rd r1 r2 r3 => - OK (nextinstr (rs#rd <- (Val.subf (Val.mulf rs#r1 rs#r2) rs#r3))) m - | Pfmul rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.mulf rs#r1 rs#r2))) m - | Pfneg rd r1 => - OK (nextinstr (rs#rd <- (Val.negf rs#r1))) m - | Pfrsp rd r1 => - OK (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m - | Pfsub rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m - | Pictf rd r1 => - OK (nextinstr (rs#rd <- (Val.floatofint rs#r1) #GPR12 <- Vundef #FPR13 <- Vundef)) m - | Piuctf rd r1 => - OK (nextinstr (rs#rd <- (Val.floatofintu rs#r1) #GPR12 <- Vundef #FPR13 <- Vundef)) m - | Plbz rd cst r1 => - load1 Mint8unsigned rd cst r1 rs m - | Plbzx rd r1 r2 => - load2 Mint8unsigned rd r1 r2 rs m - | Plfd rd cst r1 => - load1 Mfloat64 rd cst r1 rs m - | Plfdx rd r1 r2 => - load2 Mfloat64 rd r1 r2 rs m - | Plfs rd cst r1 => - load1 Mfloat32 rd cst r1 rs m - | Plfsx rd r1 r2 => - load2 Mfloat32 rd r1 r2 rs m - | Plha rd cst r1 => - load1 Mint16signed rd cst r1 rs m - | Plhax rd r1 r2 => - load2 Mint16signed rd r1 r2 rs m - | Plhz rd cst r1 => - load1 Mint16unsigned rd cst r1 rs m - | Plhzx rd r1 r2 => - load2 Mint16unsigned rd r1 r2 rs m - | Plfi rd f => - OK (nextinstr (rs#rd <- (Vfloat f) #GPR12 <- Vundef)) m - | Plwz rd cst r1 => - load1 Mint32 rd cst r1 rs m - | Plwzx rd r1 r2 => - load2 Mint32 rd r1 r2 rs m - | Pmfcrbit rd bit => - OK (nextinstr (rs#rd <- (rs#(reg_of_crbit bit)))) m - | Pmflr rd => - OK (nextinstr (rs#rd <- (rs#LR))) m - | Pmr rd r1 => - OK (nextinstr (rs#rd <- (rs#r1))) m - | Pmtctr r1 => - OK (nextinstr (rs#CTR <- (rs#r1))) m - | Pmtlr r1 => - OK (nextinstr (rs#LR <- (rs#r1))) m - | Pmulli rd r1 cst => - OK (nextinstr (rs#rd <- (Val.mul rs#r1 (const_low cst)))) m - | Pmullw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.mul rs#r1 rs#r2))) m - | Pnand rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.notint (Val.and rs#r1 rs#r2)))) m - | Pnor rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.notint (Val.or rs#r1 rs#r2)))) m - | Por rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.or rs#r1 rs#r2))) m - | Porc rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.or rs#r1 (Val.notint rs#r2)))) m - | Pori rd r1 cst => - OK (nextinstr (rs#rd <- (Val.or rs#r1 (const_low cst)))) m - | Poris rd r1 cst => - OK (nextinstr (rs#rd <- (Val.or rs#r1 (const_high cst)))) m - | Prlwinm rd r1 amount mask => - OK (nextinstr (rs#rd <- (Val.rolm rs#r1 amount mask))) m - | Pslw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.shl rs#r1 rs#r2))) m - | Psraw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.shr rs#r1 rs#r2) #CARRY <- (Val.shr_carry rs#r1 rs#r2))) m - | Psrawi rd r1 n => - OK (nextinstr (rs#rd <- (Val.shr rs#r1 (Vint n)) #CARRY <- (Val.shr_carry rs#r1 (Vint n)))) m - | Psrw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.shru rs#r1 rs#r2))) m - | Pstb rd cst r1 => - store1 Mint8unsigned rd cst r1 rs m - | Pstbx rd r1 r2 => - store2 Mint8unsigned rd r1 r2 rs m - | Pstfd rd cst r1 => - store1 Mfloat64 rd cst r1 rs m - | Pstfdx rd r1 r2 => - store2 Mfloat64 rd r1 r2 rs m - | Pstfs rd cst r1 => - store1 Mfloat32 rd cst r1 rs m - | Pstfsx rd r1 r2 => - store2 Mfloat32 rd r1 r2 rs m - | Psth rd cst r1 => - store1 Mint16unsigned rd cst r1 rs m - | Psthx rd r1 r2 => - store2 Mint16unsigned rd r1 r2 rs m - | Pstw rd cst r1 => - store1 Mint32 rd cst r1 rs m - | Pstwx rd r1 r2 => - store2 Mint32 rd r1 r2 rs m - | Psubfc rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.sub rs#r2 rs#r1) #CARRY <- Vundef)) m - | Psubfic rd r1 cst => - OK (nextinstr (rs#rd <- (Val.sub (const_low cst) rs#r1) #CARRY <- Vundef)) m - | Pxor rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.xor rs#r1 rs#r2))) m - | Pxori rd r1 cst => - OK (nextinstr (rs#rd <- (Val.xor rs#r1 (const_low cst)))) m - | Pxoris rd r1 cst => - OK (nextinstr (rs#rd <- (Val.xor rs#r1 (const_high cst)))) m - | Plabel lbl => - OK (nextinstr rs) m - end. - -(** Calling conventions for external functions. These are compatible with - the calling conventions in module [Conventions], except that - we use PPC registers instead of locations. *) - -Inductive extcall_args (rs: regset) (m: mem): - list typ -> list ireg -> list freg -> Z -> list val -> Prop := - | extcall_args_nil: forall irl frl ofs, - extcall_args rs m nil irl frl ofs nil - | extcall_args_int_reg: forall tyl ir1 irl frl ofs v1 vl, - v1 = rs (IR ir1) -> - extcall_args rs m tyl irl frl ofs vl -> - extcall_args rs m (Tint :: tyl) (ir1 :: irl) frl ofs (v1 :: vl) - | extcall_args_int_stack: forall tyl frl ofs v1 vl, - Mem.loadv Mint32 m (Val.add (rs (IR GPR1)) (Vint (Int.repr ofs))) = Some v1 -> - extcall_args rs m tyl nil frl (ofs + 4) vl -> - extcall_args rs m (Tint :: tyl) nil frl ofs (v1 :: vl) - | extcall_args_float_reg: forall tyl irl fr1 frl ofs v1 vl, - v1 = rs (FR fr1) -> - extcall_args rs m tyl (list_drop2 irl) frl ofs vl -> - extcall_args rs m (Tfloat :: tyl) irl (fr1 :: frl) ofs (v1 :: vl) - | extcall_args_float_stack: forall tyl irl ofs v1 vl, - Mem.loadv Mfloat64 m (Val.add (rs (IR GPR1)) (Vint (Int.repr ofs))) = Some v1 -> - extcall_args rs m tyl irl nil (ofs + 8) vl -> - extcall_args rs m (Tfloat :: tyl) irl nil ofs (v1 :: vl). - -Definition extcall_arguments - (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := - extcall_args rs m - sg.(sig_args) - (GPR3 :: GPR4 :: GPR5 :: GPR6 :: GPR7 :: GPR8 :: GPR9 :: GPR10 :: nil) - (FPR1 :: FPR2 :: FPR3 :: FPR4 :: FPR5 :: FPR6 :: FPR7 :: FPR8 :: FPR9 :: FPR10 :: nil) - 56 args. - -Definition loc_external_result (s: signature) : preg := - match s.(sig_res) with - | None => GPR3 - | Some Tint => GPR3 - | Some Tfloat => FPR1 - end. - -(** Execution of the instruction at [rs#PC]. *) - -Inductive state: Set := - | State: regset -> mem -> state. - -Inductive step: state -> trace -> state -> Prop := - | exec_step_internal: - forall b ofs c i rs m rs' m', - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal c) -> - find_instr (Int.unsigned ofs) c = Some i -> - exec_instr c i rs m = OK rs' m' -> - step (State rs m) E0 (State rs' m') - | exec_step_external: - forall b ef args res rs m t rs', - rs PC = Vptr b Int.zero -> - Genv.find_funct_ptr ge b = Some (External ef) -> - event_match ef args t res -> - extcall_arguments rs m ef.(ef_sig) args -> - rs' = (rs#(loc_external_result ef.(ef_sig)) <- res - #PC <- (rs LR)) -> - step (State rs m) t (State rs' m). - -End RELSEM. - -(** Execution of whole programs. *) - -Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: - let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in - let rs0 := - (Pregmap.init Vundef) - # PC <- (symbol_offset ge p.(prog_main) Int.zero) - # LR <- Vzero - # GPR1 <- (Vptr Mem.nullptr Int.zero) in - initial_state p (State rs0 m0). - -Inductive final_state: state -> int -> Prop := - | final_state_intro: forall rs m r, - rs#PC = Vzero -> - rs#GPR3 = Vint r -> - final_state (State rs m) r. - -Definition exec_program (p: program) (beh: program_behavior) : Prop := - program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. - diff --git a/backend/PPCgen.v b/backend/PPCgen.v deleted file mode 100644 index faedcb1c..00000000 --- a/backend/PPCgen.v +++ /dev/null @@ -1,548 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Translation from Mach to PPC. *) - -Require Import Coqlib. -Require Import Maps. -Require Import Errors. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Globalenvs. -Require Import Op. -Require Import Locations. -Require Import Mach. -Require Import PPC. - -(** Translation of the LTL/Linear/Mach view of machine registers - to the PPC view. PPC has two different types for registers - (integer and float) while LTL et al have only one. The - [ireg_of] and [freg_of] are therefore partial in principle. - To keep things simpler, we make them return nonsensical - results when applied to a LTL register of the wrong type. - The proof in [PPCgenproof] will show that this never happens. - - Note that no LTL register maps to [GPR12] nor [FPR13]. - These two registers are reserved as temporaries, to be used - by the generated PPC code. *) - -Definition ireg_of (r: mreg) : ireg := - match r with - | R3 => GPR3 | R4 => GPR4 | R5 => GPR5 | R6 => GPR6 - | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 | R10 => GPR10 - | R13 => GPR13 | R14 => GPR14 | R15 => GPR15 | R16 => GPR16 - | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 | R20 => GPR20 - | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 - | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 - | R29 => GPR29 | R30 => GPR30 | R31 => GPR31 - | IT1 => GPR11 | IT2 => GPR0 - | _ => GPR0 (* should not happen *) - end. - -Definition freg_of (r: mreg) : freg := - match r with - | F1 => FPR1 | F2 => FPR2 | F3 => FPR3 | F4 => FPR4 - | F5 => FPR5 | F6 => FPR6 | F7 => FPR7 | F8 => FPR8 - | F9 => FPR9 | F10 => FPR10 | F14 => FPR14 | F15 => FPR15 - | F16 => FPR16 | F17 => FPR17 | F18 => FPR18 | F19 => FPR19 - | F20 => FPR20 | F21 => FPR21 | F22 => FPR22 | F23 => FPR23 - | F24 => FPR24 | F25 => FPR25 | F26 => FPR26 | F27 => FPR27 - | F28 => FPR28 | F29 => FPR29 | F30 => FPR30 | F31 => FPR31 - | FT1 => FPR0 | FT2 => FPR11 | FT3 => FPR12 - | _ => FPR0 (* should not happen *) - end. - -(** Decomposition of integer constants. As noted in file [PPC], - immediate arguments to PowerPC instructions must fit into 16 bits, - and are interpreted after zero extension, sign extension, or - left shift by 16 bits, depending on the instruction. Integer - constants that do not fit must be synthesized using two - processor instructions. The following functions decompose - arbitrary 32-bit integers into two 16-bit halves (high and low - halves). They satisfy the following properties: -- [low_u n] is an unsigned 16-bit integer; -- [low_s n] is a signed 16-bit integer; -- [(high_u n) << 16 | low_u n] equals [n]; -- [(high_s n) << 16 + low_s n] equals [n]. -*) - -Definition low_u (n: int) := Int.and n (Int.repr 65535). -Definition high_u (n: int) := Int.shru n (Int.repr 16). -Definition low_s (n: int) := Int.sign_ext 16 n. -Definition high_s (n: int) := Int.shru (Int.sub n (low_s n)) (Int.repr 16). - -(** Smart constructors for arithmetic operations involving - a 32-bit integer constant. Depending on whether the - constant fits in 16 bits or not, one or several instructions - are generated as required to perform the operation - and prepended to the given instruction sequence [k]. *) - -Definition loadimm (r: ireg) (n: int) (k: code) := - if Int.eq (high_s n) Int.zero then - Paddi r GPR0 (Cint n) :: k - else if Int.eq (low_s n) Int.zero then - Paddis r GPR0 (Cint (high_s n)) :: k - else - Paddis r GPR0 (Cint (high_u n)) :: - Pori r r (Cint (low_u n)) :: k. - -Definition addimm_1 (r1 r2: ireg) (n: int) (k: code) := - if Int.eq (high_s n) Int.zero then - Paddi r1 r2 (Cint n) :: k - else if Int.eq (low_s n) Int.zero then - Paddis r1 r2 (Cint (high_s n)) :: k - else - Paddis r1 r2 (Cint (high_s n)) :: - Paddi r1 r1 (Cint (low_s n)) :: k. - -Definition addimm_2 (r1 r2: ireg) (n: int) (k: code) := - loadimm GPR12 n (Padd r1 r2 GPR12 :: k). - -Definition addimm (r1 r2: ireg) (n: int) (k: code) := - if ireg_eq r1 GPR0 then - addimm_2 r1 r2 n k - else if ireg_eq r2 GPR0 then - addimm_2 r1 r2 n k - else - addimm_1 r1 r2 n k. - -Definition andimm (r1 r2: ireg) (n: int) (k: code) := - if Int.eq (high_u n) Int.zero then - Pandi_ r1 r2 (Cint n) :: k - else if Int.eq (low_u n) Int.zero then - Pandis_ r1 r2 (Cint (high_u n)) :: k - else - loadimm GPR12 n (Pand_ r1 r2 GPR12 :: k). - -Definition orimm (r1 r2: ireg) (n: int) (k: code) := - if Int.eq (high_u n) Int.zero then - Pori r1 r2 (Cint n) :: k - else if Int.eq (low_u n) Int.zero then - Poris r1 r2 (Cint (high_u n)) :: k - else - Poris r1 r2 (Cint (high_u n)) :: - Pori r1 r1 (Cint (low_u n)) :: k. - -Definition xorimm (r1 r2: ireg) (n: int) (k: code) := - if Int.eq (high_u n) Int.zero then - Pxori r1 r2 (Cint n) :: k - else if Int.eq (low_u n) Int.zero then - Pxoris r1 r2 (Cint (high_u n)) :: k - else - Pxoris r1 r2 (Cint (high_u n)) :: - Pxori r1 r1 (Cint (low_u n)) :: k. - -(** Smart constructors for indexed loads and stores, - where the address is the contents of a register plus - an integer literal. *) - -Definition loadind_aux (base: ireg) (ofs: int) (ty: typ) (dst: mreg) := - match ty with - | Tint => Plwz (ireg_of dst) (Cint ofs) base - | Tfloat => Plfd (freg_of dst) (Cint ofs) base - end. - -Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := - if Int.eq (high_s ofs) Int.zero then - loadind_aux base ofs ty dst :: k - else - Paddis GPR12 base (Cint (high_s ofs)) :: - loadind_aux GPR12 (low_s ofs) ty dst :: k. - -Definition storeind_aux (src: mreg) (base: ireg) (ofs: int) (ty: typ) := - match ty with - | Tint => Pstw (ireg_of src) (Cint ofs) base - | Tfloat => Pstfd (freg_of src) (Cint ofs) base - end. - -Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) := - if Int.eq (high_s ofs) Int.zero then - storeind_aux src base ofs ty :: k - else - Paddis GPR12 base (Cint (high_s ofs)) :: - storeind_aux src GPR12 (low_s ofs) ty :: k. - -(** Constructor for a floating-point comparison. The PowerPC has - a single [fcmpu] instruction to compare floats, which sets - bits 0, 1 and 2 of the condition register to reflect ``less'', - ``greater'' and ``equal'' conditions, respectively. - The ``less or equal'' and ``greater or equal'' conditions must be - synthesized by a [cror] instruction that computes the logical ``or'' - of the corresponding two conditions. *) - -Definition floatcomp (cmp: comparison) (r1 r2: freg) (k: code) := - Pfcmpu r1 r2 :: - match cmp with - | Cle => Pcror CRbit_3 CRbit_2 CRbit_0 :: k - | Cge => Pcror CRbit_3 CRbit_2 CRbit_1 :: k - | _ => k - end. - -(** Translation of a condition. Prepends to [k] the instructions - that evaluate the condition and leave its boolean result in one of - the bits of the condition register. The bit in question is - determined by the [crbit_for_cond] function. *) - -Definition transl_cond - (cond: condition) (args: list mreg) (k: code) := - match cond, args with - | Ccomp c, a1 :: a2 :: nil => - Pcmpw (ireg_of a1) (ireg_of a2) :: k - | Ccompu c, a1 :: a2 :: nil => - Pcmplw (ireg_of a1) (ireg_of a2) :: k - | Ccompimm c n, a1 :: nil => - if Int.eq (high_s n) Int.zero then - Pcmpwi (ireg_of a1) (Cint n) :: k - else - loadimm GPR12 n (Pcmpw (ireg_of a1) GPR12 :: k) - | Ccompuimm c n, a1 :: nil => - if Int.eq (high_u n) Int.zero then - Pcmplwi (ireg_of a1) (Cint n) :: k - else - loadimm GPR12 n (Pcmplw (ireg_of a1) GPR12 :: k) - | Ccompf cmp, a1 :: a2 :: nil => - floatcomp cmp (freg_of a1) (freg_of a2) k - | Cnotcompf cmp, a1 :: a2 :: nil => - floatcomp cmp (freg_of a1) (freg_of a2) k - | Cmaskzero n, a1 :: nil => - andimm GPR12 (ireg_of a1) n k - | Cmasknotzero n, a1 :: nil => - andimm GPR12 (ireg_of a1) n k - | _, _ => - k (**r never happens for well-typed code *) - end. - -(* CRbit_0 = Less - CRbit_1 = Greater - CRbit_2 = Equal - CRbit_3 = Other *) - -Definition crbit_for_icmp (cmp: comparison) := - match cmp with - | Ceq => (CRbit_2, true) - | Cne => (CRbit_2, false) - | Clt => (CRbit_0, true) - | Cle => (CRbit_1, false) - | Cgt => (CRbit_1, true) - | Cge => (CRbit_0, false) - end. - -Definition crbit_for_fcmp (cmp: comparison) := - match cmp with - | Ceq => (CRbit_2, true) - | Cne => (CRbit_2, false) - | Clt => (CRbit_0, true) - | Cle => (CRbit_3, true) - | Cgt => (CRbit_1, true) - | Cge => (CRbit_3, true) - end. - -Definition crbit_for_cond (cond: condition) := - match cond with - | Ccomp cmp => crbit_for_icmp cmp - | Ccompu cmp => crbit_for_icmp cmp - | Ccompimm cmp n => crbit_for_icmp cmp - | Ccompuimm cmp n => crbit_for_icmp cmp - | Ccompf cmp => crbit_for_fcmp cmp - | Cnotcompf cmp => let p := crbit_for_fcmp cmp in (fst p, negb (snd p)) - | Cmaskzero n => (CRbit_2, true) - | Cmasknotzero n => (CRbit_2, false) - end. - -(** Translation of the arithmetic operation [r <- op(args)]. - The corresponding instructions are prepended to [k]. *) - -Definition transl_op - (op: operation) (args: list mreg) (r: mreg) (k: code) := - match op, args with - | Omove, a1 :: nil => - match mreg_type a1 with - | Tint => Pmr (ireg_of r) (ireg_of a1) :: k - | Tfloat => Pfmr (freg_of r) (freg_of a1) :: k - end - | Ointconst n, nil => - loadimm (ireg_of r) n k - | Ofloatconst f, nil => - Plfi (freg_of r) f :: k - | Oaddrsymbol s ofs, nil => - Paddis GPR12 GPR0 (Csymbol_high s ofs) :: - Paddi (ireg_of r) GPR12 (Csymbol_low s ofs) :: k - | Oaddrstack n, nil => - addimm (ireg_of r) GPR1 n k - | Ocast8signed, a1 :: nil => - Pextsb (ireg_of r) (ireg_of a1) :: k - | Ocast8unsigned, a1 :: nil => - Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 255) :: k - | Ocast16signed, a1 :: nil => - Pextsh (ireg_of r) (ireg_of a1) :: k - | Ocast16unsigned, a1 :: nil => - Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 65535) :: k - | Oadd, a1 :: a2 :: nil => - Padd (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oaddimm n, a1 :: nil => - addimm (ireg_of r) (ireg_of a1) n k - | Osub, a1 :: a2 :: nil => - Psubfc (ireg_of r) (ireg_of a2) (ireg_of a1) :: k - | Osubimm n, a1 :: nil => - if Int.eq (high_s n) Int.zero then - Psubfic (ireg_of r) (ireg_of a1) (Cint n) :: k - else - loadimm GPR12 n (Psubfc (ireg_of r) (ireg_of a1) GPR12 :: k) - | Omul, a1 :: a2 :: nil => - Pmullw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Omulimm n, a1 :: nil => - if Int.eq (high_s n) Int.zero then - Pmulli (ireg_of r) (ireg_of a1) (Cint n) :: k - else - loadimm GPR12 n (Pmullw (ireg_of r) (ireg_of a1) GPR12 :: k) - | Odiv, a1 :: a2 :: nil => - Pdivw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Odivu, a1 :: a2 :: nil => - Pdivwu (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oand, a1 :: a2 :: nil => - Pand_ (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oandimm n, a1 :: nil => - andimm (ireg_of r) (ireg_of a1) n k - | Oor, a1 :: a2 :: nil => - Por (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oorimm n, a1 :: nil => - orimm (ireg_of r) (ireg_of a1) n k - | Oxor, a1 :: a2 :: nil => - Pxor (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oxorimm n, a1 :: nil => - xorimm (ireg_of r) (ireg_of a1) n k - | Onand, a1 :: a2 :: nil => - Pnand (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Onor, a1 :: a2 :: nil => - Pnor (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Onxor, a1 :: a2 :: nil => - Peqv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oshl, a1 :: a2 :: nil => - Pslw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oshr, a1 :: a2 :: nil => - Psraw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oshrimm n, a1 :: nil => - Psrawi (ireg_of r) (ireg_of a1) n :: k - | Oshrximm n, a1 :: nil => - Psrawi (ireg_of r) (ireg_of a1) n :: - Paddze (ireg_of r) (ireg_of r) :: k - | Oshru, a1 :: a2 :: nil => - Psrw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Orolm amount mask, a1 :: nil => - Prlwinm (ireg_of r) (ireg_of a1) amount mask :: k - | Onegf, a1 :: nil => - Pfneg (freg_of r) (freg_of a1) :: k - | Oabsf, a1 :: nil => - Pfabs (freg_of r) (freg_of a1) :: k - | Oaddf, a1 :: a2 :: nil => - Pfadd (freg_of r) (freg_of a1) (freg_of a2) :: k - | Osubf, a1 :: a2 :: nil => - Pfsub (freg_of r) (freg_of a1) (freg_of a2) :: k - | Omulf, a1 :: a2 :: nil => - Pfmul (freg_of r) (freg_of a1) (freg_of a2) :: k - | Odivf, a1 :: a2 :: nil => - Pfdiv (freg_of r) (freg_of a1) (freg_of a2) :: k - | Omuladdf, a1 :: a2 :: a3 :: nil => - Pfmadd (freg_of r) (freg_of a1) (freg_of a2) (freg_of a3) :: k - | Omulsubf, a1 :: a2 :: a3 :: nil => - Pfmsub (freg_of r) (freg_of a1) (freg_of a2) (freg_of a3) :: k - | Osingleoffloat, a1 :: nil => - Pfrsp (freg_of r) (freg_of a1) :: k - | Ointoffloat, a1 :: nil => - Pfcti (ireg_of r) (freg_of a1) :: k - | Ointuoffloat, a1 :: nil => - Pfctiu (ireg_of r) (freg_of a1) :: k - | Ofloatofint, a1 :: nil => - Pictf (freg_of r) (ireg_of a1) :: k - | Ofloatofintu, a1 :: nil => - Piuctf (freg_of r) (ireg_of a1) :: k - | Ocmp cmp, _ => - let p := crbit_for_cond cmp in - transl_cond cmp args - (Pmfcrbit (ireg_of r) (fst p) :: - if snd p - then k - else Pxori (ireg_of r) (ireg_of r) (Cint Int.one) :: k) - | _, _ => - k (**r never happens for well-typed code *) - end. - -(** Common code to translate [Mload] and [Mstore] instructions. *) - -Definition transl_load_store - (mk1: constant -> ireg -> instruction) - (mk2: ireg -> ireg -> instruction) - (addr: addressing) (args: list mreg) (k: code) := - match addr, args with - | Aindexed ofs, a1 :: nil => - if ireg_eq (ireg_of a1) GPR0 then - Pmr GPR12 (ireg_of a1) :: - Paddis GPR12 GPR12 (Cint (high_s ofs)) :: - mk1 (Cint (low_s ofs)) GPR12 :: k - else if Int.eq (high_s ofs) Int.zero then - mk1 (Cint ofs) (ireg_of a1) :: k - else - Paddis GPR12 (ireg_of a1) (Cint (high_s ofs)) :: - mk1 (Cint (low_s ofs)) GPR12 :: k - | Aindexed2, a1 :: a2 :: nil => - mk2 (ireg_of a1) (ireg_of a2) :: k - | Aglobal symb ofs, nil => - Paddis GPR12 GPR0 (Csymbol_high symb ofs) :: - mk1 (Csymbol_low symb ofs) GPR12 :: k - | Abased symb ofs, a1 :: nil => - if ireg_eq (ireg_of a1) GPR0 then - Pmr GPR12 (ireg_of a1) :: - Paddis GPR12 GPR12 (Csymbol_high symb ofs) :: - mk1 (Csymbol_low symb ofs) GPR12 :: k - else - Paddis GPR12 (ireg_of a1) (Csymbol_high symb ofs) :: - mk1 (Csymbol_low symb ofs) GPR12 :: k - | Ainstack ofs, nil => - if Int.eq (high_s ofs) Int.zero then - mk1 (Cint ofs) GPR1 :: k - else - Paddis GPR12 GPR1 (Cint (high_s ofs)) :: - mk1 (Cint (low_s ofs)) GPR12 :: k - | _, _ => - (* should not happen *) k - end. - -(** Translation of a Mach instruction. *) - -Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := - match i with - | Mgetstack ofs ty dst => - loadind GPR1 ofs ty dst k - | Msetstack src ofs ty => - storeind src GPR1 ofs ty k - | Mgetparam ofs ty dst => - Plwz GPR12 (Cint f.(fn_link_ofs)) GPR1 :: loadind GPR12 ofs ty dst k - | Mop op args res => - transl_op op args res k - | Mload chunk addr args dst => - match chunk with - | Mint8signed => - transl_load_store - (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) addr args - (Pextsb (ireg_of dst) (ireg_of dst) :: k) - | Mint8unsigned => - transl_load_store - (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) addr args k - | Mint16signed => - transl_load_store - (Plha (ireg_of dst)) (Plhax (ireg_of dst)) addr args k - | Mint16unsigned => - transl_load_store - (Plhz (ireg_of dst)) (Plhzx (ireg_of dst)) addr args k - | Mint32 => - transl_load_store - (Plwz (ireg_of dst)) (Plwzx (ireg_of dst)) addr args k - | Mfloat32 => - transl_load_store - (Plfs (freg_of dst)) (Plfsx (freg_of dst)) addr args k - | Mfloat64 => - transl_load_store - (Plfd (freg_of dst)) (Plfdx (freg_of dst)) addr args k - end - | Mstore chunk addr args src => - match chunk with - | Mint8signed => - transl_load_store - (Pstb (ireg_of src)) (Pstbx (ireg_of src)) addr args k - | Mint8unsigned => - transl_load_store - (Pstb (ireg_of src)) (Pstbx (ireg_of src)) addr args k - | Mint16signed => - transl_load_store - (Psth (ireg_of src)) (Psthx (ireg_of src)) addr args k - | Mint16unsigned => - transl_load_store - (Psth (ireg_of src)) (Psthx (ireg_of src)) addr args k - | Mint32 => - transl_load_store - (Pstw (ireg_of src)) (Pstwx (ireg_of src)) addr args k - | Mfloat32 => - transl_load_store - (Pstfs (freg_of src)) (Pstfsx (freg_of src)) addr args k - | Mfloat64 => - transl_load_store - (Pstfd (freg_of src)) (Pstfdx (freg_of src)) addr args k - end - | Mcall sig (inl r) => - Pmtctr (ireg_of r) :: Pbctrl :: k - | Mcall sig (inr symb) => - Pbl symb :: k - | Mtailcall sig (inl r) => - Pmtctr (ireg_of r) :: - Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: - Pmtlr GPR12 :: - Pfreeframe f.(fn_link_ofs) :: - Pbctr :: k - | Mtailcall sig (inr symb) => - Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: - Pmtlr GPR12 :: - Pfreeframe f.(fn_link_ofs) :: - Pbs symb :: k - | Malloc => - Pallocblock :: k - | Mlabel lbl => - Plabel lbl :: k - | Mgoto lbl => - Pb lbl :: k - | Mcond cond args lbl => - let p := crbit_for_cond cond in - transl_cond cond args - (if (snd p) then Pbt (fst p) lbl :: k else Pbf (fst p) lbl :: k) - | Mreturn => - Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: - Pmtlr GPR12 :: - Pfreeframe f.(fn_link_ofs) :: - Pblr :: k - end. - -Definition transl_code (f: Mach.function) (il: list Mach.instruction) := - List.fold_right (transl_instr f) nil il. - -(** Translation of a whole function. Note that we must check - that the generated code contains less than [2^32] instructions, - otherwise the offset part of the [PC] code pointer could wrap - around, leading to incorrect executions. *) - -Definition transl_function (f: Mach.function) := - Pallocframe (- f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: - Pmflr GPR12 :: - Pstw GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: - transl_code f f.(fn_code). - -Fixpoint code_size (c: code) : Z := - match c with - | nil => 0 - | instr :: c' => code_size c' + 1 - end. - -Open Local Scope string_scope. - -Definition transf_function (f: Mach.function) : res PPC.code := - let c := transl_function f in - if zlt Int.max_unsigned (code_size c) - then Errors.Error (msg "code size exceeded") - else Errors.OK c. - -Definition transf_fundef (f: Mach.fundef) : res PPC.fundef := - transf_partial_fundef transf_function f. - -Definition transf_program (p: Mach.program) : res PPC.program := - transform_partial_program transf_fundef p. - diff --git a/backend/PPCgenproof.v b/backend/PPCgenproof.v deleted file mode 100644 index 6db8b477..00000000 --- a/backend/PPCgenproof.v +++ /dev/null @@ -1,1393 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for PPC generation: main proof. *) - -Require Import Coqlib. -Require Import Maps. -Require Import Errors. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Mach. -Require Import Machconcr. -Require Import Machtyping. -Require Import PPC. -Require Import PPCgen. -Require Import PPCgenretaddr. -Require Import PPCgenproof1. - -Section PRESERVATION. - -Variable prog: Mach.program. -Variable tprog: PPC.program. -Hypothesis TRANSF: transf_program prog = Errors.OK tprog. - -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof. - intros. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. - -Lemma functions_translated: - forall b f, - Genv.find_funct_ptr ge b = Some f -> - exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Errors.OK tf. -Proof - (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). - -Lemma functions_transl: - forall f b, - Genv.find_funct_ptr ge b = Some (Internal f) -> - Genv.find_funct_ptr tge b = Some (Internal (transl_function f)). -Proof. - intros. - destruct (functions_translated _ _ H) as [tf [A B]]. - rewrite A. generalize B. unfold transf_fundef, transf_partial_fundef, transf_function. - case (zlt Int.max_unsigned (code_size (transl_function f))); simpl; intro. - congruence. intro. inv B0. auto. -Qed. - -Lemma functions_transl_no_overflow: - forall b f, - Genv.find_funct_ptr ge b = Some (Internal f) -> - code_size (transl_function f) <= Int.max_unsigned. -Proof. - intros. - destruct (functions_translated _ _ H) as [tf [A B]]. - generalize B. unfold transf_fundef, transf_partial_fundef, transf_function. - case (zlt Int.max_unsigned (code_size (transl_function f))); simpl; intro. - congruence. intro; omega. -Qed. - -(** * Properties of control flow *) - -Lemma find_instr_in: - forall c pos i, - find_instr pos c = Some i -> In i c. -Proof. - induction c; simpl. intros; discriminate. - intros until i. case (zeq pos 0); intros. - left; congruence. right; eauto. -Qed. - -Lemma find_instr_tail: - forall c1 i c2 pos, - code_tail pos c1 (i :: c2) -> - find_instr pos c1 = Some i. -Proof. - induction c1; simpl; intros. - inv H. - destruct (zeq pos 0). subst pos. - inv H. auto. generalize (code_tail_pos _ _ _ H4). intro. omegaContradiction. - inv H. congruence. replace (pos0 + 1 - 1) with pos0 by omega. - eauto. -Qed. - -Remark code_size_pos: - forall fn, code_size fn >= 0. -Proof. - induction fn; simpl; omega. -Qed. - -Remark code_tail_bounds: - forall fn ofs i c, - code_tail ofs fn (i :: c) -> 0 <= ofs < code_size fn. -Proof. - assert (forall ofs fn c, code_tail ofs fn c -> - forall i c', c = i :: c' -> 0 <= ofs < code_size fn). - induction 1; intros; simpl. - rewrite H. simpl. generalize (code_size_pos c'). omega. - generalize (IHcode_tail _ _ H0). omega. - eauto. -Qed. - -Lemma code_tail_next: - forall fn ofs i c, - code_tail ofs fn (i :: c) -> - code_tail (ofs + 1) fn c. -Proof. - assert (forall ofs fn c, code_tail ofs fn c -> - forall i c', c = i :: c' -> code_tail (ofs + 1) fn c'). - induction 1; intros. - subst c. constructor. constructor. - constructor. eauto. - eauto. -Qed. - -Lemma code_tail_next_int: - forall fn ofs i c, - code_size fn <= Int.max_unsigned -> - code_tail (Int.unsigned ofs) fn (i :: c) -> - code_tail (Int.unsigned (Int.add ofs Int.one)) fn c. -Proof. - intros. rewrite Int.add_unsigned. - change (Int.unsigned Int.one) with 1. - rewrite Int.unsigned_repr. apply code_tail_next with i; auto. - generalize (code_tail_bounds _ _ _ _ H0). omega. -Qed. - -(** [transl_code_at_pc pc fn c] holds if the code pointer [pc] points - within the PPC code generated by translating Mach function [fn], - and [c] is the tail of the generated code at the position corresponding - to the code pointer [pc]. *) - -Inductive transl_code_at_pc: val -> block -> Mach.function -> Mach.code -> Prop := - transl_code_at_pc_intro: - forall b ofs f c, - Genv.find_funct_ptr ge b = Some (Internal f) -> - code_tail (Int.unsigned ofs) (transl_function f) (transl_code f c) -> - transl_code_at_pc (Vptr b ofs) b f c. - -(** The following lemmas show that straight-line executions - (predicate [exec_straight]) correspond to correct PPC executions - (predicate [exec_steps]) under adequate [transl_code_at_pc] hypotheses. *) - -Lemma exec_straight_steps_1: - forall fn c rs m c' rs' m', - exec_straight tge fn c rs m c' rs' m' -> - code_size fn <= Int.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr tge b = Some (Internal fn) -> - code_tail (Int.unsigned ofs) fn c -> - plus step tge (State rs m) E0 (State rs' m'). -Proof. - induction 1; intros. - apply plus_one. - econstructor; eauto. - eapply find_instr_tail. eauto. - eapply plus_left'. - econstructor; eauto. - eapply find_instr_tail. eauto. - apply IHexec_straight with b (Int.add ofs Int.one). - auto. rewrite H0. rewrite H3. reflexivity. - auto. - apply code_tail_next_int with i; auto. - traceEq. -Qed. - -Lemma exec_straight_steps_2: - forall fn c rs m c' rs' m', - exec_straight tge fn c rs m c' rs' m' -> - code_size fn <= Int.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr tge b = Some (Internal fn) -> - code_tail (Int.unsigned ofs) fn c -> - exists ofs', - rs'#PC = Vptr b ofs' - /\ code_tail (Int.unsigned ofs') fn c'. -Proof. - induction 1; intros. - exists (Int.add ofs Int.one). split. - rewrite H0. rewrite H2. auto. - apply code_tail_next_int with i1; auto. - apply IHexec_straight with (Int.add ofs Int.one). - auto. rewrite H0. rewrite H3. reflexivity. auto. - apply code_tail_next_int with i; auto. -Qed. - -Lemma exec_straight_exec: - forall fb f c c' rs m rs' m', - transl_code_at_pc (rs PC) fb f c -> - exec_straight tge (transl_function f) - (transl_code f c) rs m c' rs' m' -> - plus step tge (State rs m) E0 (State rs' m'). -Proof. - intros. inversion H. subst. - eapply exec_straight_steps_1; eauto. - eapply functions_transl_no_overflow; eauto. - eapply functions_transl; eauto. -Qed. - -Lemma exec_straight_at: - forall fb f c c' rs m rs' m', - transl_code_at_pc (rs PC) fb f c -> - exec_straight tge (transl_function f) - (transl_code f c) rs m (transl_code f c') rs' m' -> - transl_code_at_pc (rs' PC) fb f c'. -Proof. - intros. inversion H. subst. - generalize (functions_transl_no_overflow _ _ H2). intro. - generalize (functions_transl _ _ H2). intro. - generalize (exec_straight_steps_2 _ _ _ _ _ _ _ - H0 H4 _ _ (sym_equal H1) H5 H3). - intros [ofs' [PC' CT']]. - rewrite PC'. constructor; auto. -Qed. - -(** Correctness of the return addresses predicted by - [PPCgen.return_address_offset]. *) - -Remark code_tail_no_bigger: - forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. -Proof. - induction 1; simpl; omega. -Qed. - -Remark code_tail_unique: - forall fn c pos pos', - code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. -Proof. - induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - f_equal. eauto. -Qed. - -Lemma return_address_offset_correct: - forall b ofs fb f c ofs', - transl_code_at_pc (Vptr b ofs) fb f c -> - return_address_offset f c ofs' -> - ofs' = ofs. -Proof. - intros. inv H0. inv H. - generalize (code_tail_unique _ _ _ _ H1 H7). intro. rewrite H. - apply Int.repr_unsigned. -Qed. - -(** The [find_label] function returns the code tail starting at the - given label. A connection with [code_tail] is then established. *) - -Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := - match c with - | nil => None - | instr :: c' => - if is_label lbl instr then Some c' else find_label lbl c' - end. - -Lemma label_pos_code_tail: - forall lbl c pos c', - find_label lbl c = Some c' -> - exists pos', - label_pos lbl pos c = Some pos' - /\ code_tail (pos' - pos) c c' - /\ pos < pos' <= pos + code_size c. -Proof. - induction c. - simpl; intros. discriminate. - simpl; intros until c'. - case (is_label lbl a). - intro EQ; injection EQ; intro; subst c'. - exists (pos + 1). split. auto. split. - replace (pos + 1 - pos) with (0 + 1) by omega. constructor. constructor. - generalize (code_size_pos c). omega. - intros. generalize (IHc (pos + 1) c' H). intros [pos' [A [B C]]]. - exists pos'. split. auto. split. - replace (pos' - pos) with ((pos' - (pos + 1)) + 1) by omega. - constructor. auto. - omega. -Qed. - -(** The following lemmas show that the translation from Mach to PPC - preserves labels, in the sense that the following diagram commutes: -<< - translation - Mach code ------------------------ PPC instr sequence - | | - | Mach.find_label lbl find_label lbl | - | | - v v - Mach code tail ------------------- PPC instr seq tail - translation ->> - The proof demands many boring lemmas showing that PPC constructor - functions do not introduce new labels. -*) - -Section TRANSL_LABEL. - -Variable lbl: label. - -Remark loadimm_label: - forall r n k, find_label lbl (loadimm r n k) = find_label lbl k. -Proof. - intros. unfold loadimm. - case (Int.eq (high_s n) Int.zero). reflexivity. - case (Int.eq (low_s n) Int.zero). reflexivity. - reflexivity. -Qed. -Hint Rewrite loadimm_label: labels. - -Remark addimm_1_label: - forall r1 r2 n k, find_label lbl (addimm_1 r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold addimm_1. - case (Int.eq (high_s n) Int.zero). reflexivity. - case (Int.eq (low_s n) Int.zero). reflexivity. reflexivity. -Qed. -Remark addimm_2_label: - forall r1 r2 n k, find_label lbl (addimm_2 r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold addimm_2. autorewrite with labels. reflexivity. -Qed. -Remark addimm_label: - forall r1 r2 n k, find_label lbl (addimm r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold addimm. - case (ireg_eq r1 GPR0); intro. apply addimm_2_label. - case (ireg_eq r2 GPR0); intro. apply addimm_2_label. - apply addimm_1_label. -Qed. -Hint Rewrite addimm_label: labels. - -Remark andimm_label: - forall r1 r2 n k, find_label lbl (andimm r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold andimm. - case (Int.eq (high_u n) Int.zero). reflexivity. - case (Int.eq (low_u n) Int.zero). reflexivity. - autorewrite with labels. reflexivity. -Qed. -Hint Rewrite andimm_label: labels. - -Remark orimm_label: - forall r1 r2 n k, find_label lbl (orimm r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold orimm. - case (Int.eq (high_u n) Int.zero). reflexivity. - case (Int.eq (low_u n) Int.zero). reflexivity. reflexivity. -Qed. -Hint Rewrite orimm_label: labels. - -Remark xorimm_label: - forall r1 r2 n k, find_label lbl (xorimm r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold xorimm. - case (Int.eq (high_u n) Int.zero). reflexivity. - case (Int.eq (low_u n) Int.zero). reflexivity. reflexivity. -Qed. -Hint Rewrite xorimm_label: labels. - -Remark loadind_aux_label: - forall base ofs ty dst k, find_label lbl (loadind_aux base ofs ty dst :: k) = find_label lbl k. -Proof. - intros; unfold loadind_aux. - case ty; reflexivity. -Qed. -Remark loadind_label: - forall base ofs ty dst k, find_label lbl (loadind base ofs ty dst k) = find_label lbl k. -Proof. - intros; unfold loadind. - case (Int.eq (high_s ofs) Int.zero). apply loadind_aux_label. - transitivity (find_label lbl (loadind_aux GPR12 (low_s ofs) ty dst :: k)). - reflexivity. apply loadind_aux_label. -Qed. -Hint Rewrite loadind_label: labels. -Remark storeind_aux_label: - forall base ofs ty dst k, find_label lbl (storeind_aux base ofs ty dst :: k) = find_label lbl k. -Proof. - intros; unfold storeind_aux. - case dst; reflexivity. -Qed. -Remark storeind_label: - forall base ofs ty src k, find_label lbl (storeind base src ofs ty k) = find_label lbl k. -Proof. - intros; unfold storeind. - case (Int.eq (high_s ofs) Int.zero). apply storeind_aux_label. - transitivity (find_label lbl (storeind_aux base GPR12 (low_s ofs) ty :: k)). - reflexivity. apply storeind_aux_label. -Qed. -Hint Rewrite storeind_label: labels. -Remark floatcomp_label: - forall cmp r1 r2 k, find_label lbl (floatcomp cmp r1 r2 k) = find_label lbl k. -Proof. - intros; unfold floatcomp. destruct cmp; reflexivity. -Qed. - -Remark transl_cond_label: - forall cond args k, find_label lbl (transl_cond cond args k) = find_label lbl k. -Proof. - intros; unfold transl_cond. - destruct cond; (destruct args; - [try reflexivity | destruct args; - [try reflexivity | destruct args; try reflexivity]]). - case (Int.eq (high_s i) Int.zero). reflexivity. - autorewrite with labels; reflexivity. - case (Int.eq (high_u i) Int.zero). reflexivity. - autorewrite with labels; reflexivity. - apply floatcomp_label. apply floatcomp_label. - apply andimm_label. apply andimm_label. -Qed. -Hint Rewrite transl_cond_label: labels. -Remark transl_op_label: - forall op args r k, find_label lbl (transl_op op args r k) = find_label lbl k. -Proof. - intros; unfold transl_op; - destruct op; destruct args; try (destruct args); try (destruct args); try (destruct args); - try reflexivity; autorewrite with labels; try reflexivity. - case (mreg_type m); reflexivity. - case (Int.eq (high_s i) Int.zero); autorewrite with labels; reflexivity. - case (Int.eq (high_s i) Int.zero); autorewrite with labels; reflexivity. - case (snd (crbit_for_cond c)); reflexivity. - case (snd (crbit_for_cond c)); reflexivity. - case (snd (crbit_for_cond c)); reflexivity. - case (snd (crbit_for_cond c)); reflexivity. - case (snd (crbit_for_cond c)); reflexivity. -Qed. -Hint Rewrite transl_op_label: labels. - -Remark transl_load_store_label: - forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) - addr args k, - (forall c r, is_label lbl (mk1 c r) = false) -> - (forall r1 r2, is_label lbl (mk2 r1 r2) = false) -> - find_label lbl (transl_load_store mk1 mk2 addr args k) = find_label lbl k. -Proof. - intros; unfold transl_load_store. - destruct addr; destruct args; try (destruct args); try (destruct args); - try reflexivity. - case (ireg_eq (ireg_of m) GPR0); intro. - simpl. rewrite H. auto. - case (Int.eq (high_s i) Int.zero). simpl; rewrite H; auto. - simpl; rewrite H; auto. - simpl; rewrite H0; auto. - simpl; rewrite H; auto. - case (ireg_eq (ireg_of m) GPR0); intro; simpl; rewrite H; auto. - case (Int.eq (high_s i) Int.zero); simpl; rewrite H; auto. -Qed. -Hint Rewrite transl_load_store_label: labels. - -Lemma transl_instr_label: - forall f i k, - find_label lbl (transl_instr f i k) = - if Mach.is_label lbl i then Some k else find_label lbl k. -Proof. - intros. generalize (Mach.is_label_correct lbl i). - case (Mach.is_label lbl i); intro. - subst i. simpl. rewrite peq_true. auto. - destruct i; simpl; autorewrite with labels; try reflexivity. - destruct m; rewrite transl_load_store_label; intros; reflexivity. - destruct m; rewrite transl_load_store_label; intros; reflexivity. - destruct s0; reflexivity. - destruct s0; reflexivity. - rewrite peq_false. auto. congruence. - case (snd (crbit_for_cond c)); reflexivity. -Qed. - -Lemma transl_code_label: - forall f c, - find_label lbl (transl_code f c) = - option_map (transl_code f) (Mach.find_label lbl c). -Proof. - induction c; simpl; intros. - auto. rewrite transl_instr_label. - case (Mach.is_label lbl a). reflexivity. - auto. -Qed. - -Lemma transl_find_label: - forall f, - find_label lbl (transl_function f) = - option_map (transl_code f) (Mach.find_label lbl f.(fn_code)). -Proof. - intros. unfold transl_function. simpl. apply transl_code_label. -Qed. - -End TRANSL_LABEL. - -(** A valid branch in a piece of Mach code translates to a valid ``go to'' - transition in the generated PPC code. *) - -Lemma find_label_goto_label: - forall f lbl rs m c' b ofs, - Genv.find_funct_ptr ge b = Some (Internal f) -> - rs PC = Vptr b ofs -> - Mach.find_label lbl f.(fn_code) = Some c' -> - exists rs', - goto_label (transl_function f) lbl rs m = OK rs' m - /\ transl_code_at_pc (rs' PC) b f c' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. - generalize (transl_find_label lbl f). - rewrite H1; simpl. intro. - generalize (label_pos_code_tail lbl (transl_function f) 0 - (transl_code f c') H2). - intros [pos' [A [B C]]]. - exists (rs#PC <- (Vptr b (Int.repr pos'))). - split. unfold goto_label. rewrite A. rewrite H0. auto. - split. rewrite Pregmap.gss. constructor; auto. - rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in B. - auto. omega. - generalize (functions_transl_no_overflow _ _ H). - omega. - intros. apply Pregmap.gso; auto. -Qed. - -(** * Memory properties *) - -(** The PowerPC has no instruction for ``load 8-bit signed integer''. - We show that it can be synthesized as a ``load 8-bit unsigned integer'' - followed by a sign extension. *) - -Remark valid_access_equiv: - forall chunk1 chunk2 m b ofs, - size_chunk chunk1 = size_chunk chunk2 -> - valid_access m chunk1 b ofs -> - valid_access m chunk2 b ofs. -Proof. - intros. inv H0. rewrite H in H3. constructor; auto. -Qed. - -Remark in_bounds_equiv: - forall chunk1 chunk2 m b ofs (A: Set) (a1 a2: A), - size_chunk chunk1 = size_chunk chunk2 -> - (if in_bounds m chunk1 b ofs then a1 else a2) = - (if in_bounds m chunk2 b ofs then a1 else a2). -Proof. - intros. destruct (in_bounds m chunk1 b ofs). - rewrite in_bounds_true. auto. eapply valid_access_equiv; eauto. - destruct (in_bounds m chunk2 b ofs); auto. - elim n. eapply valid_access_equiv with (chunk1 := chunk2); eauto. -Qed. - -Lemma loadv_8_signed_unsigned: - forall m a, - Mem.loadv Mint8signed m a = - option_map (Val.sign_ext 8) (Mem.loadv Mint8unsigned m a). -Proof. - intros. unfold Mem.loadv. destruct a; try reflexivity. - unfold load. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). - destruct (in_bounds m Mint8unsigned b (Int.signed i)); auto. - simpl. - destruct (getN 0 (Int.signed i) (contents (blocks m b))); auto. - simpl. rewrite Int.sign_ext_zero_ext. auto. compute; auto. - auto. -Qed. - -(** Similarly, we show that signed 8- and 16-bit stores can be performed - like unsigned stores. *) - -Lemma storev_8_signed_unsigned: - forall m a v, - Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v. -Proof. - intros. unfold storev. destruct a; auto. - unfold store. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). - auto. auto. -Qed. - -Lemma storev_16_signed_unsigned: - forall m a v, - Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v. -Proof. - intros. unfold storev. destruct a; auto. - unfold store. rewrite (in_bounds_equiv Mint16signed Mint16unsigned). - auto. auto. -Qed. - -(** * Proof of semantic preservation *) - -(** Semantic preservation is proved using simulation diagrams - of the following form. -<< - st1 --------------- st2 - | | - t| *|t - | | - v v - st1'--------------- st2' ->> - The invariant is the [match_states] predicate below, which includes: -- The PPC code pointed by the PC register is the translation of - the current Mach code sequence. -- Mach register values and PPC register values agree. -*) - -Inductive match_stack: list Machconcr.stackframe -> Prop := - | match_stack_nil: - match_stack nil - | match_stack_cons: forall fb sp ra c s f, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - wt_function f -> - incl c f.(fn_code) -> - transl_code_at_pc ra fb f c -> - match_stack s -> - match_stack (Stackframe fb sp ra c :: s). - -Inductive match_states: Machconcr.state -> PPC.state -> Prop := - | match_states_intro: - forall s fb sp c ms m rs f - (STACKS: match_stack s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (WTF: wt_function f) - (INCL: incl c f.(fn_code)) - (AT: transl_code_at_pc (rs PC) fb f c) - (AG: agree ms sp rs), - match_states (Machconcr.State s fb sp c ms m) - (PPC.State rs m) - | match_states_call: - forall s fb ms m rs - (STACKS: match_stack s) - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Int.zero) - (ATLR: rs LR = parent_ra s), - match_states (Machconcr.Callstate s fb ms m) - (PPC.State rs m) - | match_states_return: - forall s ms m rs - (STACKS: match_stack s) - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_states (Machconcr.Returnstate s ms m) - (PPC.State rs m). - -Lemma exec_straight_steps: - forall s fb sp m1 f c1 rs1 c2 m2 ms2, - match_stack s -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - wt_function f -> - incl c2 f.(fn_code) -> - transl_code_at_pc (rs1 PC) fb f c1 -> - (exists rs2, - exec_straight tge (transl_function f) (transl_code f c1) rs1 m1 (transl_code f c2) rs2 m2 - /\ agree ms2 sp rs2) -> - exists st', - plus step tge (State rs1 m1) E0 st' /\ - match_states (Machconcr.State s fb sp c2 ms2 m2) st'. -Proof. - intros. destruct H4 as [rs2 [A B]]. - exists (State rs2 m2); split. - eapply exec_straight_exec; eauto. - econstructor; eauto. eapply exec_straight_at; eauto. -Qed. - -(** We need to show that, in the simulation diagram, we cannot - take infinitely many Mach transitions that correspond to zero - transitions on the PPC side. Actually, all Mach transitions - correspond to at least one PPC transition, except the - transition from [Machconcr.Returnstate] to [Machconcr.State]. - So, the following integer measure will suffice to rule out - the unwanted behaviour. *) - -Definition measure (s: Machconcr.state) : nat := - match s with - | Machconcr.State _ _ _ _ _ _ => 0%nat - | Machconcr.Callstate _ _ _ _ => 0%nat - | Machconcr.Returnstate _ _ _ => 1%nat - end. - -(** We show the simulation diagram by case analysis on the Mach transition - on the left. Since the proof is large, we break it into one lemma - per transition. *) - -Definition exec_instr_prop (s1: Machconcr.state) (t: trace) (s2: Machconcr.state) : Prop := - forall s1' (MS: match_states s1 s1'), - (exists s2', plus step tge s1' t s2' /\ match_states s2 s2') - \/ (measure s2 < measure s1 /\ t = E0 /\ match_states s2 s1')%nat. - - -Lemma exec_Mlabel_prop: - forall (s : list stackframe) (fb : block) (sp : val) - (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset) - (m : mem), - exec_instr_prop (Machconcr.State s fb sp (Mlabel lbl :: c) ms m) E0 - (Machconcr.State s fb sp c ms m). -Proof. - intros; red; intros; inv MS. - left; eapply exec_straight_steps; eauto with coqlib. - exists (nextinstr rs); split. - simpl. apply exec_straight_one. reflexivity. reflexivity. - apply agree_nextinstr; auto. -Qed. - -Lemma exec_Mgetstack_prop: - forall (s : list stackframe) (fb : block) (sp : val) (ofs : int) - (ty : typ) (dst : mreg) (c : list Mach.instruction) - (ms : Mach.regset) (m : mem) (v : val), - load_stack m sp ty ofs = Some v -> - exec_instr_prop (Machconcr.State s fb sp (Mgetstack ofs ty dst :: c) ms m) E0 - (Machconcr.State s fb sp c (Regmap.set dst v ms) m). -Proof. - intros; red; intros; inv MS. - unfold load_stack in H. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. - rewrite (sp_val _ _ _ AG) in H. - assert (NOTE: GPR1 <> GPR0). congruence. - generalize (loadind_correct tge (transl_function f) GPR1 ofs ty - dst (transl_code f c) rs m v H H1 NOTE). - intros [rs2 [EX [RES OTH]]]. - left; eapply exec_straight_steps; eauto with coqlib. - simpl. exists rs2; split. auto. - apply agree_exten_2 with (rs#(preg_of dst) <- v). - auto with ppcgen. - intros. case (preg_eq r0 (preg_of dst)); intro. - subst r0. rewrite Pregmap.gss. auto. - rewrite Pregmap.gso; auto. -Qed. - -Lemma exec_Msetstack_prop: - forall (s : list stackframe) (fb : block) (sp : val) (src : mreg) - (ofs : int) (ty : typ) (c : list Mach.instruction) - (ms : mreg -> val) (m m' : mem), - store_stack m sp ty ofs (ms src) = Some m' -> - exec_instr_prop (Machconcr.State s fb sp (Msetstack src ofs ty :: c) ms m) E0 - (Machconcr.State s fb sp c ms m'). -Proof. - intros; red; intros; inv MS. - unfold store_stack in H. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. - rewrite (sp_val _ _ _ AG) in H. - rewrite (preg_val ms sp rs) in H; auto. - assert (NOTE: GPR1 <> GPR0). congruence. - generalize (storeind_correct tge (transl_function f) GPR1 ofs ty - src (transl_code f c) rs m m' H H1 NOTE). - intros [rs2 [EX OTH]]. - left; eapply exec_straight_steps; eauto with coqlib. - exists rs2; split; auto. - apply agree_exten_2 with rs; auto. -Qed. - -Lemma exec_Mgetparam_prop: - forall (s : list stackframe) (fb : block) (f: Mach.function) (sp parent : val) - (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction) - (ms : Mach.regset) (m : mem) (v : val), - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m sp Tint f.(fn_link_ofs) = Some parent -> - load_stack m parent ty ofs = Some v -> - exec_instr_prop (Machconcr.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0 - (Machconcr.State s fb sp c (Regmap.set dst v ms) m). -Proof. - intros; red; intros; inv MS. - assert (f0 = f) by congruence. subst f0. - set (rs2 := nextinstr (rs#GPR12 <- parent)). - assert (EX1: exec_straight tge (transl_function f) - (transl_code f (Mgetparam ofs ty dst :: c)) rs m - (loadind GPR12 ofs ty dst (transl_code f c)) rs2 m). - simpl. apply exec_straight_one. - simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto with ppcgen. - unfold const_low. rewrite <- (sp_val ms sp rs); auto. - unfold load_stack in H0. simpl chunk_of_type in H0. - rewrite H0. reflexivity. reflexivity. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. - unfold load_stack in H1. change parent with rs2#GPR12 in H1. - assert (NOTE: GPR12 <> GPR0). congruence. - generalize (loadind_correct tge (transl_function f) GPR12 ofs ty - dst (transl_code f c) rs2 m v H1 H3 NOTE). - intros [rs3 [EX2 [RES OTH]]]. - left; eapply exec_straight_steps; eauto with coqlib. - exists rs3; split; simpl. - eapply exec_straight_trans; eauto. - apply agree_exten_2 with (rs2#(preg_of dst) <- v). - unfold rs2; auto with ppcgen. - intros. case (preg_eq r0 (preg_of dst)); intro. - subst r0. rewrite Pregmap.gss. auto. - rewrite Pregmap.gso; auto. -Qed. - -Lemma exec_Mop_prop: - forall (s : list stackframe) (fb : block) (sp : val) (op : operation) - (args : list mreg) (res : mreg) (c : list Mach.instruction) - (ms : mreg -> val) (m : mem) (v : val), - eval_operation ge sp op ms ## args m = Some v -> - exec_instr_prop (Machconcr.State s fb sp (Mop op args res :: c) ms m) E0 - (Machconcr.State s fb sp c (Regmap.set res v ms) m). -Proof. - intros; red; intros; inv MS. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. - left; eapply exec_straight_steps; eauto with coqlib. - simpl. eapply transl_op_correct; auto. - rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. -Qed. - -Lemma exec_Mload_prop: - forall (s : list stackframe) (fb : block) (sp : val) - (chunk : memory_chunk) (addr : addressing) (args : list mreg) - (dst : mreg) (c : list Mach.instruction) (ms : mreg -> val) - (m : mem) (a v : val), - eval_addressing ge sp addr ms ## args = Some a -> - loadv chunk m a = Some v -> - exec_instr_prop (Machconcr.State s fb sp (Mload chunk addr args dst :: c) ms m) - E0 (Machconcr.State s fb sp c (Regmap.set dst v ms) m). -Proof. - intros; red; intros; inv MS. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI; inversion WTI. - assert (eval_addressing tge sp addr ms##args = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - left; eapply exec_straight_steps; eauto with coqlib; - destruct chunk; simpl; simpl in H6; - (* all cases but Mint8signed *) - try (eapply transl_load_correct; eauto; - intros; simpl; unfold preg_of; rewrite H6; auto). - (* Mint8signed *) - generalize (loadv_8_signed_unsigned m a). - rewrite H0. - caseEq (loadv Mint8unsigned m a); - [idtac | simpl;intros;discriminate]. - intros v' LOAD' EQ. simpl in EQ. injection EQ. intro EQ1. clear EQ. - assert (X1: forall (cst : constant) (r1 : ireg) (rs1 : regset), - exec_instr tge (transl_function f) (Plbz (ireg_of dst) cst r1) rs1 m = - load1 tge Mint8unsigned (preg_of dst) cst r1 rs1 m). - intros. unfold preg_of; rewrite H6. reflexivity. - assert (X2: forall (r1 r2 : ireg) (rs1 : regset), - exec_instr tge (transl_function f) (Plbzx (ireg_of dst) r1 r2) rs1 m = - load2 Mint8unsigned (preg_of dst) r1 r2 rs1 m). - intros. unfold preg_of; rewrite H6. reflexivity. - generalize (transl_load_correct tge (transl_function f) - (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) - Mint8unsigned addr args - (Pextsb (ireg_of dst) (ireg_of dst) :: transl_code f c) - ms sp rs m dst a v' - X1 X2 AG H3 H7 LOAD'). - intros [rs2 [EX1 AG1]]. - exists (nextinstr (rs2#(ireg_of dst) <- v)). - split. eapply exec_straight_trans. eexact EX1. - apply exec_straight_one. simpl. - rewrite <- (ireg_val _ _ _ dst AG1);auto. rewrite Regmap.gss. - rewrite EQ1. reflexivity. reflexivity. - eauto with ppcgen. -Qed. - -Lemma exec_Mstore_prop: - forall (s : list stackframe) (fb : block) (sp : val) - (chunk : memory_chunk) (addr : addressing) (args : list mreg) - (src : mreg) (c : list Mach.instruction) (ms : mreg -> val) - (m m' : mem) (a : val), - eval_addressing ge sp addr ms ## args = Some a -> - storev chunk m a (ms src) = Some m' -> - exec_instr_prop (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0 - (Machconcr.State s fb sp c ms m'). -Proof. - intros; red; intros; inv MS. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI; inversion WTI. - rewrite <- (eval_addressing_preserved symbols_preserved) in H. - left; eapply exec_straight_steps; eauto with coqlib. - destruct chunk; simpl; simpl in H6; - try (rewrite storev_8_signed_unsigned in H0); - try (rewrite storev_16_signed_unsigned in H0); - simpl; eapply transl_store_correct; eauto; - intros; unfold preg_of; rewrite H6; reflexivity. -Qed. - -Lemma exec_Mcall_prop: - forall (s : list stackframe) (fb : block) (sp : val) - (sig : signature) (ros : mreg + ident) (c : Mach.code) - (ms : Mach.regset) (m : mem) (f : function) (f' : block) - (ra : int), - find_function_ptr ge ros ms = Some f' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - return_address_offset f c ra -> - exec_instr_prop (Machconcr.State s fb sp (Mcall sig ros :: c) ms m) E0 - (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) f' ms m). -Proof. - intros; red; intros; inv MS. - assert (f0 = f) by congruence. subst f0. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. - inv AT. - assert (NOOV: code_size (transl_function f) <= Int.max_unsigned). - eapply functions_transl_no_overflow; eauto. - destruct ros; simpl in H; simpl transl_code in H7. - (* Indirect call *) - generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1. - generalize (code_tail_next_int _ _ _ _ NOOV CT1). intro CT2. - set (rs2 := nextinstr (rs#CTR <- (ms m0))). - set (rs3 := rs2 #LR <- (Val.add rs2#PC Vone) #PC <- (ms m0)). - assert (ATPC: rs3 PC = Vptr f' Int.zero). - change (rs3 PC) with (ms m0). - destruct (ms m0); try discriminate. - generalize H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. - exploit return_address_offset_correct; eauto. constructor; eauto. - intro RA_EQ. - assert (ATLR: rs3 LR = Vptr fb ra). - rewrite RA_EQ. - change (rs3 LR) with (Val.add (Val.add (rs PC) Vone) Vone). - rewrite <- H5. reflexivity. - assert (AG3: agree ms sp rs3). - unfold rs3, rs2; auto 8 with ppcgen. - left; exists (State rs3 m); split. - apply plus_left with E0 (State rs2 m) E0. - econstructor. eauto. apply functions_transl. eexact H0. - eapply find_instr_tail. eauto. - simpl. rewrite <- (ireg_val ms sp rs); auto. - apply star_one. econstructor. - change (rs2 PC) with (Val.add (rs PC) Vone). rewrite <- H5. - simpl. auto. - apply functions_transl. eexact H0. - eapply find_instr_tail. eauto. - simpl. reflexivity. - traceEq. - econstructor; eauto. - econstructor; eauto with coqlib. - rewrite RA_EQ. econstructor; eauto. - (* Direct call *) - generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1. - set (rs2 := rs #LR <- (Val.add rs#PC Vone) #PC <- (symbol_offset tge i Int.zero)). - assert (ATPC: rs2 PC = Vptr f' Int.zero). - change (rs2 PC) with (symbol_offset tge i Int.zero). - unfold symbol_offset. rewrite symbols_preserved. rewrite H. auto. - exploit return_address_offset_correct; eauto. constructor; eauto. - intro RA_EQ. - assert (ATLR: rs2 LR = Vptr fb ra). - rewrite RA_EQ. - change (rs2 LR) with (Val.add (rs PC) Vone). - rewrite <- H5. reflexivity. - assert (AG2: agree ms sp rs2). - unfold rs2; auto 8 with ppcgen. - left; exists (State rs2 m); split. - apply plus_one. econstructor. - eauto. - apply functions_transl. eexact H0. - eapply find_instr_tail. eauto. - simpl. reflexivity. - econstructor; eauto with coqlib. - econstructor; eauto with coqlib. - rewrite RA_EQ. econstructor; eauto. -Qed. - -Lemma exec_Mtailcall_prop: - forall (s : list stackframe) (fb stk : block) (soff : int) - (sig : signature) (ros : mreg + ident) (c : list Mach.instruction) - (ms : Mach.regset) (m : mem) (f: Mach.function) (f' : block), - find_function_ptr ge ros ms = Some f' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> - exec_instr_prop - (Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0 - (Callstate s f' ms (free m stk)). -Proof. - intros; red; intros; inv MS. - assert (f0 = f) by congruence. subst f0. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. - inversion AT. subst b f0 c0. - assert (NOOV: code_size (transl_function f) <= Int.max_unsigned). - eapply functions_transl_no_overflow; eauto. - destruct ros; simpl in H; simpl in H9. - (* Indirect call *) - set (rs2 := nextinstr (rs#CTR <- (ms m0))). - set (rs3 := nextinstr (rs2#GPR12 <- (parent_ra s))). - set (rs4 := nextinstr (rs3#LR <- (parent_ra s))). - set (rs5 := nextinstr (rs4#GPR1 <- (parent_sp s))). - set (rs6 := rs5#PC <- (rs5 CTR)). - assert (exec_straight tge (transl_function f) - (transl_code f (Mtailcall sig (inl ident m0) :: c)) rs m - (Pbctr :: transl_code f c) rs5 (free m stk)). - simpl. apply exec_straight_step with rs2 m. - simpl. rewrite <- (ireg_val _ _ _ _ AG H6). reflexivity. reflexivity. - apply exec_straight_step with rs3 m. - simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. - change (rs2 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). - simpl. unfold load_stack in H2. simpl in H2. rewrite H2. - reflexivity. discriminate. reflexivity. - apply exec_straight_step with rs4 m. - simpl. reflexivity. reflexivity. - apply exec_straight_one. - simpl. change (rs4 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). - unfold load_stack in H1; simpl in H1. - simpl. rewrite H1. reflexivity. reflexivity. - left; exists (State rs6 (free m stk)); split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. - change (rs5 PC) with (Val.add (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone) Vone). - rewrite <- H7; simpl. eauto. - eapply functions_transl; eauto. - eapply find_instr_tail. - repeat (eapply code_tail_next_int; auto). eauto. - simpl. reflexivity. traceEq. - (* match states *) - econstructor; eauto. - assert (AG4: agree ms (Vptr stk soff) rs4). - unfold rs4, rs3, rs2; auto 10 with ppcgen. - assert (AG5: agree ms (parent_sp s) rs5). - unfold rs5. apply agree_nextinstr. - split. reflexivity. intros. inv AG4. rewrite H12. - rewrite Pregmap.gso; auto with ppcgen. - unfold rs6; auto with ppcgen. - change (rs6 PC) with (ms m0). - generalize H. destruct (ms m0); try congruence. - predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. - (* direct call *) - set (rs2 := nextinstr (rs#GPR12 <- (parent_ra s))). - set (rs3 := nextinstr (rs2#LR <- (parent_ra s))). - set (rs4 := nextinstr (rs3#GPR1 <- (parent_sp s))). - set (rs5 := rs4#PC <- (Vptr f' Int.zero)). - assert (exec_straight tge (transl_function f) - (transl_code f (Mtailcall sig (inr mreg i) :: c)) rs m - (Pbs i :: transl_code f c) rs4 (free m stk)). - simpl. apply exec_straight_step with rs2 m. - simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. - rewrite <- (sp_val _ _ _ AG). - simpl. unfold load_stack in H2. simpl in H2. rewrite H2. - reflexivity. discriminate. reflexivity. - apply exec_straight_step with rs3 m. - simpl. reflexivity. reflexivity. - apply exec_straight_one. - simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). - unfold load_stack in H1; simpl in H1. - simpl. rewrite H1. reflexivity. reflexivity. - left; exists (State rs5 (free m stk)); split. - (* execution *) - eapply plus_right'. eapply exec_straight_exec; eauto. - econstructor. - change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone). - rewrite <- H7; simpl. eauto. - eapply functions_transl; eauto. - eapply find_instr_tail. - repeat (eapply code_tail_next_int; auto). eauto. - simpl. unfold symbol_offset. rewrite symbols_preserved. rewrite H. - reflexivity. traceEq. - (* match states *) - econstructor; eauto. - assert (AG3: agree ms (Vptr stk soff) rs3). - unfold rs3, rs2; auto 10 with ppcgen. - assert (AG4: agree ms (parent_sp s) rs4). - unfold rs4. apply agree_nextinstr. - split. reflexivity. intros. inv AG3. rewrite H12. - rewrite Pregmap.gso; auto with ppcgen. - unfold rs5; auto with ppcgen. -Qed. - -Lemma exec_Malloc_prop: - forall (s : list stackframe) (fb : block) (sp : val) - (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (sz : int) - (m' : mem) (blk : block), - ms Conventions.loc_alloc_argument = Vint sz -> - alloc m 0 (Int.signed sz) = (m', blk) -> - exec_instr_prop (Machconcr.State s fb sp (Malloc :: c) ms m) E0 - (Machconcr.State s fb sp c - (Regmap.set (Conventions.loc_alloc_result) (Vptr blk Int.zero) ms) m'). -Proof. - intros; red; intros; inv MS. - left; eapply exec_straight_steps; eauto with coqlib. - simpl. eapply transl_alloc_correct; eauto. -Qed. - -Lemma exec_Mgoto_prop: - forall (s : list stackframe) (fb : block) (f : function) (sp : val) - (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset) - (m : mem) (c' : Mach.code), - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl (fn_code f) = Some c' -> - exec_instr_prop (Machconcr.State s fb sp (Mgoto lbl :: c) ms m) E0 - (Machconcr.State s fb sp c' ms m). -Proof. - intros; red; intros; inv MS. - assert (f0 = f) by congruence. subst f0. - inv AT. simpl in H3. - generalize (find_label_goto_label f lbl rs m _ _ _ FIND (sym_equal H1) H0). - intros [rs2 [GOTO [AT2 INV]]]. - left; exists (State rs2 m); split. - apply plus_one. econstructor; eauto. - apply functions_transl; eauto. - eapply find_instr_tail; eauto. - simpl; auto. - econstructor; eauto. - eapply Mach.find_label_incl; eauto. - apply agree_exten_2 with rs; auto. -Qed. - -Lemma exec_Mcond_true_prop: - forall (s : list stackframe) (fb : block) (f : function) (sp : val) - (cond : condition) (args : list mreg) (lbl : Mach.label) - (c : list Mach.instruction) (ms : mreg -> val) (m : mem) - (c' : Mach.code), - eval_condition cond ms ## args m = Some true -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mach.find_label lbl (fn_code f) = Some c' -> - exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 - (Machconcr.State s fb sp c' ms m). -Proof. - intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inv WTI. - pose (k1 := - if snd (crbit_for_cond cond) - then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c - else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c). - generalize (transl_cond_correct tge (transl_function f) - cond args k1 ms sp rs m true H3 AG H). - simpl. intros [rs2 [EX [RES AG2]]]. - inv AT. simpl in H5. - generalize (functions_transl _ _ H4); intro FN. - generalize (functions_transl_no_overflow _ _ H4); intro NOOV. - exploit exec_straight_steps_2; eauto. - intros [ofs' [PC2 CT2]]. - generalize (find_label_goto_label f lbl rs2 m _ _ _ FIND PC2 H1). - intros [rs3 [GOTO [AT3 INV3]]]. - left; exists (State rs3 m); split. - eapply plus_right'. - eapply exec_straight_steps_1; eauto. - caseEq (snd (crbit_for_cond cond)); intro ISSET; rewrite ISSET in RES. - econstructor; eauto. - eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto. - simpl. rewrite RES. simpl. auto. - econstructor; eauto. - eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto. - simpl. rewrite RES. simpl. auto. - traceEq. - econstructor; eauto. - eapply Mach.find_label_incl; eauto. - apply agree_exten_2 with rs2; auto. -Qed. - -Lemma exec_Mcond_false_prop: - forall (s : list stackframe) (fb : block) (sp : val) - (cond : condition) (args : list mreg) (lbl : Mach.label) - (c : list Mach.instruction) (ms : mreg -> val) (m : mem), - eval_condition cond ms ## args m = Some false -> - exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 - (Machconcr.State s fb sp c ms m). -Proof. - intros; red; intros; inv MS. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. - pose (k1 := - if snd (crbit_for_cond cond) - then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c - else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c). - generalize (transl_cond_correct tge (transl_function f) - cond args k1 ms sp rs m false H1 AG H). - simpl. intros [rs2 [EX [RES AG2]]]. - left; eapply exec_straight_steps; eauto with coqlib. - exists (nextinstr rs2); split. - simpl. eapply exec_straight_trans. eexact EX. - caseEq (snd (crbit_for_cond cond)); intro ISSET; rewrite ISSET in RES. - unfold k1; rewrite ISSET; apply exec_straight_one. - simpl. rewrite RES. reflexivity. - reflexivity. - unfold k1; rewrite ISSET; apply exec_straight_one. - simpl. rewrite RES. reflexivity. - reflexivity. - auto with ppcgen. -Qed. - -Lemma exec_Mreturn_prop: - forall (s : list stackframe) (fb stk : block) (soff : int) - (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function), - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> - exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 - (Returnstate s ms (free m stk)). -Proof. - intros; red; intros; inv MS. - assert (f0 = f) by congruence. subst f0. - set (rs2 := nextinstr (rs#GPR12 <- (parent_ra s))). - set (rs3 := nextinstr (rs2#LR <- (parent_ra s))). - set (rs4 := nextinstr (rs3#GPR1 <- (parent_sp s))). - set (rs5 := rs4#PC <- (parent_ra s)). - assert (exec_straight tge (transl_function f) - (transl_code f (Mreturn :: c)) rs m - (Pblr :: transl_code f c) rs4 (free m stk)). - simpl. apply exec_straight_three with rs2 m rs3 m. - simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. - unfold load_stack in H1. simpl in H1. - rewrite <- (sp_val _ _ _ AG). simpl. rewrite H1. - reflexivity. discriminate. - unfold rs3. change (parent_ra s) with rs2#GPR12. reflexivity. - simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). - simpl. - unfold load_stack in H0. simpl in H0. - rewrite H0. reflexivity. - reflexivity. reflexivity. reflexivity. - left; exists (State rs5 (free m stk)); split. - (* execution *) - apply plus_right' with E0 (State rs4 (free m stk)) E0. - eapply exec_straight_exec; eauto. - inv AT. econstructor. - change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone). - rewrite <- H3. simpl. eauto. - apply functions_transl; eauto. - generalize (functions_transl_no_overflow _ _ H4); intro NOOV. - simpl in H5. eapply find_instr_tail. - eapply code_tail_next_int; auto. - eapply code_tail_next_int; auto. - eapply code_tail_next_int; eauto. - reflexivity. traceEq. - (* match states *) - econstructor; eauto. - assert (AG3: agree ms (Vptr stk soff) rs3). - unfold rs3, rs2; auto 10 with ppcgen. - assert (AG4: agree ms (parent_sp s) rs4). - split. reflexivity. intros. unfold rs4. - rewrite nextinstr_inv. rewrite Pregmap.gso. - elim AG3; auto. auto with ppcgen. auto with ppcgen. - unfold rs5; auto with ppcgen. -Qed. - -Hypothesis wt_prog: wt_program prog. - -Lemma exec_function_internal_prop: - forall (s : list stackframe) (fb : block) (ms : Mach.regset) - (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block), - Genv.find_funct_ptr ge fb = Some (Internal f) -> - alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) -> - let sp := Vptr stk (Int.repr (- fn_framesize f)) in - store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 -> - store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> - exec_instr_prop (Machconcr.Callstate s fb ms m) E0 - (Machconcr.State s fb sp (fn_code f) ms m3). -Proof. - intros; red; intros; inv MS. - assert (WTF: wt_function f). - generalize (Genv.find_funct_ptr_prop wt_fundef wt_prog H); intro TY. - inversion TY; auto. - exploit functions_transl; eauto. intro TFIND. - generalize (functions_transl_no_overflow _ _ H); intro NOOV. - set (rs2 := nextinstr (rs#GPR1 <- sp #GPR12 <- Vundef)). - set (rs3 := nextinstr (rs2#GPR12 <- (parent_ra s))). - set (rs4 := nextinstr rs3). - (* Execution of function prologue *) - assert (EXEC_PROLOGUE: - exec_straight tge (transl_function f) - (transl_function f) rs m - (transl_code f (fn_code f)) rs4 m3). - unfold transl_function at 2. - apply exec_straight_three with rs2 m2 rs3 m2. - unfold exec_instr. rewrite H0. fold sp. - unfold store_stack in H1. simpl chunk_of_type in H1. - rewrite <- (sp_val _ _ _ AG). rewrite H1. reflexivity. - simpl. change (rs2 LR) with (rs LR). rewrite ATLR. reflexivity. - simpl. unfold store1. rewrite gpr_or_zero_not_zero. - unfold const_low. change (rs3 GPR1) with sp. change (rs3 GPR12) with (parent_ra s). - unfold store_stack in H2. simpl chunk_of_type in H2. rewrite H2. reflexivity. - discriminate. reflexivity. reflexivity. reflexivity. - (* Agreement at end of prologue *) - assert (AT4: transl_code_at_pc rs4#PC fb f f.(fn_code)). - change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone). - rewrite ATPC. simpl. constructor. auto. - eapply code_tail_next_int; auto. - eapply code_tail_next_int; auto. - eapply code_tail_next_int; auto. - change (Int.unsigned Int.zero) with 0. - unfold transl_function. constructor. - assert (AG2: agree ms sp rs2). - split. reflexivity. - intros. unfold rs2. rewrite nextinstr_inv. - repeat (rewrite Pregmap.gso). elim AG; auto. - auto with ppcgen. auto with ppcgen. auto with ppcgen. - assert (AG4: agree ms sp rs4). - unfold rs4, rs3; auto with ppcgen. - left; exists (State rs4 m3); split. - (* execution *) - eapply exec_straight_steps_1; eauto. - change (Int.unsigned Int.zero) with 0. constructor. - (* match states *) - econstructor; eauto with coqlib. -Qed. - -Lemma exec_function_external_prop: - forall (s : list stackframe) (fb : block) (ms : Mach.regset) - (m : mem) (t0 : trace) (ms' : RegEq.t -> val) - (ef : external_function) (args : list val) (res : val), - Genv.find_funct_ptr ge fb = Some (External ef) -> - event_match ef args t0 res -> - Machconcr.extcall_arguments ms m (parent_sp s) (ef_sig ef) args -> - ms' = Regmap.set (Conventions.loc_result (ef_sig ef)) res ms -> - exec_instr_prop (Machconcr.Callstate s fb ms m) - t0 (Machconcr.Returnstate s ms' m). -Proof. - intros; red; intros; inv MS. - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - left; exists (State (rs#(loc_external_result (ef_sig ef)) <- res #PC <- (rs LR)) - m); split. - apply plus_one. eapply exec_step_external; eauto. - eapply extcall_arguments_match; eauto. - econstructor; eauto. - rewrite loc_external_result_match. auto with ppcgen. -Qed. - -Lemma exec_return_prop: - forall (s : list stackframe) (fb : block) (sp ra : val) - (c : Mach.code) (ms : Mach.regset) (m : mem), - exec_instr_prop (Machconcr.Returnstate (Stackframe fb sp ra c :: s) ms m) E0 - (Machconcr.State s fb sp c ms m). -Proof. - intros; red; intros; inv MS. inv STACKS. simpl in *. - right. split. omega. split. auto. - econstructor; eauto. rewrite ATPC; auto. -Qed. - -Theorem transf_instr_correct: - forall s1 t s2, Machconcr.step ge s1 t s2 -> - exec_instr_prop s1 t s2. -Proof - (Machconcr.step_ind ge exec_instr_prop - exec_Mlabel_prop - exec_Mgetstack_prop - exec_Msetstack_prop - exec_Mgetparam_prop - exec_Mop_prop - exec_Mload_prop - exec_Mstore_prop - exec_Mcall_prop - exec_Mtailcall_prop - exec_Malloc_prop - exec_Mgoto_prop - exec_Mcond_true_prop - exec_Mcond_false_prop - exec_Mreturn_prop - exec_function_internal_prop - exec_function_external_prop - exec_return_prop). - -Lemma transf_initial_states: - forall st1, Machconcr.initial_state prog st1 -> - exists st2, PPC.initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inversion H. unfold ge0 in *. - econstructor; split. - econstructor. - replace (symbol_offset (Genv.globalenv tprog) (prog_main tprog) Int.zero) - with (Vptr fb Int.zero). - rewrite (Genv.init_mem_transf_partial _ _ TRANSF). - econstructor; eauto. constructor. - split. auto. intros. repeat rewrite Pregmap.gso; auto with ppcgen. - unfold symbol_offset. - rewrite (transform_partial_program_main _ _ TRANSF). - rewrite symbols_preserved. unfold ge; rewrite H0. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> Machconcr.final_state st1 r -> PPC.final_state st2 r. -Proof. - intros. inv H0. inv H. constructor. auto. - rewrite (ireg_val _ _ _ R3 AG) in H1. auto. auto. -Qed. - -Theorem transf_program_correct: - forall (beh: program_behavior), - Machconcr.exec_program prog beh -> PPC.exec_program tprog beh. -Proof. - unfold Machconcr.exec_program, PPC.exec_program; intros. - eapply simulation_star_preservation with (measure := measure); eauto. - eexact transf_initial_states. - eexact transf_final_states. - exact transf_instr_correct. -Qed. - -End PRESERVATION. diff --git a/backend/PPCgenproof1.v b/backend/PPCgenproof1.v deleted file mode 100644 index dd142c5b..00000000 --- a/backend/PPCgenproof1.v +++ /dev/null @@ -1,1686 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for PPC generation: auxiliary results. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Globalenvs. -Require Import Op. -Require Import Locations. -Require Import Mach. -Require Import Machconcr. -Require Import Machtyping. -Require Import PPC. -Require Import PPCgen. -Require Conventions. - -(** * Properties of low half/high half decomposition *) - -Lemma high_half_zero: - forall v, Val.add (high_half v) Vzero = high_half v. -Proof. - intros. generalize (high_half_type v). - rewrite Val.add_commut. - case (high_half v); simpl; intros; try contradiction. - auto. - rewrite Int.add_commut; rewrite Int.add_zero; auto. - rewrite Int.add_zero; auto. -Qed. - -Lemma low_high_u: - forall n, Int.or (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n. -Proof. - intros. unfold high_u, low_u. - rewrite Int.shl_rolm. rewrite Int.shru_rolm. - rewrite Int.rolm_rolm. - change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat wordsize)) (Int.repr 16)) - (Int.repr 16)) - (Int.repr (Z_of_nat wordsize))) - with (Int.zero). - rewrite Int.rolm_zero. rewrite <- Int.and_or_distrib. - exact (Int.and_mone n). - reflexivity. reflexivity. -Qed. - -Lemma low_high_u_xor: - forall n, Int.xor (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n. -Proof. - intros. unfold high_u, low_u. - rewrite Int.shl_rolm. rewrite Int.shru_rolm. - rewrite Int.rolm_rolm. - change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat wordsize)) (Int.repr 16)) - (Int.repr 16)) - (Int.repr (Z_of_nat wordsize))) - with (Int.zero). - rewrite Int.rolm_zero. rewrite <- Int.and_xor_distrib. - exact (Int.and_mone n). - reflexivity. reflexivity. -Qed. - -Lemma low_high_s: - forall n, Int.add (Int.shl (high_s n) (Int.repr 16)) (low_s n) = n. -Proof. - intros. rewrite Int.shl_mul_two_p. - unfold high_s. - rewrite <- (Int.divu_pow2 (Int.sub n (low_s n)) (Int.repr 65536) (Int.repr 16)). - change (two_p (Int.unsigned (Int.repr 16))) with 65536. - - assert (forall x y, y > 0 -> (x - x mod y) mod y = 0). - intros. apply Zmod_unique with (x / y). - generalize (Z_div_mod_eq x y H). intro. rewrite Zmult_comm. omega. - omega. - - assert (Int.modu (Int.sub n (low_s n)) (Int.repr 65536) = Int.zero). - unfold Int.modu, Int.zero. decEq. - change (Int.unsigned (Int.repr 65536)) with 65536. - unfold Int.sub. - assert (forall a b, Int.eqm a b -> b mod 65536 = 0 -> a mod 65536 = 0). - intros a b [k EQ] H1. rewrite EQ. - change modulus with (65536 * 65536). - rewrite Zmult_assoc. rewrite Zplus_comm. rewrite Z_mod_plus. auto. - omega. - eapply H0. apply Int.eqm_sym. apply Int.eqm_unsigned_repr. - unfold low_s. unfold Int.sign_ext. - change (two_p 16) with 65536. change (two_p (16-1)) with 32768. - set (N := Int.unsigned n). - case (zlt (N mod 65536) 32768); intro. - apply H0 with (N - N mod 65536). auto with ints. - apply H. omega. - apply H0 with (N - (N mod 65536 - 65536)). auto with ints. - replace (N - (N mod 65536 - 65536)) - with ((N - N mod 65536) + 1 * 65536). - rewrite Z_mod_plus. apply H. omega. omega. ring. - - assert (Int.repr 65536 <> Int.zero). compute. congruence. - generalize (Int.modu_divu_Euclid (Int.sub n (low_s n)) (Int.repr 65536) H1). - rewrite H0. rewrite Int.add_zero. intro. rewrite <- H2. - rewrite Int.sub_add_opp. rewrite Int.add_assoc. - replace (Int.add (Int.neg (low_s n)) (low_s n)) with Int.zero. - apply Int.add_zero. symmetry. rewrite Int.add_commut. - rewrite <- Int.sub_add_opp. apply Int.sub_idem. - - reflexivity. -Qed. - -(** * Correspondence between Mach registers and PPC registers *) - -Hint Extern 2 (_ <> _) => discriminate: ppcgen. - -(** Mapping from Mach registers to PPC registers. *) - -Definition preg_of (r: mreg) := - match mreg_type r with - | Tint => IR (ireg_of r) - | Tfloat => FR (freg_of r) - end. - -Lemma preg_of_injective: - forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. -Proof. - destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. -Qed. - -(** Characterization of PPC registers that correspond to Mach registers. *) - -Definition is_data_reg (r: preg) : Prop := - match r with - | IR GPR12 => False - | FR FPR13 => False - | PC => False | LR => False | CTR => False - | CR0_0 => False | CR0_1 => False | CR0_2 => False | CR0_3 => False - | CARRY => False - | _ => True - end. - -Lemma ireg_of_is_data_reg: - forall (r: mreg), is_data_reg (ireg_of r). -Proof. - destruct r; exact I. -Qed. - -Lemma freg_of_is_data_reg: - forall (r: mreg), is_data_reg (ireg_of r). -Proof. - destruct r; exact I. -Qed. - -Lemma preg_of_is_data_reg: - forall (r: mreg), is_data_reg (preg_of r). -Proof. - destruct r; exact I. -Qed. - -Lemma ireg_of_not_GPR1: - forall r, ireg_of r <> GPR1. -Proof. - intro. case r; discriminate. -Qed. -Lemma ireg_of_not_GPR12: - forall r, ireg_of r <> GPR12. -Proof. - intro. case r; discriminate. -Qed. -Lemma freg_of_not_FPR13: - forall r, freg_of r <> FPR13. -Proof. - intro. case r; discriminate. -Qed. -Hint Resolve ireg_of_not_GPR1 ireg_of_not_GPR12 freg_of_not_FPR13: ppcgen. - -Lemma preg_of_not: - forall r1 r2, ~(is_data_reg r2) -> preg_of r1 <> r2. -Proof. - intros; red; intro. subst r2. elim H. apply preg_of_is_data_reg. -Qed. -Hint Resolve preg_of_not: ppcgen. - -Lemma preg_of_not_GPR1: - forall r, preg_of r <> GPR1. -Proof. - intro. case r; discriminate. -Qed. -Hint Resolve preg_of_not_GPR1: ppcgen. - -(** Agreement between Mach register sets and PPC register sets. *) - -Definition agree (ms: Mach.regset) (sp: val) (rs: PPC.regset) := - rs#GPR1 = sp /\ forall r: mreg, ms r = rs#(preg_of r). - -Lemma preg_val: - forall ms sp rs r, - agree ms sp rs -> ms r = rs#(preg_of r). -Proof. - intros. elim H. auto. -Qed. - -Lemma ireg_val: - forall ms sp rs r, - agree ms sp rs -> - mreg_type r = Tint -> - ms r = rs#(ireg_of r). -Proof. - intros. elim H; intros. - generalize (H2 r). unfold preg_of. rewrite H0. auto. -Qed. - -Lemma freg_val: - forall ms sp rs r, - agree ms sp rs -> - mreg_type r = Tfloat -> - ms r = rs#(freg_of r). -Proof. - intros. elim H; intros. - generalize (H2 r). unfold preg_of. rewrite H0. auto. -Qed. - -Lemma sp_val: - forall ms sp rs, - agree ms sp rs -> - sp = rs#GPR1. -Proof. - intros. elim H; auto. -Qed. - -Lemma agree_exten_1: - forall ms sp rs rs', - agree ms sp rs -> - (forall r, is_data_reg r -> rs'#r = rs#r) -> - agree ms sp rs'. -Proof. - unfold agree; intros. elim H; intros. - split. rewrite H0. auto. exact I. - intros. rewrite H0. auto. apply preg_of_is_data_reg. -Qed. - -Lemma agree_exten_2: - forall ms sp rs rs', - agree ms sp rs -> - (forall r, - r <> IR GPR12 -> r <> FR FPR13 -> - r <> PC -> r <> LR -> r <> CTR -> - r <> CR0_0 -> r <> CR0_1 -> r <> CR0_2 -> r <> CR0_3 -> - r <> CARRY -> - rs'#r = rs#r) -> - agree ms sp rs'. -Proof. - intros. apply agree_exten_1 with rs. auto. - intros. apply H0; (red; intro; subst r; elim H1). -Qed. - -(** Preservation of register agreement under various assignments. *) - -Lemma agree_set_mreg: - forall ms sp rs r v, - agree ms sp rs -> - agree (Regmap.set r v ms) sp (rs#(preg_of r) <- v). -Proof. - unfold agree; intros. elim H; intros; clear H. - split. rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_GPR1. - intros. unfold Regmap.set. case (RegEq.eq r0 r); intro. - subst r0. rewrite Pregmap.gss. auto. - rewrite Pregmap.gso. auto. red; intro. - elim n. apply preg_of_injective; auto. -Qed. -Hint Resolve agree_set_mreg: ppcgen. - -Lemma agree_set_mireg: - forall ms sp rs r v, - agree ms sp (rs#(preg_of r) <- v) -> - mreg_type r = Tint -> - agree ms sp (rs#(ireg_of r) <- v). -Proof. - intros. unfold preg_of in H. rewrite H0 in H. auto. -Qed. -Hint Resolve agree_set_mireg: ppcgen. - -Lemma agree_set_mfreg: - forall ms sp rs r v, - agree ms sp (rs#(preg_of r) <- v) -> - mreg_type r = Tfloat -> - agree ms sp (rs#(freg_of r) <- v). -Proof. - intros. unfold preg_of in H. rewrite H0 in H. auto. -Qed. -Hint Resolve agree_set_mfreg: ppcgen. - -Lemma agree_set_other: - forall ms sp rs r v, - agree ms sp rs -> - ~(is_data_reg r) -> - agree ms sp (rs#r <- v). -Proof. - intros. apply agree_exten_1 with rs. - auto. intros. apply Pregmap.gso. red; intro; subst r0; contradiction. -Qed. -Hint Resolve agree_set_other: ppcgen. - -Lemma agree_nextinstr: - forall ms sp rs, - agree ms sp rs -> agree ms sp (nextinstr rs). -Proof. - intros. unfold nextinstr. apply agree_set_other. auto. auto. -Qed. -Hint Resolve agree_nextinstr: ppcgen. - -Lemma agree_set_mireg_twice: - forall ms sp rs r v v', - agree ms sp rs -> - mreg_type r = Tint -> - agree (Regmap.set r v ms) sp (rs #(ireg_of r) <- v' #(ireg_of r) <- v). -Proof. - intros. replace (IR (ireg_of r)) with (preg_of r). elim H; intros. - split. repeat (rewrite Pregmap.gso; auto with ppcgen). - intros. case (mreg_eq r r0); intro. - subst r0. rewrite Regmap.gss. rewrite Pregmap.gss. auto. - assert (preg_of r <> preg_of r0). - red; intro. elim n. apply preg_of_injective. auto. - rewrite Regmap.gso; auto. - repeat (rewrite Pregmap.gso; auto). - unfold preg_of. rewrite H0. auto. -Qed. -Hint Resolve agree_set_mireg_twice: ppcgen. - -Lemma agree_set_twice_mireg: - forall ms sp rs r v v', - agree (Regmap.set r v' ms) sp rs -> - mreg_type r = Tint -> - agree (Regmap.set r v ms) sp (rs#(ireg_of r) <- v). -Proof. - intros. elim H; intros. - split. rewrite Pregmap.gso. auto. - generalize (ireg_of_not_GPR1 r); congruence. - intros. generalize (H2 r0). - case (mreg_eq r0 r); intro. - subst r0. repeat rewrite Regmap.gss. unfold preg_of; rewrite H0. - rewrite Pregmap.gss. auto. - repeat rewrite Regmap.gso; auto. - rewrite Pregmap.gso. auto. - replace (IR (ireg_of r)) with (preg_of r). - red; intros. elim n. apply preg_of_injective; auto. - unfold preg_of. rewrite H0. auto. -Qed. -Hint Resolve agree_set_twice_mireg: ppcgen. - -Lemma agree_set_commut: - forall ms sp rs r1 r2 v1 v2, - r1 <> r2 -> - agree ms sp ((rs#r2 <- v2)#r1 <- v1) -> - agree ms sp ((rs#r1 <- v1)#r2 <- v2). -Proof. - intros. apply agree_exten_1 with ((rs#r2 <- v2)#r1 <- v1). auto. - intros. - case (preg_eq r r1); intro. - subst r1. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. - auto. auto. - case (preg_eq r r2); intro. - subst r2. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. - auto. auto. - repeat (rewrite Pregmap.gso; auto). -Qed. -Hint Resolve agree_set_commut: ppcgen. - -Lemma agree_nextinstr_commut: - forall ms sp rs r v, - agree ms sp (rs#r <- v) -> - r <> PC -> - agree ms sp ((nextinstr rs)#r <- v). -Proof. - intros. unfold nextinstr. apply agree_set_commut. auto. - apply agree_set_other. auto. auto. -Qed. -Hint Resolve agree_nextinstr_commut: ppcgen. - -Lemma agree_set_mireg_exten: - forall ms sp rs r v (rs': regset), - agree ms sp rs -> - mreg_type r = Tint -> - rs'#(ireg_of r) = v -> - (forall r', - r' <> IR GPR12 -> r' <> FR FPR13 -> - r' <> PC -> r' <> LR -> r' <> CTR -> - r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> - r' <> CARRY -> - r' <> IR (ireg_of r) -> rs'#r' = rs#r') -> - agree (Regmap.set r v ms) sp rs'. -Proof. - intros. apply agree_exten_2 with (rs#(ireg_of r) <- v). - auto with ppcgen. - intros. unfold Pregmap.set. case (PregEq.eq r0 (ireg_of r)); intro. - subst r0. auto. apply H2; auto. -Qed. - -(** Useful properties of the PC and GPR0 registers. *) - -Lemma nextinstr_inv: - forall r rs, r <> PC -> (nextinstr rs)#r = rs#r. -Proof. - intros. unfold nextinstr. apply Pregmap.gso. auto. -Qed. -Hint Resolve nextinstr_inv: ppcgen. - -Lemma nextinstr_set_preg: - forall rs m v, - (nextinstr (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone. -Proof. - intros. unfold nextinstr. rewrite Pregmap.gss. - rewrite Pregmap.gso. auto. apply sym_not_eq. auto with ppcgen. -Qed. -Hint Resolve nextinstr_set_preg: ppcgen. - -Lemma gpr_or_zero_not_zero: - forall rs r, r <> GPR0 -> gpr_or_zero rs r = rs#r. -Proof. - intros. unfold gpr_or_zero. case (ireg_eq r GPR0); tauto. -Qed. -Lemma gpr_or_zero_zero: - forall rs, gpr_or_zero rs GPR0 = Vzero. -Proof. - intros. reflexivity. -Qed. -Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: ppcgen. - -(** Connection between Mach and PPC calling conventions for external - functions. *) - -Lemma loc_external_result_match: - forall sg, - PPC.loc_external_result sg = preg_of (Conventions.loc_result sg). -Proof. - intros. destruct sg as [sargs sres]. - destruct sres. destruct t; reflexivity. reflexivity. -Qed. - -Lemma extcall_args_match: - forall ms m sp rs, - agree ms sp rs -> - forall tyl iregl fregl ofs args, - (forall r, In r iregl -> mreg_type r = Tint) -> - (forall r, In r fregl -> mreg_type r = Tfloat) -> - Machconcr.extcall_args ms m sp (Conventions.loc_arguments_rec tyl iregl fregl ofs) args -> - PPC.extcall_args rs m tyl (List.map ireg_of iregl) (List.map freg_of fregl) (Stacking.fe_ofs_arg + 4 * ofs) args. -Proof. - induction tyl; intros. - inversion H2; constructor. - destruct a. - (* integer case *) - destruct iregl as [ | ir1 irl]. - (* stack *) - inversion H2; subst; clear H2. inversion H8; subst; clear H8. - constructor. replace (rs GPR1) with sp. assumption. - eapply sp_val; eauto. - change (@nil ireg) with (ireg_of ## nil). - replace (Stacking.fe_ofs_arg + 4 * ofs + 4) with (Stacking.fe_ofs_arg + 4 * (ofs + 1)) by omega. - apply IHtyl; auto. - (* register *) - inversion H2; subst; clear H2. inversion H8; subst; clear H8. - simpl map. econstructor. eapply ireg_val; eauto. - apply H0; simpl; auto. - replace (4 * ofs + 4) with (4 * (ofs + 1)) by omega. - apply IHtyl; auto. - intros; apply H0; simpl; auto. - (* float case *) - destruct fregl as [ | fr1 frl]. - (* stack *) - inversion H2; subst; clear H2. inversion H8; subst; clear H8. - constructor. replace (rs GPR1) with sp. assumption. - eapply sp_val; eauto. - change (@nil freg) with (freg_of ## nil). - replace (Stacking.fe_ofs_arg + 4 * ofs + 8) with (Stacking.fe_ofs_arg + 4 * (ofs + 2)) by omega. - apply IHtyl; auto. - (* register *) - inversion H2; subst; clear H2. inversion H8; subst; clear H8. - simpl map. econstructor. eapply freg_val; eauto. - apply H1; simpl; auto. - rewrite list_map_drop2. - apply IHtyl; auto. - intros; apply H0. apply list_drop2_incl. auto. - intros; apply H1; simpl; auto. -Qed. - -Ltac ElimOrEq := - match goal with - | |- (?x = ?y) \/ _ -> _ => - let H := fresh in - (intro H; elim H; clear H; - [intro H; rewrite <- H; clear H | ElimOrEq]) - | |- False -> _ => - let H := fresh in (intro H; contradiction) - end. - -Lemma extcall_arguments_match: - forall ms m sp rs sg args, - agree ms sp rs -> - Machconcr.extcall_arguments ms m sp sg args -> - PPC.extcall_arguments rs m sg args. -Proof. - unfold Machconcr.extcall_arguments, PPC.extcall_arguments; intros. - change (extcall_args rs m sg.(sig_args) - (List.map ireg_of Conventions.int_param_regs) - (List.map freg_of Conventions.float_param_regs) - (Stacking.fe_ofs_arg + 4 * 8) args). - eapply extcall_args_match; eauto. - intro; simpl; ElimOrEq; reflexivity. - intro; simpl; ElimOrEq; reflexivity. -Qed. - -(** * Execution of straight-line code *) - -Section STRAIGHTLINE. - -Variable ge: genv. -Variable fn: code. - -(** Straight-line code is composed of PPC instructions that execute - in sequence (no branches, no function calls and returns). - The following inductive predicate relates the machine states - before and after executing a straight-line sequence of instructions. - Instructions are taken from the first list instead of being fetched - from memory. *) - -Inductive exec_straight: code -> regset -> mem -> - code -> regset -> mem -> Prop := - | exec_straight_one: - forall i1 c rs1 m1 rs2 m2, - exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> - rs2#PC = Val.add rs1#PC Vone -> - exec_straight (i1 :: c) rs1 m1 c rs2 m2 - | exec_straight_step: - forall i c rs1 m1 rs2 m2 c' rs3 m3, - exec_instr ge fn i rs1 m1 = OK rs2 m2 -> - rs2#PC = Val.add rs1#PC Vone -> - exec_straight c rs2 m2 c' rs3 m3 -> - exec_straight (i :: c) rs1 m1 c' rs3 m3. - -Lemma exec_straight_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight c1 rs1 m1 c2 rs2 m2 -> - exec_straight c2 rs2 m2 c3 rs3 m3 -> - exec_straight c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_step with rs2 m2; auto. - apply exec_straight_step with rs2 m2; auto. -Qed. - -Lemma exec_straight_two: - forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, - exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> - exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> - rs2#PC = Val.add rs1#PC Vone -> - rs3#PC = Val.add rs2#PC Vone -> - exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - apply exec_straight_one; auto. -Qed. - -Lemma exec_straight_three: - forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, - exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> - exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> - exec_instr ge fn i3 rs3 m3 = OK rs4 m4 -> - rs2#PC = Val.add rs1#PC Vone -> - rs3#PC = Val.add rs2#PC Vone -> - rs4#PC = Val.add rs3#PC Vone -> - exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - eapply exec_straight_two; eauto. -Qed. - -(** * Correctness of PowerPC constructor functions *) - -(** Properties of comparisons. *) - -Lemma compare_float_spec: - forall rs v1 v2, - let rs1 := nextinstr (compare_float rs v1 v2) in - rs1#CR0_0 = Val.cmpf Clt v1 v2 - /\ rs1#CR0_1 = Val.cmpf Cgt v1 v2 - /\ rs1#CR0_2 = Val.cmpf Ceq v1 v2 - /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> - r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. -Proof. - intros. unfold rs1. - split. reflexivity. - split. reflexivity. - split. reflexivity. - intros. rewrite nextinstr_inv; auto. - unfold compare_float. repeat (rewrite Pregmap.gso; auto). -Qed. - -Lemma compare_sint_spec: - forall rs v1 v2, - let rs1 := nextinstr (compare_sint rs v1 v2) in - rs1#CR0_0 = Val.cmp Clt v1 v2 - /\ rs1#CR0_1 = Val.cmp Cgt v1 v2 - /\ rs1#CR0_2 = Val.cmp Ceq v1 v2 - /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> - r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. -Proof. - intros. unfold rs1. - split. reflexivity. - split. reflexivity. - split. reflexivity. - intros. rewrite nextinstr_inv; auto. - unfold compare_sint. repeat (rewrite Pregmap.gso; auto). -Qed. - -Lemma compare_uint_spec: - forall rs v1 v2, - let rs1 := nextinstr (compare_uint rs v1 v2) in - rs1#CR0_0 = Val.cmpu Clt v1 v2 - /\ rs1#CR0_1 = Val.cmpu Cgt v1 v2 - /\ rs1#CR0_2 = Val.cmpu Ceq v1 v2 - /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> - r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. -Proof. - intros. unfold rs1. - split. reflexivity. - split. reflexivity. - split. reflexivity. - intros. rewrite nextinstr_inv; auto. - unfold compare_uint. repeat (rewrite Pregmap.gso; auto). -Qed. - -(** Loading a constant. *) - -Lemma loadimm_correct: - forall r n k rs m, - exists rs', - exec_straight (loadimm r n k) rs m k rs' m - /\ rs'#r = Vint n - /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold loadimm. - case (Int.eq (high_s n) Int.zero). - (* addi *) - exists (nextinstr (rs#r <- (Vint n))). - split. apply exec_straight_one. - simpl. rewrite Int.add_commut. rewrite Int.add_zero. reflexivity. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. - apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* addis *) - generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro. - exists (nextinstr (rs#r <- (Vint n))). - split. apply exec_straight_one. - simpl. rewrite Int.add_commut. - rewrite <- H. rewrite low_high_s. reflexivity. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* addis + ori *) - pose (rs1 := nextinstr (rs#r <- (Vint (Int.shl (high_u n) (Int.repr 16))))). - exists (nextinstr (rs1#r <- (Vint n))). - split. eapply exec_straight_two. - simpl. rewrite Int.add_commut. rewrite Int.add_zero. reflexivity. - simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - unfold Val.or. rewrite low_high_u. reflexivity. - reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Add integer immediate. *) - -Lemma addimm_1_correct: - forall r1 r2 n k rs m, - r1 <> GPR0 -> - r2 <> GPR0 -> - exists rs', - exec_straight (addimm_1 r1 r2 n k) rs m k rs' m - /\ rs'#r1 = Val.add rs#r2 (Vint n) - /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold addimm_1. - (* addi *) - case (Int.eq (high_s n) Int.zero). - exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))). - split. apply exec_straight_one. - simpl. rewrite gpr_or_zero_not_zero; auto. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* addis *) - generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro. - exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))). - split. apply exec_straight_one. - simpl. rewrite gpr_or_zero_not_zero; auto. - generalize (low_high_s n). rewrite H1. rewrite Int.add_zero. intro. - rewrite H2. auto. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* addis + addi *) - pose (rs1 := nextinstr (rs#r1 <- (Val.add rs#r2 (Vint (Int.shl (high_s n) (Int.repr 16)))))). - exists (nextinstr (rs1#r1 <- (Val.add rs#r2 (Vint n)))). - split. apply exec_straight_two with rs1 m. - simpl. rewrite gpr_or_zero_not_zero; auto. - simpl. rewrite gpr_or_zero_not_zero; auto. - unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. - reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. -Qed. - -Lemma addimm_2_correct: - forall r1 r2 n k rs m, - r2 <> GPR12 -> - exists rs', - exec_straight (addimm_2 r1 r2 n k) rs m k rs' m - /\ rs'#r1 = Val.add rs#r2 (Vint n) - /\ forall r': preg, r' <> r1 -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold addimm_2. - generalize (loadimm_correct GPR12 n (Padd r1 r2 GPR12 :: k) rs m). - intros [rs1 [EX [RES OTHER]]]. - exists (nextinstr (rs1#r1 <- (Val.add rs#r2 (Vint n)))). - split. eapply exec_straight_trans. eexact EX. - apply exec_straight_one. simpl. rewrite RES. rewrite OTHER. - auto. congruence. discriminate. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -Lemma addimm_correct: - forall r1 r2 n k rs m, - r2 <> GPR12 -> - exists rs', - exec_straight (addimm r1 r2 n k) rs m k rs' m - /\ rs'#r1 = Val.add rs#r2 (Vint n) - /\ forall r': preg, r' <> r1 -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold addimm. - case (ireg_eq r1 GPR0); intro. - apply addimm_2_correct; auto. - case (ireg_eq r2 GPR0); intro. - apply addimm_2_correct; auto. - generalize (addimm_1_correct r1 r2 n k rs m n0 n1). - intros [rs' [EX [RES OTH]]]. exists rs'. intuition. -Qed. - -(** And integer immediate. *) - -Lemma andimm_correct: - forall r1 r2 n k (rs : regset) m, - r2 <> GPR12 -> - let v := Val.and rs#r2 (Vint n) in - exists rs', - exec_straight (andimm r1 r2 n k) rs m k rs' m - /\ rs'#r1 = v - /\ rs'#CR0_2 = Val.cmp Ceq v Vzero - /\ forall r': preg, - r' <> r1 -> r' <> GPR12 -> r' <> PC -> - r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> - rs'#r' = rs#r'. -Proof. - intros. unfold andimm. - case (Int.eq (high_u n) Int.zero). - (* andi *) - exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)). - generalize (compare_sint_spec (rs#r1 <- v) v Vzero). - intros [A [B [C D]]]. - split. apply exec_straight_one. reflexivity. reflexivity. - split. rewrite D; try discriminate. apply Pregmap.gss. - split. auto. - intros. rewrite D; auto. apply Pregmap.gso; auto. - (* andis *) - generalize (Int.eq_spec (low_u n) Int.zero); - case (Int.eq (low_u n) Int.zero); intro. - exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)). - generalize (compare_sint_spec (rs#r1 <- v) v Vzero). - intros [A [B [C D]]]. - split. apply exec_straight_one. simpl. - generalize (low_high_u n). rewrite H0. rewrite Int.or_zero. - intro. rewrite H1. reflexivity. reflexivity. - split. rewrite D; try discriminate. apply Pregmap.gss. - split. auto. - intros. rewrite D; auto. apply Pregmap.gso; auto. - (* loadimm + and *) - generalize (loadimm_correct GPR12 n (Pand_ r1 r2 GPR12 :: k) rs m). - intros [rs1 [EX1 [RES1 OTHER1]]]. - exists (nextinstr (compare_sint (rs1#r1 <- v) v Vzero)). - generalize (compare_sint_spec (rs1#r1 <- v) v Vzero). - intros [A [B [C D]]]. - split. eapply exec_straight_trans. eexact EX1. - apply exec_straight_one. simpl. rewrite RES1. - rewrite (OTHER1 r2). reflexivity. congruence. congruence. - reflexivity. - split. rewrite D; try discriminate. apply Pregmap.gss. - split. auto. - intros. rewrite D; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Or integer immediate. *) - -Lemma orimm_correct: - forall r1 (r2: ireg) n k (rs : regset) m, - let v := Val.or rs#r2 (Vint n) in - exists rs', - exec_straight (orimm r1 r2 n k) rs m k rs' m - /\ rs'#r1 = v - /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold orimm. - case (Int.eq (high_u n) Int.zero). - (* ori *) - exists (nextinstr (rs#r1 <- v)). - split. apply exec_straight_one. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* oris *) - generalize (Int.eq_spec (low_u n) Int.zero); - case (Int.eq (low_u n) Int.zero); intro. - exists (nextinstr (rs#r1 <- v)). - split. apply exec_straight_one. simpl. - generalize (low_high_u n). rewrite H. rewrite Int.or_zero. - intro. rewrite H0. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* oris + ori *) - pose (rs1 := nextinstr (rs#r1 <- (Val.or rs#r2 (Vint (Int.shl (high_u n) (Int.repr 16)))))). - exists (nextinstr (rs1#r1 <- v)). - split. apply exec_straight_two with rs1 m. - reflexivity. simpl. unfold rs1 at 1. - rewrite nextinstr_inv; auto with ppcgen. - rewrite Pregmap.gss. rewrite Val.or_assoc. simpl. - rewrite low_high_u. reflexivity. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Xor integer immediate. *) - -Lemma xorimm_correct: - forall r1 (r2: ireg) n k (rs : regset) m, - let v := Val.xor rs#r2 (Vint n) in - exists rs', - exec_straight (xorimm r1 r2 n k) rs m k rs' m - /\ rs'#r1 = v - /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold xorimm. - case (Int.eq (high_u n) Int.zero). - (* xori *) - exists (nextinstr (rs#r1 <- v)). - split. apply exec_straight_one. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* xoris *) - generalize (Int.eq_spec (low_u n) Int.zero); - case (Int.eq (low_u n) Int.zero); intro. - exists (nextinstr (rs#r1 <- v)). - split. apply exec_straight_one. simpl. - generalize (low_high_u_xor n). rewrite H. rewrite Int.xor_zero. - intro. rewrite H0. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* xoris + xori *) - pose (rs1 := nextinstr (rs#r1 <- (Val.xor rs#r2 (Vint (Int.shl (high_u n) (Int.repr 16)))))). - exists (nextinstr (rs1#r1 <- v)). - split. apply exec_straight_two with rs1 m. - reflexivity. simpl. unfold rs1 at 1. - rewrite nextinstr_inv; try discriminate. - rewrite Pregmap.gss. rewrite Val.xor_assoc. simpl. - rewrite low_high_u_xor. reflexivity. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. - apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Indexed memory loads. *) - -Lemma loadind_aux_correct: - forall (base: ireg) ofs ty dst (rs: regset) m v, - Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> - mreg_type dst = ty -> - base <> GPR0 -> - exec_instr ge fn (loadind_aux base ofs ty dst) rs m = - OK (nextinstr (rs#(preg_of dst) <- v)) m. -Proof. - intros. unfold loadind_aux. unfold preg_of. rewrite H0. destruct ty. - simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto. - unfold const_low. simpl in H. rewrite H. auto. - simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto. - unfold const_low. simpl in H. rewrite H. auto. -Qed. - -Lemma loadind_correct: - forall (base: ireg) ofs ty dst k (rs: regset) m v, - Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> - mreg_type dst = ty -> - base <> GPR0 -> - exists rs', - exec_straight (loadind base ofs ty dst k) rs m k rs' m - /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs'#r = rs#r. -Proof. - intros. unfold loadind. - assert (preg_of dst <> PC). - unfold preg_of. case (mreg_type dst); discriminate. - (* short offset *) - case (Int.eq (high_s ofs) Int.zero). - exists (nextinstr (rs#(preg_of dst) <- v)). - split. apply exec_straight_one. apply loadind_aux_correct; auto. - unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. auto. - split. rewrite nextinstr_inv; auto. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* long offset *) - pose (rs1 := nextinstr (rs#GPR12 <- (Val.add rs#base (Vint (Int.shl (high_s ofs) (Int.repr 16)))))). - exists (nextinstr (rs1#(preg_of dst) <- v)). - split. apply exec_straight_two with rs1 m. - simpl. rewrite gpr_or_zero_not_zero; auto. - apply loadind_aux_correct. - unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - rewrite Val.add_assoc. simpl. rewrite low_high_s. assumption. - auto. discriminate. reflexivity. - unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. auto. - split. rewrite nextinstr_inv; auto. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Indexed memory stores. *) - -Lemma storeind_aux_correct: - forall (base: ireg) ofs ty src (rs: regset) m m', - Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> - mreg_type src = ty -> - base <> GPR0 -> - exec_instr ge fn (storeind_aux src base ofs ty) rs m = - OK (nextinstr rs) m'. -Proof. - intros. unfold storeind_aux. unfold preg_of in H. rewrite H0 in H. destruct ty. - simpl. unfold store1. rewrite gpr_or_zero_not_zero; auto. - unfold const_low. simpl in H. rewrite H. auto. - simpl. unfold store1. rewrite gpr_or_zero_not_zero; auto. - unfold const_low. simpl in H. rewrite H. auto. -Qed. - -Lemma storeind_correct: - forall (base: ireg) ofs ty src k (rs: regset) m m', - Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> - mreg_type src = ty -> - base <> GPR0 -> - exists rs', - exec_straight (storeind src base ofs ty k) rs m k rs' m' - /\ forall r, r <> PC -> r <> GPR12 -> rs'#r = rs#r. -Proof. - intros. unfold storeind. - (* short offset *) - case (Int.eq (high_s ofs) Int.zero). - exists (nextinstr rs). - split. apply exec_straight_one. apply storeind_aux_correct; auto. - reflexivity. - intros. rewrite nextinstr_inv; auto. - (* long offset *) - pose (rs1 := nextinstr (rs#GPR12 <- (Val.add rs#base (Vint (Int.shl (high_s ofs) (Int.repr 16)))))). - exists (nextinstr rs1). - split. apply exec_straight_two with rs1 m. - simpl. rewrite gpr_or_zero_not_zero; auto. - apply storeind_aux_correct; auto with ppcgen. - unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - rewrite nextinstr_inv; auto with ppcgen. - rewrite Pregmap.gso; auto with ppcgen. - rewrite Val.add_assoc. simpl. rewrite low_high_s. assumption. - reflexivity. reflexivity. - intros. rewrite nextinstr_inv; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Float comparisons. *) - -Lemma floatcomp_correct: - forall cmp (r1 r2: freg) k rs m, - exists rs', - exec_straight (floatcomp cmp r1 r2 k) rs m k rs' m - /\ rs'#(reg_of_crbit (fst (crbit_for_fcmp cmp))) = - (if snd (crbit_for_fcmp cmp) - then Val.cmpf cmp rs#r1 rs#r2 - else Val.notbool (Val.cmpf cmp rs#r1 rs#r2)) - /\ forall r', - r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> - r' <> CR0_2 -> r' <> CR0_3 -> rs'#r' = rs#r'. -Proof. - intros. - generalize (compare_float_spec rs rs#r1 rs#r2). - intros [A [B [C D]]]. - set (rs1 := nextinstr (compare_float rs rs#r1 rs#r2)) in *. - assert ((cmp = Ceq \/ cmp = Cne \/ cmp = Clt \/ cmp = Cgt) - \/ (cmp = Cle \/ cmp = Cge)). - case cmp; tauto. - unfold floatcomp. elim H; intro; clear H. - exists rs1. - split. generalize H0; intros [EQ|[EQ|[EQ|EQ]]]; subst cmp; - apply exec_straight_one; reflexivity. - split. - generalize H0; intros [EQ|[EQ|[EQ|EQ]]]; subst cmp; simpl; auto. - rewrite Val.negate_cmpf_eq. auto. - auto. - (* two instrs *) - exists (nextinstr (rs1#CR0_3 <- (Val.cmpf cmp rs#r1 rs#r2))). - split. elim H0; intro; subst cmp. - apply exec_straight_two with rs1 m. - reflexivity. simpl. - rewrite C; rewrite A. rewrite Val.or_commut. rewrite <- Val.cmpf_le. - reflexivity. reflexivity. reflexivity. - apply exec_straight_two with rs1 m. - reflexivity. simpl. - rewrite C; rewrite B. rewrite Val.or_commut. rewrite <- Val.cmpf_ge. - reflexivity. reflexivity. reflexivity. - split. elim H0; intro; subst cmp; simpl. - reflexivity. - reflexivity. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -Ltac TypeInv := - match goal with - | H: (List.map ?f ?x = nil) |- _ => - destruct x; [clear H | simpl in H; discriminate] - | H: (List.map ?f ?x = ?hd :: ?tl) |- _ => - destruct x; simpl in H; - [ discriminate | - injection H; clear H; let T := fresh "T" in ( - intros H T; TypeInv) ] - | _ => idtac - end. - -(** Translation of conditions. *) - -Lemma transl_cond_correct_aux: - forall cond args k ms sp rs m, - map mreg_type args = type_of_condition cond -> - agree ms sp rs -> - exists rs', - exec_straight (transl_cond cond args k) rs m k rs' m - /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) = - (if snd (crbit_for_cond cond) - then eval_condition_total cond (map ms args) - else Val.notbool (eval_condition_total cond (map ms args))) - /\ agree ms sp rs'. -Proof. - intros. destruct cond; simpl in H; TypeInv. - (* Ccomp *) - simpl. - generalize (compare_sint_spec rs ms#m0 ms#m1). - intros [A [B [C D]]]. - exists (nextinstr (compare_sint rs ms#m0 ms#m1)). - split. apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs); auto). - reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. - apply agree_exten_2 with rs; auto. - (* Ccompu *) - simpl. - generalize (compare_uint_spec rs ms#m0 ms#m1). - intros [A [B [C D]]]. - exists (nextinstr (compare_uint rs ms#m0 ms#m1)). - split. apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs); auto). - reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. - apply agree_exten_2 with rs; auto. - (* Ccompimm *) - simpl. - case (Int.eq (high_s i) Int.zero). - generalize (compare_sint_spec rs ms#m0 (Vint i)). - intros [A [B [C D]]]. - exists (nextinstr (compare_sint rs ms#m0 (Vint i))). - split. apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs); auto). - reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. - apply agree_exten_2 with rs; auto. - generalize (loadimm_correct GPR12 i (Pcmpw (ireg_of m0) GPR12 :: k) rs m). - intros [rs1 [EX1 [RES1 OTH1]]]. - assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. - generalize (compare_sint_spec rs1 ms#m0 (Vint i)). - intros [A [B [C D]]]. - exists (nextinstr (compare_sint rs1 ms#m0 (Vint i))). - split. eapply exec_straight_trans. eexact EX1. - apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs1); auto). rewrite RES1. - reflexivity. reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. - apply agree_exten_2 with rs1; auto. - (* Ccompuimm *) - simpl. - case (Int.eq (high_u i) Int.zero). - generalize (compare_uint_spec rs ms#m0 (Vint i)). - intros [A [B [C D]]]. - exists (nextinstr (compare_uint rs ms#m0 (Vint i))). - split. apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs); auto). - reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. - apply agree_exten_2 with rs; auto. - generalize (loadimm_correct GPR12 i (Pcmplw (ireg_of m0) GPR12 :: k) rs m). - intros [rs1 [EX1 [RES1 OTH1]]]. - assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. - generalize (compare_uint_spec rs1 ms#m0 (Vint i)). - intros [A [B [C D]]]. - exists (nextinstr (compare_uint rs1 ms#m0 (Vint i))). - split. eapply exec_straight_trans. eexact EX1. - apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs1); auto). rewrite RES1. - reflexivity. reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. - apply agree_exten_2 with rs1; auto. - (* Ccompf *) - simpl. - generalize (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m). - intros [rs' [EX [RES OTH]]]. - exists rs'. split. auto. - split. rewrite RES. repeat (rewrite <- (freg_val ms sp rs); auto). - apply agree_exten_2 with rs; auto. - (* Cnotcompf *) - simpl. - generalize (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m). - intros [rs' [EX [RES OTH]]]. - exists rs'. split. auto. - split. rewrite RES. repeat (rewrite <- (freg_val ms sp rs); auto). - assert (forall v1 v2, Val.notbool (Val.notbool (Val.cmpf c v1 v2)) = Val.cmpf c v1 v2). - intros v1 v2; unfold Val.cmpf; destruct v1; destruct v2; auto. - apply Val.notbool_idem2. - rewrite H. - generalize RES. case (snd (crbit_for_fcmp c)); simpl; auto. - apply agree_exten_2 with rs; auto. - (* Cmaskzero *) - simpl. - generalize (andimm_correct GPR12 (ireg_of m0) i k rs m (ireg_of_not_GPR12 m0)). - intros [rs' [A [B [C D]]]]. - exists rs'. split. assumption. - split. rewrite C. rewrite <- (ireg_val ms sp rs); auto. - apply agree_exten_2 with rs; auto. - (* Cmasknotzero *) - simpl. - generalize (andimm_correct GPR12 (ireg_of m0) i k rs m (ireg_of_not_GPR12 m0)). - intros [rs' [A [B [C D]]]]. - exists rs'. split. assumption. - split. rewrite C. rewrite <- (ireg_val ms sp rs); auto. - rewrite Val.notbool_idem3. reflexivity. - apply agree_exten_2 with rs; auto. -Qed. - -Lemma transl_cond_correct: - forall cond args k ms sp rs m b, - map mreg_type args = type_of_condition cond -> - agree ms sp rs -> - eval_condition cond (map ms args) m = Some b -> - exists rs', - exec_straight (transl_cond cond args k) rs m k rs' m - /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) = - (if snd (crbit_for_cond cond) - then Val.of_bool b - else Val.notbool (Val.of_bool b)) - /\ agree ms sp rs'. -Proof. - intros. rewrite <- (eval_condition_weaken _ _ _ H1). - apply transl_cond_correct_aux; auto. -Qed. - -(** Translation of arithmetic operations. *) - -Ltac TranslOpSimpl := - match goal with - | |- exists rs' : regset, - exec_straight ?c ?rs ?m ?k rs' ?m /\ - agree (Regmap.set ?res ?v ?ms) ?sp rs' => - (exists (nextinstr (rs#(ireg_of res) <- v)); - split; - [ apply exec_straight_one; - [ repeat (rewrite (ireg_val ms sp rs); auto); reflexivity - | reflexivity ] - | auto with ppcgen ]) - || - (exists (nextinstr (rs#(freg_of res) <- v)); - split; - [ apply exec_straight_one; - [ repeat (rewrite (freg_val ms sp rs); auto); reflexivity - | reflexivity ] - | auto with ppcgen ]) - end. - -Lemma transl_op_correct: - forall op args res k ms sp rs m v, - wt_instr (Mop op args res) -> - agree ms sp rs -> - eval_operation ge sp op (map ms args) m = Some v -> - exists rs', - exec_straight (transl_op op args res k) rs m k rs' m - /\ agree (Regmap.set res v ms) sp rs'. -Proof. - intros. rewrite <- (eval_operation_weaken _ _ _ _ _ H1). clear H1; clear v. - inversion H. - (* Omove *) - simpl. exists (nextinstr (rs#(preg_of res) <- (ms r1))). - split. caseEq (mreg_type r1); intro. - apply exec_straight_one. simpl. rewrite (ireg_val ms sp rs); auto. - simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity. - auto with ppcgen. - apply exec_straight_one. simpl. rewrite (freg_val ms sp rs); auto. - simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity. - auto with ppcgen. - auto with ppcgen. - (* Other instructions *) - clear H1; clear H2; clear H4. - destruct op; simpl in H5; injection H5; clear H5; intros; - TypeInv; simpl; try (TranslOpSimpl). - (* Omove again *) - congruence. - (* Ointconst *) - generalize (loadimm_correct (ireg_of res) i k rs m). - intros [rs' [A [B C]]]. - exists rs'. split. auto. - apply agree_set_mireg_exten with rs; auto. - (* Ofloatconst *) - exists (nextinstr (rs#(freg_of res) <- (Vfloat f) #GPR12 <- Vundef)). - split. apply exec_straight_one. reflexivity. reflexivity. - auto with ppcgen. - (* Oaddrsymbol *) - change (find_symbol_offset ge i i0) with (symbol_offset ge i i0). - set (v := symbol_offset ge i i0). - pose (rs1 := nextinstr (rs#GPR12 <- (high_half v))). - exists (nextinstr (rs1#(ireg_of res) <- v)). - split. apply exec_straight_two with rs1 m. - unfold exec_instr. rewrite gpr_or_zero_zero. - unfold const_high. rewrite Val.add_commut. - rewrite high_half_zero. reflexivity. - simpl. rewrite gpr_or_zero_not_zero. 2: congruence. - unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen. - rewrite Pregmap.gss. - fold v. rewrite Val.add_commut. unfold v. rewrite low_high_half. - reflexivity. reflexivity. reflexivity. - unfold rs1. apply agree_nextinstr. apply agree_set_mireg; auto. - apply agree_set_mreg. apply agree_nextinstr. - apply agree_set_other. auto. simpl. tauto. - (* Oaddrstack *) - assert (GPR1 <> GPR12). discriminate. - generalize (addimm_correct (ireg_of res) GPR1 i k rs m H2). - intros [rs' [EX [RES OTH]]]. - exists rs'. split. auto. - apply agree_set_mireg_exten with rs; auto. - rewrite (sp_val ms sp rs). auto. auto. - (* Ocast8unsigned *) - exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 255)))). - split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity. - replace (Val.zero_ext 8 (ms m0)) - with (Val.rolm (ms m0) Int.zero (Int.repr 255)). - auto with ppcgen. - unfold Val.rolm, Val.zero_ext. destruct (ms m0); auto. - rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto. - (* Ocast16unsigned *) - exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 65535)))). - split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity. - replace (Val.zero_ext 16 (ms m0)) - with (Val.rolm (ms m0) Int.zero (Int.repr 65535)). - auto with ppcgen. - unfold Val.rolm, Val.zero_ext. destruct (ms m0); auto. - rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto. - (* Oaddimm *) - generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m - (ireg_of_not_GPR12 m0)). - intros [rs' [A [B C]]]. - exists rs'. split. auto. - apply agree_set_mireg_exten with rs; auto. - rewrite (ireg_val ms sp rs); auto. - (* Osub *) - exists (nextinstr (rs#(ireg_of res) <- (Val.sub (ms m0) (ms m1)) #CARRY <- Vundef)). - split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). - simpl. reflexivity. auto with ppcgen. - (* Osubimm *) - case (Int.eq (high_s i) Int.zero). - exists (nextinstr (rs#(ireg_of res) <- (Val.sub (Vint i) (ms m0)) #CARRY <- Vundef)). - split. apply exec_straight_one. rewrite (ireg_val ms sp rs); auto. - reflexivity. simpl. auto with ppcgen. - generalize (loadimm_correct GPR12 i (Psubfc (ireg_of res) (ireg_of m0) GPR12 :: k) rs m). - intros [rs1 [EX [RES OTH]]]. - assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. - exists (nextinstr (rs1#(ireg_of res) <- (Val.sub (Vint i) (ms m0)) #CARRY <- Vundef)). - split. eapply exec_straight_trans. eexact EX. - apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). - simpl. rewrite RES. rewrite OTH. reflexivity. - generalize (ireg_of_not_GPR12 m0); congruence. - discriminate. - reflexivity. simpl; auto with ppcgen. - (* Omulimm *) - case (Int.eq (high_s i) Int.zero). - exists (nextinstr (rs#(ireg_of res) <- (Val.mul (ms m0) (Vint i)))). - split. apply exec_straight_one. rewrite (ireg_val ms sp rs); auto. - reflexivity. auto with ppcgen. - generalize (loadimm_correct GPR12 i (Pmullw (ireg_of res) (ireg_of m0) GPR12 :: k) rs m). - intros [rs1 [EX [RES OTH]]]. - assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. - exists (nextinstr (rs1#(ireg_of res) <- (Val.mul (ms m0) (Vint i)))). - split. eapply exec_straight_trans. eexact EX. - apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). - simpl. rewrite RES. rewrite OTH. reflexivity. - generalize (ireg_of_not_GPR12 m0); congruence. - discriminate. - reflexivity. simpl; auto with ppcgen. - (* Oand *) - pose (v := Val.and (ms m0) (ms m1)). - pose (rs1 := rs#(ireg_of res) <- v). - generalize (compare_sint_spec rs1 v Vzero). - intros [A [B [C D]]]. - exists (nextinstr (compare_sint rs1 v Vzero)). - split. apply exec_straight_one. - unfold rs1, v. repeat (rewrite (ireg_val ms sp rs); auto). - reflexivity. - apply agree_exten_2 with rs1. unfold rs1, v; auto with ppcgen. - auto. - (* Oandimm *) - generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m - (ireg_of_not_GPR12 m0)). - intros [rs' [A [B [C D]]]]. - exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto. - rewrite (ireg_val ms sp rs); auto. - (* Oorimm *) - generalize (orimm_correct (ireg_of res) (ireg_of m0) i k rs m). - intros [rs' [A [B C]]]. - exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto. - rewrite (ireg_val ms sp rs); auto. - (* Oxorimm *) - generalize (xorimm_correct (ireg_of res) (ireg_of m0) i k rs m). - intros [rs' [A [B C]]]. - exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto. - rewrite (ireg_val ms sp rs); auto. - (* Oshr *) - exists (nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (ms m1)) #CARRY <- (Val.shr_carry (ms m0) (ms m1)))). - split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). - reflexivity. auto with ppcgen. - (* Oshrimm *) - exists (nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (Vint i)) #CARRY <- (Val.shr_carry (ms m0) (Vint i)))). - split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). - reflexivity. auto with ppcgen. - (* Oxhrximm *) - pose (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (Vint i)) #CARRY <- (Val.shr_carry (ms m0) (Vint i)))). - exists (nextinstr (rs1#(ireg_of res) <- (Val.shrx (ms m0) (Vint i)))). - split. apply exec_straight_two with rs1 m. - unfold rs1; rewrite (ireg_val ms sp rs); auto. - simpl; unfold rs1; repeat rewrite <- (ireg_val ms sp rs); auto. - repeat (rewrite nextinstr_inv; try discriminate). - repeat rewrite Pregmap.gss. decEq. decEq. - apply (f_equal3 (@Pregmap.set val)); auto. - rewrite Pregmap.gso. rewrite Pregmap.gss. apply Val.shrx_carry. - discriminate. reflexivity. reflexivity. - apply agree_exten_2 with (rs#(ireg_of res) <- (Val.shrx (ms m0) (Vint i))). - auto with ppcgen. - intros. rewrite nextinstr_inv; auto. - case (preg_eq (ireg_of res) r); intro. - subst r. repeat rewrite Pregmap.gss. auto. - repeat rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. - repeat rewrite Pregmap.gso; auto. - (* Ointoffloat *) - exists (nextinstr (rs#(ireg_of res) <- (Val.intoffloat (ms m0)) #FPR13 <- Vundef)). - split. apply exec_straight_one. - repeat (rewrite (freg_val ms sp rs); auto). - reflexivity. auto with ppcgen. - (* Ointuoffloat *) - exists (nextinstr (rs#(ireg_of res) <- (Val.intuoffloat (ms m0)) #FPR13 <- Vundef)). - split. apply exec_straight_one. - repeat (rewrite (freg_val ms sp rs); auto). - reflexivity. auto with ppcgen. - (* Ofloatofint *) - exists (nextinstr (rs#(freg_of res) <- (Val.floatofint (ms m0)) #GPR12 <- Vundef #FPR13 <- Vundef)). - split. apply exec_straight_one. - repeat (rewrite (ireg_val ms sp rs); auto). - reflexivity. auto 10 with ppcgen. - (* Ofloatofintu *) - exists (nextinstr (rs#(freg_of res) <- (Val.floatofintu (ms m0)) #GPR12 <- Vundef #FPR13 <- Vundef)). - split. apply exec_straight_one. - repeat (rewrite (ireg_val ms sp rs); auto). - reflexivity. auto 10 with ppcgen. - (* Ocmp *) - set (bit := fst (crbit_for_cond c)). - set (isset := snd (crbit_for_cond c)). - set (k1 := - Pmfcrbit (ireg_of res) bit :: - (if isset - then k - else Pxori (ireg_of res) (ireg_of res) (Cint Int.one) :: k)). - generalize (transl_cond_correct_aux c args k1 ms sp rs m H2 H0). - fold bit; fold isset. - intros [rs1 [EX1 [RES1 AG1]]]. - set (rs2 := nextinstr (rs1#(ireg_of res) <- (rs1#(reg_of_crbit bit)))). - destruct isset. - exists rs2. - split. apply exec_straight_trans with k1 rs1 m. assumption. - unfold k1. apply exec_straight_one. - reflexivity. reflexivity. - unfold rs2. rewrite RES1. auto with ppcgen. - exists (nextinstr (rs2#(ireg_of res) <- (eval_condition_total c ms##args))). - split. apply exec_straight_trans with k1 rs1 m. assumption. - unfold k1. apply exec_straight_two with rs2 m. - reflexivity. simpl. - replace (Val.xor (rs2 (ireg_of res)) (Vint Int.one)) - with (eval_condition_total c ms##args). - reflexivity. - unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - rewrite RES1. apply Val.notbool_xor. apply eval_condition_total_is_bool. - reflexivity. reflexivity. - unfold rs2. auto with ppcgen. -Qed. - -Lemma transl_load_store_correct: - forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) - addr args k ms sp rs m ms' m', - (forall cst (r1: ireg) (rs1: regset) k, - eval_addressing_total ge sp addr (map ms args) = Val.add rs1#r1 (const_low ge cst) -> - agree ms sp rs1 -> - r1 <> GPR0 -> - exists rs', - exec_straight (mk1 cst r1 :: k) rs1 m k rs' m' /\ - agree ms' sp rs') -> - (forall (r1 r2: ireg) (rs1: regset) k, - eval_addressing_total ge sp addr (map ms args) = Val.add rs1#r1 rs1#r2 -> - agree ms sp rs1 -> - exists rs', - exec_straight (mk2 r1 r2 :: k) rs1 m k rs' m' /\ - agree ms' sp rs') -> - agree ms sp rs -> - map mreg_type args = type_of_addressing addr -> - exists rs', - exec_straight (transl_load_store mk1 mk2 addr args k) rs m - k rs' m' - /\ agree ms' sp rs'. -Proof. - intros. destruct addr; simpl in H2; TypeInv; simpl. - (* Aindexed *) - case (ireg_eq (ireg_of t) GPR0); intro. - (* Aindexed from GPR0 *) - set (rs1 := nextinstr (rs#GPR12 <- (ms t))). - set (rs2 := nextinstr (rs1#GPR12 <- (Val.add (ms t) (Vint (Int.shl (high_s i) (Int.repr 16)))))). - assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) = - Val.add rs2#GPR12 (const_low ge (Cint (low_s i)))). - simpl. unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss. - rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. - discriminate. - assert (AG: agree ms sp rs2). unfold rs2, rs1; auto 6 with ppcgen. - assert (NOT0: GPR12 <> GPR0). discriminate. - generalize (H _ _ _ k ADDR AG NOT0). - intros [rs' [EX' AG']]. - exists rs'. split. - apply exec_straight_trans with (mk1 (Cint (low_s i)) GPR12 :: k) rs2 m. - apply exec_straight_two with rs1 m. - unfold rs1. rewrite (ireg_val ms sp rs); auto. - unfold rs2. replace (ms t) with (rs1#GPR12). auto. - unfold rs1. rewrite nextinstr_inv. apply Pregmap.gss. discriminate. - reflexivity. reflexivity. - assumption. assumption. - (* Aindexed short *) - case (Int.eq (high_s i) Int.zero). - assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) = - Val.add rs#(ireg_of t) (const_low ge (Cint i))). - simpl. rewrite (ireg_val ms sp rs); auto. - generalize (H _ _ _ k ADDR H1 n). intros [rs' [EX' AG']]. - exists rs'. split. auto. auto. - (* Aindexed long *) - set (rs1 := nextinstr (rs#GPR12 <- (Val.add (ms t) (Vint (Int.shl (high_s i) (Int.repr 16)))))). - assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) = - Val.add rs1#GPR12 (const_low ge (Cint (low_s i)))). - simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. - rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. - discriminate. - assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen. - assert (NOT0: GPR12 <> GPR0). discriminate. - generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs1 m. - simpl. rewrite gpr_or_zero_not_zero; auto. - rewrite <- (ireg_val ms sp rs); auto. reflexivity. - assumption. assumption. - (* Aindexed2 *) - apply H0. - simpl. repeat (rewrite (ireg_val ms sp rs); auto). auto. - (* Aglobal *) - set (rs1 := nextinstr (rs#GPR12 <- (const_high ge (Csymbol_high i i0)))). - assert (ADDR: eval_addressing_total ge sp (Aglobal i i0) ms##nil = - Val.add rs1#GPR12 (const_low ge (Csymbol_low i i0))). - simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. - unfold const_high, const_low. - set (v := symbol_offset ge i i0). - symmetry. rewrite Val.add_commut. unfold v. apply low_high_half. - discriminate. - assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen. - assert (NOT0: GPR12 <> GPR0). discriminate. - generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs1 m. - unfold exec_instr. rewrite gpr_or_zero_zero. - rewrite Val.add_commut. unfold const_high. - rewrite high_half_zero. - reflexivity. reflexivity. - assumption. assumption. - (* Abased *) - assert (COMMON: - forall (rs1: regset) r, - r <> GPR0 -> - ms t = rs1#r -> - agree ms sp rs1 -> - exists rs', - exec_straight - (Paddis GPR12 r (Csymbol_high i i0) - :: mk1 (Csymbol_low i i0) GPR12 :: k) rs1 m k rs' m' - /\ agree ms' sp rs'). - intros. - set (rs2 := nextinstr (rs1#GPR12 <- (Val.add (ms t) (const_high ge (Csymbol_high i i0))))). - assert (ADDR: eval_addressing_total ge sp (Abased i i0) ms##(t::nil) = - Val.add rs2#GPR12 (const_low ge (Csymbol_low i i0))). - simpl. unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss. - unfold const_high. - set (v := symbol_offset ge i i0). - rewrite Val.add_assoc. - rewrite (Val.add_commut (high_half v)). - unfold v. rewrite low_high_half. apply Val.add_commut. - discriminate. - assert (AG: agree ms sp rs2). unfold rs2; auto with ppcgen. - assert (NOT0: GPR12 <> GPR0). discriminate. - generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs2 m. - unfold exec_instr. rewrite gpr_or_zero_not_zero; auto. - rewrite <- H3. reflexivity. reflexivity. - assumption. assumption. - case (ireg_eq (ireg_of t) GPR0); intro. - set (rs1 := nextinstr (rs#GPR12 <- (ms t))). - assert (R1: GPR12 <> GPR0). discriminate. - assert (R2: ms t = rs1 GPR12). - unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss; auto. - discriminate. - assert (R3: agree ms sp rs1). unfold rs1; auto with ppcgen. - generalize (COMMON rs1 GPR12 R1 R2 R3). intros [rs' [EX' AG']]. - exists rs'. split. - apply exec_straight_step with rs1 m. - unfold rs1. rewrite (ireg_val ms sp rs); auto. reflexivity. - assumption. assumption. - apply COMMON; auto. eapply ireg_val; eauto. - (* Ainstack *) - case (Int.eq (high_s i) Int.zero). - apply H. simpl. rewrite (sp_val ms sp rs); auto. auto. - discriminate. - set (rs1 := nextinstr (rs#GPR12 <- (Val.add sp (Vint (Int.shl (high_s i) (Int.repr 16)))))). - assert (ADDR: eval_addressing_total ge sp (Ainstack i) ms##nil = - Val.add rs1#GPR12 (const_low ge (Cint (low_s i)))). - simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. - rewrite Val.add_assoc. decEq. simpl. rewrite low_high_s. auto. - discriminate. - assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen. - assert (NOT0: GPR12 <> GPR0). discriminate. - generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs1 m. - simpl. rewrite gpr_or_zero_not_zero. - unfold rs1. rewrite (sp_val ms sp rs). reflexivity. - auto. discriminate. reflexivity. assumption. assumption. -Qed. - -(** Translation of memory loads. *) - -Lemma transl_load_correct: - forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) - chunk addr args k ms sp rs m dst a v, - (forall cst (r1: ireg) (rs1: regset), - exec_instr ge fn (mk1 cst r1) rs1 m = - load1 ge chunk (preg_of dst) cst r1 rs1 m) -> - (forall (r1 r2: ireg) (rs1: regset), - exec_instr ge fn (mk2 r1 r2) rs1 m = - load2 chunk (preg_of dst) r1 r2 rs1 m) -> - agree ms sp rs -> - map mreg_type args = type_of_addressing addr -> - eval_addressing ge sp addr (map ms args) = Some a -> - Mem.loadv chunk m a = Some v -> - exists rs', - exec_straight (transl_load_store mk1 mk2 addr args k) rs m - k rs' m - /\ agree (Regmap.set dst v ms) sp rs'. -Proof. - intros. apply transl_load_store_correct with ms. - intros. exists (nextinstr (rs1#(preg_of dst) <- v)). - split. apply exec_straight_one. rewrite H. - unfold load1. rewrite gpr_or_zero_not_zero; auto. - rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. - rewrite H5 in H4. rewrite H4. auto. - auto with ppcgen. auto with ppcgen. - intros. exists (nextinstr (rs1#(preg_of dst) <- v)). - split. apply exec_straight_one. rewrite H0. - unfold load2. - rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. - rewrite H5 in H4. rewrite H4. auto. - auto with ppcgen. auto with ppcgen. - auto. auto. -Qed. - -(** Translation of memory stores. *) - -Lemma transl_store_correct: - forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) - chunk addr args k ms sp rs m src a m', - (forall cst (r1: ireg) (rs1: regset), - exec_instr ge fn (mk1 cst r1) rs1 m = - store1 ge chunk (preg_of src) cst r1 rs1 m) -> - (forall (r1 r2: ireg) (rs1: regset), - exec_instr ge fn (mk2 r1 r2) rs1 m = - store2 chunk (preg_of src) r1 r2 rs1 m) -> - agree ms sp rs -> - map mreg_type args = type_of_addressing addr -> - eval_addressing ge sp addr (map ms args) = Some a -> - Mem.storev chunk m a (ms src) = Some m' -> - exists rs', - exec_straight (transl_load_store mk1 mk2 addr args k) rs m - k rs' m' - /\ agree ms sp rs'. -Proof. - intros. apply transl_load_store_correct with ms. - intros. exists (nextinstr rs1). - split. apply exec_straight_one. rewrite H. - unfold store1. rewrite gpr_or_zero_not_zero; auto. - rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. - rewrite H5 in H4. elim H6; intros. rewrite H9 in H4. - rewrite H4. auto. - auto with ppcgen. auto with ppcgen. - intros. exists (nextinstr rs1). - split. apply exec_straight_one. rewrite H0. - unfold store2. - rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. - rewrite H5 in H4. elim H6; intros. rewrite H8 in H4. - rewrite H4. auto. - auto with ppcgen. auto with ppcgen. - auto. auto. -Qed. - -(** Translation of allocations *) - -Lemma transl_alloc_correct: - forall ms sp rs sz m m' blk k, - agree ms sp rs -> - ms Conventions.loc_alloc_argument = Vint sz -> - Mem.alloc m 0 (Int.signed sz) = (m', blk) -> - let ms' := Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms in - exists rs', - exec_straight (Pallocblock :: k) rs m k rs' m' - /\ agree ms' sp rs'. -Proof. - intros. - pose (rs' := nextinstr (rs#GPR3 <- (Vptr blk Int.zero) #LR <- (Val.add rs#PC Vone))). - exists rs'; split. - apply exec_straight_one. unfold exec_instr. - generalize (preg_val _ _ _ Conventions.loc_alloc_argument H). - unfold preg_of; intro. simpl in H2. rewrite <- H2. rewrite H0. - rewrite H1. reflexivity. - reflexivity. - unfold ms', rs'. apply agree_nextinstr. apply agree_set_other. - change (IR GPR3) with (preg_of Conventions.loc_alloc_result). - apply agree_set_mreg. auto. - simpl. tauto. -Qed. - -End STRAIGHTLINE. - diff --git a/backend/PPCgenretaddr.v b/backend/PPCgenretaddr.v deleted file mode 100644 index eab8599e..00000000 --- a/backend/PPCgenretaddr.v +++ /dev/null @@ -1,188 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Predictor for return addresses in generated PPC code. - - The [return_address_offset] predicate defined here is used in the - concrete semantics for Mach (module [Machconcr]) to determine the - return addresses that are stored in activation records. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Globalenvs. -Require Import Op. -Require Import Locations. -Require Import Mach. -Require Import PPC. -Require Import PPCgen. - -(** The ``code tail'' of an instruction list [c] is the list of instructions - starting at PC [pos]. *) - -Inductive code_tail: Z -> code -> code -> Prop := - | code_tail_0: forall c, - code_tail 0 c c - | code_tail_S: forall pos i c1 c2, - code_tail pos c1 c2 -> - code_tail (pos + 1) (i :: c1) c2. - -Lemma code_tail_pos: - forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. -Proof. - induction 1. omega. omega. -Qed. - -(** Consider a Mach function [f] and a sequence [c] of Mach instructions - representing the Mach code that remains to be executed after a - function call returns. The predicate [return_address_offset f c ofs] - holds if [ofs] is the integer offset of the PPC instruction - following the call in the PPC code obtained by translating the - code of [f]. Graphically: -<< - Mach function f |--------- Mcall ---------| - Mach code c | |--------| - | \ \ - | \ \ - | \ \ - PPC code | |--------| - PPC function |--------------- Pbl ---------| - - <-------- ofs -------> ->> -*) - -Inductive return_address_offset: Mach.function -> Mach.code -> int -> Prop := - | return_address_offset_intro: - forall c f ofs, - code_tail ofs (transl_function f) (transl_code f c) -> - return_address_offset f c (Int.repr ofs). - -(** We now show that such an offset always exists if the Mach code [c] - is a suffix of [f.(fn_code)]. This holds because the translation - from Mach to PPC is compositional: each Mach instruction becomes - zero, one or several PPC instructions, but the order of instructions - is preserved. *) - -Lemma is_tail_code_tail: - forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. -Proof. - induction 1. exists 0; constructor. - destruct IHis_tail as [ofs CT]. exists (ofs + 1); constructor; auto. -Qed. - -Hint Resolve is_tail_refl: ppcretaddr. - -Ltac IsTail := - auto with ppcretaddr; - match goal with - | [ |- is_tail _ (_ :: _) ] => constructor; IsTail - | [ |- is_tail _ (match ?x with true => _ | false => _ end) ] => destruct x; IsTail - | [ |- is_tail _ (match ?x with left _ => _ | right _ => _ end) ] => destruct x; IsTail - | [ |- is_tail _ (match ?x with nil => _ | _ :: _ => _ end) ] => destruct x; IsTail - | [ |- is_tail _ (match ?x with Tint => _ | Tfloat => _ end) ] => destruct x; IsTail - | [ |- is_tail _ (?f _ _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail - | [ |- is_tail _ (?f _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail - | [ |- is_tail _ (?f _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail - | [ |- is_tail _ (?f _ _ _ ?k) ] => apply is_tail_trans with k; IsTail - | [ |- is_tail _ (?f _ _ ?k) ] => apply is_tail_trans with k; IsTail - | _ => idtac - end. - -Lemma loadimm_tail: - forall r n k, is_tail k (loadimm r n k). -Proof. unfold loadimm; intros; IsTail. Qed. -Hint Resolve loadimm_tail: ppcretaddr. - -Lemma addimm_tail: - forall r1 r2 n k, is_tail k (addimm r1 r2 n k). -Proof. unfold addimm, addimm_1, addimm_2; intros; IsTail. Qed. -Hint Resolve addimm_tail: ppcretaddr. - -Lemma andimm_tail: - forall r1 r2 n k, is_tail k (andimm r1 r2 n k). -Proof. unfold andimm; intros; IsTail. Qed. -Hint Resolve andimm_tail: ppcretaddr. - -Lemma orimm_tail: - forall r1 r2 n k, is_tail k (orimm r1 r2 n k). -Proof. unfold orimm; intros; IsTail. Qed. -Hint Resolve orimm_tail: ppcretaddr. - -Lemma xorimm_tail: - forall r1 r2 n k, is_tail k (xorimm r1 r2 n k). -Proof. unfold xorimm; intros; IsTail. Qed. -Hint Resolve xorimm_tail: ppcretaddr. - -Lemma loadind_tail: - forall base ofs ty dst k, is_tail k (loadind base ofs ty dst k). -Proof. unfold loadind; intros; IsTail. Qed. -Hint Resolve loadind_tail: ppcretaddr. - -Lemma storeind_tail: - forall src base ofs ty k, is_tail k (storeind src base ofs ty k). -Proof. unfold storeind; intros; IsTail. Qed. -Hint Resolve storeind_tail: ppcretaddr. - -Lemma floatcomp_tail: - forall cmp r1 r2 k, is_tail k (floatcomp cmp r1 r2 k). -Proof. unfold floatcomp; intros; destruct cmp; IsTail. Qed. -Hint Resolve floatcomp_tail: ppcretaddr. - -Lemma transl_cond_tail: - forall cond args k, is_tail k (transl_cond cond args k). -Proof. unfold transl_cond; intros; destruct cond; IsTail. Qed. -Hint Resolve transl_cond_tail: ppcretaddr. - -Lemma transl_op_tail: - forall op args r k, is_tail k (transl_op op args r k). -Proof. unfold transl_op; intros; destruct op; IsTail. Qed. -Hint Resolve transl_op_tail: ppcretaddr. - -Lemma transl_load_store_tail: - forall mk1 mk2 addr args k, - is_tail k (transl_load_store mk1 mk2 addr args k). -Proof. unfold transl_load_store; intros; destruct addr; IsTail. Qed. -Hint Resolve transl_load_store_tail: ppcretaddr. - -Lemma transl_instr_tail: - forall f i k, is_tail k (transl_instr f i k). -Proof. - unfold transl_instr; intros; destruct i; IsTail. - destruct m; IsTail. - destruct m; IsTail. - destruct s0; IsTail. - destruct s0; IsTail. -Qed. -Hint Resolve transl_instr_tail: ppcretaddr. - -Lemma transl_code_tail: - forall f c1 c2, is_tail c1 c2 -> is_tail (transl_code f c1) (transl_code f c2). -Proof. - induction 1; simpl. constructor. eapply is_tail_trans; eauto with ppcretaddr. -Qed. - -Lemma return_address_exists: - forall f c, is_tail c f.(fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. assert (is_tail (transl_code f c) (transl_function f)). - unfold transl_function. IsTail. apply transl_code_tail; auto. - destruct (is_tail_code_tail _ _ H0) as [ofs A]. - exists (Int.repr ofs). constructor. auto. -Qed. - - diff --git a/backend/RTLgenaux.ml b/backend/RTLgenaux.ml new file mode 100644 index 00000000..4c1fc05c --- /dev/null +++ b/backend/RTLgenaux.ml @@ -0,0 +1,72 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Camlcoq +open Switch +open CminorSel + +let more_likely (c: condexpr) (ifso: stmt) (ifnot: stmt) = false + +module IntOrd = + struct + type t = Integers.int + let compare x y = + if Integers.Int.eq x y then 0 else + if Integers.Int.ltu x y then -1 else 1 + end + +module IntSet = Set.Make(IntOrd) + +let normalize_table tbl = + let rec norm seen = function + | [] -> [] + | Datatypes.Coq_pair(key, act) :: rem -> + if IntSet.mem key seen + then norm seen rem + else (key, act) :: norm (IntSet.add key seen) rem + in norm IntSet.empty tbl + +let compile_switch default table = + let sw = Array.of_list (normalize_table table) in + Array.stable_sort (fun (n1, _) (n2, _) -> IntOrd.compare n1 n2) sw; + let rec build lo hi minval maxval = + match hi - lo with + | 0 -> + CTaction default + | 1 -> + let (key, act) = sw.(lo) in + if Integers.Int.sub maxval minval = Integers.Int.zero + then CTaction act + else CTifeq(key, act, CTaction default) + | 2 -> + let (key1, act1) = sw.(lo) + and (key2, act2) = sw.(lo+1) in + CTifeq(key1, act1, + if Integers.Int.sub maxval minval = Integers.Int.one + then CTaction act2 + else CTifeq(key2, act2, CTaction default)) + | 3 -> + let (key1, act1) = sw.(lo) + and (key2, act2) = sw.(lo+1) + and (key3, act3) = sw.(lo+2) in + CTifeq(key1, act1, + CTifeq(key2, act2, + if Integers.Int.sub maxval minval = coqint_of_camlint 2l + then CTaction act3 + else CTifeq(key3, act3, CTaction default))) + | _ -> + let mid = (lo + hi) / 2 in + let (pivot, _) = sw.(mid) in + CTiflt(pivot, + build lo mid minval (Integers.Int.sub pivot Integers.Int.one), + build mid hi pivot maxval) + in build 0 (Array.length sw) Integers.Int.zero Integers.Int.max_unsigned diff --git a/backend/RTLtypingaux.ml b/backend/RTLtypingaux.ml new file mode 100644 index 00000000..ff704ebe --- /dev/null +++ b/backend/RTLtypingaux.ml @@ -0,0 +1,156 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Type inference for RTL *) + +open Datatypes +open CList +open Camlcoq +open Maps +open AST +open Op +open Registers +open RTL + +exception Type_error of string + +let env = ref (PTree.empty : typ PTree.t) + +let set_type r ty = + match PTree.get r !env with + | None -> env := PTree.set r ty !env + | Some ty' -> if ty <> ty' then raise (Type_error "type mismatch") + +let rec set_types rl tyl = + match rl, tyl with + | [], [] -> () + | r1 :: rs, ty1 :: tys -> set_type r1 ty1; set_types rs tys + | _, _ -> raise (Type_error "arity mismatch") + +(* First pass: process constraints of the form typeof(r) = ty *) + +let type_instr retty (Coq_pair(pc, i)) = + match i with + | Inop(_) -> + () + | Iop(Omove, _, _, _) -> + () + | Iop(op, args, res, _) -> + let (Coq_pair(targs, tres)) = type_of_operation op in + set_types args targs; set_type res tres + | Iload(chunk, addr, args, dst, _) -> + set_types args (type_of_addressing addr); + set_type dst (type_of_chunk chunk) + | Istore(chunk, addr, args, src, _) -> + set_types args (type_of_addressing addr); + set_type src (type_of_chunk chunk) + | Icall(sg, ros, args, res, _) -> + begin try + begin match ros with + | Coq_inl r -> set_type r Tint + | Coq_inr _ -> () + end; + set_types args sg.sig_args; + set_type res (match sg.sig_res with None -> Tint | Some ty -> ty) + with Type_error msg -> + let name = + match ros with + | Coq_inl _ -> "<reg>" + | Coq_inr id -> extern_atom id in + raise(Type_error (Printf.sprintf "type mismatch in Icall(%s): %s" + name msg)) + end + | Itailcall(sg, ros, args) -> + begin try + begin match ros with + | Coq_inl r -> set_type r Tint + | Coq_inr _ -> () + end; + set_types args sg.sig_args; + if sg.sig_res <> retty then + raise (Type_error "mismatch on return type") + with Type_error msg -> + let name = + match ros with + | Coq_inl _ -> "<reg>" + | Coq_inr id -> extern_atom id in + raise(Type_error (Printf.sprintf "type mismatch in Itailcall(%s): %s" + name msg)) + end + | Ialloc(arg, res, _) -> + set_type arg Tint; set_type res Tint + | Icond(cond, args, _, _) -> + set_types args (type_of_condition cond) + | Ireturn(optres) -> + begin match optres, retty with + | None, None -> () + | Some r, Some ty -> set_type r ty + | _, _ -> raise (Type_error "type mismatch in Ireturn") + end + +let type_pass1 retty instrs = + List.iter (type_instr retty) instrs + +(* Second pass: extract move constraints typeof(r1) = typeof(r2) + and solve them iteratively *) + +let rec extract_moves = function + | [] -> [] + | Coq_pair(pc, i) :: rem -> + match i with + | Iop(Omove, [r1], r2, _) -> + (r1, r2) :: extract_moves rem + | Iop(Omove, _, _, _) -> + raise (Type_error "wrong Omove") + | _ -> + extract_moves rem + +let changed = ref false + +let rec solve_moves = function + | [] -> [] + | (r1, r2) :: rem -> + match (PTree.get r1 !env, PTree.get r2 !env) with + | Some ty1, Some ty2 -> + if ty1 = ty2 + then (changed := true; solve_moves rem) + else raise (Type_error "type mismatch in Omove") + | Some ty1, None -> + env := PTree.set r2 ty1 !env; changed := true; solve_moves rem + | None, Some ty2 -> + env := PTree.set r1 ty2 !env; changed := true; solve_moves rem + | None, None -> + (r1, r2) :: solve_moves rem + +let rec iter_solve_moves mvs = + changed := false; + let mvs' = solve_moves mvs in + if !changed then iter_solve_moves mvs' + +let type_pass2 instrs = + iter_solve_moves (extract_moves instrs) + +let typeof e r = + match PTree.get r e with Some ty -> ty | None -> Tint + +let infer_type_environment f instrs = + try + env := PTree.empty; + set_types f.fn_params f.fn_sig.sig_args; + type_pass1 f.fn_sig.sig_res instrs; + type_pass2 instrs; + let e = !env in + env := PTree.empty; + Some(typeof e) + with Type_error msg -> + Printf.eprintf "Error during RTL type inference: %s\n" msg; + None diff --git a/backend/Reloadproof.v b/backend/Reloadproof.v index 3a96d3a2..5a3acd31 100644 --- a/backend/Reloadproof.v +++ b/backend/Reloadproof.v @@ -1017,7 +1017,7 @@ Proof. intros [ls2 [A [B C]]]. assert (exists ta, eval_addressing tge sp addr (reglist ls2 (regs_for args)) = Some ta /\ Val.lessdef a ta). - apply eval_addressing_lessdef with (map rs args); auto. + apply eval_addressing_lessdef with (map rs args). rewrite B. eapply agree_locs; eauto. rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. destruct H1 as [ta [P Q]]. @@ -1047,7 +1047,7 @@ Proof. simpl in B. assert (exists ta, eval_addressing tge sp addr (reglist ls2 rargs) = Some ta /\ Val.lessdef a ta). - apply eval_addressing_lessdef with (map rs args); auto. + apply eval_addressing_lessdef with (map rs args). rewrite D. eapply agree_locs; eauto. rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. destruct H1 as [ta [P Q]]. @@ -1072,7 +1072,7 @@ Proof. apply locs_acceptable_disj_temporaries; auto. assert (exists ta, eval_addressing tge sp addr (reglist ls2 (regs_for args)) = Some ta /\ Val.lessdef a ta). - apply eval_addressing_lessdef with (map rs args); auto. + apply eval_addressing_lessdef with (map rs args). rewrite B. eapply agree_locs; eauto. rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. destruct H1 as [ta [P Q]]. diff --git a/backend/Selection.v b/backend/Selection.v deleted file mode 100644 index 1de6ae3c..00000000 --- a/backend/Selection.v +++ /dev/null @@ -1,1196 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Instruction selection *) - -(** The instruction selection pass recognizes opportunities for using - combined arithmetic and logical operations and addressing modes - offered by the target processor. For instance, the expression [x + 1] - can take advantage of the "immediate add" instruction of the processor, - and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned - into a "rotate and mask" instruction. - - Instruction selection proceeds by bottom-up rewriting over expressions. - The source language is Cminor and the target language is CminorSel. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Globalenvs. -Require Cminor. -Require Import Op. -Require Import CminorSel. - -Infix ":::" := Econs (at level 60, right associativity) : selection_scope. - -Open Local Scope selection_scope. - -(** * Lifting of let-bound variables *) - -(** Some of the instruction functions generate [Elet] constructs to - share the evaluation of a subexpression. Owing to the use of de - Bruijn indices for let-bound variables, we need to shift de Bruijn - indices when an expression [b] is put in a [Elet a b] context. *) - -Fixpoint lift_expr (p: nat) (a: expr) {struct a}: expr := - match a with - | Evar id => Evar id - | Eop op bl => Eop op (lift_exprlist p bl) - | Eload chunk addr bl => Eload chunk addr (lift_exprlist p bl) - | Econdition b c d => - Econdition (lift_condexpr p b) (lift_expr p c) (lift_expr p d) - | Elet b c => Elet (lift_expr p b) (lift_expr (S p) c) - | Eletvar n => - if le_gt_dec p n then Eletvar (S n) else Eletvar n - end - -with lift_condexpr (p: nat) (a: condexpr) {struct a}: condexpr := - match a with - | CEtrue => CEtrue - | CEfalse => CEfalse - | CEcond cond bl => CEcond cond (lift_exprlist p bl) - | CEcondition b c d => - CEcondition (lift_condexpr p b) (lift_condexpr p c) (lift_condexpr p d) - end - -with lift_exprlist (p: nat) (a: exprlist) {struct a}: exprlist := - match a with - | Enil => Enil - | Econs b cl => Econs (lift_expr p b) (lift_exprlist p cl) - end. - -Definition lift (a: expr): expr := lift_expr O a. - -(** * Smart constructors for operators *) - -(** This section defines functions for building CminorSel expressions - and statements, especially expressions consisting of operator - applications. These functions examine their arguments to choose - cheaper forms of operators whenever possible. - - For instance, [add e1 e2] will return a CminorSel expression semantically - equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a - [Oaddimm] operator if one of the arguments is an integer constant, - or suppress the addition altogether if one of the arguments is the - null integer. In passing, we perform operator reassociation - ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount - of constant propagation. -*) - -(** ** Integer logical negation *) - -(** The natural way to write smart constructors is by pattern-matching - on their arguments, recognizing cases where cheaper operators - or combined operators are applicable. For instance, integer logical - negation has three special cases (not-and, not-or and not-xor), - along with a default case that uses not-or over its arguments and itself. - This is written naively as follows: -<< -Definition notint (e: expr) := - match e with - | Eop Oand (t1:::t2:::Enil) => Eop Onand (t1:::t2:::Enil) - | Eop Oor (t1:::t2:::Enil) => Eop Onor (t1:::t2:::Enil) - | Eop Oxor (t1:::t2:::Enil) => Eop Onxor (t1:::t2:::Enil) - | _ => Elet(e, Eop Onor (Eletvar O ::: Eletvar O ::: Enil) - end. ->> - However, Coq expands complex pattern-matchings like the above into - elementary matchings over all constructors of an inductive type, - resulting in much duplication of the final catch-all case. - Such duplications generate huge executable code and duplicate - cases in the correctness proofs. - - To limit this duplication, we use the following trick due to - Yves Bertot. We first define a dependent inductive type that - characterizes the expressions that match each of the 4 cases of interest. -*) - -Inductive notint_cases: forall (e: expr), Set := - | notint_case1: - forall (t1: expr) (t2: expr), - notint_cases (Eop Oand (t1:::t2:::Enil)) - | notint_case2: - forall (t1: expr) (t2: expr), - notint_cases (Eop Oor (t1:::t2:::Enil)) - | notint_case3: - forall (t1: expr) (t2: expr), - notint_cases (Eop Oxor (t1:::t2:::Enil)) - | notint_default: - forall (e: expr), - notint_cases e. - -(** We then define a classification function that takes an expression - and return the case in which it falls. Note that the catch-all case - [notint_default] does not state that it is mutually exclusive with - the first three, more specific cases. The classification function - nonetheless chooses the specific cases in preference to the catch-all - case. *) - -Definition notint_match (e: expr) := - match e as z1 return notint_cases z1 with - | Eop Oand (t1:::t2:::Enil) => - notint_case1 t1 t2 - | Eop Oor (t1:::t2:::Enil) => - notint_case2 t1 t2 - | Eop Oxor (t1:::t2:::Enil) => - notint_case3 t1 t2 - | e => - notint_default e - end. - -(** Finally, the [notint] function we need is defined by a 4-case match - over the result of the classification function. Thus, no duplication - of the right-hand sides of this match occur, and the proof has only - 4 cases to consider (it proceeds by case over [notint_match e]). - Since the default case is not obviously exclusive with the three - specific cases, it is important that its right-hand side is - semantically correct for all possible values of [e], which is the - case here and for all other smart constructors. *) - -Definition notint (e: expr) := - match notint_match e with - | notint_case1 t1 t2 => - Eop Onand (t1:::t2:::Enil) - | notint_case2 t1 t2 => - Eop Onor (t1:::t2:::Enil) - | notint_case3 t1 t2 => - Eop Onxor (t1:::t2:::Enil) - | notint_default e => - Elet e (Eop Onor (Eletvar O ::: Eletvar O ::: Enil)) - end. - -(** This programming pattern will be applied systematically for the - other smart constructors in this file. *) - -(** ** Boolean negation *) - -Definition notbool_base (e: expr) := - Eop (Ocmp (Ccompimm Ceq Int.zero)) (e ::: Enil). - -Fixpoint notbool (e: expr) {struct e} : expr := - match e with - | Eop (Ointconst n) Enil => - Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil - | Eop (Ocmp cond) args => - Eop (Ocmp (negate_condition cond)) args - | Econdition e1 e2 e3 => - Econdition e1 (notbool e2) (notbool e3) - | _ => - notbool_base e - end. - -(** ** Integer addition and pointer addition *) - -(* -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match e with - | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil - | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Int.add n m)) Enil - | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Int.add n m)) Enil - | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) - | _ => Eop (Oaddimm n) (e ::: Enil) - end. -*) - -(** Addition of an integer constant. *) - -Inductive addimm_cases: forall (e: expr), Set := - | addimm_case1: - forall (m: int), - addimm_cases (Eop (Ointconst m) Enil) - | addimm_case2: - forall (s: ident) (m: int), - addimm_cases (Eop (Oaddrsymbol s m) Enil) - | addimm_case3: - forall (m: int), - addimm_cases (Eop (Oaddrstack m) Enil) - | addimm_case4: - forall (m: int) (t: expr), - addimm_cases (Eop (Oaddimm m) (t ::: Enil)) - | addimm_default: - forall (e: expr), - addimm_cases e. - -Definition addimm_match (e: expr) := - match e as z1 return addimm_cases z1 with - | Eop (Ointconst m) Enil => - addimm_case1 m - | Eop (Oaddrsymbol s m) Enil => - addimm_case2 s m - | Eop (Oaddrstack m) Enil => - addimm_case3 m - | Eop (Oaddimm m) (t ::: Enil) => - addimm_case4 m t - | e => - addimm_default e - end. - -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match addimm_match e with - | addimm_case1 m => - Eop (Ointconst(Int.add n m)) Enil - | addimm_case2 s m => - Eop (Oaddrsymbol s (Int.add n m)) Enil - | addimm_case3 m => - Eop (Oaddrstack (Int.add n m)) Enil - | addimm_case4 m t => - Eop (Oaddimm(Int.add n m)) (t ::: Enil) - | addimm_default e => - Eop (Oaddimm n) (e ::: Enil) - end. - -(** Addition of two integer or pointer expressions. *) - -(* -Definition add (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | Eop(Oaddimm n1) (t1:::Enil)), t2 => addimm n1 (Eop Oadd (t1:::t2:::Enil)) - | t1, Eop (Ointconst n2) Enil => addimm n2 t1 - | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | _, _ => Eop Oadd (e1:::e2:::Enil) - end. -*) - -Inductive add_cases: forall (e1: expr) (e2: expr), Set := - | add_case1: - forall (n1: int) (t2: expr), - add_cases (Eop (Ointconst n1) Enil) (t2) - | add_case2: - forall (n1: int) (t1: expr) (n2: int) (t2: expr), - add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) - | add_case3: - forall (n1: int) (t1: expr) (t2: expr), - add_cases (Eop(Oaddimm n1) (t1:::Enil)) (t2) - | add_case4: - forall (t1: expr) (n2: int), - add_cases (t1) (Eop (Ointconst n2) Enil) - | add_case5: - forall (t1: expr) (n2: int) (t2: expr), - add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | add_default: - forall (e1: expr) (e2: expr), - add_cases e1 e2. - -Definition add_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return add_cases e1 z2 with - | Eop (Ointconst n2) Enil => - add_case4 e1 n2 - | Eop (Oaddimm n2) (t2:::Enil) => - add_case5 e1 n2 t2 - | e2 => - add_default e1 e2 - end. - -Definition add_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return add_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - add_case1 n1 t2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => - add_case2 n1 t1 n2 t2 - | Eop(Oaddimm n1) (t1:::Enil), t2 => - add_case3 n1 t1 t2 - | e1, e2 => - add_match_aux e1 e2 - end. - -Definition add (e1: expr) (e2: expr) := - match add_match e1 e2 with - | add_case1 n1 t2 => - addimm n1 t2 - | add_case2 n1 t1 n2 t2 => - addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | add_case3 n1 t1 t2 => - addimm n1 (Eop Oadd (t1:::t2:::Enil)) - | add_case4 t1 n2 => - addimm n2 t1 - | add_case5 t1 n2 t2 => - addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | add_default e1 e2 => - Eop Oadd (e1:::e2:::Enil) - end. - -(** ** Integer and pointer subtraction *) - -(* -Definition sub (e1: expr) (e2: expr) := - match e1, e2 with - | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm -(intsub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | Eop (Oaddimm n1) (t1:::Enil), t2 => addimm n1 (Eop Osub (t1:::t2:::Rni -l)) - | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1::: -:t2:::Enil)) - | _, _ => Eop Osub (e1:::e2:::Enil) - end. -*) - -Inductive sub_cases: forall (e1: expr) (e2: expr), Set := - | sub_case1: - forall (t1: expr) (n2: int), - sub_cases (t1) (Eop (Ointconst n2) Enil) - | sub_case2: - forall (n1: int) (t1: expr) (n2: int) (t2: expr), - sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) - | sub_case3: - forall (n1: int) (t1: expr) (t2: expr), - sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) - | sub_case4: - forall (t1: expr) (n2: int) (t2: expr), - sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | sub_default: - forall (e1: expr) (e2: expr), - sub_cases e1 e2. - -Definition sub_match_aux (e1: expr) (e2: expr) := - match e1 as z1 return sub_cases z1 e2 with - | Eop (Oaddimm n1) (t1:::Enil) => - sub_case3 n1 t1 e2 - | e1 => - sub_default e1 e2 - end. - -Definition sub_match (e1: expr) (e2: expr) := - match e2 as z2, e1 as z1 return sub_cases z1 z2 with - | Eop (Ointconst n2) Enil, t1 => - sub_case1 t1 n2 - | Eop (Oaddimm n2) (t2:::Enil), Eop (Oaddimm n1) (t1:::Enil) => - sub_case2 n1 t1 n2 t2 - | Eop (Oaddimm n2) (t2:::Enil), t1 => - sub_case4 t1 n2 t2 - | e2, e1 => - sub_match_aux e1 e2 - end. - -Definition sub (e1: expr) (e2: expr) := - match sub_match e1 e2 with - | sub_case1 t1 n2 => - addimm (Int.neg n2) t1 - | sub_case2 n1 t1 n2 t2 => - addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | sub_case3 n1 t1 t2 => - addimm n1 (Eop Osub (t1:::t2:::Enil)) - | sub_case4 t1 n2 t2 => - addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | sub_default e1 e2 => - Eop Osub (e1:::e2:::Enil) - end. - -(** ** Rotates and immediate shifts *) - -(* -Definition rolm (e1: expr) := - match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil - | Eop (Orolm amount1 mask1) (t1:::Enil) => - let amount := Int.and (Int.add amount1 amount2) Ox1Fl in - let mask := Int.and (Int.rol mask1 amount2) mask2 in - if Int.is_rlw_mask mask - then Eop (Orolm amount mask) (t1:::Enil) - else Eop (Orolm amount2 mask2) (e1:::Enil) - | _ => Eop (Orolm amount2 mask2) (e1:::Enil) - end -*) - -Inductive rolm_cases: forall (e1: expr), Set := - | rolm_case1: - forall (n1: int), - rolm_cases (Eop (Ointconst n1) Enil) - | rolm_case2: - forall (amount1: int) (mask1: int) (t1: expr), - rolm_cases (Eop (Orolm amount1 mask1) (t1:::Enil)) - | rolm_default: - forall (e1: expr), - rolm_cases e1. - -Definition rolm_match (e1: expr) := - match e1 as z1 return rolm_cases z1 with - | Eop (Ointconst n1) Enil => - rolm_case1 n1 - | Eop (Orolm amount1 mask1) (t1:::Enil) => - rolm_case2 amount1 mask1 t1 - | e1 => - rolm_default e1 - end. - -Definition rolm (e1: expr) (amount2 mask2: int) := - match rolm_match e1 with - | rolm_case1 n1 => - Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil - | rolm_case2 amount1 mask1 t1 => - let amount := Int.and (Int.add amount1 amount2) (Int.repr 31) in - let mask := Int.and (Int.rol mask1 amount2) mask2 in - if Int.is_rlw_mask mask - then Eop (Orolm amount mask) (t1:::Enil) - else Eop (Orolm amount2 mask2) (e1:::Enil) - | rolm_default e1 => - Eop (Orolm amount2 mask2) (e1:::Enil) - end. - -Definition shlimm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then - e1 - else if Int.ltu n2 (Int.repr 32) then - rolm e1 n2 (Int.shl Int.mone n2) - else - Eop Oshl (e1:::Eop (Ointconst n2) Enil:::Enil). - -Definition shruimm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then - e1 - else if Int.ltu n2 (Int.repr 32) then - rolm e1 (Int.sub (Int.repr 32) n2) (Int.shru Int.mone n2) - else - Eop Oshru (e1:::Eop (Ointconst n2) Enil:::Enil). - -(** ** Integer multiply *) - -Definition mulimm_base (n1: int) (e2: expr) := - match Int.one_bits n1 with - | i :: nil => - shlimm e2 i - | i :: j :: nil => - Elet e2 - (Eop Oadd (shlimm (Eletvar 0) i ::: - shlimm (Eletvar 0) j ::: Enil)) - | _ => - Eop (Omulimm n1) (e2:::Enil) - end. - -(* -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Elet e2 (Eop (Ointconst Int.zero) Enil) - else if Int.eq n1 Int.one then - e2 - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil - | Eop (Oaddimm n2) (t2:::Enil) => addimm (intmul n1 n2) (mulimm_base n1 t2) - | _ => mulimm_base n1 e2 - end. -*) - -Inductive mulimm_cases: forall (e2: expr), Set := - | mulimm_case1: - forall (n2: int), - mulimm_cases (Eop (Ointconst n2) Enil) - | mulimm_case2: - forall (n2: int) (t2: expr), - mulimm_cases (Eop (Oaddimm n2) (t2:::Enil)) - | mulimm_default: - forall (e2: expr), - mulimm_cases e2. - -Definition mulimm_match (e2: expr) := - match e2 as z1 return mulimm_cases z1 with - | Eop (Ointconst n2) Enil => - mulimm_case1 n2 - | Eop (Oaddimm n2) (t2:::Enil) => - mulimm_case2 n2 t2 - | e2 => - mulimm_default e2 - end. - -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Elet e2 (Eop (Ointconst Int.zero) Enil) - else if Int.eq n1 Int.one then - e2 - else match mulimm_match e2 with - | mulimm_case1 n2 => - Eop (Ointconst(Int.mul n1 n2)) Enil - | mulimm_case2 n2 t2 => - addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | mulimm_default e2 => - mulimm_base n1 e2 - end. - -(* -Definition mul (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 - | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 - | _, _ => Eop Omul (e1:::e2:::Enil) - end. -*) - -Inductive mul_cases: forall (e1: expr) (e2: expr), Set := - | mul_case1: - forall (n1: int) (t2: expr), - mul_cases (Eop (Ointconst n1) Enil) (t2) - | mul_case2: - forall (t1: expr) (n2: int), - mul_cases (t1) (Eop (Ointconst n2) Enil) - | mul_default: - forall (e1: expr) (e2: expr), - mul_cases e1 e2. - -Definition mul_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return mul_cases e1 z2 with - | Eop (Ointconst n2) Enil => - mul_case2 e1 n2 - | e2 => - mul_default e1 e2 - end. - -Definition mul_match (e1: expr) (e2: expr) := - match e1 as z1 return mul_cases z1 e2 with - | Eop (Ointconst n1) Enil => - mul_case1 n1 e2 - | e1 => - mul_match_aux e1 e2 - end. - -Definition mul (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - mulimm n1 t2 - | mul_case2 t1 n2 => - mulimm n2 t1 - | mul_default e1 e2 => - Eop Omul (e1:::e2:::Enil) - end. - -(** ** Integer division and modulus *) - -Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). - -Definition mod_aux (divop: operation) (e1 e2: expr) := - Elet e1 - (Elet (lift e2) - (Eop Osub (Eletvar 1 ::: - Eop Omul (Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) ::: - Eletvar 0 ::: - Enil) ::: - Enil))). - -Definition mods := mod_aux Odiv. - -Inductive divu_cases: forall (e2: expr), Set := - | divu_case1: - forall (n2: int), - divu_cases (Eop (Ointconst n2) Enil) - | divu_default: - forall (e2: expr), - divu_cases e2. - -Definition divu_match (e2: expr) := - match e2 as z1 return divu_cases z1 with - | Eop (Ointconst n2) Enil => - divu_case1 n2 - | e2 => - divu_default e2 - end. - -Definition divu (e1: expr) (e2: expr) := - match divu_match e2 with - | divu_case1 n2 => - match Int.is_power2 n2 with - | Some l2 => shruimm e1 l2 - | None => Eop Odivu (e1:::e2:::Enil) - end - | divu_default e2 => - Eop Odivu (e1:::e2:::Enil) - end. - -Definition modu (e1: expr) (e2: expr) := - match divu_match e2 with - | divu_case1 n2 => - match Int.is_power2 n2 with - | Some l2 => rolm e1 Int.zero (Int.sub n2 Int.one) - | None => mod_aux Odivu e1 e2 - end - | divu_default e2 => - mod_aux Odivu e1 e2 - end. - -(** ** Bitwise and, or, xor *) - -Definition andimm (n1: int) (e2: expr) := - if Int.is_rlw_mask n1 - then rolm e2 Int.zero n1 - else Eop (Oandimm n1) (e2:::Enil). - -Definition and (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - andimm n1 t2 - | mul_case2 t1 n2 => - andimm n2 t1 - | mul_default e1 e2 => - Eop Oand (e1:::e2:::Enil) - end. - -Definition same_expr_pure (e1 e2: expr) := - match e1, e2 with - | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false - | _, _ => false - end. - -Inductive or_cases: forall (e1: expr) (e2: expr), Set := - | or_case1: - forall (amount1: int) (mask1: int) (t1: expr) - (amount2: int) (mask2: int) (t2: expr), - or_cases (Eop (Orolm amount1 mask1) (t1:::Enil)) - (Eop (Orolm amount2 mask2) (t2:::Enil)) - | or_default: - forall (e1: expr) (e2: expr), - or_cases e1 e2. - -Definition or_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return or_cases z1 z2 with - | Eop (Orolm amount1 mask1) (t1:::Enil), - Eop (Orolm amount2 mask2) (t2:::Enil) => - or_case1 amount1 mask1 t1 amount2 mask2 t2 - | e1, e2 => - or_default e1 e2 - end. - -Definition or (e1: expr) (e2: expr) := - match or_match e1 e2 with - | or_case1 amount1 mask1 t1 amount2 mask2 t2 => - if Int.eq amount1 amount2 - && Int.is_rlw_mask (Int.or mask1 mask2) - && same_expr_pure t1 t2 - then Eop (Orolm amount1 (Int.or mask1 mask2)) (t1:::Enil) - else Eop Oor (e1:::e2:::Enil) - | or_default e1 e2 => - Eop Oor (e1:::e2:::Enil) - end. - -(** ** General shifts *) - -Inductive shift_cases: forall (e1: expr), Set := - | shift_case1: - forall (n2: int), - shift_cases (Eop (Ointconst n2) Enil) - | shift_default: - forall (e1: expr), - shift_cases e1. - -Definition shift_match (e1: expr) := - match e1 as z1 return shift_cases z1 with - | Eop (Ointconst n2) Enil => - shift_case1 n2 - | e1 => - shift_default e1 - end. - -Definition shl (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shlimm e1 n2 - | shift_default e2 => - Eop Oshl (e1:::e2:::Enil) - end. - -Definition shru (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shruimm e1 n2 - | shift_default e2 => - Eop Oshru (e1:::e2:::Enil) - end. - -(** ** Floating-point arithmetic *) - -Parameter use_fused_mul : unit -> bool. - -(* -Definition addf (e1: expr) (e2: expr) := - match e1, e2 with - | Eop Omulf (t1:::t2:::Enil), t3 => Eop Omuladdf (t1:::t2:::t3:::Enil) - | t1, Eop Omulf (t2:::t3:::Enil) => Elet t1 (Eop Omuladdf (t2:::t3:::Rvar 0:::Enil)) - | _, _ => Eop Oaddf (e1:::e2:::Enil) - end. -*) - -Inductive addf_cases: forall (e1: expr) (e2: expr), Set := - | addf_case1: - forall (t1: expr) (t2: expr) (t3: expr), - addf_cases (Eop Omulf (t1:::t2:::Enil)) (t3) - | addf_case2: - forall (t1: expr) (t2: expr) (t3: expr), - addf_cases (t1) (Eop Omulf (t2:::t3:::Enil)) - | addf_default: - forall (e1: expr) (e2: expr), - addf_cases e1 e2. - -Definition addf_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return addf_cases e1 z2 with - | Eop Omulf (t2:::t3:::Enil) => - addf_case2 e1 t2 t3 - | e2 => - addf_default e1 e2 - end. - -Definition addf_match (e1: expr) (e2: expr) := - match e1 as z1 return addf_cases z1 e2 with - | Eop Omulf (t1:::t2:::Enil) => - addf_case1 t1 t2 e2 - | e1 => - addf_match_aux e1 e2 - end. - -Definition addf (e1: expr) (e2: expr) := - if use_fused_mul tt then - match addf_match e1 e2 with - | addf_case1 t1 t2 t3 => - Eop Omuladdf (t1:::t2:::t3:::Enil) - | addf_case2 t1 t2 t3 => - Eop Omuladdf (t2:::t3:::t1:::Enil) - | addf_default e1 e2 => - Eop Oaddf (e1:::e2:::Enil) - end - else Eop Oaddf (e1:::e2:::Enil). - -(* -Definition subf (e1: expr) (e2: expr) := - match e1, e2 with - | Eop Omulfloat (t1:::t2:::Enil), t3 => Eop Omulsubf (t1:::t2:::t3:::Enil) - | _, _ => Eop Osubf (e1:::e2:::Enil) - end. -*) - -Inductive subf_cases: forall (e1: expr) (e2: expr), Set := - | subf_case1: - forall (t1: expr) (t2: expr) (t3: expr), - subf_cases (Eop Omulf (t1:::t2:::Enil)) (t3) - | subf_default: - forall (e1: expr) (e2: expr), - subf_cases e1 e2. - -Definition subf_match (e1: expr) (e2: expr) := - match e1 as z1 return subf_cases z1 e2 with - | Eop Omulf (t1:::t2:::Enil) => - subf_case1 t1 t2 e2 - | e1 => - subf_default e1 e2 - end. - -Definition subf (e1: expr) (e2: expr) := - if use_fused_mul tt then - match subf_match e1 e2 with - | subf_case1 t1 t2 t3 => - Eop Omulsubf (t1:::t2:::t3:::Enil) - | subf_default e1 e2 => - Eop Osubf (e1:::e2:::Enil) - end - else Eop Osubf (e1:::e2:::Enil). - -(** ** Truncations and sign extensions *) - -Inductive cast8signed_cases: forall (e1: expr), Set := - | cast8signed_case1: - forall (e2: expr), - cast8signed_cases (Eop Ocast8signed (e2 ::: Enil)) - | cast8signed_default: - forall (e1: expr), - cast8signed_cases e1. - -Definition cast8signed_match (e1: expr) := - match e1 as z1 return cast8signed_cases z1 with - | Eop Ocast8signed (e2 ::: Enil) => - cast8signed_case1 e2 - | e1 => - cast8signed_default e1 - end. - -Definition cast8signed (e: expr) := - match cast8signed_match e with - | cast8signed_case1 e1 => e - | cast8signed_default e1 => Eop Ocast8signed (e1 ::: Enil) - end. - -Inductive cast8unsigned_cases: forall (e1: expr), Set := - | cast8unsigned_case1: - forall (e2: expr), - cast8unsigned_cases (Eop Ocast8unsigned (e2 ::: Enil)) - | cast8unsigned_default: - forall (e1: expr), - cast8unsigned_cases e1. - -Definition cast8unsigned_match (e1: expr) := - match e1 as z1 return cast8unsigned_cases z1 with - | Eop Ocast8unsigned (e2 ::: Enil) => - cast8unsigned_case1 e2 - | e1 => - cast8unsigned_default e1 - end. - -Definition cast8unsigned (e: expr) := - match cast8unsigned_match e with - | cast8unsigned_case1 e1 => e - | cast8unsigned_default e1 => Eop Ocast8unsigned (e1 ::: Enil) - end. - -Inductive cast16signed_cases: forall (e1: expr), Set := - | cast16signed_case1: - forall (e2: expr), - cast16signed_cases (Eop Ocast16signed (e2 ::: Enil)) - | cast16signed_default: - forall (e1: expr), - cast16signed_cases e1. - -Definition cast16signed_match (e1: expr) := - match e1 as z1 return cast16signed_cases z1 with - | Eop Ocast16signed (e2 ::: Enil) => - cast16signed_case1 e2 - | e1 => - cast16signed_default e1 - end. - -Definition cast16signed (e: expr) := - match cast16signed_match e with - | cast16signed_case1 e1 => e - | cast16signed_default e1 => Eop Ocast16signed (e1 ::: Enil) - end. - -Inductive cast16unsigned_cases: forall (e1: expr), Set := - | cast16unsigned_case1: - forall (e2: expr), - cast16unsigned_cases (Eop Ocast16unsigned (e2 ::: Enil)) - | cast16unsigned_default: - forall (e1: expr), - cast16unsigned_cases e1. - -Definition cast16unsigned_match (e1: expr) := - match e1 as z1 return cast16unsigned_cases z1 with - | Eop Ocast16unsigned (e2 ::: Enil) => - cast16unsigned_case1 e2 - | e1 => - cast16unsigned_default e1 - end. - -Definition cast16unsigned (e: expr) := - match cast16unsigned_match e with - | cast16unsigned_case1 e1 => e - | cast16unsigned_default e1 => Eop Ocast16unsigned (e1 ::: Enil) - end. - -Inductive singleoffloat_cases: forall (e1: expr), Set := - | singleoffloat_case1: - forall (e2: expr), - singleoffloat_cases (Eop Osingleoffloat (e2 ::: Enil)) - | singleoffloat_default: - forall (e1: expr), - singleoffloat_cases e1. - -Definition singleoffloat_match (e1: expr) := - match e1 as z1 return singleoffloat_cases z1 with - | Eop Osingleoffloat (e2 ::: Enil) => - singleoffloat_case1 e2 - | e1 => - singleoffloat_default e1 - end. - -Definition singleoffloat (e: expr) := - match singleoffloat_match e with - | singleoffloat_case1 e1 => e - | singleoffloat_default e1 => Eop Osingleoffloat (e1 ::: Enil) - end. - -(** ** Comparisons *) - -Inductive comp_cases: forall (e1: expr) (e2: expr), Set := - | comp_case1: - forall n1 t2, - comp_cases (Eop (Ointconst n1) Enil) (t2) - | comp_case2: - forall t1 n2, - comp_cases (t1) (Eop (Ointconst n2) Enil) - | comp_default: - forall (e1: expr) (e2: expr), - comp_cases e1 e2. - -Definition comp_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return comp_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - comp_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => - comp_case2 t1 n2 - | e1, e2 => - comp_default e1 e2 - end. - -Definition comp (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => - Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil) - | comp_case2 t1 n2 => - Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil) - | comp_default e1 e2 => - Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) - end. - -Definition compu (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => - Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil) - | comp_case2 t1 n2 => - Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil) - | comp_default e1 e2 => - Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) - end. - -Definition compf (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). - -(** ** Conditional expressions *) - -Fixpoint negate_condexpr (e: condexpr): condexpr := - match e with - | CEtrue => CEfalse - | CEfalse => CEtrue - | CEcond c el => CEcond (negate_condition c) el - | CEcondition e1 e2 e3 => - CEcondition e1 (negate_condexpr e2) (negate_condexpr e3) - end. - - -Definition is_compare_neq_zero (c: condition) : bool := - match c with - | Ccompimm Cne n => Int.eq n Int.zero - | Ccompuimm Cne n => Int.eq n Int.zero - | _ => false - end. - -Definition is_compare_eq_zero (c: condition) : bool := - match c with - | Ccompimm Ceq n => Int.eq n Int.zero - | Ccompuimm Ceq n => Int.eq n Int.zero - | _ => false - end. - -Fixpoint condexpr_of_expr (e: expr) : condexpr := - match e with - | Eop (Ointconst n) Enil => - if Int.eq n Int.zero then CEfalse else CEtrue - | Eop (Ocmp c) (e1 ::: Enil) => - if is_compare_neq_zero c then - condexpr_of_expr e1 - else if is_compare_eq_zero c then - negate_condexpr (condexpr_of_expr e1) - else - CEcond c (e1 ::: Enil) - | Eop (Ocmp c) el => - CEcond c el - | Econdition ce e1 e2 => - CEcondition ce (condexpr_of_expr e1) (condexpr_of_expr e2) - | _ => - CEcond (Ccompimm Cne Int.zero) (e:::Enil) - end. - -(** ** Recognition of addressing modes for load and store operations *) - -(* -Definition addressing (e: expr) := - match e with - | Eop (Oaddrsymbol s n) Enil => (Aglobal s n, Enil) - | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) - | Eop Oadd (Eop (Oaddrsymbol s n) Enil) e2 => (Abased(s, n), e2:::Enil) - | Eop (Oaddimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) - | Eop Oadd (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) - | _ => (Aindexed Int.zero, e:::Enil) - end. -*) - -Inductive addressing_cases: forall (e: expr), Set := - | addressing_case1: - forall (s: ident) (n: int), - addressing_cases (Eop (Oaddrsymbol s n) Enil) - | addressing_case2: - forall (n: int), - addressing_cases (Eop (Oaddrstack n) Enil) - | addressing_case3: - forall (s: ident) (n: int) (e2: expr), - addressing_cases - (Eop Oadd (Eop (Oaddrsymbol s n) Enil:::e2:::Enil)) - | addressing_case4: - forall (n: int) (e1: expr), - addressing_cases (Eop (Oaddimm n) (e1:::Enil)) - | addressing_case5: - forall (e1: expr) (e2: expr), - addressing_cases (Eop Oadd (e1:::e2:::Enil)) - | addressing_default: - forall (e: expr), - addressing_cases e. - -Definition addressing_match (e: expr) := - match e as z1 return addressing_cases z1 with - | Eop (Oaddrsymbol s n) Enil => - addressing_case1 s n - | Eop (Oaddrstack n) Enil => - addressing_case2 n - | Eop Oadd (Eop (Oaddrsymbol s n) Enil:::e2:::Enil) => - addressing_case3 s n e2 - | Eop (Oaddimm n) (e1:::Enil) => - addressing_case4 n e1 - | Eop Oadd (e1:::e2:::Enil) => - addressing_case5 e1 e2 - | e => - addressing_default e - end. - -Definition addressing (e: expr) := - match addressing_match e with - | addressing_case1 s n => - (Aglobal s n, Enil) - | addressing_case2 n => - (Ainstack n, Enil) - | addressing_case3 s n e2 => - (Abased s n, e2:::Enil) - | addressing_case4 n e1 => - (Aindexed n, e1:::Enil) - | addressing_case5 e1 e2 => - (Aindexed2, e1:::e2:::Enil) - | addressing_default e => - (Aindexed Int.zero, e:::Enil) - end. - -Definition load (chunk: memory_chunk) (e1: expr) := - match addressing e1 with - | (mode, args) => Eload chunk mode args - end. - -Definition store (chunk: memory_chunk) (e1 e2: expr) := - match addressing e1 with - | (mode, args) => Sstore chunk mode args e2 - end. - -(** * Translation from Cminor to CminorSel *) - -(** Instruction selection for operator applications *) - -Definition sel_constant (cst: Cminor.constant) : expr := - match cst with - | Cminor.Ointconst n => Eop (Ointconst n) Enil - | Cminor.Ofloatconst f => Eop (Ofloatconst f) Enil - | Cminor.Oaddrsymbol id ofs => Eop (Oaddrsymbol id ofs) Enil - | Cminor.Oaddrstack ofs => Eop (Oaddrstack ofs) Enil - end. - -Definition sel_unop (op: Cminor.unary_operation) (arg: expr) : expr := - match op with - | Cminor.Ocast8unsigned => cast8unsigned arg - | Cminor.Ocast8signed => cast8signed arg - | Cminor.Ocast16unsigned => cast16unsigned arg - | Cminor.Ocast16signed => cast16signed arg - | Cminor.Onegint => Eop (Osubimm Int.zero) (arg ::: Enil) - | Cminor.Onotbool => notbool arg - | Cminor.Onotint => notint arg - | Cminor.Onegf => Eop Onegf (arg ::: Enil) - | Cminor.Oabsf => Eop Oabsf (arg ::: Enil) - | Cminor.Osingleoffloat => singleoffloat arg - | Cminor.Ointoffloat => Eop Ointoffloat (arg ::: Enil) - | Cminor.Ointuoffloat => Eop Ointuoffloat (arg ::: Enil) - | Cminor.Ofloatofint => Eop Ofloatofint (arg ::: Enil) - | Cminor.Ofloatofintu => Eop Ofloatofintu (arg ::: Enil) - end. - -Definition sel_binop (op: Cminor.binary_operation) (arg1 arg2: expr) : expr := - match op with - | Cminor.Oadd => add arg1 arg2 - | Cminor.Osub => sub arg1 arg2 - | Cminor.Omul => mul arg1 arg2 - | Cminor.Odiv => divs arg1 arg2 - | Cminor.Odivu => divu arg1 arg2 - | Cminor.Omod => mods arg1 arg2 - | Cminor.Omodu => modu arg1 arg2 - | Cminor.Oand => and arg1 arg2 - | Cminor.Oor => or arg1 arg2 - | Cminor.Oxor => Eop Oxor (arg1 ::: arg2 ::: Enil) - | Cminor.Oshl => shl arg1 arg2 - | Cminor.Oshr => Eop Oshr (arg1 ::: arg2 ::: Enil) - | Cminor.Oshru => shru arg1 arg2 - | Cminor.Oaddf => addf arg1 arg2 - | Cminor.Osubf => subf arg1 arg2 - | Cminor.Omulf => Eop Omulf (arg1 ::: arg2 ::: Enil) - | Cminor.Odivf => Eop Odivf (arg1 ::: arg2 ::: Enil) - | Cminor.Ocmp c => comp c arg1 arg2 - | Cminor.Ocmpu c => compu c arg1 arg2 - | Cminor.Ocmpf c => compf c arg1 arg2 - end. - -(** Conversion from Cminor expression to Cminorsel expressions *) - -Fixpoint sel_expr (a: Cminor.expr) : expr := - match a with - | Cminor.Evar id => Evar id - | Cminor.Econst cst => sel_constant cst - | Cminor.Eunop op arg => sel_unop op (sel_expr arg) - | Cminor.Ebinop op arg1 arg2 => sel_binop op (sel_expr arg1) (sel_expr arg2) - | Cminor.Eload chunk addr => load chunk (sel_expr addr) - | Cminor.Econdition cond ifso ifnot => - Econdition (condexpr_of_expr (sel_expr cond)) - (sel_expr ifso) (sel_expr ifnot) - end. - -Fixpoint sel_exprlist (al: list Cminor.expr) : exprlist := - match al with - | nil => Enil - | a :: bl => Econs (sel_expr a) (sel_exprlist bl) - end. - -(** Conversion from Cminor statements to Cminorsel statements. *) - -Fixpoint sel_stmt (s: Cminor.stmt) : stmt := - match s with - | Cminor.Sskip => Sskip - | Cminor.Sassign id e => Sassign id (sel_expr e) - | Cminor.Sstore chunk addr rhs => store chunk (sel_expr addr) (sel_expr rhs) - | Cminor.Scall optid sg fn args => - Scall optid sg (sel_expr fn) (sel_exprlist args) - | Cminor.Stailcall sg fn args => - Stailcall sg (sel_expr fn) (sel_exprlist args) - | Cminor.Salloc id b => Salloc id (sel_expr b) - | Cminor.Sseq s1 s2 => Sseq (sel_stmt s1) (sel_stmt s2) - | Cminor.Sifthenelse e ifso ifnot => - Sifthenelse (condexpr_of_expr (sel_expr e)) - (sel_stmt ifso) (sel_stmt ifnot) - | Cminor.Sloop body => Sloop (sel_stmt body) - | Cminor.Sblock body => Sblock (sel_stmt body) - | Cminor.Sexit n => Sexit n - | Cminor.Sswitch e cases dfl => Sswitch (sel_expr e) cases dfl - | Cminor.Sreturn None => Sreturn None - | Cminor.Sreturn (Some e) => Sreturn (Some (sel_expr e)) - | Cminor.Slabel lbl body => Slabel lbl (sel_stmt body) - | Cminor.Sgoto lbl => Sgoto lbl - end. - -(** Conversion of functions and programs. *) - -Definition sel_function (f: Cminor.function) : function := - mkfunction - f.(Cminor.fn_sig) - f.(Cminor.fn_params) - f.(Cminor.fn_vars) - f.(Cminor.fn_stackspace) - (sel_stmt f.(Cminor.fn_body)). - -Definition sel_fundef (f: Cminor.fundef) : fundef := - transf_fundef sel_function f. - -Definition sel_program (p: Cminor.program) : program := - transform_program sel_fundef p. - - - diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v deleted file mode 100644 index 6d629794..00000000 --- a/backend/Selectionproof.v +++ /dev/null @@ -1,1398 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness of instruction selection *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. -Require Import Selection. - -Open Local Scope selection_scope. - -Section CMCONSTR. - -Variable ge: genv. -Variable sp: val. -Variable e: env. -Variable m: mem. - -(** * Lifting of let-bound variables *) - -Inductive insert_lenv: letenv -> nat -> val -> letenv -> Prop := - | insert_lenv_0: - forall le v, - insert_lenv le O v (v :: le) - | insert_lenv_S: - forall le p w le' v, - insert_lenv le p w le' -> - insert_lenv (v :: le) (S p) w (v :: le'). - -Lemma insert_lenv_lookup1: - forall le p w le', - insert_lenv le p w le' -> - forall n v, - nth_error le n = Some v -> (p > n)%nat -> - nth_error le' n = Some v. -Proof. - induction 1; intros. - omegaContradiction. - destruct n; simpl; simpl in H0. auto. - apply IHinsert_lenv. auto. omega. -Qed. - -Lemma insert_lenv_lookup2: - forall le p w le', - insert_lenv le p w le' -> - forall n v, - nth_error le n = Some v -> (p <= n)%nat -> - nth_error le' (S n) = Some v. -Proof. - induction 1; intros. - simpl. assumption. - simpl. destruct n. omegaContradiction. - apply IHinsert_lenv. exact H0. omega. -Qed. - -Hint Resolve eval_Evar eval_Eop eval_Eload eval_Econdition - eval_Elet eval_Eletvar - eval_CEtrue eval_CEfalse eval_CEcond - eval_CEcondition eval_Enil eval_Econs: evalexpr. - -Lemma eval_lift_expr: - forall w le a v, - eval_expr ge sp e m le a v -> - forall p le', insert_lenv le p w le' -> - eval_expr ge sp e m le' (lift_expr p a) v. -Proof. - intro w. - apply (eval_expr_ind3 ge sp e m - (fun le a v => - forall p le', insert_lenv le p w le' -> - eval_expr ge sp e m le' (lift_expr p a) v) - (fun le a v => - forall p le', insert_lenv le p w le' -> - eval_condexpr ge sp e m le' (lift_condexpr p a) v) - (fun le al vl => - forall p le', insert_lenv le p w le' -> - eval_exprlist ge sp e m le' (lift_exprlist p al) vl)); - simpl; intros; eauto with evalexpr. - - destruct v1; eapply eval_Econdition; - eauto with evalexpr; simpl; eauto with evalexpr. - - eapply eval_Elet. eauto. apply H2. apply insert_lenv_S; auto. - - case (le_gt_dec p n); intro. - apply eval_Eletvar. eapply insert_lenv_lookup2; eauto. - apply eval_Eletvar. eapply insert_lenv_lookup1; eauto. - - destruct vb1; eapply eval_CEcondition; - eauto with evalexpr; simpl; eauto with evalexpr. -Qed. - -Lemma eval_lift: - forall le a v w, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m (w::le) (lift a) v. -Proof. - intros. unfold lift. eapply eval_lift_expr. - eexact H. apply insert_lenv_0. -Qed. - -Hint Resolve eval_lift: evalexpr. - -(** * Useful lemmas and tactics *) - -(** The following are trivial lemmas and custom tactics that help - perform backward (inversion) and forward reasoning over the evaluation - of operator applications. *) - -Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. - -Ltac TrivialOp cstr := unfold cstr; intros; EvalOp. - -Ltac InvEval1 := - match goal with - | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] => - inv H; InvEval1 - | _ => - idtac - end. - -Ltac InvEval2 := - match goal with - | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => - simpl in H; inv H - | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | _ => - idtac - end. - -Ltac InvEval := InvEval1; InvEval2; InvEval2. - -(** * Correctness of the smart constructors *) - -(** We now show that the code generated by "smart constructor" functions - such as [Selection.notint] behaves as expected. Continuing the - [notint] example, we show that if the expression [e] - evaluates to some integer value [Vint n], then [Selection.notint e] - evaluates to a value [Vint (Int.not n)] which is indeed the integer - negation of the value of [e]. - - All proofs follow a common pattern: -- Reasoning by case over the result of the classification functions - (such as [add_match] for integer addition), gathering additional - information on the shape of the argument expressions in the non-default - cases. -- Inversion of the evaluations of the arguments, exploiting the additional - information thus gathered. -- Equational reasoning over the arithmetic operations performed, - using the lemmas from the [Int] and [Float] modules. -- Construction of an evaluation derivation for the expression returned - by the smart constructor. -*) - -Theorem eval_notint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (notint a) (Vint (Int.not x)). -Proof. - unfold notint; intros until x; case (notint_match a); intros; InvEval. - EvalOp. simpl. congruence. - EvalOp. simpl. congruence. - EvalOp. simpl. congruence. - eapply eval_Elet. eexact H. - eapply eval_Eop. - eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity. - eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity. - apply eval_Enil. - simpl. rewrite Int.or_idem. auto. -Qed. - -Lemma eval_notbool_base: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)). -Proof. - TrivialOp notbool_base. simpl. - inv H0. - rewrite Int.eq_false; auto. - rewrite Int.eq_true; auto. - reflexivity. -Qed. - -Hint Resolve Val.bool_of_true_val Val.bool_of_false_val - Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof. - -Theorem eval_notbool: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)). -Proof. - induction a; simpl; intros; try (eapply eval_notbool_base; eauto). - destruct o; try (eapply eval_notbool_base; eauto). - - destruct e0. InvEval. - inv H0. rewrite Int.eq_false; auto. - simpl; eauto with evalexpr. - rewrite Int.eq_true; simpl; eauto with evalexpr. - eapply eval_notbool_base; eauto. - - inv H. eapply eval_Eop; eauto. - simpl. assert (eval_condition c vl m = Some b). - generalize H6. simpl. - case (eval_condition c vl m); intros. - destruct b0; inv H1; inversion H0; auto; congruence. - congruence. - rewrite (Op.eval_negate_condition _ _ _ H). - destruct b; reflexivity. - - inv H. eapply eval_Econdition; eauto. - destruct v1; eauto. -Qed. - -Theorem eval_addimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (addimm n a) (Vint (Int.add x n)). -Proof. - unfold addimm; intros until x. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval; EvalOp; simpl. - rewrite Int.add_commut. auto. - destruct (Genv.find_symbol ge s); discriminate. - destruct sp; simpl in H1; discriminate. - subst x. rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut. -Qed. - -Theorem eval_addimm_ptr: - forall le n a b ofs, - eval_expr ge sp e m le a (Vptr b ofs) -> - eval_expr ge sp e m le (addimm n a) (Vptr b (Int.add ofs n)). -Proof. - unfold addimm; intros until ofs. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros; InvEval; EvalOp; simpl. - destruct (Genv.find_symbol ge s). - rewrite Int.add_commut. congruence. - discriminate. - destruct sp; simpl in H1; try discriminate. - inv H1. simpl. decEq. decEq. - rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. rewrite (Int.add_commut n m0). rewrite Int.add_assoc. auto. -Qed. - -Theorem eval_add: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vint (Int.add x y)). -Proof. - intros until y. - unfold add; case (add_match a b); intros; InvEval. - rewrite Int.add_commut. apply eval_addimm. auto. - replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - replace (Int.add x y) with (Int.add (Int.add i y) n1). - apply eval_addimm. EvalOp. - subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - apply eval_addimm. auto. - replace (Int.add x y) with (Int.add (Int.add x i) n2). - apply eval_addimm. EvalOp. - subst y. rewrite Int.add_assoc. auto. - EvalOp. -Qed. - -Theorem eval_add_ptr: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - replace (Int.add x y) with (Int.add (Int.add i y) n1). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - apply eval_addimm_ptr. auto. - replace (Int.add x y) with (Int.add (Int.add x i) n2). - apply eval_addimm_ptr. EvalOp. - subst y. rewrite Int.add_assoc. auto. - EvalOp. -Qed. - -Theorem eval_add_ptr_2: - forall le a b x p y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - apply eval_addimm_ptr. auto. - replace (Int.add y x) with (Int.add (Int.add i i0) (Int.add n1 n2)). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. - rewrite (Int.add_commut n1 n2). apply Int.add_permut. - replace (Int.add y x) with (Int.add (Int.add y i) n1). - apply eval_addimm_ptr. EvalOp. - subst x. repeat rewrite Int.add_assoc. auto. - replace (Int.add y x) with (Int.add (Int.add i x) n2). - apply eval_addimm_ptr. EvalOp. subst b0; reflexivity. - subst y. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - EvalOp. -Qed. - -Theorem eval_sub: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm. assumption. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. -Qed. - -Theorem eval_sub_ptr_int: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm_ptr. assumption. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm_ptr. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm_ptr. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm_ptr. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. -Qed. - -Theorem eval_sub_ptr_ptr: - forall le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - simpl; unfold eq_block. subst b0; subst b1; rewrite zeq_true. auto. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst x. rewrite Int.sub_add_l. auto. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. simpl. unfold eq_block. rewrite zeq_true. auto. -Qed. - -Lemma eval_rolm: - forall le a amount mask x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (rolm a amount mask) (Vint (Int.rolm x amount mask)). -Proof. - intros until x. unfold rolm; case (rolm_match a); intros; InvEval. - eauto with evalexpr. - case (Int.is_rlw_mask (Int.and (Int.rol mask1 amount) mask)). - EvalOp. simpl. subst x. - decEq. decEq. - replace (Int.and (Int.add amount1 amount) (Int.repr 31)) - with (Int.modu (Int.add amount1 amount) (Int.repr 32)). - symmetry. apply Int.rolm_rolm. - change (Int.repr 31) with (Int.sub (Int.repr 32) Int.one). - apply Int.modu_and with (Int.repr 5). reflexivity. - EvalOp. econstructor. EvalOp. simpl. rewrite H. reflexivity. constructor. auto. - EvalOp. -Qed. - -Theorem eval_shlimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n (Int.repr 32) = true -> - eval_expr ge sp e m le (shlimm a n) (Vint (Int.shl x n)). -Proof. - intros. unfold shlimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.shl_zero. auto. - rewrite H0. - replace (Int.shl x n) with (Int.rolm x n (Int.shl Int.mone n)). - apply eval_rolm. auto. symmetry. apply Int.shl_rolm. exact H0. -Qed. - -Theorem eval_shruimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n (Int.repr 32) = true -> - eval_expr ge sp e m le (shruimm a n) (Vint (Int.shru x n)). -Proof. - intros. unfold shruimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.shru_zero. auto. - rewrite H0. - replace (Int.shru x n) with (Int.rolm x (Int.sub (Int.repr 32) n) (Int.shru Int.mone n)). - apply eval_rolm. auto. symmetry. apply Int.shru_rolm. exact H0. -Qed. - -Lemma eval_mulimm_base: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm_base n a) (Vint (Int.mul x n)). -Proof. - intros; unfold mulimm_base. - generalize (Int.one_bits_decomp n). - generalize (Int.one_bits_range n). - change (Z_of_nat wordsize) with 32. - destruct (Int.one_bits n). - intros. EvalOp. - destruct l. - intros. rewrite H1. simpl. - rewrite Int.add_zero. rewrite <- Int.shl_mul. - apply eval_shlimm. auto. auto with coqlib. - destruct l. - intros. apply eval_Elet with (Vint x). auto. - rewrite H1. simpl. rewrite Int.add_zero. - rewrite Int.mul_add_distr_r. - rewrite <- Int.shl_mul. - rewrite <- Int.shl_mul. - EvalOp. eapply eval_Econs. - apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. - auto with coqlib. - eapply eval_Econs. - apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. - auto with coqlib. - auto with evalexpr. - reflexivity. - intros. EvalOp. -Qed. - -Theorem eval_mulimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm n a) (Vint (Int.mul x n)). -Proof. - intros until x; unfold mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.mul_zero. - intro. eapply eval_Elet; eauto with evalexpr. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro. - subst n. rewrite Int.mul_one. auto. - case (mulimm_match a); intros; InvEval. - EvalOp. rewrite Int.mul_commut. reflexivity. - replace (Int.mul x n) with (Int.add (Int.mul i n) (Int.mul n n2)). - apply eval_addimm. apply eval_mulimm_base. auto. - subst x. rewrite Int.mul_add_distr_l. decEq. apply Int.mul_commut. - apply eval_mulimm_base. assumption. -Qed. - -Theorem eval_mul: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)). -Proof. - intros until y. - unfold mul; case (mul_match a b); intros; InvEval. - rewrite Int.mul_commut. apply eval_mulimm. auto. - apply eval_mulimm. auto. - EvalOp. -Qed. - -Theorem eval_divs: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divs a b) (Vint (Int.divs x y)). -Proof. - TrivialOp divs. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. -Qed. - -Lemma eval_mod_aux: - forall divop semdivop, - (forall sp x y m, - y <> Int.zero -> - eval_operation ge sp divop (Vint x :: Vint y :: nil) m = - Some (Vint (semdivop x y))) -> - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (mod_aux divop a b) - (Vint (Int.sub x (Int.mul (semdivop x y) y))). -Proof. - intros; unfold mod_aux. - eapply eval_Elet. eexact H0. eapply eval_Elet. - apply eval_lift. eexact H1. - eapply eval_Eop. eapply eval_Econs. - eapply eval_Eletvar. simpl; reflexivity. - eapply eval_Econs. eapply eval_Eop. - eapply eval_Econs. eapply eval_Eop. - eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. - eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. - apply eval_Enil. - apply H. assumption. - eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. - apply eval_Enil. - simpl; reflexivity. apply eval_Enil. - reflexivity. -Qed. - -Theorem eval_mods: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (mods a b) (Vint (Int.mods x y)). -Proof. - intros; unfold mods. - rewrite Int.mods_divs. - eapply eval_mod_aux; eauto. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. -Qed. - -Lemma eval_divu_base: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (Eop Odivu (a ::: b ::: Enil)) (Vint (Int.divu x y)). -Proof. - intros. EvalOp. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. -Qed. - -Theorem eval_divu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)). -Proof. - intros until y. - unfold divu; case (divu_match b); intros; InvEval. - caseEq (Int.is_power2 y). - intros. rewrite (Int.divu_pow2 x y i H0). - apply eval_shruimm. auto. - apply Int.is_power2_range with y. auto. - intros. apply eval_divu_base. auto. EvalOp. auto. - eapply eval_divu_base; eauto. -Qed. - -Theorem eval_modu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)). -Proof. - intros until y; unfold modu; case (divu_match b); intros; InvEval. - caseEq (Int.is_power2 y). - intros. rewrite (Int.modu_and x y i H0). - rewrite <- Int.rolm_zero. apply eval_rolm. auto. - intro. rewrite Int.modu_divu. eapply eval_mod_aux. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. - auto. EvalOp. auto. auto. - rewrite Int.modu_divu. eapply eval_mod_aux. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. auto. auto. auto. auto. -Qed. - -Theorem eval_andimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (andimm n a) (Vint (Int.and x n)). -Proof. - intros. unfold andimm. case (Int.is_rlw_mask n). - rewrite <- Int.rolm_zero. apply eval_rolm; auto. - EvalOp. -Qed. - -Theorem eval_and: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (and a b) (Vint (Int.and x y)). -Proof. - intros until y; unfold and; case (mul_match a b); intros; InvEval. - rewrite Int.and_commut. apply eval_andimm; auto. - apply eval_andimm; auto. - EvalOp. -Qed. - -Remark eval_same_expr: - forall a1 a2 le v1 v2, - same_expr_pure a1 a2 = true -> - eval_expr ge sp e m le a1 v1 -> - eval_expr ge sp e m le a2 v2 -> - a1 = a2 /\ v1 = v2. -Proof. - intros until v2. - destruct a1; simpl; try (intros; discriminate). - destruct a2; simpl; try (intros; discriminate). - case (ident_eq i i0); intros. - subst i0. inversion H0. inversion H1. split. auto. congruence. - discriminate. -Qed. - -Lemma eval_or: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (or a b) (Vint (Int.or x y)). -Proof. - intros until y; unfold or; case (or_match a b); intros; InvEval. - caseEq (Int.eq amount1 amount2 - && Int.is_rlw_mask (Int.or mask1 mask2) - && same_expr_pure t1 t2); intro. - destruct (andb_prop _ _ H1). destruct (andb_prop _ _ H4). - generalize (Int.eq_spec amount1 amount2). rewrite H6. intro. subst amount2. - exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. - simpl. EvalOp. simpl. rewrite Int.or_rolm. auto. - simpl. apply eval_Eop with (Vint x :: Vint y :: nil). - econstructor. EvalOp. simpl. congruence. - econstructor. EvalOp. simpl. congruence. constructor. auto. - EvalOp. -Qed. - -Theorem eval_shl: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y (Int.repr 32) = true -> - eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)). -Proof. - intros until y; unfold shl; case (shift_match b); intros. - InvEval. apply eval_shlimm; auto. - EvalOp. simpl. rewrite H1. auto. -Qed. - -Theorem eval_shru: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y (Int.repr 32) = true -> - eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)). -Proof. - intros until y; unfold shru; case (shift_match b); intros. - InvEval. apply eval_shruimm; auto. - EvalOp. simpl. rewrite H1. auto. -Qed. - -Theorem eval_addf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (addf a b) (Vfloat (Float.add x y)). -Proof. - intros until y; unfold addf. - destruct (use_fused_mul tt). - case (addf_match a b); intros; InvEval. - EvalOp. simpl. congruence. - EvalOp. simpl. rewrite Float.addf_commut. congruence. - EvalOp. - intros. EvalOp. -Qed. - -Theorem eval_subf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (subf a b) (Vfloat (Float.sub x y)). -Proof. - intros until y; unfold subf. - destruct (use_fused_mul tt). - case (subf_match a b); intros. - InvEval. EvalOp. simpl. congruence. - EvalOp. - intros. EvalOp. -Qed. - -Theorem eval_cast8signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v). -Proof. - intros until v; unfold cast8signed; case (cast8signed_match a); intros; InvEval. - EvalOp. simpl. subst v. destruct v1; simpl; auto. - rewrite Int.sign_ext_idem. reflexivity. compute; auto. - EvalOp. -Qed. - -Theorem eval_cast8unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v). -Proof. - intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros; InvEval. - EvalOp. simpl. subst v. destruct v1; simpl; auto. - rewrite Int.zero_ext_idem. reflexivity. compute; auto. - EvalOp. -Qed. - -Theorem eval_cast16signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v). -Proof. - intros until v; unfold cast16signed; case (cast16signed_match a); intros; InvEval. - EvalOp. simpl. subst v. destruct v1; simpl; auto. - rewrite Int.sign_ext_idem. reflexivity. compute; auto. - EvalOp. -Qed. - -Theorem eval_cast16unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v). -Proof. - intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros; InvEval. - EvalOp. simpl. subst v. destruct v1; simpl; auto. - rewrite Int.zero_ext_idem. reflexivity. compute; auto. - EvalOp. -Qed. - -Theorem eval_singleoffloat: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). -Proof. - intros until v; unfold singleoffloat; case (singleoffloat_match a); intros; InvEval. - EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity. - EvalOp. -Qed. - -Theorem eval_comp_int: - forall le c a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)). -Proof. - intros until y. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. -Qed. - -Theorem eval_comp_ptr_int: - forall le c a x1 x2 b y v, - eval_expr ge sp e m le a (Vptr x1 x2) -> - eval_expr ge sp e m le b (Vint y) -> - (if Int.eq y Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> - eval_expr ge sp e m le (comp c a b) v. -Proof. - intros until v. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. destruct (Int.eq y Int.zero); try discriminate. - unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. - destruct c; try discriminate; auto. - EvalOp. simpl. destruct (Int.eq y Int.zero); try discriminate. - unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. - destruct c; try discriminate; auto. -Qed. - -Theorem eval_comp_int_ptr: - forall le c a x b y1 y2 v, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vptr y1 y2) -> - (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> - eval_expr ge sp e m le (comp c a b) v. -Proof. - intros until v. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. destruct (Int.eq x Int.zero); try discriminate. - unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. - destruct c; try discriminate; auto. - EvalOp. simpl. destruct (Int.eq x Int.zero); try discriminate. - unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. - destruct c; try discriminate; auto. -Qed. - -Theorem eval_comp_ptr_ptr: - forall le c a x1 x2 b y1 y2, - eval_expr ge sp e m le a (Vptr x1 x2) -> - eval_expr ge sp e m le b (Vptr y1 y2) -> - valid_pointer m x1 (Int.signed x2) && - valid_pointer m y1 (Int.signed y2) = true -> - x1 = y1 -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x2 y2)). -Proof. - intros until y2. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite H1. subst y1. rewrite dec_eq_true. - destruct (Int.cmp c x2 y2); reflexivity. -Qed. - -Theorem eval_comp_ptr_ptr_2: - forall le c a x1 x2 b y1 y2 v, - eval_expr ge sp e m le a (Vptr x1 x2) -> - eval_expr ge sp e m le b (Vptr y1 y2) -> - valid_pointer m x1 (Int.signed x2) && - valid_pointer m y1 (Int.signed y2) = true -> - x1 <> y1 -> - Cminor.eval_compare_mismatch c = Some v -> - eval_expr ge sp e m le (comp c a b) v. -Proof. - intros until y2. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. - destruct c; simpl in H3; inv H3; auto. -Qed. - -Theorem eval_compu: - forall le c a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). -Proof. - intros until y. - unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. -Qed. - -Theorem eval_compf: - forall le c a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)). -Proof. - intros. unfold compf. EvalOp. simpl. - destruct (Float.cmp c x y); reflexivity. -Qed. - -Lemma negate_condexpr_correct: - forall le a b, - eval_condexpr ge sp e m le a b -> - eval_condexpr ge sp e m le (negate_condexpr a) (negb b). -Proof. - induction 1; simpl. - constructor. - constructor. - econstructor. eauto. apply eval_negate_condition. auto. - econstructor. eauto. destruct vb1; auto. -Qed. - -Scheme expr_ind2 := Induction for expr Sort Prop - with exprlist_ind2 := Induction for exprlist Sort Prop. - -Fixpoint forall_exprlist (P: expr -> Prop) (el: exprlist) {struct el}: Prop := - match el with - | Enil => True - | Econs e el' => P e /\ forall_exprlist P el' - end. - -Lemma expr_induction_principle: - forall (P: expr -> Prop), - (forall i : ident, P (Evar i)) -> - (forall (o : operation) (e : exprlist), - forall_exprlist P e -> P (Eop o e)) -> - (forall (m : memory_chunk) (a : Op.addressing) (e : exprlist), - forall_exprlist P e -> P (Eload m a e)) -> - (forall (c : condexpr) (e : expr), - P e -> forall e0 : expr, P e0 -> P (Econdition c e e0)) -> - (forall e : expr, P e -> forall e0 : expr, P e0 -> P (Elet e e0)) -> - (forall n : nat, P (Eletvar n)) -> - forall e : expr, P e. -Proof. - intros. apply expr_ind2 with (P := P) (P0 := forall_exprlist P); auto. - simpl. auto. - intros. simpl. auto. -Qed. - -Lemma eval_base_condition_of_expr: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_condexpr ge sp e m le - (CEcond (Ccompimm Cne Int.zero) (a ::: Enil)) - b. -Proof. - intros. - eapply eval_CEcond. eauto with evalexpr. - inversion H0; simpl. rewrite Int.eq_false; auto. auto. auto. -Qed. - -Lemma is_compare_neq_zero_correct: - forall c v b, - is_compare_neq_zero c = true -> - eval_condition c (v :: nil) m = Some b -> - Val.bool_of_val v b. -Proof. - intros. - destruct c; simpl in H; try discriminate; - destruct c; simpl in H; try discriminate; - generalize (Int.eq_spec i Int.zero); rewrite H; intro; subst i. - - simpl in H0. destruct v; inv H0. - generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. - subst i; constructor. constructor; auto. constructor. - - simpl in H0. destruct v; inv H0. - generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. - subst i; constructor. constructor; auto. -Qed. - -Lemma is_compare_eq_zero_correct: - forall c v b, - is_compare_eq_zero c = true -> - eval_condition c (v :: nil) m = Some b -> - Val.bool_of_val v (negb b). -Proof. - intros. apply is_compare_neq_zero_correct with (negate_condition c). - destruct c; simpl in H; simpl; try discriminate; - destruct c; simpl; try discriminate; auto. - apply eval_negate_condition; auto. -Qed. - -Lemma eval_condition_of_expr: - forall a le v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_condexpr ge sp e m le (condexpr_of_expr a) b. -Proof. - intro a0; pattern a0. - apply expr_induction_principle; simpl; intros; - try (eapply eval_base_condition_of_expr; eauto; fail). - - destruct o; try (eapply eval_base_condition_of_expr; eauto; fail). - - destruct e0. InvEval. - inversion H1. - rewrite Int.eq_false; auto. constructor. - subst i; rewrite Int.eq_true. constructor. - eapply eval_base_condition_of_expr; eauto. - - inv H0. simpl in H7. - assert (eval_condition c vl m = Some b). - destruct (eval_condition c vl m); try discriminate. - destruct b0; inv H7; inversion H1; congruence. - assert (eval_condexpr ge sp e m le (CEcond c e0) b). - eapply eval_CEcond; eauto. - destruct e0; auto. destruct e1; auto. - simpl in H. destruct H. - inv H5. inv H11. - - case_eq (is_compare_neq_zero c); intros. - eapply H; eauto. - apply is_compare_neq_zero_correct with c; auto. - - case_eq (is_compare_eq_zero c); intros. - replace b with (negb (negb b)). apply negate_condexpr_correct. - eapply H; eauto. - apply is_compare_eq_zero_correct with c; auto. - apply negb_involutive. - - auto. - - inv H1. destruct v1; eauto with evalexpr. -Qed. - -Lemma eval_addressing: - forall le a v b ofs, - eval_expr ge sp e m le a v -> - v = Vptr b ofs -> - match addressing a with (mode, args) => - exists vl, - eval_exprlist ge sp e m le args vl /\ - eval_addressing ge sp mode vl = Some v - end. -Proof. - intros until v. unfold addressing; case (addressing_match a); intros; InvEval. - exists (@nil val). split. eauto with evalexpr. simpl. auto. - exists (@nil val). split. eauto with evalexpr. simpl. auto. - destruct (Genv.find_symbol ge s); congruence. - exists (Vint i0 :: nil). split. eauto with evalexpr. - simpl. destruct (Genv.find_symbol ge s). congruence. discriminate. - exists (Vptr b0 i :: nil). split. eauto with evalexpr. - simpl. congruence. - exists (Vint i :: Vptr b0 i0 :: nil). - split. eauto with evalexpr. simpl. - congruence. - exists (Vptr b0 i :: Vint i0 :: nil). - split. eauto with evalexpr. simpl. congruence. - exists (v :: nil). split. eauto with evalexpr. - subst v. simpl. rewrite Int.add_zero. auto. -Qed. - -Lemma eval_load: - forall le a v chunk v', - eval_expr ge sp e m le a v -> - Mem.loadv chunk m v = Some v' -> - eval_expr ge sp e m le (load chunk a) v'. -Proof. - intros. generalize H0; destruct v; simpl; intro; try discriminate. - unfold load. - generalize (eval_addressing _ _ _ _ _ H (refl_equal _)). - destruct (addressing a). intros [vl [EV EQ]]. - eapply eval_Eload; eauto. -Qed. - -Lemma eval_store: - forall chunk a1 a2 v1 v2 f k m', - eval_expr ge sp e m nil a1 v1 -> - eval_expr ge sp e m nil a2 v2 -> - Mem.storev chunk m v1 v2 = Some m' -> - step ge (State f (store chunk a1 a2) k sp e m) - E0 (State f Sskip k sp e m'). -Proof. - intros. generalize H1; destruct v1; simpl; intro; try discriminate. - unfold store. - generalize (eval_addressing _ _ _ _ _ H (refl_equal _)). - destruct (addressing a1). intros [vl [EV EQ]]. - eapply step_store; eauto. -Qed. - -(** * Correctness of instruction selection for operators *) - -(** We now prove a semantic preservation result for the [sel_unop] - and [sel_binop] selection functions. The proof exploits - the results of the previous section. *) - -Lemma eval_sel_unop: - forall le op a1 v1 v, - eval_expr ge sp e m le a1 v1 -> - eval_unop op v1 = Some v -> - eval_expr ge sp e m le (sel_unop op a1) v. -Proof. - destruct op; simpl; intros; FuncInv; try subst v. - apply eval_cast8unsigned; auto. - apply eval_cast8signed; auto. - apply eval_cast16unsigned; auto. - apply eval_cast16signed; auto. - EvalOp. - generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intro. - change true with (negb false). eapply eval_notbool; eauto. subst i; constructor. - change false with (negb true). eapply eval_notbool; eauto. constructor; auto. - change Vfalse with (Val.of_bool (negb true)). - eapply eval_notbool; eauto. constructor. - apply eval_notint; auto. - EvalOp. - EvalOp. - apply eval_singleoffloat; auto. - EvalOp. - EvalOp. - EvalOp. - EvalOp. -Qed. - -Lemma eval_sel_binop: - forall le op a1 a2 v1 v2 v, - eval_expr ge sp e m le a1 v1 -> - eval_expr ge sp e m le a2 v2 -> - eval_binop op v1 v2 m = Some v -> - eval_expr ge sp e m le (sel_binop op a1 a2) v. -Proof. - destruct op; simpl; intros; FuncInv; try subst v. - apply eval_add; auto. - apply eval_add_ptr_2; auto. - apply eval_add_ptr; auto. - apply eval_sub; auto. - apply eval_sub_ptr_int; auto. - destruct (eq_block b b0); inv H1. - eapply eval_sub_ptr_ptr; eauto. - apply eval_mul; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_divs; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_divu; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_mods; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_modu; eauto. - apply eval_and; auto. - apply eval_or; auto. - EvalOp. - caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. - apply eval_shl; auto. - EvalOp. - caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. - apply eval_shru; auto. - apply eval_addf; auto. - apply eval_subf; auto. - EvalOp. - EvalOp. - apply eval_comp_int; auto. - eapply eval_comp_int_ptr; eauto. - eapply eval_comp_ptr_int; eauto. - generalize H1; clear H1. - case_eq (valid_pointer m b (Int.signed i) && valid_pointer m b0 (Int.signed i0)); intros. - destruct (eq_block b b0); inv H2. - eapply eval_comp_ptr_ptr; eauto. - eapply eval_comp_ptr_ptr_2; eauto. - discriminate. - eapply eval_compu; eauto. - eapply eval_compf; eauto. -Qed. - -End CMCONSTR. - -(** * Semantic preservation for instruction selection. *) - -Section PRESERVATION. - -Variable prog: Cminor.program. -Let tprog := sel_program prog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -(** Relationship between the global environments for the original - CminorSel program and the generated RTL program. *) - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intros; unfold ge, tge, tprog, sel_program. - apply Genv.find_symbol_transf. -Qed. - -Lemma functions_translated: - forall (v: val) (f: Cminor.fundef), - Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (sel_fundef f). -Proof. - intros. - exact (Genv.find_funct_transf sel_fundef H). -Qed. - -Lemma function_ptr_translated: - forall (b: block) (f: Cminor.fundef), - Genv.find_funct_ptr ge b = Some f -> - Genv.find_funct_ptr tge b = Some (sel_fundef f). -Proof. - intros. - exact (Genv.find_funct_ptr_transf sel_fundef H). -Qed. - -Lemma sig_function_translated: - forall f, - funsig (sel_fundef f) = Cminor.funsig f. -Proof. - intros. destruct f; reflexivity. -Qed. - -(** Semantic preservation for expressions. *) - -Lemma sel_expr_correct: - forall sp e m a v, - Cminor.eval_expr ge sp e m a v -> - forall le, - eval_expr tge sp e m le (sel_expr a) v. -Proof. - induction 1; intros; simpl. - (* Evar *) - constructor; auto. - (* Econst *) - destruct cst; simpl; simpl in H; (econstructor; [constructor|simpl;auto]). - rewrite symbols_preserved. auto. - (* Eunop *) - eapply eval_sel_unop; eauto. - (* Ebinop *) - eapply eval_sel_binop; eauto. - (* Eload *) - eapply eval_load; eauto. - (* Econdition *) - econstructor; eauto. eapply eval_condition_of_expr; eauto. - destruct b1; auto. -Qed. - -Hint Resolve sel_expr_correct: evalexpr. - -Lemma sel_exprlist_correct: - forall sp e m a v, - Cminor.eval_exprlist ge sp e m a v -> - forall le, - eval_exprlist tge sp e m le (sel_exprlist a) v. -Proof. - induction 1; intros; simpl; constructor; auto with evalexpr. -Qed. - -Hint Resolve sel_exprlist_correct: evalexpr. - -(** Semantic preservation for terminating function calls and statements. *) - -Fixpoint sel_cont (k: Cminor.cont) : CminorSel.cont := - match k with - | Cminor.Kstop => Kstop - | Cminor.Kseq s1 k1 => Kseq (sel_stmt s1) (sel_cont k1) - | Cminor.Kblock k1 => Kblock (sel_cont k1) - | Cminor.Kcall id f sp e k1 => - Kcall id (sel_function f) sp e (sel_cont k1) - end. - -Inductive match_states: Cminor.state -> CminorSel.state -> Prop := - | match_state: forall f s k s' k' sp e m, - s' = sel_stmt s -> - k' = sel_cont k -> - match_states - (Cminor.State f s k sp e m) - (State (sel_function f) s' k' sp e m) - | match_callstate: forall f args k k' m, - k' = sel_cont k -> - match_states - (Cminor.Callstate f args k m) - (Callstate (sel_fundef f) args k' m) - | match_returnstate: forall v k k' m, - k' = sel_cont k -> - match_states - (Cminor.Returnstate v k m) - (Returnstate v k' m). - -Remark call_cont_commut: - forall k, call_cont (sel_cont k) = sel_cont (Cminor.call_cont k). -Proof. - induction k; simpl; auto. -Qed. - -Remark find_label_commut: - forall lbl s k, - find_label lbl (sel_stmt s) (sel_cont k) = - option_map (fun sk => (sel_stmt (fst sk), sel_cont (snd sk))) - (Cminor.find_label lbl s k). -Proof. - induction s; intros; simpl; auto. - unfold store. destruct (addressing (sel_expr e)); auto. - change (Kseq (sel_stmt s2) (sel_cont k)) - with (sel_cont (Cminor.Kseq s2 k)). - rewrite IHs1. rewrite IHs2. - destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)); auto. - rewrite IHs1. rewrite IHs2. - destruct (Cminor.find_label lbl s1 k); auto. - change (Kseq (Sloop (sel_stmt s)) (sel_cont k)) - with (sel_cont (Cminor.Kseq (Cminor.Sloop s) k)). - auto. - change (Kblock (sel_cont k)) - with (sel_cont (Cminor.Kblock k)). - auto. - destruct o; auto. - destruct (ident_eq lbl l); auto. -Qed. - -Lemma sel_step_correct: - forall S1 t S2, Cminor.step ge S1 t S2 -> - forall T1, match_states S1 T1 -> - exists T2, step tge T1 t T2 /\ match_states S2 T2. -Proof. - induction 1; intros T1 ME; inv ME; simpl; - try (econstructor; split; [econstructor; eauto with evalexpr | econstructor; eauto]; fail). - - (* skip call *) - econstructor; split. - econstructor. destruct k; simpl in H; simpl; auto. - rewrite <- H0; reflexivity. - constructor; auto. - (* assign *) - exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id v e) m); split. - constructor. auto with evalexpr. - constructor; auto. - (* store *) - econstructor; split. - eapply eval_store; eauto with evalexpr. - constructor; auto. - (* Scall *) - econstructor; split. - econstructor; eauto with evalexpr. - apply functions_translated; eauto. - apply sig_function_translated. - constructor; auto. - (* Stailcall *) - econstructor; split. - econstructor; eauto with evalexpr. - apply functions_translated; eauto. - apply sig_function_translated. - constructor; auto. apply call_cont_commut. - (* Salloc *) - exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id (Vptr b Int.zero) e) m'); split. - econstructor; eauto with evalexpr. - constructor; auto. - (* Sifthenelse *) - exists (State (sel_function f) (if b then sel_stmt s1 else sel_stmt s2) (sel_cont k) sp e m); split. - constructor. eapply eval_condition_of_expr; eauto with evalexpr. - constructor; auto. destruct b; auto. - (* Sreturn None *) - econstructor; split. - econstructor. rewrite <- H; reflexivity. - constructor; auto. apply call_cont_commut. - (* Sreturn Some *) - econstructor; split. - econstructor. simpl. auto. eauto with evalexpr. - constructor; auto. apply call_cont_commut. - (* Sgoto *) - econstructor; split. - econstructor. simpl. rewrite call_cont_commut. rewrite find_label_commut. - rewrite H. simpl. reflexivity. - constructor; auto. -Qed. - -Lemma sel_initial_states: - forall S, Cminor.initial_state prog S -> - exists R, initial_state tprog R /\ match_states S R. -Proof. - induction 1. - econstructor; split. - econstructor. - simpl. fold tge. rewrite symbols_preserved. eexact H. - apply function_ptr_translated. eauto. - rewrite <- H1. apply sig_function_translated; auto. - unfold tprog, sel_program. rewrite Genv.init_mem_transf. - constructor; auto. -Qed. - -Lemma sel_final_states: - forall S R r, - match_states S R -> Cminor.final_state S r -> final_state R r. -Proof. - intros. inv H0. inv H. simpl. constructor. -Qed. - -Theorem transf_program_correct: - forall (beh: program_behavior), - Cminor.exec_program prog beh -> CminorSel.exec_program tprog beh. -Proof. - unfold CminorSel.exec_program, Cminor.exec_program; intros. - eapply simulation_step_preservation; eauto. - eexact sel_initial_states. - eexact sel_final_states. - exact sel_step_correct. -Qed. - -End PRESERVATION. diff --git a/backend/Stacking.v b/backend/Stacking.v index 3f08daa3..1cf010b4 100644 --- a/backend/Stacking.v +++ b/backend/Stacking.v @@ -24,61 +24,12 @@ Require Import Linear. Require Import Bounds. Require Import Mach. Require Import Conventions. +Require Import Stacklayout. (** * Layout of activation records *) -(** The general shape of activation records is as follows, - from bottom (lowest offsets) to top: -- 24 reserved bytes. The first 4 bytes hold the back pointer to the - activation record of the caller. We use the 4 bytes at offset 12 - to store the return address. (These are reserved by the PowerPC - application binary interface.) The remaining bytes are unused. -- Space for outgoing arguments to function calls. -- Local stack slots of integer type. -- Saved values of integer callee-save registers used by the function. -- One word of padding, if necessary to align the following data - on a 8-byte boundary. -- Local stack slots of float type. -- Saved values of float callee-save registers used by the function. -- Space for the stack-allocated data declared in Cminor. - -To facilitate some of the proofs, the Cminor stack-allocated data -starts at offset 0; the preceding areas in the activation record -therefore have negative offsets. This part (with negative offsets) -is called the ``frame'', by opposition with the ``Cminor stack data'' -which is the part with positive offsets. - -The [frame_env] compilation environment records the positions of -the boundaries between areas in the frame part. -*) - -Definition fe_ofs_arg := 24. - -Record frame_env : Set := mk_frame_env { - fe_size: Z; - fe_ofs_link: Z; - fe_ofs_retaddr: Z; - fe_ofs_int_local: Z; - fe_ofs_int_callee_save: Z; - fe_num_int_callee_save: Z; - fe_ofs_float_local: Z; - fe_ofs_float_callee_save: Z; - fe_num_float_callee_save: Z -}. - -(** Computation of the frame environment from the bounds of the current - function. *) - -Definition make_env (b: bounds) := - let oil := 24 + 4 * b.(bound_outgoing) in (* integer locals *) - let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *) - let oendi := oics + 4 * b.(bound_int_callee_save) in - let ofl := align oendi 8 in (* float locals *) - let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *) - let sz := ofcs + 8 * b.(bound_float_callee_save) in (* total frame size *) - mk_frame_env sz 0 12 - oil oics b.(bound_int_callee_save) - ofl ofcs b.(bound_float_callee_save). +(** The machine- and ABI-dependent aspects of the layout are defined + in module [Stacklayout]. *) (** Computation the frame offset for the given component of the frame. The component is expressed by the following [frame_index] sum type. *) diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index a9187eed..e17f67a6 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -38,6 +38,7 @@ Require Import Mach. Require Import Machabstr. Require Import Bounds. Require Import Conventions. +Require Import Stacklayout. Require Import Stacking. (** * Properties of frames and frame accesses *) @@ -50,92 +51,6 @@ Proof. destruct ty; auto. Qed. -(* -Lemma get_slot_ok: - forall fr ty ofs, - 24 <= ofs -> fr.(fr_low) + ofs + 4 * typesize ty <= 0 -> - exists v, get_slot fr ty ofs v. -Proof. - intros. rewrite <- typesize_typesize in H0. - exists (fr.(fr_contents) ty (fr.(fr_low) + ofs)). constructor; auto. -Qed. - -Lemma set_slot_ok: - forall fr ty ofs v, - 24 <= ofs -> fr.(fr_low) + ofs + 4 * typesize ty <= 0 -> - exists fr', set_slot fr ty ofs v fr'. -Proof. - intros. rewrite <- typesize_typesize in H0. - econstructor. constructor; eauto. -Qed. - -Lemma slot_gss: - forall fr1 ty ofs v fr2, - set_slot fr1 ty ofs v fr2 -> - get_slot fr2 ty ofs v. -Proof. - intros. inv H. constructor; auto. - simpl. destruct (typ_eq ty ty); try congruence. - rewrite zeq_true. auto. -Qed. - -Remark frame_update_gso: - forall fr ty ofs v ty' ofs', - ofs' + 4 * typesize ty' <= ofs \/ ofs + 4 * typesize ty <= ofs' -> - fr_contents (update ty ofs v fr) ty' ofs' = fr_contents fr ty' ofs'. -Proof. - intros. - generalize (typesize_pos ty); intro. - generalize (typesize_pos ty'); intro. - simpl. rewrite zeq_false. 2: omega. - repeat rewrite <- typesize_typesize in H. - destruct (zle (ofs' + AST.typesize ty') ofs). auto. - destruct (zle (ofs + AST.typesize ty) ofs'). auto. - omegaContradiction. -Qed. - -Remark frame_update_overlap: - forall fr ty ofs v ty' ofs', - ofs <> ofs' -> - ofs' + 4 * typesize ty' > ofs -> ofs + 4 * typesize ty > ofs' -> - fr_contents (update ty ofs v fr) ty' ofs' = Vundef. -Proof. - intros. simpl. rewrite zeq_false; auto. - rewrite <- typesize_typesize in H0. - rewrite <- typesize_typesize in H1. - repeat rewrite zle_false; auto. -Qed. - -Remark frame_update_mismatch: - forall fr ty ofs v ty', - ty <> ty' -> - fr_contents (update ty ofs v fr) ty' ofs = Vundef. -Proof. - intros. simpl. rewrite zeq_true. - destruct (typ_eq ty ty'); congruence. -Qed. - -Lemma slot_gso: - forall fr1 ty ofs v fr2 ty' ofs' v', - set_slot fr1 ty ofs v fr2 -> - get_slot fr1 ty' ofs' v' -> - ofs' + 4 * typesize ty' <= ofs \/ ofs + 4 * typesize ty <= ofs' -> - get_slot fr2 ty' ofs' v'. -Proof. - intros. inv H. inv H0. - constructor; auto. - symmetry. simpl fr_low. apply frame_update_gso. omega. -Qed. - -Lemma slot_gi: - forall f ofs ty, - 24 <= ofs -> fr_low (init_frame f) + ofs + 4 * typesize ty <= 0 -> - get_slot (init_frame f) ty ofs Vundef. -Proof. - intros. rewrite <- typesize_typesize in H0. constructor; auto. -Qed. -*) - Section PRESERVATION. Variable prog: Linear.program. @@ -219,20 +134,13 @@ Definition index_diff (idx1 idx2: frame_index) : Prop := | _, _ => True end. -Remark align_float_part: - 24 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b <= - align (24 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8. -Proof. - apply align_le. omega. -Qed. - Ltac AddPosProps := generalize (bound_int_local_pos b); intro; generalize (bound_float_local_pos b); intro; generalize (bound_int_callee_save_pos b); intro; generalize (bound_float_callee_save_pos b); intro; generalize (bound_outgoing_pos b); intro; - generalize align_float_part; intro. + generalize (align_float_part b); intro. Lemma size_pos: fe.(fe_size) >= 0. Proof. @@ -1383,10 +1291,9 @@ Lemma shift_eval_addressing: (transl_addr (make_env (function_bounds f)) addr) args = Some v. Proof. - intros. destruct addr; auto. - simpl. rewrite symbols_preserved. auto. - simpl. rewrite symbols_preserved. auto. - unfold transl_addr, eval_addressing in *. + intros. + unfold transl_addr, eval_addressing in *; + destruct addr; try (rewrite symbols_preserved); auto. destruct args; try discriminate. apply shift_offset_sp; auto. Qed. diff --git a/backend/Stackingtyping.v b/backend/Stackingtyping.v index f3fe24f2..f1fe2cf0 100644 --- a/backend/Stackingtyping.v +++ b/backend/Stackingtyping.v @@ -25,6 +25,7 @@ Require Import Lineartyping. Require Import Mach. Require Import Machtyping. Require Import Bounds. +Require Import Stacklayout. Require Import Stacking. Require Import Stackingproof. |