-
Notifications
You must be signed in to change notification settings - Fork 30
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
* reml binary and cleanup
- Loading branch information
Showing
44 changed files
with
1,441 additions
and
702 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,78 @@ | ||
| structure ForkJoin :> FORK_JOIN = struct | ||
|
|
||
| fun alloc (n:int) (v:'a) : 'a array = | ||
| prim ("word_table0", n) | ||
|
|
||
| local | ||
|
|
||
| fun alloc_unsafe (n:int) : 'a array = | ||
| prim ("word_table0", n) | ||
|
|
||
| structure T = Thread | ||
|
|
||
| fun for (lo,hi) (f:int->unit) : unit = | ||
| let fun loop i = | ||
| if i >= hi then () | ||
| else (f i; loop (i+1)) | ||
| in loop lo | ||
| end | ||
| in | ||
| fun parfor `e (X:int) (lo:int,hi:int) (f: int #e -> unit) : unit while noput e = | ||
| if lo >= hi then () | ||
| else let val m = lo+X | ||
| in if m >= hi (* last bucket *) | ||
| then for (lo,hi) f | ||
| else T.spawn (fn () => for (lo,m) f) | ||
| (fn _ => parfor X (m,hi) f) | ||
| end | ||
|
|
||
| fun pmap `[e] (f:'a #e ->'b) : ('a list -> 'b list) while noput e = | ||
| fn (xs:'a list) => | ||
| let val v = Vector.fromList xs | ||
| val sz = Vector.length v | ||
| val a : 'b Array.array = alloc_unsafe sz | ||
| in parfor 1000 (0,sz) (fn i => Array.update(a,i,f(Vector.sub(v,i)))) | ||
| ; Array.foldr (op ::) nil a | ||
| end | ||
|
|
||
| fun par `[e1 e2] (f: unit #e1 -> 'a, g: unit #e2 -> 'b) : 'a * 'b while e1 ## e2 = | ||
| let val a1 : 'a array = alloc_unsafe 1 | ||
| val b1 : 'b array = alloc_unsafe 1 | ||
| in T.spawn (fn () => Array.update(b1,0,g())) (fn _ => (Array.update(a1,0,f()))) | ||
| ; (Array.sub(a1,0), Array.sub(b1,0)) | ||
| end | ||
|
|
||
| fun pair `[e1 e2] (f: 'a #e1 -> 'b, g: 'c #e2 -> 'd) (x:'a,y:'c) : 'b * 'd while e1 ## e2 = | ||
| par (fn () => f x, fn () => g y) | ||
|
|
||
| type gcs = int * int (* max parallelism, min sequential work *) | ||
|
|
||
| val rec parfor'__noinline `[e] : (int*int #e-> unit) -> gcs -> int*int -> unit while noput e = | ||
| fn doit => fn (P,G) => fn (lo,hi) => | ||
| if hi-lo <= 0 then () else | ||
| let val n = hi-lo | ||
| val m = Int.min(P+1, 1 + (n-1) div G) (* blocks *) | ||
| val k = n div m (* block size *) | ||
| val v = Vector.tabulate(m, fn i => | ||
| let val first = i*k | ||
| val next = first+k | ||
| in (first, | ||
| if next > hi then hi else next) | ||
| end) | ||
| fun loop n = | ||
| if n >= m-1 then doit (Vector.sub(v,n)) | ||
| else T.spawn (fn () => doit (Vector.sub(v,n))) | ||
| (fn _ => loop (n+1)) | ||
| in loop 0 | ||
| end | ||
|
|
||
| val rec parfor' `[e] : gcs -> int*int -> (int #e -> unit) -> unit while noput e = | ||
| fn gcs => fn (lo,hi) => fn f => | ||
| let fun doit (lo,hi) = for (lo,hi) f | ||
| in parfor'__noinline doit gcs (lo,hi) | ||
| end | ||
|
|
||
| val parfor' = parfor' | ||
|
|
||
| end | ||
| end |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,56 @@ | ||
| structure Thread :> THREAD = struct | ||
| type thread = foreignptr | ||
| type 'a t0 = ((unit->'a) * thread) ref | ||
| fun get__noinline ((ref (f,t0)): 'a t0) : 'a = prim("thread_get", t0) | ||
| fun spawn__noinline `[e1 e2] (f: unit #e1 -> 'a) (k: 'a t0 #e2 -> 'b) : 'b while e1 ## e2 = | ||
| let val rf : (unit -> 'a) ref = ref f | ||
| val fp_f : foreignptr = prim("pointer", !rf) | ||
|
|
||
| (* From a region inference perspective, coercing the type of | ||
| * a function to a pointer type is very unsafe, as the | ||
| * pointer type contains no information about which regions | ||
| * need to be kept alive for the pointer value to be | ||
| * valid. By including the type of the function in the type | ||
| * of the thread value, however, we keep all necessary | ||
| * regions alive. | ||
| * | ||
| * Moreover, we encapsulate the function in a ref to avoid | ||
| * that the closure is inlined into the "pointer" prim | ||
| * argument. If it is inlined, the closure will be allocated | ||
| * in a local stack-allocated region inside the "pointer" | ||
| * prim value, which cause the program to segfault.. *) | ||
|
|
||
| val t0 : thread = prim("spawnone", fp_f) | ||
| val t: 'a t0 = ref (f,t0) | ||
|
|
||
| fun force () = | ||
| if !(ref true) (* make sure the thread has terminated before returning *) | ||
| then get__noinline t (* and mimic that, from a type perspective, spawn has *) | ||
| else !rf() (* the effect of calling f *) | ||
|
|
||
| val res = k t handle e => (force(); raise e) | ||
| val _ = force () | ||
|
|
||
| (* Notice that it is not safe to call `thread_free t0` here | ||
| * as t0 may be live through later calls to `get t`. | ||
| * | ||
| * What is needed is for the ThreadInfo structs to be region | ||
| * allocated and to add finalisers (thread_free) to objects | ||
| * in these regions. Technically, the thread is detached | ||
| * already in the thread_get function. However, the mutex | ||
| * and the ThreadInfo struct is kept live. | ||
| *) | ||
| in res | ||
| end | ||
|
|
||
| type 'a t = 'a t0 | ||
|
|
||
| fun spawn `[e1 e2] (f: unit #e1 ->'a) (k: 'a t #e2 -> 'b) : 'b while e1 ## e2 = | ||
| spawn__noinline f k | ||
|
|
||
| fun get (x:'a t) : 'a = | ||
| get__noinline x | ||
|
|
||
| fun numCores () : int = | ||
| prim("numCores",()) | ||
| end |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,10 @@ | ||
| local | ||
| basis.mlb | ||
| in | ||
| THREAD.sig | ||
| ThreadSeq.sml | ||
| Thread-reml.sml | ||
| FORK_JOIN.sig | ||
| ForkJoinSeq.sml | ||
| ForkJoin-reml.sml | ||
| end |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
|
|
@@ -4,4 +4,5 @@ mlkit-mllex.1 | |
| mlkit-mlyacc.1 | ||
| smltojs.1 | ||
| mlkit.1 | ||
| reml.1 | ||
| rp2ps.1 | ||
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
|
|
@@ -2,6 +2,7 @@ Makefile | |
| Version.sml | ||
| config.h | ||
| mlkit | ||
| reml | ||
| smltojs | ||
| smlserverc | ||
| MLB | ||
|
|
||
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.