[486] | 1 | |
---|
| 2 | (** This module translates a [LIN] program into a [ASM] program. *) |
---|
| 3 | |
---|
| 4 | |
---|
[818] | 5 | let error_prefix = "LIN to ASM" |
---|
| 6 | let error s = Error.global_error error_prefix s |
---|
| 7 | |
---|
| 8 | |
---|
[1488] | 9 | (* Translation environment *) |
---|
| 10 | |
---|
| 11 | type env = |
---|
| 12 | { externals : AST.ident list ; |
---|
| 13 | exit_lbl : Label.t ; |
---|
| 14 | fresh : unit -> string } |
---|
| 15 | |
---|
| 16 | let make_env externals exit_lbl fresh = |
---|
| 17 | { externals = externals ; |
---|
| 18 | exit_lbl = exit_lbl ; |
---|
| 19 | fresh = fresh } |
---|
| 20 | |
---|
| 21 | |
---|
[741] | 22 | (* Fetch the labels found in a LIN program. *) |
---|
| 23 | |
---|
[486] | 24 | let statement_labels = function |
---|
| 25 | | LIN.St_goto lbl |
---|
| 26 | | LIN.St_label lbl |
---|
| 27 | | LIN.St_cost lbl |
---|
| 28 | | LIN.St_condacc lbl -> Label.Set.singleton lbl |
---|
| 29 | | _ -> Label.Set.empty |
---|
| 30 | |
---|
| 31 | let funct_labels (_, fun_def) = match fun_def with |
---|
| 32 | | LIN.F_int stmts -> |
---|
| 33 | let f labels stmt = Label.Set.union labels (statement_labels stmt) in |
---|
| 34 | List.fold_left f Label.Set.empty stmts |
---|
| 35 | | _ -> Label.Set.empty |
---|
| 36 | |
---|
| 37 | let prog_labels p = |
---|
| 38 | let f labels funct = Label.Set.union labels (funct_labels funct) in |
---|
| 39 | List.fold_left f Label.Set.empty p.LIN.functs |
---|
| 40 | |
---|
| 41 | |
---|
[741] | 42 | let size_of_vect_size = function |
---|
| 43 | | `Four -> 4 |
---|
| 44 | | `Seven -> 7 |
---|
| 45 | | `Eight -> 8 |
---|
| 46 | | `Eleven -> 11 |
---|
| 47 | | `Sixteen -> 16 |
---|
| 48 | |
---|
| 49 | let vect_of_int i size = |
---|
| 50 | let i' = |
---|
| 51 | if i < 0 then (MiscPottier.pow 2 (size_of_vect_size size)) + i else i in |
---|
| 52 | BitVectors.vect_of_int i' size |
---|
| 53 | |
---|
| 54 | let byte_of_int i = vect_of_int i `Eight |
---|
[486] | 55 | let data_of_int i = `DATA (byte_of_int i) |
---|
[741] | 56 | let data16_of_int i = `DATA16 (vect_of_int i `Sixteen) |
---|
[486] | 57 | let acc_addr = I8051.reg_addr I8051.a |
---|
[1491] | 58 | let dpl_addr = I8051.reg_addr I8051.dpl |
---|
| 59 | let dph_addr = I8051.reg_addr I8051.dph |
---|
| 60 | let st0_addr = I8051.reg_addr I8051.st0 |
---|
| 61 | let st1_addr = I8051.reg_addr I8051.st1 |
---|
[486] | 62 | |
---|
| 63 | |
---|
[1491] | 64 | let translate_statement env = function |
---|
[486] | 65 | | LIN.St_goto lbl -> [`Jmp lbl] |
---|
| 66 | | LIN.St_label lbl -> [`Label lbl] |
---|
| 67 | | LIN.St_comment _ -> [] |
---|
[1488] | 68 | | LIN.St_cost lbl -> |
---|
| 69 | (* TODO: hack! Need to make the difference between cost labels and regular |
---|
| 70 | labels. *) |
---|
| 71 | [`Cost lbl ; `NOP] |
---|
[486] | 72 | | LIN.St_int (r, i) -> |
---|
| 73 | [`MOV (`U3 (I8051.reg_addr r, data_of_int i))] |
---|
| 74 | | LIN.St_pop -> |
---|
| 75 | [`POP acc_addr] |
---|
| 76 | | LIN.St_push -> |
---|
| 77 | [`PUSH acc_addr] |
---|
[1488] | 78 | | LIN.St_addr x when List.mem x env.externals -> |
---|
| 79 | error ("Primitive or external " ^ x ^ " is not supported.") |
---|
| 80 | | LIN.St_addr x -> |
---|
| 81 | [`Mov (`DPTR, x)] |
---|
[486] | 82 | | LIN.St_from_acc r -> |
---|
| 83 | [`MOV (`U3 (I8051.reg_addr r, `A))] |
---|
| 84 | | LIN.St_to_acc r -> |
---|
| 85 | [`MOV (`U1 (`A, I8051.reg_addr r))] |
---|
| 86 | | LIN.St_opaccs I8051.Mul -> |
---|
| 87 | [`MUL (`A, `B)] |
---|
[818] | 88 | | LIN.St_opaccs I8051.DivuModu -> |
---|
[486] | 89 | [`DIV (`A, `B)] |
---|
| 90 | | LIN.St_op1 I8051.Cmpl -> |
---|
| 91 | [`CPL `A] |
---|
| 92 | | LIN.St_op1 I8051.Inc -> |
---|
| 93 | [`INC `A] |
---|
| 94 | | LIN.St_op2 (I8051.Add, r) -> |
---|
| 95 | [`ADD (`A, I8051.reg_addr r)] |
---|
| 96 | | LIN.St_op2 (I8051.Addc, r) -> |
---|
| 97 | [`ADDC (`A, I8051.reg_addr r)] |
---|
| 98 | | LIN.St_op2 (I8051.Sub, r) -> |
---|
| 99 | [`SUBB (`A, I8051.reg_addr r)] |
---|
| 100 | | LIN.St_op2 (I8051.And, r) -> |
---|
| 101 | [`ANL (`U1 (`A, I8051.reg_addr r))] |
---|
| 102 | | LIN.St_op2 (I8051.Or, r) -> |
---|
| 103 | [`ORL (`U1 (`A, I8051.reg_addr r))] |
---|
| 104 | | LIN.St_op2 (I8051.Xor, r) -> |
---|
| 105 | [`XRL (`U1 (`A, I8051.reg_addr r))] |
---|
| 106 | | LIN.St_clear_carry -> |
---|
| 107 | [`CLR `C] |
---|
[818] | 108 | | LIN.St_set_carry -> |
---|
| 109 | [`SETB `C] |
---|
[486] | 110 | | LIN.St_load -> |
---|
| 111 | [`MOVX (`U1 (`A, `EXT_IND_DPTR))] |
---|
| 112 | | LIN.St_store -> |
---|
| 113 | [`MOVX (`U2 (`EXT_IND_DPTR, `A))] |
---|
[1491] | 114 | | LIN.St_call_id x when List.mem x env.externals -> |
---|
| 115 | error ("Primitive or external " ^ x ^ " is not supported.") |
---|
[486] | 116 | | LIN.St_call_id f -> |
---|
| 117 | [`Call f] |
---|
[1488] | 118 | | LIN.St_call_ptr -> |
---|
| 119 | let lbl = env.fresh () in |
---|
[1491] | 120 | [`MOV (`U3 (st0_addr, dpl_addr)) ; |
---|
| 121 | `MOV (`U3 (st1_addr, dph_addr)) ; |
---|
| 122 | `Mov (`DPTR, lbl) ; |
---|
| 123 | `PUSH dpl_addr ; |
---|
| 124 | `PUSH dph_addr ; |
---|
| 125 | `PUSH st0_addr ; |
---|
| 126 | `PUSH st1_addr ; |
---|
| 127 | `RET ; |
---|
| 128 | `Label lbl] |
---|
[486] | 129 | | LIN.St_condacc lbl -> |
---|
[685] | 130 | [`WithLabel (`JNZ (`Label lbl))] |
---|
[486] | 131 | | LIN.St_return -> |
---|
| 132 | [`RET] |
---|
| 133 | |
---|
[1491] | 134 | let translate_code env code = |
---|
[1488] | 135 | List.flatten (List.map (translate_statement env) code) |
---|
[486] | 136 | |
---|
| 137 | |
---|
[1488] | 138 | let translate_fun_def env (id, def) = |
---|
[1462] | 139 | let code = match def with |
---|
[1488] | 140 | | LIN.F_int code -> translate_code env code |
---|
[1462] | 141 | | LIN.F_ext ext -> [`NOP] in |
---|
[1488] | 142 | ((`Label id) :: code) |
---|
[1462] | 143 | |
---|
[1488] | 144 | let translate_functs env main functs = |
---|
[486] | 145 | let preamble = match main with |
---|
| 146 | | None -> [] |
---|
[818] | 147 | | Some main -> |
---|
| 148 | [`MOV (`U3 (`DIRECT (byte_of_int I8051.isp_addr), |
---|
| 149 | data_of_int I8051.isp_init)) ; |
---|
[1488] | 150 | `MOV (`U3 (`DIRECT (byte_of_int I8051.spl_addr), |
---|
| 151 | data_of_int I8051.spl_init)) ; |
---|
| 152 | `MOV (`U3 (`DIRECT (byte_of_int I8051.sph_addr), |
---|
| 153 | data_of_int I8051.sph_init)) ; |
---|
[818] | 154 | `Call main ; |
---|
[1488] | 155 | `Label env.exit_lbl ; `Jmp env.exit_lbl] in |
---|
| 156 | preamble @ (List.flatten (List.map (translate_fun_def env) functs)) |
---|
[486] | 157 | |
---|
| 158 | |
---|
[1488] | 159 | let init_env p = |
---|
| 160 | let f_externals (id, def) = match def with LIN.F_ext _ -> [id] | _ -> [] in |
---|
| 161 | let externals = |
---|
| 162 | List.fold_left (fun res def -> res @ (f_externals def)) [] p.LIN.functs in |
---|
| 163 | let prog_lbls = prog_labels p in |
---|
| 164 | let exit_lbl = Label.Gen.fresh_prefix prog_lbls "_exit" in |
---|
| 165 | let fresh = Label.make_fresh prog_lbls "_call_ret" in |
---|
| 166 | make_env externals exit_lbl fresh |
---|
[486] | 167 | |
---|
| 168 | |
---|
| 169 | (* Translating programs. |
---|
| 170 | |
---|
| 171 | Global variables are associated an offset from the base of the external |
---|
| 172 | memory. *) |
---|
| 173 | |
---|
| 174 | let translate p = |
---|
[1488] | 175 | let env = init_env p in |
---|
[619] | 176 | let p = |
---|
| 177 | { ASM.ppreamble = p.LIN.vars ; |
---|
[1488] | 178 | ASM.pexit_label = env.exit_lbl ; |
---|
| 179 | ASM.pcode = translate_functs env p.LIN.main p.LIN.functs ; |
---|
[619] | 180 | ASM.phas_main = p.LIN.main <> None } in |
---|
| 181 | ASMInterpret.assembly p |
---|