package jasmin

  1. Overview
  2. Docs
package jasmin
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file utils.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
(* -------------------------------------------------------------------- *)
module Map    = BatMap
module Set    = BatSet
module Hash   = BatHashtbl

module Sint = Set.Make (BatInt)
module Mint = Map.Make (BatInt)

(* -------------------------------------------------------------------- *)
module Ss = Set.Make(String)
module Ms = Map.Make(String)

(* -------------------------------------------------------------------- *)
module ILoc = struct
  open Location

  type t = i_loc

  let compare x y = Stdlib.Int.compare x.uid_loc y.uid_loc
  let equal x y = Stdlib.Int.equal x.uid_loc y.uid_loc
  let hash x = x.uid_loc
end

module Hiloc = Hash.Make(ILoc)
module Miloc = Map.Make(ILoc)
module Siloc = Set.Make(ILoc)

(* -------------------------------------------------------------------- *)
let identity x = x

let (|-) g f = fun x -> g (f x)

(* -------------------------------------------------------------------- *)
type 'a tuple0 = unit
type 'a tuple1 = 'a
type 'a tuple2 = 'a * 'a
type 'a tuple3 = 'a * 'a * 'a
type 'a pair   = 'a * 'a

(* -------------------------------------------------------------------- *)
let as_seq0 = function [] -> () | _ -> assert false
let as_seq1 = function [x] -> x | _ -> assert false
let as_seq2 = function [x1; x2] -> (x1, x2) | _ -> assert false
let as_seq3 = function [x1; x2; x3] -> (x1, x2, x3) | _ -> assert false

(* -------------------------------------------------------------------- *)
module Option = BatOption

(* -------------------------------------------------------------------- *)
let oget ?exn (x : 'a option) =
  match x, exn with
  | None  , None     -> assert false
  | None  , Some exn -> raise exn
  | Some x, _        -> x

(* -------------------------------------------------------------------- *)
module Uniq = struct
  let gen () = Oo.id (object end)
end

(* -------------------------------------------------------------------- *)
module ISet = BatISet

(* -------------------------------------------------------------------- *)
module List = struct
  include BatList

  (* ------------------------------------------------------------------ *)
  let opick = Exceptionless.find_map

  (* ------------------------------------------------------------------ *)
  module Parallel = struct
    let map_fold2 f =
      let rec doit a xs1 xs2 =
        match xs1, xs2 with
        | [], [] -> (a, [])

        | x1 :: xs1, x2 :: xs2 ->
            let (a, x ) = f a x1 x2 in
            let (a, xs) = doit a xs1 xs2 in
            (a, x :: xs)

        | _, _ -> invalid_arg "List.map_fold2"

      in fun a xs1 xs2 -> doit a xs1 xs2

  end

  include Parallel

  (* ------------------------------------------------------------------ *)
  let last (s : 'a list) =
    match Exceptionless.last s with
    | None   -> failwith "List.last"
    | Some x -> x

  let rec find_map_opt f = function
    | [] -> None
    | x :: l ->
      begin match f x with
        | Some _ as result -> result
        | None -> find_map_opt f l
      end

  let rec pmap (f : 'a -> 'b option) (xs : 'a list) =
    match xs with
    | []      -> []
    | x :: xs ->
      let v = f x in
      let bs = pmap f xs in
        match v with
          Some b -> b :: bs
        | None -> bs

  let mapi_fold f a xs =
    let a  = ref a in
    let xs = List.mapi (fun i b ->
      let (a', b') = f i !a b in a := a'; b')
      xs
    in (!a, xs)

  let map_fold f a xs =
    mapi_fold (fun (_ : int) x -> f x) a xs

  (* ------------------------------------------------------------------ *)
  let modify_last f xs = modify_at (length xs - 1) f xs

end

(* -------------------------------------------------------------------- *)
module String = struct
  include BatString

  let drop_end n s = sub s 0 (length s - n)
end

(* -------------------------------------------------------------------- *)
module IO = BatIO

(* -------------------------------------------------------------------- *)
module Buffer = BatBuffer

(* -------------------------------------------------------------------- *)
type 'a pp = Format.formatter -> 'a -> unit

let rec pp_list sep pp fmt xs =
  let pp_list = pp_list sep pp in
  match xs with
  | []      -> ()
  | [x]     -> Format.fprintf fmt "%a" pp x
  | x :: xs -> Format.fprintf fmt "%a%(%)%a" pp x sep pp_list xs

(* -------------------------------------------------------------------- *)
let pp_enclose ~pre ~post pp fmt x =
  Format.fprintf fmt "%(%)%a%(%)" pre pp x post

(* -------------------------------------------------------------------- *)
let pp_paren pp fmt x =
  pp_enclose ~pre:"(" ~post:")" pp fmt x

(* -------------------------------------------------------------------- *)
let pp_string fmt s =
  Format.fprintf fmt "%s" s

(* -------------------------------------------------------------------- *)
type architecture =
  | X86_64
  | ARM_M4
  | RISCV

(* -------------------------------------------------------------------- *)
type model =
  | ConstantTime
  | ConstantTimeGlobal
  | Normal

(* -------------------------------------------------------------------- *)
(* Functions used to add colors to errors and warnings.                 *)

(* for locations *)
let pp_print_bold pp =
  pp_enclose ~pre:"@{<\027[1m>" ~post:"@}" pp

(* for error kind *)
let pp_print_bold_red pp =
  pp_enclose ~pre:"@{<\027[1;31m>" ~post:"@}" pp

(* for warning kind *)
let pp_print_bold_magenta pp =
  pp_enclose ~pre:"@{<\027[1;35m>" ~post:"@}" pp

(* Enabling the interpretation of semantic tags for the error channel, so that
   error and warning messages are printed with colors.
*)
let enable_colors () =
  let mark_open_stag s =
    match s with
    | Format.String_tag s -> s
    | _ -> ""
  in
  let mark_close_stag _ = "\027[m" in
  let stag_functions = Format.{
    mark_open_stag;
    mark_close_stag;
    print_open_stag = (fun _ -> ());
    print_close_stag = (fun _ -> ());
  } in
  Format.pp_set_formatter_stag_functions Format.err_formatter stag_functions;
  Format.pp_set_mark_tags Format.err_formatter true

(* -------------------------------------------------------------------- *)
(* An [error_loc] is either unknown, a single location or a pair of a location
   and a list of locations (this list comes from the inlining pass).
   We could probably just have an [i_loc], though, since we can simulate
   the other cases with a dummy location and an empty list.
*)
type error_loc = Lnone | Lone of Location.t | Lmore of Location.i_loc
type hierror = {
  err_msg      : Format.formatter -> unit; (* a printer of the main error message              *)
  err_loc      : error_loc;                (* the location                                     *)
  err_funname  : string option;            (* the name of the function, if any                 *)
  err_kind     : string;                   (* kind of error (e.g. typing, compilation)         *)
  err_sub_kind : string option;            (* sub-kind (e.g. the name of the compilation pass) *)
  err_internal : bool;                     (* whether the error is unexpected                  *)
}
exception HiError of hierror

(* We fetch from [i_loc] the locations coming from the inlining pass *)
let add_iloc e i_loc =
  let err_loc =
    match e.err_loc with
    | Lnone -> Lmore i_loc
    | Lone loc -> Lmore (Location.i_loc loc i_loc.stack_loc)
    | Lmore _ as err_loc -> err_loc (* we already have a more precise location *)
  in
  { e with err_loc }

let remove_dummy_locations =
  let open Location in
  function
  | Lnone -> Lnone
  | Lone l when isdummy l -> Lnone
  | Lone _ as x -> x
  | Lmore {  base_loc ; stack_loc ; _ } ->
     match List.filter (fun x -> not (isdummy x)) (base_loc :: stack_loc) with
     | [] -> Lnone
     | [ x ] -> Lone x
     | x :: xs -> Lmore (i_loc x xs)

let pp_hierror fmt e =
  let pp_loc fmt =
    match remove_dummy_locations e.err_loc with
    | Lnone -> ()
    | Lone l -> Format.fprintf fmt "%a:@ " (pp_print_bold Location.pp_loc) l
    | Lmore i_loc -> Format.fprintf fmt "%a:@ " (pp_print_bold Location.pp_iloc) i_loc
  in
  let pp_kind fmt =
    let pp fmt () =
      if e.err_internal then
        Format.fprintf fmt "internal %s" e.err_kind
      else
        Format.fprintf fmt "%s" e.err_kind
    in
    pp_print_bold_red pp fmt ()
  in
  let pp_funname fmt =
    match e.err_funname with
    | Some fn -> Format.fprintf fmt " in function %s" fn
    | None -> ()
  in
  (* this function decides whether we open a new line *)
  let pp_other_line fmt =
    if e.err_internal then
      (* if the error is internal, we go to a new line with an indent *)
      Format.fprintf fmt "@;<1 2>"
    else if e.err_funname <> None || e.err_sub_kind <> None then
      (* if there is at least a funname or a sub-kind, we go to a new line *)
      Format.fprintf fmt "@ "
    else
      (* otherwise, we keep the same line *)
      Format.fprintf fmt " "
  in
  let pp_err fmt =
    match e.err_sub_kind with
    | Some s -> Format.fprintf fmt "%s: %t" s e.err_msg
    | None -> Format.fprintf fmt "%t" e.err_msg
  in
  let pp_post fmt =
    if e.err_internal then
      Format.fprintf fmt "@ Please report at https://github.com/jasmin-lang/jasmin/issues"
  in
  Format.fprintf fmt "@[<v>%t%t%t:%t%t%t@]" pp_loc pp_kind pp_funname pp_other_line pp_err pp_post

(* In general, we want a [loc], that's why it is not optional. If you really
   don't want to give a [loc], pass [Lnone].
*)
let hierror ~loc ?funname ~kind ?sub_kind ?(internal=false) =
  Format.kdprintf
    (fun pp ->
      let err = {
        err_msg = pp;
        err_loc = loc;
        err_funname = funname;
        err_kind = kind;
        err_sub_kind = sub_kind;
        err_internal = internal;
      } in
      raise (HiError err))


(* -------------------------------------------------------------------- *)
(** Splits a time in seconds into hours, minutes, seconds, and centiseconds.
  Number of hours must be below one hundred. *)
let hmsc f =
  let open Float in
  let cut f n =
    let r = rem f n in
    to_int r, (f -. r) /. n
  in
  let c, f = modf f in
  let s, f = cut f 60. in
  let m, f = cut f 60. in
  let h, f = cut f 100. in
  assert (f = 0.);
  h, m, s, to_int (100. *. c)

let pp_now =
  let open Unix in
  let timestamp = ref (-1.) in
  let pp_elapsed fmt now =
    let old = !timestamp in
    if old >= 0. then begin
      let diff = now -. old in
      let h, m, s, c = hmsc diff in
      Format.fprintf fmt "|";
      if h > 0 then Format.fprintf fmt "%2dh" h else Format.fprintf fmt "   ";
      if h > 0 || m > 0 then Format.fprintf fmt "%2dm" m else Format.fprintf fmt "   ";
      Format.fprintf fmt "%2ds%02d" s c
    end;
    timestamp := now
  in
  fun fmt ->
    let  now = gettimeofday () in
    let { tm_hour; tm_min; tm_sec; _ } = localtime now in
  Format.fprintf fmt "[%02d:%02d:%02d%a]" tm_hour tm_min tm_sec pp_elapsed now

(* -------------------------------------------------------------------- *)

type warning =
  | ExtraAssignment (* -wea *)
  | UseLea (* -wlea *)
  | IntroduceArrayCopy (* -winsertarraycopy *)
  | InlinedCallToExport
  | KeptRenaming
  | SimplifyVectorSuffix
  | DuplicateVar (* -wduplicatevar *)
  | UnusedVar (* -wunusedvar *)
  | SCTchecker
  | Linter
  | Deprecated
  | Experimental
  | Always
  | PedanticPretyping

let default_warnings =
    [
      InlinedCallToExport;
      SimplifyVectorSuffix;
      DuplicateVar;
      UnusedVar;
      SCTchecker;
      Deprecated;
      Experimental;
      PedanticPretyping;
    ]

let all_warnings = Linter :: ExtraAssignment :: UseLea :: IntroduceArrayCopy :: KeptRenaming :: default_warnings

let warns = ref default_warnings

let warn_recoverable = ref false

let set_warn_recoverable b = warn_recoverable := b

let add_warning (w: warning) () =
  let ws = !warns in
  if not (List.mem w ws) then
    warns := w :: ws

let remove_warning (w: warning) =
  let ws = !warns in
  if List.mem w ws then
    warns := List.remove ws w

let set_all_warnings () = warns := all_warnings

let nowarning () = warns := []

let to_warn w = w = Always || List.mem w !warns

let warning (w:warning) loc =
  Format.kdprintf (fun pp ->
    match w with
    | PedanticPretyping when not !warn_recoverable ->
      hierror ~loc:(Lmore loc) ~kind:"typing error"
        "%t" pp
    | _ ->
      if to_warn w then
        let pp_warning fmt = pp_print_bold_magenta pp_string fmt "warning" in
        let pp_iloc fmt d =
          if not (Location.isdummy d.Location.base_loc) then
            Format.fprintf fmt "%a@ " (pp_print_bold Location.pp_iloc) d in
        Format.eprintf "@[<v>%a%t: %t@]@."
          pp_iloc loc
          pp_warning pp
    )