(* 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) | MLPeq_int => VMPprim(1, Ptest(Pint_test PTeq)) | MLPnoteq_int => VMPprim(1, Ptest(Pint_test PTnoteq)) | 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) | MLPeq_int_c => VMprim (2, Ptest(Pint_test PTeq)) | MLPnoteq_int_c => VMprim (2, Ptest(Pint_test PTnoteq)) | 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)) | MLPadd_word => VMPprim(1, Paddint) | MLPsub_word => VMPprim(1, Psubint) | MLPmul_word => VMPprim(1, Pmulint) | MLPdiv_word => VMPprim(1, Pdivint) | MLPmod_word => VMPprim(1, Pmodint) | MLPadd_word_c => VMprim (2, Paddint) | MLPsub_word_c => VMprim (2, Psubint) | MLPmul_word_c => VMprim (2, Pmulint) | MLPdiv_word_c => VMprim (2, Pdivint) | MLPmod_word_c => VMprim (2, Pmodint) | MLPeq_word => VMPprim(1, Ptest(Pword_test PTeq)) | MLPnoteq_word => VMPprim(1, Ptest(Pword_test PTnoteq)) | MLPlt_word => VMPprim(1, Ptest(Pword_test PTlt)) | MLPgt_word => VMPprim(1, Ptest(Pword_test PTgt)) | MLPle_word => VMPprim(1, Ptest(Pword_test PTle)) | MLPge_word => VMPprim(1, Ptest(Pword_test PTge)) | MLPeq_word_c => VMprim (2, Ptest(Pword_test PTeq)) | MLPnoteq_word_c => VMprim (2, Ptest(Pword_test PTnoteq)) | MLPlt_word_c => VMprim (2, Ptest(Pword_test PTlt)) | MLPgt_word_c => VMprim (2, Ptest(Pword_test PTgt)) | MLPle_word_c => VMprim (2, Ptest(Pword_test PTle)) | MLPge_word_c => VMprim (2, Ptest(Pword_test PTge)) | 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 | MLPeq_int => SOME MLPeq_int_c | MLPnoteq_int => SOME MLPnoteq_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 | MLPadd_word => SOME MLPadd_word_c | MLPsub_word => SOME MLPsub_word_c | MLPmul_word => SOME MLPmul_word_c | MLPdiv_word => SOME MLPdiv_word_c | MLPmod_word => SOME MLPmod_word_c | MLPeq_word => SOME MLPeq_word_c | MLPnoteq_word => SOME MLPnoteq_word_c | MLPlt_word => SOME MLPlt_word_c | MLPgt_word => SOME MLPgt_word_c | MLPle_word => SOME MLPle_word_c | MLPge_word => SOME MLPge_word_c | _ => NONE; (* Translation of expressions *) exception Not_constant; fun extractConstant (Lconst cst) = cst | extractConstant _ = raise Not_constant; fun mkDynexn1 exnname arg = Lprim(Pmakeblock (CONtag(0,1)), [exnname, arg])fun mkDynexn0 exnname = mkDynexn1 exnname (Lconst constUnit) (* ps: TODO perhaps share the code for raising Bind and Match *) val bindExn = mkDynexn0 (Lprim(Pget_global ({qual="General", id=["exn_bind"]}, 0), []));val matchExn = mkDynexn0 (Lprim(Pget_global ({qual="General", id=["exn_match"]}, 0), []))val bindRaiser = Lprim(Praise, [bindExn]);val matchRaiser = Lprim(Praise, [matchExn]); fun partial_fun (loc as Loc(start,stop)) () = (msgIBlock 0; errLocation loc; errPrompt "Warning: pattern matching is not exhaustive"; msgEOL(); msgEOL(); msgEBlock(); matchRaiser); fun partial_let (onTop : bool) (loc as Loc(start,stop)) () = (if not onTop then (msgIBlock 0; errLocation loc; errPrompt "Warning: pattern matching is not exhaustive"; msgEOL(); msgEOL(); msgEBlock()) else (); bindRaiser); fun partial_try () = Lprim(Praise, [Lvar 0]); 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 | VIDPATHexp (ref (RESvidpath _))=> true | VIDPATHexp (ref (OVLvidpath _)) => fatalError "isSafe:1" | 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 (ref (UNRESinfixexp e)) => fatalError "isSafe:2" | INFIXexp (ref (RESinfixexp e)) => isSafe e | 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 | STRUCTUREexp (modexp,_,_) => isSafeModExp modexp | FUNCTORexp (modexp,_,_) => isSafeModExp modexpand isSafeModExp (_, (modexp',_)) = case modexp' of DECmodexp _ => false | LONGmodexp _ => true | LETmodexp (dec,modexp) => false | PARmodexp modexp => isSafeModExp modexp | CONmodexp (modexp,sigexp) => isSafeModExp modexp | ABSmodexp (modexp,sigexp) => isSafeModExp modexp | FUNCTORmodexp (_,modid,_, sigexp, modexp) => true | APPmodexp (modexp,modexp') => false | RECmodexp (modid,_,sigexp, modexp) => false; (* 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 trExConVar (env as (rho, depth)) (ii : IdInfo) (ei:ExConInfo) = let val {exconArity, ...} = !ei val en = translateLongAccess ValId env ii in if exconArity = 0 then mkDynexn0 en else Llet([en], Lfn(mkDynexn1 (Lvar 1) (Lvar 0))) end fun trTopDynExConVar (ei : ExConInfo) (en:Lambda) = let val {exconArity,...} = !ei in if exconArity = 0 then mkDynexn0 en else Llet([en], Lfn(mkDynexn1 (Lvar 1) (Lvar 0))) 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 {info,qualid} = !idKind in (case info of VARik => translateLongAccess ValId env ii | STRik => translateLongAccess ModId env ii | FUNik => translateLongAccess FunId env ii | PRIMik pi => trPrimVar (#primOp pi) | CONik ci => trConVar ci | EXCONik ei => trExConVar env ii ei) end; (* coercion *) fun getGlobal asId {qual,id} = Lprim(Pget_global ({qual=qual,id = [mangle (asId (longIdentAsIdent id "getGlobal"))]},0),[]); fun coerceVarEnv S VE' = let val lookupVEofS = lookupVEofStr S in foldEnv (fn id => fn {info = (_,cs'),...} => fn tr_VE => case cs' of VARname _ => (let val (field,{qualid,info=(_,cs)}) = lookupVEofS id in case cs of VARname _ => if isGlobalName qualid then (Lprim(Pget_global(qualid,0),[]))::tr_VE else (Lprim(Pfield field,[Lvar 0]))::tr_VE | PRIMname pi => (trPrimVar (#primOp pi))::tr_VE | CONname ci => (trConVar ci)::tr_VE | EXNname ei => (let val {exconArity, ...} = !ei val en = if isGlobalName qualid then getGlobal ValId qualid else Lprim(Pfield field,[Lvar 0]) in if exconArity = 0 then mkDynexn0 en else Llet([en], Lfn(mkDynexn1 (Lvar 1) (Lvar 0))) end :: tr_VE) | REFname => fatalError "coerceVarEnv:1" end) | EXNname ei' => let val (field,{qualid,info = (_,cs)}) = lookupVEofS id in case cs of EXNname ei => (let val {exconArity, ...} = !ei in if isGlobalName qualid then getGlobal ValId qualid else Lprim(Pfield field, [Lvar 0]) end :: tr_VE) | _ => fatalError "coerceVarEnv:3" end | _ (* PRIMname pi' | CONname ci' | REFname *) => tr_VE) [] VE' endand coerceFunEnv S FE' tr_VE = let val lookupFEofS = lookupFEofStr S in foldEnv (fn id => fn {info = F',...} => fn tr_FE_VE => let val (field,{qualid,info = F}) = lookupFEofS id val trF = if isGlobalName qualid then getGlobal FunId qualid else Lprim(Pfield field, [Lvar 0]) in (coerceFun trF F F')::tr_FE_VE end) tr_VE FE' endand coerceModEnv S ME' tr_FE_VE = let val lookupMEofS = lookupMEofStr S in foldEnv (fn id => fn {info = RS',...} => fn tr_ME_FE_VE => let val (field,{qualid,info = RS}) = lookupMEofS id val trM = if isGlobalName qualid then getGlobal ModId qualid else Lprim(Pfield field, [Lvar 0]) in (coerceRecStr trM RS RS')::tr_ME_FE_VE end) tr_FE_VE ME' endand coerceStr lam S S' = case S' of STRstr(ME',FE',GE',TE',VE') => let val tr_VE = coerceVarEnv S VE' val tr_FE_VE = coerceFunEnv S FE' tr_VE val tr_ME_FE_VE = coerceModEnv S ME' tr_FE_VE in if isIdentityCoercion S 0 tr_ME_FE_VE then lam else Llet([lam],Lstruct tr_ME_FE_VE) end | _ => fatalError "coerceStr"and isIdentityCoercion S pos (Lprim(Pfield field, [Lvar 0])::lams) = (pos = field) andalso isIdentityCoercion S (pos+1) lams | isIdentityCoercion S pos (_::lams) = false | isIdentityCoercion S pos [] = (sizeOfStr S) = posand coerceRecStr lam (NONrec S) (NONrec S') = coerceStr lam S S' | coerceRecStr lam RS (RECrec (_,RS')) = coerceRecStr lam RS RS' | coerceRecStr lam (RECrec (_,RS)) RS' = coerceRecStr lam RS RS' and coerceMod lam (STRmod RS) (STRmod RS') = coerceRecStr lam RS RS' | coerceMod lam (FUNmod F) (FUNmod F') = coerceFun lam F F' | coerceMod _ _ _ = fatalError "coerceMod"and coerceFun lam (_,M1,EXISTSexmod(_,M1')) (_,M2,EXISTSexmod(_,M2')) = let val domCoercion = coerceMod (Lvar 0) (normMod M2) (normMod M1) val rngCoercion = coerceMod (Lvar 0) (normMod M1') (normMod M2') in case (domCoercion,rngCoercion) of (Lvar 0, Lvar 0) => lam | (Lvar 0, _) => Llet([lam], Lfn(Llet([Lapply(Lvar 1,[Lvar 0])],rngCoercion))) | (_, Lvar 0) => Llet([lam], Lfn(Llet([domCoercion], Lapply(Lvar 2,[Lvar 0])))) | (_,_) => Llet([lam], Lfn(Llet([domCoercion], Llet([Lapply(Lvar 2,[Lvar 0])], rngCoercion)))) end; fun coerceDecVarEnv (env as (rho,depth)) VE VE' = foldEnv (fn id => fn {info = (_,cs'),...} => fn tr_VE => case cs' of VARname _ => (let val {qualid,info=(_,cs)} = lookupEnv VE id in case cs of VARname _ => if isGlobalName qualid then (Lprim(Pget_global(qualid,0),[]))::tr_VE else (translateLocalAccess ValId env id)::tr_VE | PRIMname pi => (trPrimVar (#primOp pi))::tr_VE | CONname ci => (trConVar ci)::tr_VE | EXNname ei => (let val {exconArity, ...} = !ei val en = if isGlobalName qualid then getGlobal ValId qualid else translateLocalAccess ValId env id in if exconArity = 0 then mkDynexn0 en else Llet([en],Lfn(mkDynexn1 (Lvar 1) (Lvar 0)))Lines 1–500 of 1358. Load more
(* 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) | MLPeq_int => VMPprim(1, Ptest(Pint_test PTeq)) | MLPnoteq_int => VMPprim(1, Ptest(Pint_test PTnoteq)) | 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) | MLPeq_int_c => VMprim (2, Ptest(Pint_test PTeq)) | MLPnoteq_int_c => VMprim (2, Ptest(Pint_test PTnoteq)) | 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)) | MLPadd_word => VMPprim(1, Paddint) | MLPsub_word => VMPprim(1, Psubint) | MLPmul_word => VMPprim(1, Pmulint) | MLPdiv_word => VMPprim(1, Pdivint) | MLPmod_word => VMPprim(1, Pmodint) | MLPadd_word_c => VMprim (2, Paddint) | MLPsub_word_c => VMprim (2, Psubint) | MLPmul_word_c => VMprim (2, Pmulint) | MLPdiv_word_c => VMprim (2, Pdivint) | MLPmod_word_c => VMprim (2, Pmodint) | MLPeq_word => VMPprim(1, Ptest(Pword_test PTeq)) | MLPnoteq_word => VMPprim(1, Ptest(Pword_test PTnoteq)) | MLPlt_word => VMPprim(1, Ptest(Pword_test PTlt)) | MLPgt_word => VMPprim(1, Ptest(Pword_test PTgt)) | MLPle_word => VMPprim(1, Ptest(Pword_test PTle)) | MLPge_word => VMPprim(1, Ptest(Pword_test PTge)) | MLPeq_word_c => VMprim (2, Ptest(Pword_test PTeq)) | MLPnoteq_word_c => VMprim (2, Ptest(Pword_test PTnoteq)) | MLPlt_word_c => VMprim (2, Ptest(Pword_test PTlt)) | MLPgt_word_c => VMprim (2, Ptest(Pword_test PTgt)) | MLPle_word_c => VMprim (2, Ptest(Pword_test PTle)) | MLPge_word_c => VMprim (2, Ptest(Pword_test PTge)) | 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 | MLPeq_int => SOME MLPeq_int_c | MLPnoteq_int => SOME MLPnoteq_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 | MLPadd_word => SOME MLPadd_word_c | MLPsub_word => SOME MLPsub_word_c | MLPmul_word => SOME MLPmul_word_c | MLPdiv_word => SOME MLPdiv_word_c | MLPmod_word => SOME MLPmod_word_c | MLPeq_word => SOME MLPeq_word_c | MLPnoteq_word => SOME MLPnoteq_word_c | MLPlt_word => SOME MLPlt_word_c | MLPgt_word => SOME MLPgt_word_c | MLPle_word => SOME MLPle_word_c | MLPge_word => SOME MLPge_word_c | _ => NONE ; (* Translation of expressions *) exception Not_constant; fun extractConstant (Lconst cst) = cst | extractConstant _ = raise Not_constant; fun mkDynexn1 exnname arg = Lprim(Pmakeblock (CONtag(0,1)), [exnname, arg]) fun mkDynexn0 exnname = mkDynexn1 exnname (Lconst constUnit) (* ps: TODO perhaps share the code for raising Bind and Match *) val bindExn = mkDynexn0 (Lprim(Pget_global ({qual="General", id=["exn_bind"]}, 0), [])); val matchExn = mkDynexn0 (Lprim(Pget_global ({qual="General", id=["exn_match"]}, 0), [])) val bindRaiser = Lprim(Praise, [bindExn]); val matchRaiser = Lprim(Praise, [matchExn]); fun partial_fun (loc as Loc(start,stop)) () = (msgIBlock 0; errLocation loc; errPrompt "Warning: pattern matching is not exhaustive"; msgEOL(); msgEOL(); msgEBlock(); matchRaiser); fun partial_let (onTop : bool) (loc as Loc(start,stop)) () = (if not onTop then (msgIBlock 0; errLocation loc; errPrompt "Warning: pattern matching is not exhaustive"; msgEOL(); msgEOL(); msgEBlock()) else (); bindRaiser); fun partial_try () = Lprim(Praise, [Lvar 0]); 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 | VIDPATHexp (ref (RESvidpath _))=> true | VIDPATHexp (ref (OVLvidpath _)) => fatalError "isSafe:1" | 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 (ref (UNRESinfixexp e)) => fatalError "isSafe:2" | INFIXexp (ref (RESinfixexp e)) => isSafe e | 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 | STRUCTUREexp (modexp,_,_) => isSafeModExp modexp | FUNCTORexp (modexp,_,_) => isSafeModExp modexp and isSafeModExp (_, (modexp',_)) = case modexp' of DECmodexp _ => false | LONGmodexp _ => true | LETmodexp (dec,modexp) => false | PARmodexp modexp => isSafeModExp modexp | CONmodexp (modexp,sigexp) => isSafeModExp modexp | ABSmodexp (modexp,sigexp) => isSafeModExp modexp | FUNCTORmodexp (_,modid,_, sigexp, modexp) => true | APPmodexp (modexp,modexp') => false | RECmodexp (modid,_,sigexp, modexp) => false ; (* 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 trExConVar (env as (rho, depth)) (ii : IdInfo) (ei:ExConInfo) = let val {exconArity, ...} = !ei val en = translateLongAccess ValId env ii in if exconArity = 0 then mkDynexn0 en else Llet([en], Lfn(mkDynexn1 (Lvar 1) (Lvar 0))) end fun trTopDynExConVar (ei : ExConInfo) (en:Lambda) = let val {exconArity,...} = !ei in if exconArity = 0 then mkDynexn0 en else Llet([en], Lfn(mkDynexn1 (Lvar 1) (Lvar 0))) 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 {info,qualid} = !idKind in (case info of VARik => translateLongAccess ValId env ii | STRik => translateLongAccess ModId env ii | FUNik => translateLongAccess FunId env ii | PRIMik pi => trPrimVar (#primOp pi) | CONik ci => trConVar ci | EXCONik ei => trExConVar env ii ei) end; (* coercion *) fun getGlobal asId {qual,id} = Lprim(Pget_global ({qual=qual,id = [mangle (asId (longIdentAsIdent id "getGlobal"))]},0),[]) ; fun coerceVarEnv S VE' = let val lookupVEofS = lookupVEofStr S in foldEnv (fn id => fn {info = (_,cs'),...} => fn tr_VE => case cs' of VARname _ => (let val (field,{qualid,info=(_,cs)}) = lookupVEofS id in case cs of VARname _ => if isGlobalName qualid then (Lprim(Pget_global(qualid,0),[]))::tr_VE else (Lprim(Pfield field,[Lvar 0]))::tr_VE | PRIMname pi => (trPrimVar (#primOp pi))::tr_VE | CONname ci => (trConVar ci)::tr_VE | EXNname ei => (let val {exconArity, ...} = !ei val en = if isGlobalName qualid then getGlobal ValId qualid else Lprim(Pfield field,[Lvar 0]) in if exconArity = 0 then mkDynexn0 en else Llet([en], Lfn(mkDynexn1 (Lvar 1) (Lvar 0))) end :: tr_VE) | REFname => fatalError "coerceVarEnv:1" end) | EXNname ei' => let val (field,{qualid,info = (_,cs)}) = lookupVEofS id in case cs of EXNname ei => (let val {exconArity, ...} = !ei in if isGlobalName qualid then getGlobal ValId qualid else Lprim(Pfield field, [Lvar 0]) end :: tr_VE) | _ => fatalError "coerceVarEnv:3" end | _ (* PRIMname pi' | CONname ci' | REFname *) => tr_VE) [] VE' end and coerceFunEnv S FE' tr_VE = let val lookupFEofS = lookupFEofStr S in foldEnv (fn id => fn {info = F',...} => fn tr_FE_VE => let val (field,{qualid,info = F}) = lookupFEofS id val trF = if isGlobalName qualid then getGlobal FunId qualid else Lprim(Pfield field, [Lvar 0]) in (coerceFun trF F F')::tr_FE_VE end) tr_VE FE' end and coerceModEnv S ME' tr_FE_VE = let val lookupMEofS = lookupMEofStr S in foldEnv (fn id => fn {info = RS',...} => fn tr_ME_FE_VE => let val (field,{qualid,info = RS}) = lookupMEofS id val trM = if isGlobalName qualid then getGlobal ModId qualid else Lprim(Pfield field, [Lvar 0]) in (coerceRecStr trM RS RS')::tr_ME_FE_VE end) tr_FE_VE ME' end and coerceStr lam S S' = case S' of STRstr(ME',FE',GE',TE',VE') => let val tr_VE = coerceVarEnv S VE' val tr_FE_VE = coerceFunEnv S FE' tr_VE val tr_ME_FE_VE = coerceModEnv S ME' tr_FE_VE in if isIdentityCoercion S 0 tr_ME_FE_VE then lam else Llet([lam],Lstruct tr_ME_FE_VE) end | _ => fatalError "coerceStr" and isIdentityCoercion S pos (Lprim(Pfield field, [Lvar 0])::lams) = (pos = field) andalso isIdentityCoercion S (pos+1) lams | isIdentityCoercion S pos (_::lams) = false | isIdentityCoercion S pos [] = (sizeOfStr S) = pos and coerceRecStr lam (NONrec S) (NONrec S') = coerceStr lam S S' | coerceRecStr lam RS (RECrec (_,RS')) = coerceRecStr lam RS RS' | coerceRecStr lam (RECrec (_,RS)) RS' = coerceRecStr lam RS RS' and coerceMod lam (STRmod RS) (STRmod RS') = coerceRecStr lam RS RS' | coerceMod lam (FUNmod F) (FUNmod F') = coerceFun lam F F' | coerceMod _ _ _ = fatalError "coerceMod" and coerceFun lam (_,M1,EXISTSexmod(_,M1')) (_,M2,EXISTSexmod(_,M2')) = let val domCoercion = coerceMod (Lvar 0) (normMod M2) (normMod M1) val rngCoercion = coerceMod (Lvar 0) (normMod M1') (normMod M2') in case (domCoercion,rngCoercion) of (Lvar 0, Lvar 0) => lam | (Lvar 0, _) => Llet([lam], Lfn(Llet([Lapply(Lvar 1,[Lvar 0])],rngCoercion))) | (_, Lvar 0) => Llet([lam], Lfn(Llet([domCoercion], Lapply(Lvar 2,[Lvar 0])))) | (_,_) => Llet([lam], Lfn(Llet([domCoercion], Llet([Lapply(Lvar 2,[Lvar 0])], rngCoercion)))) end; fun coerceDecVarEnv (env as (rho,depth)) VE VE' = foldEnv (fn id => fn {info = (_,cs'),...} => fn tr_VE => case cs' of VARname _ => (let val {qualid,info=(_,cs)} = lookupEnv VE id in case cs of VARname _ => if isGlobalName qualid then (Lprim(Pget_global(qualid,0),[]))::tr_VE else (translateLocalAccess ValId env id)::tr_VE | PRIMname pi => (trPrimVar (#primOp pi))::tr_VE | CONname ci => (trConVar ci)::tr_VE | EXNname ei => (let val {exconArity, ...} = !ei val en = if isGlobalName qualid then getGlobal ValId qualid else translateLocalAccess ValId env id in if exconArity = 0 then mkDynexn0 en else Llet([en],Lfn(mkDynexn1 (Lvar 1) (Lvar 0)))