src/common/primitive.ml

   1
   2 (** These are the functions provided by the runtime system. *)
   3
   4
   5 let error_prefix = "Primitives"
   6 let error s = Error.global_error error_prefix s
   7 let warning s = Error.warning error_prefix s
   8
   9 let print_schar =
  10   ("print_schar", "extern void print_schar(signed char);")
  11 let print_uchar =
  12   ("print_uchar", "extern void print_uchar(unsigned char);")
  13 let print_sshort =
  14   ("print_sshort", "extern void print_sshort(signed short);")
  15 let print_ushort =
  16   ("print_ushort", "extern void print_ushort(unsigned short);")
  17 let print_sint =
  18   ("print_sint", "extern void print_sint(signed int);")
  19 let print_uint =
  20   ("print_uint", "extern void print_uint(unsigned int);")
  21 let scan_int =
  22   ("scan_int", "extern int scan_int(void);")
  23 let alloc =
  24   ("alloc", "extern int* alloc(int);")
  25 let newline =
  26   ("newline", "extern void newline(void);")
  27 let space =
  28   ("space", "extern void space(void);")
  29 let rand_bool =
  30   ("rand_bool", "extern int rand_bool(void);")
  31 let rand_int =
  32   ("rand_int", "extern int rand_int(int);")
  33
  34 let ident = fst
  35
  36 let proto = snd
  37
  38 let primitives_list =
  39   [print_schar ; print_uchar ; print_sshort ; print_ushort ;
  40    print_sint ; print_uint ; scan_int ; alloc ; newline ; space ;
  41    rand_bool ; rand_int]
  42
  43
  44 let args_byte_size = function
  45   | s when s = ident print_schar || s = ident print_uchar -> AST.QInt 1
  46   | s when s = ident print_sshort || s = ident print_ushort -> AST.QInt 2
  47   | s when s = ident print_sint || s = ident print_uint || s = ident rand_int ->
  48     AST.QInt 4
  49   | s when s = ident scan_int || s = ident newline || s = ident space ||
  50         s = ident rand_bool   ->
  51     AST.QInt 0
  52   | s when s = ident alloc -> AST.QPtr
  53   | s -> error ("unknown primitive " ^ s ^ ".")
  54
  55
  56 let primitives =
  57   List.fold_left (fun res f -> StringTools.Set.add f res) StringTools.Set.empty
  58     (List.map ident primitives_list)
  59
  60 let is_primitive f = StringTools.Set.mem f primitives
  61
  62
  63 module Interpret (M : Memory.S) = struct
  64
  65   type res = V of M.Value.t list | A of M.Value.address
  66
  67   let print_integer_primitives =
  68     List.map ident
  69       [print_schar ; print_uchar ; print_sshort ; print_ushort ;
  70        print_sint ; print_uint]
  71
  72   let is_print_integer_primitive f = List.mem f print_integer_primitives
  73
  74   let print_integer_primitive_funs = function
  75     | f when f = ident print_schar ->
  76       (IntValue.Int8.cast, IntValue.Int8.to_signed_repr)
  77     | f when f = ident print_uchar ->
  78       (IntValue.Int8.cast, IntValue.Int8.to_unsigned_repr)
  79     | f when f = ident print_sshort ->
  80       (IntValue.Int16.cast, IntValue.Int16.to_signed_repr)
  81     | f when f = ident print_ushort ->
  82       (IntValue.Int16.cast, IntValue.Int16.to_unsigned_repr)
  83     | f when f = ident print_sint ->
  84       (IntValue.Int32.cast, IntValue.Int32.to_signed_repr)
  85     | f when f = ident print_uint ->
  86       (IntValue.Int32.cast, IntValue.Int32.to_unsigned_repr)
  87     | f -> error ("unknown integer printing primitive " ^ f ^ ".")
  88
  89   let make_int_value vs = IntValue.Int32.merge (List.map M.Value.to_int_repr vs)
  90
  91   let print_integer f mem vs =
  92     let (cast, to_int_repr) = print_integer_primitive_funs f in
  93     let i = make_int_value vs in
  94     let i = cast i in
  95     let i = to_int_repr i in
  96     Printf.printf "%s%!" (IntValue.print_int_repr i) ;
  97     (mem, V [])
  98
  99   let are_ints args =
 100     let f res v = res && M.Value.is_int v in
 101     List.fold_left f true args
 102
 103   let res_of_int i =
 104     let i = IntValue.Int32.of_int i in
 105     let is = IntValue.Int32.break i (4 / M.Value.int_size) in
 106     List.map M.Value.of_int_repr is
 107
 108   let t mem f = function
 109     | args when is_print_integer_primitive f && are_ints args ->
 110       print_integer f mem args
 111     | _ when f = ident scan_int ->
 112       Printf.printf ": %!" ;
 113       (mem, V (res_of_int (int_of_string (read_line ()))))
 114     | args when f = ident alloc && are_ints args ->
 115       let size = IntValue.Int32.to_int (make_int_value args) in
 116       let (mem, addr) = M.alloc mem size in
 117       (mem, A addr)
 118     | _ when f = ident newline ->
 119       Printf.printf "\n%!" ;
 120       (mem, V [])
 121     | _ when f = ident space ->
 122       Printf.printf " %!" ;
 123       (mem, V [])
 124     | _ when f = ident rand_bool ->
 125       (mem, V (res_of_int (Random.int 2)))
 126     | args when f = ident rand_int && are_ints args ->
 127       let i = IntValue.Int32.to_int (make_int_value args) in
 128       (mem, V (res_of_int (Random.int i)))
 129     | _ -> error ("unknown primitive " ^ f ^ " or bad arguments.")
 130 end
 131
 132
 133 let print_signedness = function
 134   | AST.Signed -> "s"
 135   | AST.Unsigned -> "u"
 136
 137 let print_size = string_of_int
 138
 139 let print_type = function
 140   | AST.Sig_int (size, sign) ->
 141     "int" ^ (print_size size) ^ (print_signedness sign)
 142   | AST.Sig_float (size, sign) ->
 143     "float" ^ (print_size size) ^ (print_signedness sign)
 144   | AST.Sig_offset -> "offset"
 145   | AST.Sig_ptr -> "ptr"
 146
 147 let print_type_return = function
 148   | AST.Type_ret t -> print_type t
 149   | AST.Type_void -> "void"
 150
 151 let rec print_arg_types = function
 152   | [] -> ""
 153   | t :: ts -> (print_type t) ^ " -> " ^ (print_arg_types ts)
 154
 155 let print_sig sg =
 156   Printf.sprintf "%s%s"
 157     (print_arg_types sg.AST.args)
 158     (print_type_return sg.AST.res)
 159
 160 let prototypes =
 161   let f res s = res ^ "\n" ^ s in
 162   (List.fold_left f "" (List.map proto primitives_list)) ^ "\n\n"