[MLton] Mzton an MzScheme<->MLton FFI
Jens Axel Søgaard
jensaxel@soegaard.net
Tue, 20 Sep 2005 19:53:40 +0200
This is a multi-part message in MIME format.
--------------060904090605020203000509
Content-Type: text/plain; charset=ISO-8859-1; format=flowed
Content-Transfer-Encoding: 8bit
Matthew Fluet wrote:
>
>> The work I have done has been on the Scheme side, so I have
>> no changes to Fluet's patch from
>>
>> <http://mlton.org/pipermail/mlton/2005-July/027603.html>
>>
>> which has worked fine for me - I hope it will be included
>> in svn version?
>
> It wouldn't be hard to push it into the SVN HEAD, but I seem to recall a
> few outstanding issues that need to be tracked down.
You mentioned in
<http://mlton.org/pipermail/mlton/2005-July/027541.html>
an assertion failure, when "-debug true" is used to compile the
shared library.
> Also, you'll need to remind us of the extra flags that need to be passed
> to gcc (when invoked as a linker) to produce a shared library.
I have this in build-test.sh on Linux
/home/js/mzton/mlton-shared/mlton/build/bin/mlton\
-export-header exported.h \
-shared-library true \
-cc-opt "-symbolic -shared -fPIC"\
-link-opt "-shared -Bsymbolic"\
-codegen c -default-ann 'allowFFI true' -keep g -verbose 1\
-link-opt --verbose -link-opt -Wl,-Bsymbolic test.cm
(the -symbolic flag is ignored by Linux, but is needed on FreeBSD)
and in test.cm I have
Group is
roots.sml
test.sml
Here roots.sml (which is attached) contains various support functions.
>> Today I got callbacks working, which were the last major piece
>> missing. To give an impression of what the FFI can, I have attached an
>> example from the documentation.
>
>> The type of this function is int*int -> real array so to export it,
>> one writes
>>
>> val _ = _export "makeUnitVec" : ( int*int -> real array ) -> unit;
>> (RealArrayRoot.return o makeUnitVec);
>>
>> The important thing to note here is that we are not exporting
>> makeUnitVec, but (RealArrayRoot.return o makeUnitVec). The function
>> RealArrayRoot.return is nothing but the identity function, but it has
>> the side effect of registering the returned array with the MLton
>> garbage collector. When the Scheme object representing the returned ML
>> array is garbage collected, the Scheme garbage collector will
>> automatically tell the MLton garbage collector that the array has
>> become garbage.
>
> Can you say anything more about this? How are the two garbage
> collectors communicating information? Also, there is nothing that
> ensures that the returned ML array isn't moved by a subsequent ML
> garbage collection, which may invalidate Scheme functions that hold onto
> the array.
Each root (array, vector or reference), which is returned to the Scheme
side is given an id number. For each combination of a compound
constructor (array, vector and ref) with a base type (int, real, ...)
I have a data structure (at the moment I am using a splay map) that
associates id numbers with roots. As long as the root is in the data
structure the ML garbage collector will hold on to the value. Since
MLton uses a moving garbage collector, the Scheme side have to look
up the current address of the root each time it need to use it.
The ML code for registering roots is as follows:
(* The various root types shares the id counter *)
val curRootId = ref 0;
fun getCurrentRootId () = !curRootId;
val _ = _export "getCurrentRootId" :
(unit -> int) -> unit; getCurrentRootId;
fun getNextRoot () = ( curRootId := !curRootId+1 ; !curRootId);
signature ROOT_TYPE = sig type t end
signature ROOT =
sig
type t
exception RootNotFound;
val get: int -> t (* get root given root number *)
val reg: t -> int (* register and return root number *)
val return: t -> t (* register and return root *)
val unreg: int -> unit (* unregister root *)
end
functor Root (R: ROOT_TYPE): ROOT =
struct
type t = R.t;
exception RootNotFound;
structure RootMap = SplayMapFn(struct
type ord_key = int;
val compare = Int.compare
end);
val roots = ref RootMap.empty;
val reg = fn r => ( roots := RootMap.insert (!roots, getNextRoot (), r)
; getCurrentRootId ());
val get = fn i => case RootMap.find (!roots, i)
of NONE => raise RootNotFound
| SOME r => r;
val return =
fn r => ( roots := RootMap.insert (!roots, getNextRoot (), r)
; r);
val unreg = fn i => roots := (case RootMap.remove (!roots, i)
of (rs,_) => rs);
end
Then for each combination of constructor and base type "get" and
"unreg" is exported.
structure RealArrayRoot = Root(struct type t = real array end);
val _ = _export "getRealArray":
(int -> real array) -> unit; RealArrayRoot.get;
val _ = _export "unregRealArray" :
(int -> unit) -> unit; RealArrayRoot.unreg;
At the Scheme side roots are represented as a vector (for now) with four
entries: the id number, the imported functions get and unreg for that
particular root type and finally a value representing the base type,
which is used for type checking at the Scheme side. To get the c-pointer
corresponding to a root value, one calls:
(define (root->val r)
((root-get r) (root-id r)))
When the Scheme object representing an ML value is garbage collected,
the ML value must be unregistered at the ML side. This is done by
registering the root value with a will executor.
(define ml-will-executor (make-will-executor))
The will-executor needs to run in a separate thread:
(define will-thread (thread (lambda ()
(let loop ()
(will-execute ml-will-executor)
(loop)))))
When the FFI is to make a new root, it's will will unregister it
at the ML side:
(let ([root (make-root (get-current-root-id)
base-compound-get
base-compound-unreg
$base)])
; make sure the Scheme garbage collector will unregister the root
(ml-will-register ml-will-executor
root
(lambda (r) ((root-unreg r) (root-id r))))
root)
The extra deallocation thread complicates matters a little though.
Since there is a risk that an execution of a will will trigger an
ML garbage collection (since unreg is called), we need to make sure
that no wills are executed between the time the main thread obtains
a c-pointer to, say, an array and the time it uses the c-pointer.
This is handled by adding a semaphore to the equation:
(define semaphore-for-critical-region (make-semaphore 1))
A little macro makes sure we can write (critical-region ...)
without worrying about semaphore details.
(define-syntax will-critical-region
(syntax-rules ()
((critical-region body ...)
(begin
(semaphore-wait semaphore-for-critical-region)
(begin0
(begin body ...)
(semaphore-post semaphore-for-critical-region))))))
An usage example:
; ml-raw-array-length : pointer -> integer
; return the length of an raw (as opposed to rooted)
; array returned from mlton
(define (ml-raw-array-length cpointer-to-array)
; see GC_arrayNumElementsp in gc.h
(ptr-ref cpointer-to-array _uint -2))
; ml-array-length : rooted-array -> integer
(define (ml-array-length rooted-array)
(unless (root? rooted-array)
(error "rooted array expected, got " rooted-array))
(critical-region
(ml-raw-array-length (root->val rooted-array))))
I have attached something to test.
sh build-test.sh
will build the shared library, and
mzscheme -M errortrace -f test.ss
will import and test it.
--
Jens Axel Søgaard
--------------060904090605020203000509
Content-Type: text/plain;
name="roots.sml"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="roots.sml"
(* lib-base-sig.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
*)
signature LIB_BASE =
sig
exception Unimplemented of string
(* raised to report unimplemented features *)
exception Impossible of string
(* raised to report internal errors *)
exception NotFound
(* raised by searching operations *)
val failure : {module : string, func : string, msg : string} -> 'a
(* raise the exception Fail with a standard format message. *)
val version : {date : string, system : string, version_id : int list}
val banner : string
end (* LIB_BASE *)
(* lib-base.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
*)
structure LibBase : LIB_BASE =
struct
(* raised to report unimplemented features *)
exception Unimplemented of string
(* raised to report internal errors *)
exception Impossible of string
(* raised by searching operations *)
exception NotFound
(* raise the exception Fail with a standard format message. *)
fun failure {module, func, msg} =
raise (Fail(concat[module, ".", func, ": ", msg]))
val version = {
date = "June 1, 1996",
system = "SML/NJ Library",
version_id = [1, 0]
}
fun f ([], l) = l
| f ([x : int], l) = (Int.toString x)::l
| f (x::r, l) = (Int.toString x) :: "." :: f(r, l)
val banner = concat (
#system version :: ", Version " ::
f (#version_id version, [", ", #date version]))
end (* LibBase *)
(* splaytree-sig.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
*
* Signature for a splay tree data structure.
*
*)
signature SPLAY_TREE =
sig
datatype 'a splay =
SplayObj of {
value : 'a,
right : 'a splay,
left : 'a splay
}
| SplayNil
val splay : (('a -> order) * 'a splay) -> (order * 'a splay)
(* (r,tree') = splay (cmp,tree)
* where tree' is tree adjusted using the comparison function cmp
* and, if tree' = SplayObj{value,...}, r = cmp value.
* tree' = SplayNil iff tree = SplayNil, in which case r is undefined.
*)
val join : 'a splay * 'a splay -> 'a splay
(* join(t,t') returns a new splay tree formed of t and t'
*)
end (* SPLAY_TREE *)
(* ord-key-sig.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
*
* Abstract linearly ordered keys.
*
*)
signature ORD_KEY =
sig
type ord_key
val compare : ord_key * ord_key -> order
end (* ORD_KEY *)
(* ord-map-sig.sml
*
* COPYRIGHT (c) 1996 by AT&T Research. See COPYRIGHT file for details.
*
* Abstract signature of an applicative-style finite maps (dictionaries)
* structure over ordered monomorphic keys.
*)
signature ORD_MAP =
sig
structure Key : ORD_KEY
type 'a map
val empty : 'a map
(* The empty map *)
val insert : 'a map * Key.ord_key * 'a -> 'a map
val insert' : ((Key.ord_key * 'a) * 'a map) -> 'a map
(* Insert an item. *)
val find : 'a map * Key.ord_key -> 'a option
(* Look for an item, return NONE if the item doesn't exist *)
val remove : 'a map * Key.ord_key -> 'a map * 'a
(* Remove an item, returning new map and value removed.
* Raises LibBase.NotFound if not found.
*)
val numItems : 'a map -> int
(* Return the number of items in the map *)
val listItems : 'a map -> 'a list
val listItemsi : 'a map -> (Key.ord_key * 'a) list
(* Return an ordered list of the items (and their keys) in the map.
*)
val collate : ('a * 'a -> order) -> ('a map * 'a map) -> order
(* given an ordering on the map's range, return an ordering
* on the map.
*)
val unionWith : ('a * 'a -> 'a) -> ('a map * 'a map) -> 'a map
val unionWithi : (Key.ord_key * 'a * 'a -> 'a) -> ('a map * 'a map) -> 'a map
(* return a map whose domain is the union of the domains of the two input
* maps, using the supplied function to define the map on elements that
* are in both domains.
*)
val intersectWith : ('a * 'b -> 'c) -> ('a map * 'b map) -> 'c map
val intersectWithi : (Key.ord_key * 'a * 'b -> 'c) -> ('a map * 'b map) -> 'c map
(* return a map whose domain is the intersection of the domains of the
* two input maps, using the supplied function to define the range.
*)
val app : ('a -> unit) -> 'a map -> unit
val appi : ((Key.ord_key * 'a) -> unit) -> 'a map -> unit
(* Apply a function to the entries of the map in map order. *)
val map : ('a -> 'b) -> 'a map -> 'b map
val mapi : (Key.ord_key * 'a -> 'b) -> 'a map -> 'b map
(* Create a new map by applying a map function to the
* name/value pairs in the map.
*)
val foldl : ('a * 'b -> 'b) -> 'b -> 'a map -> 'b
val foldli : (Key.ord_key * 'a * 'b -> 'b) -> 'b -> 'a map -> 'b
(* Apply a folding function to the entries of the map
* in increasing map order.
*)
val foldr : ('a * 'b -> 'b) -> 'b -> 'a map -> 'b
val foldri : (Key.ord_key * 'a * 'b -> 'b) -> 'b -> 'a map -> 'b
(* Apply a folding function to the entries of the map
* in decreasing map order.
*)
val filter : ('a -> bool) -> 'a map -> 'a map
val filteri : (Key.ord_key * 'a -> bool) -> 'a map -> 'a map
(* Filter out those elements of the map that do not satisfy the
* predicate. The filtering is done in increasing map order.
*)
val mapPartial : ('a -> 'b option) -> 'a map -> 'b map
val mapPartiali : (Key.ord_key * 'a -> 'b option) -> 'a map -> 'b map
(* map a partial function over the elements of a map in increasing
* map order.
*)
end (* ORD_MAP *)
(* ordset-sig.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
*
* Signature for a set of values with an order relation.
*)
signature ORD_SET =
sig
structure Key : ORD_KEY
type item = Key.ord_key
type set
val empty : set
(* The empty set *)
val singleton : item -> set
(* Create a singleton set *)
val add : set * item -> set
val add' : (item * set) -> set
(* Insert an item. *)
val addList : set * item list -> set
(* Insert items from list. *)
val delete : set * item -> set
(* Remove an item. Raise NotFound if not found. *)
val member : set * item -> bool
(* Return true if and only if item is an element in the set *)
val isEmpty : set -> bool
(* Return true if and only if the set is empty *)
val equal : (set * set) -> bool
(* Return true if and only if the two sets are equal *)
val compare : (set * set) -> order
(* does a lexical comparison of two sets *)
val isSubset : (set * set) -> bool
(* Return true if and only if the first set is a subset of the second *)
val numItems : set -> int
(* Return the number of items in the table *)
val listItems : set -> item list
(* Return an ordered list of the items in the set *)
val union : set * set -> set
(* Union *)
val intersection : set * set -> set
(* Intersection *)
val difference : set * set -> set
(* Difference *)
val map : (item -> item) -> set -> set
(* Create a new set by applying a map function to the elements
* of the set.
*)
val app : (item -> unit) -> set -> unit
(* Apply a function to the entries of the set
* in decreasing order
*)
val foldl : (item * 'b -> 'b) -> 'b -> set -> 'b
(* Apply a folding function to the entries of the set
* in increasing order
*)
val foldr : (item * 'b -> 'b) -> 'b -> set -> 'b
(* Apply a folding function to the entries of the set
* in decreasing order
*)
val filter : (item -> bool) -> set -> set
val exists : (item -> bool) -> set -> bool
val find : (item -> bool) -> set -> item option
end (* ORD_SET *)
(* splaytree.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
*
* Splay tree structure.
*
*)
structure SplayTree : SPLAY_TREE =
struct
datatype 'a splay =
SplayObj of {
value : 'a,
right : 'a splay,
left : 'a splay
}
| SplayNil
datatype 'a ans_t = No | Eq of 'a | Lt of 'a | Gt of 'a
fun splay (compf, root) = let
fun adj SplayNil = (No,SplayNil,SplayNil)
| adj (arg as SplayObj{value,left,right}) =
(case compf value of
EQUAL => (Eq value, left, right)
| GREATER =>
(case left of
SplayNil => (Gt value,SplayNil,right)
| SplayObj{value=value',left=left',right=right'} =>
(case compf value' of
EQUAL => (Eq value',left',
SplayObj{value=value,left=right',right=right})
| GREATER =>
(case left' of
SplayNil => (Gt value',left',SplayObj{value=value,left=right',right=right})
| _ =>
let val (V,L,R) = adj left'
val rchild = SplayObj{value=value,left=right',right=right}
in
(V,L,SplayObj{value=value',left=R,right=rchild})
end
) (* end case *)
| _ =>
(case right' of
SplayNil => (Lt value',left',SplayObj{value=value,left=right',right=right})
| _ =>
let val (V,L,R) = adj right'
val rchild = SplayObj{value=value,left=R,right=right}
val lchild = SplayObj{value=value',left=left',right=L}
in
(V,lchild,rchild)
end
) (* end case *)
) (* end case *)
) (* end case *)
| _ =>
(case right of
SplayNil => (Lt value,left,SplayNil)
| SplayObj{value=value',left=left',right=right'} =>
(case compf value' of
EQUAL =>
(Eq value',SplayObj{value=value,left=left,right=left'},right')
| LESS =>
(case right' of
SplayNil => (Lt value',SplayObj{value=value,left=left,right=left'},right')
| _ =>
let val (V,L,R) = adj right'
val lchild = SplayObj{value=value,left=left,right=left'}
in
(V,SplayObj{value=value',left=lchild,right=L},R)
end
) (* end case *)
| _ =>
(case left' of
SplayNil => (Gt value',SplayObj{value=value,left=left,right=left'},right')
| _ =>
let val (V,L,R) = adj left'
val rchild = SplayObj{value=value',left=R,right=right'}
val lchild = SplayObj{value=value,left=left,right=L}
in
(V,lchild,rchild)
end
) (* end case *)
) (* end case *)
) (* end case *)
) (* end case *)
in
case adj root of
(No,_,_) => (GREATER,SplayNil)
| (Eq v,l,r) => (EQUAL,SplayObj{value=v,left=l,right=r})
| (Lt v,l,r) => (LESS,SplayObj{value=v,left=l,right=r})
| (Gt v,l,r) => (GREATER,SplayObj{value=v,left=l,right=r})
end
fun lrotate SplayNil = SplayNil
| lrotate (arg as SplayObj{value,left,right=SplayNil}) = arg
| lrotate (SplayObj{value,left,right=SplayObj{value=v,left=l,right=r}}) =
lrotate (SplayObj{value=v,left=SplayObj{value=value,left=left,right=l},right=r})
fun join (SplayNil,SplayNil) = SplayNil
| join (SplayNil,t) = t
| join (t,SplayNil) = t
| join (l,r) =
case lrotate l of
SplayNil => r (* impossible as l is not SplayNil *)
| SplayObj{value,left,right} => SplayObj{value=value,left=left,right=r}
end (* SplayTree *)
(* splay-set-fn.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
*
* Functor implementing ordered sets using splay trees.
*
*)
functor SplaySetFn (K : ORD_KEY) : ORD_SET =
struct
structure Key = K
open SplayTree
type item = K.ord_key
datatype set =
EMPTY
| SET of {
root : item splay ref,
nobj : int
}
fun cmpf k = fn k' => K.compare(k',k)
val empty = EMPTY
fun singleton v = SET{root = ref(SplayObj{value=v,left=SplayNil,right=SplayNil}),nobj=1}
(* Primitive insertion.
*)
fun insert (v,(nobj,root)) =
case splay (cmpf v, root) of
(EQUAL,SplayObj{value,left,right}) =>
(nobj,SplayObj{value=v,left=left,right=right})
| (LESS,SplayObj{value,left,right}) =>
(nobj+1,
SplayObj{
value=v,
left=SplayObj{value=value,left=left,right=SplayNil},
right=right})
| (GREATER,SplayObj{value,left,right}) =>
(nobj+1,
SplayObj{
value=v,
left=left,
right=SplayObj{value=value,left=SplayNil,right=right}})
| (_,SplayNil) => (1,SplayObj{value=v,left=SplayNil,right=SplayNil})
(* Add an item.
*)
fun add (EMPTY,v) = singleton v
| add (SET{root,nobj},v) = let
val (cnt,t) = insert(v,(nobj,!root))
in
SET{nobj=cnt,root=ref t}
end
fun add' (s, x) = add(x, s)
(* Insert a list of items.
*)
fun addList (set,[]) = set
| addList (set,l) = let
val arg = case set of EMPTY => (0,SplayNil)
| SET{root,nobj} => (nobj,!root)
val (cnt,t) = List.foldl insert arg l
in
SET{nobj=cnt,root=ref t}
end
(* Remove an item.
* Raise LibBase.NotFound if not found
*)
fun delete (EMPTY,_) = raise LibBase.NotFound
| delete (SET{root,nobj},key) =
case splay (cmpf key, !root) of
(EQUAL,SplayObj{value,left,right}) =>
if nobj = 1 then EMPTY
else SET{root=ref(join(left,right)),nobj=nobj-1}
| (_,r) => (root := r; raise LibBase.NotFound)
(* return true if the item is in the set *)
fun member (EMPTY, key) = false
| member (SET{root,nobj}, key) = (case splay (cmpf key, !root)
of (EQUAL, r) => (root := r; true)
| (_, r) => (root := r; false)
(* end case *))
fun isEmpty EMPTY = true
| isEmpty _ = false
local
fun member (x,tree) = let
fun mbr SplayNil = false
| mbr (SplayObj{value,left,right}) =
case K.compare(x,value) of
LESS => mbr left
| GREATER => mbr right
| _ => true
in mbr tree end
(* true if every item in t is in t' *)
fun treeIn (t,t') = let
fun isIn SplayNil = true
| isIn (SplayObj{value,left=SplayNil,right=SplayNil}) =
member(value, t')
| isIn (SplayObj{value,left,right=SplayNil}) =
member(value, t') andalso isIn left
| isIn (SplayObj{value,left=SplayNil,right}) =
member(value, t') andalso isIn right
| isIn (SplayObj{value,left,right}) =
member(value, t') andalso isIn left andalso isIn right
in
isIn t
end
in
fun equal (SET{root=rt,nobj=n},SET{root=rt',nobj=n'}) =
(n=n') andalso treeIn (!rt,!rt')
| equal (EMPTY, EMPTY) = true
| equal _ = false
fun isSubset (SET{root=rt,nobj=n},SET{root=rt',nobj=n'}) =
(n<=n') andalso treeIn (!rt,!rt')
| isSubset (EMPTY,_) = true
| isSubset _ = false
end
local
fun next ((t as SplayObj{right, ...})::rest) = (t, left(right, rest))
| next _ = (SplayNil, [])
and left (SplayNil, rest) = rest
| left (t as SplayObj{left=l, ...}, rest) = left(l, t::rest)
in
fun compare (EMPTY, EMPTY) = EQUAL
| compare (EMPTY, _) = LESS
| compare (_, EMPTY) = GREATER
| compare (SET{root=s1, ...}, SET{root=s2, ...}) = let
fun cmp (t1, t2) = (case (next t1, next t2)
of ((SplayNil, _), (SplayNil, _)) => EQUAL
| ((SplayNil, _), _) => LESS
| (_, (SplayNil, _)) => GREATER
| ((SplayObj{value=e1, ...}, r1), (SplayObj{value=e2, ...}, r2)) => (
case Key.compare(e1, e2)
of EQUAL => cmp (r1, r2)
| order => order
(* end case *))
(* end case *))
in
cmp (left(!s1, []), left(!s2, []))
end
end (* local *)
(* Return the number of items in the table *)
fun numItems EMPTY = 0
| numItems (SET{nobj,...}) = nobj
fun listItems EMPTY = []
| listItems (SET{root,...}) =
let fun apply (SplayNil,l) = l
| apply (SplayObj{value,left,right},l) =
apply(left, value::(apply (right,l)))
in
apply (!root,[])
end
fun split (value,s) =
case splay(cmpf value, s) of
(EQUAL,SplayObj{value,left,right}) => (SOME value, left, right)
| (LESS,SplayObj{value,left,right}) => (NONE, SplayObj{value=value,left=left,right=SplayNil},right)
| (GREATER,SplayObj{value,left,right}) => (NONE, left, SplayObj{value=value,right=right,left=SplayNil})
| (_,SplayNil) => (NONE, SplayNil, SplayNil)
fun intersection (EMPTY,_) = EMPTY
| intersection (_,EMPTY) = EMPTY
| intersection (SET{root,...},SET{root=root',...}) =
let fun inter(SplayNil,_) = (SplayNil,0)
| inter(_,SplayNil) = (SplayNil,0)
| inter(s, SplayObj{value,left,right}) =
case split(value,s) of
(SOME v, l, r) =>
let val (l',lcnt) = inter(l,left)
val (r',rcnt) = inter(r,right)
in
(SplayObj{value=v,left=l',right=r'},lcnt+rcnt+1)
end
| (_,l,r) =>
let val (l',lcnt) = inter(l,left)
val (r',rcnt) = inter(r,right)
in
(join(l',r'),lcnt+rcnt)
end
in
case inter(!root,!root') of
(_,0) => EMPTY
| (root,cnt) => SET{root = ref root, nobj = cnt}
end
fun count st =
let fun cnt(SplayNil,n) = n
| cnt(SplayObj{left,right,...},n) = cnt(left,cnt(right,n+1))
in
cnt(st,0)
end
fun difference (EMPTY,_) = EMPTY
| difference (s,EMPTY) = s
| difference (SET{root,...}, SET{root=root',...}) =
let fun diff(SplayNil,_) = (SplayNil,0)
| diff(s,SplayNil) = (s, count s)
| diff(s,SplayObj{value,right,left}) =
let val (_,l,r) = split(value,s)
val (l',lcnt) = diff(l,left)
val (r',rcnt) = diff(r,right)
in
(join(l',r'),lcnt+rcnt)
end
in
case diff(!root,!root') of
(_,0) => EMPTY
| (root,cnt) => SET{root = ref root, nobj = cnt}
end
fun union (EMPTY,s) = s
| union (s,EMPTY) = s
| union (SET{root,...}, SET{root=root',...}) =
let fun uni(SplayNil,s) = (s,count s)
| uni(s,SplayNil) = (s, count s)
| uni(s,SplayObj{value,right,left}) =
let val (_,l,r) = split(value,s)
val (l',lcnt) = uni(l,left)
val (r',rcnt) = uni(r,right)
in
(SplayObj{value=value,right=r',left=l'},lcnt+rcnt+1)
end
val (root,cnt) = uni(!root,!root')
in
SET{root = ref root, nobj = cnt}
end
fun map f EMPTY = EMPTY
| map f (SET{root, ...}) = let
fun mapf (acc, SplayNil) = acc
| mapf (acc, SplayObj{value,left,right}) =
mapf (add (mapf (acc, left), f value), right)
in
mapf (EMPTY, !root)
end
fun app af EMPTY = ()
| app af (SET{root,...}) =
let fun apply SplayNil = ()
| apply (SplayObj{value,left,right}) =
(apply left; af value; apply right)
in apply (!root) end
(*
fun revapp af (SET{root,...}) =
let fun apply SplayNil = ()
| apply (SplayObj{value,left,right}) =
(apply right; af value; apply left)
in apply (!root) end
*)
(* Fold function *)
fun foldr abf b EMPTY = b
| foldr abf b (SET{root,...}) =
let fun apply (SplayNil, b) = b
| apply (SplayObj{value,left,right},b) =
apply(left,abf(value,apply(right,b)))
in
apply (!root,b)
end
fun foldl abf b EMPTY = b
| foldl abf b (SET{root,...}) =
let fun apply (SplayNil, b) = b
| apply (SplayObj{value,left,right},b) =
apply(right,abf(value,apply(left,b)))
in
apply (!root,b)
end
fun filter p EMPTY = EMPTY
| filter p (SET{root,...}) = let
fun filt (SplayNil,tree) = tree
| filt (SplayObj{value,left,right},tree) = let
val t' = filt(right,filt(left,tree))
in
if p value then insert(value,t')
else t'
end
in
case filt(!root,(0,SplayNil)) of
(0,_) => EMPTY
| (cnt,t) => SET{nobj=cnt,root=ref t}
end
fun exists p EMPTY = false
| exists p (SET{root,...}) = let
fun ex SplayNil = false
| ex (SplayObj{value=v,left=l,right=r}) =
if p v then true
else case ex l of
false => ex r
| _ => true
in
ex (!root)
end
fun find p EMPTY = NONE
| find p (SET{root,...}) = let
fun ex SplayNil = NONE
| ex (SplayObj{value=v,left=l,right=r}) =
if p v then SOME v
else case ex l of
NONE => ex r
| a => a
in
ex (!root)
end
end (* SplaySet *)
(* splay-map-fn.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
*
* Functor implementing dictionaries using splay trees.
*
*)
functor SplayMapFn (K : ORD_KEY) : ORD_MAP =
struct
structure Key = K
open SplayTree
datatype 'a map =
EMPTY
| MAP of {
root : (K.ord_key * 'a) splay ref,
nobj : int
}
fun cmpf k (k', _) = K.compare(k',k)
val empty = EMPTY
(* Insert an item.
*)
fun insert (EMPTY,key,v) =
MAP{nobj=1,root=ref(SplayObj{value=(key,v),left=SplayNil,right=SplayNil})}
| insert (MAP{root,nobj},key,v) =
case splay (cmpf key, !root) of
(EQUAL,SplayObj{value,left,right}) =>
MAP{nobj=nobj,root=ref(SplayObj{value=(key,v),left=left,right=right})}
| (LESS,SplayObj{value,left,right}) =>
MAP{
nobj=nobj+1,
root=ref(SplayObj{value=(key,v),left=SplayObj{value=value,left=left,right=SplayNil},right=right})
}
| (GREATER,SplayObj{value,left,right}) =>
MAP{
nobj=nobj+1,
root=ref(SplayObj{
value=(key,v),
left=left,
right=SplayObj{value=value,left=SplayNil,right=right}
})
}
| (_,SplayNil) => raise LibBase.Impossible "SplayMapFn.insert SplayNil"
fun insert' ((k, x), m) = insert(m, k, x)
(* Look for an item, return NONE if the item doesn't exist *)
fun find (EMPTY,_) = NONE
| find (MAP{root,nobj},key) = (case splay (cmpf key, !root)
of (EQUAL, r as SplayObj{value,...}) => (root := r; SOME(#2 value))
| (_, r) => (root := r; NONE))
(* Remove an item.
* Raise LibBase.NotFound if not found
*)
fun remove (EMPTY, _) = raise LibBase.NotFound
| remove (MAP{root,nobj}, key) = (case (splay (cmpf key, !root))
of (EQUAL, SplayObj{value, left, right}) =>
if nobj = 1
then (EMPTY, #2 value)
else (MAP{root=ref(join(left,right)),nobj=nobj-1}, #2 value)
| (_,r) => (root := r; raise LibBase.NotFound)
(* end case *))
(* Return the number of items in the table *)
fun numItems EMPTY = 0
| numItems (MAP{nobj,...}) = nobj
(* Return a list of the items (and their keys) in the dictionary *)
fun listItems EMPTY = []
| listItems (MAP{root,...}) = let
fun apply (SplayNil, l) = l
| apply (SplayObj{value=(_, v), left, right}, l) =
apply(left, v::(apply (right,l)))
in
apply (!root, [])
end
fun listItemsi EMPTY = []
| listItemsi (MAP{root,...}) = let
fun apply (SplayNil,l) = l
| apply (SplayObj{value,left,right},l) =
apply(left, value::(apply (right,l)))
in
apply (!root,[])
end
local
fun next ((t as SplayObj{right, ...})::rest) = (t, left(right, rest))
| next _ = (SplayNil, [])
and left (SplayNil, rest) = rest
| left (t as SplayObj{left=l, ...}, rest) = left(l, t::rest)
in
fun collate cmpRng (EMPTY, EMPTY) = EQUAL
| collate cmpRng (EMPTY, _) = LESS
| collate cmpRng (_, EMPTY) = GREATER
| collate cmpRng (MAP{root=s1, ...}, MAP{root=s2, ...}) = let
fun cmp (t1, t2) = (case (next t1, next t2)
of ((SplayNil, _), (SplayNil, _)) => EQUAL
| ((SplayNil, _), _) => LESS
| (_, (SplayNil, _)) => GREATER
| ((SplayObj{value=(x1, y1), ...}, r1),
(SplayObj{value=(x2, y2), ...}, r2)
) => (
case Key.compare(x1, x2)
of EQUAL => (case cmpRng (y1, y2)
of EQUAL => cmp (r1, r2)
| order => order
(* end case *))
| order => order
(* end case *))
(* end case *))
in
cmp (left(!s1, []), left(!s2, []))
end
end (* local *)
(* Apply a function to the entries of the dictionary *)
fun appi af EMPTY = ()
| appi af (MAP{root,...}) =
let fun apply SplayNil = ()
| apply (SplayObj{value,left,right}) =
(apply left; af value; apply right)
in
apply (!root)
end
fun app af EMPTY = ()
| app af (MAP{root,...}) =
let fun apply SplayNil = ()
| apply (SplayObj{value=(_,value),left,right}) =
(apply left; af value; apply right)
in
apply (!root)
end
(*
fun revapp af (MAP{root,...}) =
let fun apply SplayNil = ()
| apply (SplayObj{value,left,right}) =
(apply right; af value; apply left)
in
apply (!root)
end
*)
(* Fold function *)
fun foldri (abf : K.ord_key * 'a * 'b -> 'b) b EMPTY = b
| foldri (abf : K.ord_key * 'a * 'b -> 'b) b (MAP{root,...}) =
let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
| apply (SplayObj{value,left,right},b) =
apply(left,abf(#1 value,#2 value,apply(right,b)))
in
apply (!root,b)
end
fun foldr (abf : 'a * 'b -> 'b) b EMPTY = b
| foldr (abf : 'a * 'b -> 'b) b (MAP{root,...}) =
let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
| apply (SplayObj{value=(_,value),left,right},b) =
apply(left,abf(value,apply(right,b)))
in
apply (!root,b)
end
fun foldli (abf : K.ord_key * 'a * 'b -> 'b) b EMPTY = b
| foldli (abf : K.ord_key * 'a * 'b -> 'b) b (MAP{root,...}) =
let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
| apply (SplayObj{value,left,right},b) =
apply(right,abf(#1 value,#2 value,apply(left,b)))
in
apply (!root,b)
end
fun foldl (abf : 'a * 'b -> 'b) b EMPTY = b
| foldl (abf : 'a * 'b -> 'b) b (MAP{root,...}) =
let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
| apply (SplayObj{value=(_,value),left,right},b) =
apply(right,abf(value,apply(left,b)))
in
apply (!root,b)
end
(* Map a table to a new table that has the same keys*)
fun mapi (af : K.ord_key * 'a -> 'b) EMPTY = EMPTY
| mapi (af : K.ord_key * 'a -> 'b) (MAP{root,nobj}) =
let fun ap (SplayNil : (K.ord_key * 'a) splay) = SplayNil
| ap (SplayObj{value,left,right}) = let
val left' = ap left
val value' = (#1 value, af value)
in
SplayObj{value = value', left = left', right = ap right}
end
in
MAP{root = ref(ap (!root)), nobj = nobj}
end
fun map (af : 'a -> 'b) EMPTY = EMPTY
| map (af : 'a -> 'b) (MAP{root,nobj}) =
let fun ap (SplayNil : (K.ord_key * 'a) splay) = SplayNil
| ap (SplayObj{value,left,right}) = let
val left' = ap left
val value' = (#1 value, af (#2 value))
in
SplayObj{value = value', left = left', right = ap right}
end
in
MAP{root = ref(ap (!root)), nobj = nobj}
end
(* the following are generic implementations of the unionWith and intersectWith
* operetions. These should be specialized for the internal representations
* at some point.
*)
fun unionWith f (m1, m2) = let
fun ins f (key, x, m) = (case find(m, key)
of NONE => insert(m, key, x)
| (SOME x') => insert(m, key, f(x, x'))
(* end case *))
in
if (numItems m1 > numItems m2)
then foldli (ins (fn (a, b) => f(b, a))) m1 m2
else foldli (ins f) m2 m1
end
fun unionWithi f (m1, m2) = let
fun ins f (key, x, m) = (case find(m, key)
of NONE => insert(m, key, x)
| (SOME x') => insert(m, key, f(key, x, x'))
(* end case *))
in
if (numItems m1 > numItems m2)
then foldli (ins (fn (k, a, b) => f(k, b, a))) m1 m2
else foldli (ins f) m2 m1
end
fun intersectWith f (m1, m2) = let
(* iterate over the elements of m1, checking for membership in m2 *)
fun intersect f (m1, m2) = let
fun ins (key, x, m) = (case find(m2, key)
of NONE => m
| (SOME x') => insert(m, key, f(x, x'))
(* end case *))
in
foldli ins empty m1
end
in
if (numItems m1 > numItems m2)
then intersect f (m1, m2)
else intersect (fn (a, b) => f(b, a)) (m2, m1)
end
fun intersectWithi f (m1, m2) = let
(* iterate over the elements of m1, checking for membership in m2 *)
fun intersect f (m1, m2) = let
fun ins (key, x, m) = (case find(m2, key)
of NONE => m
| (SOME x') => insert(m, key, f(key, x, x'))
(* end case *))
in
foldli ins empty m1
end
in
if (numItems m1 > numItems m2)
then intersect f (m1, m2)
else intersect (fn (k, a, b) => f(k, b, a)) (m2, m1)
end
(* this is a generic implementation of mapPartial. It should
* be specialized to the data-structure at some point.
*)
fun mapPartial f m = let
fun g (key, item, m) = (case f item
of NONE => m
| (SOME item') => insert(m, key, item')
(* end case *))
in
foldli g empty m
end
fun mapPartiali f m = let
fun g (key, item, m) = (case f(key, item)
of NONE => m
| (SOME item') => insert(m, key, item')
(* end case *))
in
foldli g empty m
end
(* this is a generic implementation of filter. It should
* be specialized to the data-structure at some point.
*)
fun filter predFn m = let
fun f (key, item, m) = if predFn item
then insert(m, key, item)
else m
in
foldli f empty m
end
fun filteri predFn m = let
fun f (key, item, m) = if predFn(key, item)
then insert(m, key, item)
else m
in
foldli f empty m
end
end (* SplayDictFn *)
(* ------------------- *)
(* IDs *)
(* The various root types shares the id counter *)
val curRootId = ref 0;
fun getCurrentRootId () = !curRootId;
val _ = _export "getCurrentRootId" : (unit -> int) -> unit; getCurrentRootId;
fun getNextRoot () = ( curRootId := !curRootId+1 ; !curRootId);
(* For each combination of base type and compound constructor, we need a root type with operations:
get, reg, return, unreg *)
signature ROOT_TYPE = sig type t end
signature ROOT =
sig
type t
exception RootNotFound;
val get: int -> t (* get root given root number *)
val reg: t -> int (* register and return root number *)
val return: t -> t (* register and return root *)
val unreg: int -> unit
end
functor Root (R: ROOT_TYPE): ROOT =
struct
type t = R.t;
exception RootNotFound;
structure RootMap = SplayMapFn(struct
type ord_key = int;
val compare = Int.compare
end);
val roots = ref RootMap.empty;
val reg =
fn r => ( roots := RootMap.insert (!roots, getNextRoot (), r)
; getCurrentRootId ());
val get =
fn i => case RootMap.find (!roots, i)
of NONE => raise RootNotFound
| SOME r => r;
val return =
fn r => ( roots := RootMap.insert (!roots, getNextRoot (), r)
; r);
(* TODO: Catch the exception, when unreg is passed an already
unregistered root *)
val unreg =
fn i => roots := (case RootMap.remove (!roots, i)
of (rs,_) => rs);
end
--------------060904090605020203000509
Content-Type: text/plain;
name="test.ss"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="test.ss"
;;; TODO:
;; - allow $unit at the left side of an _fun arrow
;; - test string conversion
;; - put this in a module
;; - write support functions for ML vectors
;; - think about what happens if a call to regRoot triggers a garbage
;; Solution: Demand that all returned compound values are registered at the ML side
;;; CONVENIENCES
; define x as short for (exit)
(define-syntax x (syntax-id-rules () (x (exit))))
(require (lib "list.ss"))
;;; OPEN FOREIGN LIBRARY
(require (lib "foreign.ss"))
(unsafe!)
(display "* Opening library\n")
(define lib (string->path "./test") #;<optional-version> )
;;; BASE TYPES
(define $unit _void)
; ((sml-abbrev sml-type $type ffi-name) ...)
(begin-for-syntax
(define base-types '()))
(define-syntax (define-base-types stx)
(syntax-case stx ()
[(_ ())
#'(void)]
[(_ ((ffi-name ffi-type sml-type sml-abbrev c-typedef c-type) clause ...))
(begin
(set! base-types (cons (syntax-object->datum #'(sml-abbrev sml-type ffi-type ffi-name)) base-types))
#'(begin
(define ffi-name ffi-type)
(define-base-types (clause ...))))]
[(_ ((ffi-name ffi-type sml-type sml-abbrev c-typedef c-type scheme->c c->scheme) clause ...))
(begin
(set! base-types (cons (syntax-object->datum #'(sml-abbrev sml-type ffi-type ffi-name)) base-types))
#'(begin
(define ffi-name (make-ctype ffi-type scheme->c c->scheme))
(define-base-types (clause ...))))]))
(define (object->bool o)
(case o
[(#t #f) o]
[else (error 'object->bool "boolean expected, got: ~a" o)]))
(define (bool->object b)
b)
(define-base-types
(; ml-ffi C-FFI SML type SML-abbrev C typedef C type Scheme->C C->Scheme
; Values of these values are simply copied between ML and Scheme
($int8 _int8 Int8.int Int8 Int8 "char")
($int16 _int16 Int16.int Int16 Int16 "short")
($int32 _int32 Int32.int Int32 Int32 "long")
($int64 _int64 Int64.int Int64 Int64 "long long")
($int _int32 int int Int32 "long")
($real32 _float Real32.real Real32 Real32 "float")
($real64 _double Real64.real Real64 Real64 "double")
($real _double real real Real64 "double")
($word8 _uint8 Word8.word Word8 Word8 "unsigned char")
($word16 _uint16 Word16.word Word16 Word16 "unsigned short")
($word32 _uint32 Word32.word Word32 Word32 "unsigned long")
($word64 _uint64 Word64.word Word64 Word64 "unsigned long")
($word _uint32 word word Word32 "unsigned int")
; Booleans and characters needs conversion to/from booleans/characters from/to integers
($bool _bool bool Bool Int32 "long" object->bool bool->object)
($char _int8 char char Int8 "char" char->integer integer->char)
; Values of these types are only valid until the next MLton garbage collection
; These are unsafe to use - hence rooted versions of these are defined below,
; in order to provide automatic GC of ML values.
($array _pointer array array Pointer "char *")
($pointer _pointer MLton.Pointer.t Pointer Pointer "char *")
($ref _pointer ref ref Pointer "char *")
($string _pointer string string Pointer "char *") ; READ ONLY
($vector _pointer vector vector Pointer "char *") ; READ ONLY
))
; The registry base-types have the format ((sml-abbrev sml-type $type) ...)
(begin-for-syntax
(require (lib "list.ss"))
; (define short-names (map first base-types)
(define short-names
'(Bool Int8 Int16 Int32 Int64 int Real32 Real64 real Word8 Word16 Word32 Word64 word char string))
(define (short-name->$name name)
(let ((a (assoc name base-types)))
(if a
(fourth a)
(error "short name not found in base-types")))))
;;; Each compound ML value is represented as a Scheme struct which
;;; holds the root id and the operations get and unreg.
;;; The id is given to the value by ML, when it is registered
;;; at the ML side before returning it to the Scheme side. The
;;; id is to be used by private routines of mzton, each time the
;;; value is refered (since ML moves values during garbage collection)
;;; and when the value is to be deallocated.
(define (make-root id get unreg base-type)
(vector id get unreg base-type))
(define (root-id v) (vector-ref v 0))
(define (root-get v) (vector-ref v 1)) ; retrieve uptodate C-pointer
(define (root-unreg v) (vector-ref v 2)) ; deallocate
(define (root-base-type v) (vector-ref v 3)) ; e.g. the base type of "array int" is "int"
(define (root? o) (and (vector? o) (= (vector-length o) 4)))
(define (root->val r) ((root-get r) (root-id r)))
;;; We want to Scheme to automatically unregister the ML values, when
;;; the roots become unreachable. This is done by registering the root
;;; values with a will executor.
(define ml-will-executor (make-will-executor))
;;; The unreachable roots needs to be unregistered; a separate
;;; thread takes care of this.
; CAREFUL: Remember to suspend this thread, in regions, where an ML garbage
; collection is unwanted.
; TODO: Compare the efficiency of the suspend/resume implementation
; with a semaphore version.
; start the separate thread
(define will-thread (thread (lambda ()
(let loop ()
(will-execute ml-will-executor)
(loop)))))
; TODO: this works fine, but using semaphores would be faster
;(define-syntax critical-region
; (syntax-rules ()
; ((critical-region body ...)
; (let ()
; (thread-suspend will-thread)
; (begin0
; (begin body ...)
; (thread-resume will-thread))))))
; This semaphore makes sure the main thread and the will
; thread doesn't call into ML at the same time
(define semaphore-for-critical-region (make-semaphore 1))
; This is used by the main thread in order not to wait
; for an already obtained semaphore. NOTE: This assumes
; the main thread is single threaded ???
(define inside-critical-region? #f)
(define-syntax will-critical-region
(syntax-rules ()
((critical-region body ...)
(begin
(semaphore-wait semaphore-for-critical-region)
(begin0
(begin body ...)
(semaphore-post semaphore-for-critical-region))))))
(define-syntax critical-region
(syntax-rules ()
((critical-region body ...)
(if inside-critical-region?
(begin body ...)
(begin
(semaphore-wait semaphore-for-critical-region)
(set! inside-critical-region? #t)
(begin0
(begin body ...)
(set! inside-critical-region? #f)
(semaphore-post semaphore-for-critical-region)))))))
(define (ml-will-register-root r)
(will-register ml-will-executor r
; this thunk will eventually be called by the will-thread,
(lambda (r)
(will-critical-region
(display "unregistering> ") (display r) (display " ")
((root-unreg r) (root-id r))))))
;(define (ml-will-try-execute)
; (will-try-execute ml-will-executor))
(define (signal-error o)
(display "signal-error: ")
(display o)
(newline))
; registering a root at the ML side, sets the current root id
(define get-current-root-id (get-ffi-obj "getCurrentRootId" lib (_fun -> $int) signal-error))
; (define-compound/base-type ...) importes getBaseCompound and unregBaseCompound
; from the ML side, and defines them as base-compound-get and base-compound-unreg.
; At the same time $BaseCompound is defined as a new C-type representing rooted
; BaseCompound values. $BaseCompound is to be used when importing functions
; from the ML side.
(define-syntax (define-compound/base-type stx)
(syntax-case stx ()
[(_ $BaseCompound compound base $base
base-compound-get getBaseCompound
base-compound-unreg unregBaseCompound
make-base-compound makeBaseCompound)
#`(begin
(define base-compound-get (get-ffi-obj getBaseCompound lib (_fun $int -> _pointer)
(lambda () (error getBaseCompound))))
(define base-compound-unreg (get-ffi-obj unregBaseCompound lib (_fun $int -> _void) signal-error))
; (display '("defining " '$BaseCompound)) (newline)
(define $BaseCompound (make-ctype _pointer
; Scheme->C
root->val
; C->Scheme
; (assumption: the returned value were just registered by the MLton side,
; thus get-current-root-id can get the id from the ML side)
(lambda (a)
(let ([root (make-root (get-current-root-id)
base-compound-get
base-compound-unreg
$base)])
; make sure the Scheme garbage collector will unregister the root
(will-register ml-will-executor
root
(lambda (r) ((root-unreg r) (root-id r))))
root))))
(define make-base-compound
(case 'compound
[(ref) (get-ffi-obj makeBaseCompound lib (_fun $base -> $BaseCompound)
(lambda () (signal-error (format "couldn't open ~a from lib" makeBaseCompound))))]
[else (get-ffi-obj makeBaseCompound lib (_fun $int $base -> $BaseCompound)
(lambda () (signal-error (format "couldn't open ~a from lib" makeBaseCompound))))])))]))
; (define-compound ...) for each base type the type (and associated functions)
; $BaseCompound is defined by building the names, and then using
; define-compound/base-type.
(define-syntax (define-compound stx)
(syntax-case stx ()
[(_ compound-stx)
(begin
(define (string->id s) (syntax-local-introduce (quasisyntax/loc stx #,(string->symbol s))))
(quasisyntax/loc stx
(begin #,@(map (lambda (base)
(let* ([compound (syntax-object->datum #'compound-stx)]
[Base (string-titlecase (symbol->string base))]
[base (string-downcase (symbol->string base))]
[Compound (string-titlecase (symbol->string compound))]
[BaseCompound (format "~a~a" Base Compound)]
[$BaseCompound (format "$~a~a" Base Compound)]
[getBaseCompound (format "get~a~a" Base Compound)]
[unregBaseCompound (format "unreg~a~a" Base Compound)]
[make-base-compound (format "make-~a-~a" base compound)])
(with-syntax ((base base)
($base (string->id (format "$~a" base)))
(Compound (string->id Compound))
(BaseCompound (string->id BaseCompound))
($BaseCompound (string->id $BaseCompound))
(getBaseCompound getBaseCompound)
(unregBaseCompound unregBaseCompound)
(base-compound-get (string->id (string-downcase (format "~a-~a-get" base compound))))
(base-compound-unreg (string->id (string-downcase (format "~a-~a-unreg" base compound))))
(make-base-compound (string->id make-base-compound))
(makeBaseCompound (format "make~a" BaseCompound)))
#'(begin
(define-compound/base-type $BaseCompound compound-stx base $base
base-compound-get getBaseCompound
base-compound-unreg unregBaseCompound
make-base-compound makeBaseCompound
)))))
short-names))))]))
; The compound constructors are array, ref and vector.
(define-compound array)
(define-compound ref)
(define-compound vector)
;;;
;;; WORKING WITH COMPOUND TYPES
;;;
;;; REF
; ml-raw-ref-ref : $base cpointer-to-base-ref -> base
(define (ml-raw-ref-ref $base cpointer-to-base-ref)
(ptr-ref cpointer-to-base-ref $base))
; ml-ref-ref : rooted-base-ref -> base
(define (ml-ref-ref rooted-base-ref)
(unless (root? rooted-base-ref)
(error #f "rooted ref expected, got " rooted-base-ref))
(critical-region
(ml-raw-ref-ref (root-base-type rooted-base-ref)
(root->val rooted-base-ref))))
; ml-raw-ml-ref-set! : $base cpointer-to-base-ref ->
(define (ml-raw-ref-set! $base cpointer-to-base-ref new-val)
(ptr-set! cpointer-to-base-ref $base new-val))
; ml-ref-set! : rooted-base-ref base ->
(define (ml-ref-set! rooted-base-ref new-val)
(unless (root? rooted-base-ref)
(error #f "rooted ref expected, got " rooted-base-ref))
(critical-region
(ml-raw-ref-set! (root-base-type rooted-base-ref)
(root->val rooted-base-ref)
new-val)))
;;; ARRAY
; ml-raw-array-length : pointer -> integer
; return the length of an raw (as opposed to rooted) array returned from mlton
(define (ml-raw-array-length cpointer-to-array)
; see GC_arrayNumElementsp in gc.h
(ptr-ref cpointer-to-array _uint -2))
; ml-array-length : rooted-array -> integer
(define (ml-array-length rooted-array)
(unless (root? rooted-array)
(error "rooted array expected, got " rooted-array))
(critical-region
(ml-raw-array-length (root->val rooted-array))))
; ml-raw-array-ref : pointer $base integer -> base
(define (ml-raw-array-ref $base cpointer-to-base-array index)
(ptr-ref cpointer-to-base-array $base index))
; ml-array-ref : rooted-base-array integer -> base
(define (ml-array-ref rooted-base-array index)
(unless (root? rooted-base-array)
(error #f "rooted array or vector expected, got " rooted-base-array))
(unless (<= 0 index (sub1 (ml-array-length rooted-base-array)))
(error "index out of range" index))
(critical-region
(ml-raw-array-ref (root-base-type rooted-base-array)
(root->val rooted-base-array)
index)))
; ml-raw-array-set! : $base cpointer-to-base-array integer new-val ->
(define (ml-raw-array-set! $base cpointer-to-base-array index new-val)
(ptr-set! cpointer-to-base-array $base index new-val))
; ml-array-set! : rooted-base-array integer base ->
(define (ml-array-set! rooted-base-array index new-val)
(unless (root? rooted-base-array)
(error "rooted array expected, got " rooted-base-array))
(unless (<= 0 index (sub1 (ml-array-length rooted-base-array)))
(error "index out of range" index))
(critical-region
(let ([$base (root-base-type rooted-base-array)]
[c-pointer (root->val rooted-base-array)])
(ml-raw-array-set! $base c-pointer index new-val))))
; ml-array->vector : (rooted-base-array alpha) -> (vector alpha)
(define (ml-array->vector rooted-base-array)
(unless (root? rooted-base-array)
(error #f "rooted array expected, got " rooted-base-array))
(critical-region
(let* ((len (ml-array-length rooted-base-array))
(s (make-vector len))
(array (root->val rooted-base-array))
($base (root-base-type rooted-base-array)))
(do ([i 0 (add1 i)]) [(= i len) s]
(vector-set! s i (ml-raw-array-ref $base array i))))))
; vector->ml-array : (vector alpha) $alpha -> ml-array
; TODO: Infer ml-make-alpha-array from $alpha
(define (vector->ml-array v $alpha ml-make-alpha-array)
(critical-region
(let* ([len (vector-length v)]
[a (ml-make-alpha-array len (vector-ref v 0))]
[c-pointer (root->val a)])
(do ([i 0 (add1 i)]) [(= i len) a]
(ml-raw-array-set! $alpha c-pointer i (vector-ref v i))))))
;;; VECTOR
;; TODO TODO: Write vector convenience functions
;; TODO TODO: Write ml-array->ml-vector
; ml-vector-length : rooted-vector -> integer
(define (ml-vector-length v)
(ml-array-length v))
; ml-raw-vector-ref $base c-pointer-to-vector integer -> base
(define (ml-raw-vector-ref $base c-pointer index)
(ml-raw-array-ref $base c-pointer index))
; ml-vector-ref (ml-vector alpha) integer -> alpha
(define (ml-vector-ref rooted-vector index)
(ml-array-ref rooted-vector index))
; ml-vector->vector : (rooted-base-vector alpha) -> (vector alpha)
(define (ml-vector->vector rooted-base-vector)
(unless (root? rooted-base-vector)
(error #f "rooted vector expected, got " rooted-base-vector))
(critical-region
(let* ((len (ml-vector-length rooted-base-vector))
(s (make-vector len))
(vector (root->val rooted-base-vector))
($base (root-base-type rooted-base-vector)))
(do ([i 0 (add1 i)]) [(= i len) s]
(vector-set! s i (ml-raw-vector-ref $base vector i))))))
;;;
;;; TEST
;;;
(display "* Opening library functions\n")
; defined above
;(define get-current-root-id (get-ffi-obj "getCurrentRootId" lib (_fun -> $int) signal-error))
(define test-int-to-int (get-ffi-obj "testIntToInt" lib (_fun $int -> $int) signal-error))
(define test-unit-to-int (get-ffi-obj "testUnitToInt" lib (_fun -> $int) signal-error))
(define test-unit-to-char (get-ffi-obj "testUnitToChar" lib (_fun -> $char) signal-error))
(define test-unit-to-bool (get-ffi-obj "testUnitToBool" lib (_fun -> $bool) signal-error))
(define test-unit-to-int-array (get-ffi-obj "testUnitToIntArray" lib (_fun -> $IntArray) signal-error))
(define test-unit-to-int-ref (get-ffi-obj "testUnitToIntRef" lib (_fun -> $IntRef) signal-error))
;;; MANDELBROT
(define ml-iterate (get-ffi-obj "iterate" lib (_fun $real $real -> $int) signal-error))
(define ml-iterate-line (get-ffi-obj "iterateLine" lib (_fun $real $real $real $real -> $IntArray) signal-error))
;;; CALLBACKS
(define ml-double-array (get-ffi-obj "doubleArray" lib (_fun $RealArray (_fun $real -> $real) -> $unit) signal-error))
(display "* Done opening library objects\n")
(display (test-int-to-int 1)) (newline)
(display (test-unit-to-int)) (newline)
(display (test-unit-to-char)) (newline)
(define a (test-unit-to-int-array))
(display a) (newline)
(display (ml-array-length a)) (newline)
(display (ml-array-ref a 0)) (newline)
(display (ml-array-ref a 1)) (newline)
(display (ml-array-ref a 2)) (newline)
(display (ml-array-ref a 3)) (newline)
(display (ml-array-ref a 4)) (newline)
(display (ml-array->vector a)) (newline)
(newline)
(define r (test-unit-to-int-ref))
(display (ml-ref-ref r)) (newline)
(ml-ref-set! r 43)
(display (ml-ref-ref r))
(newline)
(display "double test\n")
(define b (make-real-array 4 0.0))
(ml-array-set! b 0 0.0)
(ml-array-set! b 1 1.0)
(ml-array-set! b 2 2.0)
(ml-array-set! b 3 3.0)
(ml-double-array b (lambda (x) (* 2.0 x)))
(display (ml-array->vector b)) (newline)
(define make-unit-vec (get-ffi-obj "makeUnitVec" lib (_fun $int $int -> $RealArray) signal-error))
(define dot-vec (get-ffi-obj "dotVec" lib (_fun $RealArray $RealArray -> $real) signal-error))
(define modify-vec! (get-ffi-obj "modifyVec" lib (_fun $RealArray (_fun $real -> $real) -> $unit) signal-error))
--------------060904090605020203000509
Content-Type: text/plain;
name="test.cm"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="test.cm"
Group is
roots.sml
test.sml
--------------060904090605020203000509
Content-Type: text/plain;
name="test.sml"
Content-Transfer-Encoding: 8bit
Content-Disposition: inline;
filename="test.sml"
(* MZTON -- Jens Axel Søgaard -- 2005 *)
(* ROOTS
*
* Values of the base types int, bool, ... can be returned from MLton to
* Scheme with no problems.
* Compound values such as arrays, vectors and references need to be registered
* with the MLton garbage collector - otherwise MLton might remove a value
* still in use at the Scheme side.
*
* The function 'reg' registers a value and returns an
* id (an integer) that later can be used to unregister it with 'unreg'.
* The function 'return' registers a value and returns the same value;
* the id can later be read with 'getCurrentRootId'.
* The function 'get' is used by the Scheme implementation to retrieve
* a pointer to an ML value given an id previously returned from 'reg'.
* The function 'get' is neccessary to have, since MLton has a moving
* garbage collector, and it therefore isn't possible to just hold
* on to any C-pointers returned from ML on the Scheme side.
*
*
* Example:
*
* fun testUnitToIntArray () = Array.array (5,0);
* val _ = _export "testUnitToIntArray" : (unit -> int array) -> unit; (IntArrayRoot.return o testUnitToIntArray);
*
*)
(*
(* IDs *)
(* The various root types shares the id counter *)
val curRootId = ref 0;
fun getCurrentRootId () = !curRootId;
val _ = _export "getCurrentRootId" : (unit -> int) -> unit; getCurrentRootId;
fun getNextRoot () = ( curRootId := !curRootId+1 ; !curRootId);
(* For each combination of base type and compound constructor, we need a root type with operations:
get, reg, return, unreg *)
signature ROOT_TYPE = sig type t end
signature ROOT =
sig
type t
exception RootNotFound;
val get: int -> t (* get root given root number *)
val reg: t -> int (* register and return root number *)
val return: t -> t (* register and return root *)
val unreg: int -> unit
end
functor Root (R: ROOT_TYPE): ROOT =
struct
type t = R.t;
exception RootNotFound;
val roots = ref []; (* association list of integer*root pairs *)
val get =
fn i => let
val rec loop = fn nil => raise RootNotFound
| (j,r)::more => if i=j then r else (loop more)
in
loop (!roots)
end;
val reg =
fn r => ( roots := (getNextRoot (), r) :: (!roots)
; getCurrentRootId ());
val return =
fn r => ( roots := (getNextRoot (), r) :: (!roots)
; r );
val unreg =
fn i => let val rec loop = fn nil => raise RootNotFound
| (j,r)::more => if i=j then more else (j,r)::(loop more)
in roots := loop (!roots)
end;
end
*)
structure BoolArrayRoot = Root(struct type t = bool array end);
val _ = _export "getBoolArray": (int -> bool array) -> unit; BoolArrayRoot.get;
val _ = _export "unregBoolArray" : (int -> unit) -> unit; BoolArrayRoot.unreg;
val _ = _export "regBoolArray" : (bool array -> int) -> unit; BoolArrayRoot.reg;
structure CharArrayRoot = Root(struct type t = char array end);
val _ = _export "getCharArray": (int -> char array) -> unit; CharArrayRoot.get;
val _ = _export "unregCharArray" : (int -> unit) -> unit; CharArrayRoot.unreg;
val _ = _export "regCharArray" : (char array -> int) -> unit; CharArrayRoot.reg;
structure Int8ArrayRoot = Root(struct type t = Int8.int array end);
val _ = _export "getInt8Array": (int -> Int8.int array) -> unit; Int8ArrayRoot.get;
val _ = _export "unregInt8Array" : (int -> unit) -> unit; Int8ArrayRoot.unreg;
val _ = _export "regInt8Array" : (Int8.int array -> int) -> unit; Int8ArrayRoot.reg;
structure Int16ArrayRoot = Root(struct type t = Int16.int array end);
val _ = _export "getInt16Array": (int -> Int16.int array) -> unit; Int16ArrayRoot.get;
val _ = _export "unregInt16Array" : (int -> unit) -> unit; Int16ArrayRoot.unreg;
val _ = _export "regInt16Array" : (Int16.int array -> int) -> unit; Int16ArrayRoot.reg;
structure Int32ArrayRoot = Root(struct type t = Int32.int array end);
val _ = _export "getInt32Array": (int -> Int32.int array) -> unit; Int32ArrayRoot.get;
val _ = _export "unregInt32Array" : (int -> unit) -> unit; Int32ArrayRoot.unreg;
val _ = _export "regInt32Array" : (Int32.int array -> int) -> unit; Int32ArrayRoot.reg;
structure Int64ArrayRoot = Root(struct type t = Int64.int array end);
val _ = _export "getInt64Array": (int -> Int64.int array) -> unit; Int64ArrayRoot.get;
val _ = _export "unregInt64Array" : (int -> unit) -> unit; Int64ArrayRoot.unreg;
val _ = _export "regInt64Array" : (Int64.int array -> int) -> unit; Int64ArrayRoot.reg;
structure IntArrayRoot = Root(struct type t = int array end);
val _ = _export "getIntArray": (int -> int array) -> unit; IntArrayRoot.get;
val _ = _export "unregIntArray" : (int -> unit) -> unit; IntArrayRoot.unreg;
val _ = _export "regIntArray" : (int array -> int) -> unit; IntArrayRoot.reg;
structure PointerArrayRoot = Root(struct type t = MLton.Pointer.t array end);
val _ = _export "getPointerArray": (int -> MLton.Pointer.t array) -> unit; PointerArrayRoot.get;
val _ = _export "unregPointerArray" : (int -> unit) -> unit; PointerArrayRoot.unreg;
val _ = _export "regPointerArray" : (MLton.Pointer.t array -> int) -> unit; PointerArrayRoot.reg;
structure Real32ArrayRoot = Root(struct type t = Real32.real array end);
val _ = _export "getReal32Array": (int -> Real32.real array) -> unit; Real32ArrayRoot.get;
val _ = _export "unregReal32Array" : (int -> unit) -> unit; Real32ArrayRoot.unreg;
val _ = _export "regReal32Array" : (Real32.real array -> int) -> unit; Real32ArrayRoot.reg;
structure Real64ArrayRoot = Root(struct type t = Real64.real array end);
val _ = _export "getReal64Array": (int -> Real64.real array) -> unit; Real64ArrayRoot.get;
val _ = _export "unregReal64Array" : (int -> unit) -> unit; Real64ArrayRoot.unreg;
val _ = _export "regReal64Array" : (Real64.real array -> int) -> unit; Real64ArrayRoot.reg;
structure RealArrayRoot = Root(struct type t = real array end);
val _ = _export "getRealArray": (int -> real array) -> unit; RealArrayRoot.get;
val _ = _export "unregRealArray" : (int -> unit) -> unit; RealArrayRoot.unreg;
val _ = _export "regRealArray" : (real array -> int) -> unit; RealArrayRoot.reg;
structure Word8ArrayRoot = Root(struct type t = Word8.word array end);
val _ = _export "getWord8Array": (int -> Word8.word array) -> unit; Word8ArrayRoot.get;
val _ = _export "unregWord8Array" : (int -> unit) -> unit; Word8ArrayRoot.unreg;
val _ = _export "regWord8Array" : (Word8.word array -> int) -> unit; Word8ArrayRoot.reg;
structure Word16ArrayRoot = Root(struct type t = Word16.word array end);
val _ = _export "getWord16Array": (int -> Word16.word array) -> unit; Word16ArrayRoot.get;
val _ = _export "unregWord16Array" : (int -> unit) -> unit; Word16ArrayRoot.unreg;
val _ = _export "regWord16Array" : (Word16.word array -> int) -> unit; Word16ArrayRoot.reg;
structure Word32ArrayRoot = Root(struct type t = Word32.word array end);
val _ = _export "getWord32Array": (int -> Word32.word array) -> unit; Word32ArrayRoot.get;
val _ = _export "unregWord32Array" : (int -> unit) -> unit; Word32ArrayRoot.unreg;
val _ = _export "regWord32Array" : (Word32.word array -> int) -> unit; Word32ArrayRoot.reg;
structure Word64ArrayRoot = Root(struct type t = Word64.word array end);
val _ = _export "getWord64Array": (int -> Word64.word array) -> unit; Word64ArrayRoot.get;
val _ = _export "unregWord64Array" : (int -> unit) -> unit; Word64ArrayRoot.unreg;
val _ = _export "regWord64Array" : (Word64.word array -> int) -> unit; Word64ArrayRoot.reg;
structure WordArrayRoot = Root(struct type t = word array end);
val _ = _export "getWordArray": (int -> word array) -> unit; WordArrayRoot.get;
val _ = _export "unregWordArray" : (int -> unit) -> unit; WordArrayRoot.unreg;
val _ = _export "regWordArray" : (word array -> int) -> unit; WordArrayRoot.reg;
structure StringArrayRoot = Root(struct type t = string array end);
val _ = _export "getStringArray": (int -> string array) -> unit; StringArrayRoot.get;
val _ = _export "unregStringArray" : (int -> unit) -> unit; StringArrayRoot.unreg;
val _ = _export "regStringArray" : (string array -> int) -> unit; StringArrayRoot.reg;
structure BoolRefRoot = Root(struct type t = bool ref end);
val _ = _export "getBoolRef": (int -> bool ref) -> unit; BoolRefRoot.get;
val _ = _export "unregBoolRef" : (int -> unit) -> unit; BoolRefRoot.unreg;
val _ = _export "regBoolRef" : (bool ref -> int) -> unit; BoolRefRoot.reg;
structure CharRefRoot = Root(struct type t = char ref end);
val _ = _export "getCharRef": (int -> char ref) -> unit; CharRefRoot.get;
val _ = _export "unregCharRef" : (int -> unit) -> unit; CharRefRoot.unreg;
val _ = _export "regCharRef" : (char ref -> int) -> unit; CharRefRoot.reg;
structure Int8RefRoot = Root(struct type t = Int8.int ref end);
val _ = _export "getInt8Ref": (int -> Int8.int ref) -> unit; Int8RefRoot.get;
val _ = _export "unregInt8Ref" : (int -> unit) -> unit; Int8RefRoot.unreg;
val _ = _export "regInt8Ref" : (Int8.int ref -> int) -> unit; Int8RefRoot.reg;
structure Int16RefRoot = Root(struct type t = Int16.int ref end);
val _ = _export "getInt16Ref": (int -> Int16.int ref) -> unit; Int16RefRoot.get;
val _ = _export "unregInt16Ref" : (int -> unit) -> unit; Int16RefRoot.unreg;
val _ = _export "regInt16Ref" : (Int16.int ref -> int) -> unit; Int16RefRoot.reg;
structure Int32RefRoot = Root(struct type t = Int32.int ref end);
val _ = _export "getInt32Ref": (int -> Int32.int ref) -> unit; Int32RefRoot.get;
val _ = _export "unregInt32Ref" : (int -> unit) -> unit; Int32RefRoot.unreg;
val _ = _export "regInt32Ref" : (Int32.int ref -> int) -> unit; Int32RefRoot.reg;
structure Int64RefRoot = Root(struct type t = Int64.int ref end);
val _ = _export "getInt64Ref": (int -> Int64.int ref) -> unit; Int64RefRoot.get;
val _ = _export "unregInt64Ref" : (int -> unit) -> unit; Int64RefRoot.unreg;
val _ = _export "regInt64Ref" : (Int64.int ref -> int) -> unit; Int64RefRoot.reg;
structure IntRefRoot = Root(struct type t = int ref end);
val _ = _export "getIntRef": (int -> int ref) -> unit; IntRefRoot.get;
val _ = _export "unregIntRef" : (int -> unit) -> unit; IntRefRoot.unreg;
val _ = _export "regIntRef" : (int ref -> int) -> unit; IntRefRoot.reg;
structure PointerRefRoot = Root(struct type t = MLton.Pointer.t ref end);
val _ = _export "getPointerRef": (int -> MLton.Pointer.t ref) -> unit; PointerRefRoot.get;
val _ = _export "unregPointerRef" : (int -> unit) -> unit; PointerRefRoot.unreg;
val _ = _export "regPointerRef" : (MLton.Pointer.t ref -> int) -> unit; PointerRefRoot.reg;
structure Real32RefRoot = Root(struct type t = Real32.real ref end);
val _ = _export "getReal32Ref": (int -> Real32.real ref) -> unit; Real32RefRoot.get;
val _ = _export "unregReal32Ref" : (int -> unit) -> unit; Real32RefRoot.unreg;
val _ = _export "regReal32Ref" : (Real32.real ref -> int) -> unit; Real32RefRoot.reg;
structure Real64RefRoot = Root(struct type t = Real64.real ref end);
val _ = _export "getReal64Ref": (int -> Real64.real ref) -> unit; Real64RefRoot.get;
val _ = _export "unregReal64Ref" : (int -> unit) -> unit; Real64RefRoot.unreg;
val _ = _export "regReal64Ref" : (Real64.real ref -> int) -> unit; Real64RefRoot.reg;
structure RealRefRoot = Root(struct type t = real ref end);
val _ = _export "getRealRef": (int -> real ref) -> unit; RealRefRoot.get;
val _ = _export "unregRealRef" : (int -> unit) -> unit; RealRefRoot.unreg;
val _ = _export "regRealRef" : (real ref -> int) -> unit; RealRefRoot.reg;
structure Word8RefRoot = Root(struct type t = Word8.word ref end);
val _ = _export "getWord8Ref": (int -> Word8.word ref) -> unit; Word8RefRoot.get;
val _ = _export "unregWord8Ref" : (int -> unit) -> unit; Word8RefRoot.unreg;
val _ = _export "regWord8Ref" : (Word8.word ref -> int) -> unit; Word8RefRoot.reg;
structure Word16RefRoot = Root(struct type t = Word16.word ref end);
val _ = _export "getWord16Ref": (int -> Word16.word ref) -> unit; Word16RefRoot.get;
val _ = _export "unregWord16Ref" : (int -> unit) -> unit; Word16RefRoot.unreg;
val _ = _export "regWord16Ref" : (Word16.word ref -> int) -> unit; Word16RefRoot.reg;
structure Word32RefRoot = Root(struct type t = Word32.word ref end);
val _ = _export "getWord32Ref": (int -> Word32.word ref) -> unit; Word32RefRoot.get;
val _ = _export "unregWord32Ref" : (int -> unit) -> unit; Word32RefRoot.unreg;
val _ = _export "regWord32Ref" : (Word32.word ref -> int) -> unit; Word32RefRoot.reg;
structure Word64RefRoot = Root(struct type t = Word64.word ref end);
val _ = _export "getWord64Ref": (int -> Word64.word ref) -> unit; Word64RefRoot.get;
val _ = _export "unregWord64Ref" : (int -> unit) -> unit; Word64RefRoot.unreg;
val _ = _export "regWord64Ref" : (Word64.word ref -> int) -> unit; Word64RefRoot.reg;
structure WordRefRoot = Root(struct type t = word ref end);
val _ = _export "getWordRef": (int -> word ref) -> unit; WordRefRoot.get;
val _ = _export "unregWordRef" : (int -> unit) -> unit; WordRefRoot.unreg;
val _ = _export "regWordRef" : (word ref -> int) -> unit; WordRefRoot.reg;
structure StringRefRoot = Root(struct type t = string ref end);
val _ = _export "getStringRef": (int -> string ref) -> unit; StringRefRoot.get;
val _ = _export "unregStringRef" : (int -> unit) -> unit; StringRefRoot.unreg;
val _ = _export "regStringRef" : (string ref -> int) -> unit; StringRefRoot.reg;
structure BoolVectorRoot = Root(struct type t = bool vector end);
val _ = _export "getBoolVector": (int -> bool vector) -> unit; BoolVectorRoot.get;
val _ = _export "unregBoolVector" : (int -> unit) -> unit; BoolVectorRoot.unreg;
val _ = _export "regBoolVector" : (bool vector -> int) -> unit; BoolVectorRoot.reg;
structure CharVectorRoot = Root(struct type t = char vector end);
val _ = _export "getCharVector": (int -> char vector) -> unit; CharVectorRoot.get;
val _ = _export "unregCharVector" : (int -> unit) -> unit; CharVectorRoot.unreg;
val _ = _export "regCharVector" : (char vector -> int) -> unit; CharVectorRoot.reg;
structure Int8VectorRoot = Root(struct type t = Int8.int vector end);
val _ = _export "getInt8Vector": (int -> Int8.int vector) -> unit; Int8VectorRoot.get;
val _ = _export "unregInt8Vector" : (int -> unit) -> unit; Int8VectorRoot.unreg;
val _ = _export "regInt8Vector" : (Int8.int vector -> int) -> unit; Int8VectorRoot.reg;
structure Int16VectorRoot = Root(struct type t = Int16.int vector end);
val _ = _export "getInt16Vector": (int -> Int16.int vector) -> unit; Int16VectorRoot.get;
val _ = _export "unregInt16Vector" : (int -> unit) -> unit; Int16VectorRoot.unreg;
val _ = _export "regInt16Vector" : (Int16.int vector -> int) -> unit; Int16VectorRoot.reg;
structure Int32VectorRoot = Root(struct type t = Int32.int vector end);
val _ = _export "getInt32Vector": (int -> Int32.int vector) -> unit; Int32VectorRoot.get;
val _ = _export "unregInt32Vector" : (int -> unit) -> unit; Int32VectorRoot.unreg;
val _ = _export "regInt32Vector" : (Int32.int vector -> int) -> unit; Int32VectorRoot.reg;
structure Int64VectorRoot = Root(struct type t = Int64.int vector end);
val _ = _export "getInt64Vector": (int -> Int64.int vector) -> unit; Int64VectorRoot.get;
val _ = _export "unregInt64Vector" : (int -> unit) -> unit; Int64VectorRoot.unreg;
val _ = _export "regInt64Vector" : (Int64.int vector -> int) -> unit; Int64VectorRoot.reg;
structure IntVectorRoot = Root(struct type t = int vector end);
val _ = _export "getIntVector": (int -> int vector) -> unit; IntVectorRoot.get;
val _ = _export "unregIntVector" : (int -> unit) -> unit; IntVectorRoot.unreg;
val _ = _export "regIntVector" : (int vector -> int) -> unit; IntVectorRoot.reg;
structure PointerVectorRoot = Root(struct type t = MLton.Pointer.t vector end);
val _ = _export "getPointerVector": (int -> MLton.Pointer.t vector) -> unit; PointerVectorRoot.get;
val _ = _export "unregPointerVector" : (int -> unit) -> unit; PointerVectorRoot.unreg;
val _ = _export "regPointerVector" : (MLton.Pointer.t vector -> int) -> unit; PointerVectorRoot.reg;
structure Real32VectorRoot = Root(struct type t = Real32.real vector end);
val _ = _export "getReal32Vector": (int -> Real32.real vector) -> unit; Real32VectorRoot.get;
val _ = _export "unregReal32Vector" : (int -> unit) -> unit; Real32VectorRoot.unreg;
val _ = _export "regReal32Vector" : (Real32.real vector -> int) -> unit; Real32VectorRoot.reg;
structure Real64VectorRoot = Root(struct type t = Real64.real vector end);
val _ = _export "getReal64Vector": (int -> Real64.real vector) -> unit; Real64VectorRoot.get;
val _ = _export "unregReal64Vector" : (int -> unit) -> unit; Real64VectorRoot.unreg;
val _ = _export "regReal64Vector" : (Real64.real vector -> int) -> unit; Real64VectorRoot.reg;
structure RealVectorRoot = Root(struct type t = real vector end);
val _ = _export "getRealVector": (int -> real vector) -> unit; RealVectorRoot.get;
val _ = _export "unregRealVector" : (int -> unit) -> unit; RealVectorRoot.unreg;
val _ = _export "regRealVector" : (real vector -> int) -> unit; RealVectorRoot.reg;
structure Word8VectorRoot = Root(struct type t = Word8.word vector end);
val _ = _export "getWord8Vector": (int -> Word8.word vector) -> unit; Word8VectorRoot.get;
val _ = _export "unregWord8Vector" : (int -> unit) -> unit; Word8VectorRoot.unreg;
val _ = _export "regWord8Vector" : (Word8.word vector -> int) -> unit; Word8VectorRoot.reg;
structure Word16VectorRoot = Root(struct type t = Word16.word vector end);
val _ = _export "getWord16Vector": (int -> Word16.word vector) -> unit; Word16VectorRoot.get;
val _ = _export "unregWord16Vector" : (int -> unit) -> unit; Word16VectorRoot.unreg;
val _ = _export "regWord16Vector" : (Word16.word vector -> int) -> unit; Word16VectorRoot.reg;
structure Word32VectorRoot = Root(struct type t = Word32.word vector end);
val _ = _export "getWord32Vector": (int -> Word32.word vector) -> unit; Word32VectorRoot.get;
val _ = _export "unregWord32Vector" : (int -> unit) -> unit; Word32VectorRoot.unreg;
val _ = _export "regWord32Vector" : (Word32.word vector -> int) -> unit; Word32VectorRoot.reg;
structure Word64VectorRoot = Root(struct type t = Word64.word vector end);
val _ = _export "getWord64Vector": (int -> Word64.word vector) -> unit; Word64VectorRoot.get;
val _ = _export "unregWord64Vector" : (int -> unit) -> unit; Word64VectorRoot.unreg;
val _ = _export "regWord64Vector" : (Word64.word vector -> int) -> unit; Word64VectorRoot.reg;
structure WordVectorRoot = Root(struct type t = word vector end);
val _ = _export "getWordVector": (int -> word vector) -> unit; WordVectorRoot.get;
val _ = _export "unregWordVector" : (int -> unit) -> unit; WordVectorRoot.unreg;
val _ = _export "regWordVector" : (word vector -> int) -> unit; WordVectorRoot.reg;
structure StringVectorRoot = Root(struct type t = string vector end);
val _ = _export "getStringVector": (int -> string vector) -> unit; StringVectorRoot.get;
val _ = _export "unregStringVector" : (int -> unit) -> unit; StringVectorRoot.unreg;
val _ = _export "regStringVector" : (string vector -> int) -> unit; StringVectorRoot.reg;
(* ALLOCATORS *)
fun makeBoolArray (n, fill) = Array.array (n, fill);
val _ = _export "makeBoolArray" : (int*bool -> bool Array.array) -> unit; (BoolArrayRoot.return o makeBoolArray);
fun makeBoolVector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeBoolVector" : (int*bool -> bool Vector.vector) -> unit; (BoolVectorRoot.return o makeBoolVector);
fun makeBoolRef v = ref v;
val _ = _export "makeBoolRef" : (bool -> bool ref) -> unit; (BoolRefRoot.return o makeBoolRef);
fun makeCharArray (n, fill) = Array.array (n, fill);
val _ = _export "makeCharArray" : (int*char -> char Array.array) -> unit; (CharArrayRoot.return o makeCharArray);
fun makeCharVector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeCharVector" : (int*char -> char Vector.vector) -> unit; (CharVectorRoot.return o makeCharVector);
fun makeCharRef v = ref v;
val _ = _export "makeCharRef" : (char -> char ref) -> unit; (CharRefRoot.return o makeCharRef);
fun makeInt8Array (n, fill) = Array.array (n, fill);
val _ = _export "makeInt8Array" : (int*Int8.int -> Int8.int Array.array) -> unit; (Int8ArrayRoot.return o makeInt8Array);
fun makeInt8Vector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeInt8Vector" : (int*Int8.int -> Int8.int Vector.vector) -> unit; (Int8VectorRoot.return o makeInt8Vector);
fun makeInt8Ref v = ref v;
val _ = _export "makeInt8Ref" : (Int8.int -> Int8.int ref) -> unit; (Int8RefRoot.return o makeInt8Ref);
fun makeInt16Array (n, fill) = Array.array (n, fill);
val _ = _export "makeInt16Array" : (int*Int16.int -> Int16.int Array.array) -> unit; (Int16ArrayRoot.return o makeInt16Array);
fun makeInt16Vector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeInt16Vector" : (int*Int16.int -> Int16.int Vector.vector) -> unit; (Int16VectorRoot.return o makeInt16Vector);
fun makeInt16Ref v = ref v;
val _ = _export "makeInt16Ref" : (Int16.int -> Int16.int ref) -> unit; (Int16RefRoot.return o makeInt16Ref);
fun makeInt32Array (n, fill) = Array.array (n, fill);
val _ = _export "makeInt32Array" : (int*Int32.int -> Int32.int Array.array) -> unit; (Int32ArrayRoot.return o makeInt32Array);
fun makeInt32Vector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeInt32Vector" : (int*Int32.int -> Int32.int Vector.vector) -> unit; (Int32VectorRoot.return o makeInt32Vector);
fun makeInt32Ref v = ref v;
val _ = _export "makeInt32Ref" : (Int32.int -> Int32.int ref) -> unit; (Int32RefRoot.return o makeInt32Ref);
fun makeInt64Array (n, fill) = Array.array (n, fill);
val _ = _export "makeInt64Array" : (int*Int64.int -> Int64.int Array.array) -> unit; (Int64ArrayRoot.return o makeInt64Array);
fun makeInt64Vector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeInt64Vector" : (int*Int64.int -> Int64.int Vector.vector) -> unit; (Int64VectorRoot.return o makeInt64Vector);
fun makeInt64Ref v = ref v;
val _ = _export "makeInt64Ref" : (Int64.int -> Int64.int ref) -> unit; (Int64RefRoot.return o makeInt64Ref);
fun makeIntArray (n, fill) = Array.array (n, fill);
val _ = _export "makeIntArray" : (int*int -> int Array.array) -> unit; (IntArrayRoot.return o makeIntArray);
fun makeIntVector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeIntVector" : (int*int -> int Vector.vector) -> unit; (IntVectorRoot.return o makeIntVector);
fun makeIntRef v = ref v;
val _ = _export "makeIntRef" : (int -> int ref) -> unit; (IntRefRoot.return o makeIntRef);
fun makePointerArray (n, fill) = Array.array (n, fill);
val _ = _export "makePointerArray" : (int*MLton.Pointer.t -> MLton.Pointer.t Array.array) -> unit; (PointerArrayRoot.return o makePointerArray);
fun makePointerVector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makePointerVector" : (int*MLton.Pointer.t -> MLton.Pointer.t Vector.vector) -> unit; (PointerVectorRoot.return o makePointerVector);
fun makePointerRef v = ref v;
val _ = _export "makePointerRef" : (MLton.Pointer.t -> MLton.Pointer.t ref) -> unit; (PointerRefRoot.return o makePointerRef);
fun makeReal32Array (n, fill) = Array.array (n, fill);
val _ = _export "makeReal32Array" : (int*Real32.real -> Real32.real Array.array) -> unit; (Real32ArrayRoot.return o makeReal32Array);
fun makeReal32Vector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeReal32Vector" : (int*Real32.real -> Real32.real Vector.vector) -> unit; (Real32VectorRoot.return o makeReal32Vector);
fun makeReal32Ref v = ref v;
val _ = _export "makeReal32Ref" : (Real32.real -> Real32.real ref) -> unit; (Real32RefRoot.return o makeReal32Ref);
fun makeReal64Array (n, fill) = Array.array (n, fill);
val _ = _export "makeReal64Array" : (int*Real64.real -> Real64.real Array.array) -> unit; (Real64ArrayRoot.return o makeReal64Array);
fun makeReal64Vector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeReal64Vector" : (int*Real64.real -> Real64.real Vector.vector) -> unit; (Real64VectorRoot.return o makeReal64Vector);
fun makeReal64Ref v = ref v;
val _ = _export "makeReal64Ref" : (Real64.real -> Real64.real ref) -> unit; (Real64RefRoot.return o makeReal64Ref);
fun makeRealArray (n, fill) = Array.array (n, fill);
val _ = _export "makeRealArray" : (int*real -> real Array.array) -> unit; (RealArrayRoot.return o makeRealArray);
fun makeRealVector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeRealVector" : (int*real -> real Vector.vector) -> unit; (RealVectorRoot.return o makeRealVector);
fun makeRealRef v = ref v;
val _ = _export "makeRealRef" : (real -> real ref) -> unit; (RealRefRoot.return o makeRealRef);
fun makeWord8Array (n, fill) = Array.array (n, fill);
val _ = _export "makeWord8Array" : (int*Word8.word -> Word8.word Array.array) -> unit; (Word8ArrayRoot.return o makeWord8Array);
fun makeWord8Vector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeWord8Vector" : (int*Word8.word -> Word8.word Vector.vector) -> unit; (Word8VectorRoot.return o makeWord8Vector);
fun makeWord8Ref v = ref v;
val _ = _export "makeWord8Ref" : (Word8.word -> Word8.word ref) -> unit; (Word8RefRoot.return o makeWord8Ref);
fun makeWord16Array (n, fill) = Array.array (n, fill);
val _ = _export "makeWord16Array" : (int*Word16.word -> Word16.word Array.array) -> unit; (Word16ArrayRoot.return o makeWord16Array);
fun makeWord16Vector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeWord16Vector" : (int*Word16.word -> Word16.word Vector.vector) -> unit; (Word16VectorRoot.return o makeWord16Vector);
fun makeWord16Ref v = ref v;
val _ = _export "makeWord16Ref" : (Word16.word -> Word16.word ref) -> unit; (Word16RefRoot.return o makeWord16Ref);
fun makeWord32Array (n, fill) = Array.array (n, fill);
val _ = _export "makeWord32Array" : (int*Word32.word -> Word32.word Array.array) -> unit; (Word32ArrayRoot.return o makeWord32Array);
fun makeWord32Vector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeWord32Vector" : (int*Word32.word -> Word32.word Vector.vector) -> unit; (Word32VectorRoot.return o makeWord32Vector);
fun makeWord32Ref v = ref v;
val _ = _export "makeWord32Ref" : (Word32.word -> Word32.word ref) -> unit; (Word32RefRoot.return o makeWord32Ref);
fun makeWord64Array (n, fill) = Array.array (n, fill);
val _ = _export "makeWord64Array" : (int*Word64.word -> Word64.word Array.array) -> unit; (Word64ArrayRoot.return o makeWord64Array);
fun makeWord64Vector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeWord64Vector" : (int*Word64.word -> Word64.word Vector.vector) -> unit; (Word64VectorRoot.return o makeWord64Vector);
fun makeWord64Ref v = ref v;
val _ = _export "makeWord64Ref" : (Word64.word -> Word64.word ref) -> unit; (Word64RefRoot.return o makeWord64Ref);
fun makeWordArray (n, fill) = Array.array (n, fill);
val _ = _export "makeWordArray" : (int*word -> word Array.array) -> unit; (WordArrayRoot.return o makeWordArray);
fun makeWordVector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeWordVector" : (int*word -> word Vector.vector) -> unit; (WordVectorRoot.return o makeWordVector);
fun makeWordRef v = ref v;
val _ = _export "makeWordRef" : (word -> word ref) -> unit; (WordRefRoot.return o makeWordRef);
fun makeStringArray (n, fill) = Array.array (n, fill);
val _ = _export "makeStringArray" : (int*string -> string Array.array) -> unit; (StringArrayRoot.return o makeStringArray);
fun makeStringVector (n, fill) = Array.vector (Array.array (n, fill));
val _ = _export "makeStringVector" : (int*string -> string Vector.vector) -> unit; (StringVectorRoot.return o makeStringVector);
fun makeStringRef v = ref v;
val _ = _export "makeStringRef" : (string -> string ref) -> unit; (StringRefRoot.return o makeStringRef);
fun testIntToInt x = 42;
val _ = _export "testIntToInt" : (int -> int) -> unit; testIntToInt;
fun testUnitToInt () = 43;
val _ = _export "testUnitToInt" : (unit -> int) -> unit; testUnitToInt;
fun testUnitToChar () = #"A";
val _ = _export "testUnitToChar" : (unit -> char) -> unit; testUnitToChar;
fun testUnitToBool () = false;
val _ = _export "testUnitToBool" : (unit -> bool) -> unit; testUnitToBool;
fun testUnitToIntArray () = let
val A = Array.array (5,0)
in
( Array.update (A,0,0)
; Array.update (A,1,1)
; Array.update (A,2,2)
; Array.update (A,3,3)
; Array.update (A,4,4)
; A )
end;
val _ = _export "testUnitToIntArray" : (unit -> int array) -> unit; (IntArrayRoot.return o testUnitToIntArray);
fun testUnitToIntRef () = ref 42;
val _ = _export "testUnitToIntRef" : (unit -> int ref) -> unit; (IntRefRoot.return o testUnitToIntRef);
(* MANDELBROT *)
fun sq (x,y) = (x*x-y*y, 2.0*x*y);
fun add (x,y) (u,v) = (x+u,y+v):real*real;
fun sub (x,y) (u,v) = (x-u,y-v):real*real;
fun abs2 (x,y) = (x*x+y*y):real;
val maxIterations = 150;
fun iterate (c,d) =
let fun loop (x,y,n) =
let val (s,t) = add (c,d) (sq (x,y))
in if (abs2(s,t) < 4.0) andalso n<maxIterations
then loop (s,t,n+1)
else n
end
in loop (c,d,0)
end;
val _ = _export "iterate" : (real*real -> int) -> unit; iterate;
fun iterateLine (x, yFrom, yTo, yDelta) =
let val l = ceil ((yTo - yFrom) / yDelta)
val line = Array.array (l, 0)
in
let fun loop (y,i) =
if y >= yTo
then line
else ( Array.update(line, i, iterate(x,y))
; loop (y+yDelta, i+1) )
in loop (yFrom, 0)
end
end
val _ = _export "iterateLine" : (real*real*real*real -> int array) -> unit; (IntArrayRoot.return o iterateLine);
fun doubleArray (A, pointerToF)
= let val f = (_import * : MLton.Pointer.t -> real -> real;) pointerToF
in
(Array.modify f A)
end;
val _ = _export "doubleArray" : ( (real array)*MLton.Pointer.t -> unit) -> unit; doubleArray;
(*** DOCUMENTATION EXAMPLE
makeUnitVec : int * int -> real array
sumVec : (real array) * (real array) -> real array
scaleVec : real * (real array) -> real array
dotVec : (real array) * (real array) -> real
clearVec : real array -> unit
modifyVec : (real array) * (real -> real) -> unit
***)
(* return the i'th basis vector of R^n *)
fun makeUnitVec (n,i) = Array.tabulate (n, fn j => if i=j+1 then 1.0 else 0.0);
val _ = _export "makeUnitVec" : ( int*int -> real array ) -> unit; (RealArrayRoot.return o makeUnitVec);
(* return the vector sum of A and B *)
fun sumVec (A:(real array),B) = Array.tabulate (Array.length A, fn i => (Array.sub (A,i)) + (Array.sub (B,i)));
val _ = _export "sumVec" : ( (real array)*(real array) -> real array ) -> unit; (RealArrayRoot.return o sumVec);
(* multiply each entry of A with s *)
fun scaleVec (A, s:real) = Array.tabulate (Array.length A, fn i => s*(Array.sub(A,i)));
val _ = _export "scaleVec" : ( (real array)*real -> real array ) -> unit; (RealArrayRoot.return o scaleVec);
(* return the dot product of A and B *)
fun dotVec (A,B) = Array.foldli (fn (i, a, x) => (Array.sub(B,i)*a+x)) 0.0 A;
val _ = _export "dotVec" : ( (real array)*(real array) -> real ) -> unit; dotVec;
(* set each entry of A to 0.0 *)
fun clearVec A = Array.modify (fn x => 0.0) A;
val _ = _export "clearVec" : ( real array -> unit ) -> unit; clearVec;
(* replace x with f(x) for each entry x of A *)
fun modifyVec (A,f) = Array.modify f A;
(* Can't export because f has type real->real *)
fun exportedModifyVec (A,pointerToF)
= let val f = (_import * : MLton.Pointer.t -> real -> real;) pointerToF
in
modifyVec (A,f)
end;
val _ = _export "modifyVec" : ( (real array)*MLton.Pointer.t ) -> unit; exportedModifyVec;
(*
(define (iterate-line x y-from y-to y-delta)
(let* ([l (inexact->exact (ceiling (/ (- y-to y-from) y-delta)))]
[line (make-vector l 0.0)])
(do ([y y-from (+ y y-delta)]
[i 0 (+ i 1)])
[(>= y y-to) line]
(vector-set! line i (iterate x y)))))
*)
--------------060904090605020203000509
Content-Type: text/plain;
name="build-test.sh"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="build-test.sh"
/home/js/mzton/mlton-shared/mlton/build/bin/mlton\
-export-header exported.h \
-shared-library true \
-cc-opt "-symbolic -shared -fPIC"\
-link-opt "-shared -Bsymbolic"\
-codegen c -default-ann 'allowFFI true' -keep g -verbose 1\
-link-opt --verbose -link-opt -Wl,-Bsymbolic test.cm
# -link-opt -Wl,-export-dynamic
# ln -s test test.so
--------------060904090605020203000509--