Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Always unbox single-constructor datatypes #142

Merged
merged 5 commits into from
Nov 4, 2023
Merged

Always unbox single-constructor datatypes #142

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
873f2ef
always unbox single constructor datatypes
melsman Nov 3, 2023
c58df97
untabify
melsman Nov 3, 2023
1a9c46a
merge
melsman Nov 3, 2023
f1ba019
REPL pretty-printing of unboxed singleton datatypes
melsman Nov 3, 2023
a326928
unboxed unary-single constructors
melsman Nov 3, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
232 changes: 116 additions & 116 deletions basis/Real.sml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -100,114 +100,114 @@ structure Real : REAL =

fun fmt spec r =
let fun mlify s = (* Add ".0" if not "e" or "." in s *)
let val stop = size s
fun loop i = (* s[0..i-1] contains no "." or "e" *)
if i = stop then s ^ ".0"
else if sub_unsafe(s,i) = #"." orelse sub_unsafe(s,i) = #"E" then s
else loop (i+1)
in loop 0 end

open StringCvt
(* Below we check that the requested number of decimal digits
* is reasonable; else sml_general_string_of_float may crash. *)
let val stop = size s
fun loop i = (* s[0..i-1] contains no "." or "e" *)
if i = stop then s ^ ".0"
else if sub_unsafe(s,i) = #"." orelse sub_unsafe(s,i) = #"E" then s
else loop (i+1)
in loop 0 end

open StringCvt
(* Below we check that the requested number of decimal digits
* is reasonable; else sml_general_string_of_float may crash. *)
in
case spec of
SCI NONE => to_string_gen "%e" r
| SCI (SOME n) =>
if n < 0 orelse n > 400 then raise Size
else to_string_gen ("%." ^ Int.toString n ^ "e") r
| FIX NONE => to_string_gen "%f" r
| FIX (SOME n) =>
if n < 0 orelse n > 400 then raise Size
else to_string_gen ("%." ^ Int.toString n ^ "f") r
| GEN NONE => toString r
| GEN (SOME n) =>
if n < 1 orelse n > 400 then raise Size
else mlify (to_string_gen ("%." ^ Int.toString n ^ "g") r)
case spec of
SCI NONE => to_string_gen "%e" r
| SCI (SOME n) =>
if n < 0 orelse n > 400 then raise Size
else to_string_gen ("%." ^ Int.toString n ^ "e") r
| FIX NONE => to_string_gen "%f" r
| FIX (SOME n) =>
if n < 0 orelse n > 400 then raise Size
else to_string_gen ("%." ^ Int.toString n ^ "f") r
| GEN NONE => toString r
| GEN (SOME n) =>
if n < 1 orelse n > 400 then raise Size
else mlify (to_string_gen ("%." ^ Int.toString n ^ "g") r)
| EXACT => fmt (SCI (SOME 30)) r
end

fun scan getc source =
let fun decval c = Char.ord c - 48
fun pow10 0 = 1.0
| pow10 n =
if n mod 2 = 0 then
let val x = pow10 (n div 2) in x * x end
else 10.0 * pow10 (n-1)
fun pointsym src =
case getc src of
NONE => (false, src)
| SOME (c, rest) => if c = #"." then (true, rest)
else (false, src)
fun esym src =
case getc src of
NONE => (false, src)
| SOME (c, rest) =>
if c = #"e" orelse c = #"E" then
(true, rest)
else (false, src)
fun scandigs first next final source =
let fun digs state src =
case getc src of
NONE => (SOME (final state), src)
| SOME(c, rest) =>
if Char.isDigit c then
digs (next(state, decval c)) rest
else
(SOME (final state), src)
in
case getc source of
NONE => (NONE, source)
| SOME(c, rest) =>
if Char.isDigit c then digs (first (decval c)) rest
else (NONE, source)
end

fun ident x = x
val getint =
scandigs real (fn (res, cval) => 10.0 * res + real cval) ident
val getfrac =
scandigs (fn cval => (1, real cval))
(fn ((decs, frac), cval) => (decs+1, 10.0*frac+real cval))
(fn (decs, frac) => frac / pow10 decs)
val getexp = scandigs ident (fn (res, cval) => 10 * res + cval) ident

fun sign src =
case getc src of
SOME(#"+", rest) => (true, rest)
| SOME(#"-", rest) => (false, rest)
| SOME(#"~", rest) => (false, rest)
| _ => (true, src )

val src = StringCvt.dropl Char.isSpace getc source
val (manpos, src1) = sign src
val (intg, src2) = getint src1
val (decpt, src3) = pointsym src2
val (frac, src4) = getfrac src3

fun mkres v rest =
SOME(if manpos then v else ~v, rest)

fun expopt manval src =
let val (esym, src1) = esym src
val (exppos, src2) = sign src1
val (expv, rest) = getexp src2
in
case (esym, expv) of
(_, NONE) => mkres manval src
| (true, SOME exp) =>
if exppos then mkres (manval * pow10 exp) rest
else mkres (manval / pow10 exp) rest
| _ => NONE
end
fun pow10 0 = 1.0
| pow10 n =
if n mod 2 = 0 then
let val x = pow10 (n div 2) in x * x end
else 10.0 * pow10 (n-1)
fun pointsym src =
case getc src of
NONE => (false, src)
| SOME (c, rest) => if c = #"." then (true, rest)
else (false, src)
fun esym src =
case getc src of
NONE => (false, src)
| SOME (c, rest) =>
if c = #"e" orelse c = #"E" then
(true, rest)
else (false, src)
fun scandigs first next final source =
let fun digs state src =
case getc src of
NONE => (SOME (final state), src)
| SOME(c, rest) =>
if Char.isDigit c then
digs (next(state, decval c)) rest
else
(SOME (final state), src)
in
case getc source of
NONE => (NONE, source)
| SOME(c, rest) =>
if Char.isDigit c then digs (first (decval c)) rest
else (NONE, source)
end

fun ident x = x
val getint =
scandigs real (fn (res, cval) => 10.0 * res + real cval) ident
val getfrac =
scandigs (fn cval => (1, real cval))
(fn ((decs, frac), cval) => (decs+1, 10.0*frac+real cval))
(fn (decs, frac) => frac / pow10 decs)
val getexp = scandigs ident (fn (res, cval) => 10 * res + cval) ident

fun sign src =
case getc src of
SOME(#"+", rest) => (true, rest)
| SOME(#"-", rest) => (false, rest)
| SOME(#"~", rest) => (false, rest)
| _ => (true, src )

val src = StringCvt.dropl Char.isSpace getc source
val (manpos, src1) = sign src
val (intg, src2) = getint src1
val (decpt, src3) = pointsym src2
val (frac, src4) = getfrac src3

fun mkres v rest =
SOME(if manpos then v else ~v, rest)

fun expopt manval src =
let val (esym, src1) = esym src
val (exppos, src2) = sign src1
val (expv, rest) = getexp src2
in
case (esym, expv) of
(_, NONE) => mkres manval src
| (true, SOME exp) =>
if exppos then mkres (manval * pow10 exp) rest
else mkres (manval / pow10 exp) rest
| _ => NONE
end
in
case (intg, decpt, frac) of
(NONE, true, SOME fval) => expopt fval src4
| (SOME ival, false, SOME _ ) => NONE
| (SOME ival, true, NONE ) => mkres ival src2
| (SOME ival, false, NONE ) => expopt ival src2
| (SOME ival, _ , SOME fval) => expopt (ival+fval) src4
| _ => NONE
case (intg, decpt, frac) of
(NONE, true, SOME fval) => expopt fval src4
| (SOME ival, false, SOME _ ) => NONE
| (SOME ival, true, NONE ) => mkres ival src2
| (SOME ival, false, NONE ) => expopt ival src2
| (SOME ival, _ , SOME fval) => expopt (ival+fval) src4
| _ => NONE
end

fun fromString s = StringCvt.scanString scan s
Expand Down Expand Up @@ -251,12 +251,12 @@ structure Real : REAL =
fun op == (x, y) =
case compareReal (x,y) of
IEEEReal.EQUAL => true
| _ => false
| _ => false

fun op != (x,y) =
case compareReal (x,y) of
IEEEReal.EQUAL => false
| _ => true
| _ => true

fun op ?= (a,b) =
isNan a orelse isNan b orelse op == (a, b)
Expand Down Expand Up @@ -292,20 +292,20 @@ structure Real : REAL =

fun round (x : real) : int =
let (* val _ = print "**R1**\n" *)
val t0 = x+0.5
(* val _ = print "**R2**\n" *)
val floor_t0 = floor t0
(* val _ = print "**R3**\n" *)
fun even x = x mod 2 = 0
(* val _ = print "**R4**\n" *)
val t0 = x+0.5
(* val _ = print "**R2**\n" *)
val floor_t0 = floor t0
(* val _ = print "**R3**\n" *)
fun even x = x mod 2 = 0
(* val _ = print "**R4**\n" *)
in
if real(floor_t0) == t0 (* tie *) then
let (* val _ = print "**R5**\n" *)
val t = floor x
(* val _ = print "**R6**\n" *)
in if even t then t else floor_t0
end
else floor_t0
if real(floor_t0) == t0 (* tie *) then
let (* val _ = print "**R5**\n" *)
val t = floor x
(* val _ = print "**R6**\n" *)
in if even t then t else floor_t0
end
else floor_t0
end

fun toInt (rm:IEEEReal.rounding_mode) (r:real) : int =
Expand Down
5 changes: 5 additions & 0 deletions basis/repl.sml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -445,6 +445,11 @@ fun pretty_exported (i:int) : int =
let val tag : int = prim("unsafe_cast", v)
in (lookEnumTag cs tag, z_strong)
end
else if unboxed andalso length cs = 1 then (* unary & single => unboxed & untagged *)
(case lookUnaryTag cs 0 ts of
SOME (cn,t) =>
(cn ^ par_conarg (pr(d-1,t,v)), z_con1)
| NONE => ("?", z_strong))
else if unboxed then
if ubcon1 v then (* unary *)
let val tag = ubcon_tag v
Expand Down
21 changes: 12 additions & 9 deletions src/Common/TYNAME.sig
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -86,18 +86,21 @@ signature TYNAME =
val tyName_FOREIGNPTR : TyName
val tyName_EXN : TyName

val unboxed : TyName -> bool (* Returns true for type names that are
* implemented unboxed; depends on whether
* tagging of integers is enabled. *)
val setUnboxed : TyName -> unit (* After calling setUnboxed(t), unboxed(t)
* returns true. *)
datatype unboxity = UNBOXED | BOXED | UNBOXED_SINGLE

val tynamesPredefined : TyName list
val unboxity : TyName -> unboxity
val setUnboxity : TyName * unboxity -> unit (* default is BOXED *)
val unboxed : TyName -> bool
(* Returns true for type names that are implemented unboxed;
* depends on whether tagging of integers is enabled. After calling
* setUnboxity(t,UNBOXED) or setUnboxity(t,UNBOXED_SINGLE),
* unboxed(t) returns true. *)

type StringTree = PrettyPrint.StringTree
val layout : TyName -> StringTree
val tynamesPredefined : TyName list

val pu : TyName Pickle.pu
type StringTree = PrettyPrint.StringTree
val layout : TyName -> StringTree
val pu : TyName Pickle.pu

structure Map : MONO_FINMAP where type dom = TyName
structure Set : KIT_MONO_SET where type StringTree = StringTree
Expand Down
Loading
Loading