├── .gitignore ├── Cargo.toml ├── LICENSE.txt ├── Makefile ├── README.md ├── caml ├── allocpair.c ├── main.ml ├── printmod.ml └── rusty.ml └── src └── lib.rs /.gitignore: -------------------------------------------------------------------------------- 1 | target 2 | Cargo.lock 3 | *.cm[ix] 4 | *.o 5 | -------------------------------------------------------------------------------- /Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "dmz" 3 | version = "0.1.0" 4 | authors = ["Stephen Dolan "] 5 | 6 | [dependencies] 7 | libc = "0.2.0" 8 | 9 | [lib] 10 | name = "rusty" 11 | crate-type = ["staticlib"] -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright 2017- Stephen Dolan 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OCAMLOPT = ocamlopt -thread -ccopt -pthread unix.cmxa threads.cmxa 2 | 3 | main: target/debug/librusty.a caml/allocpair.c caml/rusty.ml caml/main.ml 4 | $(OCAMLOPT) -I caml $^ -o $@ 5 | 6 | printmod: target/debug/librusty.a caml/allocpair.c caml/printmod.ml 7 | $(OCAMLOPT) $^ -o $@ 8 | 9 | caml/rusty.ml: printmod 10 | ./$^ > $@ 11 | 12 | target/debug/librusty.a: src/lib.rs 13 | cargo build 14 | 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | it would be nice if there were a safe FFI between two safe languages, 2 | rather than interfacing everything via C. 3 | 4 | it would even nicer if the types of one language could be reflected 5 | soundly in the type system of the second. 6 | 7 | it would nicest if it worked for more than three types. 8 | -------------------------------------------------------------------------------- /caml/allocpair.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | value caml_alloc_cell(uintnat tag, value a) { 6 | CAMLparam1(a); 7 | CAMLlocal1(r); 8 | r = caml_alloc(1, tag); 9 | Field(r, 0) = a; 10 | CAMLreturn(r); 11 | } 12 | 13 | value caml_alloc_pair(uintnat tag, value a, value b) { 14 | CAMLparam2(a, b); 15 | CAMLlocal1(r); 16 | r = caml_alloc(2, tag); 17 | Field(r, 0) = a; 18 | Field(r, 1) = b; 19 | CAMLreturn(r); 20 | } 21 | -------------------------------------------------------------------------------- /caml/main.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | for i = 1 to 1000 do 3 | let a = ref 10 and b = ref 20 in 4 | let a', b' = Rusty.mkpair a b in 5 | if a <> a || b <> b' then begin 6 | Printf.printf "%d=%d, %d=%d\n%!" !a !a' !b !b'; 7 | assert false; 8 | end 9 | done; 10 | Printf.printf "%s\n" (Rusty.tostring ("hello", 42)); 11 | Printf.printf "%s\n" (match Rusty.strtail "hello" with Some s -> s | None -> "?"); 12 | match Rusty.somestr 42 with Some s -> Printf.printf "%s\n" s | None -> () 13 | 14 | -------------------------------------------------------------------------------- /caml/printmod.ml: -------------------------------------------------------------------------------- 1 | external print_module : unit -> unit = "print_module" 2 | 3 | let () = print_module () 4 | -------------------------------------------------------------------------------- /caml/rusty.ml: -------------------------------------------------------------------------------- 1 | external tostring : (string * int) -> string = "tostring" 2 | external mkpair : 'a -> 'b -> ('a * 'b) = "mkpair" 3 | external strtail : string -> string option = "strtail" 4 | external somestr : int -> string option = "somestr" 5 | external trip : 'a -> ('a * ('a * 'a)) = "trip" 6 | -------------------------------------------------------------------------------- /src/lib.rs: -------------------------------------------------------------------------------- 1 | #![feature(nll)] 2 | #![allow(dead_code)] 3 | #![allow(non_upper_case_globals)] 4 | #![allow(non_snake_case)] 5 | 6 | 7 | use std::cell::Cell; 8 | use std::ptr; 9 | use std::marker; 10 | use std::slice; 11 | use std::str; 12 | use std::io::{self, Write}; 13 | 14 | type Uintnat = u64; 15 | 16 | #[allow(non_camel_case_types)] 17 | type intnat = i64; 18 | type RawValue = intnat; 19 | 20 | 21 | //const Max_young_wosize : usize = 256; 22 | 23 | const No_scan_tag: u8 = 251; 24 | const Forward_tag: u8 = 250; 25 | const Infix_tag: u8 = 249; 26 | const Object_tag: u8 = 248; 27 | const Closure_tag: u8 = 247; 28 | const Lazy_tag: u8 = 246; 29 | const Abstract_tag: u8 = 251; 30 | const String_tag: u8 = 252; 31 | const Double_tag: u8 = 253; 32 | const Double_array_tag: u8 = 254; 33 | const Custom_tag: u8 = 255; 34 | 35 | fn Is_block(x: RawValue) -> bool { 36 | (x & 1) == 0 37 | } 38 | 39 | fn Hd_val(x: RawValue) -> Uintnat { 40 | assert!(Is_block(x)); 41 | unsafe { 42 | *(x as *const Uintnat).offset(-1) 43 | } 44 | } 45 | 46 | fn Wosize_val(x: RawValue) -> Uintnat { 47 | Hd_val(x) >> 10 48 | } 49 | 50 | fn Tag_val(x: RawValue) -> u8 { 51 | assert!(Is_block(x)); 52 | (Hd_val(x) & 0xff) as u8 53 | } 54 | 55 | 56 | #[repr(C)] 57 | #[allow(non_camel_case_types)] 58 | struct caml__roots_block { 59 | next: *mut caml__roots_block, 60 | ntables: intnat, 61 | nitems: intnat, 62 | tables: [*mut RawValue; 5] 63 | } 64 | 65 | const LOCALS_BLOCK_SIZE : usize = 8; 66 | type LocalsBlock = [Cell; LOCALS_BLOCK_SIZE]; 67 | 68 | struct Gc<'gc> { 69 | _marker: marker::PhantomData<&'gc i32> 70 | } 71 | 72 | extern { 73 | static mut caml_local_roots: *mut caml__roots_block; 74 | 75 | // fn caml_alloc(wosize: Uintnat, tag: Uintnat) -> *mut RawValue; 76 | // fn caml_alloc_small(wosize: Uintnat, tag: Uintnat) -> *mut RawValue; 77 | // fn caml_initialize(field: *mut RawValue, value: RawValue) -> (); 78 | fn caml_alloc_cell(tag: Uintnat, a: RawValue) -> RawValue; 79 | fn caml_alloc_pair(tag: Uintnat, a: RawValue, b: RawValue) -> RawValue; 80 | fn caml_alloc_string(len: usize) -> RawValue; 81 | fn caml_alloc_initialized_string(len: usize, contents: *const u8) -> RawValue; 82 | fn caml_string_length(s : RawValue) -> usize; 83 | 84 | fn caml_copy_double(f: f64) -> RawValue; 85 | fn caml_copy_int32(f: i32) -> RawValue; 86 | fn caml_copy_int64(f: i64) -> RawValue; 87 | fn caml_copy_nativeint(f: intnat) -> RawValue; 88 | } 89 | 90 | 91 | 92 | unsafe fn alloc_gc_cell<'a, 'gc>(_gc : &'a Gc<'gc>) -> &'gc Cell { 93 | let block = caml_local_roots; 94 | if ((*block).nitems as usize) < LOCALS_BLOCK_SIZE { 95 | let locals : &'gc LocalsBlock = &*((*block).tables[0] as *mut LocalsBlock); 96 | let idx = (*block).nitems; 97 | (*block).nitems = idx + 1; 98 | &locals[idx as usize] 99 | } else { 100 | panic!("not enough locals"); 101 | } 102 | } 103 | 104 | unsafe fn free_gc_cell(cell: &Cell) { 105 | let block = caml_local_roots; 106 | assert!((*block).tables[0].offset(((*block).nitems - 1) as isize) 107 | == 108 | cell.as_ptr()); 109 | (*block).nitems -= 1; 110 | } 111 | 112 | 113 | 114 | fn with_gc<'a, F>(body: F) -> RawValue 115 | where F: Fn(&mut Gc) -> RawValue { 116 | let mut gc = Gc {_marker: Default::default()}; 117 | let locals : LocalsBlock = Default::default(); 118 | unsafe { 119 | let mut block = 120 | caml__roots_block { 121 | next: caml_local_roots, 122 | ntables: 1, 123 | nitems: 0, 124 | tables: [locals[0].as_ptr(), 125 | ptr::null_mut(), 126 | ptr::null_mut(), 127 | ptr::null_mut(), 128 | ptr::null_mut()] 129 | }; 130 | caml_local_roots = &mut block; 131 | let result = body(&mut gc); 132 | assert!(caml_local_roots == &mut block); 133 | assert!(block.nitems == 0); 134 | caml_local_roots = block.next; 135 | result 136 | } 137 | } 138 | 139 | 140 | struct Val<'a, T:'a> { 141 | _marker: marker::PhantomData<&'a T>, 142 | raw: RawValue 143 | } 144 | 145 | 146 | impl<'a, T> Copy for Val<'a, T> { } 147 | 148 | impl<'a, T> Clone for Val<'a, T> { 149 | fn clone(&self) -> Val<'a, T> { 150 | Val {_marker: Default::default(), raw: self.raw} 151 | } 152 | } 153 | 154 | impl <'a, T> Val<'a, T> { 155 | unsafe fn new<'gc>(_gc: &'a Gc<'gc>, x: RawValue) -> Val<'a, T> { 156 | Val { _marker: Default::default(), raw: x } 157 | } 158 | 159 | fn eval(self) -> RawValue { self.raw } 160 | 161 | fn var<'g, 'gc>(self, gc: &'g Gc<'gc>) -> Var<'gc, T> { 162 | Var::new(gc, self) 163 | } 164 | 165 | unsafe fn field(self, i : Uintnat) -> Val<'a, F> { 166 | assert!(Tag_val(self.raw) < No_scan_tag); 167 | assert!(i < Wosize_val(self.raw)); 168 | Val { _marker: Default::default(), raw: *(self.raw as *const RawValue).offset(i as isize) } 169 | } 170 | 171 | fn is_block(self) -> bool { Is_block(self.raw) } 172 | } 173 | 174 | trait MLType { 175 | fn name() -> String; 176 | } 177 | 178 | impl MLType for String { 179 | fn name() -> String { "string".to_owned() } 180 | } 181 | 182 | impl MLType for intnat { 183 | fn name() -> String { "int".to_owned() } 184 | } 185 | 186 | struct AA {} 187 | impl MLType for AA { 188 | fn name() -> String { "'a".to_owned() } 189 | } 190 | 191 | struct BB {} 192 | impl MLType for BB { 193 | fn name() -> String { "'b".to_owned() } 194 | } 195 | 196 | struct CC {} 197 | impl MLType for CC { 198 | fn name() -> String { "'c".to_owned() } 199 | } 200 | 201 | struct DD {} 202 | impl MLType for DD { 203 | fn name() -> String { "'d".to_owned() } 204 | } 205 | 206 | struct EE {} 207 | impl MLType for EE { 208 | fn name() -> String { "'e".to_owned() } 209 | } 210 | 211 | fn type_name() -> String { 212 | T::name() 213 | } 214 | 215 | struct Pair { 216 | _a: marker::PhantomData, 217 | _b: marker::PhantomData 218 | } 219 | impl MLType for Pair { 220 | fn name() -> String { 221 | format!("({} * {})", A::name(), B::name()) 222 | } 223 | } 224 | 225 | struct List { 226 | _a: marker::PhantomData 227 | } 228 | impl MLType for List { 229 | fn name() -> String { 230 | format!("{} list", A::name()) 231 | } 232 | } 233 | 234 | struct Option { 235 | _a: marker::PhantomData 236 | } 237 | impl MLType for Option { 238 | fn name() -> String { 239 | format!("{} option", A::name()) 240 | } 241 | } 242 | 243 | enum CList<'a, A:'a + MLType> { 244 | Nil, 245 | Cons { x: Val<'a, A>, xs: Val<'a, List> } 246 | } 247 | impl <'a, A: MLType> Val<'a, List> { 248 | fn as_list(self) -> CList<'a, A> { 249 | if self.is_block() { 250 | CList::Cons { x: unsafe {self.field(0)}, xs: unsafe {self.field(1)} } 251 | } else { 252 | CList::Nil 253 | } 254 | } 255 | } 256 | 257 | impl <'a, A: MLType, B: MLType> Val<'a, Pair> { 258 | fn fst(self) -> Val<'a, A> { unsafe { self.field(0) }} 259 | fn snd(self) -> Val<'a, B> { unsafe { self.field(1) }} 260 | } 261 | 262 | impl <'a> Val<'a, String> { 263 | fn as_bytes(self) -> &'a [u8] { 264 | let s = self.raw; 265 | assert!(Tag_val(s) == String_tag); 266 | unsafe { 267 | slice::from_raw_parts(s as *const u8, caml_string_length(s)) 268 | } 269 | } 270 | fn as_str(self) -> &'a str { 271 | str::from_utf8(self.as_bytes()).unwrap() 272 | } 273 | } 274 | 275 | impl <'a> Val<'a, intnat> { 276 | fn as_int(self) -> intnat { 277 | assert!(!Is_block(self.raw)); 278 | self.raw >> 1 279 | } 280 | } 281 | 282 | 283 | 284 | fn of_int(n: i64) -> Val<'static, intnat> { 285 | Val { _marker: Default::default(), raw: (n << 1) | 1 } 286 | } 287 | 288 | 289 | 290 | /* A location registered with the GC */ 291 | struct Var<'a, T> { 292 | cell: &'a Cell, 293 | _marker: marker::PhantomData> 294 | } 295 | 296 | impl <'a, T> Var<'a, T> { 297 | fn new<'gc, 'tmp>(gc : &'a Gc<'gc>, x : Val<'tmp, T>) -> Var<'gc, T> { 298 | let cell : &'gc Cell = unsafe { alloc_gc_cell(gc) }; 299 | cell.set(x.eval()); 300 | Var { _marker: Default::default(), cell: cell } 301 | } 302 | fn set<'gc, 'tmp>(&mut self, x: Val<'tmp, T>) { 303 | self.cell.set(x.eval()); 304 | } 305 | fn get<'gc, 'tmp>(&'a self, _gc: &'tmp Gc<'gc>) -> Val<'tmp, T> { 306 | Val { _marker: Default::default(), raw: self.cell.get() } 307 | } 308 | } 309 | 310 | impl <'a, T> Drop for Var<'a, T> { 311 | fn drop(&mut self) { 312 | unsafe{ free_gc_cell(self.cell) } 313 | } 314 | } 315 | 316 | struct GCResult1 { 317 | raw: RawValue, 318 | _marker: marker::PhantomData 319 | } 320 | 321 | struct GCResult2 { 322 | raw: RawValue, 323 | _marker: marker::PhantomData 324 | } 325 | 326 | impl GCResult1 { 327 | fn of(raw: RawValue) -> GCResult1 { GCResult1 { _marker: Default::default(), raw: raw }} 328 | fn mark<'gc>(self, _gc: &mut Gc<'gc>) -> GCResult2 { 329 | GCResult2 { _marker: Default::default(), raw: self.raw } 330 | } 331 | } 332 | impl GCResult2 { 333 | fn eval<'a, 'gc: 'a>(self, _gc: &'a Gc<'gc>) -> Val<'a, T> { 334 | Val {_marker: Default::default(), raw: self.raw} 335 | } 336 | } 337 | 338 | struct GCtoken {} 339 | 340 | fn alloc_pair<'a,A: MLType,B: MLType>(_token: GCtoken, tag: Uintnat, a: Val<'a, A>, b: Val<'a, B>) -> GCResult1> { 341 | GCResult1::of(unsafe{caml_alloc_pair(tag, a.eval(), b.eval())}) 342 | } 343 | 344 | fn none(_token: GCtoken) -> GCResult1> { 345 | GCResult1::of(1) 346 | } 347 | 348 | fn alloc_some<'a,A:MLType>(_token: GCtoken, a: Val<'a,A>) -> GCResult1> { 349 | GCResult1::of(unsafe{caml_alloc_cell(0, a.eval())}) 350 | } 351 | 352 | fn alloc_blank_string(_token: GCtoken, len: usize) -> GCResult1 { 353 | GCResult1::of(unsafe{ caml_alloc_string(len) }) 354 | } 355 | 356 | fn alloc_bytes(token: GCtoken, s: &[u8]) -> GCResult1 { 357 | let r = alloc_blank_string(token, s.len()); 358 | unsafe { ptr::copy_nonoverlapping(s.as_ptr(), r.raw as *mut u8, s.len()); } 359 | r 360 | } 361 | 362 | fn alloc_string(token: GCtoken, s: &str) -> GCResult1 { 363 | let r = alloc_blank_string(token, s.len()); 364 | unsafe { ptr::copy_nonoverlapping(s.as_ptr(), r.raw as *mut u8, s.len()); } 365 | r 366 | } 367 | 368 | 369 | macro_rules! call { 370 | { 371 | $fn:ident 372 | ( $gc:ident, $( $arg:expr ),* ) 373 | } => {{ 374 | let res = $fn( GCtoken {}, $( $arg ),* ); 375 | res.mark($gc).eval($gc) 376 | }} 377 | } 378 | 379 | macro_rules! camlmod { 380 | { 381 | $( 382 | fn $name:ident( $gc:ident, $($arg:ident : $ty:ty),* ) -> $res:ty $body:block 383 | )* 384 | } => { 385 | $( 386 | #[no_mangle] 387 | pub extern fn $name( $($arg: RawValue), *) -> RawValue { 388 | with_gc(|$gc| { 389 | $( 390 | let $arg : Val<$ty> = unsafe { Val::new($gc, $arg) }; 391 | );* 392 | let retval : Val<$res> = $body; 393 | retval.raw 394 | }) 395 | } 396 | )* 397 | 398 | #[no_mangle] 399 | pub extern fn print_module(_unused: RawValue) -> RawValue { 400 | $( 401 | { 402 | let mut s = "".to_owned(); 403 | $( 404 | s.push_str(&type_name::<$ty>()); 405 | s.push_str(" -> "); 406 | )* 407 | s.push_str(&type_name::<$res>()); 408 | print!("external {} : {} = \"{}\"\n", 409 | stringify!($name), 410 | s, 411 | stringify!($name)); 412 | } 413 | )* 414 | io::stdout().flush().unwrap(); 415 | 1 416 | } 417 | }; 418 | } 419 | 420 | camlmod!{ 421 | fn tostring(gc, p: Pair) -> String { 422 | let pv = p.var(gc); 423 | let msg = format!("str: {}, int: {}", 424 | p.fst().as_str(), 425 | p.snd().as_int()); 426 | let ret = call!{ alloc_string(gc, &msg) }; 427 | 428 | let _msg2 = format!("str: {}", pv.get(gc).fst().as_str()); 429 | ret 430 | } 431 | 432 | fn mkpair(gc, x: AA, y: BB) -> Pair { 433 | let pair = call!{ alloc_pair(gc, 0, x, y)}; 434 | pair 435 | } 436 | 437 | fn strtail(gc, x: String) -> Option { 438 | let b = x.as_bytes(); 439 | if b.is_empty() { 440 | call!{ none(gc, ) } 441 | } else { 442 | call!{ alloc_some(gc, call!{alloc_bytes(gc, &b[1..])}) } 443 | } 444 | } 445 | 446 | fn somestr(gc, x: intnat) -> Option { 447 | let s = x.as_int().to_string(); 448 | let cell = call!{ alloc_some(gc, call!{alloc_string(gc, &s)} ) }; 449 | // let cell2 = call!{ alloc_some(gc, call!{alloc_string(gc, &s)} ) }; 450 | cell 451 | } 452 | 453 | fn triple(gc, x: AA) -> Pair> { 454 | let vx = x.var(gc); 455 | let snd = call!{alloc_pair(gc, 0, x, x)}; 456 | call!{ alloc_pair(gc, 0, vx.get(gc), snd) } 457 | } 458 | } 459 | --------------------------------------------------------------------------------