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 1970, Tue Jul 11 23:00:41 2006 UTC revision 1981, Tue Jul 18 02:03:32 2006 UTC
# Line 24  Line 24 
24        structure DA = Access        structure DA = Access
25        structure DI = DebIndex        structure DI = DebIndex
26        structure EM = ErrorMsg        structure EM = ErrorMsg
       structure II = InlInfo  
27        structure LT = PLambdaType        structure LT = PLambdaType
28        structure M  = Modules        structure M  = Modules
29        structure MC = MatchComp        structure MC = MatchComp
# Line 312  Line 311 
311           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>
312           let val nt = toDconLty DI.top typ           let val nt = toDconLty DI.top typ
313               val nrep = mkRep(rep, nt, name)               val nrep = mkRep(rep, nt, name)
314                 val _ = print "coreExn in translate.sml: "
315                 val _ = PPLexp.printLexp (CON'((name, nrep, nt), [], unitLexp))
316                 val _ = print "\n"
317           in CON'((name, nrep, nt), [], unitLexp)           in CON'((name, nrep, nt), [], unitLexp)
318           end           end
319         | _ => bug "coreExn in translate")         | _ => bug "coreExn in translate")
# Line 847  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
856                   | _ => TU.applyPoly(!typ, ts)                   | _ => TU.applyPoly(!typ, ts)
857            val (primop,intrinsicType) =            val (primop,intrinsicType) =
858                case PrimopMap.primopMap p                case (PrimOpMap.primopMap p, PrimOpTypeMap.primopTypeMap p)
859                 of SOME(p,t) => (p,t)                 of (SOME p, SOME t) => (p,t)
860                  | NONE => 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)                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 does'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 882  Line 908 
908               | _ => transPrim(primop, (toLty d intrinsicType),               | _ => transPrim(primop, (toLty d intrinsicType),
909                                map (toTyc d) intrinsicParams)                                map (toTyc d) intrinsicParams)
910        end        end
911    | mkVE (V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =    | mkVE (v as V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =
912      (* non primop variable *)      (* non primop variable *)
913        (case ts        (case ts
914           of [] => mkVar (v, d)           of [] => mkVar (v, d)
# Line 906  Line 932 
932                   end)                   end)
933    end    end
934    
935  fun mkStr (s as M.STR { access, info, ... }, d) =  fun mkStr (s as M.STR { access, prim, ... }, d) =
936      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => strLty(s, d, compInfo), NONE)
937    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
938    
939  fun mkFct (f as M.FCT { access, info, ... }, d) =  fun mkFct (f as M.FCT { access, prim, ... }, d) =
940      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => fctLty(f, d, compInfo), NONE)
941    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
942    
943  fun mkBnd d =  fun mkBnd d =
# Line 996  Line 1022 
1022               * This seems definitely wrong. *)               * This seems definitely wrong. *)
1023              (case prim              (case prim
1024                of PrimOpId.Prim name =>                of PrimOpId.Prim name =>
1025                    (case PrimOpMap.primopMap name                    (case PrimOpTypeMap.primopTypeMap name
1026                       of SOME(primop,primopty) =>                       of SOME(primopty) =>
1027                          if TU.equalTypeP(!typ,primopty)                          if TU.equalTypeP(!typ,primopty)
1028                          then LET(v, mkVar(w, d), b)                          then LET(v, mkVar(w, d), b)
1029                          else LET(v, mkPE(exp, d, btvs), b)                          else LET(v, mkPE(exp, d, btvs), b)
# Line 1141  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 1176  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))
   
         | g (CONexp (dc, ts)) = mkCE(dc, ts, NONE, d)  
         | g (APPexp (CONexp(dc, ts), e2)) = mkCE(dc, ts, SOME(g e2), d)  
1206    
1207            | g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "
1208                                         val c = mkCE(dc, ts, NONE, d)
1209                                         val _ = PPLexp.printLexp c
1210                                     in c end)
1211            | g (APPexp (CONexp(dc, ts), e2)) = (let val _ = print "mkExp APPexp: "
1212                                                     val c = mkCE(dc, ts, SOME(g e2), d)
1213                                                     val _ = PPLexp.printLexp c
1214                                                 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 1190  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 1201  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
# Line 1318  Line 1351 
1351       * no indication within the program that we are really       * no indication within the program that we are really
1352       * dealing with a constant value that -- in principle --       * dealing with a constant value that -- in principle --
1353       * could be subject to such things as constant folding. *)       * could be subject to such things as constant folding. *)
1354      let val consexp = CONexp (BT.consDcon, [BT.wordTy])      let val consexp = CONexp (BT.consDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1355          fun build [] = CONexp (BT.nilDcon, [BT.wordTy])          fun build [] = CONexp (BT.nilDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1356            | build (d :: ds) = let            | build (d :: ds) = let
1357                  val i = Word.toIntX d                  val i = Word.toIntX d
1358              in              in
# Line 1418  Line 1451 
1451  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1452    
1453  (** normalizing the plambda expression into FLINT *)  (** normalizing the plambda expression into FLINT *)
1454  val flint = FlintNM.norm plexp  val flint = let val _ = print "prenorm\n"
1455                    val n = FlintNM.norm plexp
1456                    val _ = print "postnorm\n"
1457                in n end
1458    
1459  in {flint = flint, imports = imports}  in {flint = flint, imports = imports}
1460  end (* function transDec *)  end (* function transDec *)

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

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