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/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml

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

revision 1976, Thu Jul 13 20:20:48 2006 UTC revision 1981, Tue Jul 18 02:03:32 2006 UTC
# Line 849  Line 849 
849   * In the case of a primop variable, this function reconstructs the   * In the case of a primop variable, this function reconstructs the
850   * type parameters of instantiation of the intrinsic primop type relative   * type parameters of instantiation of the intrinsic primop type relative
851   * to the variable occurrence type *)   * to the variable occurrence type *)
852  fun mkVE (V.VALvar { typ, prim = PrimOpId.Prim p, ... }, ts, d) =  fun mkVE (e as V.VALvar { typ, prim = PrimOpId.Prim p, ... }, ts, d) =
853        let val occty = (* compute the occurrence type of the variable *)        let val occty = (* compute the occurrence type of the variable *)
854                case ts                case ts
855                  of [] => !typ                  of [] => !typ
# Line 858  Line 858 
858                case (PrimOpMap.primopMap p, PrimOpTypeMap.primopTypeMap p)                case (PrimOpMap.primopMap p, PrimOpTypeMap.primopTypeMap p)
859                 of (SOME p, SOME t) => (p,t)                 of (SOME p, SOME t) => (p,t)
860                  | _ => bug "mkVE: unrecognized primop name"                  | _ => bug "mkVE: unrecognized primop name"
861              val _ = print "mkVE: before matchInstTypes\n"
862            val intrinsicParams =            val intrinsicParams =
863                (* compute intrinsic instantiation params of intrinsicType *)                (* compute intrinsic instantiation params of intrinsicType *)
864                case ((TU.matchInstTypes(occty,intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )                case ((TU.matchInstTypes(occty,intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )
865                  of SOME(_,tvs) => map TU.pruneTyvar tvs                  of SOME(_, tvs) =>
866                   | NONE => bug "primop intrinsic type doesn't match occurence type"                     (print ("tvs length "^ (Int.toString (length tvs)) ^"\n");
867                        complain EM.WARN "mkVE ->matchInstTypes -> pruneTyvar " (fn ppstrm => PPVal.ppDebugVar (fn x => "") ppstrm env e);
868                        map TU.pruneTyvar tvs)
869                     | NONE => (complain EM.COMPLAIN "matchInstTypes"
870                                  (fn ppstrm =>
871                                        (PP.newline ppstrm;
872                                         PP.string ppstrm "VALvar: ";
873                                         PPVal.ppVar ppstrm e;
874                                         PP.newline ppstrm;
875                                         PP.string ppstrm "occtypes: ";
876                                         PPType.ppType env ppstrm occty;
877                                         PP.newline ppstrm;
878                                         PP.string ppstrm "intrinsicType: ";
879                                         PPType.ppType env ppstrm intrinsicType;
880                                         PP.newline ppstrm;
881                                         PP.string ppstrm "instpoly occ: ";
882                                         PPType.ppType env ppstrm (#1 (TU.instantiatePoly occty));
883                                         PP.newline ppstrm;
884                                         PP.string ppstrm "instpoly intrinsicType: ";
885                                         let val inst = (#1 (TU.instantiatePoly intrinsicType))
886                                         in PPType.ppType env ppstrm inst
887                                         end));
888                                bug "primop intrinsic type doesn't match occurrence type")
889              val _ = print "mkVE: after matchInstTypes\n"
890         in case (primop, intrinsicParams)         in case (primop, intrinsicParams)
891              of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)              of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
892               | (PO.POLYNEQ, [t]) =>               | (PO.POLYNEQ, [t]) =>
# Line 1143  Line 1167 
1167   *                                                                         *   *                                                                         *
1168   ***************************************************************************)   ***************************************************************************)
1169  and mkDec (dec, d) =  and mkDec (dec, d) =
1170    let fun g (VALdec vbs) = mkVBs(vbs, d)    let fun g (VALdec vbs) = (print "VALdec"; mkVBs(vbs, d))
1171          | g (VALRECdec rvbs) = mkRVBs(rvbs, d)          | g (VALRECdec rvbs) = (print "VALRECdec"; mkRVBs(rvbs, d))
1172          | g (ABSTYPEdec{body,...}) = g body          | g (ABSTYPEdec{body,...}) = g body
1173          | g (EXCEPTIONdec ebs) = mkEBs(ebs, d)          | g (EXCEPTIONdec ebs) = (print "EXCEPTIONdec"; mkEBs(ebs, d))
1174          | g (STRdec sbs) = mkStrbs(sbs, d)          | g (STRdec sbs) = (print "STRdec"; mkStrbs(sbs, d))
1175          | g (ABSdec sbs) = mkStrbs(sbs, d)          | g (ABSdec sbs) = (print "ABSdec"; mkStrbs(sbs, d))
1176          | g (FCTdec fbs) = mkFctbs(fbs, d)          | g (FCTdec fbs) = (print "FCTdec"; mkFctbs(fbs, d))
1177          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)
1178          | g (SEQdec ds) =  foldr (op o) ident (map g ds)          | g (SEQdec ds) =  foldr (op o) ident (map g ds)
1179          | g (MARKdec(x, reg)) =          | g (MARKdec(x, reg)) =
# Line 1178  Line 1202 
1202        fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs        fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs
1203    
1204        and g (VARexp (ref v, ts)) =        and g (VARexp (ref v, ts)) =
1205              mkVE(v, map TP.VARty ts, d)              (print "mkExp VARexp\n"; mkVE(v, map TP.VARty ts, d))
1206    
1207          | g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "          | g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "
1208                                       val c = mkCE(dc, ts, NONE, d)                                       val c = mkCE(dc, ts, NONE, d)
# Line 1189  Line 1213 
1213                                                   val _ = PPLexp.printLexp c                                                   val _ = PPLexp.printLexp c
1214                                               in c end)                                               in c end)
1215          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1216              (print "mkExp INTexp\n";
1217               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1218                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1219                 else if TU.equalType (t, BT.intinfTy) then VAR (getII s)                 else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
# Line 1197  Line 1222 
1222                     in RECORD [WORD32 hi, WORD32 lo]                     in RECORD [WORD32 hi, WORD32 lo]
1223                     end                     end
1224                 else bug "translate INTexp")                 else bug "translate INTexp")
1225                handle Overflow => (repErr "int constant too large"; INT 0))                handle Overflow => (repErr "int constant too large"; INT 0)))
1226    
1227          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1228              (print "WORDexp\n";
1229               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1230                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1231                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
# Line 1208  Line 1234 
1234                     in RECORD [WORD32 hi, WORD32 lo]                     in RECORD [WORD32 hi, WORD32 lo]
1235                     end                     end
1236                 else (ppType t; bug "translate WORDexp"))                 else (ppType t; bug "translate WORDexp"))
1237                 handle Overflow => (repErr "word constant too large"; INT 0))                 handle Overflow => (repErr "word constant too large"; INT 0)))
1238    
1239          | g (REALexp s) = REAL s          | g (REALexp s) = REAL s
1240          | g (STRINGexp s) = STRING s          | g (STRINGexp s) = STRING s

Legend:
Removed from v.1976  
changed lines
  Added in v.1981

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