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

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/Semant/types/cproto.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/Semant/types/cproto.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1579, Mon Aug 2 20:54:18 2004 UTC revision 1580, Tue Aug 3 19:26:26 2004 UTC
# Line 40  Line 40 
40   *   *
41   * The prototype of a function taking arguments of types a1,...,an (n > 0)   * The prototype of a function taking arguments of types a1,...,an (n > 0)
42   * and producing a result of type r is encoded as:   * and producing a result of type r is encoded as:
43   *       (unit * [a1] * ... * [an] -> [r]) list   *       ([conv] * [a1] * ... * [an] -> [r]) list
44     *
45   * We use   * We use
46   *       (unit * [a1] * ... * [an] -> [r]) list list   *       ([conv] * [a1] * ... * [an] -> [r]) list list
47   * to specify a reentrant call.   * to specify a reentrant call.
48   *   *
49   * For n = 0 (C argument list is "(void)"), we use:   * For n = 0 (C argument list is "(void)"), we use:
50   *       (unit -> [r]) list     or      (unit -> [r]) list list   *       ([conv] -> [r]) list     or      ([conv] -> [r]) list list
51   * The use of list constructor(s) here is a trick to avoid having to construct   * The use of list constructor(s) here is a trick to avoid having to construct
52   * an actual function value of the required type when invoking the RAW_CCALL   * an actual function value of the required type when invoking the RAW_CCALL
53   * primop.  Instead, we just pass nil.  The code generator will throw away   * primop.  Instead, we just pass nil.  The code generator will throw away
54   * this value anyway.   * this value anyway.
55   * The unit type for non-empty records and non-empty argument lists   *
56   * avoids the degenerate case of 1-element (ML-)records.   * The [conv] type for non-empty records and non-empty argument lists
57     * has the additional effect of avoiding the degenerate case of
58     * 1-element (ML-)records.
59     *
60     * [conv] encodes the calling convention to be used:
61     *     [default]       = unit
62     *     [ccall]         = word    -- for x86/win32
63     *     [stdcall]       = int     -- for x86/win32
64   *)   *)
65  structure CProto : sig  structure CProto : sig
66      exception BadEncoding      exception BadEncoding
# Line 64  Line 72 
72       * a 64-bit floating point value, or an Unsafe.Object.object.       * a 64-bit floating point value, or an Unsafe.Object.object.
73       *)       *)
74      val decode : string ->      val decode : string ->
75                   { fun_ty : Types.ty, encoding : Types.ty }                   { fun_ty : Types.ty, encoding : Types.ty } ->
                  ->  
76                   { c_proto    : CTypes.c_proto,                   { c_proto    : CTypes.c_proto,
77                     ml_args    : PrimOp.ccall_type list,                     ml_args    : PrimOp.ccall_type list,
78                     ml_res_opt : PrimOp.ccall_type option,                     ml_res_opt : PrimOp.ccall_type option,
# Line 93  Line 100 
100          fun bad () = raise BadEncoding          fun bad () = raise BadEncoding
101          fun listTy t = T.CONty (BT.listTycon, [t])          fun listTy t = T.CONty (BT.listTycon, [t])
102      in      in
103          fun decode conv { encoding = t, fun_ty } = let          fun decode defaultconv { encoding = t, fun_ty } = let
104              (* The type-mapping table: *)              (* The type-mapping table: *)
105              val m =              val m =
106                  [(BT.intTy,           CT.C_signed   CT.I_int,       P.CCI32),                  [(BT.intTy,           CT.C_signed   CT.I_int,       P.CCI32),
# Line 151  Line 158 
158              val (fty, nlists) = unlist (t, 0)              val (fty, nlists) = unlist (t, 0)
159    
160              val reentrant = nlists > 1              val reentrant = nlists > 1
161    
162                fun getConv t =
163                    if TU.equalType (t, BT.unitTy) then SOME defaultconv
164                    else if TU.equalType (t, BT.wordTy) then SOME "ccall"
165                    else if TU.equalType (t, BT.intTy) then SOME "stdcall"
166                    else NONE
167          in          in
168              (* Get argument types and result type; decode them.              (* Get argument types and result type; decode them.
169               * Construct the corresponding CTypes.c_proto value. *)               * Construct the corresponding CTypes.c_proto value. *)
170              case getDomainRange fty of              case getDomainRange fty of
171                  NONE => bad ()                  NONE => bad ()
172                | SOME (d, r) =>                | SOME (d, r) =>
173                    let val (conv, argTys, argsML) =
174                            (case getConv d of
175                                 SOME conv => (conv, [], [])
176                               | NONE =>
177                                 (case BT.getFields d of
178                                      SOME (convty :: fl) =>
179                                        (case getConv convty of
180                                             SOME conv =>
181                  let val (argTys, argsML) =                  let val (argTys, argsML) =
182                          if TU.equalType (d, BT.unitTy) then ([], [])                                                   ListPair.unzip (map dt fl)
183                          else case BT.getFields d of                                           in
184                                   SOME (_ :: fl) => ListPair.unzip (map dt fl)                                               (conv, argTys, argsML)
185                                 | _ => bad ()                                           end
186                                           | NONE => bad ())
187                                    | _ => bad ()))
188                      val (retTy, retML, argsML) = rdt (r, argsML)                      val (retTy, retML, argsML) = rdt (r, argsML)
189                  in                  in
190                      { c_proto = { conv = conv,                      { c_proto = { conv = conv,

Legend:
Removed from v.1579  
changed lines
  Added in v.1580

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