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

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/CodeGen/main/mlriscGen.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/CodeGen/main/mlriscGen.sml

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

revision 1173, Sat Mar 23 04:18:51 2002 UTC revision 1174, Sat Mar 23 21:14:40 2002 UTC
# Line 74  Line 74 
74    
75    structure MemAliasing = MemAliasing(Cells) (* Memory aliasing *)    structure MemAliasing = MemAliasing(Cells) (* Memory aliasing *)
76    
77      structure CPSCCalls =    (* C-Calls handling *)
78         CPSCCalls(structure MS = MachineSpec
79                   structure C  = C
80                   structure MLTreeComp = MLTreeComp
81                   structure Cells = Cells
82                   structure CCalls = CCalls
83                  )
84    
85    fun error msg = MLRiscErrorMsg.error("MLRiscGen", msg)    fun error msg = MLRiscErrorMsg.error("MLRiscGen", msg)
86    
87    (*    (*
# Line 861  Line 869 
869                   | P.<   => M.LT | P.<=  => M.LE                   | P.<   => M.LT | P.<=  => M.LE
870                   | P.neq => M.NE | P.eql => M.EQ                   | P.neq => M.NE | P.eql => M.EQ
871    
872              fun real64Cmp(oper, v, w) =
873              let  val fcond =
874                          case oper
875                            of P.fEQ => M.==
876                             | P.fULG => M.?<>
877                             | P.fUN => M.?
878                             | P.fLEG => M.<=>
879                             | P.fGT => M.>
880                             | P.fGE  => M.>=
881                             | P.fUGT => M.?>
882                             | P.fUGE => M.?>=
883                             | P.fLT => M.<
884                             | P.fLE  => M.<=
885                             | P.fULT => M.?<
886                             | P.fULE => M.?<=
887                             | P.fLG => M.<>
888                             | P.fUE  => M.?=
889              in M.FCMP(64, fcond, fregbind v, fregbind w) end
890    
891            fun branchToLabel(lab) = M.JMP(M.LABEL lab,[])            fun branchToLabel(lab) = M.JMP(M.LABEL lab,[])
892    
893            local            local
# Line 937  Line 964 
964                       add(x,t); init e                       add(x,t); init e
965                      )                      )
966                 | ARITH(_,vl,x,t,e) => (addValues vl; add(x,t); init e)                 | ARITH(_,vl,x,t,e) => (addValues vl; add(x,t); init e)
967                 | RCC(_,vl,x,t,e) => (addValues vl; add(x,t); init e)                 | RCC(_,_,_,vl,x,t,e) => (addValues vl; add(x,t); init e)
968                 | PURE(p,vl,x,t,e) =>                 | PURE(p,vl,x,t,e) =>
969                      (case p of                      (case p of
970                         P.fwrap => hasFloats := true                         P.fwrap => hasFloats := true
# Line 1110  Line 1137 
1137              | eqVal(INT x, INT y) = x = y              | eqVal(INT x, INT y) = x = y
1138              | eqVal _ = false              | eqVal _ = false
1139    
               (* Perform conditional move folding *)  
               (*  
           and branch(cmp, [v,w], yes, no, hp) =  
               case (yes, no) of  
                 (APP(f,fs), APP(g,gs)) =>  
                    if eqVal(f,g) then  
                       let val cmp = M.CMP(32, cmp, regbind v, regbind w)  
                           fun condMove([],[]) = []  
                             | condMove(x::xs,y::ys) =  
                               if eqVal(x,y) then x::condMove(xs,ys)  
                               else  
                               let val v = LambdaVar.mkLvar()  
                                   val tmp = newReg PTR  
                               in emit(M.MV(32, tmp,  
                                       M.COND(32, cmp, regbind x, regbind y)));  
                                   addRegBinding(v, tmp);  
                                   addTypBinding(v, grabty x);  
                                   VAR v::condMove(xs, ys)  
                               end  
                             | condMove _ = error "condMove"  
                           val e = APP(f,condMove(fs, gs))  
                       in  gen(e, hp)  
                       end  
                    else normalBranch(cmp, v, w, yes, no, hp)  
               | _ => normalBranch(cmp, v, w, yes, no, hp)  
               *)  
   
1140                (* normal branches *)                (* normal branches *)
1141            and branch (cv, cmp, [v, w], yes, no, hp) =            and branch (cv, cmp, [v, w], yes, no, hp) =
1142            let val trueLab = newLabel ()            let val trueLab = newLabel ()
# Line 1180  Line 1180 
1180                    genlab(false_lab, no, hp)                    genlab(false_lab, no, hp)
1181                end                end
1182    
1183                  (* conditional move *)
1184              and condmove(oper, args, x, t, e, hp) =
1185                  let  fun signed(oper, v, w) =
1186                           M.CMP(32, signedCmp oper, regbind v, regbind w)
1187                       fun unsigned(oper, v, w) =
1188                           M.CMP(32, unsignedCmp oper, regbind v, regbind w)
1189                       fun equal(v, w) =
1190                           M.CMP(32, M.EQ, regbind v, regbind w)
1191                       fun notequal(v, w) =
1192                           M.CMP(32, M.NE, regbind v, regbind w)
1193                       fun unboxed x =
1194                           M.CMP(32, M.NE, M.ANDB(ity, regbind x, one), zero)
1195                       fun boxed x =
1196                           M.CMP(32, M.EQ, M.ANDB(ity, regbind x, one), zero)
1197                       val (cmp, a, b) =
1198                       case (oper, args) of
1199                         (P.cmp{oper, kind=P.INT 31},[v,w,a,b]) =>
1200                           (signed(oper,v,w), a, b)
1201                       | (P.cmp{oper, kind=P.UINT 31},[v,w,a,b]) =>
1202                           (unsigned(oper,v,w), a, b)
1203                       | (P.cmp{oper, kind=P.INT 32},[v,w,a,b]) =>
1204                           (signed(oper,v,w), a, b)
1205                       | (P.cmp{oper, kind=P.UINT 32},[v,w,a,b]) =>
1206                           (unsigned(oper,v,w), a, b)
1207                       | (P.fcmp{oper, size=64},[v,w,a,b]) =>
1208                           (real64Cmp(oper,v,w), a, b)
1209                       | (P.peql,[v,w,a,b]) => (equal(v,w), a, b)
1210                       | (P.pneq,[v,w,a,b]) => (notequal(v, w), a, b)
1211                       | (P.boxed,[v,a,b]) => (boxed v, a, b)
1212                       | (P.unboxed,[v,a,b]) => (unboxed v, a, b)
1213                       | _ => error "condmove"
1214                  in  case t of
1215                         FLTt =>
1216                           computef64(x,
1217                              M.FCOND(64, cmp, fregbind a, fregbind b), e, hp)
1218                       | _    =>
1219                           defWithCty(t, x, M.COND(32, cmp, regbind a, regbind b),
1220                                      e, hp)
1221                  end
1222    
1223            and arith(gc, oper, v, w, x, e, hp) =            and arith(gc, oper, v, w, x, e, hp) =
1224                 def(gc, x, oper(ity, regbind v, regbind w), e, hp)                 def(gc, x, oper(ity, regbind v, regbind w), e, hp)
1225    
# Line 1346  Line 1386 
1386                (*esac*))                (*esac*))
1387    
1388            and rawload ((P.INT 32 | P.UINT 32), i, x, e, hp) =            and rawload ((P.INT 32 | P.UINT 32), i, x, e, hp) =
1389                defI32 (x, M.LOAD (32, regbind i, R.memory), e, hp)                defI32 (x, M.LOAD (32, i, R.memory), e, hp)
1390              | rawload (P.INT (sz as (8 | 16)), i, x, e, hp) =              | rawload (P.INT (sz as (8 | 16)), i, x, e, hp) =
1391                defI32 (x, SX32 (sz, M.LOAD (sz, regbind i, R.memory)), e, hp)                defI32 (x, SX32 (sz, M.LOAD (sz, i, R.memory)), e, hp)
1392              | rawload (P.UINT (sz as (8 | 16)), i, x, e, hp) =              | rawload (P.UINT (sz as (8 | 16)), i, x, e, hp) =
1393                defI32 (x, ZX32 (sz, M.LOAD (sz, regbind i, R.memory)), e, hp)                defI32 (x, ZX32 (sz, M.LOAD (sz, i, R.memory)), e, hp)
1394              | rawload ((P.UINT sz | P.INT sz), _, _, _, _) =              | rawload ((P.UINT sz | P.INT sz), _, _, _, _) =
1395                error ("rawload: unsupported size: " ^ Int.toString sz)                error ("rawload: unsupported size: " ^ Int.toString sz)
1396              | rawload (P.FLOAT 64, i, x, e, hp) =              | rawload (P.FLOAT 64, i, x, e, hp) =
1397                treeifyDefF64 (x, M.FLOAD (64, regbind i, R.memory), e, hp)                treeifyDefF64 (x, M.FLOAD (64, i, R.memory), e, hp)
1398              | rawload (P.FLOAT 32, i, x, e, hp) =              | rawload (P.FLOAT 32, i, x, e, hp) =
1399                treeifyDefF64 (x, M.CVTF2F (64, 32,                treeifyDefF64 (x, M.CVTF2F (64, 32, M.FLOAD (32, i, R.memory)),
                                           M.FLOAD (32, regbind i, R.memory)),  
1400                               e, hp)                               e, hp)
1401              | rawload (P.FLOAT sz, _, _, _, _) =              | rawload (P.FLOAT sz, _, _, _, _) =
1402                error ("rawload: unsupported float size: " ^ Int.toString sz)                error ("rawload: unsupported float size: " ^ Int.toString sz)
# Line 1366  Line 1405 
1405                           P.INT (sz as (8 | 16 | 32))), i, x) =                           P.INT (sz as (8 | 16 | 32))), i, x) =
1406                (* both address and value are 32-bit values; only sz bits                (* both address and value are 32-bit values; only sz bits
1407                 * of the value are being stored *)                 * of the value are being stored *)
1408                emit (M.STORE (sz, regbind i, regbind x, R.memory))                emit (M.STORE (sz, i, regbind x, R.memory))
1409              | rawstore ((P.UINT sz | P.INT sz), _, _) =              | rawstore ((P.UINT sz | P.INT sz), _, _) =
1410                error ("rawstore: unsupported int size: " ^ Int.toString sz)                error ("rawstore: unsupported int size: " ^ Int.toString sz)
1411              | rawstore (P.FLOAT (sz as (32 | 64)) , i, x) =              | rawstore (P.FLOAT (sz as (32 | 64)) , i, x) =
1412                emit (M.FSTORE (sz, regbind i, fregbind x, R.memory))                emit (M.FSTORE (sz, i, fregbind x, R.memory))
1413              | rawstore (P.FLOAT sz, _, _) =              | rawstore (P.FLOAT sz, _, _) =
1414                error ("rawstore: unsupported float size: " ^ Int.toString sz)                error ("rawstore: unsupported float size: " ^ Int.toString sz)
1415    
# Line 1651  Line 1690 
1690                    treeifyAlloc(x, hp+4, e, hp+len*4+4)                    treeifyAlloc(x, hp+4, e, hp+len*4+4)
1691                end                end
1692    
1693                | gen(PURE(P.condmove cmp, vw, x, t, e), hp) =
1694                    condmove(cmp, vw, x, t, e, hp)
1695    
1696              (*** ARITH ***)              (*** ARITH ***)
1697              | gen(ARITH(P.arith{kind=P.INT 31, oper=P.~}, [v], x, _, e), hp) =              | gen(ARITH(P.arith{kind=P.INT 31, oper=P.~}, [v], x, _, e), hp) =
1698                  (updtHeapPtr hp;                  (updtHeapPtr hp;
# Line 1767  Line 1809 
1809              | gen(LOOKER(P.getpseudo, [i], x, _, e), hp) =              | gen(LOOKER(P.getpseudo, [i], x, _, e), hp) =
1810                  (print "getpseudo not implemented\n"; nop(x, i, e, hp))                  (print "getpseudo not implemented\n"; nop(x, i, e, hp))
1811              | gen(LOOKER(P.rawload { kind }, [i], x, _, e), hp) =              | gen(LOOKER(P.rawload { kind }, [i], x, _, e), hp) =
1812                  rawload (kind, i, x, e, hp)                  rawload (kind, regbind i, x, e, hp)
1813                | gen(LOOKER(P.rawload { kind }, [i,j], x, _, e), hp) =
1814                    rawload (kind, M.ADD(addrTy,regbind i, regbind j), x, e, hp)
1815    
1816              (*** SETTER ***)              (*** SETTER ***)
1817              | gen(SETTER(P.rawupdate FLTt,[v,i,w],e),hp) =              | gen(SETTER(P.rawupdate FLTt,[v,i,w],e),hp) =
# Line 1853  Line 1897 
1897              | gen(SETTER(P.setpseudo,_,e), hp) =              | gen(SETTER(P.setpseudo,_,e), hp) =
1898                  (print "setpseudo not implemented\n"; gen(e, hp))                  (print "setpseudo not implemented\n"; gen(e, hp))
1899              | gen (SETTER (P.rawstore { kind }, [i, x], e), hp) =              | gen (SETTER (P.rawstore { kind }, [i, x], e), hp) =
1900                  (rawstore (kind, i, x); gen (e, hp))                  (rawstore (kind, regbind i, x); gen (e, hp))
1901              | gen (RCC (p, vl, w, _, e), hp) = let              | gen (SETTER (P.rawstore { kind }, [i, j, x], e), hp) =
1902                    val { retTy, paramTys, ... } = p                  (rawstore (kind, M.ADD(addrTy, regbind i, regbind j), x);
1903                    fun build_args vl = let                   gen (e, hp))
1904                        open CTypes              | gen (RCC(arg as (_, _, _, _, w, t, e)), hp) =
1905                        fun m (C_double, v :: vl) =                let val {result, hp} =
1906                            (CCalls.FARG (fregbind v), vl)                        CPSCCalls.c_call
1907                          | m (C_float, v :: vl) =                            {stream=stream, regbind=regbind,
1908                            (CCalls.FARG (M.CVTF2F (32, 64, fregbind v)), vl)                             fregbind=fregbind, typmap=typmap, vfp=vfp, hp=hp}
1909                          | m ((C_unsigned (I_char | I_short | I_int | I_long) |                            arg
1910                                C_signed (I_char | I_short | I_int | I_long) |                in  case (result, t) of
1911                                C_PTR),                      (NONE, _) => defI31 (w, mlZero, e, hp)
1912                               v :: vl) =                    | (SOME(M.FPR x),CPS.FLTt) => treeifyDefF64 (w, x, e, hp)
1913                            (CCalls.ARG (regbind v), vl)                          (* more sanity checking here ? *)
1914                          | m (C_STRUCT _, v :: vl) =                    | (SOME(M.GPR x),CPS.INT32t) => defI32 (w, x, e, hp)
1915                            (* pass struct using the pointer to its beginning *)                    | (SOME(M.GPR x),CPS.PTRt _) => defBoxed (w, x, e, hp)
1916                            (CCalls.ARG (regbind v), vl)                    | _ => error "RCC: bad results"
                         | m (_, []) = error "RCC: not enough ML args"  
                         | m _ = error "RCC: unexpected C-type"  
                       and ml (tl, vl) = let  
                           fun one (t, (ral, vl)) = let val (a, vl') = m (t, vl)  
                                                    in (a :: ral, vl') end  
                           val (ral, vl') = foldl one ([], vl) tl  
                       in  
                           (rev ral, vl')  
                       end  
                   in  
                       case ml (paramTys, vl) of  
                           (al, []) => al  
                         | _ => error "RCC: too many ML args"  
                   end  
                   val (f, sr, a) =  
                       case (retTy, vl) of  
                           (CTypes.C_STRUCT _, fv :: srv :: avl) =>  
                           let val s = regbind srv  
                           in (regbind fv, fn _ => s, build_args avl)  
                           end  
                         | (_, fv :: avl) =>  
                           (regbind fv,  
                            fn _ => error "RCC: unexpected struct return",  
                            build_args avl)  
                         | _ => error "RCC: prototype/arglist mismatch"  
                   fun srd defs = let  
                       fun loop ([], s, r) = { save = s, restore = r }  
                         | loop (M.GPR (M.REG (ty, g)) :: l, s, r) =  
                           if List.exists (sameRegAs g) C.ccallCallerSaveR then  
                               let val t = Cells.newReg ()  
                               in  
                                   loop (l, M.COPY (ty, [t], [g]) :: s,  
                                            M.COPY (ty, [g], [t]) :: r)  
                               end  
                           else loop (l, s, r)  
                         | loop (M.FPR (M.FREG (ty, f)) :: l, s, r) =  
                           if List.exists (sameRegAs f) C.ccallCallerSaveF then  
                               let val t = Cells.newFreg ()  
                               in  
                                   loop (l, M.FCOPY (ty, [t], [f]) :: s,  
                                            M.FCOPY (ty, [f], [t]) :: r)  
                               end  
                           else loop (l, s, r)  
                         | loop _ = error "saveRestoreDedicated: unexpected def"  
                   in  
                       loop (defs, [], [])  
                   end  
   
                   val { callseq, result } =  
                       CCalls.genCall  
                           { name = f, proto = p, structRet = sr,  
                             saveRestoreDedicated = srd,  
                             paramAlloc = fn _ => false,  
                             callComment =  
                             SOME ("C prototype is: " ^ CProto.pshow p),  
                             args = a }  
   
                   fun withVSP f = let  
                       val frameptr = C.frameptr vfp  
   
                       val msp =  
                           M.LOAD (addrTy, ea (frameptr, MS.ML_STATE_OFFSET),  
                                   R.stack)  
                       val vsp =  
                           M.LOAD (addrTy, ea (msp, MS.VProcOffMSP), R.memory)  
   
                       val vsp' = M.REG (addrTy, Cells.newReg ())  
                       val inML = M.LOAD (ity, ea (vsp', MS.InMLOffVSP),  
                                          R.memory)  
                       val LimitPtrMask =  
                           M.LOAD (32, ea (vsp', MS.LimitPtrMaskOffVSP),  
                                   R.memory)  
                   in  
                       (* move vsp to its register *)  
                       emit (assign (vsp', vsp));  
                       f { inML = inML, LimitPtrMask = LimitPtrMask }  
                   end  
   
               in  
                   (* prepare for leaving ML *)  
                   withVSP (fn { inML, LimitPtrMask } =>  
                               ((* set vp_limitPtrMask to ~1 *)  
                                emit (assign (LimitPtrMask, LW 0wxffffffff));  
                                (* set vp_inML to 0 *)  
                                emit (assign (inML, LW 0w0))));  
   
                   (* now do the actual call! *)  
                   app emit callseq;  
   
                   (* come back to ML, restore proper limit pointer *)  
                   withVSP (fn { inML, LimitPtrMask } =>  
                               ((* set vp_inML back to 1 *)  
                                emit (assign (inML, LW 0w1));  
                                (* limitPtr := limitPtr & vp_limitPtrMask *)  
                                emit (assign (C.limitptr(vfp),  
                                              M.ANDB (pty, LimitPtrMask,  
                                                           C.limitptr(vfp))))));  
   
                   case (result, retTy) of  
                       (([] | [_]), (CTypes.C_void | CTypes.C_STRUCT _)) =>  
                       defI31 (w, mlZero, e, hp)  
                     | ([], _) => error "RCC: unexpectedly few results"  
                     | ([M.FPR x], CTypes.C_float) =>  
                       treeifyDefF64 (w, M.CVTF2F (64, 32, x), e, hp)  
                     | ([M.FPR x], CTypes.C_double) =>  
                       treeifyDefF64 (w, x, e, hp)  
                     | ([M.FPR _], _) => error "RCC: unexpected FP result"  
                     | ([M.GPR x], _) => (* more sanity checking here ? *)  
                       defI32 (w, x, e, hp)  
                     | _ => error "RCC: unexpectedly many results"  
1917                end                end
1918    
1919              (*** BRANCH  ***)              (*** BRANCH  ***)
# Line 2034  Line 1968 
1968                  branch(p, signedCmp oper, vw, e, d, hp)                  branch(p, signedCmp oper, vw, e, d, hp)
1969              | gen(BRANCH(P.fcmp{oper,size=64}, [v,w], p, d, e), hp) =              | gen(BRANCH(P.fcmp{oper,size=64}, [v,w], p, d, e), hp) =
1970                let val trueLab = newLabel ()                let val trueLab = newLabel ()
1971                    val fcond =                    val cmp     = real64Cmp(oper, v, w)
                       case oper  
                         of P.fEQ => M.==  
                          | P.fULG => M.?<>  
                          | P.fUN => M.?  
                          | P.fLEG => M.<=>  
                          | P.fGT => M.>  
                          | P.fGE  => M.>=  
                          | P.fUGT => M.?>  
                          | P.fUGE => M.?>=  
                          | P.fLT => M.<  
                          | P.fLE  => M.<=  
                          | P.fULT => M.?<  
                          | P.fULE => M.?<=  
                          | P.fLG => M.<>  
                          | P.fUE  => M.?=  
   
                   val cmp = M.FCMP(64, fcond, fregbind v, fregbind w)  
1972                in  emit(M.BCC(cmp, trueLab));                in  emit(M.BCC(cmp, trueLab));
1973                    genCont(e, hp);                    genCont(e, hp);
1974                    genlab(trueLab, d, hp)                    genlab(trueLab, d, hp)

Legend:
Removed from v.1173  
changed lines
  Added in v.1174

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