[486] | 1 | |
---|
| 2 | (** This module translates a [LIN] program into a [ASM] program. *) |
---|
| 3 | |
---|
| 4 | |
---|
| 5 | let statement_labels = function |
---|
| 6 | | LIN.St_goto lbl |
---|
| 7 | | LIN.St_label lbl |
---|
| 8 | | LIN.St_cost lbl |
---|
| 9 | | LIN.St_condacc lbl -> Label.Set.singleton lbl |
---|
| 10 | | _ -> Label.Set.empty |
---|
| 11 | |
---|
| 12 | let funct_labels (_, fun_def) = match fun_def with |
---|
| 13 | | LIN.F_int stmts -> |
---|
| 14 | let f labels stmt = Label.Set.union labels (statement_labels stmt) in |
---|
| 15 | List.fold_left f Label.Set.empty stmts |
---|
| 16 | | _ -> Label.Set.empty |
---|
| 17 | |
---|
| 18 | (* Fetch the labels found in a LIN program. *) |
---|
| 19 | |
---|
| 20 | let prog_labels p = |
---|
| 21 | let f labels funct = Label.Set.union labels (funct_labels funct) in |
---|
| 22 | List.fold_left f Label.Set.empty p.LIN.functs |
---|
| 23 | |
---|
| 24 | |
---|
| 25 | let byte_of_int i = BitVectors.vect_of_int i `Eight |
---|
| 26 | let data_of_int i = `DATA (byte_of_int i) |
---|
| 27 | let data16_of_int i = `DATA16 (BitVectors.vect_of_int i `Sixteen) |
---|
| 28 | let acc_addr = I8051.reg_addr I8051.a |
---|
| 29 | |
---|
| 30 | |
---|
| 31 | let translate_statement glbls_addr = function |
---|
| 32 | | LIN.St_goto lbl -> [`Jmp lbl] |
---|
| 33 | | LIN.St_label lbl -> [`Label lbl] |
---|
| 34 | | LIN.St_comment _ -> [] |
---|
| 35 | | LIN.St_cost lbl -> [`Cost lbl] |
---|
| 36 | | LIN.St_int (r, i) -> |
---|
| 37 | [`MOV (`U3 (I8051.reg_addr r, data_of_int i))] |
---|
| 38 | | LIN.St_pop -> |
---|
| 39 | [`POP acc_addr] |
---|
| 40 | | LIN.St_push -> |
---|
| 41 | [`PUSH acc_addr] |
---|
| 42 | | LIN.St_addr x -> |
---|
| 43 | [`MOV (`U4 (`DPTR, data16_of_int (List.assoc x glbls_addr)))] |
---|
| 44 | | LIN.St_from_acc r -> |
---|
| 45 | [`MOV (`U3 (I8051.reg_addr r, `A))] |
---|
| 46 | | LIN.St_to_acc r -> |
---|
| 47 | [`MOV (`U1 (`A, I8051.reg_addr r))] |
---|
| 48 | | LIN.St_opaccs I8051.Mul -> |
---|
| 49 | [`MUL (`A, `B)] |
---|
| 50 | | LIN.St_opaccs I8051.Divu -> |
---|
| 51 | [`DIV (`A, `B)] |
---|
| 52 | | LIN.St_opaccs I8051.Modu -> |
---|
| 53 | assert false (* Should have been translated before. *) |
---|
| 54 | | LIN.St_op1 I8051.Cmpl -> |
---|
| 55 | [`CPL `A] |
---|
| 56 | | LIN.St_op1 I8051.Inc -> |
---|
| 57 | [`INC `A] |
---|
| 58 | | LIN.St_op2 (I8051.Add, r) -> |
---|
| 59 | [`ADD (`A, I8051.reg_addr r)] |
---|
| 60 | | LIN.St_op2 (I8051.Addc, r) -> |
---|
| 61 | [`ADDC (`A, I8051.reg_addr r)] |
---|
| 62 | | LIN.St_op2 (I8051.Sub, r) -> |
---|
| 63 | [`SUBB (`A, I8051.reg_addr r)] |
---|
| 64 | | LIN.St_op2 (I8051.And, r) -> |
---|
| 65 | [`ANL (`U1 (`A, I8051.reg_addr r))] |
---|
| 66 | | LIN.St_op2 (I8051.Or, r) -> |
---|
| 67 | [`ORL (`U1 (`A, I8051.reg_addr r))] |
---|
| 68 | | LIN.St_op2 (I8051.Xor, r) -> |
---|
| 69 | [`XRL (`U1 (`A, I8051.reg_addr r))] |
---|
| 70 | | LIN.St_clear_carry -> |
---|
| 71 | [`CLR `C] |
---|
| 72 | | LIN.St_load -> |
---|
| 73 | [`MOVX (`U1 (`A, `EXT_IND_DPTR))] |
---|
| 74 | | LIN.St_store -> |
---|
| 75 | [`MOVX (`U2 (`EXT_IND_DPTR, `A))] |
---|
| 76 | | LIN.St_call_id f -> |
---|
| 77 | [`Call f] |
---|
| 78 | | LIN.St_condacc lbl -> |
---|
| 79 | assert false (* particular case treated in translate_code *) |
---|
| 80 | | LIN.St_return -> |
---|
| 81 | [`RET] |
---|
| 82 | |
---|
| 83 | (** [remove_following_cost_label lbl code] first finds the label instruction of |
---|
| 84 | [lbl]. It supposes that [lbl] is the destination of a conditional |
---|
| 85 | statement. Thus, it is followed by a cost instruction. The result is then |
---|
| 86 | this cost label and the code without this particular cost instruction. *) |
---|
| 87 | |
---|
| 88 | let rec remove_following_cost_label lbl = function |
---|
| 89 | | [] -> assert false (* wrong labelling *) |
---|
| 90 | | LIN.St_label lbl' :: LIN.St_cost cost_lbl :: code when lbl' = lbl -> |
---|
| 91 | (cost_lbl, LIN.St_label lbl' :: code) |
---|
| 92 | | stmt :: code -> |
---|
| 93 | let (cost_lbl, code') = remove_following_cost_label lbl code in |
---|
| 94 | (cost_lbl, stmt :: code') |
---|
| 95 | |
---|
| 96 | let translate_code tmp_universe glbls_addr = |
---|
| 97 | let rec aux = function |
---|
| 98 | | [] -> [] |
---|
| 99 | | LIN.St_condacc lbl :: code -> |
---|
| 100 | (* The conditional statement requires a special treatment. See the .mli |
---|
| 101 | for details. We have to pay a special attention to the cost labels, so |
---|
| 102 | as to not introduce an imprecision. *) |
---|
| 103 | let (cost_lbl, code') = remove_following_cost_label lbl code in |
---|
| 104 | let tmp_lbl = Label.Gen.fresh tmp_universe in |
---|
| 105 | [`WithLabel (`JZ (`Label tmp_lbl)) ; |
---|
| 106 | `Cost cost_lbl ; `Jmp lbl ; |
---|
| 107 | `Label tmp_lbl] @ |
---|
| 108 | (aux code') |
---|
| 109 | | stmt :: code -> (translate_statement glbls_addr stmt) @ (aux code) in |
---|
| 110 | aux |
---|
| 111 | |
---|
| 112 | |
---|
| 113 | let translate_fun_def tmp_universe glbls_addr (id, def) = match def with |
---|
| 114 | | LIN.F_int code -> |
---|
| 115 | (`Label id) :: (translate_code tmp_universe glbls_addr code) |
---|
| 116 | | _ -> [] |
---|
| 117 | |
---|
| 118 | let translate_functs tmp_universe glbls_addr exit_label main functs = |
---|
| 119 | let preamble = match main with |
---|
| 120 | | None -> [] |
---|
| 121 | | Some main -> [`Call main ; `Label exit_label ; `Jmp exit_label] in |
---|
| 122 | preamble @ |
---|
| 123 | (List.flatten (List.map (translate_fun_def tmp_universe glbls_addr) functs)) |
---|
| 124 | |
---|
| 125 | |
---|
| 126 | let globals_addr l = |
---|
| 127 | let f (res, offset) (x, size) = ((x, offset) :: res, offset + size) in |
---|
| 128 | fst (List.fold_left f ([], 0) l) |
---|
| 129 | |
---|
| 130 | |
---|
| 131 | (* Move the first cost label of each function at the beginning of the |
---|
| 132 | function. Indeed, some preamble instructions (such as frame creation) might |
---|
| 133 | get in the way. *) |
---|
| 134 | |
---|
| 135 | let move_first_cost_label_up_code = |
---|
| 136 | let rec aux preamble = function |
---|
| 137 | | [] -> preamble |
---|
| 138 | | LIN.St_cost lbl :: code -> LIN.St_cost lbl :: preamble @ code |
---|
| 139 | | inst :: code -> aux (preamble @ [inst]) code |
---|
| 140 | in aux [] |
---|
| 141 | |
---|
| 142 | let move_first_cost_label_up_funct (id, def) = |
---|
| 143 | let def' = match def with |
---|
| 144 | | LIN.F_int int_def -> LIN.F_int (move_first_cost_label_up_code int_def) |
---|
| 145 | | _ -> def in |
---|
| 146 | (id, def') |
---|
| 147 | |
---|
| 148 | let move_first_cost_label_up p = |
---|
| 149 | { p with LIN.functs = List.map move_first_cost_label_up_funct p.LIN.functs } |
---|
| 150 | |
---|
| 151 | |
---|
| 152 | (* Translating programs. |
---|
| 153 | |
---|
| 154 | A fresh universe is create, in order to create an exit label and fresh labels |
---|
| 155 | for the expansion of conditional instructions (see the .mli). |
---|
| 156 | |
---|
| 157 | Global variables are associated an offset from the base of the external |
---|
| 158 | memory. *) |
---|
| 159 | |
---|
| 160 | let translate p = |
---|
| 161 | let prog_lbls = prog_labels p in |
---|
| 162 | let exit_label = Label.Gen.fresh_prefix prog_lbls "_exit" in |
---|
| 163 | let fresh_tmp = |
---|
| 164 | Label.Gen.fresh_prefix (Label.Set.add exit_label prog_lbls) "_tmp_lbl" in |
---|
| 165 | let tmp_universe = Label.Gen.new_universe fresh_tmp in |
---|
| 166 | let glbls_addr = globals_addr p.LIN.vars in |
---|
| 167 | { ASM.preamble = p.LIN.vars ; |
---|
| 168 | ASM.exit_label = exit_label ; |
---|
| 169 | ASM.code = |
---|
| 170 | translate_functs tmp_universe glbls_addr exit_label p.LIN.main |
---|
| 171 | p.LIN.functs ; |
---|
| 172 | ASM.has_main = p.LIN.main <> None } |
---|