├── LICENSE ├── Makefile ├── README.md ├── _oasis ├── _tags ├── configure ├── myocamlbuild.ml ├── setup.ml └── src ├── erl.ml ├── erl_inet.ml ├── erl_inet_stubs.c ├── erl_msg.ml ├── erl_tcp.ml ├── queue_stubs.c └── test.ml /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | configure: 37 | $(SETUP) -configure $(CONFIGUREFLAGS) 38 | 39 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 40 | 41 | # OASIS_STOP 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ocaml-erlang 2 | Implementation of some Erlang primitives in OCaml. This is a toy experiment, pass by. 3 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: ocaml-erlang 3 | Version: 0.1.0 4 | Synopsis: Implementation of some Erlang primitives in OCaml 5 | Authors: xramtsov@gmail.com 6 | License: Apache-2.0 7 | Plugins: DevFiles (0.4) 8 | 9 | Executable test 10 | Path: src 11 | BuildTools: ocamlbuild 12 | MainIs: test.ml 13 | CompiledObject: native 14 | BuildDepends: delimcc, unix 15 | CSources: queue_stubs.c, erl_inet_stubs.c 16 | CCLib: -lpthread -lev 17 | Nativeopt: -ccopt -ggdb 18 | # Nativeopt: -p -ccopt -pg 19 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: e3202e6ab0df2dcb17c062dc7f4d5212) 3 | # Ignore VCS directories, you can use the same kind of rule outside 4 | # OASIS_START/STOP if you want to exclude directories that contains 5 | # useless stuff for the build process 6 | true: annot, bin_annot 7 | <**/.svn>: -traverse 8 | <**/.svn>: not_hygienic 9 | ".bzr": -traverse 10 | ".bzr": not_hygienic 11 | ".hg": -traverse 12 | ".hg": not_hygienic 13 | ".git": -traverse 14 | ".git": not_hygienic 15 | "_darcs": -traverse 16 | "_darcs": not_hygienic 17 | # Executable test 18 | # OASIS_STOP 19 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 9bd78b75e5e0b109a1abb54bf043b292) *) 3 | module OASISGettext = struct 4 | (* # 22 "src/oasis/OASISGettext.ml" *) 5 | 6 | 7 | let ns_ str = str 8 | let s_ str = str 9 | let f_ (str: ('a, 'b, 'c, 'd) format4) = str 10 | 11 | 12 | let fn_ fmt1 fmt2 n = 13 | if n = 1 then 14 | fmt1^^"" 15 | else 16 | fmt2^^"" 17 | 18 | 19 | let init = [] 20 | end 21 | 22 | module OASISString = struct 23 | (* # 22 "src/oasis/OASISString.ml" *) 24 | 25 | 26 | (** Various string utilities. 27 | 28 | Mostly inspired by extlib and batteries ExtString and BatString libraries. 29 | 30 | @author Sylvain Le Gall 31 | *) 32 | 33 | 34 | let nsplitf str f = 35 | if str = "" then 36 | [] 37 | else 38 | let buf = Buffer.create 13 in 39 | let lst = ref [] in 40 | let push () = 41 | lst := Buffer.contents buf :: !lst; 42 | Buffer.clear buf 43 | in 44 | let str_len = String.length str in 45 | for i = 0 to str_len - 1 do 46 | if f str.[i] then 47 | push () 48 | else 49 | Buffer.add_char buf str.[i] 50 | done; 51 | push (); 52 | List.rev !lst 53 | 54 | 55 | (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the 56 | separator. 57 | *) 58 | let nsplit str c = 59 | nsplitf str ((=) c) 60 | 61 | 62 | let find ~what ?(offset=0) str = 63 | let what_idx = ref 0 in 64 | let str_idx = ref offset in 65 | while !str_idx < String.length str && 66 | !what_idx < String.length what do 67 | if str.[!str_idx] = what.[!what_idx] then 68 | incr what_idx 69 | else 70 | what_idx := 0; 71 | incr str_idx 72 | done; 73 | if !what_idx <> String.length what then 74 | raise Not_found 75 | else 76 | !str_idx - !what_idx 77 | 78 | 79 | let sub_start str len = 80 | let str_len = String.length str in 81 | if len >= str_len then 82 | "" 83 | else 84 | String.sub str len (str_len - len) 85 | 86 | 87 | let sub_end ?(offset=0) str len = 88 | let str_len = String.length str in 89 | if len >= str_len then 90 | "" 91 | else 92 | String.sub str 0 (str_len - len) 93 | 94 | 95 | let starts_with ~what ?(offset=0) str = 96 | let what_idx = ref 0 in 97 | let str_idx = ref offset in 98 | let ok = ref true in 99 | while !ok && 100 | !str_idx < String.length str && 101 | !what_idx < String.length what do 102 | if str.[!str_idx] = what.[!what_idx] then 103 | incr what_idx 104 | else 105 | ok := false; 106 | incr str_idx 107 | done; 108 | !what_idx = String.length what 109 | 110 | 111 | let strip_starts_with ~what str = 112 | if starts_with ~what str then 113 | sub_start str (String.length what) 114 | else 115 | raise Not_found 116 | 117 | 118 | let ends_with ~what ?(offset=0) str = 119 | let what_idx = ref ((String.length what) - 1) in 120 | let str_idx = ref ((String.length str) - 1) in 121 | let ok = ref true in 122 | while !ok && 123 | offset <= !str_idx && 124 | 0 <= !what_idx do 125 | if str.[!str_idx] = what.[!what_idx] then 126 | decr what_idx 127 | else 128 | ok := false; 129 | decr str_idx 130 | done; 131 | !what_idx = -1 132 | 133 | 134 | let strip_ends_with ~what str = 135 | if ends_with ~what str then 136 | sub_end str (String.length what) 137 | else 138 | raise Not_found 139 | 140 | 141 | let replace_chars f s = 142 | let buf = Buffer.create (String.length s) in 143 | String.iter (fun c -> Buffer.add_char buf (f c)) s; 144 | Buffer.contents buf 145 | 146 | let lowercase_ascii = 147 | replace_chars 148 | (fun c -> 149 | if (c >= 'A' && c <= 'Z') then 150 | Char.chr (Char.code c + 32) 151 | else 152 | c) 153 | 154 | let uncapitalize_ascii s = 155 | if s <> "" then 156 | (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) 157 | else 158 | s 159 | 160 | let uppercase_ascii = 161 | replace_chars 162 | (fun c -> 163 | if (c >= 'a' && c <= 'z') then 164 | Char.chr (Char.code c - 32) 165 | else 166 | c) 167 | 168 | let capitalize_ascii s = 169 | if s <> "" then 170 | (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) 171 | else 172 | s 173 | 174 | end 175 | 176 | module OASISUtils = struct 177 | (* # 22 "src/oasis/OASISUtils.ml" *) 178 | 179 | 180 | open OASISGettext 181 | 182 | 183 | module MapExt = 184 | struct 185 | module type S = 186 | sig 187 | include Map.S 188 | val add_list: 'a t -> (key * 'a) list -> 'a t 189 | val of_list: (key * 'a) list -> 'a t 190 | val to_list: 'a t -> (key * 'a) list 191 | end 192 | 193 | module Make (Ord: Map.OrderedType) = 194 | struct 195 | include Map.Make(Ord) 196 | 197 | let rec add_list t = 198 | function 199 | | (k, v) :: tl -> add_list (add k v t) tl 200 | | [] -> t 201 | 202 | let of_list lst = add_list empty lst 203 | 204 | let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] 205 | end 206 | end 207 | 208 | 209 | module MapString = MapExt.Make(String) 210 | 211 | 212 | module SetExt = 213 | struct 214 | module type S = 215 | sig 216 | include Set.S 217 | val add_list: t -> elt list -> t 218 | val of_list: elt list -> t 219 | val to_list: t -> elt list 220 | end 221 | 222 | module Make (Ord: Set.OrderedType) = 223 | struct 224 | include Set.Make(Ord) 225 | 226 | let rec add_list t = 227 | function 228 | | e :: tl -> add_list (add e t) tl 229 | | [] -> t 230 | 231 | let of_list lst = add_list empty lst 232 | 233 | let to_list = elements 234 | end 235 | end 236 | 237 | 238 | module SetString = SetExt.Make(String) 239 | 240 | 241 | let compare_csl s1 s2 = 242 | String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) 243 | 244 | 245 | module HashStringCsl = 246 | Hashtbl.Make 247 | (struct 248 | type t = string 249 | let equal s1 s2 = (compare_csl s1 s2) = 0 250 | let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) 251 | end) 252 | 253 | module SetStringCsl = 254 | SetExt.Make 255 | (struct 256 | type t = string 257 | let compare = compare_csl 258 | end) 259 | 260 | 261 | let varname_of_string ?(hyphen='_') s = 262 | if String.length s = 0 then 263 | begin 264 | invalid_arg "varname_of_string" 265 | end 266 | else 267 | begin 268 | let buf = 269 | OASISString.replace_chars 270 | (fun c -> 271 | if ('a' <= c && c <= 'z') 272 | || 273 | ('A' <= c && c <= 'Z') 274 | || 275 | ('0' <= c && c <= '9') then 276 | c 277 | else 278 | hyphen) 279 | s; 280 | in 281 | let buf = 282 | (* Start with a _ if digit *) 283 | if '0' <= s.[0] && s.[0] <= '9' then 284 | "_"^buf 285 | else 286 | buf 287 | in 288 | OASISString.lowercase_ascii buf 289 | end 290 | 291 | 292 | let varname_concat ?(hyphen='_') p s = 293 | let what = String.make 1 hyphen in 294 | let p = 295 | try 296 | OASISString.strip_ends_with ~what p 297 | with Not_found -> 298 | p 299 | in 300 | let s = 301 | try 302 | OASISString.strip_starts_with ~what s 303 | with Not_found -> 304 | s 305 | in 306 | p^what^s 307 | 308 | 309 | let is_varname str = 310 | str = varname_of_string str 311 | 312 | 313 | let failwithf fmt = Printf.ksprintf failwith fmt 314 | 315 | 316 | let rec file_location ?pos1 ?pos2 ?lexbuf () = 317 | match pos1, pos2, lexbuf with 318 | | Some p, None, _ | None, Some p, _ -> 319 | file_location ~pos1:p ~pos2:p ?lexbuf () 320 | | Some p1, Some p2, _ -> 321 | let open Lexing in 322 | let fn, lineno = p1.pos_fname, p1.pos_lnum in 323 | let c1 = p1.pos_cnum - p1.pos_bol in 324 | let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in 325 | Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 326 | | _, _, Some lexbuf -> 327 | file_location 328 | ~pos1:(Lexing.lexeme_start_p lexbuf) 329 | ~pos2:(Lexing.lexeme_end_p lexbuf) 330 | () 331 | | None, None, None -> 332 | s_ "" 333 | 334 | 335 | let failwithpf ?pos1 ?pos2 ?lexbuf fmt = 336 | let loc = file_location ?pos1 ?pos2 ?lexbuf () in 337 | Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt 338 | 339 | 340 | end 341 | 342 | module OASISExpr = struct 343 | (* # 22 "src/oasis/OASISExpr.ml" *) 344 | 345 | 346 | open OASISGettext 347 | open OASISUtils 348 | 349 | 350 | type test = string 351 | type flag = string 352 | 353 | 354 | type t = 355 | | EBool of bool 356 | | ENot of t 357 | | EAnd of t * t 358 | | EOr of t * t 359 | | EFlag of flag 360 | | ETest of test * string 361 | 362 | 363 | type 'a choices = (t * 'a) list 364 | 365 | 366 | let eval var_get t = 367 | let rec eval' = 368 | function 369 | | EBool b -> 370 | b 371 | 372 | | ENot e -> 373 | not (eval' e) 374 | 375 | | EAnd (e1, e2) -> 376 | (eval' e1) && (eval' e2) 377 | 378 | | EOr (e1, e2) -> 379 | (eval' e1) || (eval' e2) 380 | 381 | | EFlag nm -> 382 | let v = 383 | var_get nm 384 | in 385 | assert(v = "true" || v = "false"); 386 | (v = "true") 387 | 388 | | ETest (nm, vl) -> 389 | let v = 390 | var_get nm 391 | in 392 | (v = vl) 393 | in 394 | eval' t 395 | 396 | 397 | let choose ?printer ?name var_get lst = 398 | let rec choose_aux = 399 | function 400 | | (cond, vl) :: tl -> 401 | if eval var_get cond then 402 | vl 403 | else 404 | choose_aux tl 405 | | [] -> 406 | let str_lst = 407 | if lst = [] then 408 | s_ "" 409 | else 410 | String.concat 411 | (s_ ", ") 412 | (List.map 413 | (fun (cond, vl) -> 414 | match printer with 415 | | Some p -> p vl 416 | | None -> s_ "") 417 | lst) 418 | in 419 | match name with 420 | | Some nm -> 421 | failwith 422 | (Printf.sprintf 423 | (f_ "No result for the choice list '%s': %s") 424 | nm str_lst) 425 | | None -> 426 | failwith 427 | (Printf.sprintf 428 | (f_ "No result for a choice list: %s") 429 | str_lst) 430 | in 431 | choose_aux (List.rev lst) 432 | 433 | 434 | end 435 | 436 | 437 | # 437 "myocamlbuild.ml" 438 | module BaseEnvLight = struct 439 | (* # 22 "src/base/BaseEnvLight.ml" *) 440 | 441 | 442 | module MapString = Map.Make(String) 443 | 444 | 445 | type t = string MapString.t 446 | 447 | 448 | let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" 449 | 450 | 451 | let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = 452 | let line = ref 1 in 453 | let lexer st = 454 | let st_line = 455 | Stream.from 456 | (fun _ -> 457 | try 458 | match Stream.next st with 459 | | '\n' -> incr line; Some '\n' 460 | | c -> Some c 461 | with Stream.Failure -> None) 462 | in 463 | Genlex.make_lexer ["="] st_line 464 | in 465 | let rec read_file lxr mp = 466 | match Stream.npeek 3 lxr with 467 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 468 | Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; 469 | read_file lxr (MapString.add nm value mp) 470 | | [] -> mp 471 | | _ -> 472 | failwith 473 | (Printf.sprintf "Malformed data file '%s' line %d" filename !line) 474 | in 475 | match stream with 476 | | Some st -> read_file (lexer st) MapString.empty 477 | | None -> 478 | if Sys.file_exists filename then begin 479 | let chn = open_in_bin filename in 480 | let st = Stream.of_channel chn in 481 | try 482 | let mp = read_file (lexer st) MapString.empty in 483 | close_in chn; mp 484 | with e -> 485 | close_in chn; raise e 486 | end else if allow_empty then begin 487 | MapString.empty 488 | end else begin 489 | failwith 490 | (Printf.sprintf 491 | "Unable to load environment, the file '%s' doesn't exist." 492 | filename) 493 | end 494 | 495 | let rec var_expand str env = 496 | let buff = Buffer.create ((String.length str) * 2) in 497 | Buffer.add_substitute 498 | buff 499 | (fun var -> 500 | try 501 | var_expand (MapString.find var env) env 502 | with Not_found -> 503 | failwith 504 | (Printf.sprintf 505 | "No variable %s defined when trying to expand %S." 506 | var 507 | str)) 508 | str; 509 | Buffer.contents buff 510 | 511 | 512 | let var_get name env = var_expand (MapString.find name env) env 513 | let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst 514 | end 515 | 516 | 517 | # 517 "myocamlbuild.ml" 518 | module MyOCamlbuildFindlib = struct 519 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) 520 | 521 | 522 | (** OCamlbuild extension, copied from 523 | * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html 524 | * by N. Pouillard and others 525 | * 526 | * Updated on 2016-06-02 527 | * 528 | * Modified by Sylvain Le Gall 529 | *) 530 | open Ocamlbuild_plugin 531 | 532 | 533 | type conf = {no_automatic_syntax: bool} 534 | 535 | 536 | let run_and_read = Ocamlbuild_pack.My_unix.run_and_read 537 | 538 | 539 | let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings 540 | 541 | 542 | let exec_from_conf exec = 543 | let exec = 544 | let env = BaseEnvLight.load ~allow_empty:true () in 545 | try 546 | BaseEnvLight.var_get exec env 547 | with Not_found -> 548 | Printf.eprintf "W: Cannot get variable %s\n" exec; 549 | exec 550 | in 551 | let fix_win32 str = 552 | if Sys.os_type = "Win32" then begin 553 | let buff = Buffer.create (String.length str) in 554 | (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. 555 | *) 556 | String.iter 557 | (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) 558 | str; 559 | Buffer.contents buff 560 | end else begin 561 | str 562 | end 563 | in 564 | fix_win32 exec 565 | 566 | 567 | let split s ch = 568 | let buf = Buffer.create 13 in 569 | let x = ref [] in 570 | let flush () = 571 | x := (Buffer.contents buf) :: !x; 572 | Buffer.clear buf 573 | in 574 | String.iter 575 | (fun c -> 576 | if c = ch then 577 | flush () 578 | else 579 | Buffer.add_char buf c) 580 | s; 581 | flush (); 582 | List.rev !x 583 | 584 | 585 | let split_nl s = split s '\n' 586 | 587 | 588 | let before_space s = 589 | try 590 | String.before s (String.index s ' ') 591 | with Not_found -> s 592 | 593 | (* ocamlfind command *) 594 | let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] 595 | 596 | (* This lists all supported packages. *) 597 | let find_packages () = 598 | List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) 599 | 600 | 601 | (* Mock to list available syntaxes. *) 602 | let find_syntaxes () = ["camlp4o"; "camlp4r"] 603 | 604 | 605 | let well_known_syntax = [ 606 | "camlp4.quotations.o"; 607 | "camlp4.quotations.r"; 608 | "camlp4.exceptiontracer"; 609 | "camlp4.extend"; 610 | "camlp4.foldgenerator"; 611 | "camlp4.listcomprehension"; 612 | "camlp4.locationstripper"; 613 | "camlp4.macro"; 614 | "camlp4.mapgenerator"; 615 | "camlp4.metagenerator"; 616 | "camlp4.profiler"; 617 | "camlp4.tracer" 618 | ] 619 | 620 | 621 | let dispatch conf = 622 | function 623 | | After_options -> 624 | (* By using Before_options one let command line options have an higher 625 | * priority on the contrary using After_options will guarantee to have 626 | * the higher priority override default commands by ocamlfind ones *) 627 | Options.ocamlc := ocamlfind & A"ocamlc"; 628 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 629 | Options.ocamldep := ocamlfind & A"ocamldep"; 630 | Options.ocamldoc := ocamlfind & A"ocamldoc"; 631 | Options.ocamlmktop := ocamlfind & A"ocamlmktop"; 632 | Options.ocamlmklib := ocamlfind & A"ocamlmklib" 633 | 634 | | After_rules -> 635 | 636 | (* Avoid warnings for unused tag *) 637 | flag ["tests"] N; 638 | 639 | (* When one link an OCaml library/binary/package, one should use 640 | * -linkpkg *) 641 | flag ["ocaml"; "link"; "program"] & A"-linkpkg"; 642 | 643 | (* For each ocamlfind package one inject the -package option when 644 | * compiling, computing dependencies, generating documentation and 645 | * linking. *) 646 | List.iter 647 | begin fun pkg -> 648 | let base_args = [A"-package"; A pkg] in 649 | (* TODO: consider how to really choose camlp4o or camlp4r. *) 650 | let syn_args = [A"-syntax"; A "camlp4o"] in 651 | let (args, pargs) = 652 | (* Heuristic to identify syntax extensions: whether they end in 653 | ".syntax"; some might not. 654 | *) 655 | if not (conf.no_automatic_syntax) && 656 | (Filename.check_suffix pkg "syntax" || 657 | List.mem pkg well_known_syntax) then 658 | (syn_args @ base_args, syn_args) 659 | else 660 | (base_args, []) 661 | in 662 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; 663 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; 664 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; 665 | flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; 666 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; 667 | 668 | (* TODO: Check if this is allowed for OCaml < 3.12.1 *) 669 | flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; 670 | flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; 671 | flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; 672 | flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; 673 | end 674 | (find_packages ()); 675 | 676 | (* Like -package but for extensions syntax. Morover -syntax is useless 677 | * when linking. *) 678 | List.iter begin fun syntax -> 679 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 680 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 681 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 682 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & 683 | S[A"-syntax"; A syntax]; 684 | end (find_syntaxes ()); 685 | 686 | (* The default "thread" tag is not compatible with ocamlfind. 687 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa" 688 | * options when using this tag. When using the "-linkpkg" option with 689 | * ocamlfind, this module will then be added twice on the command line. 690 | * 691 | * To solve this, one approach is to add the "-thread" option when using 692 | * the "threads" package using the previous plugin. 693 | *) 694 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); 695 | flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); 696 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); 697 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); 698 | flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]); 699 | flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); 700 | flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); 701 | flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); 702 | flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); 703 | flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]); 704 | 705 | | _ -> 706 | () 707 | end 708 | 709 | module MyOCamlbuildBase = struct 710 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 711 | 712 | 713 | (** Base functions for writing myocamlbuild.ml 714 | @author Sylvain Le Gall 715 | *) 716 | 717 | 718 | open Ocamlbuild_plugin 719 | module OC = Ocamlbuild_pack.Ocaml_compiler 720 | 721 | 722 | type dir = string 723 | type file = string 724 | type name = string 725 | type tag = string 726 | 727 | 728 | type t = 729 | { 730 | lib_ocaml: (name * dir list * string list) list; 731 | lib_c: (name * dir * file list) list; 732 | flags: (tag list * (spec OASISExpr.choices)) list; 733 | (* Replace the 'dir: include' from _tags by a precise interdepends in 734 | * directory. 735 | *) 736 | includes: (dir * dir list) list; 737 | } 738 | 739 | 740 | (* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 741 | 742 | 743 | let env_filename = Pathname.basename BaseEnvLight.default_filename 744 | 745 | 746 | let dispatch_combine lst = 747 | fun e -> 748 | List.iter 749 | (fun dispatch -> dispatch e) 750 | lst 751 | 752 | 753 | let tag_libstubs nm = 754 | "use_lib"^nm^"_stubs" 755 | 756 | 757 | let nm_libstubs nm = 758 | nm^"_stubs" 759 | 760 | 761 | let dispatch t e = 762 | let env = BaseEnvLight.load ~allow_empty:true () in 763 | match e with 764 | | Before_options -> 765 | let no_trailing_dot s = 766 | if String.length s >= 1 && s.[0] = '.' then 767 | String.sub s 1 ((String.length s) - 1) 768 | else 769 | s 770 | in 771 | List.iter 772 | (fun (opt, var) -> 773 | try 774 | opt := no_trailing_dot (BaseEnvLight.var_get var env) 775 | with Not_found -> 776 | Printf.eprintf "W: Cannot get variable %s\n" var) 777 | [ 778 | Options.ext_obj, "ext_obj"; 779 | Options.ext_lib, "ext_lib"; 780 | Options.ext_dll, "ext_dll"; 781 | ] 782 | 783 | | After_rules -> 784 | (* Declare OCaml libraries *) 785 | List.iter 786 | (function 787 | | nm, [], intf_modules -> 788 | ocaml_lib nm; 789 | let cmis = 790 | List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") 791 | intf_modules in 792 | dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis 793 | | nm, dir :: tl, intf_modules -> 794 | ocaml_lib ~dir:dir (dir^"/"^nm); 795 | List.iter 796 | (fun dir -> 797 | List.iter 798 | (fun str -> 799 | flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) 800 | ["compile"; "infer_interface"; "doc"]) 801 | tl; 802 | let cmis = 803 | List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") 804 | intf_modules in 805 | dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] 806 | cmis) 807 | t.lib_ocaml; 808 | 809 | (* Declare directories dependencies, replace "include" in _tags. *) 810 | List.iter 811 | (fun (dir, include_dirs) -> 812 | Pathname.define_context dir include_dirs) 813 | t.includes; 814 | 815 | (* Declare C libraries *) 816 | List.iter 817 | (fun (lib, dir, headers) -> 818 | (* Handle C part of library *) 819 | flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] 820 | (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; 821 | A("-l"^(nm_libstubs lib))]); 822 | 823 | flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] 824 | (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); 825 | 826 | if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then 827 | flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] 828 | (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); 829 | 830 | (* When ocaml link something that use the C library, then one 831 | need that file to be up to date. 832 | This holds both for programs and for libraries. 833 | *) 834 | dep ["link"; "ocaml"; tag_libstubs lib] 835 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 836 | 837 | dep ["compile"; "ocaml"; tag_libstubs lib] 838 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 839 | 840 | (* TODO: be more specific about what depends on headers *) 841 | (* Depends on .h files *) 842 | dep ["compile"; "c"] 843 | headers; 844 | 845 | (* Setup search path for lib *) 846 | flag ["link"; "ocaml"; "use_"^lib] 847 | (S[A"-I"; P(dir)]); 848 | ) 849 | t.lib_c; 850 | 851 | (* Add flags *) 852 | List.iter 853 | (fun (tags, cond_specs) -> 854 | let spec = BaseEnvLight.var_choose cond_specs env in 855 | let rec eval_specs = 856 | function 857 | | S lst -> S (List.map eval_specs lst) 858 | | A str -> A (BaseEnvLight.var_expand str env) 859 | | spec -> spec 860 | in 861 | flag tags & (eval_specs spec)) 862 | t.flags 863 | | _ -> 864 | () 865 | 866 | 867 | let dispatch_default conf t = 868 | dispatch_combine 869 | [ 870 | dispatch t; 871 | MyOCamlbuildFindlib.dispatch conf; 872 | ] 873 | 874 | 875 | end 876 | 877 | 878 | # 878 "myocamlbuild.ml" 879 | open Ocamlbuild_plugin;; 880 | let package_default = 881 | {MyOCamlbuildBase.lib_ocaml = []; lib_c = []; flags = []; includes = []} 882 | ;; 883 | 884 | let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} 885 | 886 | let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; 887 | 888 | # 889 "myocamlbuild.ml" 889 | (* OASIS_STOP *) 890 | Ocamlbuild_plugin.dispatch dispatch_default;; 891 | -------------------------------------------------------------------------------- /setup.ml: -------------------------------------------------------------------------------- 1 | (* setup.ml generated for the first time by OASIS v0.4.10 *) 2 | 3 | (* OASIS_START *) 4 | (* DO NOT EDIT (digest: a426e2d026defb34183b787d31fbdcff) *) 5 | (******************************************************************************) 6 | (* OASIS: architecture for building OCaml libraries and applications *) 7 | (* *) 8 | (* Copyright (C) 2011-2016, Sylvain Le Gall *) 9 | (* Copyright (C) 2008-2011, OCamlCore SARL *) 10 | (* *) 11 | (* This library is free software; you can redistribute it and/or modify it *) 12 | (* under the terms of the GNU Lesser General Public License as published by *) 13 | (* the Free Software Foundation; either version 2.1 of the License, or (at *) 14 | (* your option) any later version, with the OCaml static compilation *) 15 | (* exception. *) 16 | (* *) 17 | (* This library is distributed in the hope that it will be useful, but *) 18 | (* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) 19 | (* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) 20 | (* details. *) 21 | (* *) 22 | (* You should have received a copy of the GNU Lesser General Public License *) 23 | (* along with this library; if not, write to the Free Software Foundation, *) 24 | (* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) 25 | (******************************************************************************) 26 | 27 | let () = 28 | try 29 | Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") 30 | with Not_found -> () 31 | ;; 32 | #use "topfind";; 33 | #require "oasis.dynrun";; 34 | open OASISDynRun;; 35 | 36 | let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t 37 | open BaseCompat.Compat_0_4 38 | (* OASIS_STOP *) 39 | let () = setup ();; 40 | -------------------------------------------------------------------------------- /src/erl.ml: -------------------------------------------------------------------------------- 1 | exception Timeout 2 | type pid = int 3 | module IntSet = Set.Make ( 4 | struct 5 | let compare = Pervasives.compare 6 | type t = pid 7 | end) 8 | type msg_or_timeout = Msg of Erl_msg.t | Timeout 9 | type proc = 10 | {id : int; 11 | mutable mbox : (unit ref option * msg_or_timeout) Queue.t; 12 | mutable name : string option; 13 | mutable timer : unit ref; 14 | mutable recv_ref : unit ref option; 15 | mutable monitored_by : IntSet.t; 16 | mutable sockets : IntSet.t; 17 | mutable stack : (unit -> unit) option} 18 | 19 | let last_pid = ref 0 20 | let running_pid = ref 0 21 | let run_q = Queue.create () 22 | let timer_q = ref [] 23 | let named_procs : (string, pid) Hashtbl.t = Hashtbl.create 10 24 | let proc_table : proc option array ref = ref (Array.make 1024 None) 25 | let infinity = max_float 26 | let prompt = Delimcc.new_prompt () 27 | 28 | let next_pid () = 29 | incr last_pid; 30 | if !last_pid >= Array.length !proc_table then ( 31 | let arr = Array.make (Array.length !proc_table) None in 32 | proc_table := Array.append !proc_table arr 33 | ); 34 | !last_pid 35 | 36 | let self () = !running_pid 37 | 38 | let make_ref () = ref () 39 | 40 | let pid_to_proc pid = 41 | !proc_table.(pid) 42 | 43 | let is_process_alive pid = 44 | match pid_to_proc pid with 45 | | Some _ -> true 46 | | None -> false 47 | 48 | let processes () = 49 | Array.fold_right 50 | (fun v acc -> 51 | match v with 52 | | None -> acc 53 | | Some proc -> proc.id::acc 54 | ) !proc_table [] 55 | 56 | let init_proc () = 57 | let pid = next_pid () in 58 | let proc = {id = pid; 59 | timer = make_ref (); 60 | recv_ref = None; 61 | name = None; 62 | mbox = Queue.create (); 63 | monitored_by = IntSet.empty; 64 | sockets = IntSet.empty; 65 | stack = None} in 66 | !proc_table.(pid) <- Some proc; 67 | proc 68 | 69 | let spawn f = 70 | let proc = init_proc () in 71 | let stack () = Delimcc.push_prompt prompt (fun () -> ignore (f ())) in 72 | Queue.push (proc.id, stack) run_q; 73 | proc.id 74 | 75 | let whereis name = 76 | Hashtbl.find named_procs name 77 | 78 | let send' pid msg reference = 79 | match pid_to_proc pid with 80 | | None -> 81 | false 82 | | Some ({stack = Some resume_stack; 83 | recv_ref = ref'} as proc) when ref' == reference -> 84 | proc.stack <- None; 85 | proc.recv_ref <- None; 86 | if reference <> None && not (Queue.is_empty proc.mbox) then ( 87 | (* Inserting in the head of proc.mbox queue *) 88 | let q = Queue.create () in 89 | let _ = Queue.add (reference, Msg msg) q in 90 | let _ = Queue.transfer proc.mbox q in 91 | proc.mbox <- q 92 | ) else ( 93 | Queue.push (reference, Msg msg) proc.mbox 94 | ); 95 | Queue.push (pid, resume_stack) run_q; 96 | true 97 | | Some proc -> 98 | Queue.push (reference, Msg msg) proc.mbox; 99 | true 100 | 101 | let send pid msg = 102 | send' pid msg None 103 | 104 | let send_by_ref pid msg reference = 105 | send' pid msg (Some reference) 106 | 107 | let monitor pid = 108 | match pid_to_proc pid with 109 | | Some proc -> 110 | proc.monitored_by <- IntSet.add (self ()) proc.monitored_by 111 | | None -> 112 | ignore (send (self()) (`DOWN pid)) 113 | 114 | let demonitor pid = 115 | match pid_to_proc pid with 116 | | Some ({monitored_by = pids} as proc) -> 117 | proc.monitored_by <- IntSet.remove (self ()) pids 118 | | None -> 119 | () 120 | 121 | let register name pid = 122 | match pid_to_proc pid with 123 | | Some proc -> 124 | proc.name <- Some name; 125 | Hashtbl.replace named_procs name pid 126 | | None -> 127 | () 128 | 129 | let unregister name = 130 | let pid = Hashtbl.find named_procs name in 131 | Hashtbl.remove named_procs name; 132 | match pid_to_proc pid with 133 | | Some proc -> 134 | proc.name <- None 135 | | None -> 136 | () 137 | 138 | let register_socket pid sock = 139 | match pid_to_proc pid with 140 | | Some proc -> 141 | proc.sockets <- IntSet.add sock proc.sockets 142 | | None -> 143 | () 144 | 145 | let unregister_socket pid sock = 146 | match pid_to_proc pid with 147 | | Some proc -> 148 | proc.sockets <- IntSet.remove sock proc.sockets 149 | | None -> 150 | () 151 | 152 | let destroy_proc proc = 153 | IntSet.iter (fun pid -> ignore (send pid (`DOWN proc.id))) proc.monitored_by; 154 | IntSet.iter (fun sock -> Erl_inet.close sock) proc.sockets; 155 | !proc_table.(proc.id) <- None; 156 | match proc.name with 157 | | Some name -> 158 | Hashtbl.remove named_procs name 159 | | None -> 160 | () 161 | 162 | let rec insert_timer timer timers acc = 163 | match timers with 164 | | timer'::timers' when timer > timer' -> 165 | insert_timer timer timers' (timer'::acc) 166 | | _ -> 167 | List.rev_append acc (timer::timers) 168 | 169 | let set_timeout proc timeout = 170 | let fire_time = Unix.gettimeofday () +. timeout in 171 | proc.timer <- make_ref (); 172 | timer_q := insert_timer (fire_time, proc.id, proc.timer) !timer_q [] 173 | 174 | let cancel_timeout proc = 175 | proc.timer <- make_ref () 176 | 177 | let wait_for_msg proc timeout reference = 178 | match Queue.is_empty proc.mbox with 179 | | true when timeout > 0.0 -> 180 | if timeout <> infinity then 181 | set_timeout proc timeout; 182 | Delimcc.shift0 prompt 183 | (fun stack -> 184 | proc.stack <- Some stack; 185 | proc.recv_ref <- reference) 186 | | true -> 187 | raise Timeout 188 | | false -> 189 | () 190 | 191 | let receive' proc timeout reference = 192 | wait_for_msg proc timeout reference; 193 | cancel_timeout proc; 194 | match Queue.pop proc.mbox with 195 | | _, Timeout -> raise Timeout 196 | | _, Msg msg -> msg 197 | 198 | let receive ?timeout:(timeout = infinity) () = 199 | match pid_to_proc (self ()) with 200 | | Some proc -> 201 | receive' proc timeout None 202 | | None -> 203 | assert false 204 | 205 | let rec find_msg proc reference acc = 206 | match Queue.pop proc.mbox with 207 | | exception Not_found -> 208 | proc.mbox <- acc; 209 | None 210 | | (ref', Msg msg) when ref' == reference -> 211 | Queue.transfer proc.mbox acc; 212 | proc.mbox <- acc; 213 | Some msg 214 | | msg -> 215 | Queue.add msg acc; 216 | find_msg proc reference acc 217 | 218 | let receive_by_ref ?timeout:(timeout = infinity) reference = 219 | match pid_to_proc (self ()) with 220 | | Some proc -> 221 | let q = Queue.create () in 222 | begin match find_msg proc (Some reference) q with 223 | | Some msg -> 224 | msg 225 | | None -> 226 | receive' proc timeout (Some reference) 227 | end 228 | | None -> 229 | assert false 230 | 231 | let rec process_run_q' q = 232 | match Queue.pop q with 233 | | exception Queue.Empty -> 234 | () 235 | | (pid, task) -> 236 | begin 237 | match pid_to_proc pid with 238 | | Some proc -> 239 | running_pid := pid; 240 | begin 241 | match task () with 242 | | exception exn -> 243 | let reason = Printexc.to_string exn in 244 | Printf.printf 245 | "process %d terminated with exception: %s\n%!" 246 | pid reason; 247 | destroy_proc proc 248 | | _ -> 249 | begin 250 | match proc.stack with 251 | | None -> 252 | destroy_proc proc 253 | | Some _ -> 254 | () 255 | end 256 | end 257 | | None -> 258 | () 259 | end; 260 | process_run_q' q 261 | 262 | let process_run_q () = 263 | if not (Queue.is_empty run_q) then ( 264 | let q = Queue.create () in 265 | let _ = Queue.transfer run_q q in 266 | process_run_q' q 267 | ) 268 | 269 | let rec process_timers () = 270 | let cur_time = Unix.gettimeofday () in 271 | match !timer_q with 272 | | (fire_time, pid, timer)::timers when cur_time >= fire_time -> 273 | timer_q := timers; 274 | begin 275 | match pid_to_proc pid with 276 | | Some ({stack = Some resume_stack; 277 | timer = timer'} as proc) when timer == timer' -> 278 | proc.stack <- None; 279 | proc.recv_ref <- None; 280 | Queue.push (None, Timeout) proc.mbox; 281 | Queue.push (pid, resume_stack) run_q 282 | | _ -> 283 | () 284 | end; 285 | process_timers () 286 | | (fire_time, pid, _)::timers -> 287 | if (is_process_alive pid) then ( 288 | fire_time -. cur_time 289 | ) else ( 290 | timer_q := timers; 291 | process_timers () 292 | ) 293 | | [] -> 294 | infinity 295 | 296 | let process_io timeout = 297 | let _ = Erl_inet.wait timeout in 298 | let q = Erl_inet.queue_transfer () in 299 | let len = Erl_inet.queue_len q in 300 | for i=0 to (len-1) do ( 301 | match Erl_inet.queue_get q i with 302 | | 0, sock, pid, data -> 303 | if (data <> "") then ( 304 | ignore (send pid (`Sock_data (sock, data))); 305 | ) else ( 306 | ignore (send pid (`Sock_accept sock)) 307 | ) 308 | | err, sock, pid, _ -> 309 | unregister_socket pid sock; 310 | ignore (send pid (`Sock_error (sock, err))) 311 | ) done; 312 | Erl_inet.queue_free q 313 | 314 | let rec schedule () = 315 | let _ = process_run_q () in 316 | let timeout = process_timers () in 317 | let timeout' = match Queue.is_empty run_q with 318 | | true -> timeout 319 | | false -> 0.0 320 | in 321 | let _ = process_io timeout' in 322 | schedule () 323 | 324 | let run () = 325 | let _ = Erl_inet.init () in 326 | schedule () 327 | -------------------------------------------------------------------------------- /src/erl_inet.ml: -------------------------------------------------------------------------------- 1 | type socket = int 2 | type pid = int 3 | type sock_queue 4 | exception Sock_error of int 5 | 6 | external connect : pid -> string -> int -> socket = "ml_connect" 7 | external listen : pid -> string -> int -> int -> socket = "ml_listen" 8 | external send : socket -> string -> unit = "ml_send" 9 | external activate : socket -> unit = "ml_activate" 10 | external start : unit -> unit = "ml_start" 11 | external close : socket -> unit = "ml_close" 12 | external strerror : int -> string = "ml_strerror" 13 | (* for polling *) 14 | external wait : float -> unit = "ml_wait" 15 | external queue_transfer : unit -> sock_queue = "ml_queue_transfer" 16 | external queue_free : sock_queue -> unit = "ml_queue_free" 17 | external queue_len : sock_queue -> int = "ml_queue_len" 18 | external queue_get : sock_queue -> int -> (int * socket * pid * string) = "ml_queue_get" 19 | 20 | let init () = 21 | Callback.register_exception "sock_error" (Sock_error 0); 22 | start() 23 | -------------------------------------------------------------------------------- /src/erl_inet_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | 19 | #define RECV_BUF_SIZE 8192 20 | #define MAX_FD_NUMBER 10240 21 | #ifdef MSG_NOSIGNAL 22 | #define SEND_FLAGS MSG_NOSIGNAL 23 | #else 24 | #define SEND_FLAGS 0 25 | #endif 26 | 27 | enum { 28 | CMD_CONNECT, 29 | CMD_SEND, 30 | CMD_RECV, 31 | CMD_CLOSE, 32 | CMD_ERROR, 33 | CMD_ACTIVATE, 34 | CMD_LISTEN, 35 | CMD_ACCEPT 36 | }; 37 | 38 | typedef struct command { 39 | int pid; 40 | int fd; 41 | int cmd; 42 | int err; 43 | char *buf; 44 | size_t buf_size; 45 | } command; 46 | 47 | typedef struct socket_state { 48 | int pid; 49 | size_t obuf_size; 50 | char *obuf; 51 | ev_io *read_w; 52 | ev_io *write_w; 53 | int err; 54 | } socket_state; 55 | 56 | typedef struct thread_args { 57 | int cpu; 58 | pthread_mutex_t *lock; 59 | pthread_cond_t *done; 60 | } thread_args; 61 | 62 | static ev_timer timer_w; 63 | static ev_async wakeup_w; 64 | static socket_state *socket_tab[MAX_FD_NUMBER] = {NULL}; 65 | static void *socket_loop[256] = {NULL}; 66 | static void *send_q[256] = {NULL}; 67 | static void *async_w[256] = {NULL}; 68 | static pthread_t thread[256]; 69 | static struct ev_loop *default_loop = NULL; 70 | static void *recv_q = NULL; 71 | static int num_of_cpus = 1; 72 | 73 | extern void *queue_new(size_t); 74 | extern void queue_free(void *); 75 | extern void queue_push(void *, void *); 76 | extern void *queue_transfer(void *); 77 | extern void *queue_get(void *, size_t); 78 | extern size_t queue_len(void *); 79 | 80 | static void send_command(int fd, command *cmd) { 81 | int cpu = fd % num_of_cpus; 82 | struct ev_loop *loop = socket_loop[cpu]; 83 | void *q = send_q[cpu]; 84 | ev_async *w = async_w[cpu]; 85 | queue_push(q, cmd); 86 | ev_async_send(loop, w); 87 | } 88 | 89 | static socket_state *init_state(int pid, int fd) { 90 | socket_state *state = NULL; 91 | if (fd < MAX_FD_NUMBER) { 92 | state = malloc(sizeof(socket_state)); 93 | state->write_w = malloc(sizeof(ev_io)); 94 | state->read_w = malloc(sizeof(ev_io)); 95 | state->pid = pid; 96 | state->obuf = NULL; 97 | state->obuf_size = 0; 98 | socket_tab[fd] = state; 99 | } 100 | return state; 101 | } 102 | 103 | static void destroy_state(socket_state *state, int fd) { 104 | if (fd < MAX_FD_NUMBER) 105 | socket_tab[fd] = NULL; 106 | if (state) { 107 | free(state->obuf); 108 | free(state->write_w); 109 | free(state->read_w); 110 | }; 111 | free(state); 112 | } 113 | 114 | static socket_state *lookup_state(int fd) { 115 | if (fd < MAX_FD_NUMBER) 116 | return socket_tab[fd]; 117 | else 118 | return NULL; 119 | } 120 | 121 | static void handle_error(socket_state *state, struct ev_loop *loop, int err) 122 | { 123 | err ? (err = errno) : (err = ECONNRESET); 124 | if (err == EAGAIN || err == EWOULDBLOCK || err == EINPROGRESS) { 125 | /* Do nothing, socket is not ready yet */ 126 | } else { 127 | int fd = state->write_w->fd; 128 | command cmd = {.pid = state->pid, 129 | .fd = fd, 130 | .cmd = CMD_ERROR, 131 | .err = err, 132 | .buf = NULL, 133 | .buf_size = 0}; 134 | ev_io_stop(loop, state->write_w); 135 | ev_io_stop(loop, state->read_w); 136 | destroy_state(state, fd); 137 | close(fd); 138 | queue_push(recv_q, &cmd); 139 | ev_async_send(default_loop, &wakeup_w); 140 | } 141 | } 142 | 143 | static void handle_read(struct ev_loop *loop, ev_io *w, int revents) { 144 | socket_state *state = lookup_state(w->fd); 145 | assert(state); 146 | char *buf = malloc(RECV_BUF_SIZE); 147 | ssize_t recv = read(w->fd, buf, RECV_BUF_SIZE); 148 | if (recv > 0) { 149 | assert(RECV_BUF_SIZE >= recv); 150 | command cmd = {.pid = state->pid, 151 | .fd = w->fd, 152 | .cmd = CMD_RECV, 153 | .err = 0, 154 | .buf = buf, 155 | .buf_size = recv}; 156 | ev_io_stop(loop, w); 157 | queue_push(recv_q, &cmd); 158 | ev_async_send(default_loop, &wakeup_w); 159 | } else { 160 | free(buf); 161 | handle_error(state, loop, recv); 162 | } 163 | } 164 | 165 | static void handle_write(struct ev_loop *loop, ev_io *w, int revents) { 166 | socket_state *state = lookup_state(w->fd); 167 | assert(state); 168 | if (state->obuf_size) { 169 | ssize_t sent = send(w->fd, state->obuf, state->obuf_size, SEND_FLAGS); 170 | if (sent >= state->obuf_size) { 171 | free(state->obuf); 172 | state->obuf_size = 0; 173 | state->obuf = NULL; 174 | ev_io_stop(loop, w); 175 | } else if (sent > 0) { 176 | state->obuf_size -= sent; 177 | memmove(state->obuf, state->obuf + sent, state->obuf_size); 178 | } else { 179 | handle_error(state, loop, sent); 180 | } 181 | } else { 182 | ev_io_stop(loop, w); 183 | } 184 | } 185 | 186 | static void handle_connect(struct ev_loop *loop, ev_io *w, int revents) { 187 | socket_state *state = lookup_state(w->fd); 188 | assert(state); 189 | errno = 0; 190 | unsigned int len = sizeof(errno); 191 | getsockopt(w->fd, SOL_SOCKET, SO_ERROR, &errno, &len); 192 | if (errno) { 193 | handle_error(state, loop, -1); 194 | } else { 195 | command cmd = {.pid = state->pid, 196 | .fd = w->fd, 197 | .cmd = CMD_CONNECT, 198 | .err = 0, 199 | .buf = NULL, 200 | .buf_size = 0}; 201 | queue_push(recv_q, &cmd); 202 | ev_async_send(default_loop, &wakeup_w); 203 | ev_set_cb(state->write_w, handle_write); 204 | if (!state->obuf_size) 205 | ev_io_stop(loop, w); 206 | } 207 | } 208 | 209 | static void handle_accept(struct ev_loop *loop, ev_io *w, int revents) { 210 | socket_state *state = lookup_state(w->fd); 211 | assert(state); 212 | struct sockaddr src; 213 | socklen_t len; 214 | int fd = accept(w->fd, &src, &len); 215 | if (fd < 0) { 216 | handle_error(state, loop, errno); 217 | } else { 218 | command cmd = {.pid = state->pid, 219 | .fd = fd, 220 | .cmd = CMD_ACCEPT, 221 | .err = 0, 222 | .buf = NULL, 223 | .buf_size = 0}; 224 | send_command(fd, &cmd); 225 | } 226 | } 227 | 228 | static void process_connect(struct ev_loop *loop, socket_state *state, command *cmd) { 229 | if (!state) { 230 | state = init_state(cmd->pid, cmd->fd); 231 | ev_io_init(state->read_w, handle_read, cmd->fd, EV_READ); 232 | ev_io_init(state->write_w, handle_connect, cmd->fd, EV_WRITE); 233 | ev_io_start(loop, state->write_w); 234 | } 235 | } 236 | 237 | static void process_listen(struct ev_loop *loop, socket_state *state, command *cmd) { 238 | if (!state) { 239 | state = init_state(cmd->pid, cmd->fd); 240 | ev_io_init(state->read_w, handle_accept, cmd->fd, EV_READ); 241 | ev_io_init(state->write_w, handle_write, cmd->fd, EV_WRITE); 242 | ev_io_start(loop, state->read_w); 243 | } 244 | } 245 | 246 | static void process_accept(struct ev_loop *loop, socket_state *state, command *cmd) { 247 | if (!state) { 248 | state = init_state(cmd->pid, cmd->fd); 249 | ev_io_init(state->read_w, handle_read, cmd->fd, EV_READ); 250 | ev_io_init(state->write_w, handle_write, cmd->fd, EV_WRITE); 251 | command c = {.pid = cmd->pid, 252 | .fd = cmd->fd, 253 | .cmd = CMD_ACCEPT, 254 | .err = 0, 255 | .buf = NULL, 256 | .buf_size = 0}; 257 | queue_push(recv_q, &c); 258 | ev_async_send(default_loop, &wakeup_w); 259 | } 260 | } 261 | 262 | static void process_send(struct ev_loop *loop, socket_state *state, command *cmd) { 263 | if (state) { 264 | if (!state->obuf_size) { 265 | ssize_t sent = send(cmd->fd, cmd->buf, cmd->buf_size, SEND_FLAGS); 266 | if (sent >= cmd->buf_size) { 267 | free(cmd->buf); 268 | } else if (sent > 0) { 269 | state->obuf_size = cmd->buf_size - sent; 270 | state->obuf = malloc(state->obuf_size); 271 | memcpy(state->obuf, cmd->buf + sent, state->obuf_size); 272 | free(cmd->buf); 273 | ev_io_start(loop, state->write_w); 274 | } else { 275 | handle_error(state, loop, sent); 276 | } 277 | } else { 278 | state->obuf = realloc(state->obuf, state->obuf_size + cmd->buf_size); 279 | memcpy(state->obuf + state->obuf_size, cmd->buf, cmd->buf_size); 280 | state->obuf_size += cmd->buf_size; 281 | free(cmd->buf); 282 | ev_io_start(loop, state->write_w); 283 | } 284 | } 285 | } 286 | 287 | static void process_activate(struct ev_loop *loop, socket_state *state, command *cmd) { 288 | if (state) 289 | ev_io_start(loop, state->read_w); 290 | } 291 | 292 | static void process_close(struct ev_loop *loop, socket_state *state, command *cmd) { 293 | if (state) { 294 | ev_io_stop(loop, state->read_w); 295 | ev_io_stop(loop, state->write_w); 296 | destroy_state(state, cmd->fd); 297 | close(cmd->fd); 298 | } 299 | } 300 | 301 | static void handle_event(struct ev_loop *loop, ev_async *w, int revents) { 302 | int *cpu = ev_userdata(loop); 303 | void *q = queue_transfer(send_q[*cpu]); 304 | size_t len = queue_len(q); 305 | socket_state *state; 306 | for (int i = 0; i < len; i++) { 307 | command *cmd = queue_get(q, i); 308 | state = lookup_state(cmd->fd); 309 | switch (cmd->cmd) { 310 | case CMD_CONNECT: 311 | process_connect(loop, state, cmd); 312 | break; 313 | case CMD_LISTEN: 314 | process_listen(loop, state, cmd); 315 | break; 316 | case CMD_ACCEPT: 317 | process_accept(loop, state, cmd); 318 | break; 319 | case CMD_SEND: 320 | process_send(loop, state, cmd); 321 | break; 322 | case CMD_ACTIVATE: 323 | process_activate(loop, state, cmd); 324 | break; 325 | case CMD_CLOSE: 326 | process_close(loop, state, cmd); 327 | break; 328 | default: 329 | assert(0); 330 | } 331 | } 332 | queue_free(q); 333 | } 334 | 335 | static void handle_wakeup(struct ev_loop *loop, ev_async *w, int revents) { 336 | ev_timer_stop(loop, &timer_w); 337 | ev_break(loop, EVBREAK_ALL); 338 | } 339 | 340 | static void handle_timeout(struct ev_loop *loop, ev_timer *w, int revents) { 341 | ev_break(loop, EVBREAK_ALL); 342 | } 343 | 344 | static void *run (void *data) { 345 | thread_args *args = data; 346 | int cpu = args->cpu; 347 | async_w[cpu] = malloc(sizeof(ev_async)); 348 | send_q[cpu] = queue_new(sizeof(command)); 349 | socket_loop[cpu] = ev_loop_new(EVFLAG_AUTO); 350 | ev_async *w = async_w[cpu]; 351 | struct ev_loop *loop = socket_loop[cpu]; 352 | ev_async_init(w, handle_event); 353 | ev_async_start(loop, w); 354 | ev_set_userdata(loop, &cpu); 355 | pthread_mutex_lock(args->lock); 356 | pthread_cond_signal(args->done); 357 | pthread_mutex_unlock(args->lock); 358 | ev_run(loop, 0); 359 | printf("libev loop has terminated unexpectedly\n"); 360 | abort(); 361 | return NULL; 362 | } 363 | 364 | static int parse_addr(char *host, int port, struct sockaddr_in *dst) { 365 | int res = inet_pton(AF_INET, host, &(dst->sin_addr)); 366 | dst->sin_family = AF_INET; 367 | dst->sin_port = htons(port); 368 | return res; 369 | } 370 | 371 | static int sock_open() { 372 | int fd = socket(AF_INET, SOCK_STREAM, 0); 373 | if (fd != -1) { 374 | int res = fcntl(fd, F_SETFL, O_NONBLOCK); 375 | if (res != -1) { 376 | #ifdef SO_NOSIGPIPE 377 | int set = 1; 378 | setsockopt(fd, SOL_SOCKET, SO_NOSIGPIPE, (void *)&set, sizeof(int)); 379 | #endif 380 | return fd; 381 | } else 382 | close(fd); 383 | } 384 | return -1; 385 | } 386 | 387 | value raise_sock_error(int err) { 388 | caml_raise_with_arg(*caml_named_value("sock_error"), Val_int(err)); 389 | return Val_unit; 390 | } 391 | 392 | value ml_start(value v) { 393 | num_of_cpus = sysconf(_SC_NPROCESSORS_ONLN); 394 | assert(num_of_cpus > 0); 395 | if (num_of_cpus > 1) 396 | num_of_cpus -= 1; 397 | recv_q = queue_new(sizeof(command)); 398 | pthread_mutex_t lock; 399 | pthread_cond_t done; 400 | pthread_mutex_init(&lock, NULL); 401 | pthread_cond_init(&done, NULL); 402 | for (int i=0; i < num_of_cpus; i++) { 403 | thread_args *args = malloc(sizeof(thread_args)); 404 | args->cpu = i; 405 | args->lock = &lock; 406 | args->done = &done; 407 | pthread_create(&thread[i], NULL, run, args); 408 | pthread_mutex_lock(&lock); 409 | pthread_cond_wait(&done, &lock); 410 | pthread_mutex_unlock(&lock); 411 | } 412 | default_loop = ev_default_loop(0); 413 | ev_timer_init(&timer_w, handle_timeout, 0.0, 0.0); 414 | ev_async_init(&wakeup_w, handle_wakeup); 415 | ev_async_start(default_loop, &wakeup_w); 416 | return Val_unit; 417 | } 418 | 419 | value ml_wait(value v) { 420 | ev_tstamp timeout = Double_val(v); 421 | caml_enter_blocking_section(); 422 | int flags = EVRUN_NOWAIT; 423 | if (timeout > 0.0) { 424 | ev_timer_set(&timer_w, timeout, 0.0); 425 | ev_timer_start(default_loop, &timer_w); 426 | flags = EVRUN_ONCE; 427 | } 428 | ev_run(default_loop, flags); 429 | caml_leave_blocking_section(); 430 | return Val_unit; 431 | } 432 | 433 | value ml_connect(value pid_v, value host, value port) { 434 | int pid = Int_val(pid_v); 435 | int fd, res; 436 | struct sockaddr_in dst; 437 | if (!(parse_addr(String_val(host), Int_val(port), &dst))) 438 | caml_failwith("inet_addr_of_string"); 439 | if ((fd = sock_open()) < 0) 440 | return raise_sock_error(errno); 441 | res = connect(fd, (struct sockaddr *) &dst, sizeof(dst)); 442 | if (!res || errno == EAGAIN || errno == EINPROGRESS || errno == EWOULDBLOCK) { 443 | command cmd = {.pid = pid, 444 | .fd = fd, 445 | .cmd = CMD_CONNECT, 446 | .err = 0, 447 | .buf = NULL, 448 | .buf_size = 0}; 449 | send_command(fd, &cmd); 450 | return Val_int(fd); 451 | } else { 452 | close(fd); 453 | return raise_sock_error(errno); 454 | } 455 | } 456 | 457 | value ml_listen(value pid_v, value host, value port, value backlog_v) { 458 | int pid = Int_val(pid_v); 459 | int backlog = Int_val(backlog_v); 460 | int fd, res; 461 | struct sockaddr_in src; 462 | if (!(parse_addr(String_val(host), Int_val(port), &src))) 463 | caml_failwith("inet_addr_of_string"); 464 | if ((fd = sock_open()) < 0) 465 | return raise_sock_error(errno); 466 | if ((res = bind(fd, (struct sockaddr *) &src, sizeof(src))) < 0) { 467 | close(fd); 468 | return raise_sock_error(errno); 469 | } 470 | if ((res = listen(fd, backlog)) < 0) { 471 | close(fd); 472 | return raise_sock_error(errno); 473 | } 474 | command cmd = {.pid = pid, 475 | .fd = fd, 476 | .cmd = CMD_LISTEN, 477 | .err = 0, 478 | .buf = NULL, 479 | .buf_size = 0}; 480 | send_command(fd, &cmd); 481 | return Val_int(fd); 482 | } 483 | 484 | value ml_close(value fd_v) { 485 | int fd = Int_val(fd_v); 486 | command cmd = {.pid = 0, 487 | .fd = fd, 488 | .cmd = CMD_CLOSE, 489 | .err = 0, 490 | .buf = NULL, 491 | .buf_size = 0}; 492 | send_command(fd, &cmd); 493 | return Val_unit; 494 | } 495 | 496 | value ml_send(value fd_v, value data) { 497 | size_t size = caml_string_length(data); 498 | if (size) { 499 | int fd = Int_val(fd_v); 500 | char *buf = malloc(size); 501 | memcpy(buf, String_val(data), size); 502 | command cmd = {.pid = 0, 503 | .fd = fd, 504 | .cmd = CMD_SEND, 505 | .err = 0, 506 | .buf = buf, 507 | .buf_size = size}; 508 | send_command(fd, &cmd); 509 | } 510 | return Val_unit; 511 | } 512 | 513 | value ml_activate(value fd_v) { 514 | int fd = Int_val(fd_v); 515 | command cmd = {.pid = 0, 516 | .fd = fd, 517 | .cmd = CMD_ACTIVATE, 518 | .err = 0, 519 | .buf = NULL, 520 | .buf_size = 0}; 521 | send_command(fd, &cmd); 522 | return Val_unit; 523 | } 524 | 525 | value ml_queue_transfer(value v) { 526 | void *q = queue_transfer(recv_q); 527 | return Val_long(q); 528 | } 529 | 530 | value ml_queue_free(value v) { 531 | void *q = (void *) Long_val(v); 532 | queue_free(q); 533 | return Val_unit; 534 | } 535 | 536 | value ml_queue_len(value v) { 537 | void *q = (void *) Long_val(v); 538 | return Val_int(queue_len(q)); 539 | } 540 | 541 | value ml_queue_get(value v1, value v2) { 542 | CAMLparam0 (); 543 | CAMLlocal2 (result, data); 544 | void *q = (void *) Long_val(v1); 545 | int i = Int_val(v2); 546 | command *cmd = queue_get(q, i); 547 | data = caml_alloc_string(cmd->buf_size); 548 | memcpy(String_val(data), cmd->buf, cmd->buf_size); 549 | free(cmd->buf); 550 | result = alloc_tuple(4); 551 | Store_field(result, 0, Val_int(cmd->err)); 552 | Store_field(result, 1, Val_int(cmd->fd)); 553 | Store_field(result, 2, Val_int(cmd->pid)); 554 | Store_field(result, 3, data); 555 | CAMLreturn (result); 556 | } 557 | 558 | value ml_strerror(value v) { 559 | CAMLparam0(); 560 | CAMLlocal1(result); 561 | int err = Int_val(v); 562 | char *reason = strerror(err); 563 | result = caml_copy_string(reason); 564 | CAMLreturn (result); 565 | } 566 | -------------------------------------------------------------------------------- /src/erl_msg.ml: -------------------------------------------------------------------------------- 1 | type t = [ `DOWN of int 2 | | `Ping of int 3 | | `Pong 4 | | `Sock_data of Erl_inet.socket * string 5 | | `Sock_accept of Erl_inet.socket 6 | | `Sock_error of Erl_inet.socket * int] 7 | -------------------------------------------------------------------------------- /src/erl_tcp.ml: -------------------------------------------------------------------------------- 1 | let connect host port = 2 | let pid = Erl.self () in 3 | let fd = Erl_inet.connect pid host port in 4 | let _ = Erl.register_socket pid fd in 5 | fd 6 | 7 | let listen ?backlog:(backlog = 5) host port = 8 | let pid = Erl.self () in 9 | let fd = Erl_inet.listen pid host port backlog in 10 | let _ = Erl.register_socket pid fd in 11 | fd 12 | 13 | let close sock = 14 | let pid = Erl.self () in 15 | let _ = Erl_inet.close sock in 16 | Erl.unregister_socket pid sock 17 | 18 | let activate = Erl_inet.activate 19 | let send = Erl_inet.send 20 | -------------------------------------------------------------------------------- /src/queue_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | typedef struct queue { 7 | size_t alloc_len; 8 | size_t len; 9 | size_t elem_size; 10 | void *elems; 11 | pthread_mutex_t lock; 12 | } queue; 13 | 14 | queue *queue_new (size_t elem_size) { 15 | queue *q = malloc(sizeof(queue)); 16 | q->alloc_len = 1024; 17 | q->elem_size = elem_size; 18 | q->elems = malloc(q->alloc_len * elem_size); 19 | q->len = 0; 20 | pthread_mutex_init(&q->lock, NULL); 21 | return q; 22 | } 23 | 24 | void queue_push (queue *q, void *elem) { 25 | pthread_mutex_lock(&q->lock); 26 | memcpy(q->elems + (q->len * q->elem_size), elem, q->elem_size); 27 | q->len++; 28 | if (q->len == q->alloc_len) { 29 | q->alloc_len *= 2; 30 | q->elems = realloc(q->elems, q->alloc_len * q->elem_size); 31 | }; 32 | pthread_mutex_unlock(&q->lock); 33 | } 34 | 35 | queue *queue_transfer(queue *orig_q) { 36 | queue *q = malloc(sizeof(queue)); 37 | pthread_mutex_lock(&orig_q->lock); 38 | memcpy(q, orig_q, sizeof(queue)); 39 | orig_q->len = 0; 40 | orig_q->alloc_len = 1024; 41 | orig_q->elems = malloc(orig_q->alloc_len * orig_q->elem_size); 42 | pthread_mutex_unlock(&orig_q->lock); 43 | return q; 44 | } 45 | 46 | void *queue_get(queue *q, size_t pos) { 47 | assert(pos < q->len); 48 | return q->elems + (pos * q->elem_size); 49 | } 50 | 51 | size_t queue_len(queue *q) { 52 | return q->len; 53 | } 54 | 55 | void queue_free(queue *q) { 56 | free(q->elems); 57 | free(q); 58 | } 59 | -------------------------------------------------------------------------------- /src/test.ml: -------------------------------------------------------------------------------- 1 | let f = ref 0 2 | let port = ref 5222 3 | let data = String.make (8*1024) '\000' 4 | 5 | let rec send_loop sock = 6 | Erl_tcp.activate sock; 7 | Erl_tcp.send sock data; 8 | match Erl.receive () with 9 | | `Sock_data (_, d) -> 10 | send_loop sock 11 | | `Sock_error (_, errno) -> 12 | Printf.printf 13 | "got error: %s (%d)\n%!" 14 | (Erl_inet.strerror errno) errno; 15 | send_loop sock 16 | | _ -> 17 | send_loop sock 18 | 19 | let sender () = 20 | match Erl_tcp.connect "127.0.0.1" !port with 21 | | exception (Erl_inet.Sock_error errno) -> 22 | Printf.printf "failed to connect: %s\n%!" (Erl_inet.strerror errno) 23 | | sock -> 24 | send_loop sock 25 | 26 | let rec recv_loop () = 27 | match Erl.receive () with 28 | | `Sock_data (sock, data) -> 29 | Erl_tcp.activate sock; 30 | Erl_tcp.send sock data; 31 | recv_loop () 32 | | `Sock_accept sock -> 33 | incr f; 34 | (* Printf.printf "accepted on %d\n%!" !f; *) 35 | Erl_tcp.activate sock; 36 | recv_loop () 37 | | `Sock_error (sock, errno) -> 38 | Printf.printf 39 | "got error: %s (%d)\n%!" 40 | (Erl_inet.strerror errno) errno; 41 | recv_loop () 42 | | _ -> 43 | recv_loop () 44 | 45 | let receiver () = 46 | match Erl_tcp.listen "0.0.0.0" !port ~backlog:1000 with 47 | | exception (Erl_inet.Sock_error errno) -> 48 | Printf.printf "failed to listen: %s\n%!" (Erl_inet.strerror errno) 49 | | _ -> 50 | for i=1 to 1000 do ( 51 | ignore (Erl.spawn sender) 52 | ) done; 53 | recv_loop () 54 | 55 | let _ = 56 | (* 57 | let _ = 58 | Gc.set { (Gc.get()) with Gc.major_heap_increment = 4000000; 59 | Gc.minor_heap_size = 16000000; 60 | Gc.max_overhead = 0; 61 | Gc.space_overhead = 0} in 62 | *) 63 | ignore (Erl.spawn receiver); 64 | Erl.run () 65 | --------------------------------------------------------------------------------