Merge commit '2250fd8a2218796c07b0a25f184cdc682e4695ba' into 5.00_reb…

…ase_to_pr

Changes

@@ -45,6 +45,9 @@ Working version
   are used for passing arguments that do not fit in registers.
   (Xavier Leroy, review by Vincent Laviron)
 
+- #10681: Enforce boolean conditions for the native backend
+  (Vincent Laviron, review by Gabriel Scherer)
+
 ### Standard library:
 
 * #10622: Annotate `Uchar.t` with immediate attribute
@@ -117,6 +120,9 @@ Working version
 - #10565: Toplevel value printing: truncate strings only after 8 bytes.
   (Wiktor Kuchta, review by Xavier Leroy)
 
+- #10527: Show "#help;; for help" at toplevel startup
+  (Wiktor Kuchta, review by David Allsopp and Florian Angeletti)
+
 ### Debugging:
 
 - #10517, #10594: when running ocamldebug on a program linked with the
@@ -148,6 +154,10 @@ Working version
   (Nicolás Ojeda Bär, report by Daniel Bünzli, review by David Allsopp,
   Sébastien Hinderer, and Daniel Bünzli)
 
+- #10671, #10672: webman: Fix misalignments in unordered lists by changing the
+  CSS for coloring bullets
+  (Wiktor Kuchta, review by Florian Angeletti)
+
 ### Compiler user-interface and warnings:
 
 - #10328: Give more precise error when disambiguation could not possibly work.
@@ -203,6 +213,12 @@ Working version
   (Jacques Garrigue and Takafumi Saikawa,
    review by Thomas Refis and Florian Angeletti)
 
+* #10627: Make row_field abstract
+  Completes #10474 by making row_field abstract too.
+  An immutable view row_field_view is provided, and one converts between it
+  and row_field via inj_row_field and row_field_repr.
+  (Jacques Garrigue and Takafumi Saikawa, review by Florian Angeletti)
+
 - #10433: Remove the distinction between 32-bit aligned and 64-bit aligned
   64-bit floats in Cmm.memory_chunk.
   (Greta Yorsh, review by Xavier Leroy)
@@ -745,6 +761,13 @@ OCaml 4.13.0 (24 September 2021)
 - #10327: Add a subdirectories variable and a copy action to ocamltest
   (Sébastien Hinderer, review by David Allsopp)
 
+* #10337: Normalize type_expr nodes on access
+  One should now use accessors such as get_desc and get_level to access fields
+  of type_expr, rather than calling manually Btype.repr (which is now hidden
+  in Types.Transient_expr).
+  (Jacques Garrigue and Takafumi Saikawa,
+   review by Florian Angeletti and Gabriel Radanne)
+
 - #10358: Use a hash table for the load path.
   (Leo White, review by Gabriel Scherer)
 

api_docgen/alldoc.tex

@@ -1,10 +1,8 @@
 \documentclass{book}
-
 \usepackage[colorlinks=true,breaklinks=true]{hyperref}
 \usepackage{color}
 \usepackage{lmodern}
 \usepackage[T1]{fontenc}
-\usepackage[strings,nohyphen]{underscore}
 \input{ifocamldoc}
 \ifocamldoc
 \usepackage{ocamldoc}
@@ -67,6 +65,8 @@
 \else
 \newcommand{\docitem}[2]{\input{#1/#2}}
 \fi
+\usepackage[english]{babel}
+\usepackage[strings,nohyphen]{underscore}
 
 \begin{document}
 \chapter{Stdlib}

asmcomp/cmm_helpers.ml

@@ -1529,6 +1529,7 @@ struct
   let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none)
   let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none)
   let make_is_nonzero arg = arg
+  let arg_as_test arg = arg
   let make_if cond ifso ifnot =
     Cifthenelse (cond, Debuginfo.none, ifso, Debuginfo.none, ifnot,
       Debuginfo.none)

asmcomp/cmmgen.ml

@@ -613,8 +613,16 @@ let rec transl env e =
       let ifso_dbg = Debuginfo.none in
       let ifnot_dbg = Debuginfo.none in
       let dbg = Debuginfo.none in
-      transl_if env Unknown dbg cond
-        ifso_dbg (transl env ifso) ifnot_dbg (transl env ifnot)
+      let ifso = transl env ifso in
+      let ifnot = transl env ifnot in
+      let approx =
+        match ifso, ifnot with
+        | Cconst_int (1, _), Cconst_int (3, _) -> Then_false_else_true
+        | Cconst_int (3, _), Cconst_int (1, _) -> Then_true_else_false
+        | _, _ -> Unknown
+      in
+      transl_if env approx dbg cond
+        ifso_dbg ifso ifnot_dbg ifnot
   | Usequence(exp1, exp2) ->
       Csequence(remove_unit(transl env exp1), transl env exp2)
   | Uwhile(cond, body) ->

lambda/matching.ml

@@ -1808,7 +1808,7 @@ let divide_variant ~scopes row ctx { cases = cl; args; default = def } =
         in
         let head = Simple.head p in
         let variants = divide rem in
-        if row_field lab row = Rabsent then
+        if row_field_repr (get_row_field lab row) = Rabsent then
           variants
         else
           let tag = Btype.hash_variant lab in
@@ -2374,7 +2374,15 @@ module SArg = struct
 
   let make_isin h arg = Lprim (Pnot, [ make_isout h arg ], Loc_unknown)
 
-  let make_is_nonzero arg = arg
+  let make_is_nonzero arg =
+    if !Clflags.native_code then
+      Lprim (Pintcomp Cne,
+             [arg; Lconst (Const_base (Const_int 0))],
+             Loc_unknown)
+    else
+      arg
+
+  let arg_as_test arg = arg
 
   let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
 
@@ -2846,9 +2854,14 @@ let combine_constructor loc arg pat_env cstr partial ctx def
               (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts)
             with
             | 1, 1, [ (0, act1) ], [ (0, act2) ] ->
-                (* Typically, match on lists, will avoid isint primitive in that
-              case *)
-                Lifthenelse (arg, act2, act1)
+                if !Clflags.native_code then
+                  Lifthenelse(Lprim (Pisint, [ arg ], loc), act1, act2)
+                else
+                  (* PR#10681: we use [arg] directly as the test here;
+                     it generates better bytecode for this common case
+                     (typically options and lists), but would prevent
+                     some optimizations with the native compiler. *)
+                  Lifthenelse (arg, act2, act1)
             | n, 0, _, [] ->
                 (* The type defines constant constructors only *)
                 call_switcher loc fail_opt arg 0 (n - 1) consts
@@ -2913,7 +2926,7 @@ let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats)
       (fun (_, f) ->
         match row_field_repr f with
         | Rabsent
-        | Reither (true, _ :: _, _, _) ->
+        | Reither (true, _ :: _, _) ->
             ()
         | _ -> incr num_constr)
       (row_fields row)

lambda/simplif.ml

@@ -712,7 +712,24 @@ and list_emit_tail_infos is_tail =
 
 let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc =
   let rec aux map = function
-    | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
+    (* When compiling [fun ?(x=expr) -> body], this is first translated
+       to:
+       [fun *opt* ->
+          let x =
+            match *opt* with
+            | None -> expr
+            | Some *sth* -> *sth*
+          in
+          body]
+       We want to detect the let binding to put it into the wrapper instead of
+       the inner function.
+       We need to find which optional parameter the binding corresponds to,
+       which is why we need a deep pattern matching on the expected result of
+       the pattern-matching compiler for options.
+    *)
+    | Llet(Strict, k, id,
+           (Lifthenelse(Lprim (Pisint, [Lvar optparam], _), _, _) as def),
+           rest) when
         Ident.name optparam = "*opt*" && List.mem_assoc optparam params
           && not (List.mem_assoc optparam map)
       ->

lambda/switch.ml

@@ -126,6 +126,7 @@ sig
   val make_isout : arg -> arg -> test
   val make_isin : arg -> arg -> test
   val make_is_nonzero : arg -> test
+  val arg_as_test : arg -> test
 
   val make_if : test -> act -> act -> act
   val make_switch : loc -> arg -> int array -> act array -> act
@@ -191,6 +192,9 @@ let prerr_inter i = Printf.fprintf stderr
   and get_low cases i =
     let r,_,_ = cases.(i) in
     r
+  and get_high cases i =
+    let _,r,_ = cases.(i) in
+    r
 
   type ctests = {
     mutable n : int ;
@@ -578,6 +582,9 @@ let rec pkey chan  = function
   let make_if_nonzero arg ifso ifnot =
     Arg.make_if (Arg.make_is_nonzero arg) ifso ifnot
 
+  let make_if_bool arg ifso ifnot =
+    Arg.make_if (Arg.arg_as_test arg) ifso ifnot
+
   let do_make_if_out h arg ifso ifno =
     Arg.make_if (Arg.make_isout h arg) ifso ifno
 
@@ -667,9 +674,14 @@ let rec pkey chan  = function
           and right = {s with cases=right} in
 
           if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then
-            make_if_nonzero
-              ctx.arg
-              (c_test ctx right) (c_test ctx left)
+            if lcases = 2 && get_high cases 1+ctx.off = 1 then
+              make_if_bool
+                ctx.arg
+                (c_test ctx right) (c_test ctx left)
+            else
+              make_if_nonzero
+                ctx.arg
+                (c_test ctx right) (c_test ctx left)
           else if less_tests cright cleft then
             make_if_lt
               ctx.arg (lim+ctx.off)

lambda/switch.mli

@@ -84,14 +84,32 @@ module type S =
 
     (* Various constructors, for making a binder,
         adding one integer, etc. *)
+
+    (* [bind arg cont] should bind the expression arg to a variable,
+       then call [cont] on that variable, and return the term made of
+       the binding and the result of the call. *)
     val bind : arg -> (arg -> act) -> act
+    (* [make_const n] generates a term for the integer constant [n] *)
     val make_const : int -> arg
+    (* [make_offset arg n] generates a term for adding the constant
+       integer [n] to the term [arg] *)
     val make_offset : arg -> int -> arg
+    (* [make_prim p args] generates a test using the primitive operation [p]
+       applied to arguments [args] *)
     val make_prim : primitive -> arg list -> test
+    (* [make_isout h arg] generates a test that holds when [arg] is out of
+       the interval [0, h] *)
     val make_isout : arg -> arg -> test
+    (* [make_isin h arg] generates a test that holds when [arg] is in
+       the interval [0, h] *)
     val make_isin : arg -> arg -> test
+    (* [make_is_nonzero arg] generates a test that holds when [arg] is any
+       value except 0 *)
     val make_is_nonzero : arg -> test
-
+    (* [arg_as_test arg] casts [arg], known to be either 0 or 1,
+       to a boolean test *)
+    val arg_as_test : arg -> test
+    (* [make_if cond ifso ifnot] generates a conditional branch *)
     val make_if : test -> act -> act -> act
    (* construct an actual switch :
       make_switch arg cases acts

manual/src/html_processing/scss/_common.scss

@@ -249,14 +249,9 @@ html {
     margin-left:-1em
 }
 
-@mixin disc {
-    content:"●";
-    color:$logocolor;
-    margin-right:4px;
-    margin-left:-1em;
-    font-family: $font-sans;
-    font-size:13px;
-    vertical-align:1px;
+@mixin colored-disc-marker {
+    list-style-type: disc;
+    li::marker { color:$logocolor; }
 }
 
 @mixin diamond {

manual/src/html_processing/scss/manual.scss

@@ -23,7 +23,7 @@
 	}
     }
     ul{list-style:none;}
-    ul.itemize li::before{@include disc;}
+    ul.itemize {@include colored-disc-marker;}
 
     /* When the TOC is repeated in the main content */
     ul.ul-content {
@@ -44,7 +44,6 @@
     ul{
 	list-style: none;
 	li {
-	    margin-left: 0.5ex;
 	    span {
 		color:#c88b5f;
 	    }
@@ -54,9 +53,8 @@
 	}
     }
     /* only for Contents/Foreword in index.html: */
-    ul.ul-content li::before{
-	@include disc;
-	margin-left: 0;
+    ul.ul-content {
+	@include colored-disc-marker;
     }
     /* table of contents: (manual.001.html): */
     ul.toc ul.toc ul.toc{

manual/src/manual.tex

@@ -185,6 +185,9 @@
 % Make _ a normal character in text mode
 % it must be the last package included
 \usepackage[strings,nohyphen]{underscore}
+% Babel enables a finer control of the catcode of '_'
+% and ensures that '_' is allowed in labels and references.
+\usepackage[english]{babel}
 
 %\makeatletter \def\@wrindex#1#2{\xdef \@indexfile{\csname #1@idxfile\endcsname}\@@wrindex#2||\\}\makeatother
 

middle_end/closure/closure.ml

@@ -490,13 +490,19 @@ let simplif_prim_pure ~backend fpc p (args, approxs) dbg =
       make_const (List.nth l n)
   | Pfield(n, _, _), [ Uprim(P.Pmakeblock _, ul, _) ], [approx]
     when n < List.length ul ->
+      (* This case is particularly useful for removing allocations
+         for optional parameters *)
       (List.nth ul n, field_approx n approx)
   (* Strings *)
   | (Pstringlength | Pbyteslength),
      _,
      [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] ->
       make_const_int (String.length s)
   (* Kind test *)
+  | Pisint, [ Uprim(P.Pmakeblock _, _, _) ], _ ->
+      (* This case is particularly useful for removing allocations
+         for optional parameters *)
+      make_const_bool false
   | Pisint, _, [a1] ->
       begin match a1 with
       | Value_const(Uconst_int _) -> make_const_bool true
@@ -674,8 +680,6 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam =
             substitute loc st sb rn u2
           else
             substitute loc st sb rn u3
-      | Uprim(P.Pmakeblock _, _, _) ->
-          substitute loc st sb rn u2
       | su1 ->
           Uifthenelse(su1, substitute loc st sb rn u2,
                            substitute loc st sb rn u3)
@@ -755,6 +759,11 @@ let bind_params { backend; mutable_vars; _ } loc fpc params args body =
           let u1, u2 =
             match VP.name p1, a1 with
             | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind), [a], dbg) ->
+                (* This parameter corresponds to an optional parameter,
+                   and although it is used twice pushing the expression down
+                   actually allows us to remove the allocation as it will
+                   appear once under a Pisint primitive and once under a Pfield
+                   primitive (see [simplif_prim_pure]) *)
                 a, Uprim(P.Pmakeblock(0, Immutable, kind),
                          [Uvar (VP.var p1')], dbg)
             | _ ->
@@ -772,9 +781,6 @@ let bind_params { backend; mutable_vars; _ } loc fpc params args body =
      evaluation order (PR#2910). *)
   aux V.Map.empty (List.rev params) (List.rev args) body
 
-(* Check if a lambda term is ``pure'',
-   that is without side-effects *and* not containing function definitions *)
-
 let warning_if_forced_inline ~loc ~attribute warning =
   if attribute = Always_inline then
     Location.prerr_warning (Debuginfo.Scoped_location.to_location loc)

toplevel/genprintval.ml

@@ -452,7 +452,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                   | (l, f) :: fields ->
                       if Btype.hash_variant l = tag then
                         match row_field_repr f with
-                        | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
+                        | Rpresent(Some ty) | Reither(_,[ty],_) ->
                             let args =
                               nest tree_of_val (depth - 1) (O.field obj 1) ty
                             in

toplevel/toploop.ml

@@ -187,7 +187,7 @@ let loop ppf =
   Clflags.debug := true;
   Location.formatter_for_warnings := ppf;
   if not !Clflags.noversion then
-    fprintf ppf "        OCaml version %s%s%s@.@."
+    fprintf ppf "OCaml version %s%s%s@.Enter #help;; for help.@.@."
       Config.version
       (if Topeval.implementation_label = "" then "" else " - ")
       Topeval.implementation_label;