+17

.depend

reviewed

··· 45 45 utils/clflags.cmi : \ 46 46 utils/profile.cmi \ 47 47 utils/misc.cmi 48 48 + utils/compression.cmo : \ 49 49 + utils/compression.cmi 50 50 + utils/compression.cmx : \ 51 51 + utils/compression.cmi 52 52 + utils/compression.cmi : 48 53 utils/config.common.cmo : 49 54 utils/config.common.cmx : 50 55 utils/config.fixed.cmo : ··· 2079 2084 bytecomp/dll.cmi \ 2080 2085 utils/consistbl.cmi \ 2081 2086 utils/config.cmi \ 2087 2087 + utils/compression.cmi \ 2082 2088 file_formats/cmo_format.cmi \ 2083 2089 utils/clflags.cmi \ 2084 2090 utils/ccomp.cmi \ ··· 2096 2102 bytecomp/dll.cmx \ 2097 2103 utils/consistbl.cmx \ 2098 2104 utils/config.cmx \ 2105 2105 + utils/compression.cmx \ 2099 2106 file_formats/cmo_format.cmi \ 2100 2107 utils/clflags.cmx \ 2101 2108 utils/ccomp.cmx \ ··· 2123 2130 typing/env.cmi \ 2124 2131 bytecomp/emitcode.cmi \ 2125 2132 utils/config.cmi \ 2133 2133 + utils/compression.cmi \ 2126 2134 file_formats/cmo_format.cmi \ 2127 2135 utils/clflags.cmi \ 2128 2136 bytecomp/bytelink.cmi \ ··· 2145 2153 typing/env.cmx \ 2146 2154 bytecomp/emitcode.cmx \ 2147 2155 utils/config.cmx \ 2156 2156 + utils/compression.cmx \ 2148 2157 file_formats/cmo_format.cmi \ 2149 2158 utils/clflags.cmx \ 2150 2159 bytecomp/bytelink.cmx \ ··· 2184 2193 typing/ident.cmi \ 2185 2194 typing/env.cmi \ 2186 2195 utils/config.cmi \ 2196 2196 + utils/compression.cmi \ 2187 2197 file_formats/cmo_format.cmi \ 2188 2198 utils/clflags.cmi \ 2189 2199 bytecomp/bytegen.cmi \ ··· 2203 2213 typing/ident.cmx \ 2204 2214 typing/env.cmx \ 2205 2215 utils/config.cmx \ 2216 2216 + utils/compression.cmx \ 2206 2217 file_formats/cmo_format.cmi \ 2207 2218 utils/clflags.cmx \ 2208 2219 bytecomp/bytegen.cmx \ ··· 4073 4084 utils/misc.cmi \ 4074 4085 parsing/location.cmi \ 4075 4086 utils/config.cmi \ 4087 4087 + utils/compression.cmi \ 4076 4088 file_formats/cmi_format.cmi 4077 4089 file_formats/cmi_format.cmx : \ 4078 4090 typing/types.cmx \ 4079 4091 utils/misc.cmx \ 4080 4092 parsing/location.cmx \ 4081 4093 utils/config.cmx \ 4094 4094 + utils/compression.cmx \ 4082 4095 file_formats/cmi_format.cmi 4083 4096 file_formats/cmi_format.cmi : \ 4084 4097 typing/types.cmi \ ··· 4102 4115 typing/ident.cmi \ 4103 4116 typing/env.cmi \ 4104 4117 utils/config.cmi \ 4118 4118 + utils/compression.cmi \ 4105 4119 file_formats/cmi_format.cmi \ 4106 4120 utils/clflags.cmi \ 4107 4121 typing/btype.cmi \ ··· 4124 4138 typing/ident.cmx \ 4125 4139 typing/env.cmx \ 4126 4140 utils/config.cmx \ 4141 4141 + utils/compression.cmx \ 4127 4142 file_formats/cmi_format.cmx \ 4128 4143 utils/clflags.cmx \ 4129 4144 typing/btype.cmx \ ··· 7130 7145 parsing/location.cmi \ 7131 7146 bytecomp/instruct.cmi \ 7132 7147 utils/config.cmi \ 7148 7148 + utils/compression.cmi \ 7133 7149 file_formats/cmo_format.cmi \ 7134 7150 bytecomp/bytesections.cmi \ 7135 7151 tools/dumpobj.cmi ··· 7141 7157 parsing/location.cmx \ 7142 7158 bytecomp/instruct.cmx \ 7143 7159 utils/config.cmx \ 7160 7160 + utils/compression.cmx \ 7144 7161 file_formats/cmo_format.cmi \ 7145 7162 bytecomp/bytesections.cmx \ 7146 7163 tools/dumpobj.cmi

+2 -1

Makefile

reviewed

··· 83 83 binutils.mli binutils.ml \ 84 84 lazy_backtrack.mli lazy_backtrack.ml \ 85 85 diffing.mli diffing.ml \ 86 86 - diffing_with_keys.mli diffing_with_keys.ml) 86 86 + diffing_with_keys.mli diffing_with_keys.ml \ 87 87 + compression.mli compression.ml) 87 88 88 89 parsing_SOURCES = $(addprefix parsing/, \ 89 90 location.mli location.ml \

+4 -2

bytecomp/bytelink.ml

reviewed

··· 212 212 Symtable.patch_object code_block compunit.cu_reloc; 213 213 if !Clflags.debug && compunit.cu_debug > 0 then begin 214 214 seek_in inchan compunit.cu_debug; 215 215 - let debug_event_list : Instruct.debug_event list = input_value inchan in 216 216 - let debug_dirs : string list = input_value inchan in 215 215 + let debug_event_list : Instruct.debug_event list = 216 216 + Compression.input_value inchan in 217 217 + let debug_dirs : string list = 218 218 + Compression.input_value inchan in 217 219 let file_path = Filename.dirname (Location.absolute_path file_name) in 218 220 let debug_dirs = 219 221 if List.mem file_path debug_dirs

+4 -5

bytecomp/bytepackager.ml

reviewed

··· 172 172 let events, debug_dirs = 173 173 if !Clflags.debug && compunit.cu_debug > 0 then begin 174 174 seek_in ic compunit.cu_debug; 175 175 - let unit_events = (input_value ic : debug_event list) in 175 175 + let unit_events = (Compression.input_value ic : debug_event list) in 176 176 let events = 177 177 rev_append_map 178 178 (relocate_debug state.offset packagename state.subst) 179 179 unit_events 180 180 state.events in 181 181 - let unit_debug_dirs = (input_value ic : string list) in 181 181 + let unit_debug_dirs = (Compression.input_value ic : string list) in 182 182 let debug_dirs = 183 183 String.Set.union 184 184 state.debug_dirs ··· 291 291 build_global_target ~ppf_dump oc targetname state components coercion in 292 292 let pos_debug = pos_out oc in 293 293 if !Clflags.debug && state.events <> [] then begin 294 294 - Marshal.(to_channel oc (List.rev state.events) [Compression]); 295 295 - Marshal.(to_channel oc (String.Set.elements state.debug_dirs) 296 296 - [Compression]); 294 294 + Compression.output_value oc (List.rev state.events); 295 295 + Compression.output_value oc (String.Set.elements state.debug_dirs) 297 296 end; 298 297 let force_link = 299 298 List.exists (function

+2 -3

bytecomp/emitcode.ml

reviewed

··· 435 435 (Filename.dirname (Location.absolute_path filename)) 436 436 !debug_dirs; 437 437 let p = pos_out outchan in 438 438 - Marshal.(to_channel outchan !events [Compression]); 439 439 - Marshal.(to_channel outchan (String.Set.elements !debug_dirs) 440 440 - [Compression]); 438 438 + Compression.output_value outchan !events; 439 439 + Compression.output_value outchan (String.Set.elements !debug_dirs); 441 440 (p, pos_out outchan - p) 442 441 end else 443 442 (0, 0) in

+5 -5

configure

reviewed

··· 1715 1715 --with-target-bindir location of binary programs on target system 1716 1716 --with-afl use the AFL fuzzer 1717 1717 --with-flexdll bootstrap FlexDLL from the given sources 1718 1718 - --without-zstd disable compression of marshaled data 1718 1718 + --without-zstd disable compression of compilation artefacts 1719 1719 --with-pic[=PKGS] try to use only PIC/non-PIC objects [default=use 1720 1720 both] 1721 1721 --with-aix-soname=aix|svr4|both ··· 18674 18674 18675 18675 if test x"$zstd_status" = "xok" 18676 18676 then : 18677 18677 - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: compressed marshaling supported" >&5 18678 18678 - printf "%s\n" "$as_me: compressed marshaling supported" >&6;} 18677 18677 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: compressed compilation artefacts supported" >&5 18678 18678 + printf "%s\n" "$as_me: compressed compilation artefacts supported" >&6;} 18679 18679 cclibs="$cclibs $zstd_libs" 18680 18680 internal_cppflags="$internal_cppflags $zstd_flags" 18681 18681 printf "%s\n" "#define HAS_ZSTD 1" >>confdefs.h ··· 18689 18689 *) : 18690 18690 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $zstd_status" >&5 18691 18691 printf "%s\n" "$as_me: WARNING: $zstd_status" >&2;} 18692 18692 - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: compressed marshaling not supported" >&5 18693 18693 - printf "%s\n" "$as_me: WARNING: compressed marshaling not supported" >&2;} ;; 18692 18692 + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: compressed compilation artefacts not supported" >&5 18693 18693 + printf "%s\n" "$as_me: WARNING: compressed compilation artefacts not supported" >&2;} ;; 18694 18694 esac 18695 18695 fi 18696 18696

+3 -3

configure.ac

reviewed

··· 546 546 547 547 AC_ARG_WITH([zstd], 548 548 [AS_HELP_STRING([--without-zstd], 549 549 - [disable compression of marshaled data])]) 549 549 + [disable compression of compilation artefacts])]) 550 550 551 551 AS_IF([test x"$enable_unix_lib" = "xno"], 552 552 [AS_IF([test x"$enable_ocamldebug" = "xyes"], ··· 2171 2171 [zstd_status="zstd library not found"])])) 2172 2172 2173 2173 AS_IF([test x"$zstd_status" = "xok"], 2174 2174 - [AC_MSG_NOTICE([compressed marshaling supported]) 2174 2174 + [AC_MSG_NOTICE([compressed compilation artefacts supported]) 2175 2175 cclibs="$cclibs $zstd_libs" 2176 2176 internal_cppflags="$internal_cppflags $zstd_flags" 2177 2177 AC_DEFINE([HAS_ZSTD])], ··· 2181 2181 [yes], 2182 2182 [AC_MSG_ERROR([$zstd_status])], 2183 2183 [AC_MSG_WARN([$zstd_status]) 2184 2184 - AC_MSG_WARN([compressed marshaling not supported])])]) 2184 2184 + AC_MSG_WARN([compressed compilation artefacts not supported])])]) 2185 2185 2186 2186 ## Determine whether the debugger should/can be built 2187 2187

+2 -2

file_formats/cmi_format.ml

reviewed

··· 42 42 } 43 43 44 44 let input_cmi ic = 45 45 - let (name, sign) = (input_value ic : header) in 45 45 + let (name, sign) = (Compression.input_value ic : header) in 46 46 let crcs = (input_value ic : crcs) in 47 47 let flags = (input_value ic : flags) in 48 48 { ··· 84 84 let output_cmi filename oc cmi = 85 85 (* beware: the provided signature must have been substituted for saving *) 86 86 output_string oc Config.cmi_magic_number; 87 87 - Marshal.(to_channel oc ((cmi.cmi_name, cmi.cmi_sign) : header) [Compression]); 87 87 + Compression.output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header); 88 88 flush oc; 89 89 let crc = Digest.file filename in 90 90 let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in

+2 -2

file_formats/cmt_format.ml

reviewed

··· 380 380 381 381 exception Error of error 382 382 383 383 - let input_cmt ic = (input_value ic : cmt_infos) 383 383 + let input_cmt ic = (Compression.input_value ic : cmt_infos) 384 384 385 385 let output_cmt oc cmt = 386 386 output_string oc Config.cmt_magic_number; 387 387 - Marshal.(to_channel oc (cmt : cmt_infos) [Compression]) 387 387 + Compression.output_value oc (cmt : cmt_infos) 388 388 389 389 let read filename = 390 390 (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)

+1

otherlibs/dynlink/Makefile

reviewed

··· 89 89 utils/warnings.ml \ 90 90 utils/int_replace_polymorphic_compare.ml \ 91 91 utils/lazy_backtrack.ml \ 92 92 + utils/compression.ml \ 92 93 parsing/location.ml \ 93 94 parsing/unit_info.ml \ 94 95 parsing/longident.ml \

+1 -1

otherlibs/dynlink/byte/dynlink.ml

reviewed

··· 139 139 if compunit.cu_debug = 0 then [| |] 140 140 else begin 141 141 seek_in ic compunit.cu_debug; 142 142 - [| input_value ic |] 142 142 + [| (Compression.input_value ic : Instruct.debug_event list) |] 143 143 end in 144 144 if priv then Symtable.hide_additions old_state; 145 145 let _, clos = Meta.reify_bytecode code events (Some digest) in

-6

runtime/startup_byt.c

reviewed

··· 416 416 "false"); 417 417 #endif 418 418 printf("no_naked_pointers: true\n"); 419 419 - printf("compression_supported: %s\n", 420 420 - #ifdef HAS_ZSTD 421 421 - "true"); 422 422 - #else 423 423 - "false"); 424 424 - #endif 425 419 printf("reserved header bits: %d\n", HEADER_RESERVED_BITS); 426 420 printf("exec_magic_number: %s\n", EXEC_MAGIC); 427 421

+1 -7

stdlib/marshal.ml

reviewed

··· 17 17 No_sharing 18 18 | Closures 19 19 | Compat_32 20 20 - | Compression 20 20 + 21 21 (* note: this type definition is used in 'runtime/debugger.c' *) 22 22 23 23 external to_channel: out_channel -> 'a -> extern_flags list -> unit ··· 66 66 (* Bytes.unsafe_of_string is safe here, as the produced byte 67 67 sequence is never mutated *) 68 68 from_bytes (Bytes.unsafe_of_string buff) ofs 69 69 - 70 70 - external zstd_initialize: unit -> bool = "caml_zstd_initialize" 71 71 - 72 72 - let compr_supp = zstd_initialize() 73 73 - 74 74 - let compression_supported () = compr_supp

+1 -35

stdlib/marshal.mli

reviewed

··· 56 56 No_sharing (** Don't preserve sharing *) 57 57 | Closures (** Send function closures *) 58 58 | Compat_32 (** Ensure 32-bit compatibility *) 59 59 - | Compression (** Compress the output if possible 60 60 - @since 5.1 *) 59 59 + 61 60 (** The flags to the [Marshal.to_*] functions below. *) 62 61 63 62 val to_channel : out_channel -> 'a -> extern_flags list -> unit ··· 99 98 corresponding closure will create a new reference, different from 100 99 the global one. 101 100 102 102 - If [flags] contains [Marshal.Compression], the marshaled data 103 103 - representing value [v] is compressed before being written to 104 104 - channel [chan]. Decompression takes place automatically in 105 105 - the unmarshaling functions {!Stdlib.input_value}, {!Marshal.from_channel}, 106 106 - {!Marshal.from_string}, etc. For large values [v], compression 107 107 - typically reduces the size of marshaled data by a factor 2 to 4, 108 108 - but slows down marshaling and, to a lesser extent, unmarshaling. 109 109 - Compression is not supported on some platforms; in this case, 110 110 - the [Marshal.Compression] flag is silently ignored and uncompressed 111 111 - data is written to channel [chan]. 112 112 - 113 101 If [flags] contains [Marshal.Compat_32], marshaling fails when 114 102 it encounters an integer value outside the range [-2]{^[30]}, [2]{^[30]}[-1] 115 103 of integers that are representable on a 32-bit platform. This ··· 123 111 it has no effect if marshaling is performed on a 32-bit platform. 124 112 @raise Failure if [chan] is not in binary mode. 125 113 126 126 - @before 5.1 Compression mode was not supported 127 114 *) 128 115 129 116 external to_bytes : ··· 198 185 199 186 val total_size : bytes -> int -> int 200 187 (** See {!Marshal.header_size}.*) 201 201 - 202 202 - val compression_supported : unit -> bool 203 203 - (** Indicates whether the compressed data format is supported. 204 204 - 205 205 - If [Marshal.compression_supported()] is [true], compressed data 206 206 - is unmarshaled safely by {!Stdlib.input_value}, {!Marshal.from_channel}, 207 207 - {!Marshal.from_string} and related functions. Moreover, the 208 208 - [Marshal.Compression] flag is honored by the {!Marshal.to_channel}, 209 209 - {!Marshal.to_string} and related functions, resulting in the 210 210 - production of compressed data. 211 211 - 212 212 - If [Marshal.compression_supported()] is [false], compressed data 213 213 - causes {!Stdlib.input_value}, {!Marshal.from_channel}, 214 214 - {!Marshal.from_string} and related functions to fail and a 215 215 - [Failure] exception to be raised. Moreover, 216 216 - {!Marshal.to_channel}, {!Marshal.to_string} and related functions 217 217 - ignore the [Marshal.Compression] flag and produce uncompressed 218 218 - data. 219 219 - 220 220 - @since 5.1 221 221 - *) 222 188 223 189 (** {1:marshal_concurrency Marshal and domain safety} 224 190

+168

testsuite/tests/lib-marshal/compressed.ml

reviewed

··· 1 1 + (* TEST 2 2 + include ocamlcommon; 3 3 + *) 4 4 + 5 5 + (* Test for compressed marshaling / unmarshaling *) 6 6 + 7 7 + open Compression 8 8 + 9 9 + let max_data_depth = 500000 10 10 + 11 11 + type t = A | B of int | C of float | D of string | E of char 12 12 + | F of t | G of t * t | H of int * t | I of t * float | J 13 13 + 14 14 + let longstring = 15 15 + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" 16 16 + let verylongstring = 17 17 + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 18 18 + 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 19 19 + 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 20 20 + 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 21 21 + 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 22 22 + 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 23 23 + 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 24 24 + 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" 25 25 + 26 26 + let bigint = Int64.to_int 0x123456789ABCDEF0L 27 27 + 28 28 + let test_out ?(flags = []) filename = 29 29 + let oc = open_out_bin filename in 30 30 + output_value oc 1; 31 31 + output_value oc (-1); 32 32 + output_value oc 258; 33 33 + output_value oc 20000; 34 34 + output_value oc 0x12345678; 35 35 + output_value oc bigint; 36 36 + output_value oc "foobargeebuz"; 37 37 + output_value oc longstring; 38 38 + output_value oc verylongstring; 39 39 + output_value oc 3.141592654; 40 40 + output_value oc (); 41 41 + output_value oc A; 42 42 + output_value oc (B 1); 43 43 + output_value oc (C 2.718); 44 44 + output_value oc (D "hello, world!"); 45 45 + output_value oc (E 'l'); 46 46 + output_value oc (F(B 1)); 47 47 + output_value oc (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))); 48 48 + output_value oc (H(1, A)); 49 49 + output_value oc (I(B 2, 1e-6)); 50 50 + let x = D "sharing" in 51 51 + let y = G(x, x) in 52 52 + let z = G(y, G(x, y)) in 53 53 + output_value oc z; 54 54 + output_value oc [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]; 55 55 + let rec big n = if n <= 0 then A else H(n, big(n-1)) in 56 56 + output_value oc (big 1000); 57 57 + output_value oc (Int32.of_string "0"); 58 58 + output_value oc (Int32.of_string "123456"); 59 59 + output_value oc (Int32.of_string "-123456"); 60 60 + output_value oc (Int64.of_string "0"); 61 61 + output_value oc (Int64.of_string "123456789123456"); 62 62 + output_value oc (Int64.of_string "-123456789123456"); 63 63 + output_value oc (Nativeint.of_string "0"); 64 64 + output_value oc (Nativeint.of_string "123456"); 65 65 + output_value oc (Nativeint.of_string "-123456"); 66 66 + output_value oc 67 67 + (Nativeint.shift_left (Nativeint.of_string "123456789") 32); 68 68 + output_value oc 69 69 + (Nativeint.shift_left (Nativeint.of_string "-123456789") 32); 70 70 + let i = Int64.of_string "123456789123456" in 71 71 + output_value oc (i,i); 72 72 + close_out oc 73 73 + 74 74 + 75 75 + let test n b = 76 76 + print_string "Test "; print_int n; 77 77 + if b then print_string " passed.\n" else print_string " FAILED.\n"; 78 78 + flush stderr 79 79 + 80 80 + let test_in filename = 81 81 + let ic = open_in_bin filename in 82 82 + test 1 (input_value ic = 1); 83 83 + test 2 (input_value ic = (-1)); 84 84 + test 3 (input_value ic = 258); 85 85 + test 4 (input_value ic = 20000); 86 86 + test 5 (input_value ic = 0x12345678); 87 87 + test 6 (input_value ic = bigint); 88 88 + test 7 (input_value ic = "foobargeebuz"); 89 89 + test 8 (input_value ic = longstring); 90 90 + test 9 (input_value ic = verylongstring); 91 91 + test 10 (input_value ic = 3.141592654); 92 92 + test 11 (input_value ic = ()); 93 93 + test 12 (match input_value ic with 94 94 + A -> true 95 95 + | _ -> false); 96 96 + test 13 (match input_value ic with 97 97 + (B 1) -> true 98 98 + | _ -> false); 99 99 + test 14 (match input_value ic with 100 100 + (C f) -> f = 2.718 101 101 + | _ -> false); 102 102 + test 15 (match input_value ic with 103 103 + (D "hello, world!") -> true 104 104 + | _ -> false); 105 105 + test 16 (match input_value ic with 106 106 + (E 'l') -> true 107 107 + | _ -> false); 108 108 + test 17 (match input_value ic with 109 109 + (F(B 1)) -> true 110 110 + | _ -> false); 111 111 + test 18 (match input_value ic with 112 112 + (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true 113 113 + | _ -> false); 114 114 + test 19 (match input_value ic with 115 115 + (H(1, A)) -> true 116 116 + | _ -> false); 117 117 + test 20 (match input_value ic with 118 118 + (I(B 2, 1e-6)) -> true 119 119 + | _ -> false); 120 120 + test 21 (match input_value ic with 121 121 + G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) -> 122 122 + t1 == t2 && t3 == t5 && t4 == t1 123 123 + | _ -> false); 124 124 + test 22 (input_value ic = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); 125 125 + let rec check_big n t = 126 126 + if n <= 0 then 127 127 + test 23 (match t with A -> true | _ -> false) 128 128 + else 129 129 + match t with H(m, s) -> if m = n then check_big (n-1) s 130 130 + else test 23 false 131 131 + | _ -> test 23 false 132 132 + in 133 133 + check_big 1000 (input_value ic); 134 134 + test 26 (input_value ic = Int32.of_string "0"); 135 135 + test 27 (input_value ic = Int32.of_string "123456"); 136 136 + test 28 (input_value ic = Int32.of_string "-123456"); 137 137 + test 29 (input_value ic = Int64.of_string "0"); 138 138 + test 30 (input_value ic = Int64.of_string "123456789123456"); 139 139 + test 31 (input_value ic = Int64.of_string "-123456789123456"); 140 140 + test 32 (input_value ic = Nativeint.of_string "0"); 141 141 + test 33 (input_value ic = Nativeint.of_string "123456"); 142 142 + test 34 (input_value ic = Nativeint.of_string "-123456"); 143 143 + test 35 (input_value ic = 144 144 + Nativeint.shift_left (Nativeint.of_string "123456789") 32); 145 145 + test 36 (input_value ic = 146 146 + Nativeint.shift_left (Nativeint.of_string "-123456789") 32); 147 147 + let ((i, j) : int64 * int64) = input_value ic in 148 148 + test 37 (i = Int64.of_string "123456789123456"); 149 149 + test 38 (j = Int64.of_string "123456789123456"); 150 150 + test 39 (i == j); 151 151 + close_in ic 152 152 + 153 153 + let test_supported filename = 154 154 + Out_channel.(with_open_bin filename (fun oc -> output_value oc ())); 155 155 + let s = In_channel.(with_open_bin filename input_all) in 156 156 + let actually_supported = 157 157 + match s.[3] with 158 158 + | '\xBD' -> true 159 159 + | '\xBE' -> false 160 160 + | _ -> assert false in 161 161 + test 100 (actually_supported = compression_supported) 162 162 + 163 163 + let main () = 164 164 + test_out "intext.data"; test_in "intext.data"; 165 165 + test_supported "intext.data"; 166 166 + Sys.remove "intext.data" 167 167 + 168 168 + let _ = main ()

+38

testsuite/tests/lib-marshal/compressed.reference

reviewed

··· 1 1 + Test 1 passed. 2 2 + Test 2 passed. 3 3 + Test 3 passed. 4 4 + Test 4 passed. 5 5 + Test 5 passed. 6 6 + Test 6 passed. 7 7 + Test 7 passed. 8 8 + Test 8 passed. 9 9 + Test 9 passed. 10 10 + Test 10 passed. 11 11 + Test 11 passed. 12 12 + Test 12 passed. 13 13 + Test 13 passed. 14 14 + Test 14 passed. 15 15 + Test 15 passed. 16 16 + Test 16 passed. 17 17 + Test 17 passed. 18 18 + Test 18 passed. 19 19 + Test 19 passed. 20 20 + Test 20 passed. 21 21 + Test 21 passed. 22 22 + Test 22 passed. 23 23 + Test 23 passed. 24 24 + Test 26 passed. 25 25 + Test 27 passed. 26 26 + Test 28 passed. 27 27 + Test 29 passed. 28 28 + Test 30 passed. 29 29 + Test 31 passed. 30 30 + Test 32 passed. 31 31 + Test 33 passed. 32 32 + Test 34 passed. 33 33 + Test 35 passed. 34 34 + Test 36 passed. 35 35 + Test 37 passed. 36 36 + Test 38 passed. 37 37 + Test 39 passed. 38 38 + Test 100 passed.

+2 -6

testsuite/tests/lib-marshal/intext.ml

reviewed

··· 326 326 let s = 327 327 Marshal.to_bytes (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) flags in 328 328 test n (Marshal.header_size + Marshal.data_size s 0 = Bytes.length s) in 329 329 - test_one 300 []; 330 330 - test_one 301 [Marshal.Compression] 329 329 + test_one 300 [] 331 330 332 331 let test_bounds_checking () = 333 332 let test_one n v flags = ··· 341 340 with Invalid_argument _ -> true); 342 341 test (n+2) 343 342 (Marshal.from_string (s ^ "silly padding") 0 = v) in 344 344 - test_one 310 longstring []; 345 345 - test_one 320 longstring [Marshal.Compression] 343 343 + test_one 310 longstring [] 346 344 347 345 external marshal_to_block : int -> 'a -> Marshal.extern_flags list -> unit 348 346 = "marshal_to_block" ··· 618 616 test_out "intext.data"; test_in "intext.data"; 619 617 print_string "Default flags (again)\n"; 620 618 test_out "intext.data"; test_in "intext.data"; 621 621 - print_string "[Compression] flags\n"; 622 622 - test_out ~flags:[Marshal.Compression] "intext.data"; test_in "intext.data"; 623 619 print_string "Marshal.to_string\n"; 624 620 test_string(); 625 621 print_string "Marshal.to_buffer\n";

-44

testsuite/tests/lib-marshal/intext.reference

reviewed

··· 78 78 Test 37 passed. 79 79 Test 38 passed. 80 80 Test 39 passed. 81 81 - [Compression] flags 82 82 - Test 1 passed. 83 83 - Test 2 passed. 84 84 - Test 3 passed. 85 85 - Test 4 passed. 86 86 - Test 5 passed. 87 87 - Test 6 passed. 88 88 - Test 7 passed. 89 89 - Test 8 passed. 90 90 - Test 9 passed. 91 91 - Test 10 passed. 92 92 - Test 11 passed. 93 93 - Test 12 passed. 94 94 - Test 13 passed. 95 95 - Test 14 passed. 96 96 - Test 15 passed. 97 97 - Test 16 passed. 98 98 - Test 17 passed. 99 99 - Test 18 passed. 100 100 - Test 19 passed. 101 101 - Test 20 passed. 102 102 - Test 21 passed. 103 103 - Test 22 passed. 104 104 - Test 23 passed. 105 105 - Test 24 passed. 106 106 - Test 25 passed. 107 107 - Test 26 passed. 108 108 - Test 27 passed. 109 109 - Test 28 passed. 110 110 - Test 29 passed. 111 111 - Test 30 passed. 112 112 - Test 31 passed. 113 113 - Test 32 passed. 114 114 - Test 33 passed. 115 115 - Test 34 passed. 116 116 - Test 35 passed. 117 117 - Test 36 passed. 118 118 - Test 37 passed. 119 119 - Test 38 passed. 120 120 - Test 39 passed. 121 81 Marshal.to_string 122 82 Test 101 passed. 123 83 Test 102 passed. ··· 168 128 Test 223 passed. 169 129 Marshal.{header_size,data_size} 170 130 Test 300 passed. 171 171 - Test 301 passed. 172 131 Test 310 passed. 173 132 Test 311 passed. 174 133 Test 312 passed. 175 175 - Test 320 passed. 176 176 - Test 321 passed. 177 177 - Test 322 passed. 178 134 Marshaling to a block 179 135 Test 401 passed. 180 136 Test 402 passed.

+5 -4

tools/dumpobj.ml

reviewed

··· 502 502 List.iter print_reloc cu.cu_reloc; 503 503 if cu.cu_debug > 0 then begin 504 504 seek_in ic cu.cu_debug; 505 505 - let evl = (input_value ic : debug_event list) in 506 506 - ignore (input_value ic); (* Skip the list of absolute directory names *) 505 505 + let evl = (Compression.input_value ic : debug_event list) in 506 506 + ignore (Compression.input_value ic); 507 507 + (* Skip the list of absolute directory names *) 507 508 record_events 0 evl 508 509 end; 509 510 seek_in ic cu.cu_pos; ··· 530 531 let num_eventlists = input_binary_int ic in 531 532 for _i = 1 to num_eventlists do 532 533 let orig = input_binary_int ic in 533 533 - let evl = (input_value ic : debug_event list) in 534 534 + let evl = (Compression.input_value ic : debug_event list) in 534 535 (* Skip the list of absolute directory names *) 535 535 - ignore (input_value ic); 536 536 + ignore (Compression.input_value ic); 536 537 record_events orig evl 537 538 done 538 539 end;

+31

utils/compression.ml

reviewed

··· 1 1 + (**************************************************************************) 2 2 + (* *) 3 3 + (* OCaml *) 4 4 + (* *) 5 5 + (* Xavier Leroy, Collège de France and Inria project Cambium *) 6 6 + (* *) 7 7 + (* Copyright 2023 Institut National de Recherche en Informatique et *) 8 8 + (* en Automatique. *) 9 9 + (* *) 10 10 + (* All rights reserved. This file is distributed under the terms of *) 11 11 + (* the GNU Lesser General Public License version 2.1, with the *) 12 12 + (* special exception on linking described in the file LICENSE. *) 13 13 + (* *) 14 14 + (**************************************************************************) 15 15 + 16 16 + external zstd_initialize: unit -> bool = "caml_zstd_initialize" 17 17 + 18 18 + let compression_supported = zstd_initialize () 19 19 + 20 20 + type [@warning "-unused-constructor"] extern_flags = 21 21 + No_sharing (** Don't preserve sharing *) 22 22 + | Closures (** Send function closures *) 23 23 + | Compat_32 (** Ensure 32-bit compatibility *) 24 24 + | Compression (** Optional compression *) 25 25 + 26 26 + external to_channel: out_channel -> 'a -> extern_flags list -> unit 27 27 + = "caml_output_value" 28 28 + 29 29 + let output_value ch v = to_channel ch v [Compression] 30 30 + 31 31 + let input_value = Stdlib.input_value

+34

utils/compression.mli

reviewed

··· 1 1 + (**************************************************************************) 2 2 + (* *) 3 3 + (* OCaml *) 4 4 + (* *) 5 5 + (* Xavier Leroy, Collège de France and Inria project Cambium *) 6 6 + (* *) 7 7 + (* Copyright 2023 Institut National de Recherche en Informatique et *) 8 8 + (* en Automatique. *) 9 9 + (* *) 10 10 + (* All rights reserved. This file is distributed under the terms of *) 11 11 + (* the GNU Lesser General Public License version 2.1, with the *) 12 12 + (* special exception on linking described in the file LICENSE. *) 13 13 + (* *) 14 14 + (**************************************************************************) 15 15 + 16 16 + val output_value : out_channel -> 'a -> unit 17 17 + (** [Compression.output_value chan v] writes the representation 18 18 + of [v] on channel [chan]. 19 19 + If compression is supported, the marshaled data 20 20 + representing value [v] is compressed before being written to 21 21 + channel [chan]. 22 22 + If compression is not supported, this function behaves like 23 23 + {!Stdlib.output_value}. *) 24 24 + 25 25 + val input_value : in_channel -> 'a 26 26 + (** [Compression.input_value chan] reads from channel [chan] the 27 27 + byte representation of a structured value, as produced by 28 28 + [Compression.output_value], and reconstructs and 29 29 + returns the corresponding value. 30 30 + If compression is not supported, this function behaves like 31 31 + {!Stdlib.input_value}. *) 32 32 + 33 33 + val compression_supported : bool 34 34 + (** Reports whether compression is supported. *)

-1

utils/config.common.ml.in

reviewed

··· 117 117 p_bool "supports_shared_libraries" supports_shared_libraries; 118 118 p_bool "native_dynlink" native_dynlink; 119 119 p_bool "naked_pointers" naked_pointers; 120 120 - p_bool "compression_supported" (Marshal.compression_supported()); 121 120 122 121 p "exec_magic_number" exec_magic_number; 123 122 p "cmi_magic_number" cmi_magic_number;