├── .github └── workflows │ └── main.yml ├── .gitignore ├── changes.md ├── dune ├── dune-project ├── embed_file.ml ├── lowcaml.ml ├── lowcaml_stdlib.mli ├── readme.md └── tests ├── dune ├── test.ml └── test_lowcaml.ml /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: main 2 | on: 3 | push: 4 | pull_request: 5 | jobs: 6 | test: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v2 10 | - uses: ocaml/setup-ocaml@v2 11 | with: 12 | ocaml-compiler: ocaml-variants.5.0.0+options,ocaml-option-flambda,ocaml-option-no-flat-float-array 13 | dune-cache: true 14 | - run: opam exec -- dune runtest 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | lowcaml.opam 2 | -------------------------------------------------------------------------------- /changes.md: -------------------------------------------------------------------------------- 1 | Working version 2 | --------------- 3 | 4 | - initial version 5 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name lowcaml) 3 | (public_name lowcaml.exe) 4 | (package lowcaml) 5 | (modules lowcaml lowcaml_stdlib_cmi) 6 | (ocamlopt_flags :standard -O3) 7 | (libraries compiler-libs compiler-libs.optcomp compiler-libs.common)) 8 | 9 | (rule 10 | (targets lowcaml_stdlib_cmi.ml) 11 | (deps 12 | (file lowcaml_stdlib.cmi)) 13 | (action 14 | (run ./embed_file.exe lowcaml_stdlib.cmi lowcaml_stdlib_cmi.ml))) 15 | 16 | (executable 17 | (name embed_file) 18 | (modules embed_file)) 19 | 20 | (rule 21 | (targets lowcaml_stdlib.cmi) 22 | (deps 23 | (file lowcaml_stdlib.mli)) 24 | (action 25 | (run ocamlc lowcaml_stdlib.mli))) 26 | 27 | (library 28 | (name lowcaml_stdlib) 29 | (public_name lowcaml.stdlib) 30 | (modules lowcaml_stdlib) 31 | (virtual_modules lowcaml_stdlib)) 32 | 33 | (env 34 | (dev 35 | (flags 36 | :standard 37 | -w 38 | @68 39 | -warn-error 40 | -3-26-27-32-48-58-60 41 | -bin-annot 42 | -color 43 | always)) 44 | (strict 45 | (flags :standard -w @68 -bin-annot -color always))) 46 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) 2 | (executables_implicit_empty_intf true) 3 | (generate_opam_files true) 4 | (package (name lowcaml)) 5 | -------------------------------------------------------------------------------- /embed_file.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | match Sys.argv with 3 | | [| _; source; dest |] -> 4 | let source = In_channel.with_open_bin source In_channel.input_all in 5 | Out_channel.with_open_bin dest (fun c -> 6 | output_string c {|let data = "|}; 7 | output_string c (String.escaped source); 8 | output_string c {|"|}; 9 | ) 10 | | _ -> 11 | print_endline "Usage: embed source dest"; 12 | exit 1 13 | -------------------------------------------------------------------------------- /lowcaml.ml: -------------------------------------------------------------------------------- 1 | (* 0.1 release checklist 2 | - more examples/tests 3 | *) 4 | (* TODO 5 | - top-level constants 6 | - match/switch 7 | - lift let-bindings in expressions 8 | - lift mut creation 9 | - built-in C types (uint8_t, etc.) 10 | - custom C types (struct) 11 | - clock_gettime64 needs [struct timespec t; clock_gettime(&t)] 12 | - maybe via arrays? 13 | - tests 14 | - failing (expect) tests 15 | - generated code beauty 16 | - remove parenthesis from expressions (operator precedence) 17 | - remove shadowing suffix if allowed due to blocks 18 | - un-nest if-else chains 19 | - preserve comments 20 | - preserve number literals 21 | - group includes together 22 | - bounds checks 23 | - check whether int fits into OCaml int before returning it (likely requires stubs) 24 | - complete stdlib 25 | - use fsanitize=undefined 26 | - generate (void)x to handle unused warning (enable -Wextra) 27 | - sub-modules 28 | - inner functions 29 | - named arguments 30 | - optional arguments 31 | - 'a -> void* 32 | - [@inline] -> __attribute__((always_inline)) 33 | - (local) try -> goto 34 | - "export"/static 35 | - let (bar[@c_name "foo"]) x y = 36 | - type foo [@c_name "foo"] 37 | - nicer cmdline interface 38 | - lowcaml libraries (install mli+h?) 39 | - convert lowcaml_stdlib to library 40 | - order of side effects (e.g. in parameters)? 41 | - track dependencies of headers, remove unused header includes 42 | - include ocaml-style error in Not_supported 43 | - portable vector instructions? (http://gcc.gnu.org/onlinedocs/gcc/Vector-Extensions.html) 44 | 45 | - things to rework 46 | - the pointer types 47 | 48 | - examples 49 | - sieve 50 | - memchr (simd + bindings) 51 | - bigarray ops 52 | 53 | - porting 54 | - Array.sort (from OCaml stdlib) 55 | - bigstringaf (or other) stubs 56 | - add two float bigarrays (like owl) 57 | - bitops (popcount, bsr, bsf) 58 | - hardware aes (for rng/hash) 59 | *) 60 | 61 | let logging = ref false 62 | let log fmt = 63 | if !logging 64 | then Format.kfprintf (fun f -> Format.pp_print_newline f ()) Format.err_formatter fmt 65 | else Format.ikfprintf (fun _ -> ()) Format.err_formatter fmt 66 | let print fmt = Format.eprintf (fmt ^^ "@.") 67 | let failwithf fmt = Format.kasprintf failwith fmt 68 | let sprintf = Printf.sprintf 69 | 70 | exception Not_supported of string 71 | let not_supported fmt = Format.kasprintf (fun msg -> raise (Not_supported msg)) fmt 72 | 73 | module C_ast = struct 74 | type identifier = I of string [@unboxed] 75 | 76 | let create_identifer i = 77 | if i = "" || i.[0] <= '9' || not @@ String.for_all (function '0'..'9' | 'a'..'z' | 'A'..'Z' | '_' -> true | _ -> false) i then 78 | not_supported "Bad C identifier: %S" i; 79 | I i 80 | 81 | type ty = 82 | | I64 | I32 | I16 | I8 83 | | U64 | U32 | U16 | U8 84 | | Bool | Char 85 | | Float | Double 86 | | M128i | M256i | M512i 87 | | Mmask16 88 | | Value 89 | | Void_ptr | Const_void_ptr 90 | | Ptr of ty 91 | | Const of ty 92 | 93 | type expression = 94 | | Constant of int 95 | | Constant_i64 of int64 96 | | Constant_float of float 97 | | Constant_char of char 98 | | Constant_bool of bool 99 | | Call of identifier * expression list 100 | | Op1 of string * expression 101 | | Op2 of string * expression * expression 102 | | Ternary of expression * expression * expression 103 | | Variable of identifier 104 | | Deref of expression 105 | | Addr_of of expression 106 | | Cast of ty * expression 107 | 108 | type declaration = ty * identifier * expression 109 | 110 | type statement = 111 | | Declaration of declaration 112 | | Expression of expression 113 | | For of declaration * expression * expression * statement list 114 | | While of expression * statement list 115 | | If_then of expression * statement list 116 | | If_then_else of expression * statement list * statement list 117 | | Return of expression 118 | 119 | type element = 120 | | Function of { 121 | name: identifier; 122 | args: (identifier * ty) list; 123 | return_type: ty option; 124 | body: statement list; 125 | } 126 | | Prototype of { 127 | name: identifier; 128 | args: ty list; 129 | return_type: ty option; 130 | } 131 | | Include of string 132 | 133 | type t = { 134 | elements: element list; 135 | } 136 | 137 | module Print = struct 138 | let pr = Buffer.add_string 139 | let pr_indent buf len = Buffer.add_string buf (String.make (4 * len) ' ') 140 | let rec sep buf seperator f = function 141 | | [] -> () 142 | | [x] -> f buf x 143 | | x :: xs -> f buf x; pr buf seperator; sep buf seperator f xs 144 | 145 | let rec ty buf = function 146 | | I64 -> pr buf "int64_t" 147 | | I32 -> pr buf "int32_t" 148 | | I16 -> pr buf "int16_t" 149 | | I8 -> pr buf "int8_t" 150 | | U64 -> pr buf "uint64_t" 151 | | U32 -> pr buf "uint32_t" 152 | | U16 -> pr buf "uint16_t" 153 | | U8 -> pr buf "uint8_t" 154 | | Bool -> pr buf "bool" 155 | | Char -> pr buf "char" 156 | | Float -> pr buf "float" 157 | | Double -> pr buf "double" 158 | | M128i -> pr buf "__m128i" 159 | | M256i -> pr buf "__m256i" 160 | | M512i -> pr buf "__m512i" 161 | | Mmask16 -> pr buf "__mmask16" 162 | | Value -> pr buf "value" 163 | | Void_ptr -> pr buf "void*" 164 | | Const_void_ptr -> pr buf "const void*" 165 | | Ptr t -> ty buf t; pr buf "*" 166 | | Const Const_void_ptr -> pr buf "const void*const" 167 | | Const Void_ptr -> pr buf "void*const" 168 | | Const Ptr t -> ty buf t; pr buf "*const" 169 | | Const Const _ -> failwith "Bad C type: nested const" 170 | | Const t -> pr buf "const "; ty buf t 171 | 172 | let arg buf (I var, t) = 173 | ty buf t; 174 | pr buf " "; 175 | pr buf var 176 | 177 | let rec expression buf = function 178 | | Constant i -> pr buf (string_of_int i); 179 | | Constant_i64 i when i = Int64.min_int -> pr buf "(-9223372036854775807-1)"; (* "integer constant is so large that it is unsigned" *) 180 | | Constant_i64 i -> pr buf (Int64.to_string i); 181 | | Constant_float f -> pr buf (Float.to_string f); 182 | | Constant_char '\\' -> pr buf "'\\\\'" 183 | | Constant_char c when c >= ' ' && c <= '~' -> pr buf (sprintf "'%c'" c); 184 | | Constant_char c -> pr buf (sprintf "'\\x%02x'" (Char.code c)); 185 | | Constant_bool b -> pr buf (string_of_bool b); 186 | | Variable I v -> pr buf v; 187 | | Op1 (op, arg) -> pr buf "("; pr buf op; expression buf arg; pr buf ")" 188 | | Op2 (op, lhs, rhs) -> 189 | pr buf "("; expression buf lhs; pr buf op; expression buf rhs; pr buf ")" 190 | | Ternary (cond, then_, else_) -> 191 | pr buf "(("; expression buf cond; pr buf ") ? ("; 192 | expression buf then_; pr buf ") : ("; 193 | expression buf else_; pr buf "))"; 194 | | Call (I f, args) -> pr buf f; pr buf "("; sep buf ", " expression args; pr buf ")" 195 | | Deref e -> pr buf "*"; expression buf e 196 | | Addr_of e -> pr buf "&"; expression buf e 197 | | Cast (t, e) -> pr buf "("; ty buf t; pr buf ")"; expression buf e 198 | 199 | let declaration buf indent (t, I var, expr) = 200 | pr_indent buf indent; 201 | ty buf t; 202 | pr buf " "; 203 | pr buf var; 204 | pr buf " = "; 205 | expression buf expr; 206 | pr buf ";" 207 | 208 | let rec statement indent buf = function 209 | | Declaration d -> 210 | declaration buf indent d 211 | | Expression expr -> 212 | pr_indent buf indent; 213 | expression buf expr; 214 | pr buf ";" 215 | | For (d, cond, after, body) -> 216 | pr_indent buf indent; 217 | pr buf "for("; 218 | declaration buf 0 d; 219 | pr buf " "; 220 | expression buf cond; 221 | pr buf "; "; 222 | expression buf after; 223 | pr buf ")\n"; 224 | statements buf indent body; 225 | | While (cond, body) -> 226 | pr_indent buf indent; 227 | pr buf "while("; 228 | expression buf cond; 229 | pr buf ")\n"; 230 | statements buf indent body 231 | | If_then (cond, then_) -> 232 | pr_indent buf indent; 233 | pr buf "if("; 234 | expression buf cond; 235 | pr buf ")\n"; 236 | statements buf indent then_; 237 | | If_then_else (cond, then_, else_) -> 238 | pr_indent buf indent; 239 | pr buf "if("; 240 | expression buf cond; 241 | pr buf ")\n"; 242 | statements buf indent then_; 243 | pr buf "\n"; 244 | pr_indent buf indent; 245 | pr buf "else\n"; 246 | statements buf indent else_ 247 | | Return expr -> 248 | pr_indent buf indent; 249 | pr buf "return "; 250 | expression buf expr; 251 | pr buf ";" 252 | 253 | and statements buf indent statements = 254 | pr_indent buf indent; 255 | pr buf "{\n"; 256 | sep buf "\n" (statement (1 + indent)) statements; 257 | pr buf "\n"; (* Maybe merge into [sep]? *) 258 | pr_indent buf indent; 259 | pr buf "}" 260 | 261 | let element buf = function 262 | | Function { return_type; name = I name; args; body } -> 263 | (match return_type with None -> pr buf "void" | Some t -> ty buf t); 264 | pr buf " "; 265 | pr buf name; 266 | pr buf "("; 267 | (match args with 268 | | [] -> pr buf "void" 269 | | args -> sep buf ", " arg args); 270 | pr buf ")\n"; 271 | statements buf 0 body 272 | | Prototype { name = I name; args; return_type } -> 273 | (match return_type with None -> pr buf "void" | Some t -> ty buf t); 274 | pr buf " "; 275 | pr buf name; 276 | pr buf "("; 277 | (match args with 278 | | [] -> pr buf "void" 279 | | args -> sep buf ", " ty args); 280 | pr buf ");" 281 | | Include name -> 282 | pr buf "#include "; 283 | pr buf name 284 | 285 | let print { elements } = 286 | let buf = Buffer.create 1000 in 287 | Buffer.add_string buf "// generated by lowcaml\n"; 288 | sep buf "\n\n" element elements; 289 | pr buf "\n"; 290 | Buffer.contents buf 291 | end 292 | 293 | module Simplify = struct 294 | let rec simplify_expression = function 295 | | Deref (Addr_of x) -> x (* appears naturally due to Mut.t *) 296 | 297 | | Call (i, args) -> Call (i, List.map simplify_expression args) 298 | | Op1 (op, rhs) -> Op1 (op, simplify_expression rhs) 299 | | Op2 (op, lhs, rhs) -> Op2 (op, simplify_expression lhs, simplify_expression rhs) 300 | | Ternary (i, t, e) -> Ternary (simplify_expression i, simplify_expression t, simplify_expression e) 301 | | Constant _ | Constant_bool _ | Constant_float _ | Constant_i64 _ | Constant_char _ as x -> x 302 | | Variable _ as v -> v 303 | | Deref e -> Deref (simplify_expression e) 304 | | Addr_of e -> Addr_of (simplify_expression e) 305 | | Cast (ty, e) -> Cast (ty, simplify_expression e) 306 | 307 | let rec simplify_statement = function 308 | | Declaration _ as d -> d 309 | | Expression e -> Expression (simplify_expression e) 310 | | For (d, cond, after, body) -> For (d, simplify_expression cond, simplify_expression after, simplify_body body) 311 | | While (cond, body) -> While (simplify_expression cond, simplify_body body) 312 | | If_then (cond, body) -> If_then (simplify_expression cond, simplify_body body) 313 | | If_then_else (cond, then_, else_) -> If_then_else (simplify_expression cond, simplify_body then_, simplify_body else_) 314 | | Return e -> Return (simplify_expression e) 315 | and simplify_body s = List.map simplify_statement s 316 | 317 | let simplify_element = function 318 | | Function f -> Function { f with body = simplify_body f.body } 319 | | Prototype _ | Include _ as el -> el 320 | 321 | let go t = { elements = List.map simplify_element t.elements } 322 | end 323 | end 324 | 325 | module Names = struct 326 | module M = Map.Make(String) 327 | 328 | type t = { 329 | scope: int; 330 | idents: (C_ast.identifier * [`Mut | `Const]) Ident.Map.t; 331 | map: string M.t; 332 | } 333 | 334 | let empty = { scope = 0; map = M.empty; idents = Ident.Map.empty } 335 | 336 | let enter_scope t = { t with scope = t.scope + 1 } 337 | 338 | let get t id = Ident.Map.find id t.idents 339 | 340 | let new_var t ?(mut=false) ?ident var = 341 | let rec find_free_var i = 342 | let var = if i = 0 then var else sprintf "%s_%d" var i in 343 | if M.find_opt var t.map = None then var 344 | else find_free_var (i + 1) 345 | in 346 | let var = find_free_var 0 in 347 | { t with 348 | idents = (match ident with Some id -> Ident.Map.add id (C_ast.create_identifer var, if mut then `Mut else `Const) t.idents | None -> t.idents); 349 | map = M.add var var t.map }, 350 | C_ast.create_identifer var 351 | end 352 | 353 | module OCaml_type = struct 354 | type t = 355 | | Type_variable of { name: string } 356 | | Int 357 | | Int32 358 | | Int64 359 | | Float 360 | | Char 361 | | Bool 362 | | Unit 363 | | Bytes 364 | | String 365 | | Bigarray 366 | (* Lowcaml_stdlib types below *) 367 | | F32 368 | | U8 369 | | U16 370 | | U32 371 | | U64 372 | | I8 373 | | I16 374 | | M128i 375 | | M256i 376 | | M512i 377 | | Mmask16 378 | | Void_ptr 379 | | Const_void_ptr 380 | | Ptr of t 381 | | Const_ptr of t 382 | | Mut of t 383 | 384 | let rec map ~where env ty = 385 | match Types.get_desc (Ctype.expand_head env ty) with 386 | | Tvar (Some name) -> Type_variable { name = "'" ^ name } 387 | | Tvar None -> Type_variable { name = "_" } 388 | | Tconstr (path, [], _) when Path.same path Predef.path_unit -> Unit 389 | | Tconstr (path, [], _) when Path.same path Predef.path_bool -> Bool 390 | | Tconstr (path, [], _) when Path.same path Predef.path_int -> Int 391 | | Tconstr (path, [], _) when Path.same path Predef.path_int32 -> Int32 392 | | Tconstr (path, [], _) when Path.same path Predef.path_int64 -> Int64 393 | | Tconstr (path, [], _) when Path.same path Predef.path_float -> Float 394 | | Tconstr (path, [], _) when Path.same path Predef.path_char -> Char 395 | | Tconstr (path, [], _) when Path.same path Predef.path_bytes -> Bytes 396 | | Tconstr (path, [], _) when Path.same path Predef.path_string -> String 397 | | Tconstr (path, [], _) -> 398 | (match Path.name path with 399 | | "Lowcaml_stdlib.F32.t" -> F32 400 | | "Lowcaml_stdlib.SIMD.__m128i" -> M128i 401 | | "Lowcaml_stdlib.SIMD.__m256i" -> M256i 402 | | "Lowcaml_stdlib.SIMD.__m512i" -> M512i 403 | | "Lowcaml_stdlib.SIMD.__mmask16" -> Mmask16 404 | | "Lowcaml_stdlib.Void_ptr.t" -> Void_ptr 405 | | "Lowcaml_stdlib.Const_void_ptr.t" -> Const_void_ptr 406 | | "Lowcaml_stdlib.Uint8_t.t" -> U8 407 | | "Lowcaml_stdlib.Uint16_t.t" -> U16 408 | | "Lowcaml_stdlib.Uint32_t.t" -> U32 409 | | "Lowcaml_stdlib.Uint64_t.t" -> U64 410 | | "Lowcaml_stdlib.Int8_t.t" -> I8 411 | | "Lowcaml_stdlib.Int16_t.t" -> I16 412 | | _ -> not_supported "unknown type: %a in %s" Printtyp.type_expr ty where) 413 | | Tconstr (path, [tyarg], _) -> 414 | (match Path.name path with 415 | | "Lowcaml_stdlib.Ptr.t" -> Ptr (map ~where env tyarg) 416 | | "Lowcaml_stdlib.Const_ptr.t" -> Const_ptr (map ~where env tyarg) 417 | | "Lowcaml_stdlib.Mut.t" -> Mut (map ~where env tyarg) 418 | | _ -> not_supported "unknown type: %a in %s" Printtyp.type_expr ty where) 419 | | Tconstr (path, [_ty; _kind; _layout], _) when Path.name path = "Stdlib__Bigarray.Array1.t" -> 420 | Bigarray (* TODO: check 3rd type parameter is c_layout? *) 421 | | _ -> 422 | not_supported "type expression: %a in %s" Printtyp.type_expr ty where 423 | 424 | let rec show = function 425 | | Type_variable { name } -> name 426 | | Int -> "int" 427 | | Int32 -> "int32" 428 | | Int64 -> "int64" 429 | | Float -> "float" 430 | | Char -> "char" 431 | | Bool -> "bool" 432 | | Unit -> "unit" 433 | | Bytes -> "bytes" 434 | | String -> "string" 435 | | Bigarray -> "(_, _, _) Bigarray.Array1.t" 436 | | F32 -> "Lowcaml_stdlib.F32.t" 437 | | U8 -> "Lowcaml_stdlib.Uint8_t.t" 438 | | U16 -> "Lowcaml_stdlib.Uint16_t.t" 439 | | U32 -> "Lowcaml_stdlib.Uint32_t.t" 440 | | U64 -> "Lowcaml_stdlib.Uint64_t.t" 441 | | I8 -> "Lowcaml_stdlib.Int8_t.t" 442 | | I16 -> "Lowcaml_stdlib.Int16_t.t" 443 | | M128i -> "Lowcaml_stdlib.SIMD.__m128i" 444 | | M256i -> "Lowcaml_stdlib.SIMD.__m256i" 445 | | M512i -> "Lowcaml_stdlib.SIMD.__m512i" 446 | | Mmask16 -> "Lowcaml_stdlib.SIMD.__mmask16" 447 | | Void_ptr -> "Lowcaml_stdlib.Void_ptr.t" 448 | | Const_void_ptr -> "Lowcaml_stdlib.Const_void_ptr.t" 449 | | Ptr t -> show t ^ " Lowcaml_stdlib.Ptr.t" 450 | | Const_ptr t -> show t ^ " Lowcaml_stdlib.Const_ptr.t" 451 | | Mut t -> show t ^ " Lowcaml_stdlib.Mut.t" 452 | 453 | (* TODO: random test: x = map (show x) *) 454 | end 455 | 456 | module Lowcaml = struct 457 | open Typedtree 458 | open C_ast 459 | 460 | let print_structure_item fmt str = Pprintast.structure_item fmt (Untypeast.default_mapper.structure_item Untypeast.default_mapper str) 461 | let print_expr fmt e = Pprintast.expression fmt (Untypeast.untype_expression e) 462 | let print_pat fmt p = Pprintast.pattern fmt (Untypeast.untype_pattern p) 463 | 464 | let rec ocaml_type_to_ctype ~where = function 465 | | OCaml_type.Int | Int64 -> I64 466 | | Int32 -> I32 467 | | Float -> Double 468 | | Bool -> Bool 469 | | Char -> Char 470 | | Bytes | String | Bigarray | Unit -> Value 471 | | F32 -> Float 472 | | U8 -> U8 473 | | U16 -> U16 474 | | U32 -> U32 475 | | U64 -> U64 476 | | I8 -> I8 477 | | I16 -> I16 478 | | M128i -> M128i 479 | | M256i -> M256i 480 | | M512i -> M512i 481 | | Mmask16 -> Mmask16 482 | | Void_ptr -> Void_ptr 483 | | Const_void_ptr -> Const_void_ptr 484 | | Ptr Type_variable _ | Mut Type_variable _ -> Void_ptr 485 | | Const_ptr Type_variable _ -> Const_void_ptr 486 | | Ptr t -> Ptr (ocaml_type_to_ctype ~where t) 487 | | Const_ptr t -> Ptr (Const (ocaml_type_to_ctype ~where t)) 488 | | Mut t -> Ptr (ocaml_type_to_ctype ~where t) 489 | | Type_variable _ as t -> not_supported "type variable: %s" (OCaml_type.show t) 490 | 491 | let ocaml_type_to_external_type ~where = function 492 | | OCaml_type.Int -> "(int[@untagged])" 493 | | Int64 -> "(int64[@unboxed])" 494 | | Int32 -> "(int32[@unboxed])" 495 | | Float -> "(float[@unboxed])" 496 | | Bool | Char -> "(int[@untagged])" (* converted to int in OCaml stub *) 497 | | Bytes -> "bytes" 498 | | String -> "string" 499 | | Unit -> "unit" 500 | | Bigarray -> "(_, _, Bigarray.c_layout) Bigarray.Array1.t" (* TODO: also map type parameters *) 501 | | F32 | U8 | U16 502 | | U32 | U64 | I8 503 | | I16 504 | | M128i | M256i | M512i 505 | | Mmask16 506 | | Void_ptr | Const_void_ptr 507 | | Ptr _ | Const_ptr _ 508 | | Mut _ as t -> 509 | not_supported "type: %s in %s" (OCaml_type.show t) where 510 | | Type_variable _ as t -> 511 | not_supported "type variable: %s in %s" (OCaml_type.show t) where 512 | 513 | let is_unit ty = 514 | match Types.get_desc ty with 515 | | Tconstr (path, [], _) when Path.same path Predef.path_unit -> true 516 | | _ -> false 517 | 518 | let is_bool ty = 519 | match Types.get_desc ty with 520 | | Tconstr (path, [], _) when Path.same path Predef.path_bool -> true 521 | | _ -> false 522 | 523 | let rec get_var_from_pat pat = 524 | match pat.pat_desc with 525 | | Tpat_var (ident, var) -> Some ident, var.txt 526 | | Tpat_any -> None, "unused" 527 | | Tpat_construct (_, constr, _, _) when is_unit constr.cstr_res -> None, "unit" 528 | | Tpat_alias (p, ident, var) -> let _ = get_var_from_pat p in Some ident, var.txt 529 | | Tpat_variant _ -> not_supported "variant pattern: %a" print_pat pat 530 | | Tpat_construct _ -> not_supported "construct pattern: %a" print_pat pat 531 | | _ -> not_supported "pattern: %a" print_pat pat 532 | 533 | let rec get_args expr = 534 | (* TODO: not_supported "mixing unit and non-unit arguments: %a" print_pat pat *) 535 | match expr.exp_desc with 536 | | Texp_function { 537 | arg_label = Nolabel; 538 | param; 539 | cases = [{ c_lhs; c_guard = None; c_rhs }]; 540 | partial = Total; 541 | } -> 542 | let rest, body = get_args c_rhs in 543 | let _ident, name = get_var_from_pat c_lhs in 544 | (param, name, c_lhs.pat_type) :: rest, body 545 | | Texp_function _ -> 546 | not_supported "partial/label/pattern in function: %a" print_expr expr 547 | | _ -> 548 | [], expr 549 | 550 | let generate_primitive name args = 551 | let bad_arity expected f = failwithf "Bad arity: %s expected %d got %d" f expected (List.length args) in 552 | let args1 f = function [x] -> x | _ -> bad_arity 1 f in 553 | let args2 f = function [x; y] -> x, y | _ -> bad_arity 2 f in 554 | let args3 f = function [x; y; z] -> x, y, z | _ -> bad_arity 3 f in 555 | let bytes_get size args = 556 | let buf, offset = args2 name args in 557 | (* NOTE: only ub-safe because all C code is compiled with -fno-strict-aliasing *) 558 | (* Deref (Cast (Ptr size, Op2 ("+", Call (create_identifer "Bytes_val", [buf]), offset))) *) 559 | Deref (Cast (Ptr size, Addr_of (Call (create_identifer "Byte", [buf; offset])))) 560 | in 561 | let bytes_set size args = 562 | let buf, offset, value = args3 name args in 563 | (* Op2 ("=", Deref (Cast (Ptr size, Op2 ("+", Call (create_identifer "Bytes_val", [buf]), offset))), value) *) 564 | Op2 ("=", Deref (Cast (Ptr size, Addr_of (Call (create_identifer "Byte", [buf; offset])))), Cast (size, value)) 565 | in 566 | match name with 567 | | "lowcaml_bytes_length" -> 568 | let buf = args1 name args in 569 | Cast (I64, Call (create_identifer "caml_string_length", [buf])) 570 | | "lowcaml_bytes_get_uint8" -> bytes_get U8 args 571 | | "lowcaml_bytes_get_uint16" -> bytes_get U16 args 572 | | "lowcaml_bytes_get_uint32" -> bytes_get U32 args 573 | | "lowcaml_bytes_get_int32" -> bytes_get I32 args 574 | | "lowcaml_bytes_set_int8" -> bytes_set U8 args 575 | | "lowcaml_bytes_set_int16" -> bytes_set U16 args 576 | | "lowcaml_ptr_offset" -> 577 | (* (void* )((uint8_t* )ptr+offset) *) 578 | let ptr, offset = args2 name args in 579 | Cast (Void_ptr, Op2 ("+", Cast (Ptr U8, ptr), offset)) 580 | (* 581 | | "lowcaml_ptr_offset" -> 582 | (* (ptr+offset) *) 583 | let ptr, offset = args2 name args in 584 | Op2 ("+", ptr, offset) 585 | *) 586 | | "lowcaml_ptr_to_int" -> 587 | let ptr = args1 name args in 588 | Cast (I64, ptr) 589 | | "lowcaml_ptr_get_uint8" -> 590 | let ptr = args1 name args in 591 | Deref (Cast (Ptr U8, ptr)) 592 | | "lowcaml_ptr_write64" -> 593 | let ptr, value = args2 name args in 594 | Op2 ("=", Deref (Cast (Ptr I64, ptr)), value) 595 | | "lowcaml_bigarray_to_ptr" -> 596 | let bigarray = args1 name args in 597 | Cast (Void_ptr, Call (create_identifer "Caml_ba_data_val", [bigarray])) 598 | | "lowcaml_bytes_to_ptr" -> 599 | let bytes = args1 name args in 600 | Cast (Void_ptr, Call (create_identifer "Bytes_val", [bytes])) 601 | | "lowcaml_string_to_constptr" -> 602 | let bytes = args1 name args in 603 | Cast (Const_void_ptr, Call (create_identifer "String_val", [bytes])) 604 | | "lowcaml_ptr_to_const_ptr" -> 605 | Cast (Const_void_ptr, args1 name args) 606 | | "lowcaml_int32_to_int" -> 607 | Cast (I64, args1 name args) 608 | | "lowcaml_char_to_int" -> 609 | Op2 ("&", Constant 0xFF, Cast (I64, args1 name args)) 610 | | "lowcaml_int32_of_int" -> 611 | Cast (I32, args1 name args) 612 | | "lowcaml_int32_of_char" -> 613 | Op2 ("&", Constant 0xFF, Cast (I32, args1 name args)) 614 | | "lowcaml_int_to_uint64_t" -> 615 | Cast (U64, args1 name args) 616 | | "lowcaml_deref" -> 617 | Deref (args1 name args) 618 | | "lowcaml_mut_set" -> 619 | let ptr, value = args2 name args in 620 | Op2 ("=", Deref ptr, value) 621 | | "lowcaml_mut_create" -> 622 | not_supported "Mut.t is not allowed here" 623 | | "%identity" -> 624 | args1 name args 625 | | "%equal" -> let lhs, rhs = args2 name args in Op2 ("==", lhs, rhs) 626 | | "%notequal" -> let lhs, rhs = args2 name args in Op2 ("!=", lhs, rhs) 627 | | "%greaterthan" -> let lhs, rhs = args2 name args in Op2 (">", lhs, rhs) 628 | | "%lessthan" -> let lhs, rhs = args2 name args in Op2 ("<", lhs, rhs) 629 | | "%greaterequal" -> let lhs, rhs = args2 name args in Op2 (">=", lhs, rhs) 630 | | "%lessequal" -> let lhs, rhs = args2 name args in Op2 ("<=", lhs, rhs) 631 | | "%negint" -> Op1 ("-", args1 name args) 632 | | "%addint" | "%addfloat" -> let lhs, rhs = args2 name args in Op2 ("+", lhs, rhs) 633 | | "%subint" | "%subfloat" -> let lhs, rhs = args2 name args in Op2 ("-", lhs, rhs) 634 | | "%mulint" | "%mulfloat" -> let lhs, rhs = args2 name args in Op2 ("*", lhs, rhs) 635 | | "%divfloat" -> let lhs, rhs = args2 name args in Op2 ("/", lhs, rhs) 636 | | "%andint" -> let lhs, rhs = args2 name args in Op2 ("&", lhs, rhs) 637 | | "%orint" -> let lhs, rhs = args2 name args in Op2 ("|", lhs, rhs) 638 | | "%xorint" -> let lhs, rhs = args2 name args in Op2 ("^", lhs, rhs) 639 | | "%lslint" -> let lhs, rhs = args2 name args in Op2 ("<<", lhs, rhs) 640 | | "%lsrint" -> let lhs, rhs = args2 name args in Cast (I64, Op2 (">>", Cast (U64, lhs), rhs)) 641 | | "%int32_lsr" -> let lhs, rhs = args2 name args in Cast (I32, Op2 (">>", Cast (U32, lhs), rhs)) 642 | | "%asrint" -> let lhs, rhs = args2 name args in Op2 (">>", lhs, rhs) 643 | | "%boolnot" -> Op1 ("!", args1 name args) 644 | | "%sequand" -> let lhs, rhs = args2 name args in Op2 ("&&", lhs, rhs) 645 | | "%sequor" -> let lhs, rhs = args2 name args in Op2 ("||", lhs, rhs) 646 | | name when 647 | String.starts_with ~prefix:"%" name || 648 | String.starts_with ~prefix:"lowcaml" name -> 649 | failwithf "Unimplemented primitive: %s" name; 650 | | name -> 651 | Call (create_identifer name, args) 652 | 653 | let rec generate_simple_expression names expr = 654 | match expr.exp_desc with 655 | | Texp_apply ({ exp_desc = Texp_ident (_path, _, { val_kind = Val_prim prim; _ }); _ }, args) -> 656 | let args = 657 | match args with 658 | | [Asttypes.Nolabel, Some t] when is_unit t.exp_type -> [] 659 | | args -> 660 | List.map (function 661 | | Asttypes.Nolabel, Some arg -> generate_simple_expression names arg 662 | | _ -> not_supported "labelled argument: %a" print_expr expr 663 | ) args 664 | in 665 | let name = prim.prim_name in 666 | generate_primitive name args 667 | | Texp_apply ({ exp_desc = Texp_ident (path, _, { val_kind = Val_reg; _ }); _ }, args) -> 668 | let args = List.map (function 669 | | (Asttypes.Nolabel, Some arg) -> generate_simple_expression names arg 670 | | _ -> not_supported "labelled argument: %a" print_expr expr 671 | ) args 672 | in 673 | let fname = Path.last path in 674 | Call (create_identifer fname, args) 675 | | Texp_apply _ -> 676 | not_supported "apply: %a" print_expr expr 677 | | Texp_ident (path, _lident, { val_kind = Val_reg; _ }) -> 678 | let id = Path.head path in 679 | let name, constness = Names.get names id in 680 | (match constness with 681 | | `Mut -> Addr_of (Variable name) 682 | | `Const -> Variable name) 683 | | Texp_ifthenelse (cond, then_, Some else_) -> 684 | Ternary ( 685 | generate_simple_expression names cond, 686 | generate_simple_expression names then_, 687 | generate_simple_expression names else_) 688 | | Texp_ifthenelse (_cond, _then, None) -> 689 | not_supported "if-then is currently not allowed in expression: %a" print_expr expr 690 | | Texp_open (_, expr) -> 691 | generate_simple_expression names expr 692 | | Texp_ident (_path, _ident, _) -> 693 | failwith "TODO: ident with kind <> Val_reg" 694 | | Texp_let _ -> 695 | not_supported "let in expression: %a" print_expr expr 696 | | Texp_sequence _ -> 697 | (* could be supported using ',', maybe? *) 698 | not_supported "semicolon in expression: %a" print_expr expr 699 | | Texp_constant Const_int i -> Constant i 700 | | Texp_constant Const_int32 i -> Constant (Int32.to_int i) 701 | | Texp_constant Const_int64 i -> Constant_i64 i 702 | | Texp_constant Const_char c -> Constant_char c 703 | | Texp_constant Const_float f -> Constant_float (Float.of_string f) (* C doesn't support the all of OCaml's float literals *) 704 | | Texp_construct (_, { cstr_res; cstr_tag = Cstr_constant i; _ }, []) when is_bool cstr_res -> 705 | Constant_bool (i <> 0) 706 | | Texp_construct (_, { cstr_res; cstr_tag = Cstr_constant 0; _ }, []) when is_unit cstr_res -> 707 | Variable (create_identifer "Val_unit") 708 | | Texp_construct (_, _, _) -> 709 | not_supported "constructor: %a" print_expr expr 710 | | _ -> 711 | not_supported "in expression: %a" print_expr expr 712 | 713 | let rec generate_body ~return names body = 714 | match body.exp_desc with 715 | | Texp_let (Nonrecursive, [ 716 | { vb_pat; 717 | vb_expr = { 718 | exp_desc = Texp_apply ({ exp_desc = Texp_ident (_path, _, { val_kind = Val_prim { prim_name = "lowcaml_mut_create"; _ }; _ }); _ }, [Nolabel, Some rhs]); 719 | _ }; 720 | _ }], expr) -> 721 | let ident, var = get_var_from_pat vb_pat in 722 | let ty = vb_pat.pat_type in 723 | let names', varname = Names.new_var names ~mut:true ?ident var in 724 | let ty = 725 | match (OCaml_type.map ~where:var body.exp_env ty) with 726 | | Mut t -> ocaml_type_to_ctype ~where:var t 727 | | _ -> failwithf "bad type assigned to Mut.t: %a" Printtyp.type_expr ty 728 | in 729 | Declaration ( 730 | ty, 731 | varname, 732 | generate_simple_expression names rhs 733 | ) 734 | :: 735 | generate_body ~return names' expr 736 | | Texp_let (Nonrecursive, [binding], expr) -> 737 | let ident, var = get_var_from_pat binding.vb_pat in 738 | let ty = binding.vb_pat.pat_type in 739 | let names', varname = Names.new_var names ?ident var in 740 | Declaration ( 741 | Const (ocaml_type_to_ctype ~where:var (OCaml_type.map ~where:var body.exp_env ty)), 742 | varname, 743 | generate_simple_expression names binding.vb_expr 744 | ) 745 | :: 746 | generate_body ~return names' expr 747 | | Texp_sequence (e1, e2) -> 748 | generate_body ~return:false names e1 @ generate_body ~return names e2 749 | | Texp_ifthenelse (cond, then_, None) -> 750 | [If_then ( 751 | generate_simple_expression names cond, 752 | generate_body ~return:false (Names.enter_scope names) then_)] 753 | | Texp_ifthenelse (cond, then_, Some else_) -> 754 | [If_then_else ( 755 | generate_simple_expression names cond, 756 | generate_body ~return (Names.enter_scope names) then_, 757 | generate_body ~return (Names.enter_scope names) else_)] 758 | | Texp_while (cond, body) -> 759 | [While ( 760 | generate_simple_expression names cond, 761 | generate_body ~return:false (Names.enter_scope names) body)] 762 | | Texp_for (ident, pat, expr_from, { exp_desc = Texp_constant Const_int upto; _ }, direction, body) -> 763 | let op_condition, op_next = match direction with Upto -> "<=", "+=" | Downto -> ">=", "-=" in 764 | let var = match pat.ppat_desc with Ppat_var v -> v.txt | Ppat_any -> "i" | _ -> not_supported "pattern in for-loop" in 765 | let names, var = Names.new_var names ~ident var in 766 | let decl = I64, var, generate_simple_expression names expr_from in 767 | let while_ = Op2 (op_condition, Variable var, Constant upto) in 768 | let after = Op2 (op_next, Variable var, Constant 1) in 769 | [For (decl, while_, after, generate_body ~return:false (Names.enter_scope names) body)] 770 | | Texp_for (ident, pat, expr_from, expr_to, direction, body) -> 771 | let op_condition, op_next = match direction with Upto -> "<=", "+=" | Downto -> ">=", "-=" in 772 | let var = match pat.ppat_desc with Ppat_var v -> v.txt | Ppat_any -> "i" | _ -> not_supported "pattern in for-loop" in 773 | let names, var = Names.new_var names ~ident var in 774 | let names, upto = Names.new_var names "upto" in 775 | let decl = I64, var, generate_simple_expression names expr_from in 776 | let while_ = Op2 (op_condition, Variable var, Variable upto) in 777 | let after = Op2 (op_next, Variable var, Constant 1) in 778 | [ 779 | Declaration (Const I64, upto, generate_simple_expression names expr_to); 780 | For (decl, while_, after, generate_body ~return:false (Names.enter_scope names) body); 781 | ] 782 | | Texp_construct (_, _, _) when is_unit body.exp_type -> 783 | [] 784 | | Texp_construct (_, _, _) -> 785 | [Return (generate_simple_expression names body)] 786 | | Texp_assert _ -> 787 | not_supported "TODO: assert" 788 | | Texp_apply _ | Texp_constant _ | Texp_ident _ when return -> 789 | [Return (generate_simple_expression names body)] 790 | | Texp_apply _ -> 791 | [Expression (generate_simple_expression names body)] 792 | | Texp_constant _ | Texp_ident _ -> 793 | print "Warning: meaningless value in function body: %a" print_expr body; 794 | [Expression (generate_simple_expression names body)] 795 | | Texp_match ({ exp_type; _ } as e1, [{ c_lhs = { pat_desc = Tpat_value p; _ }; c_guard = None; c_rhs = e2}], Total) when is_unit exp_type -> 796 | (* let () = ... in ... *) 797 | (match (p :> pattern) with 798 | | { pat_desc = Tpat_construct _; _ } -> 799 | generate_body ~return:false names e1 @ generate_body ~return names e2 800 | | _ -> 801 | not_supported "in function body: %a" print_expr body) 802 | | Texp_open (_, body) -> 803 | generate_body ~return names body 804 | | Texp_let (Recursive, _, _) -> 805 | not_supported "recursive let binding: %a" print_expr body 806 | | Texp_tuple _ -> 807 | not_supported "tuple: %a" print_expr body 808 | | _ -> 809 | not_supported "in function body: %a" print_expr body 810 | 811 | let go typed = 812 | let elements, ml_funcs = List.split @@ List.map (fun item -> 813 | match item.str_desc with 814 | | Tstr_value (Nonrecursive, [value]) -> 815 | let _ident, func_name = get_var_from_pat value.vb_pat in 816 | log "Got function: %s" func_name; 817 | let args, body = get_args value.vb_expr in 818 | List.iter (fun (id, name, ty) -> log "Arg: %a %s %a" Ident.print id name Printtyp.type_expr ty) args; 819 | let return_type = body.exp_type in 820 | log "return type: %a" Printtyp.type_expr return_type; 821 | if args = [] then not_supported "TODO: Constant"; 822 | let args = List.map (fun (id, name, ty) -> id, name, OCaml_type.map ~where:name item.str_env ty) args in 823 | let return_type = OCaml_type.map ~where:func_name item.str_env return_type in 824 | let c_fun = 825 | let return_type = match return_type with Unit -> None | t -> Some (ocaml_type_to_ctype ~where:func_name t) in 826 | assert (match return_type with Some Const _ -> false | _ -> true); 827 | let names, args = List.fold_left (fun (names, args) (ident, var, ty) -> 828 | let cty = Const (ocaml_type_to_ctype ~where:var ty) in 829 | let names, var = Names.new_var names ~ident var in 830 | (names, (var, cty) :: args) 831 | ) (Names.empty, []) args 832 | in 833 | let args = List.rev args in 834 | Function { 835 | name = create_identifer func_name; 836 | args; 837 | return_type; 838 | body = generate_body ~return:(return_type <> None) names body; 839 | } 840 | in 841 | let return_ty = ocaml_type_to_external_type ~where:func_name return_type in 842 | let arg_types = String.concat " -> " (List.map (fun (_id, name, ty) -> ocaml_type_to_external_type ~where:name ty) args) in 843 | let external_decl = 844 | sprintf {|external %s : %s -> %s = "bytecode_not_supported_by_lowcaml" "%s" [@@noalloc]|} func_name arg_types return_ty func_name 845 | in 846 | let conversion_stub = 847 | if List.exists (fun (_, _, ty) -> ty = OCaml_type.Char || ty = Bool) args || 848 | return_type = Char || return_type = Bool 849 | then 850 | let arg_names = String.concat " " (List.map (fun (_, name, _) -> name) args) in 851 | let arg_names_mapped = String.concat " " (List.map (fun (_, name, ty) -> 852 | match ty with 853 | | OCaml_type.Bool -> sprintf "(Bool.to_int %s)" name 854 | | OCaml_type.Char -> sprintf "(Char.code %s)" name 855 | | _ -> name 856 | ) args) in 857 | let call = 858 | match return_type with 859 | | Char -> sprintf "Char.chr (0xFF land %s %s)" func_name arg_names_mapped 860 | | Bool -> sprintf "0 <> %s %s" func_name arg_names_mapped 861 | | _ -> sprintf "%s %s" func_name arg_names_mapped 862 | in 863 | sprintf "\nlet %s %s = %s" func_name arg_names call 864 | else 865 | "" 866 | in 867 | c_fun, Some (external_decl ^ conversion_stub) 868 | | Tstr_primitive { val_id; val_name; val_desc; val_prim = func_name :: _; _ } -> 869 | log "external: %a %s %s" Ident.print val_id val_name.txt func_name; 870 | let rec get_args_from_ty ty = 871 | match Types.get_desc ty with 872 | | Tarrow (Nolabel, arg, ret, _commutable) -> 873 | let rest, ret = get_args_from_ty ret in 874 | arg :: rest, ret 875 | | Tarrow _ -> 876 | not_supported "labelled argument in external: %a" print_structure_item item 877 | | _ -> 878 | [], ty 879 | in 880 | let args, return_type = get_args_from_ty val_desc.ctyp_type in 881 | List.iter (fun arg -> log "external arg: %a" Printtyp.type_expr arg) args; 882 | log "external return_type: %a" Printtyp.type_expr return_type; 883 | let args = List.map (OCaml_type.map ~where:func_name item.str_env) args in 884 | let return_type = OCaml_type.map ~where:func_name item.str_env return_type in 885 | Prototype { 886 | name = create_identifer func_name; 887 | args = 888 | (match args with 889 | | [Unit] -> [] 890 | | _ -> List.map (ocaml_type_to_ctype ~where:func_name) args); 891 | return_type = (match return_type with Unit -> None | t -> Some (ocaml_type_to_ctype ~where:func_name t)); 892 | }, 893 | None 894 | | Tstr_primitive { val_name; _ } -> 895 | not_supported "primitive with more than two names: %s" val_name.txt 896 | | Tstr_attribute { attr_name = { txt = "include" | "lowcaml.include"; _ }; 897 | attr_payload = PStr [{ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (header, _, None)); _ }, _); _ }]; _ } -> 898 | (match String.get header 0, String.get header (String.length header - 1) with 899 | | '<', '>' -> Include header 900 | | '<', _ | _, '>' | exception Invalid_argument _ -> not_supported "Invalid header: %S" header; 901 | | _ -> Include (sprintf "%S" header)), 902 | None 903 | | _ -> 904 | not_supported "%a" print_structure_item item 905 | ) typed.str_items 906 | in 907 | let builtin_includes = [ 908 | ""; 909 | ""; 910 | ""; 911 | ""; 912 | ""; 913 | ""; 914 | ""; 915 | ] 916 | in 917 | let elements = List.map (fun f -> C_ast.Include f) builtin_includes @ elements in 918 | { elements }, String.concat "\n" ( 919 | "(* generated by lowcaml *)\n" 920 | :: 921 | List.filter_map Fun.id ml_funcs 922 | @ 923 | [""] 924 | ) 925 | end 926 | 927 | module Util = struct 928 | let rand_dir () = 929 | let rec go i = 930 | let temp_dir = Filename.concat (Filename.get_temp_dir_name ()) (sprintf "lowcaml_stdlib_%d" (Random.bits ())) in 931 | try 932 | Sys.mkdir temp_dir 0o755; 933 | temp_dir 934 | with 935 | Sys_error e -> 936 | if i = 0 then failwithf "rand_dir: failed to create temporary directory: %s" e; 937 | go (i - 1) 938 | in 939 | go 1000 940 | 941 | let write_file filename out = 942 | match filename with 943 | | "-" -> print_string out 944 | | _ -> Out_channel.with_open_bin filename (fun c -> output_string c out) 945 | end 946 | 947 | let type_program ~cmi ~source_file program = 948 | let output_prefix = try Filename.chop_extension source_file with Invalid_argument _ -> "input" in 949 | let module_name = Compenv.module_of_filename source_file output_prefix in 950 | Clflags.strict_sequence := true; 951 | (* ignore @@ Warnings.parse_options false "-32-34-37-38-60"; *) (* TODO *) 952 | Clflags.nopervasives := true; 953 | Clflags.open_modules := ["Lowcaml_stdlib"]; 954 | begin match cmi with 955 | | Some cmi -> Clflags.include_dirs := [Filename.dirname cmi]; 956 | | None -> 957 | let temp_dir = Util.rand_dir () in 958 | at_exit (fun () -> Sys.rmdir temp_dir); 959 | let cmi = Filename.concat temp_dir "lowcaml_stdlib.cmi" in 960 | Out_channel.with_open_bin cmi (fun c -> output_string c Lowcaml_stdlib_cmi.data); 961 | at_exit (fun () -> Sys.remove cmi); 962 | Clflags.include_dirs := [temp_dir]; 963 | end; 964 | Location.input_name := source_file; 965 | Compmisc.init_path (); 966 | Env.set_unit_name module_name; 967 | Compilenv.reset ?packname:None module_name; 968 | Typecore.reset_delayed_checks (); 969 | Env.reset_required_globals (); 970 | let initial_env = Compmisc.initial_env () in 971 | let parsed = Parse.implementation (Lexing.from_string program) in 972 | let typed, _signature, _names, _shape, _final_env = Typemod.type_structure initial_env parsed in 973 | typed 974 | 975 | let () = 976 | Printexc.record_backtrace true; 977 | Random.self_init (); 978 | let i = ref "-" in 979 | let c_file = ref "-" in 980 | let ml_file = ref None in 981 | let cmi = ref None in 982 | let skip_simplify = ref false in 983 | let opt_arg res = Arg.String (fun arg -> res := Some arg) in 984 | let args = [ 985 | "-i", Arg.Set_string i, "input .ml file (default stdin)"; 986 | "-o-c", Arg.Set_string c_file, "output .c file (default stdout)"; 987 | "-o-ml", opt_arg ml_file, "output .ml file"; 988 | "-cmi", opt_arg cmi, "lowcaml stdlib cmi (default uses built-in)"; 989 | "-skip-simplify", Arg.Set skip_simplify, "skip simplify pass (default false)"; 990 | "-v", Arg.Set logging, "verbose logging"; 991 | ] 992 | in 993 | let usage_message = "Usage: lowcaml.exe [-i file] [-o-ml file] [-o-c file]" in 994 | let usage _ = Arg.usage args usage_message; exit 1 in 995 | Arg.parse args usage usage_message; 996 | let input = if !i = "-" 997 | then In_channel.input_all stdin 998 | else In_channel.with_open_bin !i In_channel.input_all 999 | in 1000 | try 1001 | let typed = type_program ~cmi:!cmi ~source_file:!i input in 1002 | let c, ml = Lowcaml.go typed in 1003 | let c = if !skip_simplify then c else C_ast.Simplify.go c in 1004 | let out = C_ast.Print.print c in 1005 | Util.write_file !c_file out; 1006 | Option.iter (fun f -> Util.write_file f ml) !ml_file 1007 | with 1008 | | Typecore.Error _ | Env.Error _ | Syntaxerr.Error _ as e -> 1009 | print "%a" Location.report_exception e; 1010 | exit 1 1011 | | Not_supported msg -> 1012 | print "--- not supported ---@\n%s" msg; 1013 | exit 1 1014 | -------------------------------------------------------------------------------- /lowcaml_stdlib.mli: -------------------------------------------------------------------------------- 1 | (******** OCaml stdlib ********) 2 | 3 | module String : sig 4 | type t = string 5 | external length : t -> int = "lowcaml_bytes_length" 6 | 7 | (* Note: No bounds checks *) 8 | external get_uint8 : t -> int -> int = "lowcaml_bytes_get_uint8" 9 | external get_uint16_le : t -> int -> int = "lowcaml_bytes_get_uint16" 10 | external get_uint32_le : t -> int -> int = "lowcaml_bytes_get_uint32" 11 | external get_int32_le : t -> int -> int32 = "lowcaml_bytes_get_int32" 12 | end 13 | 14 | module Bytes : sig 15 | type t = bytes 16 | external length : t -> int = "lowcaml_bytes_length" 17 | 18 | (* Note: No bounds checks *) 19 | external get_uint8 : t -> int -> int = "lowcaml_bytes_get_uint8" 20 | external set_uint8 : t -> int -> int -> unit = "lowcaml_bytes_set_int8" 21 | external get_uint16_le : t -> int -> int = "lowcaml_bytes_get_uint16" 22 | external get_uint32_le : t -> int -> int = "lowcaml_bytes_get_uint32" 23 | external get_int32_le : t -> int -> int32 = "lowcaml_bytes_get_int32" 24 | 25 | external set_int16_le : t -> int -> int -> unit = "lowcaml_bytes_set_int16" 26 | end 27 | 28 | module Int : sig 29 | type t = int 30 | external ( + ) : t -> t -> t = "%addint" 31 | end 32 | 33 | module Int64 : sig 34 | type t = int64 35 | external of_int : int -> t = "%identity" 36 | external to_int : t -> int = "%identity" 37 | external of_int32 : int32 -> t = "lowcaml_int32_to_int" 38 | external to_int32 : t -> int32 = "lowcaml_int32_of_int" 39 | 40 | external ( + ) : t -> t -> t = "%addint" 41 | external ( asr ) : t -> int -> t = "%asrint" 42 | external ( lsr ) : t -> int -> t = "%lsrint" 43 | end 44 | 45 | module Int32 : sig 46 | type t = int32 47 | external of_int : int -> t = "lowcaml_int32_of_int" 48 | external to_int : t -> int = "lowcaml_int32_to_int" 49 | external of_char : char -> t = "lowcaml_int32_of_char" 50 | 51 | external ( + ) : t -> t -> t = "%addint" 52 | external ( * ) : t -> t -> t = "%mulint" 53 | external ( lsl ) : t -> int -> t = "%lslint" 54 | external ( asr ) : t -> int -> t = "%asrint" 55 | external ( lsr ) : t -> int -> t = "%int32_lsr" 56 | end 57 | 58 | module Char : sig 59 | type t = char 60 | external code : t -> int = "lowcaml_char_to_int" 61 | end 62 | 63 | module Float : sig 64 | type t = float 65 | end 66 | 67 | 68 | external (=) : int -> int -> bool = "%equal" 69 | external (<>) : int -> int -> bool = "%notequal" 70 | external (>) : int -> int -> bool = "%greaterthan" 71 | external (>=) : int -> int -> bool = "%lessequal" 72 | external (<) : int -> int -> bool = "%lessthan" 73 | external (<=) : int -> int -> bool = "%greaterequal" 74 | 75 | external ( ~- ) : int -> int = "%negint" 76 | external ( ~+ ) : int -> int = "%identity" 77 | (* external succ : int -> int = "%succint" *) 78 | (* external pred : int -> int = "%predint" *) 79 | external ( + ) : int -> int -> int = "%addint" 80 | external ( - ) : int -> int -> int = "%subint" 81 | external ( * ) : int -> int -> int = "%mulint" 82 | (* external ( / ) : int -> int -> int = "%divint" *) 83 | (* external ( mod ) : int -> int -> int = "%modint" *) 84 | 85 | external ( land ) : int -> int -> int = "%andint" 86 | external ( lor ) : int -> int -> int = "%orint" 87 | external ( lxor ) : int -> int -> int = "%xorint" 88 | (* val lnot : int -> int *) 89 | external ( lsl ) : int -> int -> int = "%lslint" 90 | external ( lsr ) : int -> int -> int = "%lsrint" 91 | external ( asr ) : int -> int -> int = "%asrint" 92 | 93 | external not : bool -> bool = "%boolnot" 94 | external ( && ) : bool -> bool -> bool = "%sequand" 95 | external ( || ) : bool -> bool -> bool = "%sequor" 96 | 97 | external ( ~-. ) : float -> float = "%negfloat" 98 | external ( ~+. ) : float -> float = "%identity" 99 | external ( +. ) : float -> float -> float = "%addfloat" 100 | external ( -. ) : float -> float -> float = "%subfloat" 101 | external ( *. ) : float -> float -> float = "%mulfloat" 102 | external ( /. ) : float -> float -> float = "%divfloat" 103 | 104 | 105 | (******** C types & libc bindings ********) 106 | 107 | module Mut : sig 108 | type 'a t 109 | (** the type of stack-allocated values *) 110 | 111 | external get : 'a t -> 'a = "lowcaml_deref" 112 | 113 | external int : int -> int t = "lowcaml_mut_create" 114 | (** Allocate a new int. Can only appear in let bindings *) 115 | end 116 | 117 | external (:=) : 'a Mut.t -> 'a -> unit = "lowcaml_mut_set" 118 | external (!) : 'a Mut.t -> 'a = "lowcaml_deref" 119 | 120 | (** The following pointer types are primarily for consumption of C libraries. 121 | Use with caution. *) 122 | 123 | module Const_void_ptr : sig 124 | type t 125 | (** The [const void*] type *) 126 | 127 | external is_null : t -> bool = "%boolnot" 128 | 129 | external string : string -> t = "lowcaml_string_to_constptr" 130 | external bytes : bytes -> t = "lowcaml_string_to_constptr" 131 | external bigarray : (_, _, Bigarray.c_layout) Bigarray.Array1.t -> t = "lowcaml_bigarray_to_ptr" 132 | 133 | external to_int : t -> int = "lowcaml_ptr_to_int" 134 | 135 | external offset : t -> int -> t = "lowcaml_ptr_offset" 136 | (** Note: The offset is in bytes *) 137 | 138 | external get_uint8 : t -> int = "lowcaml_ptr_get_uint8" 139 | 140 | external of_mut : 'a Mut.t -> t = "%identity" 141 | (** warning: Mut.t is allocated on a stack, and therefore has a limited lifetime *) 142 | end 143 | 144 | module Void_ptr : sig 145 | type t 146 | (** The [void*] type *) 147 | 148 | external is_null : t -> bool = "%boolnot" 149 | 150 | external bytes : bytes -> t = "lowcaml_bytes_to_ptr" 151 | external bigarray : (_, _, Bigarray.c_layout) Bigarray.Array1.t -> t = "lowcaml_bigarray_to_ptr" 152 | 153 | external to_int : t -> int = "lowcaml_ptr_to_int" 154 | external to_const : t -> Const_void_ptr.t = "lowcaml_ptr_to_const_ptr" 155 | 156 | external offset : t -> int -> t = "lowcaml_ptr_offset" 157 | (** Note: The offset is in bytes *) 158 | 159 | external of_mut : 'a Mut.t -> t = "%identity" 160 | (** warning: Mut.t is allocated on a stack, and therefore has a limited lifetime *) 161 | end 162 | 163 | module Ptr : sig 164 | type 'a t 165 | (* pointer to ['a] *) 166 | 167 | external is_null : 'a t -> bool = "%boolnot" 168 | 169 | external bytes : bytes -> 'a t = "lowcaml_bytes_to_ptr" 170 | external bigarray : (_, _, Bigarray.c_layout) Bigarray.Array1.t -> 'a t = "lowcaml_bigarray_to_ptr" 171 | 172 | external to_int : 'a t -> int = "lowcaml_ptr_to_int" 173 | 174 | external offset : 'a t -> int -> 'a t = "lowcaml_ptr_offset" 175 | (** Note: The offset is in bytes *) 176 | 177 | external of_void_ptr : Void_ptr.t -> 'a t = "%identity" 178 | external of_mut : 'a Mut.t -> 'a t = "%identity" 179 | (** warning: Mut.t is allocated on a stack, and therefore has a limited lifetime *) 180 | end 181 | 182 | module Const_ptr : sig 183 | type 'a t 184 | (* pointer to [const 'a] *) 185 | 186 | external is_null : 'a t -> bool = "%boolnot" 187 | 188 | external string : string -> 'a t = "lowcaml_string_to_constptr" 189 | external bytes : bytes -> 'a t = "lowcaml_string_to_constptr" 190 | external bigarray : (_, _, Bigarray.c_layout) Bigarray.Array1.t -> 'a t = "lowcaml_bigarray_to_ptr" 191 | 192 | external to_int : 'a t -> int = "lowcaml_ptr_to_int" 193 | 194 | external offset : 'a t -> int -> 'a t = "lowcaml_ptr_offset" 195 | (** Note: The offset is in bytes *) 196 | 197 | external of_void_ptr : Void_ptr.t -> 'a t = "%identity" 198 | external of_const_void_ptr : Const_void_ptr.t -> 'a t = "%identity" 199 | external to_const_void_ptr : 'a t -> Const_void_ptr.t = "%identity" 200 | external of_mut : 'a Mut.t -> 'a t = "%identity" 201 | (** warning: Mut.t is allocated on a stack, and therefore has a limited lifetime *) 202 | end 203 | 204 | module Int8_t : sig 205 | type t 206 | (** The [int8_t] type *) 207 | 208 | external of_int : int -> t = "lowcaml_int_to_int8_t" 209 | end 210 | module Uint8_t : sig 211 | type t 212 | (** The [uint8_t] type *) 213 | 214 | external of_int : int -> t = "lowcaml_int_to_uint8_t" 215 | end 216 | module Uint64_t : sig 217 | type t 218 | (** The [uint64_t] type *) 219 | 220 | external of_int : int -> t = "lowcaml_int_to_uint64_t" 221 | external of_int64 : int64 -> t = "lowcaml_int_to_uint64_t" 222 | end 223 | 224 | external assert_ : bool -> unit = "assert" 225 | 226 | 227 | (******** x86 AVX SIMD instructions ********) 228 | 229 | module SIMD : sig 230 | type __m128i 231 | external _mm_set_epi8 : char -> char -> char -> char -> char -> char -> char -> char -> 232 | char -> char -> char -> char -> char -> char -> char -> char -> __m128i = "_mm_set_epi8" 233 | external _mm_set_epi32 : int32 -> int32 -> int32 -> int32 -> __m128i = "_mm_set_epi32" 234 | external _mm_set1_epi32 : int32 -> __m128i = "_mm_set1_epi32" 235 | external _mm_and_si128 : __m128i -> __m128i -> __m128i = "_mm_and_si128" 236 | external _mm_cmpeq_epi32 : __m128i -> __m128i -> __m128i = "_mm_cmpeq_epi32" 237 | external _mm_blendv_epi8 : __m128i -> __m128i -> __m128i -> __m128i = "_mm_blendv_epi8" 238 | external _mm_add_epi64 : __m128i -> __m128i -> __m128i = "_mm_add_epi64" 239 | external _mm_storeu_si64 : Void_ptr.t -> __m128i -> unit = "_mm_storeu_si64" 240 | external _mm_storeu_si128 : __m128i Ptr.t -> __m128i -> unit = "_mm_storeu_si128" 241 | external _mm_loadu_si128 : __m128i Const_ptr.t -> __m128i = "_mm_loadu_si128" 242 | external _mm_extract_epi64 : __m128i -> int32 -> int = "_mm_extract_epi64" 243 | external _mm_extract_epi32 : __m128i -> int32 -> int32 = "_mm_extract_epi32" 244 | 245 | type __m256i 246 | external _mm256_set1_epi8 : char -> __m256i = "_mm256_set1_epi8" 247 | external _mm256_set1_epi32 : int32 -> __m256i = "_mm256_set1_epi32" 248 | external _mm256_set_epi32 : int32 -> int32 -> int32 -> int32 -> int32 -> int32 -> int32 -> int32 -> __m256i = "_mm256_set_epi32" 249 | external _mm256_cmpeq_epi8 : __m256i -> __m256i -> __m256i = "_mm256_cmpeq_epi8" 250 | external _mm256_cmpeq_epi32 : __m256i -> __m256i -> __m256i = "_mm256_cmpeq_epi32" 251 | external _mm256_and_si256 : __m256i -> __m256i -> __m256i = "_mm256_and_si256" 252 | external _mm256_blendv_epi8 : __m256i -> __m256i -> __m256i -> __m256i = "_mm256_blendv_epi8" 253 | external _mm256_storeu_si256 : __m256i Ptr.t -> __m256i -> unit = "_mm256_storeu_si256" 254 | external _mm256_store_si256 : __m256i Ptr.t -> __m256i -> unit = "_mm256_store_si256" 255 | external _mm256_stream_si256 : __m256i Ptr.t -> __m256i -> unit = "_mm256_stream_si256" 256 | 257 | external _mm256_movemask_epi8 : __m256i -> int = "_mm256_movemask_epi8" 258 | 259 | external _mm256_extract_epi64 : __m256i -> int32 -> int = "_mm256_extract_epi64" 260 | external _mm256_extracti128_si256 : __m256i -> int32 -> __m128i = "_mm256_extracti128_si256" 261 | external _mm256_castsi256_si128 : __m256i -> __m128i = "_mm256_castsi256_si128" 262 | 263 | external _mm256_loadu_si256 : __m256i Const_ptr.t -> __m256i = "_mm256_loadu_si256" 264 | 265 | type __m512i 266 | type __mmask16 267 | 268 | (* external _mm256_storeu_epi8 : Ptr.t -> __m256i -> unit = "_mm256_storeu_epi8" *) (* AVX512 *) 269 | end 270 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | Lowcaml is an experimental OCaml-to-C compiler. It generates C files as well as 2 | the corresponding OCaml bindings. Its primary goal is writing typesafe SIMD 3 | code, but it can also be used to accelerate simple OCaml code and create 4 | bindings to C libraries. 5 | 6 | The following features are supported: 7 | - built-in OCaml types (`int`, `int32`, `int64`, `unit`, `bool`, `char`, `string`, `bytes` and `Bigarray.Array1.t`) 8 | - a subset of the OCaml standard library, mostly functions on the above types that don't allocate 9 | - top-level functions 10 | - for and while loops 11 | - if-else expressions 12 | - let bindings (currently only directly below functions) 13 | - externals, which call external C functions directly 14 | - calling other lowcaml functions 15 | - some libc types 16 | - stack-allocated `int` (like OCaml's `ref`), currently called `int Mut.t` 17 | - generating `#include` using `[@@@include "header"]` 18 | 19 | The following features are *not* supported, but *may* be supported in the future: 20 | - C array, struct, enum, union, typedef or bindings to types from external libraries 21 | - `static` (non-exported) C functions 22 | - stack-allocated values 23 | - OCaml variants, records, tuples 24 | - `ref` and `array` values 25 | - bytecode stubs 26 | - bounds checks 27 | - sub-modules 28 | - named and optional parameters 29 | - match expressions 30 | - top-level constants 31 | - string literals 32 | - a pure OCaml implementation of `Lowcaml_stdlib` (for jsoo support) 33 | 34 | The following features are *not* supported, and are out of scope for the project: 35 | - allocating from lowcaml or calling into the OCaml runtime: All functions generated by lowcaml are marked `[@@noalloc]` 36 | - closures, partial application, exceptions or effects 37 | - cross-platform SIMD bindings (but could be implemented as a third-party library) 38 | - complete libc bindings 39 | - 32-bit platforms 40 | - any particular support for shared memory parallelism 41 | 42 | A subset of the OCaml stdlib, as well as some libc and SIMD methods are 43 | exposed. You can browse the interface (wip): 44 | [`lowcaml_stdlib.mli`](lowcaml_stdlib.mli). 45 | 46 | Currently, only OCaml 5.0 is supported. 47 | 48 | 49 | Usage 50 | ----- 51 | 52 | Dune users can use this library by vendoring it in their project. opam users 53 | can run `dune install` which will install `lowcaml.exe` in their current opam 54 | switch. 55 | 56 | You will need a custom rule that invokes `lowcaml.exe` and a library with C 57 | stubs. In the following, `my_stubs_lowcaml.ml` is the input while `lstubs.ml` and 58 | `cstubs.c` are generated files. Dune users can use something similar to this: 59 | 60 | ``` 61 | (rule 62 | (targets lstubs.ml cstubs.c) 63 | (deps my_stubs_lowcaml.ml) 64 | (action (run lowcaml.exe -source my_stubs_lowcaml.ml -o-ml lstubs.ml -o-c cstubs.c))) 65 | 66 | (library 67 | (name lstubs) 68 | (modules lstubs) 69 | (foreign_stubs 70 | (language c) 71 | (names cstubs) 72 | (flags 73 | :standard 74 | -Wall -Wpedantic -Wconversion -Werror 75 | -mavx2 ; Note: for SIMD instructions, requires x86_64 with AVX2 76 | ))) 77 | ``` 78 | 79 | Merlin is supported by defining a dummy library. Dune users can use the 80 | following library stanza and run `dune build lowcaml_test_dummy.cma`. 81 | 82 | ``` 83 | (library 84 | (name lowcaml_merlin_dummy) 85 | (modules my_stubs_lowcaml) 86 | (libraries lowcaml.stdlib) 87 | (flags :standard -nopervasives -open Lowcaml_stdlib)) 88 | ``` 89 | 90 | 91 | Examples 92 | -------- 93 | 94 | An implementation of [Sieve of Eratosthenes](https://en.wikipedia.org/wiki/Sieve_of_Eratosthenes): 95 | 96 | ```ocaml 97 | let sieve b = 98 | let len = Bytes.length b in 99 | for i = 2 to len - 1 do 100 | if Bytes.get_uint8 b i = 0 then ( 101 | let j = Mut.int (2 * i) in 102 | while !j < len do 103 | Bytes.set_uint8 b !j 1; 104 | j := !j + i; 105 | done 106 | ) 107 | done 108 | ``` 109 | 110 | ```c 111 | // generated by lowcaml 112 | void sieve(const value b) 113 | { 114 | const int64_t len = (int64_t)caml_string_length(b); 115 | const int64_t upto = (len-1); 116 | for(int64_t i = 2; (i<=upto); (i+=1)) 117 | { 118 | if((*(uint8_t*)&Byte(b, i)==0)) 119 | { 120 | int64_t j = (2*i); 121 | while((j x then Bytes.set_int16_le b 0 42 7 | let test_if_else1 x b = if 0 <> x then Bytes.set_int16_le b 0 42 else Bytes.set_int16_le b 0 43 8 | let test_if_else2 x b = 9 | if x = 0 then 10 | Bytes.set_int16_le b 0 43 11 | else if x = 1 then 12 | Bytes.set_int16_le b 0 44 13 | let test_if_else3 x b = 14 | if x = 0 then 15 | Bytes.set_int16_le b 0 43 16 | else if x = 1 then 17 | Bytes.set_int16_le b 0 44 18 | else 19 | Bytes.set_int16_le b 0 45 20 | let test_if_else4 x y = 21 | 3 + if x = 0 then y else x 22 | 23 | let test_open () = 24 | let open Int64 in 25 | (3L + of_int Int.(3 + 4)) 26 | 27 | let test_callee x y = 28 | x + y * 3 29 | let test_call x y z = 30 | test_callee x (test_callee y z) 31 | 32 | let test_for_helper b = 33 | Bytes.set_int16_le b 0 (1 + Bytes.get_uint16_le b 0); 34 | 10 35 | let test_for1 b = 36 | for i = 0 to 10 do 37 | Bytes.set_int16_le b (2 * i) i 38 | done 39 | let test_for2 b = 40 | for _ = 0 to test_for_helper b do 41 | () 42 | done 43 | let test_for3 b = 44 | for i = 1 downto 0 do 45 | Bytes.set_int16_le b i 42; 46 | done 47 | let test_for4 b = 48 | for _ = 14 downto test_for_helper b do 49 | () 50 | done 51 | 52 | let test_bool1 x = let b = x = 1 in if b then 42 else 54 53 | let test_bool_param x = if x then 42 else 54 54 | let test_bool_ret x = x > 42 55 | 56 | let test_bool_id (x : bool) = x 57 | let test_char_id (x : char) = x 58 | let test_int_id (x : int) = x 59 | let test_int32_id (x : int32) = x 60 | let test_int64_id (x : int64) = x 61 | let test_float_id (x : float) = x 62 | 63 | let test_float1 x y = 64 | x +. y *. 3.0 -. 123. /. 7.0 65 | 66 | let test_literal_int_1 () = 4611686018427387903 67 | let test_literal_int_2 () = -4611686018427387904 68 | let test_literal_int_3 () = 4611686018427387903 + -4611686018427387904 69 | 70 | let test_literal_i64_1 () = 9223372036854775807L 71 | let test_literal_i64_2 () = -9223372036854775808L 72 | let test_literal_i64_3 () = -9223372036854775807L 73 | let test_literal_i64_4 () = Int64.(9223372036854775807L + -9223372036854775808L) 74 | 75 | let test_literal_i32_1 () = 2147483647l 76 | let test_literal_i32_2 () = -2147483648l 77 | let test_literal_i32_3 () = Int32.(2147483647l + -2147483648l) 78 | 79 | let test_literal_float1 () = 1_2_3_._1_2_3_ 80 | let test_literal_float2 () = 1. 81 | let test_literal_float3 () = 1_._ 82 | let test_literal_float4 () = -1_1_._4_3_e9_9 83 | let test_literal_float5 () = -12.43e+99 84 | let test_literal_float6 () = 12.43e-99 85 | let test_literal_float7 () = 0x1. 86 | let test_literal_float8 () = 0xa.b 87 | let test_literal_float9 () = 0x1_2_._2_p4_2_ 88 | 89 | let test_literal_bool1 () = false 90 | let test_literal_bool2 () = true 91 | 92 | let test_literal_char1 () = 'b' 93 | let test_literal_char2 () = '\\' 94 | let test_literal_char3 () = '\x00' 95 | let test_literal_char4 () = '\xff' 96 | 97 | let test_shadow1 x = 98 | let x = x + 1 in 99 | x 100 | let test_shadow2 x = 101 | let y = x + 1 in 102 | let y = y + 1 in 103 | let y_1 = x + 1 in 104 | y + y_1 105 | let test_shadow3 () = 106 | let i = 42 in 107 | for i = i to i do 108 | let i = i + 1 in 109 | let _ = i in 110 | () 111 | done 112 | let test_shadow4 () = 113 | let i = 42 in 114 | while i < 10 do 115 | let i = i + 1 in 116 | let _ = i in 117 | () 118 | done 119 | let test_shadow5 () = 120 | let i = 42 in 121 | let _ = i in 122 | for _ = 42 to 54 do 123 | let i = 54 in 124 | let _ = i in 125 | () 126 | done 127 | 128 | let test_unit1 () () = () 129 | let test_unit2 () = test_unit1 () () 130 | let test_unit3 () = let () = () in () 131 | (* let test_unit4 () = let foo = () in foo *) (* fails for now *) 132 | 133 | (* a prime sieve *) 134 | let test_sieve b = 135 | let len = Bytes.length b in 136 | for i = 2 to len - 1 do 137 | if Bytes.get_uint8 b i = 0 then ( 138 | let j = Mut.int (2 * i) in 139 | while !j < len do 140 | Bytes.set_uint8 b !j 1; 141 | j := !j + i; 142 | done 143 | ) 144 | done 145 | 146 | external libc_memcpy : Void_ptr.t -> Const_void_ptr.t -> Uint64_t.t -> Void_ptr.t = "memcpy" 147 | external libc_memset : Void_ptr.t -> int32 -> Uint64_t.t -> Void_ptr.t = "memset" 148 | external libc_memchr : Const_void_ptr.t -> int32 -> Uint64_t.t -> Void_ptr.t = "memchr" 149 | external libc_memrchr : Const_void_ptr.t -> int32 -> Uint64_t.t -> Void_ptr.t = "memrchr" 150 | external libc_memcmp : Const_void_ptr.t -> Const_void_ptr.t -> Uint64_t.t -> int32 = "memcmp" 151 | 152 | let test_external b = 153 | let p = Void_ptr.bytes b in 154 | let _ = libc_memcpy p (Void_ptr.to_const (Void_ptr.offset p 1)) (Uint64_t.of_int 1) in 155 | () 156 | 157 | external libc_getpid : unit -> int32 = "getpid" 158 | let test_external_void () = 159 | libc_getpid () 160 | 161 | let test_simd_fill b x = 162 | let i = Mut.int 0 in 163 | let len = Bytes.length b in 164 | let x = SIMD._mm256_set1_epi32 x in 165 | while !i < len do 166 | SIMD._mm256_storeu_si256 (Ptr.offset (Ptr.bytes b) !i) x; 167 | i := !i + 32; 168 | done 169 | let test_simd2 b y = 170 | SIMD._mm256_storeu_si256 (Ptr.bytes b) (SIMD._mm256_set_epi32 y y y y y y y y) 171 | 172 | let test_something (i : int) (i32 : int32) (i64 : int64) = 173 | let _ = SIMD._mm256_extract_epi64 (SIMD._mm256_set1_epi32 42l) i32 in 174 | let _ = SIMD._mm_set1_epi32 i32 in 175 | () 176 | 177 | let test_mut1 x = 178 | let x = Mut.int x in 179 | let y = x in 180 | for _ = 0 to 10 do 181 | x := !y + 1; 182 | y := !x + 1; 183 | done; 184 | !x 185 | 186 | let test_something2 x b = 187 | let x = Mut.int x in 188 | let y = x in 189 | let z = Ptr.of_mut y in 190 | let w = Ptr.offset z 42 in 191 | let p = Ptr.bytes b in 192 | let cp = Const_ptr.bytes b in 193 | let vp = Void_ptr.bytes b in 194 | let cvp = Const_void_ptr.bytes b in 195 | let p2 = Ptr.of_void_ptr vp in 196 | let p3 = Ptr.of_mut x in 197 | let cp2 = Const_ptr.of_void_ptr vp in 198 | let cp3 = Const_ptr.of_const_void_ptr cvp in 199 | let i1 = Ptr.to_int p in 200 | () 201 | 202 | (* let test_mut2 () = let x = Mut.int 0 in x *) (* Must not be able to return a Mut.t *) 203 | 204 | [@@@include ""] 205 | --------------------------------------------------------------------------------