Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Fixed forking so that arguments are reduced before forking the call. …

…Marshaling added.
  • Loading branch information...
commit 6ad5a4b618aa8a885621525e2126d1d902747042 1 parent 63cf404
@massung authored
View
2  cell.ml
@@ -62,6 +62,7 @@ and term =
| Jmp of int
| Jmp_if of int
| Call of int
+ | Fork of int
| For of int
| Comp of int
| Get of Atom.t
@@ -97,7 +98,6 @@ and term =
| Assign
| To
| Downto
- | Fork
| Yield
| Ret
View
6 compile.ml
@@ -156,6 +156,9 @@ let local p =
(* apply a block with a fixed set of arguments *)
let call term n = term >> asm (Call n)
+(* change a call to a block that's forked *)
+let fork term n = term >> asm (Fork n)
+
(* apply nothing to a block closure over and over again *)
let forever b =
let compile s =
@@ -190,9 +193,6 @@ let block locals terms =
in
get >>= compile >>= asm
-(* change a call to a block that's forked *)
-let fork call = block nop call >> asm Fork
-
(* for loop *)
let for_loop locals cond terms n =
if (List.length locals) <> n
View
10 core.ml
@@ -25,6 +25,14 @@ let prim_chan = function
| [] -> Channel (Mvar.create ())
| _ -> raise Arity_mismatch
+let prim_marshal = function
+ | [x] -> Binary (Marshal.to_string x [Marshal.Closures])
+ | _ -> raise Arity_mismatch
+
+let prim_unmarshal = function
+ | [x] -> Marshal.from_string (binary_of_cell x) 0
+ | _ -> raise Arity_mismatch
+
let prim_puts = function
| [x] -> (print_endline (binary_of_cell x); Unit)
| _ -> raise Arity_mismatch
@@ -32,5 +40,7 @@ let prim_puts = function
(* core package that all packages get *)
let prims =
[ ("chan", prim_chan)
+ ; ("marshal", prim_marshal)
+ ; ("unmarshal", prim_unmarshal)
; ("puts", prim_puts)
]
View
2  debug.ml
@@ -41,6 +41,7 @@ let rec see terms n =
| Jmp d -> Printf.sprintf "jmp #%04x" (k+d+1)
| Jmp_if d -> Printf.sprintf "jmp_if #%04x" (k+d+1)
| Call n -> Printf.sprintf "call %d" n
+ | Fork n -> Printf.sprintf "fork %d" n
| For n -> Printf.sprintf "for %d" n
| Comp n -> Printf.sprintf "comp list %d" n
| Get m -> Printf.sprintf "get %s" m.Atom.name
@@ -76,7 +77,6 @@ let rec see terms n =
| Deref -> "deref"
| Mkref -> "mkref"
| Assign -> "setref"
- | Fork -> "fork"
| Yield -> "yield"
| Ret -> "ret"
in
View
22 interp.ml
@@ -45,19 +45,10 @@ let new_thread stack_size =
(* interpret a block in a thread *)
let rec run_thread st f =
try
- let arity n = if n <> 0 then raise Arity_mismatch in
- let result = match f with
- | Block f -> (arity f.argc; interp st f.terms)
- | Native f -> (f [])
- in
- Mvar.put st.status (Completed result)
+ f ();
+ Mvar.put st.status (Completed (Vector.pop st.stack))
with err -> Mvar.put st.status (Terminated err)
-(* create a new thread to execute terms in *)
-and fork_thread st f =
- let st' = { st with status=Mvar.create (); stack=Vector.make 16 Unit } in
- Thread.create (run_thread st') f
-
(* loop forever, yielding every few instructions *)
and interp st terms =
let ip = ref 0 in
@@ -74,6 +65,7 @@ and interp st terms =
| Push_block (n,ts) -> push_block st n ts
| Local n -> push_local st n
| Call n -> call st n
+ | Fork n -> fork st n
| For n -> do_for st n
| Comp n -> do_list_comp st n
| Jmp n -> ip := !ip + n
@@ -111,7 +103,6 @@ and interp st terms =
| Mkref -> mkref st
| Deref -> deref st
| Assign -> setref st
- | Fork -> fork st
| Yield -> yield st
| Ret -> raise Return
end;
@@ -141,8 +132,11 @@ and apply_closure st n f =
interp { st with frame=frame } f.terms
(* create a new process *)
-and fork st =
- ignore (fork_thread st (proc_of_cell (Vector.pop st.stack)));
+and fork st n =
+ let s = Vector.pop_array st.stack (n+1) in
+ let stack = Vector.of_array s Unit in
+ let st' = { st with status=Mvar.create (); stack=stack } in
+ ignore (Thread.create (call st') n);
Vector.push Unit st.stack
(* relinquish control to other threads *)
View
4 lexer.mll
@@ -98,7 +98,7 @@ let comment = ';' [^ '\n']*
(* identifiers and operators *)
let id = ['a'-'z'] ['a'-'z' 'A'-'Z' '0'-'9' '_']*
let atom = ['A'-'Z'] ['a'-'z' 'A'-'Z' '0'-'9' '_']*
-let op = ['=' '<' '>' '+' '-' '*' '/' '&' '%' '^' '~']+
+let op = ['=' '<' '>' '+' '-' '*' '/' '&' '%' '^' '~']
(* sign and base-10 digits *)
let sign = ['-' '+']
@@ -145,7 +145,7 @@ rule read_token = parse
| ':' '=' { SET }
(* reserved operators *)
- | op as op { operator_of_lexeme op }
+ | op op? as op { operator_of_lexeme op }
(* setter words *)
| (id as m) ':' (id as f) { MODFUN (m,f) }
View
6 parser.mly
@@ -150,7 +150,7 @@ terms:
term:
| IF expr THEN expr ELSE expr { either $2 $4 $6 }
| BLOCK terms END_BLOCK { $2 }
- | FORK call { fork $2 }
+ | FORK fork { $2 }
| for_loop { $1 }
| expr { $1 }
@@ -220,6 +220,10 @@ call:
| postfix PAREN exprs END_PAREN { expr_list $3 (call $1) }
| postfix PAREN END_PAREN { call $1 0 }
+fork:
+ | postfix PAREN exprs END_PAREN { expr_list $3 (fork $1) }
+ | postfix PAREN END_PAREN { fork $1 0 }
+
primary:
| MODFUN { modfun $1 }
| IDENT { load $1 }
View
5 test.fc
@@ -69,3 +69,8 @@ let cons_test_1 = [1,2,3|[A,B,C]]
let cons_test_2 = [1|[]]
let cons_test_3 = let xs = [4,5,6] in [Hello|xs]
+;; marshaling test
+let term = fun msg { puts(msg) }
+let binary_term = marshal(term)
+let new_term = unmarshal(binary_term)
+let test_term = new_term("marshal test worked!")
View
7 vector.ml
@@ -34,6 +34,13 @@ let make n x =
; len=0
}
+(* create a new vector from an array *)
+let of_array arr fill =
+ { fill=fill
+ ; arr=arr
+ ; len=Array.length arr
+ }
+
(* return the length of the vector *)
let length v = v.len
Please sign in to comment.
Something went wrong with that request. Please try again.