Ignore:
Timestamp:
Nov 28, 2011, 3:13:14 PM (9 years ago)
Author:
tranquil
Message:
  • corrected previous bug
  • finished propagating immediates
File:
1 edited

Legend:

Unmodified
Added
Removed
  • Deliverables/D2.2/8051/src/RTLabs/RTLabsToRTL.ml

    r1568 r1572  
    6666let mem_local_env = Register.Map.mem
    6767let add_local_env = Register.Map.add
    68 let find_local_env = Register.Map.find
     68
     69let rec int_to_args (size : int) = function
     70
     71  | AST.Cst_int i ->
     72    let module M = IntValue.Make (struct let size = size end) in
     73    let chunks = M.break (M.of_int i) size in
     74    List.map (fun x -> RTL.Imm (M.to_int x)) chunks
     75
     76  | AST.Cst_float _ -> error_float ()
     77
     78  | AST.Cst_offset off ->
     79    let i = concrete_offset off in
     80    int_to_args size (AST.Cst_int i)
     81
     82  | AST.Cst_sizeof size' ->
     83    let i = concrete_size size' in
     84    int_to_args size (AST.Cst_int i)
     85
     86  | _ -> assert false (* should not be called on non-int arguments *)
     87
     88let find_local_env_reg = Register.Map.find
     89
     90let find_local_env a env = match a with
     91  | RTLabs.Reg r -> List.map (fun r -> RTL.Reg r) (Register.Map.find r env)
     92  | RTLabs.Imm (k, t) -> int_to_args (size_of_sig_type t) k
    6993
    7094let initialize_local_env runiverse registers result =
     
    76100  List.fold_left f Register.Map.empty registers
    77101
    78 let map_list_local_env lenv regs =
    79   let f res r = res @ (find_local_env r lenv) in
     102let map_list_local_env_reg lenv regs =
     103  let f res r = res @ (find_local_env_reg r lenv) in
    80104  List.fold_left f [] regs
    81105
     
    84108  | _ -> assert false (* do not use on these arguments *)
    85109
    86 let find_and_addr r lenv = make_addr (find_local_env r lenv)
     110let find_and_addr r lenv = make_addr (find_local_env_reg r lenv)
    87111
    88112let rtl_args regs_list lenv =
     
    144168
    145169
    146 (*
    147 
    148 let rec translate_op2 op2 destrs srcrs1 srcrs2 start_lbl dest_lbl def =
    149   match op2, destrs, srcrs1, srcrs2 with
    150 
    151     | AST.Op_mul (1, _), [destr], [srcr1], [srcr2] ->
    152       adds_graph
    153         [RTL.St_opaccs (I8051.Mul, destr, srcr1, srcr2, start_lbl)]
    154         start_lbl dest_lbl def
    155 
    156     | AST.Op_shr _, _, _, _ ->
    157       error_shift ()
    158 
    159     | AST.Op_cmp (AST.Cmp_lt, (1, AST.Unsigned)), [destr], [srcr1], [srcr2] ->
    160       let (def, tmpr) = fresh_reg def in
    161       adds_graph
    162         [RTL.St_clear_carry start_lbl ;
    163          RTL.St_op2 (I8051.Sub, destr, srcr1, srcr2, start_lbl) ;
    164          RTL.St_int (destr, 0, start_lbl) ;
    165          RTL.St_op2 (I8051.Addc, destr, destr, destr, start_lbl)]
    166         start_lbl dest_lbl def
    167 
    168     | AST.Op_cmp (cmp, ((size, AST.Signed) as int_type)), _, _, _ ->
    169       let (def, tmprs1) = fresh_regs def (List.length srcrs1) in
    170       let (def, tmprs2) = fresh_regs def (List.length srcrs2) in
    171       add_translates
    172         [translate_cst (AST.Cst_int 128) tmprs1 ;
    173          translate_cst (AST.Cst_int 128) tmprs2 ;
    174          translate_op2 (AST.Op_add int_type) tmprs1 srcrs1 tmprs1 ;
    175          translate_op2 (AST.Op_add int_type) tmprs2 srcrs2 tmprs2 ;
    176          translate_op2 (AST.Op_cmp (cmp, (size, AST.Unsigned)))
    177            destrs tmprs1 tmprs2]
    178         start_lbl dest_lbl def
    179 
    180     | AST.Op_cmpp AST.Cmp_lt, [destr], [srcr11 ; srcr12], [srcr21 ; srcr22] ->
    181       let (def, tmpr1) = fresh_reg def in
    182       let (def, tmpr2) = fresh_reg def in
    183       add_translates
    184         [translate_op2 (AST.Op_cmp (AST.Cmp_lt, uint))
    185             [tmpr1] [srcr12] [srcr22] ;
    186          translate_op2 (AST.Op_cmp (AST.Cmp_eq, uint))
    187             [tmpr2] [srcr12] [srcr22] ;
    188          translate_op2 (AST.Op_cmp (AST.Cmp_lt, uint))
    189             [destr] [srcr11] [srcr21] ;
    190          translate_op2 AST.Op_and [tmpr2] [tmpr2] [destr] ;
    191          translate_op2 AST.Op_or [destr] [tmpr1] [tmpr2]]
    192         start_lbl dest_lbl def
    193 
    194     | _ -> error_int ()
    195 *)
    196 
    197 let rec translate_cst cst destrs start_lbl dest_lbl def = match cst with
    198 
    199   | AST.Cst_int _ when destrs = [] ->
    200     add_graph start_lbl (RTL.St_skip dest_lbl) def
    201 
    202   | AST.Cst_int i ->
    203     let size = List.length destrs in
    204     let module M = IntValue.Make (struct let size = size end) in
    205     let is = List.map M.to_int (M.break (M.of_int i) size) in
    206     let f r i = RTL.St_move (r, RTL.Imm i, dest_lbl) in
    207     let l = List.map2 f destrs is in
    208     adds_graph l start_lbl dest_lbl def
    209 
    210   | AST.Cst_float _ -> error_float ()
    211 
    212   | AST.Cst_addrsymbol id ->
    213     let (r1, r2) = make_addr destrs in
    214     add_graph start_lbl (RTL.St_addr (r1, r2, id, dest_lbl)) def
    215 
    216   | AST.Cst_stack ->
    217     let (r1, r2) = make_addr destrs in
    218     add_graph start_lbl (RTL.St_stackaddr (r1, r2, dest_lbl)) def
    219 
    220   | AST.Cst_offset off ->
    221     let i = concrete_offset off in
    222     translate_cst (AST.Cst_int i) destrs start_lbl dest_lbl def
    223 
    224   | AST.Cst_sizeof size ->
    225     let i = concrete_size size in
    226     translate_cst (AST.Cst_int i) destrs start_lbl dest_lbl def
    227 
    228 
    229170let rec translate_move destrs srcrs start_lbl =
    230171  let ((common1, rest1), (common2, rest2)) = MiscPottier.reduce destrs srcrs in
    231   let f_common destr srcr = RTL.St_move (destr, RTL.Reg srcr, start_lbl) in
     172  let f_common destr srcr = RTL.St_move (destr, srcr, start_lbl) in
    232173  let translates1 = adds_graph (List.map2 f_common common1 common2) in
    233174  let translates2 = translate_cst (AST.Cst_int 0) rest1 in
    234175  add_translates [translates1 ; translates2] start_lbl
    235176
    236 let rec translate_imm destrs vals start_lbl =
    237   let ((common1, rest1), (common2, _)) = MiscPottier.reduce destrs vals in
    238   let f_common destr srcr = RTL.St_move (destr, RTL.Imm srcr, start_lbl) in
    239   let translates1 = adds_graph (List.map2 f_common common1 common2) in
    240   let translates2 = translate_cst (AST.Cst_int 0) rest1 in
    241   add_translates [translates1 ; translates2] start_lbl
     177(* translate non-int constants *)
     178and translate_cst cst destrs start_lbl = match destrs, cst with
     179
     180  | [], _ -> adds_graph [] start_lbl
     181
     182  | _, AST.Cst_float _ -> error_float ()
     183
     184  | _, AST.Cst_addrsymbol id ->
     185    let (r1, r2) = make_addr destrs in
     186    adds_graph [RTL.St_addr (r1, r2, id, start_lbl)] start_lbl
     187
     188  | _, AST.Cst_stack ->
     189    let (r1, r2) = make_addr destrs in
     190    adds_graph [RTL.St_stackaddr (r1, r2, start_lbl)] start_lbl
     191
     192  | _ ->
     193    let srcrs = int_to_args (List.length destrs) cst in
     194    translate_move destrs srcrs start_lbl
    242195
    243196
     
    260213     RTL.St_op1 (I8051.Inc, tmpr, tmpr, start_lbl) ;
    261214     RTL.St_op1 (I8051.Cmpl, tmpr, tmpr, start_lbl) ] in
    262   let srcrs = MiscPottier.make tmpr (List.length destrs) in
     215  let srcrs = MiscPottier.make (RTL.Reg tmpr) (List.length destrs) in
    263216  add_translates [adds_graph insts ; translate_move destrs srcrs]
    264217    start_lbl dest_lbl def
     
    273226      let sign_reg = MiscPottier.last srcrs in
    274227      let insts_sign = match src_sign with
    275         | AST.Unsigned -> translate_cast_unsigned rest1
    276         | AST.Signed -> translate_cast_signed rest1 sign_reg in
     228        | AST.Unsigned -> translate_cast_unsigned rest1
     229        | AST.Signed -> translate_cast_signed rest1 sign_reg in
    277230      add_translates [insts_common ; insts_sign]
    278231
    279232
    280233let translate_negint destrs srcrs start_lbl dest_lbl def =
    281   assert (List.length destrs = List.length srcrs && List.length destrs > 0) ;
    282   let f_cmpl destr srcr = RTL.St_op1 (I8051.Cmpl, destr, srcr, start_lbl) in
     234  let f_cmpl destr = function
     235    | RTL.Reg r -> RTL.St_op1 (I8051.Cmpl, destr, r, start_lbl)
     236    | RTL.Imm k -> RTL.St_move (destr, RTL.Imm (lnot k), start_lbl) in
    283237  let insts_cmpl = List.map2 f_cmpl destrs srcrs in
    284   let first, rest = List.hd destrs, List.tl destrs in
    285   let inst_init =
    286     RTL.St_op2 (I8051.Add, first, first, RTL.Imm 0, start_lbl) in
    287   let f_add destr =
    288     RTL.St_op2 (I8051.Addc, destr, destr, RTL.Imm 0, start_lbl) in
    289   let insts_add = List.map f_add rest in
    290   adds_graph (insts_cmpl @ inst_init :: insts_add)
    291     start_lbl dest_lbl def
     238  match destrs with
     239    | destr :: destrs ->
     240      let inst_init =
     241        RTL.St_op2 (I8051.Add, destr, RTL.Reg destr, RTL.Imm 1, start_lbl) in
     242      let f_add destr =
     243        RTL.St_op2 (I8051.Addc, destr, RTL.Reg destr, RTL.Imm 0, start_lbl) in
     244      let insts_add = List.map f_add destrs in
     245      adds_graph (insts_cmpl @ inst_init :: insts_add)
     246        start_lbl dest_lbl def
     247    | [] ->
     248      adds_graph [] start_lbl dest_lbl def
    292249
    293250
     
    297254    | destr :: destrs, srcr :: srcrs ->
    298255      let (def, tmpr) = fresh_reg def in
    299       let init_destr = RTL.St_move (destr, RTL.Reg srcr, start_lbl) in
     256      let init_destr = RTL.St_move (destr, srcr, start_lbl) in
    300257      let f r =
    301         RTL.St_op2 (I8051.Or, destr, destr, RTL.Reg r, start_lbl) in
     258        RTL.St_op2 (I8051.Or, destr, RTL.Reg destr, r, start_lbl) in
    302259      let big_or = List.map f srcrs in
    303260      let finalize_destr =
    304261        [RTL.St_move (tmpr, RTL.Imm 0, start_lbl) ;
    305262         RTL.St_clear_carry start_lbl ;
    306          RTL.St_op2 (I8051.Sub, tmpr, tmpr, RTL.Reg destr, start_lbl) ;
     263         RTL.St_op2 (I8051.Sub, tmpr, RTL.Reg tmpr, RTL.Reg destr, start_lbl) ;
    307264         (* carry bit is set iff destr is non-zero iff destrs was non-zero *)
    308265         RTL.St_move (tmpr, RTL.Imm 0, start_lbl) ;
    309          RTL.St_op2 (I8051.Addc, destr, tmpr, RTL.Reg tmpr, start_lbl) ;
     266         RTL.St_op2 (I8051.Addc, destr, RTL.Reg tmpr, RTL.Reg tmpr, start_lbl) ;
    310267         (* destr = carry bit = bigor of old destrs *)
    311          RTL.St_op2 (I8051.Xor, destr, destr, RTL.Imm 1, start_lbl)] in
     268         RTL.St_op2 (I8051.Xor, destr, RTL.Reg destr, RTL.Imm 1, start_lbl)] in
    312269      let epilogue = translate_cst (AST.Cst_int 0) destrs in
    313270      add_translates [adds_graph (init_destr :: big_or @ finalize_destr) ;
     
    331288
    332289  | AST.Op_notint ->
    333     let f destr srcr = RTL.St_op1 (I8051.Cmpl, destr, srcr, start_lbl) in
     290    let f destr = function
     291      | RTL.Reg srcr ->  RTL.St_op1 (I8051.Cmpl, destr, srcr, start_lbl)
     292      | RTL.Imm k -> RTL.St_move (destr, RTL.Imm (lnot k), start_lbl) in
    334293    let l = List.map2 f destrs srcrs in
    335294    adds_graph l start_lbl dest_lbl def
     
    354313    | I8051.Add -> assert false (* should not call with add, not correct *)
    355314    | _ -> [] in
    356   let inst_init = RTL.St_move (tmpr, RTL.Imm 0, start_lbl) :: carry_init in
    357315  let f_add destr srcr1 srcr2 =
    358     RTL.St_op2 (op, destr, srcr1, RTL.Reg srcr2, start_lbl) in
     316    RTL.St_op2 (op, destr, srcr1, srcr2, start_lbl) in
    359317  let insts_add =
    360318    MiscPottier.map3 f_add destrs_common srcrs1_common srcrs2_common in
    361319  let f_add_cted destr srcr =
    362     RTL.St_op2 (op, destr, srcr, RTL.Reg tmpr, start_lbl) in
     320    RTL.St_op2 (op, destr, srcr, RTL.Imm 0, start_lbl) in
    363321  let insts_add_cted = List.map2 f_add_cted destrs_cted srcrs_cted in
    364322  let f_rest destr =
    365     RTL.St_op2 (op, destr, tmpr, RTL.Reg tmpr, start_lbl) in
     323    match op with
     324      | I8051.Addc | I8051.Sub ->
     325        (* propagate carry bit *)
     326        RTL.St_op2 (op, destr, RTL.Imm 0, RTL.Imm 0, start_lbl)
     327      | _ ->
     328        RTL.St_move (destr, RTL.Imm 0, start_lbl) in
    366329  let insts_rest = List.map f_rest destrs_rest in
    367   adds_graph (inst_init @ insts_add @ insts_add_cted @ insts_rest)
     330  adds_graph (carry_init @ insts_add @ insts_add_cted @ insts_rest)
    368331    start_lbl dest_lbl def
    369332
     
    373336    | [], _ -> adds_graph [RTL.St_skip start_lbl] start_lbl
    374337    | [destr], [] ->
    375       adds_graph [RTL.St_op2 (I8051.Addc, destr, destr, RTL.Imm 0, start_lbl)]
     338      adds_graph
     339        [RTL.St_op2 (I8051.Addc, destr, RTL.Reg destr, RTL.Imm 0, start_lbl)]
    376340        start_lbl
    377341    | destr1 :: destr2 :: destrs, [] ->
    378342      add_translates
    379343        [adds_graph
    380             [RTL.St_move (tmpr, RTL.Imm 0, start_lbl) ;
    381              RTL.St_op2 (I8051.Addc, destr1, destr1, RTL.Imm 0, start_lbl) ;
    382              RTL.St_op2 (I8051.Addc, destr2, tmpr, RTL.Imm 0, start_lbl)] ;
     344            [RTL.St_op2 (I8051.Addc, destr1,
     345                         RTL.Reg destr1, RTL.Imm 0, start_lbl) ;
     346             RTL.St_op2 (I8051.Addc, destr2, RTL.Imm 0, RTL.Imm 0, start_lbl)] ;
    383347         translate_cst (AST.Cst_int 0) destrs]
    384348        start_lbl
     
    386350      adds_graph
    387351        [RTL.St_opaccs (I8051.Mul, tmpr, dummy, srcr2, srcr1, start_lbl) ;
    388          RTL.St_op2 (I8051.Addc, destr, destr, RTL.Reg tmpr, start_lbl)]
    389         start_lbl
     352         RTL.St_op2 (I8051.Addc, destr, RTL.Reg destr, RTL.Reg tmpr, start_lbl)]
     353        start_lbl
    390354    | destr1 :: destr2 :: destrs, srcr1 :: srcrs1 ->
    391355      add_translates
    392         [adds_graph
    393             [RTL.St_opaccs
    394                 (I8051.Mul, tmpr, destr2, srcr2, srcr1, start_lbl) ;
    395              RTL.St_op2 (I8051.Addc, destr1, destr1, RTL.Reg tmpr, start_lbl)] ;
    396          translate_mul1 dummy tmpr (destr2 :: destrs) srcrs1 srcr2]
    397         start_lbl
     356        [adds_graph
     357            [RTL.St_opaccs
     358                (I8051.Mul, tmpr, destr2, srcr2, srcr1, start_lbl) ;
     359             RTL.St_op2 (I8051.Addc, destr1, RTL.Reg destr1,
     360                         RTL.Reg tmpr, start_lbl)] ;
     361         translate_mul1 dummy tmpr (destr2 :: destrs) srcrs1 srcr2]
     362        start_lbl
    398363
    399364let translate_muli dummy tmpr destrs tmp_destrs srcrs1 dummy_lbl i translates
     
    404369      | [] -> []
    405370      | tmp_destr2 :: tmp_destrs2 ->
    406         [adds_graph [RTL.St_clear_carry dummy_lbl ;
    407                      RTL.St_move (tmp_destr2, RTL.Imm 0, dummy_lbl)] ;
    408          translate_mul1 dummy tmpr (tmp_destr2 :: tmp_destrs2) srcrs1 srcr2i ;
    409          translate_cst (AST.Cst_int 0) tmp_destrs1 ;
    410          translate_op I8051.Addc destrs destrs tmp_destrs])
     371        [adds_graph [RTL.St_clear_carry dummy_lbl ;
     372                     RTL.St_move (tmp_destr2, RTL.Imm 0, dummy_lbl)] ;
     373         translate_mul1 dummy tmpr (tmp_destr2 :: tmp_destrs2) srcrs1 srcr2i ;
     374         translate_cst (AST.Cst_int 0) tmp_destrs1 ;
     375         let reg_destrs = List.map (fun r -> RTL.Reg r) destrs in
     376         let tmp_destrs = List.map (fun r -> RTL.Reg r) tmp_destrs in
     377         translate_op I8051.Addc destrs reg_destrs tmp_destrs])
    411378
    412379let translate_mul destrs srcrs1 srcrs2 start_lbl dest_lbl def =
     
    415382  let (def, tmp_destrs) = fresh_regs def (List.length destrs) in
    416383  let (def, fresh_srcrs1) = fresh_regs def (List.length srcrs1) in
    417   let (def, fresh_srcrs2) = fresh_regs def (List.length srcrs2) in
     384  (* let (def, fresh_srcrs2) = fresh_regs def (List.length srcrs2) in *)
     385  let reg r = RTL.Reg r in
    418386  let insts_init =
    419387    [translate_move fresh_srcrs1 srcrs1 ;
    420      translate_move fresh_srcrs2 srcrs2 ;
     388     (* translate_move fresh_srcrs2 srcrs2 ; *)
    421389     translate_cst (AST.Cst_int 0) destrs] in
     390  let fresh_srcrs1 = List.map reg fresh_srcrs1 in
    422391  let f = translate_muli dummy tmpr destrs tmp_destrs fresh_srcrs1 start_lbl in
    423392  let insts_mul = MiscPottier.foldi f [] srcrs2 in
     
    448417        | c1hd :: c1tl, c2hd :: c2tl ->
    449418          let init =
    450             RTL.St_op2 (I8051.Xor, destr, c1hd, RTL.Reg c2hd, start_lbl) in
     419            RTL.St_op2 (I8051.Xor, destr, c1hd, c2hd, start_lbl) in
    451420          let f_common tmp_srcr1 tmp_srcr2 =
    452             [RTL.St_op2 (I8051.Xor, tmpr, tmp_srcr1,
    453                          RTL.Reg tmp_srcr2, start_lbl) ;
    454              RTL.St_op2 (I8051.Or, destr, destr, RTL.Reg tmpr, start_lbl)] in
     421            [RTL.St_op2 (I8051.Xor, tmpr, tmp_srcr1, tmp_srcr2, start_lbl) ;
     422             RTL.St_op2 (I8051.Or, destr, RTL.Reg destr,
     423                        RTL.Reg tmpr, start_lbl)] in
    455424          let insts_common = List.flatten (List.map2 f_common c1tl c2tl) in
    456425          init :: insts_common
     
    460429        | _ -> assert false in
    461430      let f_rest tmp_srcr =
    462         RTL.St_op2 (I8051.Xor, destr, destr, RTL.Reg tmp_srcr, start_lbl) in
     431        RTL.St_op2 (I8051.Xor, destr, RTL.Reg destr,
     432                    tmp_srcr, start_lbl) in
    463433      let insts_rest = List.map f_rest rest in
    464434      let insts = firsts @ insts_rest in
     
    472442    | [] -> adds_graph [] start_lbl
    473443    | destr :: _ ->
    474       adds_graph [RTL.St_op1 (I8051.Cmpl, destr, destr, start_lbl)] start_lbl
    475 
    476 
    477 
    478 (* let translate_eq_reg tmp_zero tmpr destr dummy_lbl *)
    479 (*     (srcr1, srcr2) = *)
    480 (*   [RTL.St_op2 (I8051.Xor, tmpr, srcr1, srcr2, dummy_lbl) ; *)
    481 (*    (\* now tmpr = 0 iff srcr1 = srcr2 *\) *)
    482 (*    RTL.St_clear_carry dummy_lbl ; *)
    483 (*    RTL.St_op2 (I8051.Sub, tmpr, tmp_zero, tmpr, dummy_lbl) ; *)
    484 (*    (\* now carry bit = (old tmpr is not zero) = (srcr1 != srcr2) *\) *)
    485 (*    RTL.St_op2 (I8051.Addc, tmpr, tmp_zero, tmp_zero, dummy_lbl) ; *)
    486 (*    (\* now tmpr = old carry bit = (srcr1 != srcr2) *\) *)
    487 (*    RTL.St_op1 (I8051.Cpl, tmpr, tmpr, dummy_lbl)] *)
    488 
    489 (* let translate_eq_list tmp_zero tmpr destr leq dummy_lbl = match leq with *)
    490 (*   | leqhd :: leqtl -> *)
    491 (*     let init = translate_eq_reg tmp_zero destr dummy_lbl leqhd in *)
    492 (*     let f p = translate_eq_reg tmp_zero tmpr destr dummy_lbl p @ *)
    493 (*       [RTL.St_op2 (I8051.And, destr, destr, tmpr1, dummy_lbl)] in *)
    494 (*     init @ List.flatten (List.map f leqtl) *)
    495 (*   | _ -> [RTL.St_move (destr, RTL.Imm 1, dummy_lbl)] *)
    496 
    497 (* let translate_atom tmp_zero tmp_one tmpr1 tmpr2 tmpr3 destr dummy_lbl leq *)
    498 (*     srcr1 srcr2 = *)
    499 (*   (translate_eq_list tmp_zero tmp_one tmpr1 tmpr2 tmpr3 leq dummy_lbl) @ *)
    500 (*   [RTL.St_clear_carry dummy_lbl ; *)
    501 (*    RTL.St_op2 (I8051.Sub, tmpr1, srcr1, srcr2, dummy_lbl) ; *)
    502 (*    RTL.St_op2 (I8051.Addc, tmpr1, tmp_zero, tmp_zero, dummy_lbl) ; *)
    503 (*    RTL.St_op2 (I8051.And, tmpr3, tmpr3, tmpr1, dummy_lbl) ; *)
    504 (*    RTL.St_op2 (I8051.Or, destr, destr, tmpr3, dummy_lbl)] *)
    505 
    506 (* let translate_lt_main tmp_zero tmp_one tmpr1 tmpr2 tmpr3 destr dummy_lbl *)
    507 (*     srcrs1 srcrs2 = *)
    508 (*   let f (insts, leq) srcr1 srcr2 = *)
    509 (*     let added_insts = *)
    510 (*       translate_atom tmp_zero tmp_one tmpr1 tmpr2 tmpr3 destr dummy_lbl leq *)
    511 (*      srcr1 srcr2 in *)
    512 (*     (insts @ added_insts, leq @ [(srcr1, srcr2)]) in *)
    513 (*   fst (List.fold_left2 f ([], []) srcrs1 srcrs2) *)
    514 
    515 (* let translate_lt destrs srcrs1 srcrs2 start_lbl dest_lbl def = *)
    516 (*   match destrs with *)
    517 (*     | [] -> add_graph start_lbl (RTL.St_skip dest_lbl) def *)
    518 (*     | _ -> *)
    519 (*       let (def, tmp_destrs) = fresh_regs def (List.length destrs) in *)
    520 (*       let tmp_destr = List.hd tmp_destrs in *)
    521 (*       let (def, tmp_zero) = fresh_reg def in *)
    522 (*       let (def, tmp_one) = fresh_reg def in *)
    523 (*       let (def, tmpr1) = fresh_reg def in *)
    524 (*       let (def, tmpr2) = fresh_reg def in *)
    525 (*       let (def, tmpr3) = fresh_reg def in *)
    526 (*       let (srcrs1, srcrs2, added) = complete_regs def srcrs1 srcrs2 in *)
    527 (*       let srcrs1 = List.rev srcrs1 in *)
    528 (*       let srcrs2 = List.rev srcrs2 in *)
    529 (*       let insts_init = *)
    530 (*      [translate_cst (AST.Cst_int 0) tmp_destrs ; *)
    531 (*       translate_cst (AST.Cst_int 0) added ; *)
    532 (*       adds_graph [RTL.St_int (tmp_zero, 0, start_lbl) ; *)
    533 (*                   RTL.St_int (tmp_one, 1, start_lbl)]] in *)
    534 (*       let insts_main = *)
    535 (*      translate_lt_main tmp_zero tmp_one tmpr1 tmpr2 tmpr3 tmp_destr start_lbl *)
    536 (*        srcrs1 srcrs2 in *)
    537 (*       let insts_main = [adds_graph insts_main] in *)
    538 (*       let insts_exit = [translate_move destrs tmp_destrs] in *)
    539 (*       add_translates (insts_init @ insts_main @ insts_exit ) *)
    540 (*      start_lbl dest_lbl def *)
     444      adds_graph [RTL.St_op2 (I8051.Xor, destr, RTL.Reg destr,
     445                              RTL.Imm 1, start_lbl)] start_lbl
    541446
    542447let rec pad_with p l1 l2 = match l1, l2 with
     
    552457    | [] -> adds_graph [] start_lbl dest_lbl def
    553458    | destr :: destrs ->
    554       let (def, tmpr_zero) = fresh_reg def in
    555       let (srcrs1, srcrs2) = pad_with tmpr_zero srcrs1 srcrs2 in
    556       let init =
    557         [RTL.St_move (tmpr_zero, RTL.Imm 0, start_lbl) ;
    558          RTL.St_clear_carry start_lbl] in
     459      (* not sure that it is the correct thing to do, what about signed?
     460         can really srcrs1 and srcrs2 be of different length? Are not all
     461         correct types enforced? *)
     462      let (srcrs1, srcrs2) = pad_with (RTL.Imm 0) srcrs1 srcrs2 in
     463      let init = RTL.St_clear_carry start_lbl in
    559464      let f srcr1 srcr2 =
    560         RTL.St_op2 (I8051.Sub, destr, srcr1, RTL.Reg srcr2, start_lbl) in
     465        RTL.St_op2 (I8051.Sub, destr, srcr1, srcr2, start_lbl) in
    561466      (* not interested in result, just the carry bit
    562467         the following is safe even if destrs = srcrsi *)
    563468      let iter_sub = List.map2 f srcrs1 srcrs2 in
    564469      let extract_carry =
    565         [RTL.St_op2 (I8051.Addc, destr, tmpr_zero,
    566                      RTL.Reg tmpr_zero, start_lbl)] in
     470        [RTL.St_op2 (I8051.Addc, destr, RTL.Imm 0,
     471                     RTL.Imm 0, start_lbl)] in
    567472      let epilogue = translate_cst (AST.Cst_int 0) destrs in
    568       add_translates [adds_graph (init @ iter_sub @ extract_carry);
     473      add_translates [adds_graph (init :: iter_sub @ extract_carry);
    569474                      epilogue] start_lbl dest_lbl def
    570475
    571476let rec add_128_to_last
    572     (tmp_128 : Register.t)
    573477    (last_subst : Register.t)
    574     (rs : Register.t list)
     478    (rs : RTL.argument list)
    575479    (dummy_lbl : Label.t) = match rs with
    576480  | [] -> ([], adds_graph [])
    577481  | [last] ->
    578482    let insts =
    579       [RTL.St_move (last_subst, RTL.Reg last, dummy_lbl) ;
    580        RTL.St_op2 (I8051.Add, last_subst, last_subst,
    581                    RTL.Reg tmp_128, dummy_lbl)] in
    582     ([last_subst], adds_graph insts)
     483      [RTL.St_move (last_subst, last, dummy_lbl) ;
     484       RTL.St_op2 (I8051.Add, last_subst, RTL.Reg last_subst,
     485                   RTL.Imm 128, dummy_lbl)] in
     486    ([RTL.Reg last_subst], adds_graph insts)
    583487  | hd :: tail ->
    584     let (tail', trans) = add_128_to_last tmp_128 last_subst tail dummy_lbl in
     488    let (tail', trans) = add_128_to_last last_subst tail dummy_lbl in
    585489    (hd :: tail', trans)
    586490
    587 (* what happens if srcrs1 and srcrs2 have different length? seems to me
     491(* Paolo: what happens if srcrs1 and srcrs2 have different length? seems to me
    588492   128 is added at the wrong place then *)
    589493let translate_lts destrs srcrs1 srcrs2 start_lbl dest_lbl def =
    590494  let (def, tmp_last_srcr1) = fresh_reg def in
    591495  let (def, tmp_last_srcr2) = fresh_reg def in
    592   let (def, tmp_128) = fresh_reg def in
    593496  (* I save just the last registers *)
    594497  let (srcrs1, add_128_to_srcrs1) =
    595     add_128_to_last tmp_128 tmp_last_srcr1 srcrs1 start_lbl in
     498    add_128_to_last tmp_last_srcr1 srcrs1 start_lbl in
    596499  let (srcrs2, add_128_to_srcrs2) =
    597     add_128_to_last tmp_128 tmp_last_srcr2 srcrs2 start_lbl in
     500    add_128_to_last tmp_last_srcr2 srcrs2 start_lbl in
    598501  add_translates
    599     [adds_graph [RTL.St_move (tmp_128, RTL.Imm 128, start_lbl)] ;
    600      add_128_to_srcrs1;
     502    [add_128_to_srcrs1;
    601503     add_128_to_srcrs2;
    602504     translate_ltu destrs srcrs1 srcrs2]
     
    690592      let tmp_lbl = fresh_label def in
    691593      let init = RTL.St_move (tmpr, RTL.Reg srcr, start_lbl) in
    692       let f srcr = RTL.St_op2 (I8051.Or, tmpr, tmpr, RTL.Reg srcr, start_lbl) in
     594      let f srcr = RTL.St_op2 (I8051.Or, tmpr, RTL.Reg tmpr,
     595                               RTL.Reg srcr, start_lbl) in
    693596      let def = adds_graph (init :: (List.map f srcrs)) start_lbl tmp_lbl def in
    694597      add_graph tmp_lbl (RTL.St_cond (tmpr, lbl_true, lbl_false)) def
     
    696599
    697600let translate_load addr destrs start_lbl dest_lbl def =
    698   let (def, save_addr) = fresh_regs def (List.length addr) in
    699   let (def, tmp_addr) = fresh_regs def (List.length addr) in
     601  let (def, tmp_addr) = fresh_regs def 2 in
    700602  let (tmp_addr1, tmp_addr2) = make_addr tmp_addr in
     603  let save_addr a (saves, def, rs) = match a with
     604    | RTL.Reg r when List.exists (Register.equal r) destrs ->
     605      let (def, tmp) = fresh_reg def in
     606      (RTL.St_move (tmp, RTL.Reg r, start_lbl) :: saves, def, RTL.Reg tmp :: rs)
     607    | _ as a -> (saves, def, a :: rs) in
     608  let (saves, def, addr) = List.fold_right save_addr addr ([], def, []) in
    701609  let (def, tmpr) = fresh_reg def in
    702   let insts_save_addr = translate_move save_addr addr in
    703610  let f (translates, off) r =
    704611    let translates =
    705612      translates @
    706         [adds_graph [RTL.St_move (tmpr, RTL.Imm off, start_lbl)] ;
    707          translate_op2 AST.Op_addp tmp_addr save_addr [tmpr] ;
    708          adds_graph [RTL.St_load (r, tmp_addr1, tmp_addr2, dest_lbl)]] in
     613        [translate_op2 AST.Op_addp tmp_addr addr [RTL.Imm off] ;
     614         adds_graph [RTL.St_load (r, RTL.Reg tmp_addr1,
     615                                  RTL.Reg tmp_addr2, dest_lbl)]] in
    709616    (translates, off + Driver.TargetArch.int_size) in
    710617  let (translates, _) = List.fold_left f ([], 0) destrs in
    711   add_translates (insts_save_addr :: translates) start_lbl dest_lbl def
     618  add_translates translates start_lbl dest_lbl def
    712619
    713620
     
    719626    let translates =
    720627      translates @
    721         [adds_graph [RTL.St_move (tmpr, RTL.Imm off, start_lbl)] ;
    722          translate_op2 AST.Op_addp tmp_addr addr [tmpr] ;
    723          adds_graph [RTL.St_store (tmp_addr1, tmp_addr2, srcr, dest_lbl)]] in
     628        [translate_op2 AST.Op_addp tmp_addr addr [RTL.Imm off] ;
     629         adds_graph [RTL.St_store (RTL.Reg tmp_addr1,
     630                                   RTL.Reg tmp_addr2, srcr, dest_lbl)]] in
    724631    (translates, off + Driver.TargetArch.int_size) in
    725632  let (translates, _) = List.fold_left f ([], 0) srcrs in
     
    742649
    743650  | RTLabs.St_cst (destr, cst, lbl') ->
    744     translate_cst cst (find_local_env destr lenv) lbl lbl' def
     651    translate_cst cst (find_local_env_reg destr lenv) lbl lbl' def
    745652
    746653  | RTLabs.St_op1 (op1, destr, srcr, lbl') ->
    747     translate_op1 op1 (find_local_env destr lenv) (find_local_env srcr lenv)
     654    translate_op1 op1
     655      (find_local_env_reg destr lenv)
     656      (List.map (fun r -> RTL.Reg r) (find_local_env_reg srcr lenv))
    748657      lbl lbl' def
    749658
    750   | RTLabs.St_op2 (op2, destr, RTLabs.Reg srcr1, RTLabs.Reg srcr2, lbl') ->
    751     translate_op2 op2 (find_local_env destr lenv)
     659  | RTLabs.St_op2 (op2, destr, srcr1, srcr2, lbl') ->
     660    translate_op2 op2 (find_local_env_reg destr lenv)
    752661      (find_local_env srcr1 lenv) (find_local_env srcr2 lenv) lbl lbl' def
    753662
    754   | RTLabs.St_load (_, RTLabs.Reg addr, destr, lbl') ->
    755     translate_load (find_local_env addr lenv) (find_local_env destr lenv)
     663  | RTLabs.St_load (_, addr, destr, lbl') ->
     664    translate_load (find_local_env addr lenv) (find_local_env_reg destr lenv)
    756665      lbl lbl' def
    757666
    758   | RTLabs.St_store (_, RTLabs.Reg addr, RTLabs.Reg srcr, lbl') ->
     667  | RTLabs.St_store (_, addr, srcr, lbl') ->
    759668    translate_store (find_local_env addr lenv) (find_local_env srcr lenv)
    760669      lbl lbl' def
     
    765674  | RTLabs.St_call_id (f, args, Some retr, _, lbl') ->
    766675    add_graph lbl (RTL.St_call_id (f, rtl_args args lenv,
    767                                    find_local_env retr lenv, lbl')) def
     676                                   find_local_env_reg retr lenv, lbl')) def
    768677
    769678  | RTLabs.St_call_ptr (f, args, None, _, lbl') ->
     
    775684    add_graph lbl
    776685      (RTL.St_call_ptr
    777          (f1, f2, rtl_args args lenv, find_local_env retr lenv, lbl')) def
     686         (f1, f2, rtl_args args lenv, find_local_env_reg retr lenv, lbl')) def
    778687
    779688  | RTLabs.St_tailcall_id (f, args, _) ->
     
    785694
    786695  | RTLabs.St_cond (r, lbl_true, lbl_false) ->
    787     translate_cond (find_local_env r lenv) lbl lbl_true lbl_false def
     696    translate_cond (find_local_env_reg r lenv) lbl lbl_true lbl_false def
    788697
    789698  | RTLabs.St_jumptable _ ->
     
    796705    add_graph lbl (RTL.St_return (find_local_env r lenv)) def
    797706
    798   | _ -> assert false (*not possible because of previous removal of immediates*)
    799 
    800 let remove_immediates def =
    801   let load_arg a lbl g rs = match a with
    802     | RTLabs.Reg r -> (lbl, g, rs, r)
    803     | RTLabs.Imm (c, t) ->
    804       let new_l = Label.Gen.fresh def.RTLabs.f_luniverse in
    805       let new_r = Register.fresh def.RTLabs.f_runiverse in
    806       let g = Label.Map.add lbl (RTLabs.St_cst (new_r, c, new_l)) g in
    807       (new_l, g, (new_r, t) :: rs, new_r) in
    808   let f lbl stmt (g, rs) =
    809     match stmt with
    810       | RTLabs.St_op2(op, r, a1, a2, l) ->
    811         let (lbl', g, rs, r1) = load_arg a1 lbl g rs in
    812         let (lbl', g, rs, r2) = load_arg a2 lbl' g rs in
    813         let s = RTLabs.St_op2 (op, r, RTLabs.Reg r1, RTLabs.Reg r2, l) in
    814         let g = Label.Map.add lbl' s g in
    815         (g, rs)
    816       | RTLabs.St_store(q, a1, a2, l) ->
    817         let (lbl', g, rs, r1) = load_arg a1 lbl g rs in
    818         let (lbl', g, rs, r2) = load_arg a2 lbl' g rs in
    819         let s = RTLabs.St_store (q, RTLabs.Reg r1, RTLabs.Reg r2, l) in
    820         let g = Label.Map.add lbl' s g in
    821         (g, rs)
    822       | RTLabs.St_load (q, a, r, l) ->
    823         let (lbl', g, rs, r1) = load_arg a lbl g rs in
    824         let s = RTLabs.St_load (q, RTLabs.Reg r1, r, l) in
    825         let g = Label.Map.add lbl' s g in
    826         (g, rs)
    827       | _ -> (g, rs) in
    828   let g = def.RTLabs.f_graph in
    829   let (g, rs) = Label.Map.fold f g (g, []) in
    830   let locals = List.rev_append rs def.RTLabs.f_locals in
    831   { def with RTLabs.f_graph = g; RTLabs.f_locals = locals }
     707(* let remove_non_int_immediates def = *)
     708(*   let load_arg a lbl g rs = match a with *)
     709(*     | RTLabs.Reg r -> (lbl, g, rs, r) *)
     710(*     | RTLabs.Imm ((AST.Cst_stack _ | AST.Cst_addrsymbol _) as c, t) -> *)
     711(*       let new_l = Label.Gen.fresh def.RTLabs.f_luniverse in *)
     712(*       let new_r = Register.fresh def.RTLabs.f_runiverse in *)
     713(*       let g = Label.Map.add lbl (RTLabs.St_cst (new_r, c, new_l)) g in *)
     714(*       (new_l, g, (new_r, t) :: rs, new_r) in  *)
     715(*   let f lbl stmt (g, rs) = *)
     716(*     match stmt with *)
     717(*       | RTLabs.St_op2(op, r, a1, a2, l) -> *)
     718(*      let (lbl', g, rs, r1) = load_arg a1 lbl g rs in *)
     719(*         let (lbl', g, rs, r2) = load_arg a2 lbl' g rs in *)
     720(*         let s = RTLabs.St_op2 (op, r, RTLabs.Reg r1, RTLabs.Reg r2, l) in *)
     721(*      let g = Label.Map.add lbl' s g in *)
     722(*      (g, rs) *)
     723(*       | RTLabs.St_store(q, a1, a2, l) -> *)
     724(*         let (lbl', g, rs, r1) = load_arg a1 lbl g rs in *)
     725(*         let (lbl', g, rs, r2) = load_arg a2 lbl' g rs in *)
     726(*         let s = RTLabs.St_store (q, RTLabs.Reg r1, RTLabs.Reg r2, l) in *)
     727(*         let g = Label.Map.add lbl' s g in *)
     728(*         (g, rs) *)
     729(*       | RTLabs.St_load (q, a, r, l) -> *)
     730(*         let (lbl', g, rs, r1) = load_arg a lbl g rs in *)
     731(*         let s = RTLabs.St_load (q, RTLabs.Reg r1, r, l) in *)
     732(*         let g = Label.Map.add lbl' s g in *)
     733(*         (g, rs) *)
     734(*       | _ -> (g, rs) in *)
     735(*   let g = def.RTLabs.f_graph in *)
     736(*   let (g, rs) = Label.Map.fold f g (g, []) in *)
     737(*   let locals = List.rev_append rs def.RTLabs.f_locals in *)
     738(*   { def with RTLabs.f_graph = g; RTLabs.f_locals = locals } *)
    832739 
    833740let translate_internal def =
    834   let def = remove_immediates def in
    835741  let runiverse = def.RTLabs.f_runiverse in
    836742  let lenv =
     
    838744      (def.RTLabs.f_params @ def.RTLabs.f_locals) def.RTLabs.f_result in
    839745  let set_of_list l = List.fold_right Register.Set.add l Register.Set.empty in
    840   let params = map_list_local_env lenv (List.map fst def.RTLabs.f_params) in
    841   let locals = map_list_local_env lenv (List.map fst def.RTLabs.f_locals) in
     746  let params = map_list_local_env_reg lenv (List.map fst def.RTLabs.f_params) in
     747  let locals = map_list_local_env_reg lenv (List.map fst def.RTLabs.f_locals) in
    842748  let locals = set_of_list locals in
    843749  let result = match def.RTLabs.f_result with
    844750    | None -> []
    845     | Some (r, _) -> find_local_env r lenv in
     751    | Some (r, _) -> find_local_env_reg r lenv in
    846752  let res =
    847753    { RTL.f_luniverse = def.RTLabs.f_luniverse ;
Note: See TracChangeset for help on using the changeset viewer.