Celestin Apprentice 5/Apprentice-Release5.iso/Source Code/C/Applications/Moscow ML 1.31/source code/mosml/src/compiler/Front.sml

Text File | 1996-07-03 | 27.6 KB | 787 lines | [TEXT/R*ch]

(* front.ml : translation abstract syntax -> extended lambda-calculus. *)

open Misc List Obj Fnlib Config Mixture Const Smlexc Prim Lambda Smlprim;
open Globals Location Units Types Asynt Asyntfn Tr_env Match;

datatype SMLPrimImpl =
    GVprim of QualifiedIdent
  | VMprim of int * primitive
  | VMPprim of int * primitive
  | GVTprim of QualifiedIdent * obj
;

val getPrimImpl = fn
    MLPeq =>         VMPprim(1, Pccall("sml_equal", 2))
  | MLPnoteq =>      VMPprim(1, Pccall("sml_not_equal", 2))
  | MLPeq_c =>       VMprim (2, Pccall("sml_equal", 2))
  | MLPnoteq_c =>    VMprim (2, Pccall("sml_not_equal", 2))
  | MLPref =>        VMprim (1, Pmakeblock (CONtag(refTag, 1)))
  | MLPsetref =>     VMPprim(1, Psetfield 0)
  | MLPsetref_c  =>  VMprim (2, Psetfield 0)
  | MLPadd_int   =>  VMPprim(1, Psmladdint)
  | MLPsub_int   =>  VMPprim(1, Psmlsubint)
  | MLPmul_int   =>  VMPprim(1, Psmlmulint)
  | MLPdiv_int   =>  VMPprim(1, Psmldivint)
  | MLPmod_int   =>  VMPprim(1, Psmlmodint)
  | MLPquot_int  =>  VMPprim(1, Psmlquotint)
  | MLPrem_int   =>  VMPprim(1, Psmlremint)
  | MLPlt_int    =>  VMPprim(1, Ptest(Pint_test PTlt))
  | MLPgt_int    =>  VMPprim(1, Ptest(Pint_test PTgt))
  | MLPle_int    =>  VMPprim(1, Ptest(Pint_test PTle))
  | MLPge_int    =>  VMPprim(1, Ptest(Pint_test PTge))
  | MLPadd_int_c =>  VMprim (2, Psmladdint)
  | MLPsub_int_c =>  VMprim (2, Psmlsubint)
  | MLPmul_int_c =>  VMprim (2, Psmlmulint)
  | MLPdiv_int_c =>  VMprim (2, Psmldivint)
  | MLPmod_int_c =>  VMprim (2, Psmlmodint)
  | MLPquot_int_c => VMprim (2, Psmlquotint)
  | MLPrem_int_c =>  VMprim (2, Psmlremint)
  | MLPlt_int_c =>   VMprim (2, Ptest(Pint_test PTlt))
  | MLPgt_int_c =>   VMprim (2, Ptest(Pint_test PTgt))
  | MLPle_int_c =>   VMprim (2, Ptest(Pint_test PTle))
  | MLPge_int_c =>   VMprim (2, Ptest(Pint_test PTge))
  | MLPadd_real =>   VMPprim(1, Pfloatprim Psmladdfloat)
  | MLPsub_real =>   VMPprim(1, Pfloatprim Psmlsubfloat)
  | MLPmul_real =>   VMPprim(1, Pfloatprim Psmlmulfloat)
  | MLPdiv_real =>   VMPprim(1, Pfloatprim Psmldivfloat)
  | MLPlt_real =>    VMPprim(1, Ptest(Pfloat_test PTlt))
  | MLPgt_real =>    VMPprim(1, Ptest(Pfloat_test PTgt))
  | MLPle_real =>    VMPprim(1, Ptest(Pfloat_test PTle))
  | MLPge_real =>    VMPprim(1, Ptest(Pfloat_test PTge))
  | MLPadd_real_c => VMprim (2, Pfloatprim Psmladdfloat)
  | MLPsub_real_c => VMprim (2, Pfloatprim Psmlsubfloat)
  | MLPmul_real_c => VMprim (2, Pfloatprim Psmlmulfloat)
  | MLPdiv_real_c => VMprim (2, Pfloatprim Psmldivfloat)
  | MLPlt_real_c =>  VMprim (2, Ptest(Pfloat_test PTlt))
  | MLPgt_real_c =>  VMprim (2, Ptest(Pfloat_test PTgt))
  | MLPle_real_c =>  VMprim (2, Ptest(Pfloat_test PTle))
  | MLPge_real_c =>  VMprim (2, Ptest(Pfloat_test PTge))
  | MLPlt_string =>  VMPprim(1, Ptest(Pstring_test PTlt))
  | MLPgt_string =>  VMPprim(1, Ptest(Pstring_test PTgt))
  | MLPle_string =>  VMPprim(1, Ptest(Pstring_test PTle))
  | MLPge_string =>  VMPprim(1, Ptest(Pstring_test PTge))
  | MLPconcat =>     VMPprim(1, Pccall("sml_concat", 2))
  | MLPlt_string_c =>   VMprim (2, Ptest(Pstring_test PTlt))
  | MLPgt_string_c =>   VMprim (2, Ptest(Pstring_test PTgt))
  | MLPle_string_c =>   VMprim (2, Ptest(Pstring_test PTle))
  | MLPge_string_c =>   VMprim (2, Ptest(Pstring_test PTge))
  | MLPconcat_c =>   VMprim(2, Pccall("sml_concat", 2))
  | MLPprim(arity, prim)  => VMprim(arity, prim)
  | MLPccall(arity, name) => VMprim(arity, Pccall(name, arity))
  | MLPgv qualid         => GVprim qualid
  | MLPgvt(qualid, ref sc) =>   GVTprim(qualid, sc)
;

val curriedPrimVersion = fn
    MLPeq       =>    SOME MLPeq_c
  | MLPnoteq    =>    SOME MLPnoteq_c
  | MLPsetref   =>    SOME MLPsetref_c
  | MLPadd_int  =>    SOME MLPadd_int_c
  | MLPsub_int  =>    SOME MLPsub_int_c
  | MLPmul_int  =>    SOME MLPmul_int_c
  | MLPdiv_int  =>    SOME MLPdiv_int_c
  | MLPmod_int  =>    SOME MLPmod_int_c
  | MLPquot_int =>    SOME MLPquot_int_c
  | MLPrem_int  =>    SOME MLPrem_int_c
  | MLPlt_int   =>    SOME MLPlt_int_c
  | MLPgt_int   =>    SOME MLPgt_int_c
  | MLPle_int   =>    SOME MLPle_int_c
  | MLPge_int   =>    SOME MLPge_int_c
  | MLPadd_real =>    SOME MLPadd_real_c
  | MLPsub_real =>    SOME MLPsub_real_c
  | MLPmul_real =>    SOME MLPmul_real_c
  | MLPdiv_real =>    SOME MLPdiv_real_c
  | MLPlt_real  =>    SOME MLPlt_real_c
  | MLPgt_real  =>    SOME MLPgt_real_c
  | MLPle_real  =>    SOME MLPle_real_c
  | MLPge_real  =>    SOME MLPge_real_c
  | MLPlt_string =>   SOME MLPlt_string_c
  | MLPgt_string =>   SOME MLPgt_string_c
  | MLPle_string =>   SOME MLPle_string_c
  | MLPge_string =>   SOME MLPge_string_c
  | MLPconcat   =>    SOME MLPconcat_c
  | _           =>    NONE
;

(* Translation of expressions *)

exception Not_constant;

fun extractConstant (Lconst cst) = cst
  | extractConstant _ = raise Not_constant
;

val bindConst  = Lconst(BLOCKsc(EXNtag bindTagName,  []));
val matchConst = Lconst(BLOCKsc(EXNtag matchTagName, []));
val bindRaiser  = Lprim(Praise, [bindConst]);
val matchRaiser = Lprim(Praise, [matchConst]);

fun partial_fun (loc as Loc(start,stop)) (tsb : ThreeValuedLogic) =
  case tsb of
    True =>
      (msgIBlock 0;
       errLocation loc;
       errPrompt "Warning: pattern matching is not exhaustive";
       msgEOL(); msgEOL();
       msgEBlock();
       matchRaiser)
  | _ =>
      matchRaiser
;

fun partial_let (onTop : bool) (loc as Loc(start,stop))
                (tsb : ThreeValuedLogic) =
  case tsb of
    True =>
      (if not onTop then
         (msgIBlock 0;
          errLocation loc;
          errPrompt "Warning: pattern matching is not exhaustive";
          msgEOL(); msgEOL();
          msgEBlock())
       else ();
       bindRaiser)
  | _ =>
      bindRaiser
;

fun partial_try (tsb : ThreeValuedLogic) =
  Lprim(Praise, [Lvar 0])
;

val smlExnTag = EXNtag exnTagName;

fun extract_fields arity =
  let fun loop i =
    if i >= arity then []
    else
      Lprim(Pfield i, [Lvar 0]) :: loop (i+1)
  in loop 0 end
;

fun normApp (func as (_, func')) args =
  case func' of
      PARexp e        => normApp e args
    | TYPEDexp(e,_)   => normApp e args
    | APPexp(e1,e2)   => normApp e1 (e2 :: args)
    | _               => (func, args)
;

fun extractPairArg (_, exp') =
  case exp' of
      PARexp e                       => extractPairArg e
    | TYPEDexp(e,_)                  => extractPairArg e
    | RECexp(ref (TUPLEre [e1,e2]))  => SOME (e1, e2)
    | _                              => NONE
;

fun canSplitFirstArg (Lvar n :: args) = true
  | canSplitFirstArg (Lprim(Pget_global _, []) :: args) = true
  | canSplitFirstArg _ = false
;

fun splitFirstArg (arg :: args) =
      Lprim(Pfield 0, [arg]) :: Lprim(Pfield 1, [arg]) :: args
  | splitFirstArg _ = fatalError "splitFirstArg"
;

(* An expression is "safe", if evaluating it can't produce *)
(* side-effects, i.e. I/O, exceptions, etc. *)
(* The following is a crude approximation... *)

fun isSafe (_, exp') =
  case exp' of
    SCONexp _ => true
  | VARexp _ => true
  | FNexp _ => true
  | APPexp(e1,e2) => false
  | RECexp(ref (RECre fs)) =>
      all (fn (_, e) => isSafe e) fs
  | RECexp(ref (TUPLEre es)) =>
      all isSafe es
  | VECexp es =>
      all isSafe es
  | PARexp e => isSafe e
  | LETexp (dec,exp) => false
  | INFIXexp es => fatalError "isSafe"
  | TYPEDexp(e,ty) => isSafe e
  | ANDALSOexp(e1,e2) =>
      isSafe e1 andalso isSafe e2
  | ORELSEexp(e1,e2) =>
      isSafe e1 andalso isSafe e2
  | HANDLEexp(e, mrules) => false
  | RAISEexp e => false
  | IFexp(e0,e1,e2) =>
      isSafe e0 andalso isSafe e1 andalso isSafe e2
  | WHILEexp(e1,e2) =>
      isSafe e1 andalso isSafe e2
  | SEQexp(e1,e2) =>
      isSafe e1 andalso isSafe e2
;

(* All unsafe arguments must be lifted, except the rightmost one, *)
(* in order to preserve the evaluation order. *)

datatype AppArgs =
    SAFEarg of Exp
  | CONSTarg of Lambda
  | UNSAFEarg
;

fun trConVar (ci : ConInfo) =
  let val {conArity, conIsGreedy, conTag, conSpan, ...} = !ci in
    case (conIsGreedy, conArity, conSpan) of
        (true,  _, _) =>
          Lfn(Lprim(
            Pmakeblock(CONtag(conTag,conSpan)), extract_fields conArity))
      | (false, 0, _) =>
          Lconst(BLOCKsc(CONtag(conTag,conSpan), []))
      | (false, _, 1) =>
          Lfn(Lvar 0)
      | (false, _, _) =>
          Lfn(Lprim(Pmakeblock(CONtag(conTag,conSpan)), [(Lvar 0)]))
  end;

fun trStaticExConVar isGreedy arity tag =
  case (isGreedy, arity) of
      (true,  _) =>
        Lfn(Lprim(Pmakeblock(EXNtag tag), extract_fields arity))
    | (false, 0) =>
        Lconst(BLOCKsc(EXNtag tag, []))
    | (false, _) =>
        Lfn(Lprim(Pmakeblock (EXNtag tag), [Lvar 0]))
;

fun trExConVar (env as (rho, depth)) q (ei : ExConInfo) =
  let val {qual, id} = q
      val {exconArity, exconIsGreedy, exconTag, ...} = !ei
  in
    case exconTag of
        NONE =>
          if exconArity = 0 then
            let val en = translateLocalAccess env id
            in Lprim(Pmakeblock smlExnTag, [en]) end
          else
            let val en = translateLocalAccess (rho, depth+1) id
            in Lfn(Lprim(Pmakeblock smlExnTag, [en, Lvar 0])) end
     | SOME tag =>
         trStaticExConVar exconIsGreedy exconArity tag
  end;

fun trTopExConVar (ei : ExConInfo) =
  let val {exconArity, exconIsGreedy, exconTag, ...} = !ei in
    case exconTag of
        NONE => fatalError "trTopExConVar"
      | SOME tag =>
         trStaticExConVar exconIsGreedy exconArity tag
  end;

fun trPrimVar prim =
  case getPrimImpl prim of
      GVprim globalName =>
        Lprim(Pget_global (globalName, 0), [])
    | VMprim(arity, p) =>
        let fun make_fn n args =
          if n >= arity
          then Lprim(p, args)
          else Lfn(make_fn (n+1) (Lvar n :: args))
        in make_fn 0 [] end
    | VMPprim(arity, p) =>
        let fun make_fn n args =
          if n >= arity
          then Lprim(p, splitFirstArg args)
          else Lfn(make_fn (n+1) (Lvar n :: args))
        in make_fn 0 [] end
    | GVTprim(globalName, sc) =>
        Lfn(Lapply(
              Lprim(Pget_global (globalName, 0), []),
              [Lconst(QUOTEsc (ref sc)), Lvar 0]))
;

fun trVar (env as (rho, depth)) (ii : IdInfo) =
  let val {info={idKind, ...}, ...} = ii
      val {qualid, info} = !idKind
  in
    case info of
        VARik =>
          translateAccess env qualid
      | PRIMik pi =>
          trPrimVar (#primOp pi)
      | CONik ci =>
          trConVar ci
      | EXCONik ei =>
          trExConVar env qualid ei
  end;

fun trExp (env as (rho, depth)) (exp as (loc, exp')) =
  case exp' of
    SCONexp scon =>
      Lconst (ATOMsc scon)
  | VARexp(ref (RESve ii)) =>
      trVar env ii
  | VARexp(ref (OVLve _)) => fatalError "trExp"
  | FNexp [] =>
      fatalError "trExp: empty fun"
  | FNexp(mrules as MRule(pats,_)::_) =>
      foldR (fn pat => fn lam => Lfn lam)
            (trMatch loc env (partial_fun loc) mrules)
            pats
  | APPexp(e1,e2) =>
      (case normApp e1 [e2] of
           (func as (loc, FNexp mrules), args) =>
             if curriedness mrules = List.length args then
               Llet(trLetArgs env args,
                    trMatch loc env (partial_fun loc) mrules)
             else
               let val (env', tr_args, envelope) = trArgs env args
               in envelope(Lapply(trExp env' func, tr_args)) end
          | (func as (_, VARexp(ref (RESve ii))), args) =>
              trVarApp env ii args
          | (func, args) =>
              let val (env', tr_args, envelope) = trArgs env (func :: args)
              in envelope(Lapply(hd tr_args, tl tr_args)) end)
  | RECexp(ref (RECre fs)) =>
      trRec env (CONtag(0,1)) fs
  | RECexp(ref (TUPLEre es)) =>
      trTuple env (CONtag(0,1)) es
  | VECexp es =>
      trTuple env (CONtag(0,1)) es
  | PARexp e => trExp env e
  | LETexp (dec,exp) =>
      let val ((rho', depth'), envelope) = trDec env dec
          val env'' = (plusEnv rho rho', depth')
      in envelope(trExp env'' exp) end
  | INFIXexp es => fatalError "trExp"
  | TYPEDexp(e,ty) => trExp env e
  | ANDALSOexp(e1,e2) =>
      Landalso(trExp env e1, trExp env e2)
  | ORELSEexp(e1,e2) =>
      Lorelse(trExp env e1, trExp env e2)
  | HANDLEexp(e, mrules) =>
      Lhandle(trExp env e, trMatch loc env partial_try mrules)
  | RAISEexp e =>
      Lprim(Praise, [trExp env e])
  | IFexp(e0,e1,e2) =>
      Lif(trExp env e0, trExp env e1, trExp env e2)
  | WHILEexp(e1,e2) =>
      Lwhile(trExp env e1, trExp env e2)
  | SEQexp(e1,e2) =>
      Lseq(trExp env e1, trExp env e2)

and trVarApp env (ii : IdInfo) args =
  let val {qualid={id, ...}, info={idKind, ...}} = ii in
    case #info(!idKind) of
        VARik =>
          let val (env', tr_args, envelope) = trArgs env args
          in envelope(Lapply(trVar env' ii, tr_args)) end
      | PRIMik pi =>
          let val {primOp, ...} = pi in
            case curriedPrimVersion primOp of
                NONE => trPrimApp env primOp args
              | SOME prim_c =>
                  (case extractPairArg (hd args) of
                        NONE => trPrimApp env primOp args
                      | SOME(arg', arg'') =>
                          trPrimApp env prim_c (arg'::arg''::(tl args)))
          end
      | CONik ci =>
          let val {conArity, conIsGreedy, conTag, conSpan, ...} = !ci in
            if List.length args <> 1 then
              fatalError "trVarApp: unary con requires 1 arg"
            else ();
            case (conIsGreedy, conArity, conSpan) of
                (true,  _, _) =>
                  (case (hd args) of
                      (_, RECexp(ref (RECre fs))) =>
                        trRec env (CONtag(conTag,conSpan)) fs
                    | (_, RECexp(ref (TUPLEre es))) =>
                        trTuple env (CONtag(conTag,conSpan)) es
                    | _ =>
                        Llet([trExp env (hd args)],
                              Lprim(Pmakeblock(CONtag(conTag,conSpan)),
                                    extract_fields conArity)))
              | (false, 0, _) =>
                  fatalError "trVarApp: nullary con in app"
              | (false, _, 1) =>
                  trExp env (hd args)
              | (false, _, _) =>
                  (* Normal unary con, in the end... *)
                  let val tr_arg = trExp env (hd args) in
                    Lconst(BLOCKsc(CONtag(conTag,conSpan),
                                    [extractConstant tr_arg]))
                    handle Not_constant =>
                        Lprim(Pmakeblock(CONtag(conTag,conSpan)), [tr_arg])
                  end
          end
      | EXCONik ei =>
          let val {exconArity, exconIsGreedy, exconTag, ...} = !ei in
            if List.length args <> 1 then
              fatalError "trVarApp: unary excon requires 1 arg"
            else ();
            case exconTag of
                NONE =>
                  let val () =
                        if exconArity = 0 then
                          fatalError "trVarApp: nullary excon in app"
                        else ();
                      val en = translateLocalAccess env id
                      val tr_arg = trExp env (hd args)
                  in Lprim(Pmakeblock smlExnTag, [en, tr_arg]) end
              | SOME tag =>
                 (case (exconIsGreedy, exconArity) of
                    (true,  _) =>
                      (case (hd args) of
                          (_, RECexp(ref (RECre fs))) =>
                            trRec env (EXNtag tag) fs
                        | (_, RECexp(ref (TUPLEre es))) =>
                            trTuple env (EXNtag tag) es
                        | _ =>
                            Llet([trExp env (hd args)],
                                  Lprim(Pmakeblock(EXNtag tag),
                                        extract_fields exconArity)))
                  | (false, 0) =>
                      fatalError "trVarApp: nullary excon in app"
                  | (false, _) =>
                      let val tr_arg = trExp env (hd args)
                      in Lprim(Pmakeblock (EXNtag tag), [tr_arg]) end)
          end
  end

and trPrimApp env prim args =
  let val (env', tr_args, envelope) = trArgs env args in
    case getPrimImpl prim of
        GVprim globalName =>
          envelope(Lapply(trPrimVar prim, tr_args))
      | VMprim(arity, p) =>
          if arity <> List.length tr_args
          then envelope(Lapply(trPrimVar prim, tr_args))
          else envelope(Lprim(p, tr_args))
      | VMPprim(arity, p) =>
          if (arity <> List.length tr_args) then
            envelope(Lapply(trPrimVar prim, tr_args))
          else if canSplitFirstArg tr_args then
            envelope(Lprim(p, splitFirstArg tr_args))
          else if arity = 1 then
            Llet(tr_args, Lprim(p, splitFirstArg [Lvar 0]))
          else
            envelope(Lapply(trPrimVar prim, tr_args))
      | GVTprim(globalName, sc) =>
          envelope(Lapply(Lprim(Pget_global (globalName, 0), []),
                          Lconst(QUOTEsc (ref sc))::tr_args))
  end

and trRec env tag fs =
  let val labs = map fst fs and es = map snd fs
      val (env', tr_es, envelope) = trArgs env es
      val tr_es' = map snd (sortRow (zip2 labs tr_es))
  in
    (case tag of CONtag _ => () | EXNtag _ => raise Not_constant;
     envelope(Lconst(BLOCKsc(tag, map extractConstant tr_es'))))
    handle Not_constant =>
           envelope(Lprim(Pmakeblock tag, tr_es'))
  end

and trTuple env tag es =
  let val (env', tr_es, envelope) = trArgs env es in
    (case tag of CONtag _ => () | EXNtag _ => raise Not_constant;
     envelope(Lconst(BLOCKsc(tag, map extractConstant tr_es))))
    handle Not_constant =>
           envelope(Lprim(Pmakeblock tag, tr_es))
  end

(* We recognize constant arguments only upon translating them, *)
(* to avoid repeated traversals of the abstract syntax tree. *)

and classifyArgs (env as (rho, depth)) unsafe safe = fn
    [] => (unsafe, safe)
  | arg :: args =>
      if isSafe arg then
        classifyArgs env unsafe ((SAFEarg arg) :: safe) args
      else
        let val lam = trExp env arg in
          case lam of
              Lconst _ =>
                classifyArgs env unsafe ((CONSTarg lam) :: safe) args
            | _ =>
                classifyArgs (rho, depth+1) (lam :: unsafe)
                             (UNSAFEarg :: safe) args
        end

and adjustHeadArgs env pos acc = fn
    [] => acc
  | SAFEarg exp :: rest =>
      adjustHeadArgs env pos (trExp env exp :: acc) rest
  | CONSTarg lam :: rest =>
      adjustHeadArgs env pos (lam :: acc) rest
  | UNSAFEarg :: rest =>
      adjustHeadArgs env (pos+1) (Lvar pos :: acc) rest

(* The rightmost unsafe expression needn't be lifted, *)
(* as it can't do any harm. *)

and adjustArgs env quasisafe acc = fn
    [] => fatalError "adjustArgs"
  | SAFEarg exp :: rest =>
      adjustArgs env quasisafe (trExp env exp :: acc) rest
  | CONSTarg lam :: rest =>
      adjustArgs env quasisafe (lam :: acc) rest
  | UNSAFEarg :: rest =>
      adjustHeadArgs env 0 (quasisafe :: acc) rest

and trArgs (env as (rho, depth)) args =
  case classifyArgs env [] [] args of
      ([], safe) => (env, adjustHeadArgs env 0 [] safe, fn lam => lam)
    | (quasisafe :: unsafe, safe) =>
        let val num = List.length unsafe
            val env' = (rho, depth + num)
        in
          (env',
           adjustArgs env' quasisafe [] safe,
           if num = 0 then fn lam => lam
                      else fn lam => Llet(rev unsafe, lam))
        end

and trValDec onTop (env as (rho, depth)) pvbs rvbs =
  let val ((rho',  depth'),  envelope' ) =
        trValBind onTop env pvbs
      val ((rho'', depth''), envelope'') =
        trRecValBind (rho, depth') rvbs
  in
    ((plusEnv rho' rho'', depth''), envelope' o envelope'')
  end

and trDec (env as (rho, depth)) (loc, dec') =
  case dec' of
    VALdec (pvbs, rvbs) =>
      trValDec false env pvbs rvbs
  | PRIM_VALdec _ => ((NILenv, depth), fn lam => lam)
  | FUNdec _ => fatalError "trDec"
  | TYPEdec _ => ((NILenv, depth), fn lam => lam)
  | PRIM_TYPEdec _ => ((NILenv, depth), fn lam => lam)
  | DATATYPEdec(dbs, _) => ((NILenv, depth), fn lam => lam)
  | ABSTYPEdec(dbs, _, dec2) =>
      trDec env dec2
  | EXCEPTIONdec ebs =>
      trExBindList env ebs
  | LOCALdec(dec1,dec2) =>
      let val ((rho', depth'), envelope') =
                              trDec env dec1
          val ((rho'', depth''), envelope'') =
                              trDec ((plusEnv rho rho'), depth') dec2
      in ((rho'', depth''), envelope' o envelope'') end
  | OPENdec _ => ((NILenv, depth), fn lam => lam)
  | EMPTYdec => ((NILenv, depth), fn lam => lam)
  | SEQdec(dec1,dec2) =>
      let val ((rho', depth'), envelope') =
                              trDec env dec1
          val ((rho'', depth''), envelope'') =
                              trDec ((plusEnv rho rho'), depth') dec2
      in ((plusEnv rho' rho'', depth''), envelope' o envelope'') end
  | FIXITYdec  _ =>  ((NILenv, depth), fn lam => lam)

and tr1ValBind onTop (env as (rho, depth)) (ValBind(pat, arg)) =
  let val (env', add_lets) = mkEnvOfPats depth [pat]
      val tr_arg = trExp env arg
      val m_env = (rho, depth+1)
      val loc = xLR pat
      fun envelope lam =
            Llet([tr_arg],
              translateMatch m_env (partial_let onTop loc) loc
                             [([pat], add_lets lam)])
  in (env', envelope) end

and trValBind onTop (env as (rho, depth)) = fn
    [] => ((NILenv, depth), fn lam => lam)
  | [vb] =>
      tr1ValBind onTop env vb
  | vb :: vbs =>
      let val (env' as (rho', depth'),  envelope') =
             tr1ValBind onTop env vb
          val (env'' as (rho'', depth''), envelope'') =
             trValBind onTop (rho, depth') vbs
      in ((plusEnv rho' rho'', depth''), envelope' o envelope'') end

and trRecValBind (env as (rho, depth)) = fn
    [] => ((NILenv, depth), fn lam => lam)
  | vbs =>
      let val pats = map (fn ValBind(p, _) => p) vbs
          val args = map (fn ValBind(_, e) => e) vbs
          val (env' as (rho', depth')) = mkEnvOfRecPats depth pats
          val new_env = (plusEnv rho rho', depth')
          val tr_bindings = map (trExp new_env) args
          fun envelope lam = Lletrec(tr_bindings, lam)
      in (env', envelope) end

and trMatch loc (env as (rho, depth)) failure_code mrules =
  let val m_env = (rho, depth + curriedness mrules)
      fun trMRule (MRule(pats, exp)) =
        let val ((rho', depth'), add_lets) = mkEnvOfPats depth pats
            val new_env = (plusEnv rho rho', depth')
        in (pats, add_lets (trExp new_env exp)) end
  in translateMatch m_env failure_code loc (map trMRule mrules) end

and trLetArgs (env as (rho, depth)) = fn
    [] =>  []
  | exp :: exps =>
      trExp env exp :: trLetArgs (rho, depth+1) exps

and trBindings (env as (rho, depth)) = fn
    [] => []
  | (pat, exp) :: rest =>
      trExp env exp :: trBindings (rho, depth+1) rest

and trExBindList (env as (rho, depth)) ebs =
  let val id_path_list =
        mapFrom (fn depth =>
                 fn
                    (EXDECexbind(ii, _))   =>
                              (#id(#qualid ii), Path_local depth)
                  | (EXEQUALexbind(ii, _)) =>
                              (#id (#qualid ii), Path_local depth))
                depth ebs
      and len = List.length ebs
      and args = mapFrom (fn i => fn eb => trExBind (rho, i) eb) depth ebs
      val rho' = foldR (fn (id, path) => fn rho => bindInEnv rho id path)
                       NILenv id_path_list
  in ((rho', depth+len), fn lam => Llet(args, lam)) end

and trExBind env = fn
    EXDECexbind(ii, _) =>
      let val () =
            if isExConStatic(getExConInfo ii) then fatalError "trExBind"
            else ()
          val uname = ATOMsc(STRINGscon(currentUnitName()))
          val exid  = ATOMsc(STRINGscon (#id (#qualid ii)))
          val en = BLOCKsc(CONtag(0,1), [exid, uname])
      in Lprim(Pmakeblock(CONtag(refTag, 1)), [Lconst en]) end
  | EXEQUALexbind(ii, ii') =>
      (if isExConStatic(getExConInfo ii') then fatalError "trExBind"
       else ();
       translateExName env ii')
;

(* Translation of toplevel declarations *)

fun makeSeq f [] = Lunspec
  | makeSeq f [x] = f x
  | makeSeq f (x::rest) = Lseq(f x, makeSeq f rest)
;

fun lookupLocalRenEnv renEnv id =
  mkUniqueGlobalName (id, (lookup id renEnv))
  handle Subscript => fatalError "lookupLocalRenEnv"
;

fun storeGlobal renEnv env var =
  Lprim(Pset_global (lookupLocalRenEnv renEnv var),
          [translateLocalAccess env var])
;

fun equGlobal renEnv var0 var =
  Lprim(Pset_global (lookupLocalRenEnv renEnv var),
    [Lprim(Pget_global (lookupLocalRenEnv renEnv var0), [])])
;

fun tr1ToplevelRecValBind renEnv rho = fn
    ([], exp) => Lunspec
  | ([var], exp) =>
      Lprim(Pset_global (lookupLocalRenEnv renEnv var), [trExp (rho, 0) exp])
  | (var :: vars, exp) =>
      Lseq(Lprim(Pset_global (lookupLocalRenEnv renEnv var),
                 [trExp (rho, 0) exp]),
        makeSeq (equGlobal renEnv var) vars)
;

fun revWithoutDuplicates [] acc = acc
  | revWithoutDuplicates (x :: xs) acc =
      if member x acc then
        revWithoutDuplicates xs acc
      else
        revWithoutDuplicates xs (x :: acc)
;

datatype TopLambda =
    NILtlam
  | SEQtlam of TopLambda * TopLambda
  | LAMtlam of bool * Lambda
;

fun flattenTLam tlam acc =
  case tlam of
      NILtlam => acc
    | SEQtlam(tlam1, tlam2) =>
        flattenTLam tlam1 (flattenTLam tlam2 acc)
    | LAMtlam(is_pure, lam) => (is_pure, lam) :: acc
;

fun trToplevelDec rho (dec as (_, dec')) =
  case dec' of
      VALdec ([ValBind((_, VARpat ii), exp)], []) =>
        let val id = #id(#qualid ii)
            val id' = mkUniqueGlobalName (renameId id)
        in
          (mk1Env id (Path_global id'),
            LAMtlam(isSafe exp,
              Lprim(Pset_global id', [trExp (rho, 0) exp])))
        end
    | VALdec ([], rvbs) =>
        let val ves = map (fn ValBind(p, e) => (domPat p, e)) rvbs
            val vars = foldL (fn (vs, _) => fn acc => vs @ acc) [] ves
            val renEnv = map renameId vars
            val rho' =
              foldR (fn (id' as (id, _)) => fn rho =>
                       bindInEnv rho id (Path_global (mkUniqueGlobalName id')))
                    NILenv renEnv
        in
          (rho',
           LAMtlam(true,
             makeSeq (tr1ToplevelRecValBind renEnv (plusEnv rho rho')) ves))
        end
    | VALdec (pvbs, rvbs) =>
        let val (env as (rho', depth'), envelope) =
               trValDec true (rho, 0) pvbs rvbs
            val vars = foldEnv (fn id => fn _ => fn vars => id :: vars)
                               [] rho'
            val renEnv = map renameId vars
        in
          (foldR (fn (id' as (id,_)) => fn rho =>
                    bindInEnv rho id (Path_global (mkUniqueGlobalName id')))
                 NILenv renEnv,
           LAMtlam(
             all (fn ValBind(_, e) => isSafe e) pvbs,
             envelope (makeSeq (storeGlobal renEnv env)
                               (revWithoutDuplicates vars []))))
        end
    | PRIM_VALdec _ => (NILenv, NILtlam)
    | FUNdec _ => fatalError "trToplevelDec"
    | TYPEdec _ => (NILenv, NILtlam)
    | PRIM_TYPEdec _ => (NILenv, NILtlam)
    | DATATYPEdec(dbs, _) => (NILenv, NILtlam)
    | ABSTYPEdec(dbs, _, dec2) =>
        trToplevelDec rho dec2
    | EXCEPTIONdec ebs => (NILenv, NILtlam)
    | LOCALdec(dec1,dec2) =>
        let val (rho' , tlam')  = trToplevelDec rho dec1
            val (rho'', tlam'') = trToplevelDec (plusEnv rho rho') dec2
        in (rho'', SEQtlam(tlam', tlam'')) end
    | OPENdec _ => (NILenv, NILtlam)
    | EMPTYdec => (NILenv, NILtlam)
    | SEQdec(dec1,dec2) =>
        let val (rho' , tlam')  = trToplevelDec rho dec1
            val (rho'', tlam'') = trToplevelDec (plusEnv rho rho') dec2
        in (plusEnv rho' rho'', SEQtlam(tlam', tlam'')) end
    | FIXITYdec  _ =>  (NILenv, NILtlam)
;

fun REofRho1 id (Path_global (_, stamp)) re = (id, stamp) :: re
  | REofRho1 _  _            _              = fatalError "REofRho1"

fun REofRho rho =
  foldEnv REofRho1 [] rho
;

fun translateToplevelDec dec =
  let val (rho, tlam) = trToplevelDec NILenv dec
  in (REofRho rho, flattenTLam tlam []) end
;