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 1981, Tue Jul 18 02:03:32 2006 UTC revision 1987, Mon Jul 24 23:07:36 2006 UTC
# Line 48  Line 48 
48   *                   CONSTANTS AND UTILITY FUNCTIONS                        *   *                   CONSTANTS AND UTILITY FUNCTIONS                        *
49   ****************************************************************************)   ****************************************************************************)
50    
51  val debugging = ref true  val debugging = ref false
52  fun bug msg = EM.impossible("Translate: " ^ msg)  fun bug msg = EM.impossible("Translate: " ^ msg)
53  val say = Control.Print.say  val say = Control.Print.say
54    
55    fun debugmsg (msg : string) =
56        if !debugging then (say msg; say "\n") else ()
57    
58  val ppDepth = Control.Print.printDepth  val ppDepth = Control.Print.printDepth
59    
60  fun ppType ty =  fun ppType ty =
# Line 311  Line 315 
315           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>
316           let val nt = toDconLty DI.top typ           let val nt = toDconLty DI.top typ
317               val nrep = mkRep(rep, nt, name)               val nrep = mkRep(rep, nt, name)
318               val _ = print "coreExn in translate.sml: "               val _ = debugmsg ">>coreExn in translate.sml: "
319               val _ = PPLexp.printLexp (CON'((name, nrep, nt), [], unitLexp))               (* val _ = PPLexp.printLexp (CON'((name, nrep, nt), [], unitLexp))
320               val _ = print "\n"               val _ = print "\n" *)
321           in CON'((name, nrep, nt), [], unitLexp)           in CON'((name, nrep, nt), [], unitLexp)
322           end           end
323         | _ => bug "coreExn in translate")         | _ => bug "coreExn in translate")
# Line 858  Line 862 
862                case (PrimOpMap.primopMap p, PrimOpTypeMap.primopTypeMap p)                case (PrimOpMap.primopMap p, PrimOpTypeMap.primopTypeMap p)
863                 of (SOME p, SOME t) => (p,t)                 of (SOME p, SOME t) => (p,t)
864                  | _ => bug "mkVE: unrecognized primop name"                  | _ => bug "mkVE: unrecognized primop name"
865            val _ = print "mkVE: before matchInstTypes\n"            val _ = debugmsg ">>mkVE: before matchInstTypes"
866            val intrinsicParams =            val intrinsicParams =
867                (* compute intrinsic instantiation params of intrinsicType *)                (* compute intrinsic instantiation params of intrinsicType *)
868                case ((TU.matchInstTypes(occty, intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )                case ((TU.matchInstTypes(occty, intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )
869                  of SOME(_, tvs) =>                  of SOME(_, tvs) =>
870                     (print ("tvs length "^ (Int.toString (length tvs)) ^"\n");                     ((*print ("tvs length "^ (Int.toString (length tvs)) ^"\n");
871                      complain EM.WARN "mkVE ->matchInstTypes -> pruneTyvar " (fn ppstrm => PPVal.ppDebugVar (fn x => "") ppstrm env e);                      complain EM.WARN "mkVE ->matchInstTypes -> pruneTyvar " (fn ppstrm => PPVal.ppDebugVar (fn x => "") ppstrm env e);
872                      map TU.pruneTyvar tvs)                      if (length tvs) = 1 then complain EM.WARN "mkVE ->matchInstTypes -> pruneTyvar " (fn ppstrm => PPType.ppType env ppstrm (TP.VARty (hd tvs))) else ();
873                        *)map TU.pruneTyvar tvs)
874                   | NONE => (complain EM.COMPLAIN "matchInstTypes"                   | NONE => (complain EM.COMPLAIN "matchInstTypes"
875                                (fn ppstrm =>                                (fn ppstrm =>
876                                      (PP.newline ppstrm;                                      (PP.newline ppstrm;
# Line 882  Line 887 
887                                       PPType.ppType env ppstrm (#1 (TU.instantiatePoly occty));                                       PPType.ppType env ppstrm (#1 (TU.instantiatePoly occty));
888                                       PP.newline ppstrm;                                       PP.newline ppstrm;
889                                       PP.string ppstrm "instpoly intrinsicType: ";                                       PP.string ppstrm "instpoly intrinsicType: ";
890                                       let val inst = (#1 (TU.instantiatePoly intrinsicType))                                       PPType.ppType env ppstrm (#1 (TU.instantiatePoly intrinsicType))));
                                      in PPType.ppType env ppstrm inst  
                                      end));  
891                              bug "primop intrinsic type doesn't match occurrence type")                              bug "primop intrinsic type doesn't match occurrence type")
892            val _ = print "mkVE: after matchInstTypes\n"            val _ = debugmsg "<<mkVE: after matchInstTypes"
893         in case (primop, intrinsicParams)         in case (primop, intrinsicParams)
894              of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)              of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
895               | (PO.POLYNEQ, [t]) =>               | (PO.POLYNEQ, [t]) =>
# Line 1167  Line 1170 
1170   *                                                                         *   *                                                                         *
1171   ***************************************************************************)   ***************************************************************************)
1172  and mkDec (dec, d) =  and mkDec (dec, d) =
1173    let fun g (VALdec vbs) = (print "VALdec"; mkVBs(vbs, d))    let fun g (VALdec vbs) = mkVBs(vbs, d)
1174          | g (VALRECdec rvbs) = (print "VALRECdec"; mkRVBs(rvbs, d))          | g (VALRECdec rvbs) = mkRVBs(rvbs, d)
1175          | g (ABSTYPEdec{body,...}) = g body          | g (ABSTYPEdec{body,...}) = g body
1176          | g (EXCEPTIONdec ebs) = (print "EXCEPTIONdec"; mkEBs(ebs, d))          | g (EXCEPTIONdec ebs) = mkEBs(ebs, d)
1177          | g (STRdec sbs) = (print "STRdec"; mkStrbs(sbs, d))          | g (STRdec sbs) = mkStrbs(sbs, d)
1178          | g (ABSdec sbs) = (print "ABSdec"; mkStrbs(sbs, d))          | g (ABSdec sbs) = mkStrbs(sbs, d)
1179          | g (FCTdec fbs) = (print "FCTdec"; mkFctbs(fbs, d))          | g (FCTdec fbs) = mkFctbs(fbs, d)
1180          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)
1181          | g (SEQdec ds) =  foldr (op o) ident (map g ds)          | g (SEQdec ds) =  foldr (op o) ident (map g ds)
1182          | g (MARKdec(x, reg)) =          | g (MARKdec(x, reg)) =
# Line 1202  Line 1205 
1205        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
1206    
1207        and g (VARexp (ref v, ts)) =        and g (VARexp (ref v, ts)) =
1208              (print "mkExp VARexp\n"; mkVE(v, map TP.VARty ts, d))              (debugmsg ">>mkExp VARexp"; mkVE(v, map TP.VARty ts, d))
1209    
1210          | g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "          | g (CONexp (dc, ts)) =
1211              (let val _ = debugmsg ">>mkExp CONexp: "
1212                                       val c = mkCE(dc, ts, NONE, d)                                       val c = mkCE(dc, ts, NONE, d)
1213                                       val _ = PPLexp.printLexp c                 val _ = if !debugging then PPLexp.printLexp c else ()
1214                                   in c end)                                   in c end)
1215          | g (APPexp (CONexp(dc, ts), e2)) = (let val _ = print "mkExp APPexp: "          | g (APPexp (CONexp(dc, ts), e2)) =
1216              (let val _ = debugmsg ">>mkExp APPexp: "
1217                                                   val c = mkCE(dc, ts, SOME(g e2), d)                                                   val c = mkCE(dc, ts, SOME(g e2), d)
1218                                                   val _ = PPLexp.printLexp c                 val _ = if !debugging then PPLexp.printLexp c else ()
1219                                               in c end)                                               in c end)
1220          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1221            (print "mkExp INTexp\n";            (debugmsg ">>mkExp INTexp";
1222               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1223                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1224                 else if TU.equalType (t, BT.intinfTy) then VAR (getII s)                 else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
# Line 1225  Line 1230 
1230                handle Overflow => (repErr "int constant too large"; INT 0)))                handle Overflow => (repErr "int constant too large"; INT 0)))
1231    
1232          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1233            (print "WORDexp\n";            (debugmsg ">>WORDexp";
1234               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1235                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1236                 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 1437  Line 1442 
1442  (** the list of things being exported from the current compilation unit *)  (** the list of things being exported from the current compilation unit *)
1443  val exportLexp = SRECORD (map VAR exportLvars)  val exportLexp = SRECORD (map VAR exportLvars)
1444    
1445    val _ = debugmsg ">>mkDec"
1446  (** translating the ML absyn into the PLambda expression *)  (** translating the ML absyn into the PLambda expression *)
1447  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1448    val _ = debugmsg "<<mkDec"
1449    
1450  (** add bindings for intinf constants *)  (** add bindings for intinf constants *)
1451  val body = wrapII body  val body = wrapII body
# Line 1451  Line 1458 
1458  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1459    
1460  (** normalizing the plambda expression into FLINT *)  (** normalizing the plambda expression into FLINT *)
1461  val flint = let val _ = print "prenorm\n"  val flint = let val _ = debugmsg ">>norm"
1462                  val n = FlintNM.norm plexp                  val n = FlintNM.norm plexp
1463                  val _ = print "postnorm\n"                  val _ = debugmsg "<<postnorm"
1464              in n end              in n end
1465    
1466  in {flint = flint, imports = imports}  in {flint = flint, imports = imports}

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

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