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 1438, Mon Jan 12 03:12:20 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          | Args of arg_location list
103    
104        val wordTy = 32
105        val fltTy = 32      (* MLRISC type of float *)
106        val dblTy = 64      (* MLRISC type of double *)
107    
108      (* stack pointer *)
109        val spReg = T.REG(wordTy, C.GPReg 1)
110    
111      (* registers used for parameter passing *)
112        val argGPRs = List.map C.GPReg [3, 4, 5, 6, 7, 8, 9, 10]
113        val argFPRs = List.map C.FPReg [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13]
114        val resGPR = C.GPReg 3
115        val resRegLoc = Reg(wordTy, resGPR, NONE)
116        val resFPR = C.FPReg 1
117    
118      (* C callee-save registers *)
119        val calleeSaveRegs = List.map C.GPReg [
120                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      datatype c_arg      val linkReg = T.GPR(T.REG(wordTy, C.lr))
       = ARG of T.rexp  
       | FARG of T.fexp  
       | ARGS of c_arg list  
134    
135      val mem = T.Region.memory    (* the parameter area lies just above the linkage area in the caller's frame.
136      val stack = T.Region.memory     * The linkage area is 24 bytes, so the first parameter is at 24(sp).
137       *)
138        val paramAreaOffset = 24
139    
140      val maxRegArgs = 6    (* size, padding, and natural alignment for integer types.  Note that the
141      val paramAreaOffset = 68     * padding is based on the parameter-passing description on p. 35 of the
142       * documentation and the alignment is from p. 31.
143       *)
144        fun sizeOf CTy.I_char = {sz = 1, pad = 3, align = 1}
145          | sizeOf CTy.I_short = {sz = 2, pad = 2, align = 2}
146          | sizeOf CTy.I_int = {sz = 4, pad = 0, align = 4}
147          | sizeOf CTy.I_long = {sz = 4, pad = 0, align = 4}
148          | sizeOf CTy.I_long_long = {sz = 8, pad = 0, align = 8}
149    
150      fun LI i = T.LI (T.I.fromInt (32, i))    (* sizes of other C types *)
151        val sizeOfPtr = {sz = 4, pad = 0, align = 4}
152    
153      val GP = C.GPReg    (* compute the size and alignment information for a struct; tys is the list
154      val FP = C.FPReg     * of member types.  The alignment is what Apple calls the "embedding" alignment.
   
     fun greg r = GP r  
     fun oreg r = GP (r + 8)  
     fun freg r = FP r  
   
     fun reg32 r = T.REG (32, r)  
     fun freg64 r = T.FREG (64, r)  
   
     val sp = oreg 6  
     val spreg = reg32 sp  
   
     fun addli (x, 0) = x  
       | addli (x, d) = let  
           val d' = T.I.fromInt (32, d)  
           in  
             case x  
              of T.ADD (_, r, T.LI d) =>  
                   T.ADD (32, r, T.LI (T.I.ADD (32, d, d')))  
               | _ => T.ADD (32, x, T.LI d')  
           end  
   
     fun argaddr n = addli (spreg, paramAreaOffset + 4*n)  
   
   (* temp location for transfers through memory *)  
     val tmpaddr = argaddr 1  
   
     fun roundup (i, a) = a * ((i + a - 1) div a)  
   
     fun intSizeAndAlign Ty.I_char = (1, 1)  
       | intSizeAndAlign Ty.I_short = (2, 2)  
       | intSizeAndAlign Ty.I_int = (4, 4)  
       | intSizeAndAlign Ty.I_long = (4, 4)  
       | intSizeAndAlign Ty.I_long_long = (8, 8)  
   
   (* calculate size and alignment for a C type *)  
     fun szal (T.C_unsigned ty) = intSizeAndAlign ty  
       | szal (T.C_signed ty) = intSizeAndAlign ty  
       | szal Ty.C_void = raise Fail "unexpected void type"  
       | szal Ty.C_float = (4, 4)  
       | szal Ty.C_PTR = (4, 4)  
       | szal Ty.C_double = (8, 8)  
       | szal (Ty.C_long_double) = (8, 8)  
       | szal (Ty.C_ARRAY(t, n)) = let val (s, a) = szal t in (n * s, 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))
162                  val (ts, ta) = szal t (* size and alignment for member *)                  end
163                  in            fun sz CTy.C_void = error "unexpected void argument type"
164                  (* member must be aligned according to its own              | sz CTy.C_float = {sz = 4, align = 4}
165                   * alignment requirement; the next free position              | sz CTy.C_double = {sz = 8, align = 8}
166                   * is then at "aligned member-address plus member-size";              | sz CTy.C_long_double = {sz = 8, align = 8}
167                   * new total alignment is max of current alignment              | sz (CTy.C_unsigned isz) = let
168                   * and member alignment (assuming all alignments are                  val {sz, align, ...} = sizeOf isz
169                   * powers of 2) *)                  in
170                    pack (roundup (i, ta) + ts, Int.max (a, ta), tl)                    {sz = sz, align = align}
171                  end                  end
172                | sz (CTy.C_signed isz) = let
173                    val {sz, align, ...} = sizeOf isz
174                    in
175                      {sz = sz, align = align}
176                    end
177                | sz CTy.C_PTR = {sz = 4, align = 4}
178                | sz (CTy.C_ARRAY(ty, n)) = let
179                    val {sz, align} = sz ty
180                    in
181                      {sz = n*sz, align = align}
182                    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
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
202    
203      (* compute the layout of a C call's arguments *)
204        fun layout {conv, retTy, paramTys} = let
205              fun gprRes isz = (case #sz(sizeOf isz)
206                     of 8 => raise Fail "register pairs not yet supported"
207                      | _ => SOME resRegLoc
208                    (* end case *))
209              val (resLoc, argGPRs, structRet) = (case retTy
210                     of CTy.C_void => (NONE, argGPRs, NONE)
211                      | CTy.C_float => (SOME(FReg(fltTy, resFPR, NONE)), argGPRs, NONE)
212                      | CTy.C_double => (SOME(FReg(dblTy, resFPR, NONE)), argGPRs, NONE)
213                      | CTy.C_long_double => (SOME(FReg(dblTy, resFPR, NONE)), argGPRs, NONE)
214                      | CTy.C_unsigned isz => (gprRes isz, argGPRs, NONE)
215                      | CTy.C_signed isz => (gprRes isz, argGPRs, NONE)
216                      | CTy.C_PTR => (SOME resRegLoc, argGPRs, NONE)
217                      | CTy.C_ARRAY _ => error "array return type"
218                      | CTy.C_STRUCT s => let
219                          val sz = sizeOfStruct s
220            in            in
221              pack (0, 1, l)                        (* Note that this is a place where the MacOS X and Linux ABIs differ.
222            end                         * In Linux, GPR3/GPR4 are used to return composite values of 8 bytes.
   
     fun genCall { name, proto, paramAlloc, structRet, saveRestoreDedicated,  
                   callComment, args } = let  
         val { conv, retTy, paramTys } = proto  
         val _ = case conv of  
                     ("" | "ccall") => ()  
                   | _ => error (concat ["unknown calling convention \"",  
                                         String.toString conv, "\""])  
         val res_szal =  
             case retTy of  
                 (Ty.C_long_double | Ty.C_STRUCT _) => SOME (szal retTy)  
               | _ => NONE  
   
         val nargwords = let  
             fun loop ([], n) = n  
               | loop (t :: tl, n) =  
                 loop (tl, (case t of  
                                (Ty.C_double | Ty.C_signed Ty.I_long_long |  
                                 Ty.C_unsigned Ty.I_long_long) => 2  
                              | _ => 1) + n)  
         in  
             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              in                            else (SOME resRegLoc, argGPRs, NONE)
227                  case t of                        end
228                      (Ty.C_void | Ty.C_PTR |                  (* end case *))
229                       Ty.C_signed (Ty.I_int | Ty.I_long) |            fun assign ([], offset, _, _, layout) = List.rev layout
230                       Ty.C_unsigned (Ty.I_int | Ty.I_long)) => ldst 32              | assign (ty::tys, offset, availGPRs, availFPRs, layout) = (
231                    | (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) => ldst 8                  case ty
232                    | (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>                   of CTy.C_void => error "unexpected void tyument type"
233                      ldst 16                    | CTy.C_float => (case (availGPRs, availFPRs)
234                    | (Ty.C_signed Ty.I_long_long |                         of (_::gprs, fpr::fprs) =>
235                       Ty.C_unsigned Ty.I_long_long) => ldst 64                              assign (tys, offset+4, gprs, fprs, FReg(fltTy, fpr, SOME offset)::layout)
236                    | (Ty.C_ARRAY _) =>                          | ([], fpr::fprs) =>
237                      error "ARRAY within gather/scatter struct"                              assign (tys, offset+4, [], fprs, FReg(fltTy, fpr, SOME offset)::layout)
238                    | (Ty.C_STRUCT _) =>                          | ([], []) =>
239                      (* Here we have to do the equivalent of a "memcpy". *)                              assign (tys, offset+4, [], [], FStk(fltTy, offset)::layout)
240                      let val from = a (* argument is address of struct *)                        (* end case *))
241                          fun cp (ty, incr) = let                    | CTy.C_double =>
242                              fun load_from from_off =                        assignFPR (tys, offset, availGPRs, availFPRs, layout)
243                                  T.LOAD (32, addli (from, from_off), mem)                    | CTy.C_long_double =>
244                              (* from_off is relative to from,                        assignFPR (tys, offset, availGPRs, availFPRs, layout)
245                               * to_off is relative to %sp *)                    | CTy.C_unsigned isz =>
246                              fun loop (i, from_off, to_off, cpc) =                        assignGPR(sizeOf isz, tys, offset, availGPRs, availFPRs, layout)
247                                  if i <= 0 then cpc                    | CTy.C_signed isz =>
248                                  else loop (i - incr,                        assignGPR(sizeOf isz, tys, offset, availGPRs, availFPRs, layout)
249                                             from_off + incr, to_off + incr,                    | CTy.C_PTR =>
250                                             T.STORE (ty, addli (spreg, to_off),                        assignGPR(sizeOfPtr, tys, offset, availGPRs, availFPRs, layout)
251                                                      load_from from_off,                    | CTy.C_ARRAY _ =>
252                                                      stack)                        assignGPR(sizeOfPtr, tys, offset, availGPRs, availFPRs, layout)
253                                             :: cpc)                    | CTy.C_STRUCT tys' => raise Fail "struct arguments not supported yet"
254                          in                  (* end case *))
255                              loop (sz, 0, to_off, cpc)          (* assign a GP register and memory for an integer/pointer argument. *)
256                          end            and assignGPR ({sz, pad, ...}, args, offset, availGPRs, availFPRs, layout) = let
257                      in                  val (loc, availGPRs) = (case (sz, availGPRs)
258                          case al of                         of (8, _) => raise Fail "register pairs not yet supported"
259                              1 => cp (8, 1)                          | (_, []) => (Stk(wordTy, offset), [])
260                            | 2 => cp (16, 2)                          | (_, r1::rs) => (Reg(wordTy, r1, SOME offset), rs)
261                            | _ => (* 4 or more *) cp (32, 4)                        (* end case *))
262                      end                  val offset = offset + IntInf.fromInt(sz + pad)
263                    | (Ty.C_float | Ty.C_double | Ty.C_long_double) =>                  in
264                      error "floating point type does not match ARG"                    assign (args, offset, availGPRs, availFPRs, loc::layout)
265              end                  end
266            | struct_copy (_, _, ARGS args, Ty.C_STRUCT tl, to_off, cpc) =          (* assign a FP register and memory/GPRs for double-precision argument. *)
267              (* gather/scatter case *)            and assignFPR (args, offset, availGPRs, availFPRs, layout) = let
268              let fun loop ([], [], _, cpc) = cpc                  fun continue (availGPRs, availFPRs, loc) =
269                    | loop (t :: tl, a :: al, to_off, cpc) = let                        assign (args, offset+8, availGPRs, availFPRs, loc::layout)
270                          val (tsz, tal) = szal t                  fun freg fpr = FReg(dblTy, fpr, SOME offset)
271                          val to_off' = roundup (to_off, tal)                  in
272                          val cpc' = struct_copy (tsz, tal, a, t, to_off', cpc)                    case (availGPRs, availFPRs)
273                      in                     of (_::_::gprs, fpr::fprs) => continue (gprs, fprs, freg fpr)
274                          loop (tl, al, to_off' + tsz, cpc')                      | (_, fpr::fprs) => continue ([], fprs, freg fpr)
275                      end                      | ([], []) => continue ([], [], FStk(dblTy, offset))
276                    | loop _ =                    (* end case *)
277                      error "number of types does not match number of arguments"                  end
278              in            in {
279                  loop (tl, args, to_off, cpc)              argLocs = assign (paramTys, 0, argGPRs, argFPRs, []),
280              end              resLoc = resLoc,
281            | struct_copy (_, _, ARGS _, _, _, _) =              structRetLoc = structRet
282              error "gather/scatter for non-struct"            } end
           | 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
                 NONE => ([], [])  
               | SOME (sz, al) => let  
                     val addr = structRet { szb = sz, align = al }  
                 in  
                     ([T.STORE (32, addli (spreg, 64), addr, stack)],  
                      [T.EXT (ix (IX.UNIMP sz))])  
                 end  
291    
292          val call = T.CALL { funct = name, targets = [],    (* SP-based address of parameter at given offset *)
293        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
329                            [T.MV(wordTy, resGPR, structAddr)]
330                          end
331                    (* end case *))
332            (* 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.1438  
changed lines
  Added in v.1532

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