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/MLRISC/ppc/c-calls/ppc-macosx.sml
ViewVC logotype

Diff of /sml/trunk/src/MLRISC/ppc/c-calls/ppc-macosx.sml

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

revision 1443, Sun Jan 25 19:27:10 2004 UTC revision 1532, Tue Jul 13 03:49:10 2004 UTC
# Line 80  Line 80 
80  functor PPCMacOSX_CCalls (  functor PPCMacOSX_CCalls (
81    
82      structure T : MLTREE      structure T : MLTREE
     val ix : (T.stm, T.rexp, T.fexp, T.ccexp) PPCInstrExt.sext -> T.sext  
83    
84    ): PPC_MACOSX_C_CALLS = struct    ): C_CALLS = struct
85    
86      structure T  = T      structure T  = T
87      structure Ty = CTypes      structure CTy = CTypes
88      structure C = PPCCells      structure C = PPCCells
     structure IX = PPCInstrExt  
89    
90      fun error msg = MLRiscErrorMsg.error ("PPCCompCCalls", msg)      fun error msg = MLRiscErrorMsg.error ("PPCCompCCalls", msg)
91    
92      datatype arg_loc    (* the location of arguments/parameters; offsets are given with respect to the
93        = GPR of C.cell     * low end of the parameter area.
94        | FPR of C.cell     *)
95        | STK      datatype arg_location
96          = Reg of T.ty * T.reg * T.I.machine_int option
97      type arg_pos = {                                          (* integer/pointer argument in register *)
98          offset : int,           (* stack offset of memory for argument *)        | FReg of T.fty * T.reg * T.I.machine_int option
99          loc : arg_loc           (* location where argument is passed *)                                          (* floating-point argument in register *)
100        }        | Stk of T.ty * T.I.machine_int   (* integer/pointer argument in parameter area *)
101          | FStk of T.fty * T.I.machine_int (* floating-point argument in parameter area *)
102      datatype c_arg        | Args of arg_location list
103        = ARG of T.rexp  
104        | FARG of T.fexp      val wordTy = 32
105        | ARGS of c_arg list      val fltTy = 32      (* MLRISC type of float *)
106        val dblTy = 64      (* MLRISC type of double *)
     val mem = T.Region.memory  
     val stack = T.Region.memory  
   
     val maxRegArgs = 6  
     val paramAreaOffset = 68  
   
     fun LI i = T.LI(T.I.fromInt (32, i))  
   
     fun reg r = C.GPReg r  
     fun freg r = C.FPReg r  
   
     fun reg32 r = T.REG(32, r)  
     fun freg64 r = T.FREG(64, r)  
107    
108    (* stack pointer *)    (* stack pointer *)
109      val sp = reg1      val spReg = T.REG(wordTy, C.GPReg 1)
     val spR = reg32 sp  
110    
111      fun addli (x, 0) = x    (* registers used for parameter passing *)
112        | addli (x, d) = let      val argGPRs = List.map C.GPReg [3, 4, 5, 6, 7, 8, 9, 10]
113            val d' = T.I.fromInt (32, d)      val argFPRs = List.map C.FPReg [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13]
114            in      val resGPR = C.GPReg 3
115              case x      val resRegLoc = Reg(wordTy, resGPR, NONE)
116               of T.ADD (_, r, T.LI d) =>      val resFPR = C.FPReg 1
117                    T.ADD (32, r, T.LI (T.I.ADD (32, d, d')))  
118                | _ => T.ADD (32, x, T.LI d')    (* C callee-save registers *)
119              (* end case *)      val calleeSaveRegs = List.map C.GPReg [
120            end              13, 14, 15, 16, 17, 18, 19, 20, 21, 22,
121                23, 24, 25, 26, 27, 28, 29, 30, 31
122              ]
123        val calleeSaveFRegs = List.map C.FPReg [
124                14, 15, 16, 17, 18, 19, 20, 21, 22,
125                23, 24, 25, 26, 27, 28, 29, 30, 31
126              ]
127    
128      (* C caller-save registers (including argument registers) *)
129        val callerSaveRegs =
130              T.FPR(T.FREG(dblTy, C.FPReg 0)) ::
131                (List.map (fn r => T.GPR(T.REG(wordTy, C.GPReg r))) [2, 11, 12])
132    
133      fun argaddr n = addli (spreg, paramAreaOffset + 4*n)      val linkReg = T.GPR(T.REG(wordTy, C.lr))
134    
135    (* layout information for C types; note that stack and struct alignment    (* the parameter area lies just above the linkage area in the caller's frame.
136     * are different for some types     * The linkage area is 24 bytes, so the first parameter is at 24(sp).
137     *)     *)
138      type layout_info = {      val paramAreaOffset = 24
         sz : int,  
         stkAlign : int,  
         structAlign : int  
       }  
139    
140      fun roundup (i, a) = a * ((i + a - 1) div a)    (* size, padding, and natural alignment for integer types.  Note that the
141       * padding is based on the parameter-passing description on p. 35 of the
142    (* layout information for integer types *)     * documentation and the alignment is from p. 31.
143      local     *)
144        fun layout n = {sz = n, stkAlign = n, structAlign = n}      fun sizeOf CTy.I_char = {sz = 1, pad = 3, align = 1}
145          | sizeOf CTy.I_short = {sz = 2, pad = 2, align = 2}
146        fun intSizeAndAlign Ty.I_char = layout 1        | sizeOf CTy.I_int = {sz = 4, pad = 0, align = 4}
147          | intSizeAndAlign Ty.I_short = layout 2        | sizeOf CTy.I_long = {sz = 4, pad = 0, align = 4}
148          | intSizeAndAlign Ty.I_int = layout 4        | sizeOf CTy.I_long_long = {sz = 8, pad = 0, align = 8}
         | intSizeAndAlign Ty.I_long = layout 4  
         | intSizeAndAlign Ty.I_long_long = {sz = 8, stkAlign = 8, structAlign = 4}  
149    
150      in    (* sizes of other C types *)
151        val sizeOfPtr = {sz = 4, pad = 0, align = 4}
152    
153    (* calculate size and alignment for a C type *)    (* compute the size and alignment information for a struct; tys is the list
154      fun szal (T.C_unsigned ty) = intSizeAndAlign ty     * of member types.  The alignment is what Apple calls the "embedding" alignment.
       | szal (T.C_signed ty) = intSizeAndAlign ty  
       | szal Ty.C_void = raise Fail "unexpected void type"  
       | szal Ty.C_float = layout 4  
       | szal Ty.C_PTR = layout 4  
       | szal Ty.C_double = {sz = 8, stkAlign = 8, structAlign = 4}  
       | szal (Ty.C_long_double) = {sz = 8, stkAlign = 8, structAlign = 4}  
       | szal (Ty.C_ARRAY(t, n)) = let  
           val a = szal t  
           in  
             {sz = n * #sz a, stkAlign = ?, structAlign = #structAlign a}  
           end  
       | szal (Ty.C_STRUCT l) = let  
 (* FIXME: the rules for structs are more complicated (and they also depend  
  * on the alignment mode).  In Power alignment, 8-byte quantites like  
  * long long and double are 4-byte aligned in structs.  
  *)  
         (* i: next free memory address (relative to struct start);  
          * a: current total alignment,  
          * l: list of struct member types  
155           *)           *)
156            fun pack (i, a, []) =      fun sizeOfStruct tys = let
157              (* when we are done with all elements, the total size          (* align the address to the given alignment, which must be a power of 2 *)
158               * of the struct must be padded out to its own alignment            fun alignAddr (addr, align) = let
159               *)                  val mask = Word.fromInt(align-1)
160                  (roundup (i, a), a)                  in
161              | pack (i, a, t :: tl) = let                    Word.toIntX(Word.andb(Word.fromInt addr + mask, Word.notb mask))
                 val (ts, ta) = szal t (* size and alignment for member *)  
                 in  
                 (* member must be aligned according to its own  
                  * alignment requirement; the next free position  
                  * is then at "aligned member-address plus member-size";  
                  * new total alignment is max of current alignment  
                  * and member alignment (assuming all alignments are  
                  * powers of 2) *)  
                   pack (roundup (i, ta) + ts, Int.max (a, ta), tl)  
                 end  
           in  
             pack (0, 1, l)  
162            end            end
163              fun sz CTy.C_void = error "unexpected void argument type"
164                | sz CTy.C_float = {sz = 4, align = 4}
165                | sz CTy.C_double = {sz = 8, align = 8}
166                | sz CTy.C_long_double = {sz = 8, align = 8}
167                | sz (CTy.C_unsigned isz) = let
168                    val {sz, align, ...} = sizeOf isz
169                    in
170                      {sz = sz, align = align}
171      end      end
172                | sz (CTy.C_signed isz) = let
173      datatype arg                  val {sz, align, ...} = sizeOf isz
       = Simple of (Ty.c_type * arg_pos)         (* includes arrays *)  
       | Struct of arg list  
   
   (* layout arguments *)  
     fun layout argTys = let  
           fun assign ([], _, _, offset, args) = (offset, List.rev args)  
             | assign (x::xs, gprs, fprs, offset, args) = let  
                 fun assignInt sz = (case (sz, gprs)  
                        of (_, []) =>  
                             assign(xs, [], fprs,  
                         | (8, [r]) =>  
                         | (8, r1::r2::rs) =>  
                         | (_, r::rs) =>  
                       (* end case *))  
174                  in                  in
175                    case x                    {sz = sz, align = align}
176                     of (Ty.C_unsigned _) => assignInt x                  end
177                      | (Ty.C_signed _) => assignInt x              | sz CTy.C_PTR = {sz = 4, align = 4}
178                      | (Ty.C_PTR) => assignInt x              | sz (CTy.C_ARRAY(ty, n)) = let
179                      | (Ty.C_float) => assignFlt x                  val {sz, align} = sz ty
180                      | (Ty.C_double) => assignFlt x                  in
181                      | (Ty.C_long_double) => assignFlt x                    {sz = n*sz, align = align}
                     | (Ty.C_ARRAY(ty, n)) =>  
                     | (Ty.CSTRUCT tys) =>  
                   (* end case *)  
182                  end                  end
183                | sz (CTy.C_STRUCT tys) = ssz tys
184              and ssz [] = {sz = 0, align = 4}
185                | ssz (first::rest) = let
186                    fun f ([], maxAlign, offset) =
187                          {sz = alignAddr(offset, maxAlign), align = maxAlign}
188                      | f (ty::tys, maxAlign, offset) = let
189                            val {sz, align} = sz ty
190                            val align = Int.min(align, 4)
191                            val offset = alignAddr(offset, align)
192            in            in
193                              f (tys, Int.max(maxAlign, align), offset+sz)
194                            end
195                    val {sz, align} = sz first
196                    in
197                      f (rest, align, sz)
198                    end
199              in
200                #sz(ssz tys)
201            end            end
202    
203      fun genCall { name, proto, paramAlloc, structRet, saveRestoreDedicated,    (* compute the layout of a C call's arguments *)
204                    callComment, args } = let      fun layout {conv, retTy, paramTys} = let
205          val { conv, retTy, paramTys } = proto            fun gprRes isz = (case #sz(sizeOf isz)
206          val _ = case conv of                   of 8 => raise Fail "register pairs not yet supported"
207                      ("" | "ccall") => ()                    | _ => SOME resRegLoc
208                    | _ => error (concat ["unknown calling convention \"",                  (* end case *))
209                                          String.toString conv, "\""])            val (resLoc, argGPRs, structRet) = (case retTy
210          val res_szal =                   of CTy.C_void => (NONE, argGPRs, NONE)
211              case retTy of                    | CTy.C_float => (SOME(FReg(fltTy, resFPR, NONE)), argGPRs, NONE)
212                  (Ty.C_long_double | Ty.C_STRUCT _) => SOME (szal retTy)                    | CTy.C_double => (SOME(FReg(dblTy, resFPR, NONE)), argGPRs, NONE)
213                | _ => NONE                    | CTy.C_long_double => (SOME(FReg(dblTy, resFPR, NONE)), argGPRs, NONE)
214                      | CTy.C_unsigned isz => (gprRes isz, argGPRs, NONE)
215          val nargwords = let                    | CTy.C_signed isz => (gprRes isz, argGPRs, NONE)
216              fun loop ([], n) = n                    | CTy.C_PTR => (SOME resRegLoc, argGPRs, NONE)
217                | loop (t :: tl, n) =                    | CTy.C_ARRAY _ => error "array return type"
218                  loop (tl, (case t of                    | CTy.C_STRUCT s => let
219                                 (Ty.C_double | Ty.C_signed Ty.I_long_long |                        val sz = sizeOfStruct s
220                                  Ty.C_unsigned Ty.I_long_long) => 2                        in
221                               | _ => 1) + n)                        (* Note that this is a place where the MacOS X and Linux ABIs differ.
222          in                         * In Linux, GPR3/GPR4 are used to return composite values of 8 bytes.
             loop (paramTys, 0)  
         end  
   
         val regargwords = Int.min (nargwords, maxRegArgs)  
         val stackargwords = Int.max (nargwords, maxRegArgs) - maxRegArgs  
   
         val stackargsstart = paramAreaOffset + 4 * maxRegArgs  
   
         val scratchstart = stackargsstart + 4 * stackargwords  
   
         (* Copy struct or part thereof to designated area on the stack.  
          * An already properly aligned address (relative to %sp) is  
          * in to_off. *)  
         fun struct_copy (sz, al, ARG a, t, to_off, cpc) =  
             (* Two main cases here:  
              *   1. t is C_STRUCT _: in this case "a" computes the address  
              *      of the struct to be copied.  
              *   2. t is some other non-floating type; "a" computes the  
              *      the corresponding value (i.e., not its address).  
223               *)               *)
224              let fun ldst ty =                          if (sz > 4)
225                      T.STORE (ty, addli (spreg, to_off), a, stack) :: cpc                            then (SOME resRegLoc, List.tl argGPRs, SOME{szb=sz, align=4})
226                              else (SOME resRegLoc, argGPRs, NONE)
227                          end
228                    (* end case *))
229              fun assign ([], offset, _, _, layout) = List.rev layout
230                | assign (ty::tys, offset, availGPRs, availFPRs, layout) = (
231                    case ty
232                     of CTy.C_void => error "unexpected void tyument type"
233                      | CTy.C_float => (case (availGPRs, availFPRs)
234                           of (_::gprs, fpr::fprs) =>
235                                assign (tys, offset+4, gprs, fprs, FReg(fltTy, fpr, SOME offset)::layout)
236                            | ([], fpr::fprs) =>
237                                assign (tys, offset+4, [], fprs, FReg(fltTy, fpr, SOME offset)::layout)
238                            | ([], []) =>
239                                assign (tys, offset+4, [], [], FStk(fltTy, offset)::layout)
240                          (* end case *))
241                      | CTy.C_double =>
242                          assignFPR (tys, offset, availGPRs, availFPRs, layout)
243                      | CTy.C_long_double =>
244                          assignFPR (tys, offset, availGPRs, availFPRs, layout)
245                      | CTy.C_unsigned isz =>
246                          assignGPR(sizeOf isz, tys, offset, availGPRs, availFPRs, layout)
247                      | CTy.C_signed isz =>
248                          assignGPR(sizeOf isz, tys, offset, availGPRs, availFPRs, layout)
249                      | CTy.C_PTR =>
250                          assignGPR(sizeOfPtr, tys, offset, availGPRs, availFPRs, layout)
251                      | CTy.C_ARRAY _ =>
252                          assignGPR(sizeOfPtr, tys, offset, availGPRs, availFPRs, layout)
253                      | CTy.C_STRUCT tys' => raise Fail "struct arguments not supported yet"
254                    (* end case *))
255            (* assign a GP register and memory for an integer/pointer argument. *)
256              and assignGPR ({sz, pad, ...}, args, offset, availGPRs, availFPRs, layout) = let
257                    val (loc, availGPRs) = (case (sz, availGPRs)
258                           of (8, _) => raise Fail "register pairs not yet supported"
259                            | (_, []) => (Stk(wordTy, offset), [])
260                            | (_, r1::rs) => (Reg(wordTy, r1, SOME offset), rs)
261                          (* end case *))
262                    val offset = offset + IntInf.fromInt(sz + pad)
263              in              in
264                  case t of                    assign (args, offset, availGPRs, availFPRs, loc::layout)
265                      (Ty.C_void | Ty.C_PTR |                  end
266                       Ty.C_signed (Ty.I_int | Ty.I_long) |          (* assign a FP register and memory/GPRs for double-precision argument. *)
267                       Ty.C_unsigned (Ty.I_int | Ty.I_long)) => ldst 32            and assignFPR (args, offset, availGPRs, availFPRs, layout) = let
268                    | (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) => ldst 8                  fun continue (availGPRs, availFPRs, loc) =
269                    | (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>                        assign (args, offset+8, availGPRs, availFPRs, loc::layout)
270                      ldst 16                  fun freg fpr = FReg(dblTy, fpr, SOME offset)
271                    | (Ty.C_signed Ty.I_long_long |                  in
272                       Ty.C_unsigned Ty.I_long_long) => ldst 64                    case (availGPRs, availFPRs)
273                    | (Ty.C_ARRAY _) =>                     of (_::_::gprs, fpr::fprs) => continue (gprs, fprs, freg fpr)
274                      error "ARRAY within gather/scatter struct"                      | (_, fpr::fprs) => continue ([], fprs, freg fpr)
275                    | (Ty.C_STRUCT _) =>                      | ([], []) => continue ([], [], FStk(dblTy, offset))
276                      (* Here we have to do the equivalent of a "memcpy". *)                    (* end case *)
277                      let val from = a (* argument is address of struct *)                  end
278                          fun cp (ty, incr) = let            in {
279                              fun load_from from_off =              argLocs = assign (paramTys, 0, argGPRs, argFPRs, []),
280                                  T.LOAD (32, addli (from, from_off), mem)              resLoc = resLoc,
281                              (* from_off is relative to from,              structRetLoc = structRet
282                               * to_off is relative to %sp *)            } end
                             fun loop (i, from_off, to_off, cpc) =  
                                 if i <= 0 then cpc  
                                 else loop (i - incr,  
                                            from_off + incr, to_off + incr,  
                                            T.STORE (ty, addli (spreg, to_off),  
                                                     load_from from_off,  
                                                     stack)  
                                            :: cpc)  
                         in  
                             loop (sz, 0, to_off, cpc)  
                         end  
                     in  
                         case al of  
                             1 => cp (8, 1)  
                           | 2 => cp (16, 2)  
                           | _ => (* 4 or more *) cp (32, 4)  
                     end  
                   | (Ty.C_float | Ty.C_double | Ty.C_long_double) =>  
                     error "floating point type does not match ARG"  
             end  
           | struct_copy (_, _, ARGS args, Ty.C_STRUCT tl, to_off, cpc) =  
             (* gather/scatter case *)  
             let fun loop ([], [], _, cpc) = cpc  
                   | loop (t :: tl, a :: al, to_off, cpc) = let  
                         val (tsz, tal) = szal t  
                         val to_off' = roundup (to_off, tal)  
                         val cpc' = struct_copy (tsz, tal, a, t, to_off', cpc)  
                     in  
                         loop (tl, al, to_off' + tsz, cpc')  
                     end  
                   | loop _ =  
                     error "number of types does not match number of arguments"  
             in  
                 loop (tl, args, to_off, cpc)  
             end  
           | struct_copy (_, _, ARGS _, _, _, _) =  
             error "gather/scatter for non-struct"  
           | struct_copy (sz, al, FARG a, t, to_off, cpc) =  
             let fun fldst ty =  
                    T.FSTORE (ty, addli (spreg, to_off), a, stack) :: cpc  
             in  
                 case t of  
                     Ty.C_float => fldst 32  
                   | Ty.C_double => fldst 64  
                   | Ty.C_long_double => fldst 128  
                   | _ => error "non-floating-point type does not match FARG"  
             end  
   
         val (stackdelta, argsetupcode, copycode) = let  
             fun loop ([], [], _, ss, asc, cpc) =  
                 (roundup (Int.max (0, ss - stackargsstart), 8), asc, cpc)  
               | loop (t :: tl, a :: al, n, ss, asc, cpc) = let  
                     fun wordassign a =  
                         if n < 6 then T.MV (32, oreg n, a)  
                         else T.STORE (32, argaddr n, a, stack)  
                     fun wordarg (a, cpc, ss) =  
                         loop (tl, al, n + 1, ss, wordassign a :: asc, cpc)  
   
                     fun dwordmemarg (addr, region, tmpstore) = let  
                         fun toreg (n, addr) =  
                             T.MV (32, oreg n, T.LOAD (32, addr, region))  
                         fun tomem (n, addr) =  
                             T.STORE (32,  
                                      argaddr n,  
                                      T.LOAD (32, addr, region),  
                                      stack)  
                         fun toany (n, addr) =  
                             if n < 6 then toreg (n, addr) else tomem (n, addr)  
                     in  
                         (* if n < 6 andalso n div 2 = 0 then  
                          *     use ldd here once MLRISC gets its usage right  
                          * else  
                          *   ... *)  
                         loop (tl, al, n+2, ss,  
                               tmpstore @  
                               toany (n, addr)  
                               :: toany (n+1, addli (addr, 4))  
                               :: asc,  
                               cpc)  
                     end  
                     fun dwordarg mkstore =  
                         if n > 6 andalso n div 2 = 1 then  
                             (* 8-byte aligned memory *)  
                             loop (tl, al, n+2, ss,  
                                   mkstore (argaddr n) :: asc,  
                                   cpc)  
                         else dwordmemarg (tmpaddr, stack, [mkstore tmpaddr])  
                 in  
                     case (t, a) of  
                         ((Ty.C_void | Ty.C_PTR | Ty.C_ARRAY _ |  
                           Ty.C_unsigned (Ty.I_int | Ty.I_long) |  
                           Ty.C_signed (Ty.I_int | Ty.I_long)),  
                          ARG a) => wordarg (a, cpc, ss)  
                       | (Ty.C_signed Ty.I_char, ARG a) =>  
                         wordarg (T.SX (32, 8, a), cpc, ss)  
                       | (Ty.C_unsigned Ty.I_char, ARG a) =>  
                         wordarg (T.ZX (32, 8, a), cpc, ss)  
                       | (Ty.C_signed Ty.I_short, ARG a) =>  
                         wordarg (T.SX (32, 16, a), cpc, ss)  
                       | (Ty.C_unsigned Ty.I_short, ARG a) =>  
                         wordarg (T.ZX (32, 16, a), cpc, ss)  
                       | ((Ty.C_signed Ty.I_long_long |  
                           Ty.C_unsigned Ty.I_long_long), ARG a) =>  
                         (case a of  
                              T.LOAD (_, addr, region) =>  
                              dwordmemarg (addr, region, [])  
                            | _ => dwordarg (fn addr =>  
                                                T.STORE (64, addr, a, stack)))  
                       | (Ty.C_float, FARG a) =>  
                         (* we use the stack region reserved for storing  
                          * %o0-%o5 as temporary storage for transferring  
                          * floating point values *)  
                         (case a of  
                              T.FLOAD (_, addr, region) =>  
                              wordarg (T.LOAD (32, addr, region), cpc, ss)  
                            | _ =>  
                              if n < 6 then let  
                                  val ld = T.MV (32, oreg n,  
                                                 T.LOAD (32, tmpaddr, stack))  
                                  val cp = T.FSTORE (32, tmpaddr, a, stack)  
                              in  
                                  loop (tl, al, n + 1, ss, cp :: ld :: asc, cpc)  
                              end  
                              else loop (tl, al, n + 1, ss,  
                                         T.FSTORE (32, argaddr n, a, stack)  
                                         :: asc,  
                                         cpc))  
                       | (Ty.C_double, FARG a) =>  
                         (case a of  
                              T.FLOAD (_, addr, region) =>  
                              dwordmemarg (addr, region, [])  
                            | _ => dwordarg (fn addr =>  
                                                T.FSTORE (64, addr, a, stack)))  
                       | (Ty.C_long_double, FARG a) => let  
                             (* Copy 128-bit floating point value (16 bytes)  
                              * into scratch space (aligned at 8-byte boundary).  
                              * The address of the scratch copy is then  
                              * passed as a regular 32-bit argument. *)  
                             val ss' = roundup (ss, 8)  
                             val ssaddr = addli (spreg, ss')  
                         in  
                             wordarg (ssaddr,  
                                      T.FSTORE (128, ssaddr, a, stack) :: cpc,  
                                      ss' + 16)  
                         end  
                       | (t as Ty.C_STRUCT _, a) => let  
                             (* copy entire struct into scratch space  
                              * (aligned according to struct's alignment  
                              * requirements).  The address of the scratch  
                              * copy is then passed as a regular 32-bit  
                              * argument. *)  
                             val (sz, al) = szal t  
                             val ss' = roundup (ss, al)  
                             val ssaddr = addli (spreg, ss')  
                             val cpc' = struct_copy (sz, al, a, t, ss', cpc)  
                         in  
                             wordarg (ssaddr, cpc', ss' + sz)  
                         end  
                       | _ => error "argument/type mismatch"  
                 end  
               | loop _ = error "wrong number of arguments"  
         in  
             loop (paramTys, args, 0, scratchstart, [], [])  
         end  
   
         val (defs, uses) = let  
             val gp = T.GPR o reg32  
             val fp = T.FPR o freg64  
             val g_regs = map (gp o greg) [1, 2, 3, 4, 5, 6, 7]  
             val a_regs = map (gp o oreg) [0, 1, 2, 3, 4, 5]  
             val l_reg = gp (oreg 7)  
             val f_regs = map (fp o freg)  
                              [0, 2, 4, 6, 8, 10, 12, 14,  
                               16, 18, 20, 22, 24, 26, 28, 30]  
             (* a call instruction defines all caller-save registers:  
              *   - %g1 - %g7  
              *   - %o0 - %o5 (argument registers)  
              *   - %o7       (link register)  
              *   - all fp registers *)  
   
             val defs = g_regs @ a_regs @ l_reg :: f_regs  
             (* A call instruction "uses" just the argument registers. *)  
             val uses = List.take (a_regs, regargwords)  
         in  
             (defs, uses)  
         end  
   
         val result =  
             case retTy of  
                 Ty.C_float => [T.FPR (T.FREG (32, FP 0))]  
               | Ty.C_double => [T.FPR (T.FREG (64, FP 0))] (* %f0/%f1 *)  
               | Ty.C_long_double => []  
               | Ty.C_STRUCT _ => []  
               | Ty.C_ARRAY _ => error "array return type"  
               | (Ty.C_PTR | Ty.C_void |  
                  Ty.C_signed (Ty.I_int | Ty.I_long) |  
                  Ty.C_unsigned (Ty.I_int | Ty.I_long)) =>  
                 [T.GPR (T.REG (32, oreg 0))]  
               | (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) =>  
                 [T.GPR (T.REG (8, oreg 0))]  
               | (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>  
                 [T.GPR (T.REG (16, oreg 0))]  
               | (Ty.C_signed Ty.I_long_long | Ty.C_unsigned Ty.I_long_long) =>  
                 [T.GPR (T.REG (64, oreg 0))]  
283    
284          val { save, restore } = saveRestoreDedicated defs      datatype c_arg
285          = ARG of T.rexp
286          | FARG of T.fexp
287          | ARGS of c_arg list
288    
289          val (sretsetup, srethandshake) =      val memRg = T.Region.memory
290              case res_szal of      val stkRg = T.Region.memory
291                  NONE => ([], [])  
292                | SOME (sz, al) => let    (* SP-based address of parameter at given offset *)
293                      val addr = structRet { szb = sz, align = al }      fun paramAddr off =
294              T.ADD(wordTy, spReg, T.LI(off + IntInf.fromInt paramAreaOffset))
295    
296        fun genCall {
297              name, proto, paramAlloc, structRet, saveRestoreDedicated,
298              callComment, args
299            } = let
300              val {conv, retTy, paramTys} = proto
301              val {argLocs, resLoc, structRetLoc} = layout proto
302            (* generate code to assign the arguments to their locations *)
303              fun assignArgs ([], [], stms) = stms
304                | assignArgs (Reg(ty, r, _) :: locs, ARG exp :: args, stms) =
305                    assignArgs (locs, args, T.MV(ty, r, exp) :: stms)
306                | assignArgs (Stk(ty, off) :: locs, ARG exp :: args, stms) =
307                    assignArgs (locs, args, T.STORE(ty, paramAddr off, exp, stkRg) :: stms)
308                | assignArgs (FReg(ty, r, _) :: locs, FARG fexp :: args, stms) =
309                    assignArgs (locs, args, T.FMV(ty, r, fexp) :: stms)
310                | assignArgs (FStk(ty, off) :: locs, FARG fexp :: args, stms) =
311                    assignArgs (locs, args, T.FSTORE(ty, paramAddr off, fexp, stkRg) :: stms)
312                | assignArgs ((Args locs') :: locs, (ARGS args') :: args, stms) =
313                    assignArgs (locs, args, assignArgs(locs', args', stms))
314                | assignArgs _ = error "argument/formal mismatch"
315              val argSetupCode = List.rev(assignArgs(argLocs, args, []))
316            (* convert the result location to an MLRISC expression list *)
317              val result = (case resLoc
318                     of NONE => []
319                      | SOME(Reg(ty, r, _)) => [T.GPR(T.REG(ty, r))]
320                      | SOME(FReg(ty, r, _)) => [T.FPR(T.FREG(ty, r))]
321                      | SOME _ => raise Fail "bogus result location"
322                    (* end case *))
323            (* make struct return-area setup (if necessary) *)
324              val setupStructRet = (case structRetLoc
325                     of NONE => []
326                      | SOME loc => let
327                          val structAddr = structRet loc
328                  in                  in
329                      ([T.STORE (32, addli (spreg, 64), addr, stack)],                          [T.MV(wordTy, resGPR, structAddr)]
                      [T.EXT (ix (IX.UNIMP sz))])  
330                  end                  end
331                    (* end case *))
332          val call = T.CALL { funct = name, targets = [],          (* determine the registers used and defined by this call *)
333              val (uses, defs) = let
334                    val locs = (case resLoc
335                           of NONE => argLocs
336                            | SOME loc => loc::argLocs
337                          (* end case *))
338                  (* get the list of registers used to pass arguments and results *)
339                    fun addArgReg (Reg(ty, r, _)::locs, argRegs) =
340                          addArgReg (locs, T.GPR(T.REG(ty, r))::argRegs)
341                      | addArgReg (FReg(ty, r, _)::locs, argRegs) =
342                          addArgReg (locs, T.FPR(T.FREG(ty, r))::argRegs)
343                      | addArgReg ((Args locs')::locs, argRegs) =
344                          addArgReg (locs, addArgReg(locs', argRegs))
345                      | addArgReg (_::locs, argRegs) = addArgReg(locs, argRegs)
346                      | addArgReg ([], argRegs) = rev argRegs
347                    val argRegs = addArgReg (locs, [])
348                    in
349                      (argRegs, linkReg :: callerSaveRegs)
350                    end
351            (* the actual call instruction *)
352              val callStm = T.CALL {
353                      funct = name, targets = [],
354                              defs = defs, uses = uses,                              defs = defs, uses = uses,
355                              region = mem, pops = 0 }                    region = memRg, pops = 0
356                    }
357          val call =          (* annotate, if necessary *)
358              case callComment of            val callStm = (case callComment
359                  NONE => call                   of NONE => callStm
360                | SOME c =>                    | SOME c => T.ANNOTATION(callStm, #create MLRiscAnnotations.COMMENT c)
361                  T.ANNOTATION (call, #create MLRiscAnnotations.COMMENT c)                  (* end case *))
362            (* take care of dedicated client registers *)
363          val (sp_sub, sp_add) =            val {save, restore} = saveRestoreDedicated defs
364              if stackdelta = 0 then ([], []) else            val callseq = List.concat [
365              if paramAlloc { szb = stackdelta, align = 4 } then ([], [])                    setupStructRet,
366              else ([T.MV (32, sp, T.SUB (32, spreg, LI stackdelta))],                    argSetupCode,
                   [T.MV (32, sp, addli (spreg, stackdelta))])  
   
         val callseq =  
             List.concat [sp_sub,  
                          copycode,  
                          argsetupcode,  
                          sretsetup,  
367                           save,                           save,
368                           [call],                    [callStm],
369                           srethandshake,                    restore
370                           restore,                  ]
371                           sp_add]            in
372              (* check calling convention *)
373      in              case conv
374                 of ("" | "ccall") => ()
375                  | _ => error (concat [
376                        "unknown calling convention \"",
377                        String.toString conv, "\""
378                      ])
379                (* end case *);
380          { callseq = callseq, result = result }          { callseq = callseq, result = result }
381      end      end
382    
383  end  end

Legend:
Removed from v.1443  
changed lines
  Added in v.1532

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