src/LIN/LINToASM.ml

   1
   2 (** This module translates a [LIN] program into a [ASM] program. *)
   3
   4
   5 let error_prefix = "LIN to ASM"
   6 let error s = Error.global_error error_prefix s
   7
   8
   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
  22 (* Fetch the labels found in a LIN program. *)
  23
  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
  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   try BitVectors.vect_of_int i' size
  53   with Invalid_argument _ (* "BitVectors.vect_of_int: size not big enough" *) ->
  54     error
  55       (Printf.sprintf "integer %d is too big to convert using %d bits. Maybe the stack frame of a function is too big."
  56          i (size_of_vect_size size))
  57
  58 let byte_of_int i = vect_of_int i `Eight
  59 let data_of_int i = `DATA (byte_of_int i)
  60 let data16_of_int i = `DATA16 (vect_of_int i `Sixteen)
  61 let acc_addr = I8051.reg_addr I8051.a
  62 let dpl_addr = I8051.reg_addr I8051.dpl
  63 let dph_addr = I8051.reg_addr I8051.dph
  64 let st0_addr = I8051.reg_addr I8051.st0
  65 let st1_addr = I8051.reg_addr I8051.st1
  66
  67
  68 let translate_statement env = function
  69   | LIN.St_goto lbl -> [`Jmp lbl]
  70   | LIN.St_label lbl -> [`Label lbl]
  71   | LIN.St_comment _ -> []
  72   | LIN.St_cost lbl ->
  73     (* TODO: hack! Need to make the difference between cost labels and regular
  74        labels. *)
  75     [`Cost lbl ; `NOP]
  76   | LIN.St_int (r, i) ->
  77     [`MOV (`U3 (I8051.reg_addr r, data_of_int i))]
  78   | LIN.St_pop ->
  79     [`POP acc_addr]
  80   | LIN.St_push ->
  81     [`PUSH acc_addr]
  82   | LIN.St_addr x when List.mem x env.externals ->
  83     (* HACK! for Lustre support: externals appears in the code but are not
  84        used. *)
  85     [`MOV (`U4 (`DPTR, data16_of_int 0))]
  86   (* error ("Primitive or external " ^ x ^ " is not supported.") *)
  87   | LIN.St_addr x ->
  88     [`Mov (`DPTR, x)]
  89   | LIN.St_from_acc r ->
  90     [`MOV (`U3 (I8051.reg_addr r, `A))]
  91   | LIN.St_to_acc r ->
  92     [`MOV (`U1 (`A, I8051.reg_addr r))]
  93   | LIN.St_opaccs I8051.Mul ->
  94     [`MUL (`A, `B)]
  95   | LIN.St_opaccs I8051.DivuModu ->
  96     [`DIV (`A, `B)]
  97   | LIN.St_op1 I8051.Cmpl ->
  98     [`CPL `A]
  99   | LIN.St_op1 I8051.Inc ->
 100     [`INC `A]
 101   | LIN.St_op2 (I8051.Add, r) ->
 102     [`ADD (`A, I8051.reg_addr r)]
 103   | LIN.St_op2 (I8051.Addc, r) ->
 104     [`ADDC (`A, I8051.reg_addr r)]
 105   | LIN.St_op2 (I8051.Sub, r) ->
 106     [`SUBB (`A, I8051.reg_addr r)]
 107   | LIN.St_op2 (I8051.And, r) ->
 108     [`ANL (`U1 (`A, I8051.reg_addr r))]
 109   | LIN.St_op2 (I8051.Or, r) ->
 110     [`ORL (`U1 (`A, I8051.reg_addr r))]
 111   | LIN.St_op2 (I8051.Xor, r) ->
 112     [`XRL (`U1 (`A, I8051.reg_addr r))]
 113   | LIN.St_clear_carry ->
 114     [`CLR `C]
 115   | LIN.St_set_carry ->
 116     [`SETB `C]
 117   | LIN.St_load ->
 118     [`MOVX (`U1 (`A, `EXT_IND_DPTR))]
 119   | LIN.St_store ->
 120     [`MOVX (`U2 (`EXT_IND_DPTR, `A))]
 121   | LIN.St_call_id x when List.mem x env.externals ->
 122     (* HACK! for Lustre support: externals appears in the code but are not
 123        used. *)
 124     []
 125   (* error ("Primitive or external " ^ x ^ " is not supported.") *)
 126   | LIN.St_call_id f ->
 127     [`Call f]
 128   | LIN.St_call_ptr ->
 129     let lbl = env.fresh () in
 130     [`MOV (`U3 (st0_addr, dpl_addr)) ; (* save DPL *)
 131      `MOV (`U3 (st1_addr, dph_addr)) ; (* save DPH *)
 132      `Mov (`DPTR, lbl) ;               (* DPTR <- return address *)
 133      `PUSH dpl_addr ;                  (* push DPL *)
 134      `PUSH dph_addr ;                  (* push DPH *)
 135      `MOV (`U3 (dpl_addr, st0_addr)) ; (* restore DPL *)
 136      `MOV (`U3 (dph_addr, st1_addr)) ; (* restore DPH *)
 137      `MOV (`U1 (`A, data_of_int 0)) ;  (* A <- 0 *)
 138      `JMP `IND_DPTR ;                  (* jump to A+DPTR *)
 139      `Label lbl]                       (* return address *)
 140   | LIN.St_condacc lbl ->
 141     [`WithLabel (`JNZ (`Label lbl))]
 142   | LIN.St_return ->
 143     [`RET]
 144
 145 let translate_code env code =
 146   List.flatten (List.map (translate_statement env) code)
 147
 148
 149 let translate_fun_def env (id, def) =
 150   let code = match def with
 151   | LIN.F_int code -> translate_code env code
 152   | LIN.F_ext ext -> [`NOP] in
 153   ((`Label id) :: code)
 154
 155 let translate_functs env main functs =
 156   let preamble = match main with
 157     | None -> []
 158     | Some main ->
 159       [`MOV (`U3 (`DIRECT (byte_of_int I8051.isp_addr),
 160                   data_of_int I8051.isp_init)) ;
 161        `MOV (`U3 (`DIRECT (byte_of_int I8051.spl_addr),
 162                   data_of_int I8051.spl_init)) ;
 163        `MOV (`U3 (`DIRECT (byte_of_int I8051.sph_addr),
 164                   data_of_int I8051.sph_init)) ;
 165        `Call main ;
 166        `Label env.exit_lbl ; `Jmp env.exit_lbl] in
 167   preamble @ (List.flatten (List.map (translate_fun_def env) functs))
 168
 169
 170 let init_env p =
 171   let f_externals (id, def) = match def with LIN.F_ext _ -> [id] | _ -> [] in
 172   let externals =
 173     List.fold_left (fun res def -> res @ (f_externals def)) [] p.LIN.functs in
 174   let prog_lbls = prog_labels p in
 175   let exit_lbl = Label.Gen.fresh_prefix prog_lbls "_exit" in
 176   let fresh = Label.make_fresh prog_lbls "_call_ret" in
 177   make_env externals exit_lbl fresh
 178
 179
 180 (* Translating programs.
 181
 182    Global variables are associated an offset from the base of the external
 183    memory. *)
 184
 185 let translate p =
 186   let env = init_env p in
 187   let p =
 188     { ASM.ppreamble = p.LIN.vars ;
 189       ASM.pexit_label = env.exit_lbl ;
 190       ASM.pcode = translate_functs env p.LIN.main p.LIN.functs ;
 191       ASM.phas_main = p.LIN.main <> None } in
 192   ASMInterpret.assembly p