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 1521, Wed Jun 30 21:44:58 2004 UTC revision 1531, Mon Jul 12 19:44:50 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 CTy = 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    
# Line 94  Line 93 
93     * low end of the parameter area.     * low end of the parameter area.
94     *)     *)
95      datatype arg_location      datatype arg_location
96        = Reg of T.ty * T.reg             (* integer/pointer argument in register *)        = Reg of T.ty * T.reg * T.I.machine_int option
97        | FReg of T.fty * T.freg          (* floating-point argument in register *)                                          (* integer/pointer argument in register *)
98          | FReg of T.fty * T.reg * T.I.machine_int option
99                                            (* floating-point argument in register *)
100        | Stk of T.ty * T.I.machine_int   (* integer/pointer argument in parameter area *)        | 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 *)        | FStk of T.fty * T.I.machine_int (* floating-point argument in parameter area *)
102        | Args of arg_location list        | Args of arg_location list
103    
104  (* ?? use arg_location instead of the following? *)      val wordTy = 32
105      datatype arg_loc      val fltTy = 32      (* MLRISC type of float *)
106        = GPR of C.cell      val dblTy = 64      (* MLRISC type of double *)
107        | GPR2 of C.cell * C.cell  
108        | FPR of C.cell    (* stack pointer *)
109        | STK      val spReg = T.REG(wordTy, C.GPReg 1)
   
     type arg_pos = {  
         offset : int,           (* stack offset of memory for argument *)  
         loc : arg_loc           (* location where argument is passed *)  
       }  
110    
111    (* registers used for parameter passing *)    (* registers used for parameter passing *)
112      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]
113      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]
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 *)    (* C callee-save registers *)
119      val calleeSaveRegs = List.map C.GPReg [      val calleeSaveRegs = List.map C.GPReg [
# Line 126  Line 125 
125              23, 24, 25, 26, 27, 28, 29, 30, 31              23, 24, 25, 26, 27, 28, 29, 30, 31
126            ]            ]
127    
128    (* size of integer types *)    (* C caller-save registers (including argument registers) *)
129      fun sizeOf CTy.I_char = {sz = 1, pad = 3}      val callerSaveRegs =
130        | sizeOf CTy.I_short = {sz = 2, pad = 2}            T.FPR(T.FREG(dblTy, C.FPReg 0)) ::
131        | sizeOf CTy.I_int = {sz = 4, pad = 0}              (List.map (fn r => T.GPR(T.REG(wordTy, C.GPReg r))) [2, 11, 12])
132        | sizeOf CTy.I_long = {sz = 4, pad = 0}  
133        | sizeOf CTy.I_long_long = {sz = 8, pad = 0}      val linkReg = T.GPR(T.REG(wordTy, C.lr))
134    
135      (* the parameter area lies just above the linkage area in the caller's frame.
136       * The linkage area is 24 bytes, so the first parameter is at 24(sp).
137       *)
138        val paramAreaOffset = 24
139    
140      (* 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       * 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      (* sizes of other C types *)
151        val sizeOfPtr = {sz = 4, pad = 0, align = 4}
152    
153      (* compute the size and alignment information for a struct; tys is the list
154       * of member types.  The alignment is what Apple calls the "embedding" alignment.
155       *)
156        fun sizeOfStruct tys = let
157            (* align the address to the given alignment, which must be a power of 2 *)
158              fun alignAddr (addr, align) = let
159                    val mask = Word.fromInt(align-1)
160                    in
161                      Word.toIntX(Word.andb(Word.fromInt addr + mask, Word.notb mask))
162                    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
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 *)    (* compute the layout of a C call's arguments *)
204      fun layout {conv, retTy, paramTys} = let      fun layout {conv, retTy, paramTys} = let
205            val structRet = (case retTy            fun gprRes isz = (case #sz(sizeOf isz)
206                   of CTy.C_STRUCT _ => true                   of 8 => raise Fail "register pairs not yet supported"
207                    | _ => false                    | _ => 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
221                          (* Note that this is a place where the MacOS X and Linux ABIs differ.
222                           * In Linux, GPR3/GPR4 are used to return composite values of 8 bytes.
223                           *)
224                            if (sz > 4)
225                              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 *))                  (* end case *))
           fun assign ([], offset, _, _, layout) = {sz = offset, layout = List.rev layout}  
             | assign (arg::args, offset, availGPRs, availFPRs, layout) = (  
                 case arg  
                  of CTy.C_void => error "unexpected void argument type"  
                   | CTy.C_float =>  
241                    | CTy.C_double =>                    | CTy.C_double =>
242                          assignFPR (tys, offset, availGPRs, availFPRs, layout)
243                    | CTy.C_long_double =>                    | CTy.C_long_double =>
244                          assignFPR (tys, offset, availGPRs, availFPRs, layout)
245                    | CTy.C_unsigned isz =>                    | CTy.C_unsigned isz =>
246                          assignGPR(sizeOf isz, tys, offset, availGPRs, availFPRs, layout)
247                    | CTy.C_signed isz =>                    | CTy.C_signed isz =>
248                          assignGPR(sizeOf isz, tys, offset, availGPRs, availFPRs, layout)
249                    | CTy.C_PTR =>                    | CTy.C_PTR =>
250                          assignGPR(sizeOfPtr, tys, offset, availGPRs, availFPRs, layout)
251                    | CTy.C_ARRAY _ =>                    | CTy.C_ARRAY _ =>
252                    | CTy.C_STRUCT tys =>                        assignGPR(sizeOfPtr, tys, offset, availGPRs, availFPRs, layout)
253                      | CTy.C_STRUCT tys' => raise Fail "struct arguments not supported yet"
254                  (* end case *))                  (* end case *))
255            and assignGPR (offset, sz, pad, availGPRs, availFPRs) = let          (* assign a GP register and memory for an integer/pointer argument. *)
256                  val offset' = offset + sz + pad            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                    ({offset = offset, loc = loc}, offset')                    assign (args, offset, availGPRs, availFPRs, loc::layout)
265                  end                  end
266              | assignGPR (args, offset, [], availFPRs) =          (* assign a FP register and memory/GPRs for double-precision argument. *)
267            and assignFPR (offset, gpr::availGPRs, fpr::availFPRs) =            and assignFPR (args, offset, availGPRs, availFPRs, layout) = let
268              | assignFPR (offset, [], fpr::availFPRs) =                  fun continue (availGPRs, availFPRs, loc) =
269              | assignFPR (offset, [], []) =                        assign (args, offset+8, availGPRs, availFPRs, loc::layout)
270            in                  fun freg fpr = FReg(dblTy, fpr, SOME offset)
271              assign (paramTys, 0, argGPRs, argFPRs, [])                  in
272                      case (availGPRs, availFPRs)
273                       of (_::_::gprs, fpr::fprs) => continue (gprs, fprs, freg fpr)
274                        | (_, fpr::fprs) => continue ([], fprs, freg fpr)
275                        | ([], []) => continue ([], [], FStk(dblTy, offset))
276                      (* end case *)
277            end            end
278              in {
279                argLocs = assign (paramTys, 0, argGPRs, argFPRs, []),
280                resLoc = resLoc,
281                structRetLoc = structRet
282              } end
283    
284      datatype c_arg      datatype c_arg
285        = ARG of T.rexp        = ARG of T.rexp
286        | FARG of T.fexp        | FARG of T.fexp
287        | ARGS of c_arg list        | ARGS of c_arg list
288    
289      val mem = T.Region.memory      val memRg = T.Region.memory
290      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)  
291    
292    (* layout information for C types; note that stack and struct alignment    (* SP-based address of parameter at given offset *)
293     * are different for some types      fun paramAddr off =
294     *)            T.ADD(wordTy, spReg, T.LI(off + IntInf.fromInt paramAreaOffset))
     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  
295    
296      fun genCall {      fun genCall {
297            name, proto, paramAlloc, structRet, saveRestoreDedicated,            name, proto, paramAlloc, structRet, saveRestoreDedicated,
298            callComment, args            callComment, args
299          } = let          } = let
300            val {conv, retTy, paramTys} = proto            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                    val argRegs = addArgReg (locs, [])
347                    in
348                      (argRegs, linkReg :: callerSaveRegs)
349                    end
350            (* the actual call instruction *)
351              val callStm = T.CALL {
352                      funct = name, targets = [],
353                      defs = defs, uses = uses,
354                      region = memRg, pops = 0
355                    }
356            (* annotate, if necessary *)
357              val callStm = (case callComment
358                     of NONE => callStm
359                      | SOME c => T.ANNOTATION(callStm, #create MLRiscAnnotations.COMMENT c)
360                    (* end case *))
361            (* take care of dedicated client registers *)
362              val {save, restore} = saveRestoreDedicated defs
363            val callseq = List.concat [            val callseq = List.concat [
364                    sp_sub,                    setupStructRet,
365                    copycode,                    argSetupCode,
                   argsetupcode,  
                   sretsetup,  
366                    save,                    save,
367                    [call],                    [callStm],
368                    srethandshake,                    restore
                   restore,  
                   sp_add  
369                  ]                  ]
370            in            in
371            (* check calling convention *)            (* check calling convention *)
# Line 307  Line 379 
379              {callseq = callseq, result = result}              {callseq = callseq, result = result}
380            end            end
381    
 (******  
         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  
 *****)  
   
382    end    end

Legend:
Removed from v.1521  
changed lines
  Added in v.1531

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