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 1522, Tue Jul 6 17:09:21 2004 UTC revision 1523, Tue Jul 6 19:48:33 2004 UTC
# Line 106  Line 106 
106      val fltTy = 32      (* MLRISC type of float *)      val fltTy = 32      (* MLRISC type of float *)
107      val dblTy = 64      (* MLRISC type of double *)      val dblTy = 64      (* MLRISC type of double *)
108    
109      (* stack pointer *)
110        val sp = C.GPReg 1
111        val spR = T.REG(wordTy, sp)
112    
113    (* registers used for parameter passing *)    (* registers used for parameter passing *)
114      val argGPRs = List.map C.GPReg [3, 4, 5, 6, 7, 8, 9, 10]      val argGPRs = List.map C.GPReg [3, 4, 5, 6, 7, 8, 9, 10]
115      val argFPRs = List.map C.FPReg [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13]      val argFPRs = List.map C.FPReg [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13]
# Line 122  Line 126 
126              23, 24, 25, 26, 27, 28, 29, 30, 31              23, 24, 25, 26, 27, 28, 29, 30, 31
127            ]            ]
128    
129      (* C caller-save registers (including argument registers) *)
130        val callerSaveRegs =
131    (* FIXME: also need link register *)
132              (List.map C.GPReg [2, 11, 12]) @ argGPRs @ (List.map C.FPReg [0]) @ argFPRs
133    
134    (* size and padding for integer types.  Note that the padding is based on the    (* size and padding for integer types.  Note that the padding is based on the
135     * parameter-passing description on p. 35 of the documentation.     * parameter-passing description on p. 35 of the documentation.
136     *)     *)
# Line 134  Line 143 
143    (* sizes of other C types *)    (* sizes of other C types *)
144      val sizeOfPtr = {sz = 4, pad = 0}      val sizeOfPtr = {sz = 4, pad = 0}
145    
146      fun sizeOfStruct ? = ?      fun sizeOfStruct tys = ?
147    
148    (* compute the layout of a C call's arguments *)    (* compute the layout of a C call's arguments *)
149      fun layout {conv, retTy, paramTys} = let      fun layout {conv, retTy, paramTys} = let
# Line 209  Line 218 
218                      | ([], []) => continue ([], [], FStk(dblTy, offset))                      | ([], []) => continue ([], [], FStk(dblTy, offset))
219                    (* end case *)                    (* end case *)
220                  end                  end
221            in            in {
222              { args = assign (paramTys, 0, argGPRs, argFPRs, []), res = resReg }              argLocs = assign (paramTys, 0, argGPRs, argFPRs, []),
223            end              resLoc = resReg,
224                structRet = ?
225              } end
226    
227      datatype c_arg      datatype c_arg
228        = ARG of T.rexp        = ARG of T.rexp
229        | FARG of T.fexp        | FARG of T.fexp
230        | ARGS of c_arg list        | ARGS of c_arg list
231    
232      val mem = T.Region.memory      val memRg = T.Region.memory
233      val stack = T.Region.memory      val stkRg = 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)  
   
   (* stack pointer *)  
     val sp = reg1  
     val spR = 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 case *)  
           end  
   
     fun argaddr n = addli (spreg, paramAreaOffset + 4*n)  
   
   (* layout information for C types; note that stack and struct alignment  
    * are different for some types  
    *)  
     type layout_info = {  
         sz : int,  
         stkAlign : int,  
         structAlign : int  
       }  
   
     fun roundup (i, a) = a * ((i + a - 1) div a)  
   
   (* layout information for integer types *)  
     local  
       fun layout n = {sz = n, stkAlign = n, structAlign = n}  
   
       fun intSizeAndAlign Ty.I_char = layout 1  
         | intSizeAndAlign Ty.I_short = layout 2  
         | intSizeAndAlign Ty.I_int = layout 4  
         | intSizeAndAlign Ty.I_long = layout 4  
         | intSizeAndAlign Ty.I_long_long = {sz = 8, stkAlign = 8, structAlign = 4}  
   
     in  
   
   (* 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 = 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  
          *)  
           fun pack (i, a, []) =  
             (* when we are done with all elements, the total size  
              * of the struct must be padded out to its own alignment  
              *)  
                 (roundup (i, a), a)  
             | pack (i, a, t :: tl) = let  
                 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)  
           end  
     end  
   
     fun assignIntLoc (ty, gprs, offset) = let  
           val {sz, alignStk, alignStruct} = szal ty  
           val offset = align(offset, alignStk)  
           in  
             case (sz, gprs)  
              of (_, []) => ({offset = offset, loc = ARG(??)}, offset+sz, [])  
               | (8, [r]) =>  
               | (8, r1::r2::rs) =>  
               | (_, r::rs) =>({offset = offset, loc = GPR r}, offset+sz, rs)  
             (* end case *)  
           end  
234    
235      fun genCall {      fun genCall {
236            name, proto, paramAlloc, structRet, saveRestoreDedicated,            name, proto, paramAlloc, structRet, saveRestoreDedicated,
237            callComment, args            callComment, args
238          } = let          } = let
239            val {conv, retTy, paramTys} = proto            val {conv, retTy, paramTys} = proto
240              val {argLocs, resLoc, structRet} = layout proto
241            (* generate code to assign the arguments to their locations *)
242              fun assignArgs ([], [], stms) = stms
243                | assignArgs (Reg(ty, r, _) :: locs, ARG exp :: args, stms) =
244                    assignArgs (locs, args, T.MV(ty, r, exp) :: stms)
245                | assignArgs (Stk(ty, off) :: locs, ARG exp :: args, stms) =
246                    assignArgs (locs, args, T.STORE(ty, ?, exp, stkRg) :: stms)
247                | assignArgs (FReg(ty, r, _) :: locs, FARG fexp :: args) =
248                    assignArgs (locs, args, T.FMV(ty, r, fexp) :: stms)
249                | assignArgs (FStk(ty, off) :: locs, FARG fexp :: args, stms) =
250                    assignArgs (locs, args, T.FSTORE(ty, ?, fexp, stkRg) :: stms)
251                | assignArgs ((Args locs') :: locs, (ARGS args') :: args, stms) =
252                    assignArgs (locs, args, assignArgs(locs', args', stms))
253                | assignArgs _ = error "argument/formal mismatch"
254              val argsetupCode = List.rev(assignArgs(args, args, []))
255            (* convert the result location to an MLRISC expression list *)
256              val result = (case resLoc
257                     of NONE => []
258                      | SOME(Reg(ty, r, _)) => [T.REG(ty, r)]
259                      | SOME(FReg(ty, r, _)) => [T.FREG(ty, r)]
260                      | SOME _ => raise Fail "bogus result location"
261                    (* end case *))
262            (* determine the registers used and defined by this call *)
263              val (uses, defs) = let
264                    val locs = (case resLoc
265                           of NONE => argLocs
266                            | SOME loc => loc::argLocs
267                          (* end case *))
268                  (* get the list of registers used to pass arguments and results *)
269                    fun addArgReg (Reg(ty, r, _)::locs, argRegs) =
270                          addArgReg (locs, T.GPR(T.REG(ty, r))::argRegs)
271                      | addArgReg (FReg(ty, r, _)::locs, argRegs) =
272                          addArgReg (locs, T.FPR(T.FREG(ty, r))::argRegs)
273                      | addArgReg ((Args locs')::locs, argRegs) =
274                          addArgReg (locs, addArgReg(locs', argRegs))
275                      | addArgReg (_::locs, argRegs) = addArgReg(locs, argRegs)
276                    val argRegs = addArgReg (locs, [])
277                    in
278                      (argRegs, callerSaveRegs)
279                    end
280            (* the actual call instruction *)
281              val callStm = T.CALL {
282                      funct = name, targets = [],
283                      defs = defs, uses = uses,
284                      region = memRg, pops = 0
285                    }
286            (* annotate, if necessary *)
287              val callStm = (case callComment
288                     of NONE => callStm
289                      | SOME c => T.ANNOTATION(callStm, #create MLRiscAnnotations.COMMENT c)
290                    (* end case *))
291            val callseq = List.concat [            val callseq = List.concat [
292                    sp_sub,                    ??,
293                    copycode,                    argSetupCode,
294                    argsetupcode,                    [callStm],
295                    sretsetup,                    ??
                   save,  
                   [call],  
                   srethandshake,  
                   restore,  
                   sp_add  
296                  ]                  ]
297            in            in
298            (* check calling convention *)            (* check calling convention *)
# Line 355  Line 306 
306              {callseq = callseq, result = result}              {callseq = callseq, result = result}
307            end            end
308    
 (******  
         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).  
              *)  
             let fun ldst ty =  
                     T.STORE (ty, addli (spreg, to_off), a, stack) :: cpc  
             in  
                 case t of  
                     (Ty.C_void | Ty.C_PTR |  
                      Ty.C_signed (Ty.I_int | Ty.I_long) |  
                      Ty.C_unsigned (Ty.I_int | Ty.I_long)) => ldst 32  
                   | (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) => ldst 8  
                   | (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>  
                     ldst 16  
                   | (Ty.C_signed Ty.I_long_long |  
                      Ty.C_unsigned Ty.I_long_long) => ldst 64  
                   | (Ty.C_ARRAY _) =>  
                     error "ARRAY within gather/scatter struct"  
                   | (Ty.C_STRUCT _) =>  
                     (* Here we have to do the equivalent of a "memcpy". *)  
                     let val from = a (* argument is address of struct *)  
                         fun cp (ty, incr) = let  
                             fun load_from from_off =  
                                 T.LOAD (32, addli (from, from_off), mem)  
                             (* from_off is relative to from,  
                              * to_off is relative to %sp *)  
                             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))]  
   
         val { save, restore } = saveRestoreDedicated defs  
   
         val (sretsetup, srethandshake) =  
             case res_szal of  
                 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  
   
         val call = T.CALL { funct = name, targets = [],  
                             defs = defs, uses = uses,  
                             region = mem, pops = 0 }  
   
         val call =  
             case callComment of  
                 NONE => call  
               | SOME c =>  
                 T.ANNOTATION (call, #create MLRiscAnnotations.COMMENT c)  
   
         val (sp_sub, sp_add) =  
             if stackdelta = 0 then ([], []) else  
             if paramAlloc { szb = stackdelta, align = 4 } then ([], [])  
             else ([T.MV (32, sp, T.SUB (32, spreg, LI stackdelta))],  
                   [T.MV (32, sp, addli (spreg, stackdelta))])  
   
         val callseq =  
             List.concat [sp_sub,  
                          copycode,  
                          argsetupcode,  
                          sretsetup,  
                          save,  
                          [call],  
                          srethandshake,  
                          restore,  
                          sp_add]  
   
     in  
         { callseq = callseq, result = result }  
     end  
 *****)  
   
309    end    end

Legend:
Removed from v.1522  
changed lines
  Added in v.1523

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