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/FLINT/trans/translate.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/trans/translate.sml

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

revision 17, Wed Mar 11 21:00:18 1998 UTC revision 24, Thu Mar 12 00:49:58 1998 UTC
# Line 5  Line 5 
5  sig  sig
6    
7    (* Invariant: transDec always applies to a top-level absyn declaration *)    (* Invariant: transDec always applies to a top-level absyn declaration *)
8    val transDec : Absyn.dec * Access.lvar list    val transDec : Absyn.dec * Lambda.lvar list * StaticEnv.staticEnv *
9                   * StaticEnv.staticEnv * CompBasic.compInfo                   ElabUtil.compInfo
10                   -> {flint: FLINT.prog,                   -> {genLambda: Lambda.lexp option list -> Lambda.lexp,
11                       imports: PersStamps.persstamp list}                       importPids: PersStamps.persstamp list}
12    
13  end (* signature TRANSLATE *)  end (* signature TRANSLATE *)
14    
# Line 20  Line 20 
20        structure DA = Access        structure DA = Access
21        structure DI = DebIndex        structure DI = DebIndex
22        structure EM = ErrorMsg        structure EM = ErrorMsg
23        structure CB = CompBasic        structure EU = ElabUtil
24        structure II = InlInfo        structure II = InlInfo
25        structure LT = PLambdaType        structure LT = PLambdaType
26        structure M  = Modules        structure M  = Modules
# Line 118  Line 118 
118   ****************************************************************************)   ****************************************************************************)
119    
120  fun transDec (rootdec, exportLvars, env,  fun transDec (rootdec, exportLvars, env,
121                compInfo as {coreEnv,errorMatch,error,...}: CB.compInfo) =                compInfo as {coreEnv,errorMatch,error,...}: EU.compInfo) =
122  let  let
123    
124  (*  (*
# Line 331  Line 331 
331     in fill pat     in fill pat
332    end (* function fillPat *)    end (* function fillPat *)
333    
334    (*
335    val fillPat = Stats.doPhase(Stats.makePhase "Compiler 047 4-fillPat") fillPat
336    *)
337    
338  (** The runtime polymorphic equality and string equality dictionary. *)  (** The runtime polymorphic equality and string equality dictionary. *)
339  val eqDict =  val eqDict =
340    let val strEqRef : lexp option ref = ref NONE    let val strEqRef : lexp option ref = ref NONE
# Line 632  Line 636 
636                            COND(APP(cmpOp(LESSU),                            COND(APP(cmpOp(LESSU),
637                                     RECORD[vi,APP(lenOp seqtc, va)]),                                     RECORD[vi,APP(lenOp seqtc, va)]),
638                                 APP(oper, RECORD[va,vi,vv]),                                 APP(oper, RECORD[va,vi,vv]),
639                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))                                 mkRaise(coreExn "Subscript", lt_int))))))
640                end                end
641    
642          | g (PO.NUMUPDATE{kind,checked=true}) =          | g (PO.NUMUPDATE{kind,checked=true}) =
# Line 654  Line 658 
658                            COND(APP(cmpOp(LESSU),                            COND(APP(cmpOp(LESSU),
659                                     RECORD[vi,APP(lenOp tc1, va)]),                                     RECORD[vi,APP(lenOp tc1, va)]),
660                                 APP(oper', RECORD[va,vi,vv]),                                 APP(oper', RECORD[va,vi,vv]),
661                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))                                 mkRaise(coreExn "Subscript", lt_int))))))
662                end                end
663    
664          | g (PO.ASSIGN) =          | g (PO.ASSIGN) =
# Line 925  Line 929 
929   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *
930   *                                                                         *   *                                                                         *
931   ***************************************************************************)   ***************************************************************************)
932    (*
933    and mkDec x = Stats.doPhase(Stats.makePhase "Compiler 048 mkDec") mkDec0 x
934    and mkExp x = Stats.doPhase(Stats.makePhase "Compiler 049 mkExp") mkExp0 x
935    *)
936  and mkDec (dec, d) =  and mkDec (dec, d) =
937    let fun g (VALdec vbs) = mkVBs(vbs, d)    let fun g (VALdec vbs) = mkVBs(vbs, d)
938          | g (VALRECdec rvbs) = mkRVBs(rvbs, d)          | g (VALRECdec rvbs) = mkRVBs(rvbs, d)
# Line 976  Line 984 
984               (** NOTE: the above won't work for cross compiling to               (** NOTE: the above won't work for cross compiling to
985                         multi-byte characters **)                         multi-byte characters **)
986    
987          | g (RECORDexp []) = unitLexp          | g (RECORDexp []) = INT 0
988          | g (RECORDexp xs) =          | g (RECORDexp xs) =
989               if sorted xs then RECORD (map (fn (_,e) => g e) xs)               if sorted xs then RECORD (map (fn (_,e) => g e) xs)
990               else let val vars = map (fn (l,e) => (l,(g e, mkv()))) xs               else let val vars = map (fn (l,e) => (l,(g e, mkv()))) xs
# Line 1006  Line 1014 
1014                   val nd = DI.next d                   val nd = DI.next d
1015                in case (ks, tps)                in case (ks, tps)
1016                    of ([], []) => g e                    of ([], []) => g e
1017                     | _ => PACK(LT.ltc_poly(ks, [TT.toLty nd nty]),                     | _ => PACK(LT.ltc_poly(ks, [TT.toLty nd nty]), ts, nts , g e)
                                ts, nts , g e)  
1018               end               end
1019  *)  *)
1020          | g (SEQexp [e]) = g e          | g (SEQexp [e]) = g e
# Line 1056  Line 1063 
1063   * closeLexp `closes' over all free (EXTERN) variables [`inlining' version]   * closeLexp `closes' over all free (EXTERN) variables [`inlining' version]
1064   *  - make sure that all operations on various imparative data structures   *  - make sure that all operations on various imparative data structures
1065   *    are carried out NOW and not later when the result function is called.   *    are carried out NOW and not later when the result function is called.
1066     *
1067     * val closeLexp : PLambda.lexp
1068     *                  -> (Lambda.lexp option list -> Lambda.lexp) * pid list
1069   *)   *)
1070  fun closeLexp body =  fun closeLexp body =
1071    let (* free variable + pid + inferred lty *)    let (* free variable + pid + inferred lty *)
# Line 1064  Line 1074 
1074        (* the name of the `main' argument *)        (* the name of the `main' argument *)
1075        val imports = mkv ()        val imports = mkv ()
1076        val impVar = VAR (imports)        val impVar = VAR (imports)
1077    
1078        val impLty = LT.ltc_str (map (fn (_, (_, lt)) => lt) l)        val impLty = LT.ltc_str (map (fn (_, (_, lt)) => lt) l)
1079    
1080        fun h ((_, (lvar, lt)) :: rest, i, lexp) =        fun h (_ :: xs, (_, (lvar, lt)) :: rest, i, lexp) =
1081              let val hdr = buildHdr lvar              let val hdr = buildHdr lvar
1082                  val bindexp = LET(lvar, SELECT(i, impVar), hdr lexp)                  val bindexp = LET(lvar, SELECT(i, impVar), hdr lexp)
1083               in h (rest, i + 1, bindexp)               in h (xs, rest, i + 1, bindexp)
1084              end              end
1085          | h ([], _, lexp) = FN (imports, impLty, lexp)          | h ([], [], _, lexp) = FN (imports, impLty, lexp)
1086            | h _ = bug "unexpected arguments in close"
1087    
1088          fun genLexp inls =
1089            let val plexp = h(inls, l, 0, body)
1090    
1091          val _ = if !Control.CG.printLambda
1092                  then (say "\n\n[After Translation into PLambda ...]\n\n";
1093                        PPLexp.printLexp plexp)
1094                  else ()
1095    
1096    
1097        val plexp = h(l, 0, body)           in if !Control.CG.flinton then
1098     in {flint = FlintNM.norm plexp, imports = (map #1 l)}                let val flexp = (FlintNM.norm plexp)
1099    
1100          val _ = if !Control.CG.printLambda
1101                  then (say "\n\n[After Translation into FLINT ...]\n\n";
1102                        PPFlint.printFundec flexp)
1103                  else ()
1104    
1105                   in (Flint2Lambda.transFundec flexp)
1106                  end
1107                else NormLexp.normLexp plexp
1108            end
1109    
1110       in {genLambda = (fn inls => genLexp inls),
1111           importPids = (map #1 l)}
1112    end    end
1113    
1114  val exportLexp = SRECORD (map VAR exportLvars)  val exportLexp = SRECORD (map VAR exportLvars)
# Line 1085  Line 1119 
1119  end (* top-level local *)  end (* top-level local *)
1120  end (* structure Translate *)  end (* structure Translate *)
1121    
1122    (*
1123     * $Log: translate.sml,v $
1124     * Revision 1.9  1997/08/15  16:05:26  jhr
1125     *   Bug fix to lift free structure references outside closures [zsh].
1126     *
1127     * Revision 1.8  1997/05/05  20:00:17  george
1128     *   Change the term language into the quasi-A-normal form. Added a new round
1129     *   of lambda contraction before and after type specialization and
1130     *   representation analysis. Type specialization including minimum type
1131     *   derivation is now turned on all the time. Real array is now implemented
1132     *   as realArray. A more sophisticated partial boxing scheme is added and
1133     *   used as the default.
1134     *
1135     * Revision 1.7  1997/04/18  15:49:04  george
1136     *   Cosmetic changes on some constructor names. Changed the shape for
1137     *   FIX type to potentially support shared dtsig. -- zsh
1138     *
1139     * Revision 1.6  1997/04/08  19:42:15  george
1140     *   Fixed a bug in inlineShift operations. The test to determine if the
1141     *   shift amount is within range should always an UINT 31 comparison --
1142     *   regardless of the entity being shifted.
1143     *
1144     * Revision 1.5  1997/03/25  13:41:44  george
1145     *   Fixing the coredump bug caused by duplicate top-level declarations.
1146     *   For example, in almost any versions of SML/NJ, typing
1147     *           val x = "" val x = 3
1148     *   would lead to core dump. This is avoided by changing the "exportLexp"
1149     *   field returned by the pickling function (pickle/picklemod.sml) into
1150     *   a list of lambdavars, and then during the pretty-printing (print/ppdec.sml),
1151     *   each variable declaration is checked to see if it is in the "exportLvars"
1152     *   list, if true, it will be printed as usual, otherwise, the pretty-printer
1153     *   will print the result as <hiddle-value>.
1154     *                                              -- zsh
1155     *
1156     * Revision 1.4  1997/03/22  18:25:25  dbm
1157     * Added temporary debugging code.  This could be cleaned out later.
1158     *
1159     * Revision 1.3  1997/02/26  21:54:48  george
1160     *   Putting back the access-lifting code to avoid the "exportFn image blowup"
1161     *   bug --- BUG 1142.
1162     *
1163     * Revision 1.1.1.1  1997/01/14  01:38:47  george
1164     *   Version 109.24
1165     *
1166     *)
1167    

Legend:
Removed from v.17  
changed lines
  Added in v.24

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