Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /MLRISC/trunk/vararg-ccall/vararg-ccall.sml
ViewVC logotype

Annotation of /MLRISC/trunk/vararg-ccall/vararg-ccall.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3068 - (view) (download)

1 : mrainey 3062 structure VarargCCall =
2 :     struct
3 :    
4 :     structure DL = DynLinkage
5 :     structure Consts = VarargCCallConstants
6 :    
7 : mrainey 3068 datatype argument = I of int | R of real | B of bool | S of string
8 :    
9 : mrainey 3062 fun main's s = DL.lib_symbol (DL.main_lib, s)
10 :     val malloc_h = main's "malloc"
11 :     val free_h = main's "free"
12 :    
13 :     exception OutOfMemory
14 :    
15 :     fun sys_malloc (n : Word32.word) =
16 :     let val w_p = RawMemInlineT.rawccall :
17 :     Word32.word * Word32.word * (unit * word -> string) list
18 :     -> Word32.word
19 :     val a = w_p (DL.addr malloc_h, n, [])
20 :     in if a = 0w0 then raise OutOfMemory else a
21 :     end
22 :    
23 :     fun sys_free (a : Word32.word) =
24 :     let val p_u = RawMemInlineT.rawccall :
25 :     Word32.word * Word32.word * (unit * string -> unit) list
26 :     -> unit
27 :     in p_u (DL.addr free_h, a, [])
28 :     end
29 :    
30 :     fun alloc bytes = sys_malloc (Word32.toLargeWord bytes)
31 :     fun free a = sys_free a
32 :    
33 :     type addr = Word32.word
34 :     infix ++
35 :     fun (a: addr) ++ i = a + Word32.fromInt i
36 :    
37 :     fun set' (p, w) = RawMemInlineT.w32s (p, w)
38 :     fun nxt' p = p ++ 1
39 :    
40 :     fun cpML' { from, to } = let
41 :     val n = String.size from
42 :     fun loop (i, p) =
43 :     if i >= n then set' (p, 0w0)
44 :     else (set' (p, Word32.fromInt (Char.ord
45 :     (String.sub (from, i))));
46 :     loop (i+1, nxt' p))
47 :     in
48 :     loop (0, to)
49 :     end
50 :    
51 :     fun dupML' s = let
52 :     val z = alloc (Word32.fromInt (String.size s + 1))
53 :     in
54 :     cpML' { from = s, to = z };
55 :     z
56 :     end
57 :    
58 : mrainey 3068 (* default width of a field in a zipped argument *)
59 : mrainey 3062 val defaultWidthB = Word32.fromInt Consts.defaultWidthB
60 :     val argOffB = Word32.fromInt Consts.argOff * defaultWidthB
61 :     val kindOffB = Word32.fromInt Consts.kindOff * defaultWidthB
62 :     val locOffB = Word32.fromInt Consts.locOff * defaultWidthB
63 :     val tyOffB = Word32.fromInt Consts.tyOff * defaultWidthB
64 : mrainey 3068 val zippedArgSzB = Word32.fromInt Consts.zippedArgSzB
65 : mrainey 3062
66 :     fun set (p, off, v) = set'(p+off, v)
67 :    
68 : mrainey 3068 (* track strings allocated for the call *)
69 :     local
70 :     val allocatedStrs = ref ([] : Word32.word list)
71 :     in
72 :     fun freeStrs () = (
73 :     List.app free (!allocatedStrs);
74 :     allocatedStrs := [])
75 :     fun addStr s = allocatedStrs := s :: !allocatedStrs
76 :     end
77 :    
78 :     (* encode the argument field *)
79 :     fun encodeArg (arrPtr, I i) = set(arrPtr, argOffB, Word32.fromInt i)
80 :     | encodeArg (arrPtr, S s) = let
81 :     val strPtr = dupML' s
82 :     in
83 :     addStr strPtr;
84 :     set(arrPtr, argOffB, strPtr)
85 : mrainey 3062 end
86 : mrainey 3068 | encodeArg (arrPtr, B b) = set(arrPtr, argOffB, if b then 0w1 else 0w0)
87 :     | encodeArg (arrPtr, R r) = RawMemInlineT.f64s (arrPtr+argOffB, r)
88 : mrainey 3062
89 : mrainey 3068 (* encode a zipped argument *)
90 :     fun encodeZippedArg ((arg, k, l, ty), arrPtr) = (
91 :     encodeArg(arrPtr, arg);
92 :     set(arrPtr, kindOffB, Word32.fromInt k);
93 :     set(arrPtr, locOffB, Word32.fromInt l);
94 :     set(arrPtr, tyOffB, Word32.fromInt ty);
95 :     (* advance the pointer by one zipped argument *)
96 :     arrPtr + zippedArgSzB
97 :     )
98 : mrainey 3062
99 : mrainey 3068 (* encode an array of zipped arguments *)
100 :     fun encodeZippedArgs args = let
101 :     val nArgs = List.length args
102 :     val argsSzB = Word32.fromInt nArgs * zippedArgSzB
103 :     val arrPtr = alloc argsSzB
104 :     in
105 :     List.foldl encodeZippedArg arrPtr args;
106 :     {startCArr=arrPtr, endCArr=argsSzB+arrPtr}
107 : mrainey 3062 end
108 :    
109 :     fun vararg's s = let
110 :     val lh = DynLinkage.open_lib
111 :     { name = "./vararg", global = true, lazy = true }
112 :     in
113 :     DL.lib_symbol (lh, s)
114 :     end
115 :    
116 :     (* call the vararg interpreter *)
117 : mrainey 3068 fun vararg (cFun, zippedArgs) = let
118 :     val vararg_h = vararg's Consts.varargInterpreter
119 : mrainey 3062 val callInterp = RawMemInlineT.rawccall :
120 :     Word32.word * (Word32.word * Word32.word * Word32.word) *
121 :     (unit * Word32.word * Word32.word * Word32.word -> Word32.word) list
122 :     -> Word32.word
123 :     val cFunAddr = DL.addr (vararg's cFun)
124 : mrainey 3068 val {startCArr, endCArr} = encodeZippedArgs zippedArgs
125 :     (* call the interpreter *)
126 :     val x = callInterp (DL.addr vararg_h, (cFunAddr, startCArr, endCArr), [])
127 : mrainey 3062 in
128 : mrainey 3068 freeStrs();
129 :     free startCArr;
130 :     x
131 : mrainey 3062 end
132 :    
133 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0