home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Front.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  29.4 KB  |  826 lines  |  [TEXT/R*ch]
  1. (* front.ml : translation abstract syntax -> extended lambda-calculus. *)
  2.  
  3. open Misc List Obj Fnlib Config Mixture Const Smlexc Prim Lambda Smlprim;
  4. open Globals Location Units Types Asynt Asyntfn Tr_env Match;
  5.  
  6. datatype SMLPrimImpl =
  7.     GVprim of QualifiedIdent
  8.   | VMprim of int * primitive
  9.   | VMPprim of int * primitive
  10.   | GVTprim of QualifiedIdent * obj
  11. ;
  12.  
  13. val getPrimImpl = fn
  14.     MLPeq =>         VMPprim(1, Pccall("sml_equal", 2))
  15.   | MLPnoteq =>      VMPprim(1, Pccall("sml_not_equal", 2))
  16.   | MLPeq_c =>       VMprim (2, Pccall("sml_equal", 2))
  17.   | MLPnoteq_c =>    VMprim (2, Pccall("sml_not_equal", 2))
  18.   | MLPref =>        VMprim (1, Pmakeblock (CONtag(refTag, 1)))
  19.   | MLPsetref =>     VMPprim(1, Psetfield 0)
  20.   | MLPsetref_c  =>  VMprim (2, Psetfield 0)
  21.   | MLPadd_int   =>  VMPprim(1, Psmladdint)
  22.   | MLPsub_int   =>  VMPprim(1, Psmlsubint)
  23.   | MLPmul_int   =>  VMPprim(1, Psmlmulint)
  24.   | MLPdiv_int   =>  VMPprim(1, Psmldivint)
  25.   | MLPmod_int   =>  VMPprim(1, Psmlmodint)
  26.   | MLPquot_int  =>  VMPprim(1, Psmlquotint)
  27.   | MLPrem_int   =>  VMPprim(1, Psmlremint)
  28.   | MLPeq_int    =>  VMPprim(1, Ptest(Pint_test PTeq))
  29.   | MLPnoteq_int =>  VMPprim(1, Ptest(Pint_test PTnoteq))
  30.   | MLPlt_int    =>  VMPprim(1, Ptest(Pint_test PTlt))
  31.   | MLPgt_int    =>  VMPprim(1, Ptest(Pint_test PTgt))
  32.   | MLPle_int    =>  VMPprim(1, Ptest(Pint_test PTle))
  33.   | MLPge_int    =>  VMPprim(1, Ptest(Pint_test PTge))
  34.   | MLPadd_int_c =>  VMprim (2, Psmladdint)
  35.   | MLPsub_int_c =>  VMprim (2, Psmlsubint)
  36.   | MLPmul_int_c =>  VMprim (2, Psmlmulint)
  37.   | MLPdiv_int_c =>  VMprim (2, Psmldivint)
  38.   | MLPmod_int_c =>  VMprim (2, Psmlmodint)
  39.   | MLPquot_int_c => VMprim (2, Psmlquotint)
  40.   | MLPrem_int_c =>  VMprim (2, Psmlremint)
  41.   | MLPeq_int_c =>   VMprim (2, Ptest(Pint_test PTeq))
  42.   | MLPnoteq_int_c => VMprim (2, Ptest(Pint_test PTnoteq))
  43.   | MLPlt_int_c =>   VMprim (2, Ptest(Pint_test PTlt))
  44.   | MLPgt_int_c =>   VMprim (2, Ptest(Pint_test PTgt))
  45.   | MLPle_int_c =>   VMprim (2, Ptest(Pint_test PTle))
  46.   | MLPge_int_c =>   VMprim (2, Ptest(Pint_test PTge))
  47.   | MLPadd_real =>   VMPprim(1, Pfloatprim Psmladdfloat)
  48.   | MLPsub_real =>   VMPprim(1, Pfloatprim Psmlsubfloat)
  49.   | MLPmul_real =>   VMPprim(1, Pfloatprim Psmlmulfloat)
  50.   | MLPdiv_real =>   VMPprim(1, Pfloatprim Psmldivfloat)
  51.   | MLPlt_real =>    VMPprim(1, Ptest(Pfloat_test PTlt))
  52.   | MLPgt_real =>    VMPprim(1, Ptest(Pfloat_test PTgt))
  53.   | MLPle_real =>    VMPprim(1, Ptest(Pfloat_test PTle))
  54.   | MLPge_real =>    VMPprim(1, Ptest(Pfloat_test PTge))
  55.   | MLPadd_real_c => VMprim (2, Pfloatprim Psmladdfloat)
  56.   | MLPsub_real_c => VMprim (2, Pfloatprim Psmlsubfloat)
  57.   | MLPmul_real_c => VMprim (2, Pfloatprim Psmlmulfloat)
  58.   | MLPdiv_real_c => VMprim (2, Pfloatprim Psmldivfloat)
  59.   | MLPlt_real_c =>  VMprim (2, Ptest(Pfloat_test PTlt))
  60.   | MLPgt_real_c =>  VMprim (2, Ptest(Pfloat_test PTgt))
  61.   | MLPle_real_c =>  VMprim (2, Ptest(Pfloat_test PTle))
  62.   | MLPge_real_c =>  VMprim (2, Ptest(Pfloat_test PTge))
  63.   | MLPlt_string =>  VMPprim(1, Ptest(Pstring_test PTlt))
  64.   | MLPgt_string =>  VMPprim(1, Ptest(Pstring_test PTgt))
  65.   | MLPle_string =>  VMPprim(1, Ptest(Pstring_test PTle))
  66.   | MLPge_string =>  VMPprim(1, Ptest(Pstring_test PTge))
  67.   | MLPconcat =>     VMPprim(1, Pccall("sml_concat", 2))
  68.   | MLPlt_string_c => VMprim (2, Ptest(Pstring_test PTlt))
  69.   | MLPgt_string_c => VMprim (2, Ptest(Pstring_test PTgt))
  70.   | MLPle_string_c => VMprim (2, Ptest(Pstring_test PTle))
  71.   | MLPge_string_c => VMprim (2, Ptest(Pstring_test PTge))
  72.   | MLPconcat_c    => VMprim(2, Pccall("sml_concat", 2))
  73.   | MLPadd_word   =>  VMPprim(1, Paddint)
  74.   | MLPsub_word   =>  VMPprim(1, Psubint)
  75.   | MLPmul_word   =>  VMPprim(1, Pmulint)
  76.   | MLPdiv_word   =>  VMPprim(1, Pdivint)
  77.   | MLPmod_word   =>  VMPprim(1, Pmodint)
  78.   | MLPadd_word_c =>  VMprim (2, Paddint)
  79.   | MLPsub_word_c =>  VMprim (2, Psubint)
  80.   | MLPmul_word_c =>  VMprim (2, Pmulint)
  81.   | MLPdiv_word_c =>  VMprim (2, Pdivint)
  82.   | MLPmod_word_c =>  VMprim (2, Pmodint)
  83.   | MLPeq_word     => VMPprim(1, Ptest(Pword_test PTeq))
  84.   | MLPnoteq_word  => VMPprim(1, Ptest(Pword_test PTnoteq))
  85.   | MLPlt_word     => VMPprim(1, Ptest(Pword_test PTlt))
  86.   | MLPgt_word     => VMPprim(1, Ptest(Pword_test PTgt))
  87.   | MLPle_word     => VMPprim(1, Ptest(Pword_test PTle))
  88.   | MLPge_word     => VMPprim(1, Ptest(Pword_test PTge))
  89.   | MLPeq_word_c   => VMprim (2, Ptest(Pword_test PTeq))
  90.   | MLPnoteq_word_c => VMprim (2, Ptest(Pword_test PTnoteq))
  91.   | MLPlt_word_c   => VMprim (2, Ptest(Pword_test PTlt))
  92.   | MLPgt_word_c   => VMprim (2, Ptest(Pword_test PTgt))
  93.   | MLPle_word_c   => VMprim (2, Ptest(Pword_test PTle))
  94.   | MLPge_word_c   => VMprim (2, Ptest(Pword_test PTge))
  95.   | MLPprim(arity, prim)  => VMprim(arity, prim)
  96.   | MLPccall(arity, name) => VMprim(arity, Pccall(name, arity))
  97.   | MLPgv qualid         => GVprim qualid
  98.   | MLPgvt(qualid, ref sc) =>   GVTprim(qualid, sc)
  99. ;
  100.  
  101. val curriedPrimVersion = fn
  102.     MLPeq       =>    SOME MLPeq_c
  103.   | MLPnoteq    =>    SOME MLPnoteq_c
  104.   | MLPsetref   =>    SOME MLPsetref_c
  105.   | MLPadd_int  =>    SOME MLPadd_int_c
  106.   | MLPsub_int  =>    SOME MLPsub_int_c
  107.   | MLPmul_int  =>    SOME MLPmul_int_c
  108.   | MLPdiv_int  =>    SOME MLPdiv_int_c
  109.   | MLPmod_int  =>    SOME MLPmod_int_c
  110.   | MLPquot_int =>    SOME MLPquot_int_c
  111.   | MLPrem_int  =>    SOME MLPrem_int_c
  112.   | MLPeq_int   =>    SOME MLPeq_int_c
  113.   | MLPnoteq_int =>   SOME MLPnoteq_int_c
  114.   | MLPlt_int   =>    SOME MLPlt_int_c
  115.   | MLPgt_int   =>    SOME MLPgt_int_c
  116.   | MLPle_int   =>    SOME MLPle_int_c
  117.   | MLPge_int   =>    SOME MLPge_int_c
  118.   | MLPadd_real =>    SOME MLPadd_real_c
  119.   | MLPsub_real =>    SOME MLPsub_real_c
  120.   | MLPmul_real =>    SOME MLPmul_real_c
  121.   | MLPdiv_real =>    SOME MLPdiv_real_c
  122.   | MLPlt_real  =>    SOME MLPlt_real_c
  123.   | MLPgt_real  =>    SOME MLPgt_real_c
  124.   | MLPle_real  =>    SOME MLPle_real_c
  125.   | MLPge_real  =>    SOME MLPge_real_c
  126.   | MLPlt_string =>   SOME MLPlt_string_c
  127.   | MLPgt_string =>   SOME MLPgt_string_c
  128.   | MLPle_string =>   SOME MLPle_string_c
  129.   | MLPge_string =>   SOME MLPge_string_c
  130.   | MLPconcat    =>   SOME MLPconcat_c
  131.   | MLPadd_word  =>   SOME MLPadd_word_c
  132.   | MLPsub_word  =>   SOME MLPsub_word_c
  133.   | MLPmul_word  =>   SOME MLPmul_word_c
  134.   | MLPdiv_word  =>   SOME MLPdiv_word_c
  135.   | MLPmod_word  =>   SOME MLPmod_word_c
  136.   | MLPeq_word   =>   SOME MLPeq_word_c
  137.   | MLPnoteq_word =>   SOME MLPnoteq_word_c
  138.   | MLPlt_word   =>   SOME MLPlt_word_c
  139.   | MLPgt_word   =>   SOME MLPgt_word_c
  140.   | MLPle_word   =>   SOME MLPle_word_c
  141.   | MLPge_word   =>   SOME MLPge_word_c
  142.   | _            =>   NONE
  143. ;
  144.  
  145. (* Translation of expressions *)
  146.  
  147. exception Not_constant;
  148.  
  149. fun extractConstant (Lconst cst) = cst
  150.   | extractConstant _ = raise Not_constant
  151. ;
  152.  
  153. val bindConst  = Lconst(BLOCKsc(EXNtag bindTagName,  []));
  154. val matchConst = Lconst(BLOCKsc(EXNtag matchTagName, []));
  155. val bindRaiser  = Lprim(Praise, [bindConst]);
  156. val matchRaiser = Lprim(Praise, [matchConst]);
  157.  
  158.  
  159. fun partial_fun (loc as Loc(start,stop)) () =
  160.     (msgIBlock 0;
  161.      errLocation loc;
  162.      errPrompt "Warning: pattern matching is not exhaustive";
  163.      msgEOL(); msgEOL();
  164.      msgEBlock();
  165.      matchRaiser);
  166.  
  167. fun partial_let (onTop : bool) (loc as Loc(start,stop)) () =
  168.     (if not onTop then
  169.      (msgIBlock 0;
  170.       errLocation loc;
  171.       errPrompt "Warning: pattern matching is not exhaustive";
  172.       msgEOL(); msgEOL();
  173.       msgEBlock())
  174.      else ();
  175.      bindRaiser);
  176.  
  177. fun partial_try () =
  178.     Lprim(Praise, [Lvar 0]);
  179.  
  180. val smlExnTag = EXNtag exnTagName;
  181.  
  182. fun extract_fields arity =
  183.   let fun loop i =
  184.     if i >= arity then []
  185.     else
  186.       Lprim(Pfield i, [Lvar 0]) :: loop (i+1)
  187.   in loop 0 end
  188. ;
  189.  
  190. fun normApp (func as (_, func')) args =
  191.   case func' of
  192.       PARexp e        => normApp e args
  193.     | TYPEDexp(e,_)   => normApp e args
  194.     | APPexp(e1,e2)   => normApp e1 (e2 :: args)
  195.     | _               => (func, args)
  196. ;
  197.  
  198. fun extractPairArg (_, exp') =
  199.   case exp' of
  200.       PARexp e                       => extractPairArg e
  201.     | TYPEDexp(e,_)                  => extractPairArg e
  202.     | RECexp(ref (TUPLEre [e1,e2]))  => SOME (e1, e2)
  203.     | _                              => NONE
  204. ;
  205.  
  206. fun canSplitFirstArg (Lvar n :: args) = true
  207.   | canSplitFirstArg (Lprim(Pget_global _, []) :: args) = true
  208.   | canSplitFirstArg _ = false
  209. ;
  210.  
  211. fun splitFirstArg (arg :: args) =
  212.       Lprim(Pfield 0, [arg]) :: Lprim(Pfield 1, [arg]) :: args
  213.   | splitFirstArg _ = fatalError "splitFirstArg"
  214. ;
  215.  
  216. (* An expression is "safe", if evaluating it can't produce *)
  217. (* side-effects, i.e. I/O, exceptions, etc. *)
  218. (* The following is a crude approximation... *)
  219.  
  220. fun isSafe (_, exp') =
  221.   case exp' of
  222.     SCONexp _ => true
  223.   | VARexp _ => true
  224.   | FNexp _ => true
  225.   | APPexp(e1,e2) => false
  226.   | RECexp(ref (RECre fs)) =>
  227.       all (fn (_, e) => isSafe e) fs
  228.   | RECexp(ref (TUPLEre es)) =>
  229.       all isSafe es
  230.   | VECexp es =>
  231.       all isSafe es
  232.   | PARexp e => isSafe e
  233.   | LETexp (dec,exp) => false
  234.   | INFIXexp es => fatalError "isSafe"
  235.   | TYPEDexp(e,ty) => isSafe e
  236.   | ANDALSOexp(e1,e2) =>
  237.       isSafe e1 andalso isSafe e2
  238.   | ORELSEexp(e1,e2) =>
  239.       isSafe e1 andalso isSafe e2
  240.   | HANDLEexp(e, mrules) => false
  241.   | RAISEexp e => false
  242.   | IFexp(e0,e1,e2) =>
  243.       isSafe e0 andalso isSafe e1 andalso isSafe e2
  244.   | WHILEexp(e1,e2) =>
  245.       isSafe e1 andalso isSafe e2
  246.   | SEQexp(e1,e2) =>
  247.       isSafe e1 andalso isSafe e2
  248. ;
  249.  
  250. (* All unsafe arguments must be lifted, except the rightmost one, *)
  251. (* in order to preserve the evaluation order. *)
  252.  
  253. datatype AppArgs =
  254.     SAFEarg of Exp
  255.   | CONSTarg of Lambda
  256.   | UNSAFEarg
  257. ;
  258.  
  259. fun trConVar (ci : ConInfo) =
  260.   let val {conArity, conIsGreedy, conTag, conSpan, ...} = !ci in
  261.     case (conIsGreedy, conArity, conSpan) of
  262.         (true,  _, _) =>
  263.           Lfn(Lprim(
  264.             Pmakeblock(CONtag(conTag,conSpan)), extract_fields conArity))
  265.       | (false, 0, _) =>
  266.           Lconst(BLOCKsc(CONtag(conTag,conSpan), []))
  267.       | (false, _, 1) =>
  268.           Lfn(Lvar 0)
  269.       | (false, _, _) =>
  270.           Lfn(Lprim(Pmakeblock(CONtag(conTag,conSpan)), [(Lvar 0)]))
  271.   end;
  272.  
  273. fun trStaticExConVar isGreedy arity tag =
  274.   case (isGreedy, arity) of
  275.       (true,  _) =>
  276.         Lfn(Lprim(Pmakeblock(EXNtag tag), extract_fields arity))
  277.     | (false, 0) =>
  278.         Lconst(BLOCKsc(EXNtag tag, []))
  279.     | (false, _) =>
  280.         Lfn(Lprim(Pmakeblock (EXNtag tag), [Lvar 0]))
  281. ;
  282.  
  283. fun trExConVar (env as (rho, depth)) q (ei : ExConInfo) =
  284.   let val {qual, id} = q
  285.       val {exconArity, exconIsGreedy, exconTag, ...} = !ei
  286.   in
  287.     case exconTag of
  288.         NONE =>
  289.           if exconArity = 0 then
  290.             let val en = translateLocalAccess env id
  291.             in Lprim(Pmakeblock smlExnTag, [en]) end
  292.           else
  293.             let val en = translateLocalAccess (rho, depth+1) id
  294.             in Lfn(Lprim(Pmakeblock smlExnTag, [en, Lvar 0])) end
  295.      | SOME tag =>
  296.          trStaticExConVar exconIsGreedy exconArity tag
  297.   end;
  298.  
  299. fun trTopExConVar (ei : ExConInfo) =
  300.   let val {exconArity, exconIsGreedy, exconTag, ...} = !ei in
  301.     case exconTag of
  302.         NONE => fatalError "trTopExConVar"
  303.       | SOME tag =>
  304.          trStaticExConVar exconIsGreedy exconArity tag
  305.   end;
  306.  
  307. fun trPrimVar prim =
  308.   case getPrimImpl prim of
  309.       GVprim globalName =>
  310.         Lprim(Pget_global (globalName, 0), [])
  311.     | VMprim(arity, p) =>
  312.         let fun make_fn n args =
  313.           if n >= arity
  314.           then Lprim(p, args)
  315.           else Lfn(make_fn (n+1) (Lvar n :: args))
  316.         in make_fn 0 [] end
  317.     | VMPprim(arity, p) =>
  318.         let fun make_fn n args =
  319.           if n >= arity
  320.           then Lprim(p, splitFirstArg args)
  321.           else Lfn(make_fn (n+1) (Lvar n :: args))
  322.         in make_fn 0 [] end
  323.     | GVTprim(globalName, sc) =>
  324.         Lfn(Lapply(
  325.               Lprim(Pget_global (globalName, 0), []),
  326.               [Lconst(QUOTEsc (ref sc)), Lvar 0]))
  327. ;
  328.  
  329. fun trVar (env as (rho, depth)) (ii : IdInfo) =
  330.   let val {info={idKind, ...}, ...} = ii
  331.       val {qualid, info} = !idKind
  332.   in
  333.     case info of
  334.         VARik =>
  335.           translateAccess env qualid
  336.       | PRIMik pi =>
  337.           trPrimVar (#primOp pi)
  338.       | CONik ci =>
  339.           trConVar ci
  340.       | EXCONik ei =>
  341.           trExConVar env qualid ei
  342.   end;
  343.  
  344. fun trExp (env as (rho, depth)) (exp as (loc, exp')) =
  345.   case exp' of
  346.     SCONexp (scon, _) =>
  347.       Lconst (ATOMsc scon)
  348.   | VARexp(ref (RESve ii)) =>
  349.       trVar env ii
  350.   | VARexp(ref (OVLve _)) => fatalError "trExp"
  351.   | FNexp [] =>
  352.       fatalError "trExp: empty fun"
  353.   | FNexp(mrules as MRule(pats,_)::_) =>
  354.       foldR (fn pat => fn lam => Lfn lam)
  355.             (trMatch loc env (partial_fun loc) mrules)
  356.             pats
  357.   | APPexp(e1,e2) =>
  358.       (case normApp e1 [e2] of
  359.            (func as (loc, FNexp mrules), args) =>
  360.              if curriedness mrules = List.length args then
  361.                Llet(trLetArgs env args,
  362.                     trMatch loc env (partial_fun loc) mrules)
  363.              else
  364.                let val (env', tr_args, envelope) = trArgs env args
  365.                in envelope(Lapply(trExp env' func, tr_args)) end
  366.           | (func as (_, VARexp(ref (RESve ii))), args) =>
  367.               trVarApp env ii args
  368.           | (func, args) =>
  369.               let val (env', tr_args, envelope) = trArgs env (func :: args)
  370.               in envelope(Lapply(hd tr_args, tl tr_args)) end)
  371.   | RECexp(ref (RECre fs)) =>
  372.       trRec env (CONtag(0,1)) fs
  373.   | RECexp(ref (TUPLEre es)) =>
  374.       trTuple env (CONtag(0,1)) es
  375.   | VECexp es =>
  376.       trTuple env (CONtag(0,1)) es
  377.   | PARexp e => trExp env e
  378.   | LETexp (dec,exp) =>
  379.       let val ((rho', depth'), envelope) = trDec env dec
  380.           val env'' = (plusEnv rho rho', depth')
  381.       in envelope(trExp env'' exp) end
  382.   | INFIXexp es => fatalError "trExp"
  383.   | TYPEDexp(e,ty) => trExp env e
  384.   | ANDALSOexp(e1,e2) =>
  385.       Landalso(trExp env e1, trExp env e2)
  386.   | ORELSEexp(e1,e2) =>
  387.       Lorelse(trExp env e1, trExp env e2)
  388.   | HANDLEexp(e, mrules) =>
  389.       Lhandle(trExp env e, trMatch loc env partial_try mrules)
  390.   | RAISEexp e =>
  391.       Lprim(Praise, [trExp env e])
  392.   | IFexp(e0,e1,e2) =>
  393.       Lif(trExp env e0, trExp env e1, trExp env e2)
  394.   | WHILEexp(e1,e2) =>
  395.       Lwhile(trExp env e1, trExp env e2)
  396.   | SEQexp(e1,e2) =>
  397.       Lseq(trExp env e1, trExp env e2)
  398.  
  399. and trVarApp env (ii : IdInfo) args =
  400.   let val {qualid={id, ...}, info={idKind, ...}} = ii in
  401.     case #info(!idKind) of
  402.         VARik =>
  403.           let val (env', tr_args, envelope) = trArgs env args
  404.           in envelope(Lapply(trVar env' ii, tr_args)) end
  405.       | PRIMik pi =>
  406.           let val {primOp, ...} = pi in
  407.             case curriedPrimVersion primOp of
  408.                 NONE => trPrimApp env primOp args
  409.               | SOME prim_c =>
  410.                   (case extractPairArg (hd args) of
  411.                         NONE => trPrimApp env primOp args
  412.                       | SOME(arg', arg'') =>
  413.                           trPrimApp env prim_c (arg'::arg''::(tl args)))
  414.           end
  415.       | CONik ci =>
  416.           let val {conArity, conIsGreedy, conTag, conSpan, ...} = !ci in
  417.             if List.length args <> 1 then
  418.               fatalError "trVarApp: unary con requires 1 arg"
  419.             else ();
  420.             case (conIsGreedy, conArity, conSpan) of
  421.                 (true,  _, _) =>
  422.                   (case (hd args) of
  423.                       (_, RECexp(ref (RECre fs))) =>
  424.                         trRec env (CONtag(conTag,conSpan)) fs
  425.                     | (_, RECexp(ref (TUPLEre es))) =>
  426.                         trTuple env (CONtag(conTag,conSpan)) es
  427.                     | _ =>
  428.                         Llet([trExp env (hd args)],
  429.                               Lprim(Pmakeblock(CONtag(conTag,conSpan)),
  430.                                     extract_fields conArity)))
  431.               | (false, 0, _) =>
  432.                   fatalError "trVarApp: nullary con in app"
  433.               | (false, _, 1) =>
  434.                   trExp env (hd args)
  435.               | (false, _, _) =>
  436.                   (* Normal unary con, in the end... *)
  437.                   let val tr_arg = trExp env (hd args) in
  438.                     Lconst(BLOCKsc(CONtag(conTag,conSpan),
  439.                                     [extractConstant tr_arg]))
  440.                     handle Not_constant =>
  441.                         Lprim(Pmakeblock(CONtag(conTag,conSpan)), [tr_arg])
  442.                   end
  443.           end
  444.       | EXCONik ei =>
  445.           let val {exconArity, exconIsGreedy, exconTag, ...} = !ei in
  446.             if List.length args <> 1 then
  447.               fatalError "trVarApp: unary excon requires 1 arg"
  448.             else ();
  449.             case exconTag of
  450.                 NONE =>
  451.                   let val () =
  452.                         if exconArity = 0 then
  453.                           fatalError "trVarApp: nullary excon in app"
  454.                         else ();
  455.                       val en = translateLocalAccess env id
  456.                       val tr_arg = trExp env (hd args)
  457.                   in Lprim(Pmakeblock smlExnTag, [en, tr_arg]) end
  458.               | SOME tag =>
  459.                  (case (exconIsGreedy, exconArity) of
  460.                     (true,  _) =>
  461.                       (case (hd args) of
  462.                           (_, RECexp(ref (RECre fs))) =>
  463.                             trRec env (EXNtag tag) fs
  464.                         | (_, RECexp(ref (TUPLEre es))) =>
  465.                             trTuple env (EXNtag tag) es
  466.                         | _ =>
  467.                             Llet([trExp env (hd args)],
  468.                                   Lprim(Pmakeblock(EXNtag tag),
  469.                                         extract_fields exconArity)))
  470.                   | (false, 0) =>
  471.                       fatalError "trVarApp: nullary excon in app"
  472.                   | (false, _) =>
  473.                       let val tr_arg = trExp env (hd args)
  474.                       in Lprim(Pmakeblock (EXNtag tag), [tr_arg]) end)
  475.           end
  476.   end
  477.  
  478. and trPrimApp env prim args =
  479.     case getPrimImpl prim of
  480.         GVprim globalName =>
  481.         let val (env', tr_args, envelope) = trArgs env args 
  482.         in envelope(Lapply(trPrimVar prim, tr_args)) end
  483.       | VMprim(arity, p) =>
  484.         if arity <> List.length args then 
  485.         let val (env', tr_args, envelope) = trArgs env args 
  486.         in envelope(Lapply(trPrimVar prim, tr_args)) end
  487.         else 
  488.         Lprim(p, map (trExp env) args)
  489.       | VMPprim(arity, p) =>
  490.         let val (env', tr_args, envelope) = trArgs env args 
  491.         in
  492.         if (arity <> List.length tr_args) then
  493.             envelope(Lapply(trPrimVar prim, tr_args))
  494.         else if canSplitFirstArg tr_args then
  495.             envelope(Lprim(p, splitFirstArg tr_args))
  496.         else if arity = 1 then
  497.             Llet(tr_args, Lprim(p, splitFirstArg [Lvar 0]))
  498.         else
  499.             envelope(Lapply(trPrimVar prim, tr_args))
  500.         end
  501.       | GVTprim(globalName, sc) =>
  502.         let val (env', tr_args, envelope) = trArgs env args 
  503.         in
  504.         envelope(Lapply(Lprim(Pget_global (globalName, 0), []),
  505.                 Lconst(QUOTEsc (ref sc))::tr_args))
  506.         end
  507.  
  508. and trRec env tag fs =
  509.   let val labs = map fst fs and es = map snd fs
  510.       val (env', tr_es, envelope) = trArgs env es
  511.       val tr_es' = map snd (sortRow (zip2 labs tr_es))
  512.   in
  513.     (case tag of CONtag _ => () | EXNtag _ => raise Not_constant;
  514.      envelope(Lconst(BLOCKsc(tag, map extractConstant tr_es'))))
  515.     handle Not_constant =>
  516.            envelope(Lprim(Pmakeblock tag, tr_es'))
  517.   end
  518.  
  519. and trTuple env tag es =
  520.   let val tr_es = map (trExp env) es in
  521.     (case tag of CONtag _ => () | EXNtag _ => raise Not_constant;
  522.      Lconst(BLOCKsc(tag, map extractConstant tr_es)))
  523.     handle Not_constant => Lprim(Pmakeblock tag, tr_es)
  524.   end
  525.  
  526. (* We recognize constant arguments only upon translating them, *)
  527. (* to avoid repeated traversals of the abstract syntax tree. *)
  528.  
  529. and classifyArgs (env as (rho, depth)) unsafe safe = fn
  530.     [] => (unsafe, safe)
  531.   | arg :: args =>
  532.       if isSafe arg then
  533.         classifyArgs env unsafe ((SAFEarg arg) :: safe) args
  534.       else
  535.         let val lam = trExp env arg in
  536.           case lam of
  537.               Lconst _ =>
  538.                 classifyArgs env unsafe ((CONSTarg lam) :: safe) args
  539.             | _ =>
  540.                 classifyArgs (rho, depth+1) (lam :: unsafe)
  541.                              (UNSAFEarg :: safe) args
  542.         end
  543.  
  544. and adjustHeadArgs env pos acc = fn
  545.     [] => acc
  546.   | SAFEarg exp :: rest =>
  547.       adjustHeadArgs env pos (trExp env exp :: acc) rest
  548.   | CONSTarg lam :: rest =>
  549.       adjustHeadArgs env pos (lam :: acc) rest
  550.   | UNSAFEarg :: rest =>
  551.       adjustHeadArgs env (pos+1) (Lvar pos :: acc) rest
  552.  
  553. (* The rightmost unsafe expression needn't be lifted, *)
  554. (* as it can't do any harm. *)
  555.  
  556. and adjustArgs env quasisafe acc = fn
  557.     [] => fatalError "adjustArgs"
  558.   | SAFEarg exp :: rest =>
  559.       adjustArgs env quasisafe (trExp env exp :: acc) rest
  560.   | CONSTarg lam :: rest =>
  561.       adjustArgs env quasisafe (lam :: acc) rest
  562.   | UNSAFEarg :: rest =>
  563.       adjustHeadArgs env 0 (quasisafe :: acc) rest
  564.  
  565. and trArgs (env as (rho, depth)) args =
  566.   case classifyArgs env [] [] args of
  567.       ([], safe) => (env, adjustHeadArgs env 0 [] safe, fn lam => lam)
  568.     | (quasisafe :: unsafe, safe) =>
  569.         let val num = List.length unsafe
  570.             val env' = (rho, depth + num)
  571.         in
  572.           (env',
  573.            adjustArgs env' quasisafe [] safe,
  574.            if num = 0 then fn lam => lam
  575.                       else fn lam => Llet(rev unsafe, lam))
  576.         end
  577.  
  578. and trValDec onTop (env as (rho, depth)) pvbs rvbs =
  579.   let val ((rho',  depth'),  envelope' ) =
  580.         trValBind onTop env pvbs
  581.       val ((rho'', depth''), envelope'') =
  582.         trRecValBind (rho, depth') rvbs
  583.   in
  584.     ((plusEnv rho' rho'', depth''), envelope' o envelope'')
  585.   end
  586.  
  587. and trDec (env as (rho, depth)) (loc, dec') =
  588.   case dec' of
  589.     VALdec (_, (pvbs, rvbs)) =>
  590.       trValDec false env pvbs rvbs
  591.   | PRIM_VALdec _ => ((NILenv, depth), fn lam => lam)
  592.   | FUNdec _ => fatalError "trDec"
  593.   | TYPEdec _ => ((NILenv, depth), fn lam => lam)
  594.   | PRIM_TYPEdec _ => ((NILenv, depth), fn lam => lam)
  595.   | DATATYPEdec(dbs, _) => ((NILenv, depth), fn lam => lam)
  596.   | ABSTYPEdec(dbs, _, dec2) =>
  597.       trDec env dec2
  598.   | EXCEPTIONdec ebs =>
  599.       trExBindList env ebs
  600.   | LOCALdec(dec1,dec2) =>
  601.       let val ((rho', depth'), envelope') =
  602.                               trDec env dec1
  603.           val ((rho'', depth''), envelope'') =
  604.                               trDec ((plusEnv rho rho'), depth') dec2
  605.       in ((rho'', depth''), envelope' o envelope'') end
  606.   | OPENdec _ => ((NILenv, depth), fn lam => lam)
  607.   | EMPTYdec => ((NILenv, depth), fn lam => lam)
  608.   | SEQdec(dec1,dec2) =>
  609.       let val ((rho', depth'), envelope') =
  610.                               trDec env dec1
  611.           val ((rho'', depth''), envelope'') =
  612.                               trDec ((plusEnv rho rho'), depth') dec2
  613.       in ((plusEnv rho' rho'', depth''), envelope' o envelope'') end
  614.   | FIXITYdec  _ =>  ((NILenv, depth), fn lam => lam)
  615.  
  616. and tr1ValBind onTop (env as (rho, depth)) (ValBind(pat, arg)) =
  617.   let val (env', add_lets) = mkEnvOfPats depth [pat]
  618.       val tr_arg = trExp env arg
  619.       val m_env = (rho, depth+1)
  620.       val loc = xLR pat
  621.       fun envelope lam =
  622.             Llet([tr_arg],
  623.               translateMatch m_env (partial_let onTop loc) loc
  624.                              [([pat], add_lets lam)])
  625.   in (env', envelope) end
  626.  
  627. and trValBind onTop (env as (rho, depth)) = fn
  628.     [] => ((NILenv, depth), fn lam => lam)
  629.   | [vb] =>
  630.       tr1ValBind onTop env vb
  631.   | vb :: vbs =>
  632.       let val (env' as (rho', depth'),  envelope') =
  633.              tr1ValBind onTop env vb
  634.           val (env'' as (rho'', depth''), envelope'') =
  635.              trValBind onTop (rho, depth') vbs
  636.       in ((plusEnv rho' rho'', depth''), envelope' o envelope'') end
  637.  
  638. and trRecValBind (env as (rho, depth)) = fn
  639.     [] => ((NILenv, depth), fn lam => lam)
  640.   | vbs =>
  641.       let val pats = map (fn ValBind(p, _) => p) vbs
  642.           val args = map (fn ValBind(_, e) => e) vbs
  643.           val (rho', depth') = mkEnvOfRecPats depth pats
  644.       val rho'' = mkHashEnv (length pats) rho'
  645.           val new_env = (plusEnv rho rho'', depth')
  646.           val tr_bindings = map (trExp new_env) args
  647.           fun envelope lam = Lletrec(tr_bindings, lam)
  648.       in ((rho'', depth'), envelope) end
  649.  
  650. and trMatch loc (env as (rho, depth)) failure_code mrules =
  651.   let val m_env = (rho, depth + curriedness mrules)
  652.       fun trMRule (MRule(pats, exp)) =
  653.         let val ((rho', depth'), add_lets) = mkEnvOfPats depth pats
  654.             val new_env = (plusEnv rho rho', depth')
  655.         in (pats, add_lets (trExp new_env exp)) end
  656.   in translateMatch m_env failure_code loc (map trMRule mrules) end
  657.  
  658. and trLetArgs (env as (rho, depth)) = fn
  659.     [] =>  []
  660.   | exp :: exps =>
  661.       trExp env exp :: trLetArgs (rho, depth+1) exps
  662.  
  663. and trBindings (env as (rho, depth)) = fn
  664.     [] => []
  665.   | (pat, exp) :: rest =>
  666.       trExp env exp :: trBindings (rho, depth+1) rest
  667.  
  668. and trExBindList (env as (rho, depth)) ebs =
  669.   let val id_path_list =
  670.         mapFrom (fn depth =>
  671.                  fn
  672.                     (EXDECexbind(ii, _))   =>
  673.                               (#id(#qualid ii), Path_local depth)
  674.                   | (EXEQUALexbind(ii, _)) =>
  675.                               (#id (#qualid ii), Path_local depth))
  676.                 depth ebs
  677.       and len = List.length ebs
  678.       and args = mapFrom (fn i => fn eb => trExBind (rho, i) eb) depth ebs
  679.       val rho' = foldR (fn (id, path) => fn rho => bindInEnv rho id path)
  680.                        NILenv id_path_list
  681.   in ((rho', depth+len), fn lam => Llet(args, lam)) end
  682.  
  683. and trExBind env = fn
  684.     EXDECexbind(ii, _) =>
  685.       let val () =
  686.             if isExConStatic(getExConInfo ii) then fatalError "trExBind"
  687.             else ()
  688.           val uname = ATOMsc(STRINGscon(currentUnitName()))
  689.           val exid  = ATOMsc(STRINGscon (#id (#qualid ii)))
  690.           val en = BLOCKsc(CONtag(0,1), [exid, uname])
  691.       in Lprim(Pmakeblock(CONtag(refTag, 1)), [Lconst en]) end
  692.   | EXEQUALexbind(ii, ii') =>
  693.       (if isExConStatic(getExConInfo ii') then fatalError "trExBind"
  694.        else ();
  695.        translateExName env ii')
  696. ;
  697.  
  698. (* Translation of toplevel declarations *)
  699.  
  700. fun makeSeq f [] = Lunspec
  701.   | makeSeq f [x] = f x
  702.   | makeSeq f (x::rest) = Lseq(f x, makeSeq f rest)
  703. ;
  704.  
  705. fun lookupLocalRenEnv renEnv id =
  706.   mkUniqueGlobalName (id, (lookup id renEnv))
  707.   handle Subscript => fatalError "lookupLocalRenEnv"
  708. ;
  709.  
  710. fun storeGlobal renEnv env var =
  711.   Lprim(Pset_global (lookupLocalRenEnv renEnv var),
  712.           [translateLocalAccess env var])
  713. ;
  714.  
  715. fun equGlobal renEnv var0 var =
  716.   Lprim(Pset_global (lookupLocalRenEnv renEnv var),
  717.     [Lprim(Pget_global (lookupLocalRenEnv renEnv var0), [])])
  718. ;
  719.  
  720. fun tr1ToplevelRecValBind renEnv rho = fn
  721.     ([], exp) => Lunspec
  722.   | ([var], exp) =>
  723.       Lprim(Pset_global (lookupLocalRenEnv renEnv var), [trExp (rho, 0) exp])
  724.   | (var :: vars, exp) =>
  725.       Lseq(Lprim(Pset_global (lookupLocalRenEnv renEnv var),
  726.                  [trExp (rho, 0) exp]),
  727.         makeSeq (equGlobal renEnv var) vars)
  728. ;
  729.  
  730. fun revWithoutDuplicates [] acc = acc
  731.   | revWithoutDuplicates (x :: xs) acc =
  732.       if member x acc then
  733.         revWithoutDuplicates xs acc
  734.       else
  735.         revWithoutDuplicates xs (x :: acc)
  736. ;
  737.  
  738. datatype TopLambda =
  739.     NILtlam
  740.   | SEQtlam of TopLambda * TopLambda
  741.   | LAMtlam of bool * Lambda
  742. ;
  743.  
  744. fun flattenTLam tlam acc =
  745.   case tlam of
  746.       NILtlam => acc
  747.     | SEQtlam(tlam1, tlam2) =>
  748.         flattenTLam tlam1 (flattenTLam tlam2 acc)
  749.     | LAMtlam(is_pure, lam) => (is_pure, lam) :: acc
  750. ;
  751.  
  752. fun trToplevelDec rho (dec as (_, dec')) =
  753.   case dec' of
  754.       VALdec (_, ([ValBind((_, VARpat ii), exp)], [])) =>
  755.         let val id = #id(#qualid ii)
  756.             val id' = mkUniqueGlobalName (renameId id)
  757.         in
  758.           (mk1Env id (Path_global id'),
  759.             LAMtlam(isSafe exp,
  760.               Lprim(Pset_global id', [trExp (rho, 0) exp])))
  761.         end
  762.     | VALdec (_, ([], rvbs)) =>
  763.         let val ves = map (fn ValBind(p, e) => (domPat p, e)) rvbs
  764.             val vars = foldL (fn (vs, _) => fn acc => vs @ acc) [] ves
  765.             val renEnv = map renameId vars
  766.             val rho' =
  767.               foldR (fn (id' as (id, _)) => fn rho =>
  768.                        bindInEnv rho id (Path_global (mkUniqueGlobalName id')))
  769.                     NILenv renEnv
  770.         val rho'' = mkHashEnv (length vars) rho'
  771.         in
  772.           (rho'',
  773.            LAMtlam(true,
  774.              makeSeq (tr1ToplevelRecValBind renEnv (plusEnv rho rho'')) ves))
  775.         end
  776.     | VALdec (_, (pvbs, rvbs)) =>
  777.         let val ((rho', depth'), envelope) =
  778.                trValDec true (rho, 0) pvbs rvbs
  779.             val vars = foldEnv (fn id => fn _ => fn vars => id :: vars) [] rho'
  780.         val n = length vars
  781.         val rho'' = mkHashEnv n rho'
  782.             val renEnv = map renameId vars
  783.         val renrho = 
  784.         foldR (fn (id' as (id,_)) => fn rho =>
  785.                bindInEnv rho id (Path_global (mkUniqueGlobalName id')))
  786.               NILenv renEnv
  787.         in
  788.           (mkHashEnv n renrho,
  789.            LAMtlam(
  790.              all (fn ValBind(_, e) => isSafe e) pvbs,
  791.              envelope (makeSeq (storeGlobal renEnv (rho'', depth'))
  792.                                (revWithoutDuplicates vars []))))
  793.         end
  794.     | PRIM_VALdec _ => (NILenv, NILtlam)
  795.     | FUNdec _ => fatalError "trToplevelDec"
  796.     | TYPEdec _ => (NILenv, NILtlam)
  797.     | PRIM_TYPEdec _ => (NILenv, NILtlam)
  798.     | DATATYPEdec(dbs, _) => (NILenv, NILtlam)
  799.     | ABSTYPEdec(dbs, _, dec2) =>
  800.         trToplevelDec rho dec2
  801.     | EXCEPTIONdec ebs => (NILenv, NILtlam)
  802.     | LOCALdec(dec1,dec2) =>
  803.         let val (rho' , tlam')  = trToplevelDec rho dec1
  804.             val (rho'', tlam'') = trToplevelDec (plusEnv rho rho') dec2
  805.         in (rho'', SEQtlam(tlam', tlam'')) end
  806.     | OPENdec _ => (NILenv, NILtlam)
  807.     | EMPTYdec => (NILenv, NILtlam)
  808.     | SEQdec(dec1,dec2) =>
  809.         let val (rho' , tlam')  = trToplevelDec rho dec1
  810.             val (rho'', tlam'') = trToplevelDec (plusEnv rho rho') dec2
  811.         in (plusEnv rho' rho'', SEQtlam(tlam', tlam'')) end
  812.     | FIXITYdec  _ =>  (NILenv, NILtlam)
  813. ;
  814.  
  815. fun REofRho1 id (Path_global (_, stamp)) re = (id, stamp) :: re
  816.   | REofRho1 _  _            _              = fatalError "REofRho1"
  817.  
  818. fun REofRho rho =
  819.   foldEnv REofRho1 [] rho
  820. ;
  821.  
  822. fun translateToplevelDec dec =
  823.   let val (rho, tlam) = trToplevelDec NILenv dec
  824.   in (REofRho rho, flattenTLam tlam []) end
  825. ;
  826.