Mercurial > urweb

comparison src/cjr_print.sml @ 324:b91480c9a729

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
More opportunities to use regions and lack of string copying
author Adam Chlipala <adamc@hcoop.net>
date Thu, 11 Sep 2008 13:06:51 -0400
parents 5030e909fbf3
children e457d8972ff1
comparison
equal deleted inserted replaced
323:5030e909fbf3 324:b91480c9a729
391 | PConFfi {mod = m, datatyp, con, ...} => 391 | PConFfi {mod = m, datatyp, con, ...} =>
392 ("uw_" ^ ident m ^ "_" ^ ident datatyp, 392 ("uw_" ^ ident m ^ "_" ^ ident datatyp,
393 "uw_" ^ ident m ^ "_" ^ ident con, 393 "uw_" ^ ident m ^ "_" ^ ident con,
394 "uw_" ^ ident con) 394 "uw_" ^ ident con)
395 395
396 fun p_unsql env (tAll as (t, loc)) e = 396 fun p_unsql wontLeakStrings env (tAll as (t, loc)) e =
397 case t of 397 case t of
398 TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"] 398 TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
399 | TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"] 399 | TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
400 | TFfi ("Basis", "string") => box [string "uw_Basis_strdup(ctx, ", e, string ")"] 400 | TFfi ("Basis", "string") =>
401 if wontLeakStrings then
402 e
403 else
404 box [string "uw_Basis_strdup(ctx, ", e, string ")"]
401 | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] 405 | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
402 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; 406 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
403 Print.eprefaces' [("Type", p_typ env tAll)]; 407 Print.eprefaces' [("Type", p_typ env tAll)];
404 string "ERROR") 408 string "ERROR")
405 409
440 case t of 444 case t of
441 Int => string "sizeof(uw_Basis_int)" 445 Int => string "sizeof(uw_Basis_int)"
442 | Float => string "sizeof(uw_Basis_float)" 446 | Float => string "sizeof(uw_Basis_float)"
443 | String => box [string "strlen(", e, string ")"] 447 | String => box [string "strlen(", e, string ")"]
444 | Bool => string "sizeof(uw_Basis_bool)" 448 | Bool => string "sizeof(uw_Basis_bool)"
449
450 fun notLeaky env allowHeapAllocated =
451 let
452 fun nl (t, _) =
453 case t of
454 TFun _ => false
455 | TRecord n =>
456 let
457 val xts = E.lookupStruct env n
458 in
459 List.all (fn (_, t) => nl t) xts
460 end
461 | TDatatype (dk, _, ref cons) =>
462 (allowHeapAllocated orelse dk = Enum)
463 andalso List.all (fn (_, _, to) => case to of
464 NONE => true
465 | SOME t => nl t) cons
466 | TFfi ("Basis", "string") => false
467 | TFfi _ => true
468 | TOption t => allowHeapAllocated andalso nl t
469 in
470 nl
471 end
445 472
446 fun p_exp' par env (e, loc) = 473 fun p_exp' par env (e, loc) =
447 case e of 474 case e of
448 EPrim p => Prim.p_t_GCC p 475 EPrim p => Prim.p_t_GCC p
449 | ERel n => p_rel env n 476 | ERel n => p_rel env n
709 val tables = ListUtil.mapConcat (fn (x, xts) => 736 val tables = ListUtil.mapConcat (fn (x, xts) =>
710 map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts) 737 map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts)
711 tables 738 tables
712 739
713 val outputs = exps @ tables 740 val outputs = exps @ tables
741
742 val wontLeakStrings = notLeaky env true state
743 val wontLeakAnything = notLeaky env false state
714 in 744 in
715 box [string "(uw_begin_region(ctx), ({", 745 box [string "(uw_begin_region(ctx), ",
746 if wontLeakAnything then
747 string "uw_begin_regio(ctx), "
748 else
749 box [],
750 string "({",
716 newline, 751 newline,
717 string "PGconn *conn = uw_get_db(ctx);", 752 string "PGconn *conn = uw_get_db(ctx);",
718 newline, 753 newline,
719 case prepared of 754 case prepared of
720 NONE => box [string "char *query = ", 755 NONE => box [string "char *query = ",
824 string ".", 859 string ".",
825 string proj, 860 string proj,
826 space, 861 space,
827 string "=", 862 string "=",
828 space, 863 space,
829 p_unsql env t 864 p_unsql wontLeakStrings env t
830 (box [string "PQgetvalue(res, i, ", 865 (box [string "PQgetvalue(res, i, ",
831 string (Int.toString i), 866 string (Int.toString i),
832 string ")"]), 867 string ")"]),
833 string ";", 868 string ";",
834 newline]) outputs, 869 newline]) outputs,
849 string "}", 884 string "}",
850 newline, 885 newline,
851 newline, 886 newline,
852 string "PQclear(res);", 887 string "PQclear(res);",
853 newline, 888 newline,
889 if wontLeakAnything then
890 box [string "uw_end_region(ctx);",
891 newline]
892 else
893 box [],
854 string "acc;", 894 string "acc;",
855 newline, 895 newline,
856 string "}))"] 896 string "}))"]
857 end 897 end
858 898